PersistQueryRecursive becomes PersistQueryForest
This commit is contained in:
fr33domlover
parent
76a627385c
commit
48d7c9e929
4 changed files with 341 additions and 279 deletions
184
src/Database/Persist/Local/Class/PersistQueryForest.hs
Normal file
184
src/Database/Persist/Local/Class/PersistQueryForest.hs
Normal file
|
|
@ -0,0 +1,184 @@
|
||||||
|
{- 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.PersistQueryForest
|
||||||
|
( RecursionDirection (..)
|
||||||
|
, PersistQueryForest (..)
|
||||||
|
, selectForestSource
|
||||||
|
, selectForestKeys
|
||||||
|
, selectForestList
|
||||||
|
, selectForestKeysList
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.Reader (MonadReader)
|
||||||
|
import Control.Monad.Trans.Reader (ReaderT)
|
||||||
|
import Control.Monad.Trans.Resource (MonadResource, release)
|
||||||
|
import Data.Acquire (Acquire, allocateAcquire, with)
|
||||||
|
import Database.Persist.Class
|
||||||
|
import Database.Persist.Types
|
||||||
|
|
||||||
|
import qualified Data.Conduit as C
|
||||||
|
import qualified Data.Conduit.List as CL
|
||||||
|
|
||||||
|
data RecursionDirection
|
||||||
|
= Ancestors
|
||||||
|
| Decendants
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- | Backends supporting conditional operations recursively over trees.
|
||||||
|
class PersistQuery backend => PersistQueryForest backend where
|
||||||
|
-- | Update individual fields on any record in the transitive closure and
|
||||||
|
-- matching the given criterion.
|
||||||
|
updateForestWhere
|
||||||
|
:: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> [Update val]
|
||||||
|
-> ReaderT backend m ()
|
||||||
|
|
||||||
|
-- | Delete all records in the transitive closure which match the given
|
||||||
|
-- criterion.
|
||||||
|
deleteForestWhere
|
||||||
|
:: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> ReaderT backend m ()
|
||||||
|
|
||||||
|
-- | Get all records in the transitive closure, which match the given
|
||||||
|
-- criterion, in the specified order. Returns also the identifiers.
|
||||||
|
selectForestSourceRes
|
||||||
|
:: ( PersistEntity val
|
||||||
|
, PersistEntityBackend val ~ backend
|
||||||
|
, MonadIO m1
|
||||||
|
, MonadIO m2
|
||||||
|
)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> [SelectOpt val]
|
||||||
|
-> ReaderT backend m1 (Acquire (C.Source m2 (Entity val)))
|
||||||
|
|
||||||
|
-- | Get the 'Key's of all records in the transitive closure, which match
|
||||||
|
-- the given criterion.
|
||||||
|
selectForestKeysRes
|
||||||
|
:: ( PersistEntity val
|
||||||
|
, PersistEntityBackend val ~ backend
|
||||||
|
, MonadIO m1
|
||||||
|
, MonadIO m2
|
||||||
|
)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> [SelectOpt val]
|
||||||
|
-> ReaderT backend m1 (Acquire (C.Source m2 (Key val)))
|
||||||
|
|
||||||
|
-- | The total number of records in the transitive closure which fulfill
|
||||||
|
-- the given criterion.
|
||||||
|
countForest
|
||||||
|
:: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> ReaderT backend m Int
|
||||||
|
|
||||||
|
-- | Get all records in the transitive closure, which match the given
|
||||||
|
-- criterion, in the specified order. Returns also the identifiers.
|
||||||
|
selectForestSource
|
||||||
|
:: ( PersistQueryForest backend
|
||||||
|
, MonadResource m
|
||||||
|
, PersistEntity val
|
||||||
|
, PersistEntityBackend val ~ backend
|
||||||
|
, MonadReader env m
|
||||||
|
, HasPersistBackend env backend
|
||||||
|
)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> [SelectOpt val]
|
||||||
|
-> C.Source m (Entity val)
|
||||||
|
selectForestSource dir field root filts opts = do
|
||||||
|
srcRes <-
|
||||||
|
liftPersist $ selectForestSourceRes dir field root filts opts
|
||||||
|
(releaseKey, src) <- allocateAcquire srcRes
|
||||||
|
src
|
||||||
|
release releaseKey
|
||||||
|
|
||||||
|
-- | Get the 'Key's of all records in the transitive closure, which match the
|
||||||
|
-- given criterion.
|
||||||
|
selectForestKeys
|
||||||
|
:: ( PersistQueryForest backend
|
||||||
|
, MonadResource m
|
||||||
|
, PersistEntity val
|
||||||
|
, backend ~ PersistEntityBackend val
|
||||||
|
, MonadReader env m
|
||||||
|
, HasPersistBackend env backend
|
||||||
|
)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> [SelectOpt val]
|
||||||
|
-> C.Source m (Key val)
|
||||||
|
selectForestKeys dir field root filts opts = do
|
||||||
|
srcRes <- liftPersist $ selectForestKeysRes dir field root filts opts
|
||||||
|
(releaseKey, src) <- allocateAcquire srcRes
|
||||||
|
src
|
||||||
|
release releaseKey
|
||||||
|
|
||||||
|
-- | Call 'selectForestSource' but return the result as a list.
|
||||||
|
selectForestList
|
||||||
|
:: ( PersistQueryForest backend
|
||||||
|
, MonadIO m
|
||||||
|
, PersistEntity val
|
||||||
|
, PersistEntityBackend val ~ backend
|
||||||
|
)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> [SelectOpt val]
|
||||||
|
-> ReaderT backend m [Entity val]
|
||||||
|
selectForestList dir field root filts opts = do
|
||||||
|
srcRes <- selectForestSourceRes dir field root filts opts
|
||||||
|
liftIO $ with srcRes (C.$$ CL.consume)
|
||||||
|
|
||||||
|
-- | Call 'selectForestKeys' but return the result as a list.
|
||||||
|
selectForestKeysList
|
||||||
|
:: ( PersistQueryForest backend
|
||||||
|
, MonadIO m
|
||||||
|
, PersistEntity val
|
||||||
|
, PersistEntityBackend val ~ backend
|
||||||
|
)
|
||||||
|
=> RecursionDirection
|
||||||
|
-> EntityField val (Maybe (Key val))
|
||||||
|
-> Key val
|
||||||
|
-> [Filter val]
|
||||||
|
-> [SelectOpt val]
|
||||||
|
-> ReaderT backend m [Key val]
|
||||||
|
selectForestKeysList dir field root filts opts = do
|
||||||
|
srcRes <- selectForestKeysRes dir field root filts opts
|
||||||
|
liftIO $ with srcRes (C.$$ CL.consume)
|
||||||
|
|
@ -1,255 +0,0 @@
|
||||||
{- 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/>.
|
|
||||||
-}
|
|
||||||
|
|
||||||
{- The code is based on PersistQuery. Actually, most of the difference is
|
|
||||||
- slightly different names and 3 additional function parameters.
|
|
||||||
-}
|
|
||||||
|
|
||||||
-- | Recursive queries are performed by taking the output of a recursion step,
|
|
||||||
-- possibly modifying it, and using the result as the input for the next
|
|
||||||
-- recursion step.
|
|
||||||
--
|
|
||||||
-- This module currently provides a single way to perform that recursive step:
|
|
||||||
-- Match between the /id/ column and some other column which has the same type.
|
|
||||||
--
|
|
||||||
-- For example, suppose we have a `Message` type with a `messageParent` field.
|
|
||||||
-- For given messages `a` and `b`, if `messageParent b == Just a` then `b` is a
|
|
||||||
-- reply to `a`. Therefore, all the replies to a given message point to it
|
|
||||||
-- using the `messageParent` field. And there can be replies to replies and so
|
|
||||||
-- on, creating a tree of messages.
|
|
||||||
--
|
|
||||||
-- > Message
|
|
||||||
-- > author PersonId
|
|
||||||
-- > content Text
|
|
||||||
-- > parent MessageId Maybe
|
|
||||||
--
|
|
||||||
-- If we start with a single message and follow the `messageParent` values
|
|
||||||
-- recursively, we'll be able to get a list (or a tree) of the __ancestors__ of
|
|
||||||
-- the message. Our message /a/ may be a reply to some other message /b/, and
|
|
||||||
-- /b/ may be a reply to message /c/ and so on. Eventually, if there are no
|
|
||||||
-- cycles and it's really a tree structure, we'll reach the root message, which
|
|
||||||
-- has no parent.
|
|
||||||
--
|
|
||||||
-- But there's another way to recurse. What if we wanted to find the replies
|
|
||||||
-- for a given message? And the replies of the replies, and so on? In other
|
|
||||||
-- words, the __decendants__ of a given message. Suppose we start with a
|
|
||||||
-- message /a/. We get a list of the replies of /a/, i.e. message whose parent
|
|
||||||
-- is `Just a`. Then we find the replies of those messages, i.e. the replies of
|
|
||||||
-- the replies of /a/. And so on, recursively, until we can't find more replies
|
|
||||||
-- and then we stop.
|
|
||||||
--
|
|
||||||
-- Therefore we can perform the recursion in one of two directions:
|
|
||||||
--
|
|
||||||
-- - __Outwards__, i.e. follow from a message to its parents. More generally,
|
|
||||||
-- given a persistent entity type `Foobar`, follow recursively using a
|
|
||||||
-- specific field of it, whose type is `FoobarId`. It's called "outwards"
|
|
||||||
-- because it's like following out-edges of a graph node, i.e. arrows
|
|
||||||
-- pointing from a node towards other nodes.
|
|
||||||
-- - __Inwards__, i.e. find the children (i.e. replies) of a message, and then
|
|
||||||
-- their children, and so on. More generally, given a persistent entity type
|
|
||||||
-- `Foobar`, find other values referring to it using a specific field, whose
|
|
||||||
-- type is `FoobarId`, and recursive find such values for the results we get
|
|
||||||
-- and so on. It's called "inwards" because it's like following in-edges of a
|
|
||||||
-- graph node, i.e. arrows pointing from other nodes towards that node.
|
|
||||||
--
|
|
||||||
-- The 'RecursionDirection' type is used for specifying the direction.
|
|
||||||
--
|
|
||||||
-- When you follow all the children of an entity recursively, or all of its
|
|
||||||
-- parents, we call the result you get the __transitive closure__ of the
|
|
||||||
-- specific field you used. You can further specify the direction, i.e.
|
|
||||||
-- __outward transitive closure__ or __inward transitive closure__. For
|
|
||||||
-- examples, if you follow a message's parents recursively as in the example
|
|
||||||
-- above, you get an outward transitive closure on the /parent/ field.
|
|
||||||
--
|
|
||||||
-- Note that the definition used here is __not__ the same as the mathematical
|
|
||||||
-- definition. When you perform a recursive query without filters, you get not
|
|
||||||
-- only the ancestors (or the decendants) of an entity, but also the root
|
|
||||||
-- entity itself. In other words, even though a message is not a reply of
|
|
||||||
-- itself, you'll still get it in the query result. If you want to get just the
|
|
||||||
-- ancestors (or decendants), i.e. the actual transitive closer of the "is
|
|
||||||
-- reply of" relation in the mathematical sense, use a filter to omit the root
|
|
||||||
-- message based on the ID, i.e. @[MessageParent /= msgid]@.
|
|
||||||
--
|
|
||||||
-- Therefore, when the term "transitive closure" is used below, it means not
|
|
||||||
-- just the ancestors (or decendants), but also the origin entity too.
|
|
||||||
module Database.Persist.Local.Class.PersistQueryRecursive
|
|
||||||
( RecursionDirection (..)
|
|
||||||
, PersistQueryRecursive (..)
|
|
||||||
, selectRecursivelySource
|
|
||||||
, selectRecursivelyKeys
|
|
||||||
, selectRecursivelyList
|
|
||||||
, selectRecursivelyKeysList
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Reader (MonadReader)
|
|
||||||
import Control.Monad.Trans.Reader (ReaderT)
|
|
||||||
import Control.Monad.Trans.Resource (MonadResource, release)
|
|
||||||
import Data.Acquire (Acquire, allocateAcquire, with)
|
|
||||||
import Database.Persist.Class
|
|
||||||
import Database.Persist.Types
|
|
||||||
|
|
||||||
import qualified Data.Conduit as C
|
|
||||||
import qualified Data.Conduit.List as CL
|
|
||||||
|
|
||||||
data RecursionDirection
|
|
||||||
= RecOut
|
|
||||||
| RecIn
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Backends supporting recursive conditional operations.
|
|
||||||
class PersistQuery backend => PersistQueryRecursive backend where
|
|
||||||
-- | Update individual fields on any record in the transitive closure and
|
|
||||||
-- matching the given criterion.
|
|
||||||
updateRecursivelyWhere
|
|
||||||
:: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [Update val]
|
|
||||||
-> ReaderT backend m ()
|
|
||||||
|
|
||||||
-- | Delete all records in the transitive closure which match the given
|
|
||||||
-- criterion.
|
|
||||||
deleteRecursivelyWhere
|
|
||||||
:: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> ReaderT backend m ()
|
|
||||||
|
|
||||||
-- | Get all records in the transitive closure, which match the given
|
|
||||||
-- criterion, in the specified order. Returns also the identifiers.
|
|
||||||
selectRecursivelySourceRes
|
|
||||||
:: ( PersistEntity val
|
|
||||||
, PersistEntityBackend val ~ backend
|
|
||||||
, MonadIO m1
|
|
||||||
, MonadIO m2
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> ReaderT backend m1 (Acquire (C.Source m2 (Entity val)))
|
|
||||||
|
|
||||||
-- | Get the 'Key's of all records in the transitive closure, which match
|
|
||||||
-- the given criterion.
|
|
||||||
selectRecursivelyKeysRes
|
|
||||||
:: ( PersistEntity val
|
|
||||||
, PersistEntityBackend val ~ backend
|
|
||||||
, MonadIO m1
|
|
||||||
, MonadIO m2
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> ReaderT backend m1 (Acquire (C.Source m2 (Key val)))
|
|
||||||
|
|
||||||
-- | The total number of records in the transitive closure which fulfill
|
|
||||||
-- the given criterion.
|
|
||||||
countRecursively
|
|
||||||
:: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> ReaderT backend m Int
|
|
||||||
|
|
||||||
-- | Get all records in the transitive closure, which match the given
|
|
||||||
-- criterion, in the specified order. Returns also the identifiers.
|
|
||||||
selectRecursivelySource
|
|
||||||
:: ( PersistQueryRecursive backend
|
|
||||||
, MonadResource m
|
|
||||||
, PersistEntity val
|
|
||||||
, PersistEntityBackend val ~ backend
|
|
||||||
, MonadReader env m
|
|
||||||
, HasPersistBackend env backend
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> C.Source m (Entity val)
|
|
||||||
selectRecursivelySource dir field root filts opts = do
|
|
||||||
srcRes <-
|
|
||||||
liftPersist $ selectRecursivelySourceRes dir field root filts opts
|
|
||||||
(releaseKey, src) <- allocateAcquire srcRes
|
|
||||||
src
|
|
||||||
release releaseKey
|
|
||||||
|
|
||||||
-- | Get the 'Key's of all records in the transitive closure, which match the
|
|
||||||
-- given criterion.
|
|
||||||
selectRecursivelyKeys
|
|
||||||
:: ( PersistQueryRecursive backend
|
|
||||||
, MonadResource m
|
|
||||||
, PersistEntity val
|
|
||||||
, backend ~ PersistEntityBackend val
|
|
||||||
, MonadReader env m
|
|
||||||
, HasPersistBackend env backend
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> C.Source m (Key val)
|
|
||||||
selectRecursivelyKeys dir field root filts opts = do
|
|
||||||
srcRes <- liftPersist $ selectRecursivelyKeysRes dir field root filts opts
|
|
||||||
(releaseKey, src) <- allocateAcquire srcRes
|
|
||||||
src
|
|
||||||
release releaseKey
|
|
||||||
|
|
||||||
-- | Call 'selectRecursivelySource' but return the result as a list.
|
|
||||||
selectRecursivelyList
|
|
||||||
:: ( PersistQueryRecursive backend
|
|
||||||
, MonadIO m
|
|
||||||
, PersistEntity val
|
|
||||||
, PersistEntityBackend val ~ backend
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> ReaderT backend m [Entity val]
|
|
||||||
selectRecursivelyList dir field root filts opts = do
|
|
||||||
srcRes <- selectRecursivelySourceRes dir field root filts opts
|
|
||||||
liftIO $ with srcRes (C.$$ CL.consume)
|
|
||||||
|
|
||||||
-- | Call 'selectRecursivelyKeys' but return the result as a list.
|
|
||||||
selectRecursivelyKeysList
|
|
||||||
:: ( PersistQueryRecursive backend
|
|
||||||
, MonadIO m
|
|
||||||
, PersistEntity val
|
|
||||||
, PersistEntityBackend val ~ backend
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> ReaderT backend m [Key val]
|
|
||||||
selectRecursivelyKeysList dir field root filts opts = do
|
|
||||||
srcRes <- selectRecursivelyKeysRes dir field root filts opts
|
|
||||||
liftIO $ with srcRes (C.$$ CL.consume)
|
|
||||||
133
src/Database/Persist/Local/RecursionDoc.hs
Normal file
133
src/Database/Persist/Local/RecursionDoc.hs
Normal file
|
|
@ -0,0 +1,133 @@
|
||||||
|
{- 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/>.
|
||||||
|
-}
|
||||||
|
|
||||||
|
-- |
|
||||||
|
-- = Intro
|
||||||
|
--
|
||||||
|
-- Recursive queries are performed by taking the output of a recursion step,
|
||||||
|
-- possibly modifying it, and using the result as the input for the next
|
||||||
|
-- recursion step. Like /persistent/ itself, the API provided here is a
|
||||||
|
-- high-level, safe subset, and you can use 'rawSql' etc. for the less common
|
||||||
|
-- cases or backend-specific features not covered by it. Instead of talking
|
||||||
|
-- about recursion concepts, the API uses terms like /tree/ and /graph/.
|
||||||
|
--
|
||||||
|
-- This module supports two ways to represent hierarchy using persistent
|
||||||
|
-- records:
|
||||||
|
--
|
||||||
|
-- 1. Forest (i.e. one or more trees)
|
||||||
|
-- 2. Graph
|
||||||
|
--
|
||||||
|
-- If your hierarchy supports up to one parent per node, you'll probably take
|
||||||
|
-- the forest approach. If multiple parents per node are supported, you'll
|
||||||
|
-- probably take the graph approach. Note that this API is still new and
|
||||||
|
-- experimental, and is based on experience working only with SQL. Suggestions
|
||||||
|
-- and use cases are very welcome.
|
||||||
|
--
|
||||||
|
-- = Forest
|
||||||
|
--
|
||||||
|
-- In the forest model, the recursive step is done by matching between the /id/
|
||||||
|
-- column of a certain entity and some other column. The idea is that you have
|
||||||
|
-- an entity @Ent@ with a field of type @Maybe (Key Ent)@. Through that field,
|
||||||
|
-- a node points to its parent node. Nodes without a parent are called root
|
||||||
|
-- nodes. If there's a single such root node, you get a tree structure. Is
|
||||||
|
-- there are multiple root nodes, there are multiple trees, i.e. a forest.
|
||||||
|
--
|
||||||
|
-- For example, suppose we have a `Message` type with a `messageParent` field.
|
||||||
|
-- For given messages `a` and `b`, if `messageParent b == Just a` then `b` is a
|
||||||
|
-- reply to `a`. Therefore, all the replies to a given message point to it
|
||||||
|
-- using the `messageParent` field. And there can be replies to replies and so
|
||||||
|
-- on, creating a tree of messages.
|
||||||
|
--
|
||||||
|
-- > Message
|
||||||
|
-- > author PersonId
|
||||||
|
-- > content Text
|
||||||
|
-- > parent MessageId Maybe
|
||||||
|
--
|
||||||
|
-- If we start with a single message and follow the `messageParent` values
|
||||||
|
-- recursively, we'll be able to get a list (or a tree) of the __ancestors__ of
|
||||||
|
-- the message. Our message /a/ may be a reply to some other message /b/, and
|
||||||
|
-- /b/ may be a reply to message /c/ and so on. Eventually, if there are no
|
||||||
|
-- cycles and it's really a tree structure, we'll reach the root message, which
|
||||||
|
-- has no parent.
|
||||||
|
--
|
||||||
|
-- But there's another way to recurse. What if we wanted to find the replies
|
||||||
|
-- for a given message? And the replies of the replies, and so on? In other
|
||||||
|
-- words, the __decendants__ of a given message. Suppose we start with a
|
||||||
|
-- message /a/. We get a list of the replies of /a/, i.e. message whose parent
|
||||||
|
-- is `Just a`. Then we find the replies of those messages, i.e. the replies of
|
||||||
|
-- the replies of /a/. And so on, recursively, until we can't find more replies
|
||||||
|
-- and then we stop.
|
||||||
|
--
|
||||||
|
-- Therefore we can perform the recursion in one of two directions:
|
||||||
|
--
|
||||||
|
-- - __Towards the root nodes__, i.e. follow from a message to its parents.
|
||||||
|
-- More generally, given a persistent entity type `Foobar`, follow
|
||||||
|
-- recursively using a specific field of it, whose type is `FoobarId`.
|
||||||
|
-- - __Towards leaf nodes__, i.e. find the children (i.e. replies) of a
|
||||||
|
-- message, and then their children, and so on. More generally, given a
|
||||||
|
-- persistent entity type `Foobar`, find other values referring to it using a
|
||||||
|
-- specific field, whose type is `Maybe FoobarId`, and recursively find such
|
||||||
|
-- values for the results we get and so on.
|
||||||
|
--
|
||||||
|
-- The 'RecursionDirection' type is used for specifying the direction.
|
||||||
|
--
|
||||||
|
-- When you follow all the children of an entity recursively, or all of its
|
||||||
|
-- parents, we call the result you get the __transitive closure__ of the
|
||||||
|
-- specific field you used. You can further specify the direction, i.e.
|
||||||
|
-- __outward transitive closure__ or __inward transitive closure__. For
|
||||||
|
-- examples, if you follow a message's parents recursively as in the example
|
||||||
|
-- above, you get an outward transitive closure on the /parent/ field.
|
||||||
|
--
|
||||||
|
-- Note that the definition used here is __not__ the same as the mathematical
|
||||||
|
-- definition. When you perform a recursive query without filters, you get not
|
||||||
|
-- only the ancestors (or the decendants) of an entity, but also the root
|
||||||
|
-- entity itself. In other words, even though a message is not a reply of
|
||||||
|
-- itself, you'll still get it in the query result. If you want to get just the
|
||||||
|
-- ancestors (or decendants), i.e. the actual transitive closer of the "is
|
||||||
|
-- reply of" relation in the mathematical sense, use a filter to omit the root
|
||||||
|
-- message based on the ID, i.e. @[MessageParent /= msgid]@.
|
||||||
|
--
|
||||||
|
-- Therefore, when the term "transitive closure" is used below, it means not
|
||||||
|
-- just the ancestors (or decendants), but also the origin entity too.
|
||||||
|
--
|
||||||
|
-- = Graph
|
||||||
|
--
|
||||||
|
-- Sometimes a tree isn't enough. One common structure for hierarchies which
|
||||||
|
-- isn't a tree is the DAG, Directed Acyclic Graph. A DAG is a graph which has
|
||||||
|
-- no cycles. It allows a node to have an arbitrary number of parents, as long
|
||||||
|
-- as a parent can't be a child of its own child, or more generally, a node
|
||||||
|
-- can't be an ancestor of its ancestors.
|
||||||
|
--
|
||||||
|
-- For example, suppose you'd like to create an application that manages data
|
||||||
|
-- about human languages. For each language you'd like to specify, from which
|
||||||
|
-- older languages it developed. Some languages are simply decendants of older
|
||||||
|
-- versions of themselves, but other languages are a mix of several older
|
||||||
|
-- languages, or have a variety of influences.
|
||||||
|
--
|
||||||
|
-- In this case, each language may have multiple parents (and a language can't
|
||||||
|
-- be an ancestor of itself). We need something more general than a tree.
|
||||||
|
--
|
||||||
|
-- There are probably various ways to represent such a graph in the various
|
||||||
|
-- backends. This module provides a single way to do that, which is hopefully
|
||||||
|
-- safe and works well on different kinds of backends. The idea is that you
|
||||||
|
-- have two separate tables: One for the entities and another one for the
|
||||||
|
-- parent-child relations between them. For example, we can have a @Language@
|
||||||
|
-- entity, and a @LanguageOrigin@ entity with two fields, @parent@ and @child@,
|
||||||
|
-- both of type @LanguageId@.
|
||||||
|
--
|
||||||
|
-- Before you can use the graph approach you should define an instance of the
|
||||||
|
-- 'PersistEntityGraph' class. That class creates a relation between the two
|
||||||
|
-- entities (@Language@ and @LanguageOrigin@ in the example).
|
||||||
|
module Database.Persist.Local.RecursionDoc () where
|
||||||
|
|
@ -13,9 +13,9 @@
|
||||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Database.Persist.Local.Sql.Orphan.PersistQueryRecursive
|
module Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
||||||
( deleteRecursivelyWhereCount
|
( deleteForestWhereCount
|
||||||
, updateRecursivelyWhereCount
|
, updateForestWhereCount
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -39,17 +39,17 @@ import Database.Persist.Sql.Util
|
||||||
import qualified Data.Conduit.List as CL (head, mapM)
|
import qualified Data.Conduit.List as CL (head, mapM)
|
||||||
import qualified Data.Text as T (pack, unpack, intercalate)
|
import qualified Data.Text as T (pack, unpack, intercalate)
|
||||||
|
|
||||||
import Database.Persist.Local.Class.PersistQueryRecursive
|
import Database.Persist.Local.Class.PersistQueryForest
|
||||||
import Database.Persist.Local.Sql.Orphan.Common
|
import Database.Persist.Local.Sql.Orphan.Common
|
||||||
|
|
||||||
instance PersistQueryRecursive SqlBackend where
|
instance PersistQueryForest SqlBackend where
|
||||||
updateRecursivelyWhere dir field root filts upds =
|
updateForestWhere dir field root filts upds =
|
||||||
void $ updateRecursivelyWhereCount dir field root filts upds
|
void $ updateForestWhereCount dir field root filts upds
|
||||||
|
|
||||||
deleteRecursivelyWhere dir field root filts =
|
deleteForestWhere dir field root filts =
|
||||||
void $ deleteRecursivelyWhereCount dir field root filts
|
void $ deleteForestWhereCount dir field root filts
|
||||||
|
|
||||||
selectRecursivelySourceRes dir field root filts opts = do
|
selectForestSourceRes dir field root filts opts = do
|
||||||
conn <- ask
|
conn <- ask
|
||||||
let (sql, vals, parse) = sqlValsParse conn
|
let (sql, vals, parse) = sqlValsParse conn
|
||||||
srcRes <- rawQueryRes sql vals
|
srcRes <- rawQueryRes sql vals
|
||||||
|
|
@ -88,7 +88,7 @@ instance PersistQueryRecursive SqlBackend where
|
||||||
]
|
]
|
||||||
vals = getFiltsValues conn $ isRoot : filts
|
vals = getFiltsValues conn $ isRoot : filts
|
||||||
|
|
||||||
selectRecursivelyKeysRes dir field root filts opts = do
|
selectForestKeysRes dir field root filts opts = do
|
||||||
conn <- ask
|
conn <- ask
|
||||||
let (sql, vals, parse) = sqlValsParse conn
|
let (sql, vals, parse) = sqlValsParse conn
|
||||||
srcRes <- rawQueryRes sql vals
|
srcRes <- rawQueryRes sql vals
|
||||||
|
|
@ -151,7 +151,7 @@ instance PersistQueryRecursive SqlBackend where
|
||||||
]
|
]
|
||||||
vals = getFiltsValues conn $ isRoot : filts
|
vals = getFiltsValues conn $ isRoot : filts
|
||||||
|
|
||||||
countRecursively dir field root filts = do
|
countForest dir field root filts = do
|
||||||
conn <- ask
|
conn <- ask
|
||||||
let (sql, vals) = sqlAndVals conn
|
let (sql, vals) = sqlAndVals conn
|
||||||
withRawQuery sql vals $ do
|
withRawQuery sql vals $ do
|
||||||
|
|
@ -183,15 +183,15 @@ instance PersistQueryRecursive SqlBackend where
|
||||||
]
|
]
|
||||||
vals = getFiltsValues conn $ isRoot : filts
|
vals = getFiltsValues conn $ isRoot : filts
|
||||||
|
|
||||||
-- | Same as 'deleteRecursivelyWhere', but returns the number of rows affected.
|
-- | Same as 'deleteForestWhere', but returns the number of rows affected.
|
||||||
deleteRecursivelyWhereCount
|
deleteForestWhereCount
|
||||||
:: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend)
|
:: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend)
|
||||||
=> RecursionDirection
|
=> RecursionDirection
|
||||||
-> EntityField val (Maybe (Key val))
|
-> EntityField val (Maybe (Key val))
|
||||||
-> Key val
|
-> Key val
|
||||||
-> [Filter val]
|
-> [Filter val]
|
||||||
-> ReaderT SqlBackend m Int64
|
-> ReaderT SqlBackend m Int64
|
||||||
deleteRecursivelyWhereCount dir field root filts = do
|
deleteForestWhereCount dir field root filts = do
|
||||||
conn <- ask
|
conn <- ask
|
||||||
let (sql, vals) = sqlAndVals conn
|
let (sql, vals) = sqlAndVals conn
|
||||||
rawExecuteCount sql vals
|
rawExecuteCount sql vals
|
||||||
|
|
@ -221,8 +221,8 @@ deleteRecursivelyWhereCount dir field root filts = do
|
||||||
]
|
]
|
||||||
vals = getFiltsValues conn $ isRoot : filts
|
vals = getFiltsValues conn $ isRoot : filts
|
||||||
|
|
||||||
-- | Same as 'updateRecursivelyWhere', but returns the number of rows affected.
|
-- | Same as 'updateForestWhere', but returns the number of rows affected.
|
||||||
updateRecursivelyWhereCount
|
updateForestWhereCount
|
||||||
:: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val)
|
:: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val)
|
||||||
=> RecursionDirection
|
=> RecursionDirection
|
||||||
-> EntityField val (Maybe (Key val))
|
-> EntityField val (Maybe (Key val))
|
||||||
|
|
@ -230,8 +230,8 @@ updateRecursivelyWhereCount
|
||||||
-> [Filter val]
|
-> [Filter val]
|
||||||
-> [Update val]
|
-> [Update val]
|
||||||
-> ReaderT SqlBackend m Int64
|
-> ReaderT SqlBackend m Int64
|
||||||
updateRecursivelyWhereCount _ _ _ _ [] = return 0
|
updateForestWhereCount _ _ _ _ [] = return 0
|
||||||
updateRecursivelyWhereCount dir field root filts upds = do
|
updateForestWhereCount dir field root filts upds = do
|
||||||
conn <- ask
|
conn <- ask
|
||||||
let (sql, vals) = sqlAndVals conn
|
let (sql, vals) = sqlAndVals conn
|
||||||
rawExecuteCount sql vals
|
rawExecuteCount sql vals
|
||||||
|
|
@ -311,7 +311,7 @@ withRecursive dir field root conn t getcols =
|
||||||
--, connEscapeName conn $ fieldDB $ entityId t
|
--, connEscapeName conn $ fieldDB $ entityId t
|
||||||
--, " = ?"
|
--, " = ?"
|
||||||
, " UNION SELECT "
|
, " UNION SELECT "
|
||||||
, qcols temp
|
, qcols $ entityDB t
|
||||||
, " FROM "
|
, " FROM "
|
||||||
, connEscapeName conn $ entityDB t
|
, connEscapeName conn $ entityDB t
|
||||||
, ", "
|
, ", "
|
||||||
|
|
@ -320,14 +320,14 @@ withRecursive dir field root conn t getcols =
|
||||||
, connEscapeName conn $ entityDB t
|
, connEscapeName conn $ entityDB t
|
||||||
, "."
|
, "."
|
||||||
, connEscapeName conn $ fieldDB $ case dir of
|
, connEscapeName conn $ fieldDB $ case dir of
|
||||||
RecOut -> persistFieldDef field
|
Ancestors -> persistFieldDef field
|
||||||
RecIn -> entityId t
|
Decendants -> entityId t
|
||||||
, " = "
|
, " = "
|
||||||
, connEscapeName conn temp
|
, connEscapeName conn temp
|
||||||
, "."
|
, "."
|
||||||
, connEscapeName conn $ fieldDB $ case dir of
|
, connEscapeName conn $ fieldDB $ case dir of
|
||||||
RecOut -> entityId t
|
Ancestors -> entityId t
|
||||||
RecIn -> persistFieldDef field
|
Decendants -> persistFieldDef field
|
||||||
, " ) "
|
, " ) "
|
||||||
]
|
]
|
||||||
in (temp, isRoot, cols, qcols, sql)
|
in (temp, isRoot, cols, qcols, sql)
|
||||||
Loading…
Reference in a new issue