hasbolt-extras 0.0.0.12 → 0.0.0.14
raw patch · 33 files changed
+1404/−1131 lines, 33 filesdep +aesondep +aeson-casingdep +scientific
Dependencies added: aeson, aeson-casing, scientific, unordered-containers, vector
Files
- CHANGELOG.md +10/−0
- hasbolt-extras.cabal +20/−15
- src/Database/Bolt/Extras.hs +9/−10
- src/Database/Bolt/Extras/Condition.hs +0/−64
- src/Database/Bolt/Extras/DSL.hs +4/−4
- src/Database/Bolt/Extras/DSL/Internal/Executer.hs +1/−1
- src/Database/Bolt/Extras/DSL/Internal/Instances.hs +2/−2
- src/Database/Bolt/Extras/DSL/Internal/Types.hs +5/−5
- src/Database/Bolt/Extras/Graph.hs +10/−39
- src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs +45/−0
- src/Database/Bolt/Extras/Graph/Internal/Class.hs +29/−0
- src/Database/Bolt/Extras/Graph/Internal/Get.hs +260/−0
- src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs +186/−0
- src/Database/Bolt/Extras/Graph/Internal/Put.hs +125/−0
- src/Database/Bolt/Extras/Internal/Condition.hs +64/−0
- src/Database/Bolt/Extras/Internal/Cypher.hs +66/−0
- src/Database/Bolt/Extras/Internal/Instances.hs +117/−0
- src/Database/Bolt/Extras/Internal/Persisted.hs +56/−0
- src/Database/Bolt/Extras/Internal/Types.hs +67/−0
- src/Database/Bolt/Extras/Persisted.hs +0/−50
- src/Database/Bolt/Extras/Query.hs +0/−30
- src/Database/Bolt/Extras/Query/Cypher.hs +0/−66
- src/Database/Bolt/Extras/Query/Delete.hs +0/−35
- src/Database/Bolt/Extras/Query/Get.hs +0/−142
- src/Database/Bolt/Extras/Query/Put.hs +0/−117
- src/Database/Bolt/Extras/Query/Set.hs +0/−49
- src/Database/Bolt/Extras/Query/Utils.hs +0/−7
- src/Database/Bolt/Extras/Template.hs +3/−28
- src/Database/Bolt/Extras/Template/Converters.hs +0/−301
- src/Database/Bolt/Extras/Template/Instances.hs +0/−93
- src/Database/Bolt/Extras/Template/Internal/Converters.hs +297/−0
- src/Database/Bolt/Extras/Template/Types.hs +0/−68
- src/Database/Bolt/Extras/Utils.hs +28/−5
CHANGELOG.md view
@@ -6,6 +6,16 @@ ## [Unreleased] +## [0.0.0.14] - 2018-12-25+### Added+- `mergeGraphs`, ability to take not all node properties from DB.+### Changed+- Refactoring.++## [0.0.0.13] - 2018-12-05+### Added+- `ToJSON` and `FromJSON` instances for `Persisted a`.+ ## [0.0.0.12] - 2018-10-15 ### Added - `REMOVE` query.
hasbolt-extras.cabal view
@@ -1,5 +1,5 @@ name: hasbolt-extras-version: 0.0.0.12+version: 0.0.0.14 synopsis: Extras for hasbolt library description: Extras for hasbolt library homepage: https://github.com/biocad/hasbolt-extras#readme@@ -24,38 +24,43 @@ library hs-source-dirs: src exposed-modules: Database.Bolt.Extras- , Database.Bolt.Extras.Condition , Database.Bolt.Extras.Graph- , Database.Bolt.Extras.Persisted- , Database.Bolt.Extras.Query , Database.Bolt.Extras.Template- , Database.Bolt.Extras.Utils , Database.Bolt.Extras.DSL- other-modules: Database.Bolt.Extras.Query.Get- , Database.Bolt.Extras.Query.Put- , Database.Bolt.Extras.Query.Set- , Database.Bolt.Extras.Query.Delete- , Database.Bolt.Extras.Query.Utils- , Database.Bolt.Extras.Query.Cypher- - , Database.Bolt.Extras.Template.Types- , Database.Bolt.Extras.Template.Instances- , Database.Bolt.Extras.Template.Converters+ , Database.Bolt.Extras.Utils+ other-modules: Database.Bolt.Extras.Internal.Cypher+ , Database.Bolt.Extras.Internal.Condition+ , Database.Bolt.Extras.Internal.Persisted+ , Database.Bolt.Extras.Internal.Instances+ , Database.Bolt.Extras.Internal.Types + , Database.Bolt.Extras.Template.Internal.Converters+ , Database.Bolt.Extras.DSL.Internal.Types , Database.Bolt.Extras.DSL.Internal.Language , Database.Bolt.Extras.DSL.Internal.Executer , Database.Bolt.Extras.DSL.Internal.Instances++ , Database.Bolt.Extras.Graph.Internal.AbstractGraph+ , Database.Bolt.Extras.Graph.Internal.Class+ , Database.Bolt.Extras.Graph.Internal.Get+ , Database.Bolt.Extras.Graph.Internal.Put+ , Database.Bolt.Extras.Graph.Internal.GraphQuery build-depends: base >=4.7 && <5+ , aeson+ , aeson-casing , containers , free , hasbolt , lens , mtl , neat-interpolation+ , scientific , template-haskell , text , th-lift-instances+ , vector+ , unordered-containers ghc-options: -Wall -O2 default-language: Haskell2010
src/Database/Bolt/Extras.hs view
@@ -1,14 +1,13 @@ module Database.Bolt.Extras (- module Database.Bolt.Extras.Graph- , module Database.Bolt.Extras.Utils- , module Database.Bolt.Extras.Template- , module Database.Bolt.Extras.Query- , module Database.Bolt.Extras.Persisted+ module Database.Bolt.Extras.Internal.Condition+ , module Database.Bolt.Extras.Internal.Persisted+ , module Database.Bolt.Extras.Internal.Cypher+ , module Database.Bolt.Extras.Internal.Types ) where -import Database.Bolt.Extras.Graph-import Database.Bolt.Extras.Utils-import Database.Bolt.Extras.Template-import Database.Bolt.Extras.Query-import Database.Bolt.Extras.Persisted+import Database.Bolt.Extras.Internal.Condition+import Database.Bolt.Extras.Internal.Cypher+import Database.Bolt.Extras.Internal.Instances ()+import Database.Bolt.Extras.Internal.Persisted+import Database.Bolt.Extras.Internal.Types
− src/Database/Bolt/Extras/Condition.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}--module Database.Bolt.Extras.Condition- (- Condition (..)- , tautology- , matches- , itself- ) where---- | Conditional expressions over type 'a' and its mappings.--- Supported operations:--- * equality check :==--- * disunction :&&--- * conjunction :||------ Typical usage:--- Say we have variable 'var :: a', a function 'f :: a -> b' and a value 'val :: b'.--- Expression 'f :== b' acts as 'f a == b'--- Examples:------ > data D = D { fld1 :: Int--- > , fld2 :: String--- > , fld3 :: Double--- > }--- >--- > d = D 42 "noononno" 1.618--- > d `matches` (fld1 :== 12 :&& fld2 :== "abc")--- > False--- >--- > d `matches` (fld1 :== 42 :|| fld3 == 1.0)--- > True----infix 4 :==-infixr 3 :&&-infixr 2 :||-data Condition a = forall b. Eq b => (a -> b) :== b- | Condition a :&& Condition a- | Condition a :|| Condition a----- | Check whether data satisfies conditions on it.----matches :: a -> Condition a -> Bool-matches obj (transform :== ref) = transform obj == ref-matches obj (u :&& v) = matches obj u && matches obj v-matches obj (u :|| v) = matches obj u || matches obj v----- | Matching 'tautology' will always succeed.--- > whatever `matches` tautology == True--- > -- Match is lazy:--- > undefined `matches` tautology == True----tautology :: Condition a-tautology = const True :== True----- | Object itself instead of its mappings is matched with help of this alias.--- > 42 `matches` (itself :== 42) == True--- > 42 `matches` (itself :== 41) == False----itself :: a -> a-itself = id
src/Database/Bolt/Extras/DSL.hs view
@@ -5,7 +5,7 @@ , module Database.Bolt.Extras.DSL.Internal.Executer ) where -import Database.Bolt.Extras.DSL.Internal.Types-import Database.Bolt.Extras.DSL.Internal.Language-import Database.Bolt.Extras.DSL.Internal.Executer-import Database.Bolt.Extras.DSL.Internal.Instances ()+import Database.Bolt.Extras.DSL.Internal.Executer+import Database.Bolt.Extras.DSL.Internal.Instances ()+import Database.Bolt.Extras.DSL.Internal.Language+import Database.Bolt.Extras.DSL.Internal.Types
src/Database/Bolt/Extras/DSL/Internal/Executer.hs view
@@ -13,9 +13,9 @@ import Data.Text as T (Text, intercalate, unwords)+import Database.Bolt.Extras (ToCypher (..)) import Database.Bolt.Extras.DSL.Internal.Instances () import Database.Bolt.Extras.DSL.Internal.Types (Expr (..))-import Database.Bolt.Extras.Query.Cypher (ToCypher (..)) -- | Translates 'Expr' to cypher query. --
src/Database/Bolt/Extras/DSL/Internal/Instances.hs view
@@ -10,9 +10,9 @@ import Control.Monad.Writer (execWriter, tell) import Data.Monoid ((<>)) import Data.Text (intercalate, pack)+import Database.Bolt.Extras (ToCypher (..),+ fromInt) import Database.Bolt.Extras.DSL.Internal.Types-import Database.Bolt.Extras.Persisted (fromInt)-import Database.Bolt.Extras.Query.Cypher (ToCypher (..)) import NeatInterpolation (text) import Text.Printf (printf)
src/Database/Bolt/Extras/DSL/Internal/Types.hs view
@@ -23,11 +23,11 @@ , toRelSelector ) where -import Data.Map.Strict (toList)-import Data.Text (Text)-import Database.Bolt (Node (..), URelationship (..),- Value (..))-import Database.Bolt.Extras.Persisted (BoltId)+import Data.Map.Strict (toList)+import Data.Text (Text)+import Database.Bolt (Node (..), URelationship (..),+ Value (..))+import Database.Bolt.Extras (BoltId) -- | Class for Selectors, which can update identifier, labels and props. --
src/Database/Bolt/Extras/Graph.hs view
@@ -1,43 +1,14 @@-{-# LANGUAGE TemplateHaskell #-}- module Database.Bolt.Extras.Graph (- Graph (..)- , emptyGraph- , addNode- , addRelation+ module Database.Bolt.Extras.Graph.Internal.AbstractGraph+ , module Database.Bolt.Extras.Graph.Internal.Class+ , module Database.Bolt.Extras.Graph.Internal.Get+ , module Database.Bolt.Extras.Graph.Internal.GraphQuery+ , module Database.Bolt.Extras.Graph.Internal.Put ) where -import Control.Lens (makeLenses, over)-import Data.Map.Strict (Map, insert, notMember)-import Text.Printf (printf)---- | 'Graph' contains vertices, that are parameterized by some type @n@, and relations,--- that parameterized by pair of type @n@. This pair represents vertices, that are connected with this relation.----data Graph n a b = Graph { _vertices :: Map n a- , _relations :: Map (n, n) b- } deriving (Show)--makeLenses ''Graph---- | Creates empty graph.----emptyGraph :: Ord n => Graph n a b-emptyGraph = Graph mempty mempty---- | Adds node to graph by it's @name@ and @node@ content.--- If graph already contains vertex with given @name@, error will be thrown.----addNode :: (Show n, Ord n) => n -> a -> Graph n a b -> Graph n a b-addNode name node graph = if name `notMember` _vertices graph- then over vertices (insert name node) graph- else error . printf "vertex with name %s key already exists" . show $ name---- | Adds relation to graph by @startName@ of vertex, @endName@ of vertex, and @rel@ with relation content.--- If graph already contains relation with given @(startName, endName)@, error will be thrown.----addRelation :: (Show n, Ord n) => n -> n -> b -> Graph n a b -> Graph n a b-addRelation startName endName rel graph = if (startName, endName) `notMember` _relations graph- then over relations (insert (startName, endName) rel) graph- else error $ printf "relation with names (%s, %s) already exists" (show startName) (show endName)+import Database.Bolt.Extras.Graph.Internal.AbstractGraph+import Database.Bolt.Extras.Graph.Internal.Class+import Database.Bolt.Extras.Graph.Internal.Get+import Database.Bolt.Extras.Graph.Internal.GraphQuery+import Database.Bolt.Extras.Graph.Internal.Put
+ src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.Bolt.Extras.Graph.Internal.AbstractGraph+ (+ Graph (..)+ , vertices+ , relations+ , emptyGraph+ , addNode+ , addRelation+ ) where++import Control.Lens (makeLenses, over)+import Data.Map.Strict (Map, insert, notMember)+import Text.Printf (printf)++-- | 'Graph' contains vertices, that are parameterized by some type @n@, and relations,+-- that parameterized by pair of type @n@. This pair represents vertices, that are connected with this relation.+--+data Graph n a b = Graph { _vertices :: Map n a+ , _relations :: Map (n, n) b+ } deriving (Show)++makeLenses ''Graph++-- | Creates empty graph.+--+emptyGraph :: Ord n => Graph n a b+emptyGraph = Graph mempty mempty++-- | Adds node to graph by it's @name@ and @node@ content.+-- If graph already contains vertex with given @name@, error will be thrown.+--+addNode :: (Show n, Ord n) => n -> a -> Graph n a b -> Graph n a b+addNode name node graph = if name `notMember` _vertices graph+ then over vertices (insert name node) graph+ else error . printf "vertex with name %s key already exists" . show $ name++-- | Adds relation to graph by @startName@ of vertex, @endName@ of vertex, and @rel@ with relation content.+-- If graph already contains relation with given @(startName, endName)@, error will be thrown.+--+addRelation :: (Show n, Ord n) => n -> n -> b -> Graph n a b -> Graph n a b+addRelation startName endName rel graph = if (startName, endName) `notMember` _relations graph+ then over relations (insert (startName, endName) rel) graph+ else error $ printf "relation with names (%s, %s) already exists" (show startName) (show endName)
+ src/Database/Bolt/Extras/Graph/Internal/Class.hs view
@@ -0,0 +1,29 @@+module Database.Bolt.Extras.Graph.Internal.Class+ (+ Requestable (..)+ , Returnable (..)+ , Extractable (..)+ ) where++import Control.Monad.IO.Class (MonadIO)+import Data.Text (Text)+import Database.Bolt (BoltActionT, Record)++-- | Class describes entity, which can be requested.+--+class Requestable a where+ -- | Condition for BoltId like "ID(a) = b" if BoltId is presented.+ maybeBoltIdCond :: a -> Maybe Text+ -- | How to convert entity to Cypher.+ request :: a -> Text++-- | Class describes entity, which can be returned.+--+class Returnable a where+ -- | How to return entity in the Cypher.+ return' :: a -> Text++-- | Class describes entity, which can be extracted from records by name.+--+class Extractable a where+ extract :: MonadIO m => Text -> [Record] -> BoltActionT m [a]
+ src/Database/Bolt/Extras/Graph/Internal/Get.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Database.Bolt.Extras.Graph.Internal.Get+ (+ NodeName+ -- * Types for requesting nodes and relationships+ , NodeGetter (..)+ , RelGetter (..)+ , GetterLike (..)+ , (#)+ , defaultNode+ , defaultRel+ -- * Types for extracting nodes and relationships+ , NodeResult (..)+ , RelResult (..)+ , relationName+ -- * Graph types+ , GraphGetRequest+ , GraphGetResponseA+ , GraphGetResponseB+ ) where++import Control.Monad.IO.Class (MonadIO)+import Data.Aeson as A (FromJSON (..),+ Result (..),+ ToJSON (..),+ Value,+ fromJSON,+ genericParseJSON,+ genericToJSON,+ omitNothingFields,+ toJSON)+import Data.Aeson.Casing (aesonPrefix,+ snakeCase)+import Data.Function ((&))+import Data.Map.Strict as M (Map,+ filter,+ fromList,+ insert,+ toList,+ (!))+import Data.Maybe (fromJust,+ isJust)+import Data.Monoid ((<>))+import Data.Text (Text, cons,+ intercalate,+ pack)+import Database.Bolt as B (BoltActionT,+ Node (..),+ Record,+ URelationship (..),+ Value)+import Database.Bolt.Extras (BoltId, GetBoltId (..),+ Label,+ NodeLike (..),+ ToCypher (..),+ URelationLike (..))+import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph)+import Database.Bolt.Extras.Graph.Internal.Class (Extractable (..),+ Requestable (..),+ Returnable (..))+import GHC.Generics (Generic)+import NeatInterpolation (text)+import Text.Printf (printf)++-- | Alias for node name+--+type NodeName = Text++----------------------------------------------------------+-- REQUEST --+----------------------------------------------------------++-- | Helper to find 'Node's.+--+data NodeGetter = NodeGetter { ngboltId :: Maybe BoltId+ , ngLabels :: [Label]+ , ngProps :: Map Text B.Value+ , ngReturnProps :: [Text]+ }+ deriving (Show, Eq)++-- | Helper to find 'URelationship's.+--+data RelGetter = RelGetter { rgboltId :: Maybe BoltId+ , rgLabel :: Maybe Label+ , rgProps :: Map Text B.Value+ , rgReturnProps :: [Text]+ }+ deriving (Show, Eq)++(#) :: a -> (a -> b) -> b+(#) = (&)++defaultNode :: NodeGetter+defaultNode = NodeGetter Nothing [] (fromList []) []++defaultRel :: RelGetter+defaultRel = RelGetter Nothing Nothing (fromList []) []++-- | Helper to work with Getters.+--+class GetterLike a where+ withBoltId :: BoltId -> a -> a+ withLabel :: Label -> a -> a+ withProp :: (Text, B.Value) -> a -> a+ withReturn :: [Text] -> a -> a++instance GetterLike NodeGetter where+ withBoltId boltId ng = ng { ngboltId = Just boltId }+ withLabel lbl ng = ng { ngLabels = lbl : ngLabels ng }+ withProp (pk, pv) ng = ng { ngProps = insert pk pv (ngProps ng) }+ withReturn props ng = ng { ngReturnProps = ngReturnProps ng ++ props }++instance GetterLike RelGetter where+ withBoltId boltId rg = rg { rgboltId = Just boltId }+ withLabel lbl rg = rg { rgLabel = Just lbl }+ withProp (pk, pv) rg = rg { rgProps = insert pk pv (rgProps rg) }+ withReturn props rg = rg { rgReturnProps = rgReturnProps rg ++ props }++instance Requestable (NodeName, NodeGetter) where+ maybeBoltIdCond (name, ng) = pack . printf "ID(%s)=%d" name <$> ngboltId ng++ request (name, ng) = [text|($name $labels $propsQ)|]+ where+ labels = toCypher . ngLabels $ ng+ propsQ = "{" <> (toCypher . toList . ngProps $ ng) <> "}"++instance Requestable ((NodeName, NodeName), RelGetter) where+ maybeBoltIdCond (names, rg) = pack . printf "ID(%s)=%d" (relationName names) <$> rgboltId rg++ request ((stName, enName), rg) = [text|($stName)-[$name $typeQ $propsQ]-($enName)|]+ where+ name = relationName (stName, enName)+ typeQ = maybe "" toCypher (rgLabel rg)+ propsQ = "{" <> (toCypher . toList . rgProps $ rg) <> "}"++instance Returnable (NodeName, NodeGetter) where+ return' (name, ng) = let showProps = showRetProps name $ ngReturnProps ng+ in [text|{ id: id($name),+ labels: labels($name),+ props: $showProps+ } as $name+ |]++instance Returnable ((NodeName, NodeName), RelGetter) where+ return' ((stName, enName), rg) = let name = relationName (stName, enName)+ showProps = showRetProps name $ rgReturnProps rg+ in [text|{ id: id($name),+ label: type($name),+ props: $showProps+ } as $name+ |]++-- | Creates relationship name from the names of its start and end nodes+-- in the way `<startNodeName>0<endNodeName>`.+relationName :: (NodeName, NodeName) -> Text+relationName (st, en) = st <> "0" <> en++showRetProps :: Text -> [Text] -> Text+showRetProps name [] = "properties(" <> name <> ")"+showRetProps name props = name <> "{" <> intercalate ", " (cons '.' <$> props) <> "}"++----------------------------------------------------------+-- RESULT --+----------------------------------------------------------++-- | Result for node in the Aeson like format.+--+data NodeResult = NodeResult { nresId :: BoltId+ , nresLabels :: [Label]+ , nresProps :: Map Text A.Value+ }+ deriving (Show, Eq, Generic)++-- | Result for relationship in the Aeson like format.+--+data RelResult = RelResult { rresId :: BoltId+ , rresLabel :: Label+ , rresProps :: Map Text A.Value+ }+ deriving (Show, Eq, Generic)++instance GetBoltId NodeResult where+ getBoltId = nresId++instance GetBoltId RelResult where+ getBoltId = rresId++instance ToJSON NodeResult where+ toJSON = genericToJSON (aesonPrefix snakeCase)+ { omitNothingFields = True }+instance FromJSON NodeResult where+ parseJSON = genericParseJSON (aesonPrefix snakeCase)+ { omitNothingFields = True }++instance ToJSON RelResult where+ toJSON = genericToJSON (aesonPrefix snakeCase)+ { omitNothingFields = True }+instance FromJSON RelResult where+ parseJSON = genericParseJSON (aesonPrefix snakeCase)+ { omitNothingFields = True }++instance Extractable NodeResult where+ extract = extractFromJSON++instance Extractable RelResult where+ extract = extractFromJSON++instance Extractable Node where+ extract :: forall m. MonadIO m => Text -> [Record] -> BoltActionT m [Node]+ extract t rec = (toNode <$>) <$> (extractFromJSON t rec :: BoltActionT m [NodeResult])++instance Extractable URelationship where+ extract :: forall m. MonadIO m => Text -> [Record] -> BoltActionT m [URelationship]+ extract t rec = (toURelation <$>) <$> (extractFromJSON t rec :: BoltActionT m [RelResult])++extractFromJSON :: (MonadIO m, FromJSON a) => Text -> [Record] -> BoltActionT m [a]+extractFromJSON var = pure . fmap (\r -> case fromJSON (toJSON (r ! var)) of+ Success parsed -> parsed+ Error err -> error err)++fromJSONM :: forall a. FromJSON a => A.Value -> Maybe a+fromJSONM (fromJSON -> Success r :: Result a) = Just r+fromJSONM _ = Nothing++instance NodeLike NodeResult where+ toNode NodeResult{..} = Node nresId nresLabels (fromJust <$> M.filter isJust (fromJSONM <$> nresProps))+ fromNode Node{..} = NodeResult nodeIdentity labels (toJSON <$> nodeProps)++instance URelationLike RelResult where+ toURelation RelResult{..} = URelationship rresId rresLabel (fromJust <$> M.filter isJust (fromJSONM <$> rresProps))+ fromURelation URelationship{..} = RelResult urelIdentity urelType (toJSON <$> urelProps)++----------------------------------------------------------+-- GRAPH TYPES --+----------------------------------------------------------++-- | The combinations of 'Getter's to load graph from the database.+--+type GraphGetRequest = Graph NodeName NodeGetter RelGetter++-- | The graph of 'Node's and 'URelationship's which we got from the database using 'GraphGetRequest',+-- converted to the Aeson Value like.+--+type GraphGetResponseA = Graph NodeName NodeResult RelResult++-- | The graph of 'Node's and 'URelationship's which we got from the database using 'GraphGetRequest',+-- converted to the Bolt Value like.+--+type GraphGetResponseB = Graph NodeName Node URelationship
+ src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs view
@@ -0,0 +1,186 @@+{-# 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 (..)+ , mergeGraphs+ ) where++import Control.Lens (over, (^.))+import Control.Monad.IO.Class (MonadIO)+import Data.List (foldl')+import Data.Map.Strict (fromList,+ keys,+ mapKeys,+ mapWithKey,+ toList,+ union, (!))+import Data.Maybe (catMaybes)+import Data.Monoid ((<>))+import Data.Text (Text,+ intercalate,+ pack)+import Database.Bolt (BoltActionT,+ Node,+ Record,+ URelationship,+ query)+import Database.Bolt.Extras (GetBoltId (..))+import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph (..),+ emptyGraph,+ relations,+ vertices)+import Database.Bolt.Extras.Graph.Internal.Class (Extractable (..),+ Requestable (..),+ Returnable (..))+import Database.Bolt.Extras.Graph.Internal.Get (NodeGetter,+ NodeName,+ NodeResult,+ RelGetter,+ RelResult,+ relationName)+import NeatInterpolation (text)++-- | Type family used to perform requests to the Neo4j based on graphs.+--+class GraphQuery a where+ -- | Type of entity, describing node for request.+ type NodeReq a :: *+ -- | Type of entity, describing relationship for request.+ type RelReq a :: *+ -- | Type of node entity, which will be extracted from result.+ type NodeRes a :: *+ -- | Type of relationship entity, which will be extracted from result.+ type RelRes a :: *++ -- | 'MATCH' or 'MERGE' or 'CREATE'+ clause :: Text++ -- | Abstract function to form query for get request.+ --+ 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|$clause' $completeRequest+ $conditionsQ+ RETURN $completeReturn|]+ where+ clause' = clause @a++ vertices' = toList (graph ^. vertices)+ relations' = toList (graph ^. relations)++ requestVertices = request <$> vertices'+ requestRelations = request <$> relations'++ conditionsID = catMaybes (fmap maybeBoltIdCond vertices' ++ fmap maybeBoltIdCond relations')+ conditions = customConds ++ conditionsID+ conditionsQ = if null conditions then "" else "WHERE " <> intercalate " AND " conditions++ returnVertices = return' <$> vertices'+ returnRelations = return' <$> relations'++ completeRequest = intercalate ", " $ requestVertices ++ requestRelations+ completeReturn = intercalate ", " $ returnVertices ++ returnRelations++ -- | Abstract function, which exctracts graph from records if nodes and relations can be extracted.+ --+ 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]++ -- | For given query graph, perform query and extract results graph.+ --+ 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 (keys $ graph ^. vertices) (keys $ graph ^. relations) response++-- | Get request with result in Aeson format.+-- Easy way to show result graphs.+--+data GetRequestA = GetRequestA++-- | Get request with result in Bolt format.+-- Easy way to extract results and convert them to another entities (using 'fromNode').+--+data GetRequestB = GetRequestB++instance GraphQuery GetRequestA where+ type NodeReq GetRequestA = NodeGetter+ type RelReq GetRequestA = RelGetter+ type NodeRes GetRequestA = NodeResult+ type RelRes GetRequestA = RelResult+ clause = "MATCH"++instance GraphQuery GetRequestB where+ type NodeReq GetRequestB = NodeGetter+ type RelReq GetRequestB = RelGetter+ type NodeRes GetRequestB = Node+ type RelRes GetRequestB = URelationship+ clause = "MATCH"++-- | Helper function to merge graphs of results, i.e.+-- if you requested graph A->B->C+-- and in the database there were two B entities connected to the same entity A+-- and four C entities, connected to the same two entities B,+-- cypher query will return four graphs, which satisfy this path,+-- despite the fact that A was presented only once in the database+-- and B was presented only two times in the database.+-- This function will merge these four graphs in one+-- and return nodes by node names with suffixes equal to their BoltId-s.+--+-- For example, if there were four graphs:+-- nodes: [A (boltId = 0), B (boltId = 1), C (boltId = 3)], relations: [A -> B, B -> C],+-- nodes: [A (boltId = 0), B (boltId = 1), C (boltId = 4)], relations: [A -> B, B -> C],+-- nodes: [A (boltId = 0), B (boltId = 2), C (boltId = 5)], relations: [A -> B, B -> C],+-- nodes: [A (boltId = 0), B (boltId = 2), C (boltId = 6)], relations: [A -> B, B -> C],+-- this function will merge them into new graph:+-- nodes: [A0 (boltId = 0), B1 (boltId = 1), B2 (boltId = 2),+-- C3 (boltId = 3), C4 (boltId = 4), C5 (boltId = 5), C6 (boltId = 6)],+-- relations: [A0 -> B1, A0 -> B2, B1 -> C3, B1 -> C4, B2 -> C5, B2 -> C6].+--+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
+ src/Database/Bolt/Extras/Graph/Internal/Put.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Bolt.Extras.Graph.Internal.Put+ (+ PutNode (..)+ , PutRelationship (..)+ , GraphPutRequest+ , GraphPutResponse+ , putNode+ , putRelationship+ , putGraph+ ) where++import Control.Monad (forM)+import Control.Monad.IO.Class (MonadIO)+import Data.Map.Strict (mapWithKey,+ toList, (!))+import qualified Data.Map.Strict as M (map)+import qualified Data.Text as T (Text,+ pack)+import Database.Bolt (BoltActionT,+ Node (..),+ RecordValue (..),+ URelationship (..),+ Value (..),+ at, exact,+ query)+import Database.Bolt.Extras (BoltId, ToCypher (..),+ fromInt)+import Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph (..))+import NeatInterpolation (text)++type NodeName = T.Text++-- | 'PutNode' is the wrapper for 'Node' where we can specify if we want to merge or create it.+--+data PutNode = BoltId BoltId | MergeN Node | CreateN Node+ deriving (Show)++-- | 'PutRelationship' is the wrapper for 'Relationship' where we can specify if we want to merge or create it.+--+data PutRelationship = MergeR URelationship | CreateR URelationship+ deriving (Show)++-- | The graph of 'Node's with specified uploading type and 'URelationship's.+--+type GraphPutRequest = Graph NodeName PutNode PutRelationship++-- | The graph of 'BoltId's corresponding to the nodes and relationships+-- which we get after putting 'GraphPutRequest'.+--+type GraphPutResponse = Graph NodeName BoltId BoltId++-- | For given @Node _ labels nodeProps@ makes query MERGE or CREATE depending+-- on the type of 'PutNode' and returns 'BoltId' of the loaded 'Node'.+-- If we already know 'BoltId' of the 'Node' with such parameters, this function does nothing.+--+-- Potentially, if you MERGE some 'Node' and its labels and props are occured in+-- several 'Node's, then the result can be not one but several 'Node's,+-- so the result of this function will be a list of corresponding 'BoltId's.+--+putNode :: (MonadIO m) => PutNode -> BoltActionT m [BoltId]+putNode ut = case ut of+ (BoltId bId) -> pure [bId]+ (MergeN node) -> helper (T.pack "MERGE") node+ (CreateN node) -> helper (T.pack "CREATE") node+ where+ helper :: (MonadIO m) => T.Text -> Node -> BoltActionT m [BoltId]+ helper q node = do+ let varQ = "n"++ let labelsQ = toCypher $ labels node+ let propsQ = toCypher . filter ((/= N ()) . snd) . toList $ nodeProps node++ let getQuery = [text|$q ($varQ $labelsQ {$propsQ})+ RETURN ID($varQ) as $varQ|]++ records <- query getQuery+ forM records $ \record -> do+ nodeIdentity' <- record `at` varQ >>= exact+ pure $ fromInt nodeIdentity'++-- | Every relationship in Bolt protocol starts from one 'Node' and ends in anoter.+-- For given starting and ending 'Node's 'BoltId's, and for @URelationship _ urelType urelProps@+-- this method makes MERGE query and then returns the corresponding 'BoltId'.+--+putRelationship :: (MonadIO m) => BoltId -> PutRelationship -> BoltId -> BoltActionT m BoltId+putRelationship start pr end = case pr of+ (MergeR relationship) -> helper (T.pack "MERGE") relationship+ (CreateR relationship) -> helper (T.pack "CREATE") relationship+ where+ helper :: (MonadIO m) => T.Text -> URelationship -> BoltActionT m BoltId+ helper q URelationship{..} = do+ [record] <- query putQuery+ urelIdentity' <- record `at` varQ >>= exact+ pure $ fromInt urelIdentity'+ where+ varQ = "r"+ labelQ = toCypher urelType+ propsQ = toCypher . toList $ urelProps+ startT = T.pack . show $ start+ endT = T.pack . show $ end++ putQuery :: T.Text+ putQuery = [text|MATCH (a), (b)+ WHERE ID(a) = $startT AND ID(b) = $endT+ $q (a)-[$varQ $labelQ {$propsQ}]->(b)+ RETURN ID($varQ) as $varQ|]++-- | Creates graph using given 'GraphPutRequest'.+-- If there were multiple choices while merging given _vertices, the first match is used for connection.+--+putGraph :: (MonadIO m) => GraphPutRequest -> BoltActionT m GraphPutResponse+putGraph requestGraph = do+ let vertices' = _vertices requestGraph+ let rels = _relations requestGraph+ nodes <- sequenceA $ M.map (fmap head . putNode) vertices'+ edges <- sequenceA $+ mapWithKey (\key v -> do+ let stNode = nodes ! fst key+ let endNode = nodes ! snd key+ putRelationship stNode v endNode) rels+ return $ Graph nodes edges
+ src/Database/Bolt/Extras/Internal/Condition.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ExistentialQuantification #-}++module Database.Bolt.Extras.Internal.Condition+ (+ Condition (..)+ , tautology+ , matches+ , itself+ ) where++-- | Conditional expressions over type 'a' and its mappings.+-- Supported operations:+-- * equality check :==+-- * disunction :&&+-- * conjunction :||+--+-- Typical usage:+-- Say we have variable 'var :: a', a function 'f :: a -> b' and a value 'val :: b'.+-- Expression 'f :== b' acts as 'f a == b'+-- Examples:+--+-- > data D = D { fld1 :: Int+-- > , fld2 :: String+-- > , fld3 :: Double+-- > }+-- >+-- > d = D 42 "noononno" 1.618+-- > d `matches` (fld1 :== 12 :&& fld2 :== "abc")+-- > False+-- >+-- > d `matches` (fld1 :== 42 :|| fld3 == 1.0)+-- > True+--+infix 4 :==+infixr 3 :&&+infixr 2 :||+data Condition a = forall b. Eq b => (a -> b) :== b+ | Condition a :&& Condition a+ | Condition a :|| Condition a+++-- | Check whether data satisfies conditions on it.+--+matches :: a -> Condition a -> Bool+matches obj (transform :== ref) = transform obj == ref+matches obj (u :&& v) = matches obj u && matches obj v+matches obj (u :|| v) = matches obj u || matches obj v+++-- | Matching 'tautology' will always succeed.+-- > whatever `matches` tautology == True+-- > -- Match is lazy:+-- > undefined `matches` tautology == True+--+tautology :: Condition a+tautology = const True :== True+++-- | Object itself instead of its mappings is matched with help of this alias.+-- > 42 `matches` (itself :== 42) == True+-- > 42 `matches` (itself :== 41) == False+--+itself :: a -> a+itself = id
+ src/Database/Bolt/Extras/Internal/Cypher.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Database.Bolt.Extras.Internal.Cypher+ (+ ToCypher (..)+ ) where++-------------------------------------------------------------------------------------------------+-- Queries for neo4j are formatted with `Cypher` language.+-- Read documentation for `Cypher` here: https://neo4j.com/docs/developer-manual/current/cypher/.+-- This file contains some converation rules from 'Database.Bolt' types to `Cypher`.+-------------------------------------------------------------------------------------------------++import Data.Monoid ((<>))+import Data.Text as T (Text, concat, cons,+ intercalate, pack,+ replace, toUpper)+import Database.Bolt (Value (..))+import Database.Bolt.Extras.Internal.Types (Label, Property)+import Database.Bolt.Extras.Utils (currentLoc)+import NeatInterpolation (text)++-- | The class for convertation into Cypher.+--+class ToCypher a where+ toCypher :: a -> Text++-- | Convertation for 'Database.Bolt.Value' into Cypher.+--+instance ToCypher Value where+ toCypher (N ()) = ""+ toCypher (B bool) = toUpper . pack . show $ bool+ toCypher (I int) = pack . show $ int+ toCypher (F double) = pack . show $ double+ toCypher (T t) = "\"" <> escapeSpecSymbols t <> "\""+ toCypher (L values) = let cvalues = T.intercalate "," $ map toCypher values+ in [text|[$cvalues]|]+ toCypher _ = error $ $currentLoc ++ "unacceptable Value type"++escapeSpecSymbols :: Text -> Text+escapeSpecSymbols = replace "\"" "\\\"" . replace "\\" "\\\\"++-- | Label with @name@ are formatted into @:name@+--+instance ToCypher Label where+ toCypher = cons ':'++-- | Several labels are formatted with concatenation.+--+instance ToCypher [Label] where+ toCypher = T.concat . map toCypher++-- | Converts property with @name@ and @value@ to @name:value@.+--+instance ToCypher Property where+ toCypher (propTitle, value) = T.concat [propTitle, pack ":", toCypher value]++-- | Several properties are formatted with concatenation.+--+instance ToCypher [Property] where+ toCypher = T.intercalate "," . map toCypher+
+ src/Database/Bolt/Extras/Internal/Instances.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Database.Bolt.Extras.Internal.Instances () where++import Control.Applicative ((<|>))+import Data.Aeson (FromJSON (..),+ ToJSON (..))+import Data.Aeson.Types (Parser)+import Data.Map.Strict (Map)+import Data.Text (Text)+import Database.Bolt (Value (..))+import qualified Database.Bolt as DB (Structure)+import Database.Bolt.Extras.Internal.Types (FromValue (..),+ ToValue (..))+import Database.Bolt.Extras.Utils (currentLoc)+import GHC.Float (double2Float,+ float2Double)+++instance ToValue () where+ toValue = N++instance ToValue Bool where+ toValue = B++instance ToValue Int where+ toValue = I++instance ToValue Double where+ toValue = F++instance ToValue Float where+ toValue = F . float2Double++instance ToValue Text where+ toValue = T++instance ToValue Value where+ toValue = id++instance ToValue a => ToValue [a] where+ toValue = L . fmap toValue++instance ToValue a => ToValue (Maybe a) where+ toValue (Just a) = toValue a+ toValue _ = toValue ()++instance ToValue (Map Text Value) where+ toValue = M++instance ToValue DB.Structure where+ toValue = S++instance FromValue () where+ fromValue (N ()) = ()+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into ()"++instance FromValue Bool where+ fromValue (B boolV) = boolV+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Bool"++instance FromValue Int where+ fromValue (I intV) = intV+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Int"++instance FromValue Double where+ fromValue (F doubleV) = doubleV+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Double"++instance FromValue Float where+ fromValue (F doubleV) = double2Float doubleV+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Float"++instance FromValue Text where+ fromValue (T textV) = textV+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Text"++instance FromValue Value where+ fromValue = id++instance FromValue a => FromValue [a] where+ fromValue (L listV) = fmap fromValue listV+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into [Value]"++instance FromValue a => FromValue (Maybe a) where+ fromValue (N ()) = Nothing+ fromValue a = Just $ fromValue a++instance FromValue (Map Text Value) where+ fromValue (M mapV) = mapV+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into (Map Text Value)"++instance FromValue DB.Structure where+ fromValue (S structureV) = structureV+ fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Structure"++instance ToJSON Value where+ toJSON (N _) = toJSON ()+ toJSON (B b) = toJSON b+ toJSON (I i) = toJSON i+ toJSON (F f) = toJSON f+ toJSON (T t) = toJSON t+ toJSON (L l) = toJSON l+ toJSON (M m) = toJSON m+ toJSON _ = error "Database.Bolt.Extras.Internal.Instances: could not convert to json Database.Bolt.Value"++instance FromJSON Value where+ parseJSON v = B <$> (parseJSON v :: Parser Bool)+ <|> I <$> (parseJSON v :: Parser Int)+ <|> F <$> (parseJSON v :: Parser Double)+ <|> T <$> (parseJSON v :: Parser Text)+ <|> L <$> (parseJSON v :: Parser [Value])+ <|> M <$> (parseJSON v :: Parser (Map Text Value))+ <|> error "Database.Bolt.Extras.Internal.Instances: could not convert from json Database.Bolt.Value"
+ src/Database/Bolt/Extras/Internal/Persisted.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}++module Database.Bolt.Extras.Internal.Persisted+ (+ BoltId+ , Persisted (..)+ , GetBoltId (..)+ , fromInt+ ) where++import Data.Aeson (FromJSON (..), ToJSON (..),+ genericParseJSON, genericToJSON)+import Data.Aeson.Casing (aesonPrefix, snakeCase)+import Database.Bolt (Node (..), Relationship (..),+ URelationship (..))+import GHC.Generics (Generic (..))++-- | 'BoltId' is alias for Bolt 'Node', 'Relationship' and 'URelationship' identities.+--+type BoltId = Int++-- | 'Persisted' is wrapper for some object that can be identified with 'BoltId'.+--+data Persisted a = Persisted { objectId :: BoltId+ , objectValue :: a+ } deriving (Show, Functor, Eq, Ord, Read, Generic)++-- | This is just check that your 'BoltId' is valid.+--+fromInt :: Int -> BoltId+fromInt i | i >= 0 = i+ | otherwise = error "Database.Bolt.Extras.Internal.Persisted: could not create BoltId with identity less then zero."++-- | Common class to get 'BoltId' from the object.+--+class GetBoltId a where+ getBoltId :: a -> BoltId++instance GetBoltId Node where+ getBoltId = fromInt . nodeIdentity++instance GetBoltId Relationship where+ getBoltId = fromInt . relIdentity++instance GetBoltId URelationship where+ getBoltId = fromInt . urelIdentity++instance GetBoltId (Persisted a) where+ getBoltId = fromInt . objectId++instance ToJSON a => ToJSON (Persisted a) where+ toJSON = genericToJSON $ aesonPrefix snakeCase++instance FromJSON a => FromJSON (Persisted a) where+ parseJSON = genericParseJSON $ aesonPrefix snakeCase
+ src/Database/Bolt/Extras/Internal/Types.hs view
@@ -0,0 +1,67 @@+module Database.Bolt.Extras.Internal.Types+ (+ FromValue (..)+ , Label+ , Labels (..)+ , NodeLike (..)+ , Properties (..)+ , Property+ , ToValue (..)+ , URelationLike (..)+ ) where++import Data.Map.Strict (Map)+import Data.Text (Text)+import Database.Bolt (Node (..), URelationship (..), Value (..))++-- | Alias for Neo4j label.+--+type Label = Text++-- | Alias for Neo4j property.+--+type Property = (Text, Value)++-- | 'NodeLike' class represents convertable into and from 'Node'.+--+class NodeLike a where+ toNode :: a -> Node+ fromNode :: Node -> a++-- | 'URelationLike' class represents convertable into and from 'URelationship'.+--+class URelationLike a where+ toURelation :: a -> URelationship+ fromURelation :: URelationship -> a++-- | 'ToValue' means that something can be converted into Bolt 'Value'.+--+class ToValue a where+ toValue :: a -> Value++-- | 'FromValue' means that something can be converted from Bolt 'Value'.+--+class FromValue a where+ fromValue :: Value -> a++-- | 'Labels' means that labels can be obtained from entity.+--+class Labels a where+ getLabels :: a -> [Label]++instance Labels Node where+ getLabels = labels++instance Labels URelationship where+ getLabels = pure . urelType++-- | 'Properties' means that properties can be obtained from entity.+--+class Properties a where+ getProps :: a -> Map Text Value++instance Properties Node where+ getProps = nodeProps++instance Properties URelationship where+ getProps = urelProps
− src/Database/Bolt/Extras/Persisted.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}--module Database.Bolt.Extras.Persisted- (- BoltId- , Persisted (..)- , GetBoltId (..)- , fromInt- ) where--import Database.Bolt (Node (..), Relationship (..),- URelationship (..))-import Database.Bolt.Extras.Utils (currentLoc)-import GHC.Generics (Generic (..))----- | 'BoltId' is alias for Bolt 'Node', 'Relationship' and 'URelationship' identities.----type BoltId = Int---- | 'Persisted' is wrapper for some object that can be identified with 'BoltId'.----data Persisted a = Persisted { objectId :: BoltId- , objectValue :: a- } deriving (Show, Functor, Eq, Ord, Read, Generic)---- | This is just check that your 'BoltId' is valid.----fromInt :: Int -> BoltId-fromInt i | i >= 0 = i- | otherwise = error $ $currentLoc ++ "could not create BoltId with identity less then zero."---- Common class to get 'BoltId' from the object.----class GetBoltId a where- getBoltId :: a -> BoltId--instance GetBoltId Node where- getBoltId = fromInt . nodeIdentity--instance GetBoltId Relationship where- getBoltId = fromInt . relIdentity--instance GetBoltId URelationship where- getBoltId = fromInt . urelIdentity--instance GetBoltId (Persisted a) where- getBoltId = fromInt . objectId
− src/Database/Bolt/Extras/Query.hs
@@ -1,30 +0,0 @@-module Database.Bolt.Extras.Query- ( GraphGetRequest- , GraphGetResponse- , GraphPutRequest- , GraphPutResponse- , NodeGetter (..)- , NodeName- , PutNode (..)- , PutRelationship (..)- , RelGetter (..)- , ToCypher (..)- , getGraph- , putGraph- , setNode- , deleteNodes- ) where--import Database.Bolt.Extras.Query.Cypher (ToCypher (..))-import Database.Bolt.Extras.Query.Get (GraphGetRequest,- GraphGetResponse,- NodeGetter (..),- RelGetter (..), getGraph)-import Database.Bolt.Extras.Query.Put (GraphPutRequest,- GraphPutResponse,- PutNode (..),- PutRelationship (..),- putGraph)-import Database.Bolt.Extras.Query.Set (setNode)-import Database.Bolt.Extras.Query.Delete (deleteNodes)-import Database.Bolt.Extras.Query.Utils (NodeName)
− src/Database/Bolt/Extras/Query/Cypher.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Database.Bolt.Extras.Query.Cypher- (- ToCypher (..)- ) where------------------------------------------------------------------------------------------------------ Queries for neo4j are formatted with `Cypher` language.--- Read documentation for `Cypher` here: https://neo4j.com/docs/developer-manual/current/cypher/.--- This file contains some converation rules from 'Database.Bolt' types to `Cypher`.----------------------------------------------------------------------------------------------------import Data.Monoid ((<>))-import Data.Text as T (Text, concat, cons,- intercalate, pack, replace,- toUpper)-import Database.Bolt (Value (..))-import Database.Bolt.Extras.Template (Label, Property)-import Database.Bolt.Extras.Utils (currentLoc)-import NeatInterpolation (text)---- | The class for convertation into Cypher.----class ToCypher a where- toCypher :: a -> Text---- | Convertation for 'Database.Bolt.Value' into Cypher.----instance ToCypher Value where- toCypher (N ()) = ""- toCypher (B bool) = toUpper . pack . show $ bool- toCypher (I int) = pack . show $ int- toCypher (F double) = pack . show $ double- toCypher (T t) = "\"" <> escapeSpecSymbols t <> "\""- toCypher (L values) = let cvalues = T.intercalate "," $ map toCypher values- in [text|[$cvalues]|]- toCypher _ = error $ $currentLoc ++ "unacceptable Value type"--escapeSpecSymbols :: Text -> Text-escapeSpecSymbols = replace "\"" "\\\"" . replace "\\" "\\\\"---- | Label with @name@ are formatted into @:name@----instance ToCypher Label where- toCypher = cons ':'---- | Several labels are formatted with concatenation.----instance ToCypher [Label] where- toCypher = T.concat . map toCypher---- | Converts property with @name@ and @value@ to @name:value@.----instance ToCypher Property where- toCypher (propTitle, value) = T.concat [propTitle, pack ":", toCypher value]---- | Several properties are formatted with concatenation.----instance ToCypher [Property] where- toCypher = T.intercalate "," . map toCypher-
− src/Database/Bolt/Extras/Query/Delete.hs
@@ -1,35 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module Database.Bolt.Extras.Query.Delete- (- deleteNodes- ) where--import Control.Monad (forM)-import Control.Monad.IO.Class (MonadIO)-import Data.Text (Text, intercalate, pack)-import Database.Bolt (BoltActionT, RecordValue (..),- at, exact, query)-import Database.Bolt.Extras.Persisted (BoltId, fromInt)-import NeatInterpolation (text)---- | 'deleteNodes' is used to delete all nodes with given 'BoltId's--- and all corresponding relatioships.----deleteNodes :: (MonadIO m) => [BoltId] -> BoltActionT m [BoltId]-deleteNodes boltIds = do- records <- query formQuery- forM records $ \record -> do- nodeIdentity' <- record `at` varQ >>= exact- pure $ fromInt nodeIdentity'- where- varQ = "n"-- formBoltIds :: Text- formBoltIds = intercalate ", " $ fmap (pack . show) boltIds-- formQuery = [text|MATCH ($varQ)- WHERE ID($varQ) IN [$formBoltIds]- DETACH DELETE $varQ- RETURN ID($varQ) as $varQ|]
− src/Database/Bolt/Extras/Query/Get.hs
@@ -1,142 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}--module Database.Bolt.Extras.Query.Get- ( NodeGetter (..)- , GraphGetRequest- , GraphGetResponse- , RelGetter (..)- , getGraph- , nodeAsText- , condIdAsText- ) where--import Control.Monad.IO.Class (MonadIO)-import Data.Map.Strict (Map, keys, mapWithKey,- toList, (!))-import qualified Data.Text as T (Text, concat, empty,- intercalate, pack)-import Database.Bolt (BoltActionT, Node (..),- Record, RecordValue (..),- Relationship (..),- URelationship (..), exact,- query)-import Database.Bolt.Extras.Graph (Graph (..))-import Database.Bolt.Extras.Persisted (BoltId)-import Database.Bolt.Extras.Query.Cypher (ToCypher (..))-import Database.Bolt.Extras.Query.Utils (NodeName)-import Database.Bolt.Extras.Template.Types (Label, Property)-import NeatInterpolation (text)-import Text.Printf (printf)---- | Helper to find 'Node's.----data NodeGetter = NodeGetter { boltIdN :: Maybe BoltId- , labelsN :: Maybe [Label]- , propsN :: Maybe [Property]- } deriving (Show)---- | Helper to find 'URelationship's.----data RelGetter = RelGetter { labelR :: Maybe Label- , propsR :: Maybe [Property]- } deriving (Show)---- | The combinations of 'Getter's to load graph from the database.----type GraphGetRequest = Graph NodeName NodeGetter RelGetter---- | The graph of 'Node's and 'URelationship's which we got from the database using 'GraphGetRequest'.----type GraphGetResponse = Graph NodeName Node URelationship---- | For the given 'GraphGetRequest' find all graphs, which match it.--- This function creates single cypher query and performs it.----getGraph :: (MonadIO m) => [T.Text] -> GraphGetRequest -> BoltActionT m [GraphGetResponse]-getGraph customConds requestGraph = do- response <- query (formQuery customConds nodeVars edgesVars vertices rels)- mapM (\i -> do- nodes <- sequence $ mapOnlyKey (fmap (!! i) . flip exactValues response) vertices- edges <- sequence $ mapOnlyKey (fmap (makeU . (!! i)) . flip exactValues response . namesToText) rels- return (Graph nodes edges)) [0.. length response - 1]- where- vertices :: Map NodeName NodeGetter- vertices = _vertices requestGraph-- rels :: Map (NodeName, NodeName) RelGetter- rels = _relations requestGraph-- nodeVars :: [T.Text]- nodeVars = keys vertices-- edgesVars :: [T.Text]- edgesVars = map (\k -> T.concat [fst k, "0", snd k]) (keys rels)-- exactValues :: (MonadIO m, RecordValue a) => T.Text -> [Record] -> BoltActionT m [a]- exactValues var = mapM (exact . (! var))-- makeU :: Relationship -> URelationship- makeU Relationship{..} = URelationship relIdentity relType relProps-- namesToText :: (NodeName, NodeName) -> T.Text- namesToText (nameA, nameB) = T.concat [nameA, "0", nameB]-- mapOnlyKey :: (k -> b) -> Map k a -> Map k b- mapOnlyKey f = mapWithKey (\k _ -> f k)----- | This function creates cypher query, which is used for getting graph from the database.----formQuery :: [T.Text] -> [T.Text] -> [T.Text] -> Map NodeName NodeGetter -> Map (NodeName, NodeName) RelGetter -> T.Text-formQuery customConds returnNodes returnEdges vertices rels =- [text|MATCH $completeRequest- $conditionsQ- RETURN $completeResponse|]- where- nodes = nodeAsText <$> toList vertices-- conditionsId = intercalateAnd . filter (/= "\n") $ fmap condIdAsText (toList vertices)- customConditions = intercalateAnd customConds- conditions = intercalateAnd . filter (/= T.empty) $ [conditionsId, customConditions]- conditionsQ = if conditions == T.empty then "" else T.concat ["WHERE ", conditions]-- edges = fmap (relationshipAsText vertices) (toList rels)-- completeRequest = T.intercalate "," $ nodes ++ edges- completeResponse = T.intercalate "," $ returnNodes ++ returnEdges-- intercalateAnd :: [T.Text] -> T.Text- intercalateAnd = T.intercalate " AND "--condIdAsText :: (NodeName, NodeGetter) -> T.Text-condIdAsText (name, sel) = [text|$boltIdNR|]- where- boltIdNR = maybeNull (T.pack . printf "ID(%s)=%d" name) (boltIdN sel)--nodeAsText :: (NodeName, NodeGetter) -> T.Text-nodeAsText (name, sel) = [text|($name $labels $propsQ)|]- where- labels = maybeNull toCypher (labelsN sel)- propsQ = maybeNull (\props -> T.concat ["{", toCypher props, "}"]) (propsN sel)--relationshipAsText :: Map NodeName NodeGetter -> ((NodeName, NodeName), RelGetter) -> T.Text-relationshipAsText vertices ((begNodeName, endNodeName), uRel) =- [text|($begNodeName $begNodeLabels $begNodeProps)-[$name $typeQ $propsQ]-($endNodeName $endNodeLabels $endNodeProps)|]- where- name = T.concat [begNodeName, "0", endNodeName]- typeQ = maybeNull toCypher (labelR uRel)-- begNode = vertices ! begNodeName- begNodeLabels = maybeNull toCypher $ labelsN begNode- begNodeProps = maybeNull (\props -> T.concat ["{", toCypher props, "}"]) (propsN begNode)-- endNode = vertices ! endNodeName- endNodeLabels = maybeNull toCypher $ labelsN endNode- endNodeProps = maybeNull (\props -> T.concat ["{", toCypher props, "}"]) (propsN endNode)-- propsQ = maybeNull (\props -> T.concat ["{", toCypher props, "}"]) (propsR uRel)--maybeNull :: (a -> T.Text) -> Maybe a -> T.Text-maybeNull = maybe ""
− src/Database/Bolt/Extras/Query/Put.hs
@@ -1,117 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}--module Database.Bolt.Extras.Query.Put- ( GraphPutRequest- , GraphPutResponse- , PutNode (..)- , PutRelationship (..)- , putGraph- ) where--import Control.Monad (forM)-import Control.Monad.IO.Class (MonadIO)-import Data.Map.Strict (mapWithKey, toList, (!))-import qualified Data.Map.Strict as M (map)-import qualified Data.Text as T (Text, pack)-import Database.Bolt (BoltActionT, Node (..),- RecordValue (..),- URelationship (..),- Value (..), at, exact,- query)-import Database.Bolt.Extras.Graph (Graph (..))-import Database.Bolt.Extras.Persisted (BoltId, fromInt)-import Database.Bolt.Extras.Query.Cypher (ToCypher (..))-import Database.Bolt.Extras.Query.Utils (NodeName)-import NeatInterpolation (text)---- | 'PutNode' is the wrapper for 'Node' where we can specify if we want to merge or create it.----data PutNode = BoltId BoltId | MergeN Node | CreateN Node- deriving (Show)---- | 'PutRelationship' is the wrapper for 'Relationship' where we can specify if we want to merge or create it.----data PutRelationship = MergeR URelationship | CreateR URelationship- deriving (Show)---- | The graph of 'Node's with specified uploading type and 'URelationship's.----type GraphPutRequest = Graph NodeName PutNode PutRelationship---- | The graph of 'BoltId's corresponding to the nodes and relationships--- which we get after putting 'GraphPutRequest'.----type GraphPutResponse = Graph NodeName BoltId BoltId---- | For given @Node _ labels nodeProps@ makes query MERGE or CREATE depending--- on the type of 'PutNode' and returns 'BoltId' of the loaded 'Node'.--- If we already know 'BoltId' of the 'Node' with such parameters, this function does nothing.------ Potentially, if you MERGE some 'Node' and its labels and props are occured in--- several 'Node's, then the result can be not one but several 'Node's,--- so the result of this function will be a list of corresponding 'BoltId's.----putNode :: (MonadIO m) => PutNode -> BoltActionT m [BoltId]-putNode ut = case ut of- (BoltId bId) -> pure [bId]- (MergeN node) -> helper (T.pack "MERGE") node- (CreateN node) -> helper (T.pack "CREATE") node- where- helper :: (MonadIO m) => T.Text -> Node -> BoltActionT m [BoltId]- helper q node = do- let varQ = "n"-- let labelsQ = toCypher $ labels node- let propsQ = toCypher . filter ((/= N ()) . snd) . toList $ nodeProps node-- let getQuery = [text|$q ($varQ $labelsQ {$propsQ})- RETURN ID($varQ) as $varQ|]-- records <- query getQuery- forM records $ \record -> do- nodeIdentity' <- record `at` varQ >>= exact- pure $ fromInt nodeIdentity'---- | Every relationship in Bolt protocol starts from one 'Node' and ends in anoter.--- For given starting and ending 'Node's 'BoltId's, and for @URelationship _ urelType urelProps@--- this method makes MERGE query and then returns the corresponding 'BoltId'.----putRelationship :: (MonadIO m) => BoltId -> PutRelationship -> BoltId -> BoltActionT m BoltId-putRelationship start pr end = case pr of- (MergeR relationship) -> helper (T.pack "MERGE") relationship- (CreateR relationship) -> helper (T.pack "CREATE") relationship- where- helper :: (MonadIO m) => T.Text -> URelationship -> BoltActionT m BoltId- helper q URelationship{..} = do- [record] <- query putQuery- urelIdentity' <- record `at` varQ >>= exact- pure $ fromInt urelIdentity'- where- varQ = "r"- labelQ = toCypher urelType- propsQ = toCypher . toList $ urelProps- startT = T.pack . show $ start- endT = T.pack . show $ end-- putQuery :: T.Text- putQuery = [text|MATCH (a), (b)- WHERE ID(a) = $startT AND ID(b) = $endT- $q (a)-[$varQ $labelQ {$propsQ}]->(b)- RETURN ID($varQ) as $varQ|]---- | Creates graph using given 'GraphPutRequest'.--- If there were multiple choices while merging given _vertices, the first match is used for connection.----putGraph :: (MonadIO m) => GraphPutRequest -> BoltActionT m GraphPutResponse-putGraph requestGraph = do- let vertices = _vertices requestGraph- let rels = _relations requestGraph- nodes <- sequenceA $ M.map (fmap head . putNode) vertices- edges <- sequenceA $- mapWithKey (\key v -> do- let stNode = nodes ! fst key- let endNode = nodes ! snd key- putRelationship stNode v endNode) rels- return $ Graph nodes edges
− src/Database/Bolt/Extras/Query/Set.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module Database.Bolt.Extras.Query.Set- (- setNode- ) where--import Control.Monad.IO.Class (MonadIO)-import Data.Monoid ((<>))-import Data.Text (Text, intercalate)-import Database.Bolt (BoltActionT,- RecordValue (..),- Value (..), at, exact,- query)-import Database.Bolt.Extras.Persisted (BoltId, fromInt)-import Database.Bolt.Extras.Query.Cypher (ToCypher (..))-import Database.Bolt.Extras.Query.Get (NodeGetter, condIdAsText,- nodeAsText)-import Database.Bolt.Extras.Template.Types (Property)-import NeatInterpolation (text)---- | 'setNode' updates properties for the node,--- corresponding to the given 'NodeGetter'.----setNode :: (MonadIO m) => NodeGetter -> [Property] -> BoltActionT m BoltId-setNode nodeGetter props = do- let nodeGetterT = nodeAsText (varQ, nodeGetter)- let condId = condIdAsText (varQ, nodeGetter)-- let newProperties = intercalate "," $ formPropertySet <$> filter ((/= N ()) . snd) props-- let getQuery = [text|MATCH $nodeGetterT- WHERE $condId- SET $newProperties- RETURN ID($varQ) as $varQ|]-- record <- head <$> query getQuery- nodeIdentity' <- record `at` varQ >>= exact- pure $ fromInt nodeIdentity'-- where- varQ = "n"-- formPropertyName :: Text -> Text- formPropertyName n = varQ <> "." <> n-- formPropertySet :: Property -> Text- formPropertySet (name, prop) = formPropertyName name <> "=" <> toCypher prop
− src/Database/Bolt/Extras/Query/Utils.hs
@@ -1,7 +0,0 @@-module Database.Bolt.Extras.Query.Utils- ( NodeName- ) where--import Data.Text (Text)--type NodeName = Text
src/Database/Bolt/Extras/Template.hs view
@@ -1,32 +1,7 @@ module Database.Bolt.Extras.Template- ( FromValue (..)- , Label- , Labels (..)- , Node (..)- , NodeLike (..)- , Properties (..)- , Property- , Relationship (..)- , ToValue (..)- , URelationLike (..)- , URelationship (..)- , Value (..)- , makeNodeLike- , makeURelationLike+ (+ module Database.Bolt.Extras.Template.Internal.Converters ) where -import Database.Bolt.Extras.Template.Converters (makeNodeLike,- makeURelationLike)-import Database.Bolt.Extras.Template.Instances ()-import Database.Bolt.Extras.Template.Types (FromValue (..),- Label, Labels (..),- Node (..),- NodeLike (..),- Properties (..),- Property,- Relationship (..),- ToValue (..),- URelationLike (..),- URelationship (..),- Value (..))+import Database.Bolt.Extras.Template.Internal.Converters
− src/Database/Bolt/Extras/Template/Converters.hs
@@ -1,301 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--module Database.Bolt.Extras.Template.Converters- (- makeNodeLike- , makeURelationLike- ) where--import Control.Lens (view, _1)-import Control.Monad ((>=>))-import Data.Map.Strict (fromList, member,- notMember, (!))-import Data.Text (Text, pack, unpack)-import Database.Bolt.Extras.Template.Types (FromValue (..),- Labels (..), Node (..),- NodeLike (..),- Properties (..),- ToValue (..),- URelationLike (..),- URelationship (..),- Value (..))-import Database.Bolt.Extras.Utils (currentLoc, dummyId)-import Instances.TH.Lift ()-import Language.Haskell.TH-import Language.Haskell.TH.Syntax---- | Describes a @bijective@ class, i.e. class that has two functions: @phi :: a -> SomeType@ and @phiInv :: SomeType -> a@.--- Requires class name, @SomeType@ name and names of the class functions (@phi@ and @phiInv@).----data BiClassInfo = BiClassInfo { className :: Name- , dataName :: Name- , classToFun :: Name- , classFromFun :: Name- }---- | Example of @bijective@ class is 'NodeLike'.--- Describes conversions into and from 'Node'.--- That is, this class provides a bridge between Neo4j world and Haskell world.----nodeLikeClass :: BiClassInfo-nodeLikeClass = BiClassInfo { className = ''NodeLike- , dataName = 'Node- , classToFun = 'toNode- , classFromFun = 'fromNode- }---- | Another example of @bijective@ class is 'URelationLike'.--- Describes conversions into and from 'URelationship'.----uRelationLikeClass :: BiClassInfo-uRelationLikeClass = BiClassInfo { className = ''URelationLike- , dataName = 'URelationship- , classToFun = 'toURelation- , classFromFun = 'fromURelation- }---- | Make an instance of 'NodeLike' class.--- Only data types with one constructor are currently supported.--- Each field is transformed into 'Text' key and its value is transformed into a 'Value'.--- For example, we have a structure------ > data Foo = Bar { baz :: Double--- > , quux :: Text--- > , quuz :: Int--- > }------ You can make it instance of NodeClass by writing--- > makeNodeLike ''Foo------ Then you may create example and convert it into from from Node:------ > ghci>:set -XOverloadedStrings--- > ghci> let foo = Bar 42.0 "Loren ipsum" 7--- > ghci> toNode foo--- > Node {nodeIdentity = -1, labels = ["Foo"], nodeProps = fromList [("baz",F 42.0),("quux",T "Loren ipsum"),("quuz",I 7)]}--- > ghci> fromNode . toNode $ foo :: Foo--- > Bar {baz = 42.0, quux = "Loren ipsum", quuz = 7}----makeNodeLike :: Name -> Q [Dec]-makeNodeLike = makeBiClassInstance nodeLikeClass----- | Make an instance of 'URelationLike' class.--- Transformations are the same as in 'NodeLike' instance declaration with the only one difference:--- 'URelationship' holds only one label (or type), but 'Node' holds list of labels.----makeURelationLike :: Name -> Q [Dec]-makeURelationLike = makeBiClassInstance uRelationLikeClass----- | Declare an instance of `bijective` class using TemplateHaskell.--- It works as follows:--- Say we have a type with field records, e.g.------ > data VariableDomainScoring = VDS { specie :: Text--- > , vgen :: Double--- > , fr :: Double--- > , sim :: Double--- > , germline :: Text--- > }------ As an example, transformation into Node is described below.------ > data Node = Node { nodeIdentity :: Int -- ^Neo4j node identifier--- > , labels :: [Text] -- ^Set of node labels (types)--- > , nodeProps :: Map Text Value -- ^Dict of node properties--- > }--- > deriving (Show, Eq)------ @nodeIdentity@ will be set to a dummy value (-1). There is no way of obtaining object ID before uploading it into database.--- @labels@ will be set to type name, i.e. @VariableDomainScoring@. This is due to our convention: object label into Neo4j is the same as its type name in Haskell.--- @nodeProps@ will be set to a Map: keys are field record names, values are data in the corresponding fields.------ Therefore, applying toNode on a @VariableDomainScoring@ will give the following:--- > Node { nodeIdentity = -1--- > , labels = ["VariableDomainScoring"]--- > , nodeProps = fromList [("specie", T "text value"), ("vgen", F %float_value), ("fr", F %float_value), ("sim", F %float_value), ("germline", T "text value")]--- > }----makeBiClassInstance :: BiClassInfo -> Name -> Q [Dec]-makeBiClassInstance BiClassInfo {..} typeCon = do- -- reify function gives Info about Name such as constructor name and its fields. See: https://hackage.haskell.org/package/template-haskell-2.12.0.0/docs/Language-Haskell-TH.html#t:Info- TyConI declaration <- reify typeCon-- -- get type declaration parameters: type name and fields. Supports data and newtype only. These will be used in properties Map formation.- let (tyName, constr) = getTypeCons declaration-- -- nameBase gives object name without package prefix. `label` is the type name here.- let label = nameBase tyName-- -- collects the names of all fields in the type.- let dataFields = concatMap (snd . getConsFields) constr-- -- gets data constructor name- let (consName, _) = head $ fmap getConsFields constr-- -- Just a fresh variable. It will be used in labmda abstractions in makeToClause and makeFromClause functions.- fresh <- newName "x"-- -- constructs `bijective` class functions (phi and phiInv – toClause and fromClause correspondingly here).- toClause <- makeToClause label dataName fresh dataFields- fromClause <- makeFromClause label consName fresh dataFields-- -- function declarations themselves.- let bodyDecl = [FunD classToFun [toClause], FunD classFromFun [fromClause]]-- -- Instance declaration itself.- pure [InstanceD Nothing [] (AppT (ConT className) (ConT typeCon)) bodyDecl]------ | Extract information about type: constructor name and field record names.----getConsFields :: Con -> (Name, [Name])-getConsFields (RecC cName decs) = (cName, fmap (view _1) decs)-getConsFields (ForallC _ _ cons) = getConsFields cons-getConsFields (RecGadtC (cName:_) decs _) = (cName, fmap (view _1) decs)-getConsFields (NormalC cName _) = (cName, [])-getConsFields _ = error $ $currentLoc ++ "unsupported data declaration."----- | Parse a type declaration and retrieve its name and its constructors.----getTypeCons :: Dec -> (Name, [Con])-getTypeCons (DataD _ typeName _ _ constructors _) = (typeName, constructors)-getTypeCons (NewtypeD _ typeName _ _ constructor _) = (typeName, [constructor])-getTypeCons otherDecl = error $ $currentLoc ++ "unsupported declaration: " ++ show otherDecl ++ "\nShould be either 'data' or 'newtype'."---- | Describes the body of conversion to target type function.----makeToClause :: String -> Name -> Name -> [Name] -> Q Clause-makeToClause label dataCons varName dataFields | null dataFields = pure $ Clause [WildP] (NormalB result) []- | otherwise = pure $ Clause [VarP varName] (NormalB result) []- where- -- apply field record to a data.- getValue :: Name -> Exp- getValue name = AppE (VarE name) (VarE varName)-- -- List of values which a data holds.- -- The same in terms of Haskell :: valuesExp = fmap (\field -> toValue (field x))- -- `x` is a bounded in pattern match variable (e.g. toNode x = ...). If toNode :: a -> Node, then x :: a, i.e. x is data which we want to convert into Node.- -- `field` is a field record function.- valuesExp :: [Exp]- valuesExp = fmap (\fld -> AppE (VarE 'toValue) (getValue fld)) dataFields-- -- Retrieve all field record names from the convertible type.- fieldNames :: [String]- fieldNames = fmap nameBase dataFields-- -- List of pairs :: [(key, value)]- -- `key` is field record name.- -- `value` is the data that corresponding field holds.- pairs :: [Exp]- pairs = zipWith (\fld val -> TupE [strToTextE fld, val]) fieldNames valuesExp-- -- Map representation:- -- mapE = fromList pairs- -- in terms of Haskell.- mapE :: Exp- mapE = AppE (VarE 'fromList) (ListE pairs)-- -- A bit of crutches.- -- The difference between Node and URelationship is in the number of labels they hold.- -- strToTextE returns Text packed in Exp so `id` is applied to it when constructing URelationship.- -- Node takes list of labels so the label must be packed into list using ListE . (:[])- fieldFun :: Exp -> Exp- fieldFun | nameBase dataCons == "URelationship" = id- | nameBase dataCons == "Node" = ListE . (:[])- | otherwise = error $ $currentLoc ++ "unsupported data type."-- -- In terms of Haskell:- -- dataCons (fromIntegral dummyId) (fieldFun label) mapE- -- Constructs data with three fields.- result :: Exp- result = AppE (AppE (AppE (ConE dataCons) (LitE . IntegerL . fromIntegral $ dummyId)) (fieldFun $ strToTextE label)) mapE----- | Describes the body of conversion from target type function.----makeFromClause :: String -> Name -> Name -> [Name] -> Q Clause-makeFromClause label conName varName dataFields = do-- -- Obtain all data field types.- -- 'reify' returns 'Q Info', and we are interested in its 'VarI' constructur which provides information about variable: name and type.- -- To obtain field type, one should get the second field record of VarI.- fieldTypes <- mapM (reify >=> extractVarType) dataFields-- -- Contains 'True' in each position where 'Maybe a' type occured and 'False' everywhere else.- let maybeFields = fmap isMaybe fieldTypes-- -- fieldNames :: [Text]- -- field records of the target type.- let fieldNames = fmap (pack . nameBase) dataFields-- -- maybeLabels :: [(Text, Bool)]- -- field records of the target type and 'isMaybe' check results.- let maybeNames = zip fieldNames maybeFields-- -- dataLabel :: Text- -- Label a.k.a type name- let dataLabel = pack label-- -- Field record names packed in Exp- -- \x -> [|x|] :: a -> Q Exp- -- Therefore, fieldNamesE :: [Exp]- fieldNamesE <- mapM (\x -> [|x|]) fieldNames-- -- maybeNamesE :: [Exp]- -- Contains Exp representation of (Text, Bool) – field name and isMaybe check result on it.- let maybeNamesE = zipWith (\n m -> TupE [n, ConE $ if m then trueName else falseName]) fieldNamesE maybeFields-- -- varExp :: Q Exp- -- Pattern match variable packed in Exp. It will be used in QuasiQuotation below.- let varExp = pure (VarE varName)-- -- Guard checks that all necessary fields are present in the container.- guardSuccess <- NormalG <$> [|checkLabels $(varExp) [dataLabel] && checkProps $(varExp) maybeNames|]-- -- `otherwise` case.- guardFail <- NormalG <$> [|otherwise|]-- -- Unpack error message.- failExp <- [|unpackError $(varExp) (unpack dataLabel)|]-- -- Kind of this function realization in terms of Haskell:- -- fromNode :: Node -> a- -- fromNode varName | checkLabels varName [dataLabel] && checkProps varName fieldNames = ConName { foo = bar, baz = quux ...}- -- | otherwise = unpackError varName (unpack dataLabel)- let successExp = RecConE conName (zipWith (\f fldName -> (fldName, AppE (AppE (VarE 'getProp) (VarE varName)) f)) maybeNamesE dataFields)- let successCase = (guardSuccess, successExp)- let failCase = (guardFail, failExp)-- pure $ Clause [VarP varName] (GuardedB [successCase, failCase]) []---extractVarType :: Info -> Q Type-extractVarType (VarI _ fieldType _) = pure fieldType-extractVarType _ = error ($currentLoc ++ "this can not happen.")---- | Check whether given type is '_ -> Maybe _'--- It pattern matches arrow type applied to any argument ant 'T _' and checks if T is ''Maybe-isMaybe :: Type -> Bool-isMaybe (AppT (AppT ArrowT _) (AppT (ConT t) _)) = t == ''Maybe-isMaybe _ = False--strToTextE :: String -> Exp-strToTextE str = AppE (VarE 'pack) (LitE . StringL $ str)--checkProps :: Properties t => t -> [(Text, Bool)] -> Bool-checkProps container = all (\(fieldName, fieldMaybe) -> fieldMaybe || fieldName `member` getProps container)--checkLabels :: Labels t => t -> [Text] -> Bool-checkLabels container = all (`elem` getLabels container)--getProp :: (Properties t, FromValue a) => t -> (Text, Bool) -> a-getProp container (fieldName, fieldMaybe) | fieldMaybe && fieldName `notMember` getProps container = fromValue $ N ()- | otherwise = fromValue (getProps container ! fieldName)--unpackError :: Show c => c -> String -> a-unpackError container label = error $ $currentLoc ++ " could not unpack " ++ label ++ " from " ++ show container
− src/Database/Bolt/Extras/Template/Instances.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Database.Bolt.Extras.Template.Instances () where--import Data.Map.Strict (Map)-import Data.Text (Text)-import Database.Bolt (Value (..))-import qualified Database.Bolt as DB (Structure)-import Database.Bolt.Extras.Template.Types (FromValue (..),- ToValue (..))-import Database.Bolt.Extras.Utils (currentLoc)-import GHC.Float (double2Float,- float2Double)--instance ToValue () where- toValue = N--instance ToValue Bool where- toValue = B--instance ToValue Int where- toValue = I--instance ToValue Double where- toValue = F--instance ToValue Float where- toValue = F . float2Double--instance ToValue Text where- toValue = T--instance ToValue Value where- toValue = id--instance ToValue a => ToValue [a] where- toValue = L . fmap toValue--instance ToValue a => ToValue (Maybe a) where- toValue (Just a) = toValue a- toValue _ = toValue ()--instance ToValue (Map Text Value) where- toValue = M--instance ToValue DB.Structure where- toValue = S--instance FromValue () where- fromValue (N ()) = ()- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into ()"--instance FromValue Bool where- fromValue (B boolV) = boolV- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Bool"--instance FromValue Int where- fromValue (I intV) = intV- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Int"--instance FromValue Double where- fromValue (F doubleV) = doubleV- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Double"--instance FromValue Float where- fromValue (F doubleV) = double2Float doubleV- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Float"--instance FromValue Text where- fromValue (T textV) = textV- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Text"--instance FromValue Value where- fromValue = id--instance FromValue a => FromValue [a] where- fromValue (L listV) = fmap fromValue listV- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into [Value]"--instance FromValue a => FromValue (Maybe a) where- fromValue (N ()) = Nothing- fromValue a = Just $ fromValue a--instance FromValue (Map Text Value) where- fromValue (M mapV) = mapV- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into (Map Text Value)"--instance FromValue DB.Structure where- fromValue (S structureV) = structureV- fromValue v = error $ $currentLoc ++ "could not unpack " ++ show v ++ " into Structure"
+ src/Database/Bolt/Extras/Template/Internal/Converters.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.Bolt.Extras.Template.Internal.Converters+ (+ makeNodeLike+ , makeURelationLike+ ) where++import Control.Lens (view, _1)+import Control.Monad ((>=>))+import Data.Map.Strict (fromList, member, notMember, (!))+import Data.Text (Text, pack, unpack)+import Database.Bolt (Node (..), URelationship (..), Value (..))+import Database.Bolt.Extras (FromValue (..), Labels (..),+ NodeLike (..),+ Properties (..), ToValue (..),+ URelationLike (..))+import Database.Bolt.Extras.Utils (currentLoc, dummyId)+import Instances.TH.Lift ()+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++-- | Describes a @bijective@ class, i.e. class that has two functions: @phi :: a -> SomeType@ and @phiInv :: SomeType -> a@.+-- Requires class name, @SomeType@ name and names of the class functions (@phi@ and @phiInv@).+--+data BiClassInfo = BiClassInfo { className :: Name+ , dataName :: Name+ , classToFun :: Name+ , classFromFun :: Name+ }++-- | Example of @bijective@ class is 'NodeLike'.+-- Describes conversions into and from 'Node'.+-- That is, this class provides a bridge between Neo4j world and Haskell world.+--+nodeLikeClass :: BiClassInfo+nodeLikeClass = BiClassInfo { className = ''NodeLike+ , dataName = 'Node+ , classToFun = 'toNode+ , classFromFun = 'fromNode+ }++-- | Another example of @bijective@ class is 'URelationLike'.+-- Describes conversions into and from 'URelationship'.+--+uRelationLikeClass :: BiClassInfo+uRelationLikeClass = BiClassInfo { className = ''URelationLike+ , dataName = 'URelationship+ , classToFun = 'toURelation+ , classFromFun = 'fromURelation+ }++-- | Make an instance of 'NodeLike' class.+-- Only data types with one constructor are currently supported.+-- Each field is transformed into 'Text' key and its value is transformed into a 'Value'.+-- For example, we have a structure+--+-- > data Foo = Bar { baz :: Double+-- > , quux :: Text+-- > , quuz :: Int+-- > }+--+-- You can make it instance of NodeClass by writing+-- > makeNodeLike ''Foo+--+-- Then you may create example and convert it into from from Node:+--+-- > ghci>:set -XOverloadedStrings+-- > ghci> let foo = Bar 42.0 "Loren ipsum" 7+-- > ghci> toNode foo+-- > Node {nodeIdentity = -1, labels = ["Foo"], nodeProps = fromList [("baz",F 42.0),("quux",T "Loren ipsum"),("quuz",I 7)]}+-- > ghci> fromNode . toNode $ foo :: Foo+-- > Bar {baz = 42.0, quux = "Loren ipsum", quuz = 7}+--+makeNodeLike :: Name -> Q [Dec]+makeNodeLike = makeBiClassInstance nodeLikeClass+++-- | Make an instance of 'URelationLike' class.+-- Transformations are the same as in 'NodeLike' instance declaration with the only one difference:+-- 'URelationship' holds only one label (or type), but 'Node' holds list of labels.+--+makeURelationLike :: Name -> Q [Dec]+makeURelationLike = makeBiClassInstance uRelationLikeClass+++-- | Declare an instance of `bijective` class using TemplateHaskell.+-- It works as follows:+-- Say we have a type with field records, e.g.+--+-- > data VariableDomainScoring = VDS { specie :: Text+-- > , vgen :: Double+-- > , fr :: Double+-- > , sim :: Double+-- > , germline :: Text+-- > }+--+-- As an example, transformation into Node is described below.+--+-- > data Node = Node { nodeIdentity :: Int -- ^Neo4j node identifier+-- > , labels :: [Text] -- ^Set of node labels (types)+-- > , nodeProps :: Map Text Value -- ^Dict of node properties+-- > }+-- > deriving (Show, Eq)+--+-- @nodeIdentity@ will be set to a dummy value (-1). There is no way of obtaining object ID before uploading it into database.+-- @labels@ will be set to type name, i.e. @VariableDomainScoring@. This is due to our convention: object label into Neo4j is the same as its type name in Haskell.+-- @nodeProps@ will be set to a Map: keys are field record names, values are data in the corresponding fields.+--+-- Therefore, applying toNode on a @VariableDomainScoring@ will give the following:+-- > Node { nodeIdentity = -1+-- > , labels = ["VariableDomainScoring"]+-- > , nodeProps = fromList [("specie", T "text value"), ("vgen", F %float_value), ("fr", F %float_value), ("sim", F %float_value), ("germline", T "text value")]+-- > }+--+makeBiClassInstance :: BiClassInfo -> Name -> Q [Dec]+makeBiClassInstance BiClassInfo {..} typeCon = do+ -- reify function gives Info about Name such as constructor name and its fields. See: https://hackage.haskell.org/package/template-haskell-2.12.0.0/docs/Language-Haskell-TH.html#t:Info+ TyConI declaration <- reify typeCon++ -- get type declaration parameters: type name and fields. Supports data and newtype only. These will be used in properties Map formation.+ let (tyName, constr) = getTypeCons declaration++ -- nameBase gives object name without package prefix. `label` is the type name here.+ let label = nameBase tyName++ -- collects the names of all fields in the type.+ let dataFields = concatMap (snd . getConsFields) constr++ -- gets data constructor name+ let (consName, _) = head $ fmap getConsFields constr++ -- Just a fresh variable. It will be used in labmda abstractions in makeToClause and makeFromClause functions.+ fresh <- newName "x"++ -- constructs `bijective` class functions (phi and phiInv – toClause and fromClause correspondingly here).+ toClause <- makeToClause label dataName fresh dataFields+ fromClause <- makeFromClause label consName fresh dataFields++ -- function declarations themselves.+ let bodyDecl = [FunD classToFun [toClause], FunD classFromFun [fromClause]]++ -- Instance declaration itself.+ pure [InstanceD Nothing [] (AppT (ConT className) (ConT typeCon)) bodyDecl]++++-- | Extract information about type: constructor name and field record names.+--+getConsFields :: Con -> (Name, [Name])+getConsFields (RecC cName decs) = (cName, fmap (view _1) decs)+getConsFields (ForallC _ _ cons) = getConsFields cons+getConsFields (RecGadtC (cName:_) decs _) = (cName, fmap (view _1) decs)+getConsFields (NormalC cName _) = (cName, [])+getConsFields _ = error $ $currentLoc ++ "unsupported data declaration."+++-- | Parse a type declaration and retrieve its name and its constructors.+--+getTypeCons :: Dec -> (Name, [Con])+getTypeCons (DataD _ typeName _ _ constructors _) = (typeName, constructors)+getTypeCons (NewtypeD _ typeName _ _ constructor _) = (typeName, [constructor])+getTypeCons otherDecl = error $ $currentLoc ++ "unsupported declaration: " ++ show otherDecl ++ "\nShould be either 'data' or 'newtype'."++-- | Describes the body of conversion to target type function.+--+makeToClause :: String -> Name -> Name -> [Name] -> Q Clause+makeToClause label dataCons varName dataFields | null dataFields = pure $ Clause [WildP] (NormalB result) []+ | otherwise = pure $ Clause [VarP varName] (NormalB result) []+ where+ -- apply field record to a data.+ getValue :: Name -> Exp+ getValue name = AppE (VarE name) (VarE varName)++ -- List of values which a data holds.+ -- The same in terms of Haskell :: valuesExp = fmap (\field -> toValue (field x))+ -- `x` is a bounded in pattern match variable (e.g. toNode x = ...). If toNode :: a -> Node, then x :: a, i.e. x is data which we want to convert into Node.+ -- `field` is a field record function.+ valuesExp :: [Exp]+ valuesExp = fmap (AppE (VarE 'toValue) . getValue) dataFields++ -- Retrieve all field record names from the convertible type.+ fieldNames :: [String]+ fieldNames = fmap nameBase dataFields++ -- List of pairs :: [(key, value)]+ -- `key` is field record name.+ -- `value` is the data that corresponding field holds.+ pairs :: [Exp]+ pairs = zipWith (\fld val -> TupE [strToTextE fld, val]) fieldNames valuesExp++ -- Map representation:+ -- mapE = fromList pairs+ -- in terms of Haskell.+ mapE :: Exp+ mapE = AppE (VarE 'fromList) (ListE pairs)++ -- A bit of crutches.+ -- The difference between Node and URelationship is in the number of labels they hold.+ -- strToTextE returns Text packed in Exp so `id` is applied to it when constructing URelationship.+ -- Node takes list of labels so the label must be packed into list using ListE . (:[])+ fieldFun :: Exp -> Exp+ fieldFun | nameBase dataCons == "URelationship" = id+ | nameBase dataCons == "Node" = ListE . (:[])+ | otherwise = error $ $currentLoc ++ "unsupported data type."++ -- In terms of Haskell:+ -- dataCons (fromIntegral dummyId) (fieldFun label) mapE+ -- Constructs data with three fields.+ result :: Exp+ result = AppE (AppE (AppE (ConE dataCons) (LitE . IntegerL . fromIntegral $ dummyId)) (fieldFun $ strToTextE label)) mapE+++-- | Describes the body of conversion from target type function.+--+makeFromClause :: String -> Name -> Name -> [Name] -> Q Clause+makeFromClause label conName varName dataFields = do++ -- Obtain all data field types.+ -- 'reify' returns 'Q Info', and we are interested in its 'VarI' constructur which provides information about variable: name and type.+ -- To obtain field type, one should get the second field record of VarI.+ fieldTypes <- mapM (reify >=> extractVarType) dataFields++ -- Contains 'True' in each position where 'Maybe a' type occured and 'False' everywhere else.+ let maybeFields = fmap isMaybe fieldTypes++ -- fieldNames :: [Text]+ -- field records of the target type.+ let fieldNames = fmap (pack . nameBase) dataFields++ -- maybeLabels :: [(Text, Bool)]+ -- field records of the target type and 'isMaybe' check results.+ let maybeNames = zip fieldNames maybeFields++ -- dataLabel :: Text+ -- Label a.k.a type name+ let dataLabel = pack label++ -- Field record names packed in Exp+ -- \x -> [|x|] :: a -> Q Exp+ -- Therefore, fieldNamesE :: [Exp]+ fieldNamesE <- mapM (\x -> [|x|]) fieldNames++ -- maybeNamesE :: [Exp]+ -- Contains Exp representation of (Text, Bool) – field name and isMaybe check result on it.+ let maybeNamesE = zipWith (\n m -> TupE [n, ConE $ if m then trueName else falseName]) fieldNamesE maybeFields++ -- varExp :: Q Exp+ -- Pattern match variable packed in Exp. It will be used in QuasiQuotation below.+ let varExp = pure (VarE varName)++ -- Guard checks that all necessary fields are present in the container.+ guardSuccess <- NormalG <$> [|checkLabels $(varExp) [dataLabel] && checkProps $(varExp) maybeNames|]++ -- `otherwise` case.+ guardFail <- NormalG <$> [|otherwise|]++ -- Unpack error message.+ failExp <- [|unpackError $(varExp) (unpack dataLabel)|]++ -- Kind of this function realization in terms of Haskell:+ -- fromNode :: Node -> a+ -- fromNode varName | checkLabels varName [dataLabel] && checkProps varName fieldNames = ConName { foo = bar, baz = quux ...}+ -- | otherwise = unpackError varName (unpack dataLabel)+ let successExp = RecConE conName (zipWith (\f fldName -> (fldName, AppE (AppE (VarE 'getProp) (VarE varName)) f)) maybeNamesE dataFields)+ let successCase = (guardSuccess, successExp)+ let failCase = (guardFail, failExp)++ pure $ Clause [VarP varName] (GuardedB [successCase, failCase]) []+++extractVarType :: Info -> Q Type+extractVarType (VarI _ fieldType _) = pure fieldType+extractVarType _ = error ($currentLoc ++ "this can not happen.")++-- | Check whether given type is '_ -> Maybe _'+-- It pattern matches arrow type applied to any argument ant 'T _' and checks if T is ''Maybe+isMaybe :: Type -> Bool+isMaybe (AppT (AppT ArrowT _) (AppT (ConT t) _)) = t == ''Maybe+isMaybe _ = False++strToTextE :: String -> Exp+strToTextE str = AppE (VarE 'pack) (LitE . StringL $ str)++checkProps :: Properties t => t -> [(Text, Bool)] -> Bool+checkProps container = all (\(fieldName, fieldMaybe) -> fieldMaybe || fieldName `member` getProps container)++checkLabels :: Labels t => t -> [Text] -> Bool+checkLabels container = all (`elem` getLabels container)++getProp :: (Properties t, FromValue a) => t -> (Text, Bool) -> a+getProp container (fieldName, fieldMaybe) | fieldMaybe && fieldName `notMember` getProps container = fromValue $ N ()+ | otherwise = fromValue (getProps container ! fieldName)++unpackError :: Show c => c -> String -> a+unpackError container label = error $ $currentLoc ++ " could not unpack " ++ label ++ " from " ++ show container
− src/Database/Bolt/Extras/Template/Types.hs
@@ -1,68 +0,0 @@-module Database.Bolt.Extras.Template.Types- (- FromValue (..)- , Label- , Labels (..)- , Node (..)- , NodeLike (..)- , Properties (..)- , Property- , Relationship (..)- , ToValue (..)- , URelationLike (..)- , URelationship (..)- , Value (..)- ) where--import Data.Map.Strict (Map)-import Data.Text (Text)-import Database.Bolt (Node (..), Relationship (..),- URelationship (..), Value (..))---- | Alias for Neo4j label.----type Label = Text---- | Alias for Neo4j property.----type Property = (Text, Value)---- | 'NodeLike' class represents convertable into and from 'Node'.----class NodeLike a where- toNode :: a -> Node- fromNode :: Node -> a---- | 'URelationLike' class represents convertable into and from 'URelationship'.----class URelationLike a where- toURelation :: a -> URelationship- fromURelation :: URelationship -> a---- | 'ToValue' means that something can be converted into Bolt 'Value'.----class ToValue a where- toValue :: a -> Value---- | 'FromValue' means that something can be converted from Bolt 'Value'.----class FromValue a where- fromValue :: Value -> a--class Labels a where- getLabels :: a -> [Label]--instance Labels Node where- getLabels = labels--instance Labels URelationship where- getLabels = pure . urelType--class Properties a where- getProps :: a -> Map Text Value--instance Properties Node where- getProps = nodeProps--instance Properties URelationship where- getProps = urelProps
src/Database/Bolt/Extras/Utils.hs view
@@ -1,15 +1,24 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Database.Bolt.Extras.Utils ( dummyId , union , currentLoc+ , exactValues+ , exactValuesM ) where -import Data.List (nub)-import qualified Data.Map.Strict as M (union)-import Database.Bolt (Node (..))-import Language.Haskell.TH (Exp (..), Lit (..), Loc (..), Q, location)-import Text.Printf (printf)+import Control.Monad.IO.Class (MonadIO)+import Data.List (nub)+import Data.Map.Strict as M ((!), (!?))+import qualified Data.Map.Strict as M (union)+import Data.Text (Text)+import Database.Bolt as B (BoltActionT, Node (..), Record,+ RecordValue, Value (..), exact)+import Language.Haskell.TH (Exp (..), Lit (..), Loc (..), Q,+ location)+import Text.Printf (printf) -- | 'dummyId' is used to load 'Node' and 'URelationship' into database,@@ -32,3 +41,17 @@ currentLoc = do loc <- location pure $ LitE $ StringL $ printf "%s:%d: " (loc_module loc) (fst $ loc_start loc)++-- | Extract values+--+exactValues :: (Monad m, RecordValue a) => Text -> [Record] -> m [a]+exactValues var = mapM (exact . (! var))++-- | Extract values (maybe)+exactValuesM :: (MonadIO m, RecordValue a) => Text -> [Record] -> BoltActionT m [Maybe a]+exactValuesM var = mapM (safeExact . (!? var))+ where+ safeExact :: (MonadIO m, RecordValue a) => Maybe B.Value -> BoltActionT m (Maybe a)+ safeExact Nothing = pure Nothing+ safeExact (Just (N ())) = pure Nothing+ safeExact (Just x ) = Just <$> exact x