diff --git a/.gitignore b/.gitignore index 7546d70..d5fa922 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,5 @@ cabal.sandbox.config cabal.project.local .HTF/ *.swo +*.swp +stack.yaml.lock diff --git a/CHANGELOG.md b/CHANGELOG.md index a9f0c4c..1023b40 100644 --- a/CHANGELOG.md +++ b/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. diff --git a/hasbolt-extras.cabal b/hasbolt-extras.cabal index d423a31..47d7e78 100644 --- a/hasbolt-extras.cabal +++ b/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 diff --git a/src/Database/Bolt/Extras/DSL/Typed.hs b/src/Database/Bolt/Extras/DSL/Typed.hs index d843ed6..a1e4ee5 100644 --- a/src/Database/Bolt/Extras/DSL/Typed.hs +++ b/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"}) + +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 + -} {- $safety diff --git a/src/Database/Bolt/Extras/DSL/Typed/Families.hs b/src/Database/Bolt/Extras/DSL/Typed/Families.hs index 7812c28..9595462 100644 --- a/src/Database/Bolt/Extras/DSL/Typed/Families.hs +++ b/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 diff --git a/src/Database/Bolt/Extras/DSL/Typed/Types.hs b/src/Database/Bolt/Extras/DSL/Typed/Types.hs index 96be980..c890f04 100644 --- a/src/Database/Bolt/Extras/DSL/Typed/Types.hs +++ b/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 + diff --git a/src/Database/Bolt/Extras/Graph/Internal/Get.hs b/src/Database/Bolt/Extras/Graph/Internal/Get.hs index 670c7db..785dd3e 100644 --- a/src/Database/Bolt/Extras/Graph/Internal/Get.hs +++ b/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 (#) = (&) diff --git a/stack.yaml b/stack.yaml index f1a8611..af71e52 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.14 +resolver: lts-13.6 packages: - '.' diff --git a/test/Doctest.hs b/test/Doctest.hs index 88669b3..87eca4c 100644 --- a/test/Doctest.hs +++ b/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" ]