hasbolt-extras 0.0.0.22 → 0.0.0.23

raw patch · 7 files changed

+514/−2 lines, 7 filesdep +doctestdep ~hasboltPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: doctest

Dependency ranges changed: hasbolt

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• hasbolt-extras.cabal +18/−2
• src/Database/Bolt/Extras/DSL/Typed.hs +189/−0
• src/Database/Bolt/Extras/DSL/Typed/Families.hs +62/−0
• src/Database/Bolt/Extras/DSL/Typed/Instances.hs +91/−0
• src/Database/Bolt/Extras/DSL/Typed/Types.hs +138/−0
• test/Doctest.hs +12/−0

@@ -6,6 +6,10 @@  ## [Unreleased] +## [0.0.0.23] - 2019-11-07+### Added+- Type-safe selectors for nodes and relationships.+ ## [0.0.0.22] - 2019-09-19 ### Changed - Exported `(#)` operator.

@@ -1,5 +1,5 @@ name:           hasbolt-extras-version:        0.0.0.22+version:        0.0.0.23 synopsis:       Extras for hasbolt library description:    Extras for hasbolt library homepage:       https://github.com/biocad/hasbolt-extras#readme@@ -27,6 +27,7 @@                      , Database.Bolt.Extras.Graph                      , Database.Bolt.Extras.Template                      , Database.Bolt.Extras.DSL+                     , Database.Bolt.Extras.DSL.Typed                      , Database.Bolt.Extras.Utils   other-modules:       Database.Bolt.Extras.Internal.Cypher                      , Database.Bolt.Extras.Internal.Condition@@ -40,6 +41,9 @@                      , Database.Bolt.Extras.DSL.Internal.Language                      , Database.Bolt.Extras.DSL.Internal.Executer                      , Database.Bolt.Extras.DSL.Internal.Instances+                     , Database.Bolt.Extras.DSL.Typed.Types+                     , Database.Bolt.Extras.DSL.Typed.Families+                     , Database.Bolt.Extras.DSL.Typed.Instances                       , Database.Bolt.Extras.Graph.Internal.AbstractGraph                      , Database.Bolt.Extras.Graph.Internal.Class@@ -52,7 +56,7 @@                      , aeson-casing >= 0.1.0.5                      , containers >= 0.5.10.2                      , free >= 5.0-                     , hasbolt >= 0.1.3.0+                     , hasbolt >= 0.1.3.5                      , lens >= 4.16                      , mtl >= 2.2.0                      , neat-interpolation >= 0.3.2.0@@ -79,3 +83,15 @@                      , text   default-language:    Haskell2010   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -O2++test-suite doctest+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Doctest.hs++  build-depends:       base >= 4.7 && < 5  +                     , hasbolt-extras+                     , doctest >= 0.16++  default-language:    Haskell2010+  ghc-options:         -threaded

@@ -0,0 +1,189 @@+{- | Type-safe DSL for Cypher++This module extends selectors from 'Database.Bolt.Extras.DSL.DSL' with extra type-level+information to make them more type-safe to use.++None of additional type information exists at runtime, so using this module does not degrade+performance at all.++-}++module Database.Bolt.Extras.DSL.Typed+  (++  -- * Selecting Nodes and Relations+  --+  -- $selecting++  -- ** Type safety+  --+  -- $safety++    SelectorLike(..)+  , lbl+  , prop+  , (=:)+  , NodeSelector, RelSelector+  , defN+  , defR++  -- * Building paths+  --+  -- $paths++  , (.&)+  , (!->:)+  , (!-:)+  , (-:)+  , (<-:)+  , p+  ) where+++import Database.Bolt.Extras.DSL.Typed.Types+import Database.Bolt.Extras.DSL.Typed.Instances ()++{- $setup+>>> :set -XDeriveGeneric+>>> :set -XTypeApplications+>>> :set -XOverloadedLabels+>>> :set -XOverloadedStrings+>>> import Data.Text (Text, unpack)+>>> import GHC.Generics (Generic)+>>> import Database.Bolt.Extras (toCypher)+>>> toCypherN = putStrLn . unpack . toCypher  . unsafeNodeSelector+>>> toCypherR = putStrLn . unpack . toCypher . unsafeRelSelector+>>> toCypherP = putStrLn . unpack . toCypher+>>> data Binder = Binder { uuid :: Text } deriving (Generic)+>>> data Foo = Foo { bar :: Bool, foo :: Int } deriving (Generic)+>>> data PLACE = PLACE deriving (Generic)+>>> data ELEMENT = ELEMENT deriving (Generic)+>>> data Name = Name { name :: Text } deriving (Generic)+>>> data User = User { user :: Text } deriving (Generic)+>>> data NAME_OF = NAME_OF deriving (Generic)+>>> data USER_CREATED = USER_CREATED { timestamp :: Int } deriving (Generic)+>>> data Library = Library deriving (Generic)+>>> data BinderLibrary = BinderLibrary deriving (Generic)+>>> import Database.Bolt.Extras.DSL (createF, mergeF, Selector(..), formQuery, returnF)+>>> toCypherQ = putStrLn . unpack . formQuery+-}++{- $selecting++There are types for Node and Relationship selectors: 'NodeSelector' and 'RelSelector'.+Both of them carry extra type-level information about labels assigned to Cypher variables.++Empty selectors may be constructed with 'defN' and 'defR' respectively. Selectors can be+extended with the following combinators:++- 'withIdentifier' adds an identifier (variable name)+- '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++Typically selectors are chained by '.&' starting from 'defN' or 'defR' like this:++>>> toCypherN $ defN .& withIdentifier "binder" .& lbl @Binder .& prop (#uuid =: "123-456")+(binder:Binder{uuid:"123-456"})++Alternatively, @OverloadedLabels@ may be used to create an empty selector with an identifier:++>>> toCypherN $ #binder .& lbl @Binder .& prop (#uuid =: "123-456")+(binder:Binder{uuid:"123-456"})++This syntax is more concise and makes it obvious what is going on. Thus, it is the preferred+one.++The type used with 'lbl' should have 'GHC.Generics.Generic' instance.++Nodes may have multiple labels:++>>> toCypherN $ defN .& lbl @Binder .& lbl @Foo+(:Foo:Binder)++But relations have at most one:++>>> defR .& lbl @PLACE .& lbl @ELEMENT+...+... Can't add a new label to relationship selector that already has label PLACE!+...++==== Complex queries++These selectors are fully compatible with the 'Database.Bolt.Extras.DSL.DSL':++>>> :{+toCypherQ $ do+   mergeF+     [ PS $ p $ #name .& lbl @Name .& prop (#name =: "CT42")+     ]+   mergeF+     [ PS $ p $ #user .& lbl @User .& prop (#user =: "123-456")+     ]+   createF+     [ PS $ p $ #lib .& lbl @Library .& lbl @BinderLibrary+     , PS $ #name -: defR .& lbl @NAME_OF !->: #lib+     , PS $ #user -: defR .& lbl @USER_CREATED .& prop (#timestamp =: 1572340394000) !->: #lib+     ]+   returnF ["lib"]+:}+MERGE (name:Name{name:"CT42"}) MERGE (user:User{user:"123-456"}) CREATE (lib:BinderLibrary:Library), (name)-[:NAME_OF]->(lib), (user)-[:USER_CREATED{timestamp:1572340394000}]->(lib) RETURN lib++-}++{- $safety++Obviosuly, if you try to use @lbl \@Foo@ syntax with undefined type @Foo@, GHC itself+will report the error.++Here are more interesting cases:++>>> -- Properties are looked for in all labels+>>> toCypherN $ defN .& lbl @Binder .& lbl @Foo .& prop (#foo =: 42) .& prop (#uuid =: "123-456")+(:Foo:Binder{uuid:"123-456",foo:42})++>>> -- Adding a property to node without any labels+>>> defN .& prop (#uuid =: "123-456")+...+... There is no field "uuid" in any of the records+... '[]+...++>>> -- Adding a property that does not exist in the label+>>> defN .& lbl @Binder .& prop (#foo =: 42)+...+... There is no field "foo" in any of the records+... '[Binder]+...++>>> -- Adding a property with wrong type+>>> defN .& lbl @Binder .& prop (#uuid =: 42)+...+... No instance for (Num Text) arising from the literal ‘42’+...++Here we see that GHC undestands that the property should have type @Text@ and tries to unify it with+the type of literal @42@, which is @Num a => a@.++>>> -- Adding a property to relationship without a label+>>> defR .& prop (#foo =: 42)+...+... Tried to set property "foo" on a relationship without label!+...+-}++{- $paths++This module is completely interopable with path selectors from 'Database.Bolt.Extras.DSL.DSL' —+adding a 'NodeSelector' or 'RelSelector' to path simply drops all type information, converting it+into untyped variant.++Due to limitation of what symbols are allowed in operators and operator-like data constructors, this+module renames some of the path constructors. Precedence of the operators allow them to be combined+in the same expression with '.&' and '$' without any extra parentheses.++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)+-}

@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Type Families that implement the logic of type-level labels.+module Database.Bolt.Extras.DSL.Typed.Families where++import           Data.Kind      (Constraint, Type)+import           Data.Type.Bool (If, type (||))+import           GHC.Generics   ((:*:), C1, D1, Meta (..), Rec0, Rep, S1)+import           GHC.TypeLits   (ErrorMessage (..), Symbol, TypeError)++-- | This family extracts name of the type from Generic 'Rep'.+type family GetTypeName (a :: k -> Type) :: Symbol where+  GetTypeName (D1 ('MetaData name _ _ _) _) = name++-- | This family checks whether a record (in a form of 'Rep') has a field with given name.+type family RecordHasField (field :: Symbol) (record :: k -> Type) :: Bool where+  RecordHasField field (D1 _ (C1 _ sels)) = RecordHasField field sels+  RecordHasField field (l :*: r) = RecordHasField field l || RecordHasField field r+  RecordHasField field (S1 ('MetaSel ('Just field) _ _ _) _) = 'True+  RecordHasField _ _ = 'False++-- | This family extracts the type of field with given name from Generic record in a 'Rep'.+type family GetTypeFromRecord (field :: Symbol) (record :: k -> Type) :: Type where+  GetTypeFromRecord field (D1 _ (C1 _ sels)) = GetTypeFromRecord field sels+  GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 typ)) = typ+  GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 typ ) :*: _) = typ+  GetTypeFromRecord field (S1 ('MetaSel ('Just _) _ _ _) (Rec0 typ ) :*: r) =+    GetTypeFromRecord field r++-- | This family extracts a type of the field with given name from the first type in the list+-- that has it.+type family GetTypeFromList (field :: Symbol) (types :: [Type]) :: Type where+  GetTypeFromList field (t ': ts)+    = If+        (RecordHasField field (Rep t))+        (GetTypeFromRecord field (Rep t))+        (GetTypeFromList field ts)++-- * Implementation of type errors++-- | Just a dummy type for implementation trick.+-- This is based on https://kcsongor.github.io/report-stuck-families/+data T1++type family Any :: k+-- | This family is able to check whether its argument is stuck and resolve with an error+-- in that case.+type family Assert (err :: Constraint) (a :: k) :: k where+  Assert _ T1 = Any+  Assert _ k = 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+    = TypeError+        ('Text "There is no field " ':<>: 'ShowType field ':<>: 'Text " in any of the records"+         ':$$: 'ShowType types+        )

@@ -0,0 +1,91 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Database.Bolt.Extras.DSL.Typed.Instances where++import           Data.Coerce                             (coerce)+import           Data.Function                           ((&))+import           Data.Kind                               (Type)+import           Data.Text                               (pack)+import           GHC.Exts                                (proxy#)+import           GHC.Generics                            (Rep)+import           GHC.OverloadedLabels                    (IsLabel (..))+import           GHC.TypeLits                            (ErrorMessage (..),+                                                          KnownSymbol, Symbol,+                                                          TypeError, symbolVal')++import qualified Database.Bolt                           as B+import qualified Database.Bolt.Extras.DSL                as UT++import           Database.Bolt.Extras.DSL.Typed.Families+import           Database.Bolt.Extras.DSL.Typed.Types++instance (KnownSymbol x, types ~ '[]) => IsLabel x (NodeSelector types) where+  fromLabel = defN & withIdentifier (pack $ symbolVal' @x proxy#)++instance (KnownSymbol x, types ~ 'Nothing) => IsLabel x (RelSelector types) where+  fromLabel = defR & withIdentifier (pack $ symbolVal' @x proxy#)++instance (field ~ field1, KnownSymbol field) => IsLabel field (SymbolS field1) where+  fromLabel = SymbolS $ symbolVal' @field proxy#++instance SelectorLike NodeSelector where+  type CanAddType _ = ()+  type AddType (types :: [Type]) (typ :: Type) = typ ': types+  type HasField (types :: [Type]) (field :: Symbol) (typ :: Type) =+    Assert (NoFieldError field types) (GetTypeFromList field types) ~ typ++  withIdentifier = coerce $ UT.withIdentifier @UT.NodeSelector+  withLabel+    :: forall (typ :: Type) (types :: [Type]) (label :: Symbol)+    .  label ~ GetTypeName (Rep typ)+    => KnownSymbol label+    => NodeSelector types -> NodeSelector (typ ': types)+  withLabel = coerce $ UT.withLabel @UT.NodeSelector $ pack $ symbolVal' @label proxy#++  withProp+    :: forall (field :: Symbol) (types :: [Type]) (typ :: Type)+    .  B.IsValue typ+    => (SymbolS field, typ) -> NodeSelector types -> NodeSelector types+  withProp (SymbolS field, val) = coerce $ UT.withProp @UT.NodeSelector $ pack field B.=: val++instance SelectorLike RelSelector where+  type CanAddType 'Nothing = ()+  type CanAddType ('Just a)+    = TypeError+        ('Text "Can't add a new label to relationship selector that already has label "+         ':<>: 'ShowType a+         ':<>: 'Text "!"+        )+  type AddType 'Nothing (typ :: Type) = 'Just 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) (typ :: Type) =+    Assert (NoFieldError field '[record]) (GetTypeFromRecord field (Rep record)) ~ typ++  withIdentifier = coerce $ UT.withIdentifier @UT.RelSelector+  withLabel+    :: forall (typ :: Type) (types :: Maybe Type) (label :: Symbol)+    .  CanAddType types+    => GetTypeName (Rep typ) ~ label+    => KnownSymbol label+    => RelSelector types -> RelSelector (AddType types typ)+  withLabel = coerce $ UT.withLabel @UT.RelSelector $ pack $ symbolVal' @label proxy#++  withProp+    :: forall (field :: Symbol) (types :: Maybe Type) (typ :: Type)+    .  B.IsValue typ+    => (SymbolS field, typ) -> RelSelector types -> RelSelector types+  withProp (SymbolS field, val) = coerce $ UT.withProp @UT.RelSelector $ pack field B.=: val

@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeInType             #-}++module Database.Bolt.Extras.DSL.Typed.Types where++import           Data.Kind                               (Constraint, Type)+import           Data.Text                               (Text)+import qualified Database.Bolt                           as B+import           GHC.Generics                            (Rep)+import           GHC.TypeLits                            (KnownSymbol, Symbol)++import qualified Database.Bolt.Extras.DSL                as UT++import           Database.Bolt.Extras.DSL.Typed.Families++-- | Class for Selectors that know type of their labels. This class is kind-polymorphic,+-- so that instances may select a specific collection of labels they support.+--+-- __NOTE__: Due to the way GHC orders type variables for class methods, it's more convenient+-- to use 'lbl' and 'prop' synonyms defined below, and 'withLabel' and 'withProp' methods+-- should be considered an implementation detail.+class SelectorLike (a :: k -> Type) where+  -- | This constraint checks that current collection of types supports adding one more.+  type CanAddType (types :: k) :: Constraint++  -- | This type family implements adding a new type (of label) to the collection.+  --+  -- Injectivity annotation is required to make type inference possible.+  type AddType (types :: k) (typ :: Type) = (result :: k) | result -> types typ++  -- | This constraint checks that field with this name has correct type in the collection+  -- of labels.+  type HasField (types :: k) (field :: Symbol) (typ :: Type) :: Constraint++  -- | Set an identifier — Cypher variable name.+  withIdentifier :: Text -> a types -> a types++  -- | Add a new label, if possible.+  withLabel+    :: CanAddType types+    => KnownSymbol (GetTypeName (Rep typ))+    => a types+    -> a (AddType types typ)++  -- | Add a property with value, checking that such property exists.+  withProp+    :: HasField types field typ+    => B.IsValue typ+    => (SymbolS field, typ)+    -> a types+    -> a types++-- | Synonym for 'withLabel' with label type variable as first one, enabling @lbl \@Foo@ type+-- application syntax.+lbl+  :: forall (typ :: Type) k (types :: k) (a :: k -> Type)+  .  SelectorLike a+  => CanAddType types+  => KnownSymbol (GetTypeName (Rep typ))+  => a types+  -> a (AddType types typ)+lbl = withLabel++-- | Shorter synonym for 'withProp'.+prop+  :: forall (field :: Symbol) (a :: k -> Type) (types :: k) (typ :: Type)+  .  SelectorLike a+  => HasField types field typ+  => B.IsValue typ+  => (SymbolS field, typ) -- ^ Field name along with its value. This pair should be constructed with '=:'.+  -> a types -> a types+prop = withProp++-- | Smart constructor for a pair of field name and its value. To be used with @OverloadedLabels@:+--+-- > #uuid =: "123"+(=:) :: forall (field :: Symbol) (typ :: Type). SymbolS field -> typ -> (SymbolS field, typ)+(=:) = (,)++-- | A wrapper around 'Database.Extras.DSL.NodeSelector' with phantom type.+--+-- Node selectors remember arbitrary number of labels in a type-level list.+newtype NodeSelector (typ :: [Type])+  = NodeSelector { unsafeNodeSelector :: UT.NodeSelector }+    deriving (Show, Eq)++-- | A wrapper around 'Database.Extras.DSL.RelSelector' with phantom type.+--+-- Relationship selectors remember at most one label in a type-level @Maybe@.+newtype RelSelector (typ :: Maybe Type)+  = RelSelector { unsafeRelSelector :: UT.RelSelector }+    deriving (Show, Eq)++newtype SymbolS (s :: Symbol) = SymbolS { getSymbol :: String }+  deriving (Show)++-- | An empty 'NodeSelector'.+defN :: NodeSelector '[]+defN = NodeSelector UT.defaultNode++-- | An empty 'RelSelector'.+defR :: RelSelector 'Nothing+defR = RelSelector UT.defaultRel++infixl 3 .&+-- | This is the same as 'Data.Function.&', but with higher precedence, so that it binds before+-- path combinators.+(.&) :: a -> (a -> b) -> b+a .& f = f a+{-# INLINE (.&) #-}++infixl 2 !->:+-- | See 'UT.:!->:'. This combinator forgets type-level information from the selectors.+(!->:) :: RelSelector a -> NodeSelector b -> UT.PathPart+RelSelector r !->: NodeSelector n = r UT.:!->: n++infixl 2 !-:+-- | See 'UT.:!-:'. This combinator forgets type-level information from the selectors.+(!-:) :: RelSelector a -> NodeSelector b -> UT.PathPart+RelSelector r !-: NodeSelector n = r UT.:!-: n++infixl 1 -:+-- | See 'UT.-:'. This combinator forgets type-level information from the selectors.+(-:) :: NodeSelector a -> UT.PathPart -> UT.PathSelector+NodeSelector ns -: pp = UT.P ns UT.:-!: pp++infixl 1 <-:+-- | See 'UT.<-:'. This combinator forgets type-level information from the selectors.+(<-:) :: NodeSelector a -> UT.PathPart -> UT.PathSelector+NodeSelector ns <-: pp = UT.P ns UT.:<-!: pp++-- | See 'UT.P'. This combinator forgets type-level information from the selectors.+p :: NodeSelector a -> UT.PathSelector+p (NodeSelector ns) = UT.P ns

@@ -0,0 +1,12 @@+module Main where++import           Test.DocTest (doctest)++-- Taken from https://github.com/kowainik/membrain/blob/master/test/Doctest.hs++main :: IO ()+main =+  doctest+    [ "-isrc"+    , "src/Database/Bolt/Extras/DSL/Typed.hs"+    ]