diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/hasbolt-extras.cabal b/hasbolt-extras.cabal --- a/hasbolt-extras.cabal +++ b/hasbolt-extras.cabal @@ -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 diff --git a/src/Database/Bolt/Extras.hs b/src/Database/Bolt/Extras.hs --- a/src/Database/Bolt/Extras.hs +++ b/src/Database/Bolt/Extras.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Condition.hs b/src/Database/Bolt/Extras/Condition.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Condition.hs +++ /dev/null @@ -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 diff --git a/src/Database/Bolt/Extras/DSL.hs b/src/Database/Bolt/Extras/DSL.hs --- a/src/Database/Bolt/Extras/DSL.hs +++ b/src/Database/Bolt/Extras/DSL.hs @@ -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 diff --git a/src/Database/Bolt/Extras/DSL/Internal/Executer.hs b/src/Database/Bolt/Extras/DSL/Internal/Executer.hs --- a/src/Database/Bolt/Extras/DSL/Internal/Executer.hs +++ b/src/Database/Bolt/Extras/DSL/Internal/Executer.hs @@ -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. -- diff --git a/src/Database/Bolt/Extras/DSL/Internal/Instances.hs b/src/Database/Bolt/Extras/DSL/Internal/Instances.hs --- a/src/Database/Bolt/Extras/DSL/Internal/Instances.hs +++ b/src/Database/Bolt/Extras/DSL/Internal/Instances.hs @@ -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) diff --git a/src/Database/Bolt/Extras/DSL/Internal/Types.hs b/src/Database/Bolt/Extras/DSL/Internal/Types.hs --- a/src/Database/Bolt/Extras/DSL/Internal/Types.hs +++ b/src/Database/Bolt/Extras/DSL/Internal/Types.hs @@ -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. -- diff --git a/src/Database/Bolt/Extras/Graph.hs b/src/Database/Bolt/Extras/Graph.hs --- a/src/Database/Bolt/Extras/Graph.hs +++ b/src/Database/Bolt/Extras/Graph.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs b/src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Graph/Internal/AbstractGraph.hs @@ -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) diff --git a/src/Database/Bolt/Extras/Graph/Internal/Class.hs b/src/Database/Bolt/Extras/Graph/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Graph/Internal/Class.hs @@ -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] diff --git a/src/Database/Bolt/Extras/Graph/Internal/Get.hs b/src/Database/Bolt/Extras/Graph/Internal/Get.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Graph/Internal/Get.hs @@ -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 `0`. +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 diff --git a/src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs b/src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Graph/Internal/GraphQuery.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Graph/Internal/Put.hs b/src/Database/Bolt/Extras/Graph/Internal/Put.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Graph/Internal/Put.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Internal/Condition.hs b/src/Database/Bolt/Extras/Internal/Condition.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Internal/Condition.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Internal/Cypher.hs b/src/Database/Bolt/Extras/Internal/Cypher.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Internal/Cypher.hs @@ -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 + diff --git a/src/Database/Bolt/Extras/Internal/Instances.hs b/src/Database/Bolt/Extras/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Internal/Instances.hs @@ -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" diff --git a/src/Database/Bolt/Extras/Internal/Persisted.hs b/src/Database/Bolt/Extras/Internal/Persisted.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Internal/Persisted.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Internal/Types.hs b/src/Database/Bolt/Extras/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Internal/Types.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Persisted.hs b/src/Database/Bolt/Extras/Persisted.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Persisted.hs +++ /dev/null @@ -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 diff --git a/src/Database/Bolt/Extras/Query.hs b/src/Database/Bolt/Extras/Query.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Query.hs +++ /dev/null @@ -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) diff --git a/src/Database/Bolt/Extras/Query/Cypher.hs b/src/Database/Bolt/Extras/Query/Cypher.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Query/Cypher.hs +++ /dev/null @@ -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 - diff --git a/src/Database/Bolt/Extras/Query/Delete.hs b/src/Database/Bolt/Extras/Query/Delete.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Query/Delete.hs +++ /dev/null @@ -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|] diff --git a/src/Database/Bolt/Extras/Query/Get.hs b/src/Database/Bolt/Extras/Query/Get.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Query/Get.hs +++ /dev/null @@ -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 "" diff --git a/src/Database/Bolt/Extras/Query/Put.hs b/src/Database/Bolt/Extras/Query/Put.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Query/Put.hs +++ /dev/null @@ -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 diff --git a/src/Database/Bolt/Extras/Query/Set.hs b/src/Database/Bolt/Extras/Query/Set.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Query/Set.hs +++ /dev/null @@ -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 diff --git a/src/Database/Bolt/Extras/Query/Utils.hs b/src/Database/Bolt/Extras/Query/Utils.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Query/Utils.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Database.Bolt.Extras.Query.Utils - ( NodeName - ) where - -import Data.Text (Text) - -type NodeName = Text diff --git a/src/Database/Bolt/Extras/Template.hs b/src/Database/Bolt/Extras/Template.hs --- a/src/Database/Bolt/Extras/Template.hs +++ b/src/Database/Bolt/Extras/Template.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Template/Converters.hs b/src/Database/Bolt/Extras/Template/Converters.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Template/Converters.hs +++ /dev/null @@ -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 diff --git a/src/Database/Bolt/Extras/Template/Instances.hs b/src/Database/Bolt/Extras/Template/Instances.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Template/Instances.hs +++ /dev/null @@ -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" diff --git a/src/Database/Bolt/Extras/Template/Internal/Converters.hs b/src/Database/Bolt/Extras/Template/Internal/Converters.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/Template/Internal/Converters.hs @@ -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 diff --git a/src/Database/Bolt/Extras/Template/Types.hs b/src/Database/Bolt/Extras/Template/Types.hs deleted file mode 100644 --- a/src/Database/Bolt/Extras/Template/Types.hs +++ /dev/null @@ -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 diff --git a/src/Database/Bolt/Extras/Utils.hs b/src/Database/Bolt/Extras/Utils.hs --- a/src/Database/Bolt/Extras/Utils.hs +++ b/src/Database/Bolt/Extras/Utils.hs @@ -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