summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorozzzzz <>2019-09-11 10:20:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-09-11 10:20:00 (GMT)
commit5538e83743a411b6d7b7f3be72daf5f9405a9d46 (patch)
tree02edf59352e289893b4d84d0cf08c846ea853cd5
parent1b822b3b6bd3eb2d5800e17617c0fecfdf899300 (diff)
version 0.0.0.210.0.0.21
-rw-r--r--CHANGELOG.md4
-rw-r--r--hasbolt-extras.cabal2
-rw-r--r--src/Database/Bolt/Extras/DSL.hs50
-rw-r--r--src/Database/Bolt/Extras/DSL/Internal/Instances.hs26
-rw-r--r--src/Database/Bolt/Extras/DSL/Internal/Language.hs7
-rw-r--r--src/Database/Bolt/Extras/DSL/Internal/Types.hs53
6 files changed, 131 insertions, 11 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 6e5e75c..8234760 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.
## [Unreleased]
+## [0.0.0.21] - 2019-09-09
+### Added
+- `OverloadedLabels` instances and operators for easy selector writing.
+
## [0.0.0.20] - 2019-09-06
### Added
- `WITH` statement in DSL.
diff --git a/hasbolt-extras.cabal b/hasbolt-extras.cabal
index d6582b4..8f56c80 100644
--- a/hasbolt-extras.cabal
+++ b/hasbolt-extras.cabal
@@ -1,5 +1,5 @@
name: hasbolt-extras
-version: 0.0.0.20
+version: 0.0.0.21
synopsis: Extras for hasbolt library
description: Extras for hasbolt library
homepage: https://github.com/biocad/hasbolt-extras#readme
diff --git a/src/Database/Bolt/Extras/DSL.hs b/src/Database/Bolt/Extras/DSL.hs
index 5132097..96fdbdc 100644
--- a/src/Database/Bolt/Extras/DSL.hs
+++ b/src/Database/Bolt/Extras/DSL.hs
@@ -1,8 +1,52 @@
module Database.Bolt.Extras.DSL
(
- module Database.Bolt.Extras.DSL.Internal.Types
- , module Database.Bolt.Extras.DSL.Internal.Language
- , module Database.Bolt.Extras.DSL.Internal.Executer
+ -- * Selectors for nodes, relations and paths
+ --
+ -- | These data types let you specify Cypher queries.
+ --
+ -- With @OverloadedLabels@ and operators you can write selectors in very concise
+ -- Cypher-like form:
+ --
+ -- > (#n .: "Name" .# ["name" =: "C42"]) -: (defR .: "NAME_OF") :!->: (#m .: "Molecule")
+ -- > (n:Name{name:"C42"})-[:NAME_OF]->(m:Molecule)
+ --
+ NodeSelector(..),
+ RelSelector(..),
+ SelectorLike(..),
+ (.:), (.#),
+ toNodeSelector, toRelSelector,
+ PathSelector(..),
+ PathPart(..),
+ (-:), (<-:),
+ Selector(..),
+ Selectors,
+
+ -- ** Default selectors
+ defaultNode, defN, defaultRel, defR,
+
+ -- * Cypher conditions
+ Cond(..),
+ Conds(..),
+
+ -- * DSL for Cypher
+ --
+ -- | The free-monadic DSL lets you write Cypher queries in Haskell like this:
+ --
+ -- > formQuery $ do
+ -- > matchF [
+ -- > PS $ (#n .: "Name" .# ["name" =: "C42"]) -: (defR .: "NAME_OF") :!->: (#m .: "Molecule")
+ -- > ]
+ -- > returnF ["n", "m"]
+ --
+
+ -- ** DSL operations
+ module Database.Bolt.Extras.DSL.Internal.Language,
+
+ -- ** Rendering Cypher queries
+ formQuery,
+
+ -- ** Implementation details
+ Expr(..)
) where
import Database.Bolt.Extras.DSL.Internal.Executer
diff --git a/src/Database/Bolt/Extras/DSL/Internal/Instances.hs b/src/Database/Bolt/Extras/DSL/Internal/Instances.hs
index af664cd..78b8296 100644
--- a/src/Database/Bolt/Extras/DSL/Internal/Instances.hs
+++ b/src/Database/Bolt/Extras/DSL/Internal/Instances.hs
@@ -1,21 +1,35 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Bolt.Extras.DSL.Internal.Instances () where
import Control.Monad.Writer (execWriter, tell)
+import Data.Function ((&))
import Data.Monoid ((<>))
+import Data.Proxy (Proxy (..))
import Data.Text (intercalate, pack)
import Database.Bolt.Extras (ToCypher (..),
fromInt)
-import Database.Bolt.Extras.DSL.Internal.Types
+import GHC.OverloadedLabels (IsLabel (..))
+import GHC.TypeLits (KnownSymbol,
+ symbolVal)
import NeatInterpolation (text)
import Text.Printf (printf)
+import Database.Bolt.Extras.DSL.Internal.Types
+
+instance KnownSymbol x => IsLabel x NodeSelector where
+ fromLabel = defaultNode & withIdentifier (pack $ symbolVal @x Proxy)
+
+instance KnownSymbol x => IsLabel x RelSelector where
+ fromLabel = defaultRel & withIdentifier (pack $ symbolVal @x Proxy)
+
instance SelectorLike NodeSelector where
withIdentifier idx node = node { nodeIdentifier = Just idx }
withLabel lbl node = node { nodeLabels = lbl : nodeLabels node }
diff --git a/src/Database/Bolt/Extras/DSL/Internal/Language.hs b/src/Database/Bolt/Extras/DSL/Internal/Language.hs
index b81e030..4dbfaf3 100644
--- a/src/Database/Bolt/Extras/DSL/Internal/Language.hs
+++ b/src/Database/Bolt/Extras/DSL/Internal/Language.hs
@@ -1,6 +1,7 @@
module Database.Bolt.Extras.DSL.Internal.Language
(
- createF
+ CypherDSL
+ , createF
, matchF
, optionalMatchF
, mergeF
@@ -19,6 +20,10 @@ import Data.Text (Text)
import Database.Bolt.Extras.DSL.Internal.Types (Conds (..), Expr (..),
Selectors)
+-- | A synonym for 'Free' DSL.
+--
+type CypherDSL a = Free Expr ()
+
-- | Prepare 'CREATE' query
--
createF :: Selectors -> Free Expr ()
diff --git a/src/Database/Bolt/Extras/DSL/Internal/Types.hs b/src/Database/Bolt/Extras/DSL/Internal/Types.hs
index 29a85ae..b5aedd5 100644
--- a/src/Database/Bolt/Extras/DSL/Internal/Types.hs
+++ b/src/Database/Bolt/Extras/DSL/Internal/Types.hs
@@ -16,13 +16,20 @@ module Database.Bolt.Extras.DSL.Internal.Types
, Conds (..)
, Expr (..)
, SelectorLike (..)
+ , (.:)
+ , (.#)
, (#)
+ , (-:)
+ , (<-:)
, defaultNode
+ , defN
, defaultRel
+ , defR
, toNodeSelector
, toRelSelector
) where
+import Data.Foldable (foldl')
import Data.Map.Strict (toList)
import Data.Text (Text)
import Database.Bolt (Node (..), URelationship (..),
@@ -38,6 +45,12 @@ class SelectorLike a where
-- | Selector for 'Node's.
--
+-- This datatype has @OverloadedLabels@ instance to simplify specifying nodes. Labels produce
+-- empty nodes.
+--
+-- > #foo :: NodeSelector
+-- > -- foo = NodeSelector (Just "foo") [] []
+--
data NodeSelector = NodeSelector { nodeIdentifier :: Maybe Text
, nodeLabels :: [Text]
, nodeProperties :: [(Text, Value)]
@@ -46,12 +59,30 @@ data NodeSelector = NodeSelector { nodeIdentifier :: Maybe Text
-- | Selector for 'URelationship's.
--
+-- This datatype has @OverloadedLabels@ instance as well, similar to 'NodeSelector'.
data RelSelector = RelSelector { relIdentifier :: Maybe Text
, relLabel :: Text
, relProperties :: [(Text, Value)]
}
deriving (Show, Eq)
+-- | Operator version of 'withLabel'. To be used with @OverloadedLabels@ instances.
+--
+-- > #foo .: "Foo" :: NodeSelector
+--
+infixl 9 .:
+(.:) :: SelectorLike a => a -> Text -> a
+(.:) = flip withLabel
+
+-- | Operator version of 'withProp'. To be used with @OverloadedLabels@ instances.
+--
+-- See also 'Database.Bolt.=:' from @Database.Bolt@ package.
+--
+-- > #foo .# ["bar" =: 42, "baz" =: "baz"] :: NodeSelector
+--
+infixl 9 .#
+(.#) :: SelectorLike a => a -> [(Text, Value)] -> a
+(.#) = foldl' (flip withProp)
(#) :: a -> (a -> b) -> b
(#) = flip ($)
@@ -71,6 +102,18 @@ data PathSelector = PathSelector :-!: PathPart -- ^ not directed relation
| P NodeSelector -- ^ starting node of Path
deriving (Show, Eq)
+-- | Combined version of ':-!:' and 'P' for specifying the first node of path.
+--
+infixl 1 -:
+(-:) :: NodeSelector -> PathPart -> PathSelector
+ns -: pp = P ns :-!: pp
+
+-- | Combined version of ':<-!:' and 'P' for specifying the first node of path.
+--
+infixl 1 <-:
+(<-:) :: NodeSelector -> PathPart -> PathSelector
+ns <-: pp = P ns :<-!: pp
+
data Selector = PS PathSelector -- ^ path selector
| TS Text -- ^ free text selector
deriving (Show, Eq)
@@ -109,12 +152,22 @@ data Expr next = Create Selectors next -- ^ CREATE query
| Text Text next -- ^ free text query
deriving (Show, Eq, Functor)
+-- | Empty 'NodeSelector'.
defaultNode :: NodeSelector
defaultNode = NodeSelector Nothing [] []
+-- | Shorter synonym for 'defaultRel'.
+defN :: NodeSelector
+defN = defaultNode
+
+-- | Empty 'RelSelector'.
defaultRel :: RelSelector
defaultRel = RelSelector Nothing "" []
+-- | Shorter synonym for 'defaultRel'.
+defR :: RelSelector
+defR = defaultRel
+
toNodeSelector :: Node -> NodeSelector
toNodeSelector Node{..} = defaultNode { nodeLabels = labels
, nodeProperties = filter ((/= N ()) . snd) (toList nodeProps)