mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-15 03:25:07 +09:00
Transitive reduction of DAGs in SQL
This commit is contained in:
fr33domlover
parent
c340508385
commit
8c1d4dd6f1
1 changed files with 182 additions and 0 deletions
|
|
@ -81,6 +81,9 @@ module Database.Persist.Local.Sql
|
|||
, rmpath
|
||||
, rpathm
|
||||
, rmpathm
|
||||
-- * Transitive reduction of DAGs
|
||||
, trrSelect
|
||||
, trrApply
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -88,6 +91,7 @@ import Prelude
|
|||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Trans.Reader (ReaderT, ask)
|
||||
import Data.Int (Int64)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Proxy (Proxy)
|
||||
import Data.Text (Text)
|
||||
|
|
@ -1322,3 +1326,181 @@ rmpathm
|
|||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
rmpathm = xmpathm FollowBackward []
|
||||
|
||||
-- | It more-or-less looks like this:
|
||||
--
|
||||
-- > WITH RECURSIVE
|
||||
-- > temp (id, path, cycle) AS (
|
||||
-- > SELECT node.id, ARRAY[node.id], FALSE
|
||||
-- > FROM node
|
||||
-- > UNION ALL
|
||||
-- > SELECT edge.dest,
|
||||
-- > temp.path || edge.dest,
|
||||
-- > edge.dest = ANY(temp.path)
|
||||
-- > FROM edge INNER JOIN temp
|
||||
-- > ON edge.source = temp.id
|
||||
-- > WHERE NOT temp.cycle
|
||||
-- > )
|
||||
-- > SELECT *
|
||||
-- > FROM edge
|
||||
-- >
|
||||
-- > EXCEPT
|
||||
-- >
|
||||
-- > SELECT e.*
|
||||
-- > FROM edge AS pre
|
||||
-- > INNER JOIN temp ON pre.dest = temp.path[1]
|
||||
-- > INNER JOIN edge AS e ON e.source = pre.source AND e.dest = temp.id
|
||||
-- > WHERE NOT temp.cycle
|
||||
trrSelect
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Entity edge]
|
||||
trrSelect proxy = do
|
||||
conn <- ask
|
||||
let tNode = entityDef $ dummyFromFst proxy
|
||||
tEdge = entityDef $ dummyFromSnd proxy
|
||||
fwd = persistFieldDef $ destFieldFromProxy proxy
|
||||
bwd = persistFieldDef $ sourceFieldFromProxy proxy
|
||||
temp = DBName "temp_hierarchy_cte"
|
||||
tid = DBName "id"
|
||||
tpath = DBName "path"
|
||||
tcycle = DBName "cycle"
|
||||
edgeP = DBName "pre"
|
||||
edgeE = DBName "e"
|
||||
dbname = connEscapeName conn
|
||||
ecols = T.intercalate ", " $ entityColumnNames tEdge conn
|
||||
qecols name =
|
||||
T.intercalate ", " $
|
||||
map ((dbname name <>) . ("." <>)) $
|
||||
entityColumnNames tEdge conn
|
||||
t ^* f = dbname t <> "." <> dbname f
|
||||
t <#> s = dbname t <> " INNER JOIN " <> dbname s
|
||||
t <# s = dbname t <> " LEFT OUTER JOIN " <> dbname s
|
||||
|
||||
sqlStep forward backward = mconcat
|
||||
[ "SELECT "
|
||||
, entityDB tEdge ^* fieldDB forward, ", "
|
||||
, temp ^* tpath, " || ", entityDB tEdge ^* fieldDB forward, ", "
|
||||
, entityDB tEdge ^* fieldDB forward, " = ANY(", temp ^* tpath, ")"
|
||||
, " FROM ", entityDB tEdge <#> temp
|
||||
, " ON ", entityDB tEdge ^* fieldDB backward, " = ", temp ^* tid
|
||||
, " WHERE NOT " <> temp ^* tcycle
|
||||
]
|
||||
|
||||
sql = mconcat
|
||||
[ "WITH RECURSIVE "
|
||||
, dbname temp
|
||||
, " ("
|
||||
, T.intercalate "," $ map dbname [tid, tpath, tcycle]
|
||||
, ") AS ( SELECT "
|
||||
, entityDB tNode ^* fieldDB (entityId tNode), ", "
|
||||
, "ARRAY[", entityDB tNode ^* fieldDB (entityId tNode), "], "
|
||||
, "FALSE"
|
||||
, " FROM ", dbname $ entityDB tNode
|
||||
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
||||
, " IN ?"
|
||||
, " UNION ALL "
|
||||
, sqlStep fwd bwd
|
||||
, " )"
|
||||
, " SELECT ", ecols
|
||||
, " FROM ", dbname $ entityDB tEdge
|
||||
, " EXCEPT "
|
||||
, " SELECT ", qecols edgeE
|
||||
, " FROM ", dbname $ entityDB tEdge, " AS ", dbname edgeP
|
||||
, " INNER JOIN ", dbname temp
|
||||
, " ON ", edgeP ^* fieldDB fwd, " = ", temp ^* tpath, "[1]"
|
||||
, " INNER JOIN ", dbname $ entityDB tEdge, " AS ", dbname edgeE
|
||||
, " ON ", edgeE ^* fieldDB bwd, " = ", edgeP ^* fieldDB bwd
|
||||
, " AND ", edgeE ^* fieldDB fwd, " = ", temp ^* tid
|
||||
, " WHERE NOT ", temp ^* tcycle
|
||||
]
|
||||
rawSql sql []
|
||||
|
||||
-- | It more-or-less looks like this:
|
||||
--
|
||||
-- > WITH RECURSIVE
|
||||
-- > temp (id, path, cycle) AS (
|
||||
-- > SELECT node.id, ARRAY[node.id], FALSE
|
||||
-- > FROM node
|
||||
-- > UNION ALL
|
||||
-- > SELECT edge.dest,
|
||||
-- > temp.path || edge.dest,
|
||||
-- > edge.dest = ANY(temp.path)
|
||||
-- > FROM edge INNER JOIN temp
|
||||
-- > ON edge.source = temp.id
|
||||
-- > WHERE NOT temp.cycle
|
||||
-- > )
|
||||
-- > DELETE FROM edge
|
||||
-- > WHERE id IN (
|
||||
-- > SELECT e.id
|
||||
-- > FROM edge AS pre
|
||||
-- > INNER JOIN temp ON pre.dest = temp.path[1]
|
||||
-- > INNER JOIN edge AS e ON e.source = pre.source AND e.dest = temp.id
|
||||
-- > WHERE NOT temp.cycle
|
||||
-- > )
|
||||
trrApply
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Int64
|
||||
trrApply proxy = do
|
||||
conn <- ask
|
||||
let tNode = entityDef $ dummyFromFst proxy
|
||||
tEdge = entityDef $ dummyFromSnd proxy
|
||||
fwd = persistFieldDef $ destFieldFromProxy proxy
|
||||
bwd = persistFieldDef $ sourceFieldFromProxy proxy
|
||||
temp = DBName "temp_hierarchy_cte"
|
||||
tid = DBName "id"
|
||||
tpath = DBName "path"
|
||||
tcycle = DBName "cycle"
|
||||
edgeP = DBName "pre"
|
||||
edgeE = DBName "e"
|
||||
dbname = connEscapeName conn
|
||||
t ^* f = dbname t <> "." <> dbname f
|
||||
t <#> s = dbname t <> " INNER JOIN " <> dbname s
|
||||
t <# s = dbname t <> " LEFT OUTER JOIN " <> dbname s
|
||||
|
||||
sqlStep forward backward = mconcat
|
||||
[ "SELECT "
|
||||
, entityDB tEdge ^* fieldDB forward, ", "
|
||||
, temp ^* tpath, " || ", entityDB tEdge ^* fieldDB forward, ", "
|
||||
, entityDB tEdge ^* fieldDB forward, " = ANY(", temp ^* tpath, ")"
|
||||
, " FROM ", entityDB tEdge <#> temp
|
||||
, " ON ", entityDB tEdge ^* fieldDB backward, " = ", temp ^* tid
|
||||
, " WHERE NOT " <> temp ^* tcycle
|
||||
]
|
||||
|
||||
sql = mconcat
|
||||
[ "WITH RECURSIVE "
|
||||
, dbname temp
|
||||
, " ("
|
||||
, T.intercalate "," $ map dbname [tid, tpath, tcycle]
|
||||
, ") AS ( SELECT "
|
||||
, entityDB tNode ^* fieldDB (entityId tNode), ", "
|
||||
, "ARRAY[", entityDB tNode ^* fieldDB (entityId tNode), "], "
|
||||
, "FALSE"
|
||||
, " FROM ", dbname $ entityDB tNode
|
||||
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
||||
, " IN ?"
|
||||
, " UNION ALL "
|
||||
, sqlStep fwd bwd
|
||||
, " ) DELETE FROM ", dbname $ entityDB tEdge
|
||||
, " WHERE ", entityDB tEdge ^* fieldDB (entityId tEdge), " IN ("
|
||||
, " SELECT ", edgeE ^* fieldDB (entityId tEdge)
|
||||
, " FROM ", dbname $ entityDB tEdge, " AS ", dbname edgeP
|
||||
, " INNER JOIN ", dbname temp
|
||||
, " ON ", edgeP ^* fieldDB fwd, " = ", temp ^* tpath, "[1]"
|
||||
, " INNER JOIN ", dbname $ entityDB tEdge, " AS ", dbname edgeE
|
||||
, " ON ", edgeE ^* fieldDB bwd, " = ", edgeP ^* fieldDB bwd
|
||||
, " AND ", edgeE ^* fieldDB fwd, " = ", temp ^* tid
|
||||
, " WHERE NOT ", temp ^* tcycle
|
||||
, " )"
|
||||
]
|
||||
rawExecuteCount sql []
|
||||
|
|
|
|||
Loading…
Reference in a new issue