-
Notifications
You must be signed in to change notification settings - Fork 9
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
* initial version of refactoring * version 0.0.0.8: dsl
- Loading branch information
Showing
7 changed files
with
333 additions
and
4 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,11 @@ | ||
| 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 | ||
| ) where | ||
|
|
||
| import Database.Bolt.Extras.DSL.Internal.Types | ||
| import Database.Bolt.Extras.DSL.Internal.Language | ||
| import Database.Bolt.Extras.DSL.Internal.Executer | ||
| import Database.Bolt.Extras.DSL.Internal.Instances () |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,48 @@ | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
|
|
||
| module Database.Bolt.Extras.DSL.Internal.Executer | ||
| ( | ||
| formQuery | ||
| ) where | ||
|
|
||
| import Control.Monad.Free (Free (..), | ||
| foldFree) | ||
| import Control.Monad.Writer (Writer, | ||
| execWriter, tell) | ||
| import Data.Monoid ((<>)) | ||
| import Data.Text as T (Text, | ||
| intercalate, | ||
| unwords) | ||
| import Database.Bolt.Extras.DSL.Internal.Instances () | ||
| import Database.Bolt.Extras.DSL.Internal.Types (Expr (..)) | ||
| import Database.Bolt.Extras.Query.Cypher (ToCypher (..)) | ||
|
|
||
| -- | Translates 'Expr' to cypher query. | ||
| -- | ||
| execute :: Expr a -> Writer [Text] a | ||
| execute (Create s n) = executeHelperS "CREATE " s n | ||
| execute (Match s n) = executeHelperS "MATCH " s n | ||
| execute (OptionalMatch s n) = executeHelperS "OPTIONAL MATCH " s n | ||
| execute (Merge s n) = executeHelperS "MERGE " s n | ||
| execute (Where c n) = executeHelperT "WHERE " c n | ||
| execute (Set t n) = executeHelperT "SET " t n | ||
| execute (Delete t n) = executeHelperT "DELETE " t n | ||
| execute (DetachDelete t n) = executeHelperT "DETACH DELETE " t n | ||
| execute (Return t n) = executeHelperT "RETURN " t n | ||
| execute (Text t n) = tell [t] >> pure n | ||
|
|
||
| -- | Helper to translate 'Expr' with 'Selector's | ||
| -- | ||
| executeHelperS :: ToCypher a => Text -> a -> b -> Writer [Text] b | ||
| executeHelperS txt s n = tell [txt <> toCypher s] >> pure n | ||
|
|
||
| -- | Helper to translate 'Expr' with 'Text's | ||
| -- | ||
| executeHelperT :: Text -> [Text] -> b -> Writer [Text] b | ||
| executeHelperT txt t n = tell [txt <> intercalate ", " t] >> pure n | ||
|
|
||
| formQueryW :: Free Expr () -> Writer [Text] () | ||
| formQueryW = foldFree execute | ||
|
|
||
| formQuery :: Free Expr () -> Text | ||
| formQuery = T.unwords . execWriter . formQueryW |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,84 @@ | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE RecordWildCards #-} | ||
| {-# LANGUAGE TypeSynonymInstances #-} | ||
| {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
|
|
||
| module Database.Bolt.Extras.DSL.Internal.Instances () where | ||
|
|
||
| import Control.Monad.Writer (execWriter, tell) | ||
| import Data.Text (intercalate) | ||
| import Database.Bolt.Extras.DSL.Internal.Types | ||
| import Database.Bolt.Extras.Query.Cypher (ToCypher (..)) | ||
|
|
||
| instance SelectorLike NodeSelector where | ||
| withIdentifier idx node = node { nodeIdentifier = Just idx } | ||
| withLabel lbl node = node { nodeLabels = lbl : nodeLabels node } | ||
| withProp prop node = node { nodeProperties = prop : nodeProperties node } | ||
|
|
||
| instance SelectorLike RelSelector where | ||
| withIdentifier idx rel = rel { relIdentifier = Just idx } | ||
| withLabel lbl rel = rel { relLabel = lbl } | ||
| withProp prop rel = rel { relProperties = prop : relProperties rel } | ||
|
|
||
| instance ToCypher NodeSelector where | ||
| toCypher NodeSelector{..} = execWriter $ do | ||
| tell "(" | ||
| case nodeIdentifier of | ||
| Just idx -> tell idx | ||
| Nothing -> pure () | ||
| case nodeLabels of | ||
| [] -> pure () | ||
| _ -> tell $ toCypher nodeLabels | ||
| case nodeProperties of | ||
| [] -> pure () | ||
| _ -> do tell "{" | ||
| tell $ toCypher nodeProperties | ||
| tell "}" | ||
| tell ")" | ||
|
|
||
| instance ToCypher RelSelector where | ||
| toCypher RelSelector{..} = execWriter $ do | ||
| tell "[" | ||
| case relIdentifier of | ||
| Just idx -> tell idx | ||
| Nothing -> pure () | ||
| case relLabel of | ||
| "" -> pure () | ||
| _ -> tell $ toCypher relLabel | ||
| case relProperties of | ||
| [] -> pure () | ||
| _ -> do tell "{" | ||
| tell $ toCypher relProperties | ||
| tell "}" | ||
| tell "]" | ||
|
|
||
| instance ToCypher PathSelector where | ||
| toCypher (ps :-!: rs :!->: ns) = execWriter $ do | ||
| tell $ toCypher ps | ||
| tell "-" | ||
| tell $ toCypher rs | ||
| tell "->" | ||
| tell $ toCypher ns | ||
| toCypher (ps :<-!: rs :!-: ns) = execWriter $ do | ||
| tell $ toCypher ps | ||
| tell "<-" | ||
| tell $ toCypher rs | ||
| tell "-" | ||
| tell $ toCypher ns | ||
| toCypher (ps :-!: rs :!-: ns) = execWriter $ do | ||
| tell $ toCypher ps | ||
| tell "-" | ||
| tell $ toCypher rs | ||
| tell "-" | ||
| tell $ toCypher ns | ||
| toCypher (P ns) = execWriter $ | ||
| tell $ toCypher ns | ||
| toCypher (_ :<-!: _ :!->: _) = error "Database.Bolt.Extras.DSL: incorrect path" | ||
|
|
||
| instance ToCypher Selector where | ||
| toCypher (PS ps) = toCypher ps | ||
| toCypher (TS txt) = txt | ||
|
|
||
| instance ToCypher Selectors where | ||
| toCypher = intercalate ", " . fmap toCypher |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,68 @@ | ||
| module Database.Bolt.Extras.DSL.Internal.Language | ||
| ( | ||
| createF | ||
| , matchF | ||
| , optionalMatchF | ||
| , mergeF | ||
| , whereF | ||
| , setF | ||
| , deleteF | ||
| , detachDeleteF | ||
| , returnF | ||
| , textF | ||
| ) where | ||
|
|
||
| import Control.Monad.Free (Free (..), liftF) | ||
| import Data.Text (Text) | ||
| import Database.Bolt.Extras.DSL.Internal.Types (Cond, Expr (..), | ||
| Selectors) | ||
|
|
||
| -- | Prepare 'CREATE' query | ||
| -- | ||
| createF :: Selectors -> Free Expr () | ||
| createF sels = liftF (Create sels ()) | ||
|
|
||
| -- | Prepare 'MATCH' query | ||
| -- | ||
| matchF :: Selectors -> Free Expr () | ||
| matchF sels = liftF (Match sels ()) | ||
|
|
||
| -- | Prepare 'OPTIONAL MATCH' query | ||
| -- | ||
| optionalMatchF :: Selectors -> Free Expr () | ||
| optionalMatchF sels = liftF (OptionalMatch sels ()) | ||
|
|
||
| -- | Prepare 'MERGE' query | ||
| -- | ||
| mergeF :: Selectors -> Free Expr () | ||
| mergeF sels = liftF (Merge sels ()) | ||
|
|
||
| -- | Prepare 'WHERE' query | ||
| -- | ||
| whereF :: Cond -> Free Expr () | ||
| whereF cond = liftF (Where cond ()) | ||
|
|
||
| -- | Prepare 'SET' query | ||
| -- | ||
| setF :: [Text] -> Free Expr () | ||
| setF txts = liftF (Set txts ()) | ||
|
|
||
| -- | Prepare 'DELETE' query | ||
| -- | ||
| deleteF :: [Text] -> Free Expr () | ||
| deleteF txts = liftF (Delete txts ()) | ||
|
|
||
| -- | Prepare 'DETACH DELETE' query | ||
| -- | ||
| detachDeleteF :: [Text] -> Free Expr () | ||
| detachDeleteF txts = liftF (DetachDelete txts ()) | ||
|
|
||
| -- | Prepare 'RETURN' query | ||
| -- | ||
| returnF :: [Text] -> Free Expr () | ||
| returnF txts = liftF (Return txts ()) | ||
|
|
||
| -- | Prepare query with custom text | ||
| -- | ||
| textF :: Text -> Free Expr () | ||
| textF txt = liftF (Text txt ()) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,106 @@ | ||
| {-# LANGUAGE DeriveFunctor #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE RecordWildCards #-} | ||
| {-# LANGUAGE TypeSynonymInstances #-} | ||
|
|
||
| module Database.Bolt.Extras.DSL.Internal.Types | ||
| ( | ||
| NodeSelector (..) | ||
| , RelSelector (..) | ||
| , PathPart (..) | ||
| , PathSelector (..) | ||
| , Selector (..) | ||
| , Selectors | ||
| , Cond | ||
| , Expr (..) | ||
| , SelectorLike (..) | ||
| , (#) | ||
| , defaultNode | ||
| , defaultRel | ||
| , toNodeSelector | ||
| , toRelSelector | ||
| ) where | ||
|
|
||
| import Data.Map.Strict (toList) | ||
| import Data.Text (Text) | ||
| import Database.Bolt (Node (..), URelationship (..), Value (..)) | ||
|
|
||
| -- | Class for Selectors, which can update identifier, labels and props. | ||
| -- | ||
| class SelectorLike a where | ||
| withIdentifier :: Text -> a -> a | ||
| withLabel :: Text -> a -> a | ||
| withProp :: (Text, Value) -> a -> a | ||
|
|
||
| -- | Selector for 'Node's. | ||
| -- | ||
| data NodeSelector = NodeSelector { nodeIdentifier :: Maybe Text | ||
| , nodeLabels :: [Text] | ||
| , nodeProperties :: [(Text, Value)] | ||
| } | ||
| deriving (Show, Eq) | ||
|
|
||
| -- | Selector for 'URelationship's. | ||
| -- | ||
| data RelSelector = RelSelector { relIdentifier :: Maybe Text | ||
| , relLabel :: Text | ||
| , relProperties :: [(Text, Value)] | ||
| } | ||
| deriving (Show, Eq) | ||
|
|
||
|
|
||
| (#) :: a -> (a -> b) -> b | ||
| (#) = flip ($) | ||
|
|
||
| -- | Selector for paths. | ||
| -- | ||
| infixl 2 :!->: | ||
| infixl 2 :!-: | ||
| data PathPart = RelSelector :!->: NodeSelector | ||
| | RelSelector :!-: NodeSelector | ||
| deriving (Show, Eq) | ||
|
|
||
| infixl 1 :-!: | ||
| infixl 1 :<-!: | ||
| data PathSelector = PathSelector :-!: PathPart | ||
| | PathSelector :<-!: PathPart | ||
| | P NodeSelector | ||
| deriving (Show, Eq) | ||
|
|
||
| data Selector = PS PathSelector | TS Text | ||
| deriving (Show, Eq) | ||
|
|
||
| type Selectors = [Selector] | ||
|
|
||
| type Cond = [Text] | ||
|
|
||
| -- | Expression in Cypher language. | ||
| -- | ||
| data Expr next = Create Selectors next | ||
| | Match Selectors next | ||
| | OptionalMatch Selectors next | ||
| | Merge Selectors next | ||
| | Where Cond next | ||
| | Set [Text] next | ||
| | Delete [Text] next | ||
| | DetachDelete [Text] next | ||
| | Return [Text] next | ||
| | Text Text next | ||
| deriving (Show, Eq, Functor) | ||
|
|
||
| defaultNode :: NodeSelector | ||
| defaultNode = NodeSelector Nothing [] [] | ||
|
|
||
| defaultRel :: RelSelector | ||
| defaultRel = RelSelector Nothing "" [] | ||
|
|
||
| toNodeSelector :: Node -> NodeSelector | ||
| toNodeSelector Node{..} = defaultNode { nodeLabels = labels | ||
| , nodeProperties = filter ((/= N ()) . snd) (toList nodeProps) | ||
| } | ||
|
|
||
| toRelSelector :: URelationship -> RelSelector | ||
| toRelSelector URelationship{..} = defaultRel { relLabel = urelType | ||
| , relProperties = toList urelProps | ||
| } |