PersistEntityGraph is for any graph, PersistEntityHierarchy for DAGs

src/Database/Persist/Local/Class/PersistEntityGraph.hs

@@ -23,5 +23,5 @@ import Prelude
 import Database.Persist
 
 class (PersistEntity n, PersistEntity e) => PersistEntityGraph n e where
-    parentField :: EntityField e (Key n)
+    sourceField :: EntityField e (Key n)
-    childField  :: EntityField e (Key n)
+    destField   :: EntityField e (Key n)

src/Database/Persist/Local/Class/PersistEntityHierarchy.hs

@@ -0,0 +1,52 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Database.Persist.Local.Class.PersistEntityHierarchy
+    ( HierarchyEdgeDirection (..)
+    , PersistEntityHierarchy (..)
+    , defParentField
+    , defChildField
+    )
+where
+
+import Prelude
+
+import Database.Persist
+import Database.Persist.Local.Class.PersistEntityGraph
+
+data HierarchyEdgeDirection n e = TowardsChild | TowardsParent
+
+class PersistEntityGraph n e => PersistEntityHierarchy n e where
+    edgeDirection :: HierarchyEdgeDirection n e
+    parentField   :: EntityField e (Key n)
+    childField    :: EntityField e (Key n)
+
+defParentField
+    :: PersistEntityGraph n e
+    => HierarchyEdgeDirection n e
+    -> EntityField e (Key n)
+defParentField dir =
+    case dir of
+        TowardsChild  -> sourceField
+        TowardsParent -> destField
+
+defChildField
+    :: PersistEntityGraph n e
+    => HierarchyEdgeDirection n e
+    -> EntityField e (Key n)
+defChildField dir =
+    case dir of
+        TowardsChild  -> destField
+        TowardsParent -> sourceField

src/Database/Persist/Local/Sql.hs

@@ -49,17 +49,17 @@ dummyFromFst _ = Nothing
 dummyFromSnd :: Proxy (a, b) -> Maybe b
 dummyFromSnd _ = Nothing
 
-childFieldFromProxy
+destFieldFromProxy
     :: PersistEntityGraph node edge
     => Proxy (node, edge)
     -> EntityField edge (Key node)
-childFieldFromProxy _ = childField
+destFieldFromProxy _ = destField
 
-parentFieldFromProxy
+sourceFieldFromProxy
     :: PersistEntityGraph node edge
     => Proxy (node, edge)
     -> EntityField edge (Key node)
-parentFieldFromProxy _ = parentField
+sourceFieldFromProxy _ = sourceField
 
 rawSqlWithGraph
     :: ( RawSql a
@@ -139,8 +139,8 @@ containsCycle' proxy = do
     conn <- ask
     let tNode = entityDef $ dummyFromFst proxy
         tEdge = entityDef $ dummyFromSnd proxy
-        fwd = childFieldFromProxy proxy
+        fwd = destFieldFromProxy proxy
-        bwd = parentFieldFromProxy proxy
+        bwd = sourceFieldFromProxy proxy
         start = DBName "temp_start_cte"
         temp = DBName "temp_hierarchy_cte"
         tid = DBName "id"

vervis.cabal

@@ -69,6 +69,7 @@ library
                        Database.Persist.Class.Local
                        Database.Persist.Sql.Local
                        Database.Persist.Local.Class.PersistEntityGraph
+                       Database.Persist.Local.Class.PersistEntityHierarchy
                        Database.Persist.Local.Class.PersistQueryForest
                        Database.Persist.Local.RecursionDoc
                        Database.Persist.Local.Sql