{-# 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 (..)
, GetRequestA (..)
, GetRequestB (..)
, PutRequestB (..)
, 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.Monoid ((<>))
import Data.Text as T (Text, intercalate,
null,
pack)
import Database.Bolt (BoltActionT,
Node,
Record,
URelationship,
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 customConds graph = [text|$completeRequest
$conditionsQ
RETURN DISTINCT $completeReturn|]
where
vertices' = toList (graph ^. vertices)
relations' = toList (graph ^. relations)
(completeRequest, reqConds) = requestEntities @a vertices' relations'
conditions = reqConds ++ customConds
conditionsQ = if Prelude.null conditions then "" else " WHERE " <> intercalate " AND " conditions
returnVertices = return' <$> filter isReturned' vertices'
returnRelations = return' <$> filter isReturned' relations'
completeReturn = intercalate ", " $ Prelude.filter (not . T.null) $ returnVertices ++ returnRelations
extractGraphs :: (Extractable (NodeRes a), Extractable (RelRes a), MonadIO m)
=> [NodeName]
-> [(NodeName, NodeName)]
-> [Record]
-> BoltActionT m [Graph NodeName (NodeRes a) (RelRes a)]
extractGraphs verticesN relationsN records = mapM (\i -> do
vertices' <- zip verticesN <$> traverse (fmap (!! i) . flip extract records ) verticesN
relations' <- zip relationsN <$> traverse (fmap (!! i) . flip extract records . relationName) relationsN
pure $ Graph (fromList vertices') (fromList relations'))
[0 .. length records - 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 conds graph = do
response <- query $ formQuery @a conds graph
extractGraphs @a presentedVertices presentedRelations response
where
presentedVertices = fmap fst . filter isReturned' . toList $ graph ^. vertices
presentedRelations = fmap fst . filter isReturned' . toList $ graph ^. relations
data GetRequestA = GetRequestA
data GetRequestB = GetRequestB
instance GraphQuery GetRequestA where
type NodeReq GetRequestA = NodeGetter
type RelReq GetRequestA = RelGetter
type NodeRes GetRequestA = NodeResult
type RelRes GetRequestA = RelResult
requestEntities = requestGetters
instance GraphQuery GetRequestB where
type NodeReq GetRequestB = NodeGetter
type RelReq GetRequestB = RelGetter
type NodeRes GetRequestB = Node
type RelRes GetRequestB = URelationship
requestEntities = requestGetters
data PutRequestB = PutRequestB
instance GraphQuery PutRequestB where
type NodeReq PutRequestB = PutNode
type RelReq PutRequestB = PutRelationship
type NodeRes PutRequestB = BoltId
type RelRes PutRequestB = BoltId
requestEntities = requestPut
mergeGraphs :: GetBoltId a => [Graph NodeName a b] -> Graph NodeName a b
mergeGraphs graphs = foldl' mergeGraph emptyGraph (updateGraph <$> graphs)
where
updateGraph :: GetBoltId a => Graph NodeName a b -> Graph NodeName a b
updateGraph graph = Graph newVertices newRelations
where
namesMap = (\name node -> name <> (pack . show . getBoltId $ node) ) `mapWithKey` (graph ^. vertices)
newVertices = (\name -> namesMap ! name ) `mapKeys` (graph ^. vertices)
newRelations = (\(startName, endName) -> (namesMap ! startName, namesMap ! endName) ) `mapKeys` (graph ^. relations)
mergeGraph :: GetBoltId a => Graph NodeName a b -> Graph NodeName a b -> Graph NodeName a b
mergeGraph graphToMerge initialGraph = over relations (union (graphToMerge ^. relations)) $
over vertices (union (graphToMerge ^. vertices))
initialGraph