hasbolt-extras (empty) → 0.0.0.1

raw patch · 18 files changed

+1007/−0 lines, 18 filesdep +basedep +containersdep +hasboltsetup-changed

Dependencies added: base, containers, hasbolt, lens, neat-interpolation, template-haskell, text, th-lift-instances

Files

• CHANGELOG.md +13/−0
• LICENSE +29/−0
• README.md +1/−0
• Setup.hs +2/−0
• hasbolt-extras.cabal +50/−0
• src/Database/Bolt/Extras.hs +14/−0
• src/Database/Bolt/Extras/Graph.hs +43/−0
• src/Database/Bolt/Extras/Persisted.hs +50/−0
• src/Database/Bolt/Extras/Query.hs +19/−0
• src/Database/Bolt/Extras/Query/Cypher.hs +62/−0
• src/Database/Bolt/Extras/Query/Get.hs +131/−0
• src/Database/Bolt/Extras/Query/Put.hs +96/−0
• src/Database/Bolt/Extras/Query/Utils.hs +7/−0
• src/Database/Bolt/Extras/Template.hs +31/−0
• src/Database/Bolt/Extras/Template/Converters.hs +269/−0
• src/Database/Bolt/Extras/Template/Instances.hs +93/−0
• src/Database/Bolt/Extras/Template/Types.hs +66/−0
• src/Database/Bolt/Extras/Utils.hs +31/−0

@@ -0,0 +1,13 @@+# Changelog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)+and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html).++## [Unreleased]++## [0.1.0.0] - 2018-02-22+### Added+- Template Haskell code to generate `Node`s and `URelationship`s.+- Simple queries to upload `Node` and `URelationship`.+- Simple query to download `Node`s.

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2018, BIOCAD+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# hasbolt-extras

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,50 @@+name:           hasbolt-extras+version:        0.0.0.1+synopsis:       Extras for hasbolt library+description:    Extras for hasbolt library+homepage:       https://github.com/biocad/hasbolt-extras#readme+bug-reports:    https://github.com/biocad/hasbolt-extras/issues+author:         Bogdan Neterebskii, Vladimir Morozov, Sofya Kochkova, Alexander Sadovnikov+maintainer:     neterebskii@gmail.com+copyright:      (c) 2018, BIOCAD+stability:      experimental+category:       Database+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files: CHANGELOG.md+                    README.md++source-repository head+  type: git+  location: https://github.com/biocad/hasbolt-extras++library+  hs-source-dirs:      src+  exposed-modules:     Database.Bolt.Extras+                     , Database.Bolt.Extras.Graph+                     , Database.Bolt.Extras.Persisted+                     , Database.Bolt.Extras.Query+                     , Database.Bolt.Extras.Template+                     , Database.Bolt.Extras.Utils+  other-modules:       Database.Bolt.Extras.Query.Get+                     , Database.Bolt.Extras.Query.Put+                     , 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+                  +  build-depends:       base >=4.7 && <5+                     , text+                     , hasbolt+                     , containers+                     , neat-interpolation+                     , template-haskell+                     , th-lift-instances+                     , lens+  ghc-options:     -Wall -O2+  default-language: Haskell2010

@@ -0,0 +1,14 @@+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+  ) 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

@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.Bolt.Extras.Graph+  (+    Graph (..)+  , 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)

@@ -0,0 +1,50 @@+{-# 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

@@ -0,0 +1,19 @@+module Database.Bolt.Extras.Query+  ( GraphGetRequest+  , GraphGetResponse+  , GraphPutRequest+  , GraphPutResponse+  , NodeName+  , PutNode (..)+  , ToCypher (..)+  , getGraph+  , putGraph+  ) where++import           Database.Bolt.Extras.Query.Cypher (ToCypher (..))+import           Database.Bolt.Extras.Query.Get    (GraphGetRequest,+                                                    GraphGetResponse, getGraph)+import           Database.Bolt.Extras.Query.Put    (GraphPutRequest,+                                                    GraphPutResponse,+                                                    PutNode (..), putGraph)+import           Database.Bolt.Extras.Query.Utils  (NodeName)

@@ -0,0 +1,62 @@+{-# 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.Text                         as T (Text, concat, cons,+                                                         intercalate, pack,+                                                         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)      = [text|"$t"|]+  toCypher (L values) = let cvalues = T.intercalate "," $ map toCypher values+                        in [text|[$cvalues]|]+  toCypher _          = error $ $currentLoc ++ "unacceptable Value type"++-- | 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+

@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}++module Database.Bolt.Extras.Query.Get+    ( GraphGetRequest+    , GraphGetResponse+    , getGraph+    ) 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.+-- _varQNName is the mark for this Node, which will be used in Cypher queries.+-- For example "MATCH(a)", here _varQNName = "a"+data NodeGetter = NodeGetter { boltIdN :: Maybe BoltId+                             , labelsN :: Maybe [Label]+                             , propsN  :: Maybe [Property]+                             } deriving (Show)++-- | RelGetter is used for searching using indexes of 'Node's in the given graph.+data RelGetter = RelGetter { labelR :: Maybe Label+                           , propsR :: Maybe [Property]+                           } deriving (Show)++-- | The combinations of Getters to load graph from the database.+type GraphGetRequest = Graph NodeName NodeGetter RelGetter++type GraphGetResponse = Graph NodeName Node URelationship++-- | For the given GraphGetRequest find the graph, which matches 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)++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 ""

@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}++module Database.Bolt.Extras.Query.Put+    ( GraphPutRequest+    , GraphPutResponse+    , PutNode (..)+    , 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 (..), 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)++-- | For given @Node _ labels nodeProps@ makes query @MERGE (n:labels {props}) RETURN ID(n) as n@+-- and then return 'Node' with actual ID.+--+-- Potentially, if you MERGE some 'Node' and it labels and props are occured in+-- several 'Node's, then the result can be not one but several 'Node's.+--+data PutNode = BoltId BoltId | Merge Node | Create Node+  deriving (Show)++type GraphPutRequest = Graph NodeName PutNode URelationship++type GraphPutResponse = Graph NodeName BoltId BoltId++putNode :: (MonadIO m) => PutNode -> BoltActionT m [BoltId]+putNode ut = case ut of+    (BoltId bId)  -> pure [bId]+    (Merge node)  -> helper (T.pack "MERGE") node+    (Create 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 . 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, and for @URelationship  _ urelType urelProps@+-- this method makes MERGE query and then return 'Relationship' with actual ID.+putRelationship :: (MonadIO m) => BoltId -> URelationship -> BoltId -> BoltActionT m BoltId+putRelationship start URelationship{..} end = do+  [record]      <- query mergeQ+  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++    mergeQ :: T.Text+    mergeQ = [text|MATCH (a), (b)+              WHERE ID(a) = $startT AND ID(b) = $endT+              MERGE (a)-[$varQ $labelQ {$propsQ}]->(b)+              RETURN ID($varQ) as $varQ|]++-- | Create Graph using given GraphU and the list describing 'Node's indices (from the given _vertices),+-- which should be connected by the corresponding 'Relationship'.+-- 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

@@ -0,0 +1,7 @@+module Database.Bolt.Extras.Query.Utils+  ( NodeName+  ) where++import           Data.Text (Text)++type NodeName = Text

@@ -0,0 +1,31 @@+module Database.Bolt.Extras.Template+  ( FromValue (..)+  , Label+  , Labels (..)+  , Node (..)+  , NodeLike (..)+  , Properties (..)+  , Property+  , Relationship (..)+  , ToValue (..)+  , URelationLike (..)+  , URelationship (..)+  , Value (..)+  , makeNodeLike+  , makeURelationLike+  ) 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 (..))

@@ -0,0 +1,269 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.Bolt.Extras.Template.Converters+ (+    makeNodeLike+  , makeURelationLike+  ) where++import           Control.Lens                        (view, _1)+import           Data.Map.Strict                     (fromList, member, (!))+import           Data.Text                           (Text, pack, unpack)+import           Database.Bolt.Extras.Template.Types (FromValue (..),+                                                      Labels (..), Node (..),+                                                      NodeLike (..),+                                                      Properties (..),+                                                      ToValue (..),+                                                      URelationLike (..),+                                                      URelationship (..))+import           Database.Bolt.Extras.Utils          (currentLoc, dummyId)+import           Instances.TH.Lift                   ()+import           Language.Haskell.TH++-- | 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+  -- fieldNames :: [Text]+  -- field records of the target type.+  let fieldNames = fmap (pack . nameBase) dataFields++  -- 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++  -- 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) fieldNames|]++  -- `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 d -> (d, AppE (AppE (VarE 'getProp) (VarE varName)) f)) fieldNamesE dataFields)+  let successCase = (guardSuccess, successExp)+  let failCase = (guardFail, failExp)++  pure $ Clause [VarP varName] (GuardedB [successCase, failCase]) []+++strToTextE :: String -> Exp+strToTextE str = AppE (VarE 'pack) (LitE . StringL $ str)++checkProps :: Properties t => t -> [Text] -> Bool+checkProps container = all (`member` getProps container)++checkLabels :: Labels t => t -> [Text] -> Bool+checkLabels container = all (`elem` getLabels container)++getProp :: (Properties t, FromValue a) => t -> Text -> a+getProp container field = fromValue (getProps container ! field)++unpackError :: Show c => c -> String -> a+unpackError container label = error $ $currentLoc ++ " could not unpack " ++ label ++ " from " ++ show container

@@ -0,0 +1,93 @@+{-# 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"

@@ -0,0 +1,66 @@+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++++

@@ -0,0 +1,31 @@+module Database.Bolt.Extras.Utils+  (+    dummyId+  , union+  , currentLoc+  ) 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)+++-- | 'dummyId' is used to load 'Node' and 'URelationship' into database,+-- because id from database is not known for such moment.+dummyId :: Int+dummyId = -1++-- | 'Node's can be merged. 'union' is useful when you have to store in one node+-- several labels and props from different classes.+union :: Node -> Node -> Node+(Node _ labels1 props1) `union` (Node _ labels2 props2) = Node dummyId+                                                               (nub $ labels1 ++ labels2)+                                                               (props1 `M.union` props2)++-- | 'currentLoc' shows module name and line where this expression is used.+currentLoc :: Q Exp+currentLoc = do+  loc <- location+  pure $ LitE $ StringL $ printf "%s:%d: " (loc_module loc) (fst $ loc_start loc)