Typed selectors for DSL (#31)

* Working implementation of selectors * Add operators for paths * Add OverloadedLabels instances for typed selectors * Add TypeError for relationship labels * Add custom type errors * Change .# to prop * Write top-level haddock for Typed module * Add function-level haddocks * Document internal type families * Add doctest to cabal * Add a note about performance * PR remarks * Add p combinator * Add '.&' * Add complex query example * version 0.0.0.23: type-safe selectors * Fix type families to get not only first field * Update doctest * Update CHANGELOG.md Co-Authored-By: Bogdan Neterebskii <[email protected]>
biocad · Nov 7, 2019 · 6e3016b · 6e3016b
1 parent 878f11a
commit 6e3016b
Show file tree

Hide file tree

Showing 7 changed files with 512 additions and 1 deletion.
diff --git 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.23] - 2019-11-07
+### Added
+- Type-safe selectors for nodes and relationships.
+
 ## [0.0.0.22] - 2019-09-19
 ### Changed
 - Exported `(#)` operator.

diff --git a/hasbolt-extras.cabal b/hasbolt-extras.cabal
@@ -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 @@ library
                      , 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 @@ library
                      , 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
@@ -79,3 +83,15 @@ executable example
                      , 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
diff --git a/src/Database/Bolt/Extras/DSL/Typed.hs b/src/Database/Bolt/Extras/DSL/Typed.hs
@@ -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)
+-}
diff --git a/src/Database/Bolt/Extras/DSL/Typed/Families.hs b/src/Database/Bolt/Extras/DSL/Typed/Families.hs
@@ -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
+        )
diff --git a/src/Database/Bolt/Extras/DSL/Typed/Instances.hs b/src/Database/Bolt/Extras/DSL/Typed/Instances.hs
@@ -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