diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,11 @@ ## [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. 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.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 @@ , 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 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 @@ -34,11 +34,13 @@ 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 @@ [] -> 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 @@ "" -> 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 diff --git a/src/Database/Bolt/Extras/DSL/Internal/Language.hs b/src/Database/Bolt/Extras/DSL/Internal/Language.hs --- a/src/Database/Bolt/Extras/DSL/Internal/Language.hs +++ b/src/Database/Bolt/Extras/DSL/Internal/Language.hs @@ -22,7 +22,7 @@ -- | A synonym for 'Free' DSL. -- -type CypherDSL a = Free Expr () +type CypherDSL a = Free Expr a -- | Prepare 'CREATE' query -- 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 @@ -42,6 +42,7 @@ 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 @@ data NodeSelector = NodeSelector { nodeIdentifier :: Maybe Text , nodeLabels :: [Text] , nodeProperties :: [(Text, Value)] + , nodeParams :: [(Text, Text)] } deriving (Show, Eq) @@ -63,6 +65,7 @@ data RelSelector = RelSelector { relIdentifier :: Maybe Text , relLabel :: Text , relProperties :: [(Text, Value)] + , relParams :: [(Text, Text)] } deriving (Show, Eq) @@ -154,7 +157,7 @@ -- | Empty 'NodeSelector'. defaultNode :: NodeSelector -defaultNode = NodeSelector Nothing [] [] +defaultNode = NodeSelector Nothing [] [] [] -- | Shorter synonym for 'defaultRel'. defN :: NodeSelector @@ -162,7 +165,7 @@ -- | Empty 'RelSelector'. defaultRel :: RelSelector -defaultRel = RelSelector Nothing "" [] +defaultRel = RelSelector Nothing "" [] [] -- | Shorter synonym for 'defaultRel'. defR :: RelSelector diff --git a/src/Database/Bolt/Extras/DSL/Typed.hs b/src/Database/Bolt/Extras/DSL/Typed.hs --- a/src/Database/Bolt/Extras/DSL/Typed.hs +++ b/src/Database/Bolt/Extras/DSL/Typed.hs @@ -23,6 +23,7 @@ , lbl , prop , propMaybe + , param , (=:) , NodeSelector, RelSelector , nodeSelector, relSelector @@ -39,17 +40,29 @@ , (-:) , (<-:) , 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 @@ - '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 @@ ==== 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 @@ ==== 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 @@ {- $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. @@ -245,4 +260,25 @@ >>> 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. -} diff --git a/src/Database/Bolt/Extras/DSL/Typed/Families.hs b/src/Database/Bolt/Extras/DSL/Typed/Families.hs --- a/src/Database/Bolt/Extras/DSL/Typed/Families.hs +++ b/src/Database/Bolt/Extras/DSL/Typed/Families.hs @@ -55,6 +55,12 @@ 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 diff --git a/src/Database/Bolt/Extras/DSL/Typed/Instances.hs b/src/Database/Bolt/Extras/DSL/Typed/Instances.hs --- a/src/Database/Bolt/Extras/DSL/Typed/Instances.hs +++ b/src/Database/Bolt/Extras/DSL/Typed/Instances.hs @@ -15,7 +15,7 @@ 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 @@ 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 @@ => (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 @@ ) 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 @@ . 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) diff --git a/src/Database/Bolt/Extras/DSL/Typed/Parameters.hs b/src/Database/Bolt/Extras/DSL/Typed/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/DSL/Typed/Parameters.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Bolt.Extras.DSL.Typed.Parameters + where + +import Control.Monad.IO.Class (MonadIO) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Text (Text, pack) +import Database.Bolt (BoltActionT, + IsValue (..), + Record, Value, + queryP) +import GHC.TypeLits (Symbol) + +import Database.Bolt.Extras.DSL.Internal.Executer (formQuery) +import Database.Bolt.Extras.DSL.Internal.Language (CypherDSL) +import Database.Bolt.Extras.DSL.Typed.Types (SymbolS (..)) + +{- $setup +>>> :set -XTypeApplications +>>> :set -XOverloadedLabels +>>> :set -XDataKinds +>>> :set -XOverloadedStrings +>>> :load Database.Bolt.Extras.DSL.Typed.Instances Database.Bolt.Extras.DSL.Typed.Parameters +>>> import Control.Monad.IO.Class +>>> import Database.Bolt (BoltActionT, Record) +>>> import Database.Bolt.Extras.DSL (returnF) +>>> import Database.Bolt.Extras.DSL.Typed.Parameters +-} + +-- | A wrapper around arbitrary 'CypherDSL' expression which stores type-level list of named +-- parameters (@$foo@) with their types. +newtype CypherDSLParams (params :: [(Symbol, Type)]) (a :: Type) + = CypherDSLParams (CypherDSL a) + +-- | This type class ensures safety of queries with parameters by checking in compile time that +-- all parameters are supplied and have correct type. +-- +-- Instances of this class will add more arguments to @fun@, one for each element in @params@. +-- +-- This should be considered an implementation detail. +class QueryWithParams (params :: [(Symbol, Type)]) (m :: Type -> Type) fun | params m -> fun where + -- | Internal function that accumulates parameters from type-level list. + collectParams :: CypherDSL () -> [(Text, Value)] -> fun + +-- | Base case: if there are no parameters, perform query with 'queryP'. +instance MonadIO m => QueryWithParams '[] m (BoltActionT m [Record]) where + collectParams dsl params = queryP (formQuery dsl) $ Map.fromList params + +-- | Recursion case: append the next parameter to accumulator and to function's type. +instance (IsValue typ, QueryWithParams rest m fun) + => QueryWithParams ('(field, typ) ': rest) m ((SymbolS field, typ) -> fun) + where + + collectParams dsl params (SymbolS s, a) = collectParams @rest @m dsl ((pack s, toValue a) : params) + +-- | Run a query (in the form of 'CypherDSLParams'). This is a function of variable number of arguments. +-- Actual number will be determined by type-level list @params@. +-- +-- A couple of examples: +-- +-- >>> dsl = CypherDSLParams (returnF []) :: CypherDSLParams '[ '("foo", Int), '("bar", Text) ] () +-- >>> :t queryWithParams dsl +-- queryWithParams dsl +-- :: MonadIO m => +-- (SymbolS "foo", Int) +-- -> (SymbolS "bar", Text) -> BoltActionT m [Record] +-- >>> :t queryWithParams dsl (#foo =: 42) +-- queryWithParams dsl (#foo =: 42) +-- :: MonadIO m => (SymbolS "bar", Text) -> BoltActionT m [Record] +-- >>> :t queryWithParams dsl (#foo =: 42) (#bar =: "Hello") +-- queryWithParams dsl (#foo =: 42) (#bar =: "Hello") +-- :: MonadIO m => BoltActionT m [Record] +-- >>> :t queryWithParams dsl (#foo =: True) +-- ... +-- ... Couldn't match type ‘Int’ with ‘Bool’ +-- ... +-- >>> :t queryWithParams dsl (#bar =: 42) +-- ... +-- ... Couldn't match type ‘"bar"’ with ‘"foo"’ +-- ... +queryWithParams + :: forall params m fun + . MonadIO m + => QueryWithParams params m fun + => CypherDSLParams params () + -> fun +queryWithParams (CypherDSLParams dsl) = collectParams @params @m dsl [] diff --git a/src/Database/Bolt/Extras/DSL/Typed/Types.hs b/src/Database/Bolt/Extras/DSL/Typed/Types.hs --- a/src/Database/Bolt/Extras/DSL/Typed/Types.hs +++ b/src/Database/Bolt/Extras/DSL/Typed/Types.hs @@ -47,6 +47,9 @@ -- of labels. type HasField (types :: k) (field :: Symbol) (typ :: Type) :: Constraint + -- | This constraint checks that field with this name exists in the collection, with any type. + type HasField' (types :: k) (field :: Symbol) :: Constraint + -- | Set an identifier — Cypher variable name. withIdentifier :: Text -> a types -> a types @@ -65,6 +68,14 @@ -> a types -> a types + -- | Add a property as named parameter (@$foo@). Only checks that given property exists, + -- no matter its type. + withParam + :: HasField' types field + => (SymbolS field, Text) + -> a types + -> a types + -- | Synonym for 'withLabel' with label type variable as first one, enabling @lbl \@Foo@ type -- application syntax. lbl @@ -113,6 +124,28 @@ -> a types -> a types propMaybe (name, Just val) = withProp (name, val) propMaybe _ = id + +-- | Shorter synonym for 'withParam'. +-- +-- >>> data Foo = Foo { foo :: Int, bar :: Maybe String } deriving Generic +-- >>> toCypherN $ defN .& lbl @Foo .& param (#foo =: "foo") +-- (:Foo{foo:$foo}) +-- >>> toCypherN $ defN .& lbl @Foo .& prop (#foo =: 42) .& param (#bar =: "bar") +-- (:Foo{foo:42,bar:$bar}) +-- >>> toCypherN $ defN .& lbl @Foo .& param (#baz =: "baz") +-- ... +-- ... There is no field "baz" in any of the records +-- ... '[Foo] +-- ... +-- +-- __NOTE__: this will add @$@ symbol to parameter name automatically. +param + :: forall (field :: Symbol) (a :: k -> Type) (types :: k) + . SelectorLike a + => HasField' types field + => (SymbolS field, Text) + -> a types -> a types +param = withParam -- | Smart constructor for a pair of field name and its value. To be used with @OverloadedLabels@: -- diff --git a/src/Database/Bolt/Extras/Internal/Cypher.hs b/src/Database/Bolt/Extras/Internal/Cypher.hs --- a/src/Database/Bolt/Extras/Internal/Cypher.hs +++ b/src/Database/Bolt/Extras/Internal/Cypher.hs @@ -59,8 +59,13 @@ instance ToCypher Property where toCypher (propTitle, value) = T.concat [propTitle, pack ":", toCypher value] +instance ToCypher (Text, Text) where + toCypher (propTitle, param) = propTitle <> ":$" <> param + -- | Several properties are formatted with concatenation. -- instance ToCypher [Property] where toCypher = T.intercalate "," . map toCypher +instance ToCypher [(Text, Text)] where + toCypher = T.intercalate "," . map toCypher diff --git a/test/Doctest.hs b/test/Doctest.hs --- a/test/Doctest.hs +++ b/test/Doctest.hs @@ -10,4 +10,5 @@ [ "-isrc" , "src/Database/Bolt/Extras/DSL/Typed.hs" , "src/Database/Bolt/Extras/DSL/Typed/Types.hs" + , "src/Database/Bolt/Extras/DSL/Typed/Parameters.hs" ]