hasbolt-extras 0.0.1.0 → 0.0.1.1

raw patch · 12 files changed

+249/−17 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• hasbolt-extras.cabal +2/−1
• src/Database/Bolt/Extras/DSL/Internal/Instances.hs +34/−8
• src/Database/Bolt/Extras/DSL/Internal/Language.hs +1/−1
• src/Database/Bolt/Extras/DSL/Internal/Types.hs +5/−2
• src/Database/Bolt/Extras/DSL/Typed.hs +40/−4
• src/Database/Bolt/Extras/DSL/Typed/Families.hs +6/−0
• src/Database/Bolt/Extras/DSL/Typed/Instances.hs +20/−1
• src/Database/Bolt/Extras/DSL/Typed/Parameters.hs +97/−0
• src/Database/Bolt/Extras/DSL/Typed/Types.hs +33/−0
• src/Database/Bolt/Extras/Internal/Cypher.hs +5/−0
• test/Doctest.hs +1/−0

@@ -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.

@@ -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

@@ -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

@@ -22,7 +22,7 @@  -- | A synonym for 'Free' DSL. ---type CypherDSL a = Free Expr ()+type CypherDSL a = Free Expr a  -- | Prepare 'CREATE' query --

@@ -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

@@ -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. -}

@@ -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

@@ -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)

@@ -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 []

@@ -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@: --

@@ -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

@@ -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"     ]