diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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.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 diff --git a/src/Database/Bolt/Extras/DSL/Typed.hs b/src/Database/Bolt/Extras/DSL/Typed.hs new file mode 100644 --- /dev/null +++ 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 new file mode 100644 --- /dev/null +++ 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 new file mode 100644 --- /dev/null +++ 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 diff --git a/src/Database/Bolt/Extras/DSL/Typed/Types.hs b/src/Database/Bolt/Extras/DSL/Typed/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Extras/DSL/Typed/Types.hs @@ -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 diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -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" + ]