version 0.0.0.24: Maybe in typed selectors (#33)

* version 0.0.0.24: Maybe in typed selectors

* Integrate typed selectors and graph api

* Export converters to untyped DSL

* lts version up

.gitignore

@@ -20,3 +20,5 @@ cabal.sandbox.config
 cabal.project.local
 .HTF/
 *.swo
+*.swp
+stack.yaml.lock

CHANGELOG.md

@@ -6,6 +6,11 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.
 
 ## [Unreleased]
 
+## [0.0.0.24] - 2019-11-08
+### Added
+- Support for `Maybe` fields in typed selectors;
+- Integration of typed selectors and Graph API.
+
 ## [0.0.0.23] - 2019-11-07
 ### Added
 - Type-safe selectors for nodes and relationships.

hasbolt-extras.cabal

@@ -1,5 +1,5 @@
 name:           hasbolt-extras
-version:        0.0.0.23
+version:        0.0.0.24
 synopsis:       Extras for hasbolt library
 description:    Extras for hasbolt library
 homepage:       https://github.com/biocad/hasbolt-extras#readme

src/Database/Bolt/Extras/DSL/Typed.hs

@@ -22,8 +22,10 @@ module Database.Bolt.Extras.DSL.Typed
     SelectorLike(..)
   , lbl
   , prop
+  , propMaybe
   , (=:)
   , NodeSelector, RelSelector
+  , nodeSelector, relSelector
   , defN
   , defR
 
@@ -40,19 +42,23 @@ module Database.Bolt.Extras.DSL.Typed
   ) where
 
 
-import Database.Bolt.Extras.DSL.Typed.Types
-import Database.Bolt.Extras.DSL.Typed.Instances ()
+import           Database.Bolt.Extras.DSL.Typed.Instances ()
+import           Database.Bolt.Extras.DSL.Typed.Types
 
 {- $setup
 >>> :set -XDeriveGeneric
 >>> :set -XTypeApplications
 >>> :set -XOverloadedLabels
 >>> :set -XOverloadedStrings
+>>> :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)
 >>> import GHC.Generics (Generic)
 >>> import Database.Bolt.Extras (toCypher)
->>> toCypherN = putStrLn . unpack . toCypher  . unsafeNodeSelector
->>> toCypherR = putStrLn . unpack . toCypher . unsafeRelSelector
+>>> import Data.Function ((&))
+>>> import qualified Database.Bolt.Extras.Graph as G
+>>> toCypherN = putStrLn . unpack . toCypher . nodeSelector
+>>> toCypherR = putStrLn . unpack . toCypher . relSelector
 >>> toCypherP = putStrLn . unpack . toCypher
 >>> data Binder = Binder { uuid :: Text } deriving (Generic)
 >>> data Foo = Foo { bar :: Bool, foo :: Int } deriving (Generic)
@@ -64,8 +70,9 @@ import Database.Bolt.Extras.DSL.Typed.Instances ()
 >>> 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
+>>> import Database.Bolt.Extras.DSL as DSL (createF, mergeF, Selector(..), formQuery, returnF)
+>>> toCypherQ = putStrLn . unpack . DSL.formQuery
+>>> formQueryG = putStrLn . unpack . G.formQuery @G.GetRequest []
 -}
 
 {- $selecting
@@ -129,6 +136,58 @@ toCypherQ $ do
 :}
 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
 
+==== Dropping types
+
+It is possible to convert typed selectors to untyped ones from 'Database.Bolt.Extras.DSL.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
+of graph query using typed selectors.
+
+>>> import Database.Bolt.Extras.Graph
+>>> nToG = ngFromDSL . nodeSelector
+>>> rToG = rgFromDSL . relSelector
+>>> :{
+formQueryG $ emptyGraph
+ & addNode "binder"
+   (nToG
+      (defN .& lbl @Binder .& prop (#uuid =: "123-456"))
+      & isReturned
+      & withReturn allProps
+   )
+ & addNode "user"
+   (nToG
+      (defN .& lbl @User .& prop (#user =: "098-765"))
+      & isReturned
+      & withReturn allProps
+   )
+ & addRelation "user" "binder"
+   (rToG
+      (defR .& lbl @USER_CREATED)
+      & isReturned
+      & withReturn allProps
+   )
+:}
+MATCH (user)-[user0binder :USER_CREATED {}]->(binder)
+, (binder :Binder {uuid:"123-456"})
+, (user :User {user:"098-765"})
+<BLANKLINE>
+WITH DISTINCT binder, user, user0binder
+RETURN { id: id(binder),
+  labels: labels(binder),
+  props: properties(binder)
+} as binder
+, { id: id(user),
+  labels: labels(user),
+  props: properties(user)
+} as user
+, { id: id(user0binder),
+  label: type(user0binder),
+  props: properties(user0binder)
+} as user0binder
+<BLANKLINE>
 -}
 
 {- $safety

src/Database/Bolt/Extras/DSL/Typed/Families.hs

@@ -26,7 +26,9 @@ type family RecordHasField (field :: Symbol) (record :: k -> Type) :: Bool where
 -- | 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 (Maybe typ))) = typ
   GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 typ)) = typ
+  GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 (Maybe typ) ) :*: _) = typ
   GetTypeFromRecord field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 typ ) :*: _) = typ
   GetTypeFromRecord field (S1 ('MetaSel ('Just _) _ _ _) (Rec0 typ ) :*: r) =
     GetTypeFromRecord field r

src/Database/Bolt/Extras/DSL/Typed/Types.hs

@@ -17,6 +17,17 @@ import qualified Database.Bolt.Extras.DSL                as UT
 
 import           Database.Bolt.Extras.DSL.Typed.Families
 
+{- $setup
+>>> :set -XDeriveGeneric
+>>> :set -XTypeApplications
+>>> :set -XOverloadedLabels
+>>> :load Database.Bolt.Extras.DSL.Typed.Instances
+>>> import Data.Text (unpack)
+>>> import GHC.Generics (Generic)
+>>> import Database.Bolt.Extras (toCypher)
+>>> toCypherN = putStrLn . unpack . toCypher  . nodeSelector
+-}
+
 -- | 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.
 --
@@ -66,6 +77,15 @@ lbl
 lbl = withLabel
 
 -- | Shorter synonym for 'withProp'.
+--
+-- Properties of type @Maybe a@ are treated as properties of type @a@, since there is no difference
+-- between the two in Cypher.
+--
+-- >>> data Foo = Foo { foo :: Int, bar :: Maybe String } deriving Generic
+-- >>> toCypherN $ defN .& lbl @Foo .& prop (#foo =: 42)
+-- (:Foo{foo:42})
+-- >>> toCypherN $ defN .& lbl @Foo .& prop (#bar =: "hello")
+-- (:Foo{bar:"hello"})
 prop
   :: forall (field :: Symbol) (a :: k -> Type) (types :: k) (typ :: Type)
   .  SelectorLike a
@@ -75,6 +95,25 @@ prop
   -> a types -> a types
 prop = withProp
 
+-- | A variant of 'prop' that accepts values in @Maybe@. If given @Nothing@, does nothing.
+--
+-- This works both for properties with @Maybe@ and without.
+--
+-- >>> data Foo = Foo { foo :: Int, bar :: Maybe String } deriving Generic
+-- >>> toCypherN $ defN .& lbl @Foo .& propMaybe (#foo =: Just 42)
+-- (:Foo{foo:42})
+-- >>> toCypherN $ defN .& lbl @Foo .& propMaybe (#bar =: Nothing)
+-- (:Foo)
+propMaybe
+  :: forall (field :: Symbol) (a :: k -> Type) (types :: k) (typ :: Type)
+  .  SelectorLike a
+  => HasField types field typ
+  => B.IsValue typ
+  => (SymbolS field, Maybe typ)
+  -> a types -> a types
+propMaybe (name, Just val) = withProp (name, val)
+propMaybe _                = id
+
 -- | Smart constructor for a pair of field name and its value. To be used with @OverloadedLabels@:
 --
 -- > #uuid =: "123"
@@ -85,14 +124,18 @@ prop = withProp
 --
 -- Node selectors remember arbitrary number of labels in a type-level list.
 newtype NodeSelector (typ :: [Type])
-  = NodeSelector { unsafeNodeSelector :: UT.NodeSelector }
+  = NodeSelector
+      { nodeSelector :: UT.NodeSelector -- ^ Convert to untyped '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 }
+  = RelSelector
+      { relSelector :: UT.RelSelector -- ^ Convert to untyped 'UT.RelSelector'.
+      }
     deriving (Show, Eq)
 
 newtype SymbolS (s :: Symbol) = SymbolS { getSymbol :: String }
@@ -136,3 +179,4 @@ 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
+

src/Database/Bolt/Extras/Graph/Internal/Get.hs

@@ -15,6 +15,7 @@ module Database.Bolt.Extras.Graph.Internal.Get
     NodeGetter (..)
   , RelGetter (..)
   , GetterLike (..)
+  , ngFromDSL, rgFromDSL
   , (#)
   , defaultNode
   , defaultRel
@@ -79,6 +80,7 @@ import           Database.Bolt.Extras                              (BoltId, GetB
                                                                     NodeLike (..),
                                                                     ToCypher (..),
                                                                     URelationLike (..))
+import qualified Database.Bolt.Extras.DSL                          as DSL
 import           Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph,
                                                                     NodeName,
                                                                     relationName,
@@ -117,6 +119,26 @@ data RelGetter = RelGetter { rgboltId      :: Maybe BoltId     -- ^ known 'BoltI
                            }
   deriving (Show, Eq)
 
+-- | Create a 'NodeGetter' from 'DSL.NodeSelector' from the DSL. 'ngIsReturned' is set to @False@.
+ngFromDSL :: DSL.NodeSelector-> NodeGetter
+ngFromDSL DSL.NodeSelector {..} = NodeGetter
+  { ngboltId      = Nothing
+  , ngLabels      = nodeLabels
+  , ngProps       = fromList nodeProperties
+  , ngReturnProps = []
+  , ngIsReturned  = False
+  }
+
+-- | Create a 'RelGetter' from 'DSL.RelSelector' from the DSL. 'rgIsReturned' is set to @False@.
+rgFromDSL :: DSL.RelSelector -> RelGetter
+rgFromDSL DSL.RelSelector {..} = RelGetter
+  { rgboltId      = Nothing
+  , rgLabel       = Just relLabel
+  , rgProps       = fromList relProperties
+  , rgReturnProps = []
+  , rgIsReturned  = False
+  }
+
 -- | A synonym for '&'. Kept for historical reasons.
 (#) :: a -> (a -> b) -> b
 (#) = (&)

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-11.14
+resolver: lts-13.6
 
 packages:
 - '.'

test/Doctest.hs

@@ -9,4 +9,5 @@ main =
   doctest
     [ "-isrc"
     , "src/Database/Bolt/Extras/DSL/Typed.hs"
+    , "src/Database/Bolt/Extras/DSL/Typed/Types.hs"
     ]