{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
module Database.Bolt.Extras.Graph.Internal.GraphQuery
(
GraphQuery (..)
, GetRequest (..)
, PutRequest (..)
, mergeGraphs
) where
import Control.Lens (over, (^.))
import Control.Monad.IO.Class (MonadIO)
import Data.List (foldl')
import Data.Map.Strict (fromList,
mapKeys,
mapWithKey,
toList,
union, (!))
import Data.Text as T (Text, intercalate,
null,
pack)
import Database.Bolt (BoltActionT,
Record,
query)
import Database.Bolt.Extras (BoltId, GetBoltId (..))
import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph (..),
NodeName,
emptyGraph,
relationName,
relations,
vertices)
import Database.Bolt.Extras.Graph.Internal.Class (Extractable (..),
Requestable (..),
Returnable (..))
import Database.Bolt.Extras.Graph.Internal.Get (NodeGetter,
NodeResult,
RelGetter,
RelResult,
requestGetters)
import Database.Bolt.Extras.Graph.Internal.Put (PutNode, PutRelationship,
requestPut)
import NeatInterpolation (text)
class GraphQuery a where
type NodeReq a :: *
type RelReq a :: *
type NodeRes a :: *
type RelRes a :: *
requestEntities :: (Requestable (NodeName, NodeReq a),
Requestable ((NodeName, NodeName), RelReq a))
=> [(NodeName, NodeReq a)]
-> [((NodeName, NodeName), RelReq a)]
-> (Text, [Text])
formQuery :: (Requestable (NodeName, NodeReq a),
Requestable ((NodeName, NodeName), RelReq a),
Returnable (NodeName, NodeReq a),
Returnable ((NodeName, NodeName), RelReq a))
=> [Text]
-> Graph NodeName (NodeReq a) (RelReq a)
-> Text
formQuery [NodeName]
customConds Graph NodeName (NodeReq a) (RelReq a)
graph = [text|$completeRequest
$conditionsQ
WITH DISTINCT $distinctVars
RETURN $completeReturn|]
where
vertices' :: [(NodeName, NodeReq a)]
vertices' = forall k a. Map k a -> [(k, a)]
toList (Graph NodeName (NodeReq a) (RelReq a)
graph forall s a. s -> Getting a s a -> a
^. forall n a1 b a2.
Lens (Graph n a1 b) (Graph n a2 b) (Map n a1) (Map n a2)
vertices)
relations' :: [((NodeName, NodeName), RelReq a)]
relations' = forall k a. Map k a -> [(k, a)]
toList (Graph NodeName (NodeReq a) (RelReq a)
graph forall s a. s -> Getting a s a -> a
^. forall n a b1 b2.
Lens (Graph n a b1) (Graph n a b2) (Map (n, n) b1) (Map (n, n) b2)
relations)
distinctVars :: NodeName
distinctVars = NodeName -> [NodeName] -> NodeName
intercalate NodeName
", " forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(NodeName, NodeReq a)]
vertices' forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NodeName, NodeName) -> NodeName
relationName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((NodeName, NodeName), RelReq a)]
relations'
(NodeName
completeRequest, [NodeName]
reqConds) = forall a.
(GraphQuery a, Requestable (NodeName, NodeReq a),
Requestable ((NodeName, NodeName), RelReq a)) =>
[(NodeName, NodeReq a)]
-> [((NodeName, NodeName), RelReq a)] -> (NodeName, [NodeName])
requestEntities @a [(NodeName, NodeReq a)]
vertices' [((NodeName, NodeName), RelReq a)]
relations'
conditions :: [NodeName]
conditions = [NodeName]
reqConds forall a. [a] -> [a] -> [a]
++ [NodeName]
customConds
conditionsQ :: NodeName
conditionsQ = if forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [NodeName]
conditions then NodeName
"" else NodeName
" WHERE " forall a. Semigroup a => a -> a -> a
<> NodeName -> [NodeName] -> NodeName
intercalate NodeName
" AND " [NodeName]
conditions
returnVertices :: [NodeName]
returnVertices = forall a. Returnable a => a -> NodeName
return' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Returnable a => a -> Bool
isReturned' [(NodeName, NodeReq a)]
vertices'
returnRelations :: [NodeName]
returnRelations = forall a. Returnable a => a -> NodeName
return' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Returnable a => a -> Bool
isReturned' [((NodeName, NodeName), RelReq a)]
relations'
completeReturn :: NodeName
completeReturn = NodeName -> [NodeName] -> NodeName
intercalate NodeName
", " forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeName -> Bool
T.null) forall a b. (a -> b) -> a -> b
$ [NodeName]
returnVertices forall a. [a] -> [a] -> [a]
++ [NodeName]
returnRelations
:: (Extractable (NodeRes a), Extractable (RelRes a), MonadIO m)
=> [NodeName]
-> [(NodeName, NodeName)]
-> [Record]
-> BoltActionT m [Graph NodeName (NodeRes a) (RelRes a)]
extractGraphs [NodeName]
verticesN [(NodeName, NodeName)]
relationsN [Record]
records = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\BoltId
i -> do
[(NodeName, NodeRes a)]
vertices' <- forall a b. [a] -> [b] -> [(a, b)]
zip [NodeName]
verticesN forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> BoltId -> a
!! BoltId
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a (m :: * -> *).
(Extractable a, MonadIO m) =>
NodeName -> [Record] -> BoltActionT m [a]
extract [Record]
records ) [NodeName]
verticesN
[((NodeName, NodeName), RelRes a)]
relations' <- forall a b. [a] -> [b] -> [(a, b)]
zip [(NodeName, NodeName)]
relationsN forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> BoltId -> a
!! BoltId
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a (m :: * -> *).
(Extractable a, MonadIO m) =>
NodeName -> [Record] -> BoltActionT m [a]
extract [Record]
records forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeName, NodeName) -> NodeName
relationName) [(NodeName, NodeName)]
relationsN
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall n a b. Map n a -> Map (n, n) b -> Graph n a b
Graph (forall k a. Ord k => [(k, a)] -> Map k a
fromList [(NodeName, NodeRes a)]
vertices') (forall k a. Ord k => [(k, a)] -> Map k a
fromList [((NodeName, NodeName), RelRes a)]
relations'))
[BoltId
0 .. forall (t :: * -> *) a. Foldable t => t a -> BoltId
length [Record]
records forall a. Num a => a -> a -> a
- BoltId
1]
makeRequest :: (Requestable (NodeName, NodeReq a),
Requestable ((NodeName, NodeName), RelReq a),
Returnable (NodeName, NodeReq a),
Returnable ((NodeName, NodeName), RelReq a),
Extractable (NodeRes a),
Extractable (RelRes a),
MonadIO m)
=> [Text]
-> Graph NodeName (NodeReq a) (RelReq a)
-> BoltActionT m [Graph NodeName (NodeRes a) (RelRes a)]
makeRequest [NodeName]
conds Graph NodeName (NodeReq a) (RelReq a)
graph = do
[Record]
response <- forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
NodeName -> BoltActionT m [Record]
query forall a b. (a -> b) -> a -> b
$ forall a.
(GraphQuery a, Requestable (NodeName, NodeReq a),
Requestable ((NodeName, NodeName), RelReq a),
Returnable (NodeName, NodeReq a),
Returnable ((NodeName, NodeName), RelReq a)) =>
[NodeName] -> Graph NodeName (NodeReq a) (RelReq a) -> NodeName
formQuery @a [NodeName]
conds Graph NodeName (NodeReq a) (RelReq a)
graph
forall a (m :: * -> *).
(GraphQuery a, Extractable (NodeRes a), Extractable (RelRes a),
MonadIO m) =>
[NodeName]
-> [(NodeName, NodeName)]
-> [Record]
-> BoltActionT m [Graph NodeName (NodeRes a) (RelRes a)]
extractGraphs @a [NodeName]
presentedVertices [(NodeName, NodeName)]
presentedRelations [Record]
response
where
presentedVertices :: [NodeName]
presentedVertices = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Returnable a => a -> Bool
isReturned' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
toList forall a b. (a -> b) -> a -> b
$ Graph NodeName (NodeReq a) (RelReq a)
graph forall s a. s -> Getting a s a -> a
^. forall n a1 b a2.
Lens (Graph n a1 b) (Graph n a2 b) (Map n a1) (Map n a2)
vertices
presentedRelations :: [(NodeName, NodeName)]
presentedRelations = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Returnable a => a -> Bool
isReturned' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
toList forall a b. (a -> b) -> a -> b
$ Graph NodeName (NodeReq a) (RelReq a)
graph forall s a. s -> Getting a s a -> a
^. forall n a b1 b2.
Lens (Graph n a b1) (Graph n a b2) (Map (n, n) b1) (Map (n, n) b2)
relations
data GetRequest = GetRequest
instance GraphQuery GetRequest where
type NodeReq GetRequest = NodeGetter
type RelReq GetRequest = RelGetter
type NodeRes GetRequest = NodeResult
type RelRes GetRequest = RelResult
requestEntities :: (Requestable (NodeName, NodeReq GetRequest),
Requestable ((NodeName, NodeName), RelReq GetRequest)) =>
[(NodeName, NodeReq GetRequest)]
-> [((NodeName, NodeName), RelReq GetRequest)]
-> (NodeName, [NodeName])
requestEntities = [(NodeName, NodeGetter)]
-> [((NodeName, NodeName), RelGetter)] -> (NodeName, [NodeName])
requestGetters
data PutRequest = PutRequest
instance GraphQuery PutRequest where
type NodeReq PutRequest = PutNode
type RelReq PutRequest = PutRelationship
type NodeRes PutRequest = BoltId
type RelRes PutRequest = BoltId
requestEntities :: (Requestable (NodeName, NodeReq PutRequest),
Requestable ((NodeName, NodeName), RelReq PutRequest)) =>
[(NodeName, NodeReq PutRequest)]
-> [((NodeName, NodeName), RelReq PutRequest)]
-> (NodeName, [NodeName])
requestEntities = [(NodeName, PutNode)]
-> [((NodeName, NodeName), PutRelationship)]
-> (NodeName, [NodeName])
requestPut
mergeGraphs :: GetBoltId a => [Graph NodeName a b] -> Graph NodeName a b
mergeGraphs :: forall a b.
GetBoltId a =>
[Graph NodeName a b] -> Graph NodeName a b
mergeGraphs [Graph NodeName a b]
graphs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a b.
GetBoltId a =>
Graph NodeName a b -> Graph NodeName a b -> Graph NodeName a b
mergeGraph forall n a b. Ord n => Graph n a b
emptyGraph (forall a b. GetBoltId a => Graph NodeName a b -> Graph NodeName a b
updateGraph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Graph NodeName a b]
graphs)
where
updateGraph :: GetBoltId a => Graph NodeName a b -> Graph NodeName a b
updateGraph :: forall a b. GetBoltId a => Graph NodeName a b -> Graph NodeName a b
updateGraph Graph NodeName a b
graph = forall n a b. Map n a -> Map (n, n) b -> Graph n a b
Graph Map NodeName a
newVertices Map (NodeName, NodeName) b
newRelations
where
namesMap :: Map NodeName NodeName
namesMap = (\NodeName
name a
node -> NodeName
name forall a. Semigroup a => a -> a -> a
<> (String -> NodeName
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. GetBoltId a => a -> BoltId
getBoltId forall a b. (a -> b) -> a -> b
$ a
node) ) forall k a b. (k -> a -> b) -> Map k a -> Map k b
`mapWithKey` (Graph NodeName a b
graph forall s a. s -> Getting a s a -> a
^. forall n a1 b a2.
Lens (Graph n a1 b) (Graph n a2 b) (Map n a1) (Map n a2)
vertices)
newVertices :: Map NodeName a
newVertices = (\NodeName
name -> Map NodeName NodeName
namesMap forall k a. Ord k => Map k a -> k -> a
! NodeName
name ) forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
`mapKeys` (Graph NodeName a b
graph forall s a. s -> Getting a s a -> a
^. forall n a1 b a2.
Lens (Graph n a1 b) (Graph n a2 b) (Map n a1) (Map n a2)
vertices)
newRelations :: Map (NodeName, NodeName) b
newRelations = (\(NodeName
startName, NodeName
endName) -> (Map NodeName NodeName
namesMap forall k a. Ord k => Map k a -> k -> a
! NodeName
startName, Map NodeName NodeName
namesMap forall k a. Ord k => Map k a -> k -> a
! NodeName
endName) ) forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
`mapKeys` (Graph NodeName a b
graph forall s a. s -> Getting a s a -> a
^. forall n a b1 b2.
Lens (Graph n a b1) (Graph n a b2) (Map (n, n) b1) (Map (n, n) b2)
relations)
mergeGraph :: GetBoltId a => Graph NodeName a b -> Graph NodeName a b -> Graph NodeName a b
mergeGraph :: forall a b.
GetBoltId a =>
Graph NodeName a b -> Graph NodeName a b -> Graph NodeName a b
mergeGraph Graph NodeName a b
graphToMerge Graph NodeName a b
initialGraph = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall n a b1 b2.
Lens (Graph n a b1) (Graph n a b2) (Map (n, n) b1) (Map (n, n) b2)
relations (forall k a. Ord k => Map k a -> Map k a -> Map k a
union (Graph NodeName a b
graphToMerge forall s a. s -> Getting a s a -> a
^. forall n a b1 b2.
Lens (Graph n a b1) (Graph n a b2) (Map (n, n) b1) (Map (n, n) b2)
relations)) forall a b. (a -> b) -> a -> b
$
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall n a1 b a2.
Lens (Graph n a1 b) (Graph n a2 b) (Map n a1) (Map n a2)
vertices (forall k a. Ord k => Map k a -> Map k a -> Map k a
union (Graph NodeName a b
graphToMerge forall s a. s -> Getting a s a -> a
^. forall n a1 b a2.
Lens (Graph n a1 b) (Graph n a2 b) (Map n a1) (Map n a2)
vertices))
Graph NodeName a b
initialGraph