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/>.
|
||||
-}
|
||||
|
||||
module Database.Persist.Local.Sql.Orphan.PersistQueryRecursive
|
||||
( deleteRecursivelyWhereCount
|
||||
, updateRecursivelyWhereCount
|
||||
module Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
||||
( deleteForestWhereCount
|
||||
, updateForestWhereCount
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -39,17 +39,17 @@ import Database.Persist.Sql.Util
|
|||
import qualified Data.Conduit.List as CL (head, mapM)
|
||||
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
|
||||
|
||||
instance PersistQueryRecursive SqlBackend where
|
||||
updateRecursivelyWhere dir field root filts upds =
|
||||
void $ updateRecursivelyWhereCount dir field root filts upds
|
||||
instance PersistQueryForest SqlBackend where
|
||||
updateForestWhere dir field root filts upds =
|
||||
void $ updateForestWhereCount dir field root filts upds
|
||||
|
||||
deleteRecursivelyWhere dir field root filts =
|
||||
void $ deleteRecursivelyWhereCount dir field root filts
|
||||
deleteForestWhere 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
|
||||
let (sql, vals, parse) = sqlValsParse conn
|
||||
srcRes <- rawQueryRes sql vals
|
||||
|
|
@ -88,7 +88,7 @@ instance PersistQueryRecursive SqlBackend where
|
|||
]
|
||||
vals = getFiltsValues conn $ isRoot : filts
|
||||
|
||||
selectRecursivelyKeysRes dir field root filts opts = do
|
||||
selectForestKeysRes dir field root filts opts = do
|
||||
conn <- ask
|
||||
let (sql, vals, parse) = sqlValsParse conn
|
||||
srcRes <- rawQueryRes sql vals
|
||||
|
|
@ -151,7 +151,7 @@ instance PersistQueryRecursive SqlBackend where
|
|||
]
|
||||
vals = getFiltsValues conn $ isRoot : filts
|
||||
|
||||
countRecursively dir field root filts = do
|
||||
countForest dir field root filts = do
|
||||
conn <- ask
|
||||
let (sql, vals) = sqlAndVals conn
|
||||
withRawQuery sql vals $ do
|
||||
|
|
@ -183,15 +183,15 @@ instance PersistQueryRecursive SqlBackend where
|
|||
]
|
||||
vals = getFiltsValues conn $ isRoot : filts
|
||||
|
||||
-- | Same as 'deleteRecursivelyWhere', but returns the number of rows affected.
|
||||
deleteRecursivelyWhereCount
|
||||
-- | Same as 'deleteForestWhere', but returns the number of rows affected.
|
||||
deleteForestWhereCount
|
||||
:: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend)
|
||||
=> RecursionDirection
|
||||
-> EntityField val (Maybe (Key val))
|
||||
-> Key val
|
||||
-> [Filter val]
|
||||
-> ReaderT SqlBackend m Int64
|
||||
deleteRecursivelyWhereCount dir field root filts = do
|
||||
deleteForestWhereCount dir field root filts = do
|
||||
conn <- ask
|
||||
let (sql, vals) = sqlAndVals conn
|
||||
rawExecuteCount sql vals
|
||||
|
|
@ -221,8 +221,8 @@ deleteRecursivelyWhereCount dir field root filts = do
|
|||
]
|
||||
vals = getFiltsValues conn $ isRoot : filts
|
||||
|
||||
-- | Same as 'updateRecursivelyWhere', but returns the number of rows affected.
|
||||
updateRecursivelyWhereCount
|
||||
-- | Same as 'updateForestWhere', but returns the number of rows affected.
|
||||
updateForestWhereCount
|
||||
:: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val)
|
||||
=> RecursionDirection
|
||||
-> EntityField val (Maybe (Key val))
|
||||
|
|
@ -230,8 +230,8 @@ updateRecursivelyWhereCount
|
|||
-> [Filter val]
|
||||
-> [Update val]
|
||||
-> ReaderT SqlBackend m Int64
|
||||
updateRecursivelyWhereCount _ _ _ _ [] = return 0
|
||||
updateRecursivelyWhereCount dir field root filts upds = do
|
||||
updateForestWhereCount _ _ _ _ [] = return 0
|
||||
updateForestWhereCount dir field root filts upds = do
|
||||
conn <- ask
|
||||
let (sql, vals) = sqlAndVals conn
|
||||
rawExecuteCount sql vals
|
||||
|
|
@ -311,7 +311,7 @@ withRecursive dir field root conn t getcols =
|
|||
--, connEscapeName conn $ fieldDB $ entityId t
|
||||
--, " = ?"
|
||||
, " UNION SELECT "
|
||||
, qcols temp
|
||||
, qcols $ entityDB t
|
||||
, " FROM "
|
||||
, connEscapeName conn $ entityDB t
|
||||
, ", "
|
||||
|
|
@ -320,14 +320,14 @@ withRecursive dir field root conn t getcols =
|
|||
, connEscapeName conn $ entityDB t
|
||||
, "."
|
||||
, connEscapeName conn $ fieldDB $ case dir of
|
||||
RecOut -> persistFieldDef field
|
||||
RecIn -> entityId t
|
||||
Ancestors -> persistFieldDef field
|
||||
Decendants -> entityId t
|
||||
, " = "
|
||||
, connEscapeName conn temp
|
||||
, "."
|
||||
, connEscapeName conn $ fieldDB $ case dir of
|
||||
RecOut -> entityId t
|
||||
RecIn -> persistFieldDef field
|
||||
Ancestors -> entityId t
|
||||
Decendants -> persistFieldDef field
|
||||
, " ) "
|
||||
]
|
||||
in (temp, isRoot, cols, qcols, sql)
|
||||
Loading…
Reference in a new issue