diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,10 @@ ## [Unreleased] +## [0.0.0.21] - 2019-09-09 +### Added +- `OverloadedLabels` instances and operators for easy selector writing. + ## [0.0.0.20] - 2019-09-06 ### Added - `WITH` statement in DSL. 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.20 +version: 0.0.0.21 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.hs b/src/Database/Bolt/Extras/DSL.hs --- a/src/Database/Bolt/Extras/DSL.hs +++ b/src/Database/Bolt/Extras/DSL.hs @@ -1,8 +1,52 @@ module Database.Bolt.Extras.DSL ( - module Database.Bolt.Extras.DSL.Internal.Types - , module Database.Bolt.Extras.DSL.Internal.Language - , module Database.Bolt.Extras.DSL.Internal.Executer + -- * Selectors for nodes, relations and paths + -- + -- | These data types let you specify Cypher queries. + -- + -- With @OverloadedLabels@ and operators you can write selectors in very concise + -- Cypher-like form: + -- + -- > (#n .: "Name" .# ["name" =: "C42"]) -: (defR .: "NAME_OF") :!->: (#m .: "Molecule") + -- > (n:Name{name:"C42"})-[:NAME_OF]->(m:Molecule) + -- + NodeSelector(..), + RelSelector(..), + SelectorLike(..), + (.:), (.#), + toNodeSelector, toRelSelector, + PathSelector(..), + PathPart(..), + (-:), (<-:), + Selector(..), + Selectors, + + -- ** Default selectors + defaultNode, defN, defaultRel, defR, + + -- * Cypher conditions + Cond(..), + Conds(..), + + -- * DSL for Cypher + -- + -- | The free-monadic DSL lets you write Cypher queries in Haskell like this: + -- + -- > formQuery $ do + -- > matchF [ + -- > PS $ (#n .: "Name" .# ["name" =: "C42"]) -: (defR .: "NAME_OF") :!->: (#m .: "Molecule") + -- > ] + -- > returnF ["n", "m"] + -- + + -- ** DSL operations + module Database.Bolt.Extras.DSL.Internal.Language, + + -- ** Rendering Cypher queries + formQuery, + + -- ** Implementation details + Expr(..) ) where import Database.Bolt.Extras.DSL.Internal.Executer diff --git a/src/Database/Bolt/Extras/DSL/Internal/Instances.hs b/src/Database/Bolt/Extras/DSL/Internal/Instances.hs --- a/src/Database/Bolt/Extras/DSL/Internal/Instances.hs +++ b/src/Database/Bolt/Extras/DSL/Internal/Instances.hs @@ -1,20 +1,34 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Bolt.Extras.DSL.Internal.Instances () where import Control.Monad.Writer (execWriter, tell) +import Data.Function ((&)) import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) import Data.Text (intercalate, pack) import Database.Bolt.Extras (ToCypher (..), fromInt) -import Database.Bolt.Extras.DSL.Internal.Types +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.TypeLits (KnownSymbol, + symbolVal) import NeatInterpolation (text) import Text.Printf (printf) + +import Database.Bolt.Extras.DSL.Internal.Types + +instance KnownSymbol x => IsLabel x NodeSelector where + fromLabel = defaultNode & withIdentifier (pack $ symbolVal @x Proxy) + +instance KnownSymbol x => IsLabel x RelSelector where + fromLabel = defaultRel & withIdentifier (pack $ symbolVal @x Proxy) instance SelectorLike NodeSelector where withIdentifier idx node = node { nodeIdentifier = Just idx } diff --git a/src/Database/Bolt/Extras/DSL/Internal/Language.hs b/src/Database/Bolt/Extras/DSL/Internal/Language.hs --- a/src/Database/Bolt/Extras/DSL/Internal/Language.hs +++ b/src/Database/Bolt/Extras/DSL/Internal/Language.hs @@ -1,6 +1,7 @@ module Database.Bolt.Extras.DSL.Internal.Language ( - createF + CypherDSL + , createF , matchF , optionalMatchF , mergeF @@ -18,6 +19,10 @@ import Data.Text (Text) import Database.Bolt.Extras.DSL.Internal.Types (Conds (..), Expr (..), Selectors) + +-- | A synonym for 'Free' DSL. +-- +type CypherDSL a = Free Expr () -- | Prepare 'CREATE' query -- diff --git a/src/Database/Bolt/Extras/DSL/Internal/Types.hs b/src/Database/Bolt/Extras/DSL/Internal/Types.hs --- a/src/Database/Bolt/Extras/DSL/Internal/Types.hs +++ b/src/Database/Bolt/Extras/DSL/Internal/Types.hs @@ -16,13 +16,20 @@ , Conds (..) , Expr (..) , SelectorLike (..) + , (.:) + , (.#) , (#) + , (-:) + , (<-:) , defaultNode + , defN , defaultRel + , defR , toNodeSelector , toRelSelector ) where +import Data.Foldable (foldl') import Data.Map.Strict (toList) import Data.Text (Text) import Database.Bolt (Node (..), URelationship (..), @@ -38,6 +45,12 @@ -- | Selector for 'Node's. -- +-- This datatype has @OverloadedLabels@ instance to simplify specifying nodes. Labels produce +-- empty nodes. +-- +-- > #foo :: NodeSelector +-- > -- foo = NodeSelector (Just "foo") [] [] +-- data NodeSelector = NodeSelector { nodeIdentifier :: Maybe Text , nodeLabels :: [Text] , nodeProperties :: [(Text, Value)] @@ -46,13 +59,31 @@ -- | Selector for 'URelationship's. -- +-- This datatype has @OverloadedLabels@ instance as well, similar to 'NodeSelector'. data RelSelector = RelSelector { relIdentifier :: Maybe Text , relLabel :: Text , relProperties :: [(Text, Value)] } deriving (Show, Eq) +-- | Operator version of 'withLabel'. To be used with @OverloadedLabels@ instances. +-- +-- > #foo .: "Foo" :: NodeSelector +-- +infixl 9 .: +(.:) :: SelectorLike a => a -> Text -> a +(.:) = flip withLabel +-- | Operator version of 'withProp'. To be used with @OverloadedLabels@ instances. +-- +-- See also 'Database.Bolt.=:' from @Database.Bolt@ package. +-- +-- > #foo .# ["bar" =: 42, "baz" =: "baz"] :: NodeSelector +-- +infixl 9 .# +(.#) :: SelectorLike a => a -> [(Text, Value)] -> a +(.#) = foldl' (flip withProp) + (#) :: a -> (a -> b) -> b (#) = flip ($) @@ -71,6 +102,18 @@ | P NodeSelector -- ^ starting node of Path deriving (Show, Eq) +-- | Combined version of ':-!:' and 'P' for specifying the first node of path. +-- +infixl 1 -: +(-:) :: NodeSelector -> PathPart -> PathSelector +ns -: pp = P ns :-!: pp + +-- | Combined version of ':<-!:' and 'P' for specifying the first node of path. +-- +infixl 1 <-: +(<-:) :: NodeSelector -> PathPart -> PathSelector +ns <-: pp = P ns :<-!: pp + data Selector = PS PathSelector -- ^ path selector | TS Text -- ^ free text selector deriving (Show, Eq) @@ -109,11 +152,21 @@ | Text Text next -- ^ free text query deriving (Show, Eq, Functor) +-- | Empty 'NodeSelector'. defaultNode :: NodeSelector defaultNode = NodeSelector Nothing [] [] +-- | Shorter synonym for 'defaultRel'. +defN :: NodeSelector +defN = defaultNode + +-- | Empty 'RelSelector'. defaultRel :: RelSelector defaultRel = RelSelector Nothing "" [] + +-- | Shorter synonym for 'defaultRel'. +defR :: RelSelector +defR = defaultRel toNodeSelector :: Node -> NodeSelector toNodeSelector Node{..} = defaultNode { nodeLabels = labels