hasbolt-extras 0.0.0.2 → 0.0.0.3
raw patch · 8 files changed
+89/−30 lines, 8 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- hasbolt-extras.cabal +2/−2
- src/Database/Bolt/Extras/Query/Get.hs +12/−5
- src/Database/Bolt/Extras/Query/Put.hs +19/−9
- src/Database/Bolt/Extras/Template.hs +1/−0
- src/Database/Bolt/Extras/Template/Converters.hs +40/−8
- src/Database/Bolt/Extras/Template/Types.hs +8/−6
- src/Database/Bolt/Extras/Utils.hs +3/−0
CHANGELOG.md view
@@ -6,6 +6,10 @@ ## [Unreleased] +## [0.1.0.3] - 2018-04-05+### Changed+- More accurate `fromNode` on data fields with `Maybe a` type. If there is no such field in Node, data field will be set to Nothing.+ ## [0.1.0.0] - 2018-02-22 ### Added - Template Haskell code to generate `Node`s and `URelationship`s.
hasbolt-extras.cabal view
@@ -1,11 +1,11 @@ name: hasbolt-extras-version: 0.0.0.2+version: 0.0.0.3 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+maintainer: neterebskiy@biocad.ru copyright: (c) 2018, BIOCAD stability: experimental category: Database
src/Database/Bolt/Extras/Query/Get.hs view
@@ -30,25 +30,29 @@ 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.+-- | Helper to find 'URelationship's.+-- data RelGetter = RelGetter { labelR :: Maybe Label , propsR :: Maybe [Property] } deriving (Show) --- | The combinations of Getters to load graph from the database.+-- | 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 the graph, which matches it.+-- | 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)@@ -81,6 +85,9 @@ 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
src/Database/Bolt/Extras/Query/Put.hs view
@@ -25,19 +25,28 @@ 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.+-- | 'PutNode' is the wrapper for 'Node' where we can specify if we want to merge or create it. -- data PutNode = BoltId BoltId | Merge Node | Create Node deriving (Show) +-- | The graph of 'Node's with specified uploading type and 'URelationship's.+-- type GraphPutRequest = Graph NodeName PutNode URelationship +-- | 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]@@ -60,8 +69,9 @@ 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.+-- 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 -> URelationship -> BoltId -> BoltActionT m BoltId putRelationship start URelationship{..} end = do [record] <- query mergeQ@@ -80,9 +90,9 @@ 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'.+-- | 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
src/Database/Bolt/Extras/Template.hs view
@@ -29,3 +29,4 @@ URelationLike (..), URelationship (..), Value (..))+
src/Database/Bolt/Extras/Template/Converters.hs view
@@ -8,7 +8,9 @@ ) where import Control.Lens (view, _1)-import Data.Map.Strict (fromList, member, (!))+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 (..),@@ -16,10 +18,12 @@ Properties (..), ToValue (..), URelationLike (..),- URelationship (..))+ 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@).@@ -216,10 +220,23 @@ -- 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@@ -229,12 +246,16 @@ -- 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) fieldNames|]+ guardSuccess <- NormalG <$> [|checkLabels $(varExp) [dataLabel] && checkProps $(varExp) maybeNames|] -- `otherwise` case. guardFail <- NormalG <$> [|otherwise|]@@ -246,24 +267,35 @@ -- 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 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-checkProps container = all (`member` getProps container)+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 -> a-getProp container field = fromValue (getProps container ! field)+getProp :: (Properties t, FromValue a) => t -> (Text, Bool) -> a+getProp container (fieldName, fieldMaybe) | fieldMaybe && fieldName `notMember` getProps container = fromValue $ N ()+ | otherwise = fromValue (getProps container ! fieldName) unpackError :: Show c => c -> String -> a unpackError container label = error $ $currentLoc ++ " could not unpack " ++ label ++ " from " ++ show container
src/Database/Bolt/Extras/Template/Types.hs view
@@ -19,27 +19,33 @@ import Database.Bolt (Node (..), Relationship (..), URelationship (..), Value (..)) --- | Alias for Neo4j label+-- | Alias for Neo4j label.+-- type Label = Text --- | Alias for Neo4j property+-- | 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 @@ -60,7 +66,3 @@ instance Properties URelationship where getProps = urelProps----
src/Database/Bolt/Extras/Utils.hs view
@@ -14,17 +14,20 @@ -- | '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