version 0.0.1.1: param combinator (#36)

CHANGELOG.md

@@ -6,6 +6,11 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.
 
 ## [Unreleased]
 
+## [0.0.1.1] - 2019-12-31
+### Added
+- `param` combinator to add named parameters to selectors;
+- `CypherDSLParams` to control parameters that queries accept.
+
 ## [0.0.1.0] - 2019-12-17
 ### Changed
 - Use `hasbolt` 0.1.4.0.

hasbolt-extras.cabal

@@ -1,5 +1,5 @@
 name:           hasbolt-extras
-version:        0.0.1.0
+version:        0.0.1.1
 synopsis:       Extras for hasbolt library
 description:    Extras for hasbolt library
 homepage:       https://github.com/biocad/hasbolt-extras#readme
@@ -44,6 +44,7 @@ library
                      , Database.Bolt.Extras.DSL.Typed.Types
                      , Database.Bolt.Extras.DSL.Typed.Families
                      , Database.Bolt.Extras.DSL.Typed.Instances
+                     , Database.Bolt.Extras.DSL.Typed.Parameters
 
                      , Database.Bolt.Extras.Graph.Internal.AbstractGraph
                      , Database.Bolt.Extras.Graph.Internal.Class

src/Database/Bolt/Extras/DSL/Internal/Instances.hs

@@ -34,11 +34,13 @@ instance SelectorLike NodeSelector where
     withIdentifier idx node = node { nodeIdentifier = Just idx }
     withLabel lbl node      = node { nodeLabels = lbl : nodeLabels node }
     withProp prop node      = node { nodeProperties = prop : nodeProperties node }
+    withParam prop node     = node { nodeParams = prop : nodeParams node }
 
 instance SelectorLike RelSelector where
     withIdentifier idx rel = rel { relIdentifier = Just idx }
     withLabel lbl rel      = rel { relLabel = lbl }
     withProp prop rel      = rel { relProperties = prop : relProperties rel }
+    withParam prop rel     = rel { relParams = prop : relParams rel }
 
 instance ToCypher NodeSelector where
   toCypher NodeSelector{..} = execWriter $ do
@@ -50,10 +52,22 @@ instance ToCypher NodeSelector where
       [] -> pure ()
       _  -> tell $ toCypher nodeLabels
     case nodeProperties of
-      [] -> pure ()
-      _  -> do tell "{"
-               tell $ toCypher nodeProperties
-               tell "}"
+      [] -> case nodeParams of
+              [] -> pure ()
+              _ -> do
+                tell "{"
+                tell $ toCypher nodeParams
+                tell "}"
+      _ -> do
+        tell "{"
+        tell $ toCypher nodeProperties
+        case nodeParams of
+          [] -> pure ()
+          _ -> do
+            tell ","
+            tell $ toCypher nodeParams
+        tell "}"
+
     tell ")"
 
 instance ToCypher RelSelector where
@@ -66,10 +80,22 @@ instance ToCypher RelSelector where
       "" -> pure ()
       _  -> tell $ toCypher relLabel
     case relProperties of
-      [] -> pure ()
-      _  -> do tell "{"
-               tell $ toCypher relProperties
-               tell "}"
+      [] -> case relParams of
+              [] -> pure ()
+              _ -> do
+                tell "{"
+                tell $ toCypher relParams
+                tell "}"
+      _ -> do
+        tell "{"
+        tell $ toCypher relProperties
+        case relParams of
+          [] -> pure ()
+          _ -> do
+            tell ","
+            tell $ toCypher relParams
+        tell "}"
+
     tell "]"
 
 instance ToCypher PathSelector where

src/Database/Bolt/Extras/DSL/Internal/Language.hs

@@ -22,7 +22,7 @@ import           Database.Bolt.Extras.DSL.Internal.Types (Conds (..), Expr (..),
 
 -- | A synonym for 'Free' DSL.
 --
-type CypherDSL a = Free Expr ()
+type CypherDSL a = Free Expr a
 
 -- | Prepare 'CREATE' query
 --

src/Database/Bolt/Extras/DSL/Internal/Types.hs

@@ -42,6 +42,7 @@ class SelectorLike a where
    withIdentifier :: Text -> a -> a
    withLabel      :: Text -> a -> a
    withProp       :: (Text, Value) -> a -> a
+   withParam      :: (Text, Text) -> a -> a
 
 -- | Selector for 'Node's.
 --
@@ -54,6 +55,7 @@ class SelectorLike a where
 data NodeSelector = NodeSelector { nodeIdentifier :: Maybe Text
                                  , nodeLabels     :: [Text]
                                  , nodeProperties :: [(Text, Value)]
+                                 , nodeParams     :: [(Text, Text)]
                                  }
   deriving (Show, Eq)
 
@@ -63,6 +65,7 @@ data NodeSelector = NodeSelector { nodeIdentifier :: Maybe Text
 data RelSelector = RelSelector { relIdentifier :: Maybe Text
                                , relLabel      :: Text
                                , relProperties :: [(Text, Value)]
+                               , relParams     :: [(Text, Text)]
                                }
   deriving (Show, Eq)
 
@@ -154,15 +157,15 @@ data Expr next = Create Selectors next        -- ^ CREATE query
 
 -- | Empty 'NodeSelector'.
 defaultNode :: NodeSelector
-defaultNode = NodeSelector Nothing [] []
+defaultNode = NodeSelector Nothing [] [] []
 
 -- | Shorter synonym for 'defaultRel'.
 defN :: NodeSelector
 defN = defaultNode
 
 -- | Empty 'RelSelector'.
 defaultRel :: RelSelector
-defaultRel = RelSelector Nothing "" []
+defaultRel = RelSelector Nothing "" [] []
 
 -- | Shorter synonym for 'defaultRel'.
 defR :: RelSelector

src/Database/Bolt/Extras/DSL/Typed.hs

@@ -23,6 +23,7 @@ module Database.Bolt.Extras.DSL.Typed
   , lbl
   , prop
   , propMaybe
+  , param
   , (=:)
   , NodeSelector, RelSelector
   , nodeSelector, relSelector
@@ -39,17 +40,29 @@ module Database.Bolt.Extras.DSL.Typed
   , (-:)
   , (<-:)
   , p
+
+  -- * Queries with parameters
+  --
+  -- $params
+
+  , CypherDSLParams(..)
+  , queryWithParams
+
+  -- ** Implementation details
+  , QueryWithParams(..)
   ) where
 
 
 import           Database.Bolt.Extras.DSL.Typed.Instances ()
 import           Database.Bolt.Extras.DSL.Typed.Types
+import           Database.Bolt.Extras.DSL.Typed.Parameters
 
 {- $setup
 >>> :set -XDeriveGeneric
 >>> :set -XTypeApplications
 >>> :set -XOverloadedLabels
 >>> :set -XOverloadedStrings
+>>> :set -XDataKinds
 >>> :load Database.Bolt.Extras.Graph Database.Bolt.Extras.DSL.Typed Database.Bolt.Extras.DSL
 >>> import Database.Bolt.Extras.DSL.Typed
 >>> import Data.Text (Text, unpack)
@@ -87,6 +100,8 @@ extended with the following combinators:
 - 'lbl' adds a label represented by some Haskell type
 - 'prop' adds a new property, making sure that this property exists in one of the labels and
   has correct type
+- 'param' adds a new property with named parameter (@$foo@ syntax in Cypher), making sure that
+  this property exists in one of the labels
 
 Typically selectors are chained by '.&' starting from 'defN' or 'defR' like this:
 
@@ -117,7 +132,7 @@ But relations have at most one:
 
 ==== Complex queries
 
-These selectors are fully compatible with the 'Database.Bolt.Extras.DSL.DSL':
+These selectors are fully compatible with the "Database.Bolt.Extras.DSL":
 
 >>> :{
 toCypherQ $ do
@@ -138,12 +153,12 @@ MERGE (name:Name{name:"CT42"}) MERGE (user:User{user:"123-456"}) CREATE (lib:Bin
 
 ==== Dropping types
 
-It is possible to convert typed selectors to untyped ones from 'Database.Bolt.Extras.DSL.DSL' using
+It is possible to convert typed selectors to untyped ones from "Database.Bolt.Extras.DSL" using
 'nodeSelector' and 'relSelector' funcions.
 
 ==== Using with Graph api
 
-This module is also interopable with 'Database.Bolt.Extras.Graph.Graph' API. Here is an example
+This module is also interopable with "Database.Bolt.Extras.Graph" API. Here is an example
 of graph query using typed selectors.
 
 >>> import Database.Bolt.Extras.Graph
@@ -233,7 +248,7 @@ the type of literal @42@, which is @Num a => a@.
 
 {- $paths
 
-This module is completely interopable with path selectors from 'Database.Bolt.Extras.DSL.DSL' —
+This module is completely interopable with path selectors from "Database.Bolt.Extras.DSL" —
 adding a 'NodeSelector' or 'RelSelector' to path simply drops all type information, converting it
 into untyped variant.
 
@@ -246,3 +261,24 @@ Here is an example of a path constructed this way:
 >>> toCypherP (#binder .& lbl @Binder .& prop (#uuid =: "123") -: defR .& lbl @ELEMENT !->: #el)
 (binder:Binder{uuid:"123"})-[:ELEMENT]->(el)
 -}
+
+{- $params
+
+There is an option to annotate queries ('Database.Bolt.Extras.DSL.CypherDSL') with parameters they accept,
+like this:
+
+> fooQ :: CypherDSLParams '[ '("foo", Int), '("bar", Text) ]
+> fooQ = CypherDSLParams $ do
+>     matchF [ PS $ p $ #n .& lbl @Foo .& param (#foo =: "foo") .& param (#bar =: "bar")
+>     returnF ["n"]
+
+This will render to the following Cypher expression:
+
+> match (n: Foo {foo: $foo, bar: $bar}) return n
+
+To make sure that all parameters are filled, use 'queryWithParams' function:
+
+> records <- queryWithParams fooQ (#foo =: 42) (#bar =: "Hello")
+
+See below for more examples.
+-}

src/Database/Bolt/Extras/DSL/Typed/Families.hs

@@ -55,6 +55,12 @@ type family Assert (err :: Constraint) (a :: k) :: k where
   Assert _ T1 = Any
   Assert _ k = k
 
+-- | A version of 'Assert' that returns trivial constraint @()@ when argument is not stuck,
+-- discarding its actual value.
+type family AssertC (err :: Constraint) (a :: k) :: Constraint where
+  AssertC _ T1 = Any
+  AssertC _ k = ()
+
 -- | Error text for the case when records do no have the required field.
 type family NoFieldError (field :: Symbol) (types :: [Type]) :: k where
   NoFieldError field types

src/Database/Bolt/Extras/DSL/Typed/Instances.hs

@@ -15,7 +15,7 @@ module Database.Bolt.Extras.DSL.Typed.Instances where
 import           Data.Coerce                             (coerce)
 import           Data.Function                           ((&))
 import           Data.Kind                               (Type)
-import           Data.Text                               (pack)
+import           Data.Text                               (Text, pack)
 import           GHC.Exts                                (proxy#)
 import           GHC.Generics                            (Rep)
 import           GHC.OverloadedLabels                    (IsLabel (..))
@@ -43,6 +43,8 @@ instance SelectorLike NodeSelector where
   type AddType (types :: [Type]) (typ :: Type) = typ ': types
   type HasField (types :: [Type]) (field :: Symbol) (typ :: Type) =
     Assert (NoFieldError field types) (GetTypeFromList field types) ~ typ
+  type HasField' (types :: [Type]) (field :: Symbol) =
+    AssertC (NoFieldError field types) (GetTypeFromList field types)
 
   withIdentifier = coerce $ UT.withIdentifier @UT.NodeSelector
   withLabel
@@ -58,6 +60,11 @@ instance SelectorLike NodeSelector where
     => (SymbolS field, typ) -> NodeSelector types -> NodeSelector types
   withProp (SymbolS field, val) = coerce $ UT.withProp @UT.NodeSelector $ pack field B.=: val
 
+  withParam
+    :: forall (field :: Symbol) (types :: [Type])
+    .  (SymbolS field, Text) -> NodeSelector types -> NodeSelector types
+  withParam (SymbolS field, name) = coerce $ UT.withParam @UT.NodeSelector (pack field, name)
+
 instance SelectorLike RelSelector where
   type CanAddType 'Nothing = ()
   type CanAddType ('Just a)
@@ -74,6 +81,13 @@ instance SelectorLike RelSelector where
         )
   type HasField ('Just record) (field :: Symbol) (typ :: Type) =
     Assert (NoFieldError field '[record]) (GetTypeFromRecord field (Rep record)) ~ typ
+  type HasField' 'Nothing (field :: Symbol)
+    = TypeError
+        ('Text "Tried to set property " ':<>: 'ShowType field
+         ':<>: 'Text " on a relationship without label!"
+        )
+  type HasField' ('Just record) (field :: Symbol) =
+    Assert (NoFieldError field '[record]) (RecordHasField field (Rep record)) ~ 'True
 
   withIdentifier = coerce $ UT.withIdentifier @UT.RelSelector
   withLabel
@@ -89,3 +103,8 @@ instance SelectorLike RelSelector where
     .  B.IsValue typ
     => (SymbolS field, typ) -> RelSelector types -> RelSelector types
   withProp (SymbolS field, val) = coerce $ UT.withProp @UT.RelSelector $ pack field B.=: val
+
+  withParam
+    :: forall (field :: Symbol) (types :: Maybe Type)
+    .  (SymbolS field, Text) -> RelSelector types -> RelSelector types
+  withParam (SymbolS field, name) = coerce $ UT.withParam @UT.RelSelector (pack field, name)