hasbolt-extras 0.0.0.7 → 0.0.0.8

raw patch · 7 files changed

+333/−4 lines, 7 filesdep +freedep +mtlPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: free, mtl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• hasbolt-extras.cabal +12/−4
• src/Database/Bolt/Extras/DSL.hs +11/−0
• src/Database/Bolt/Extras/DSL/Internal/Executer.hs +48/−0
• src/Database/Bolt/Extras/DSL/Internal/Instances.hs +84/−0
• src/Database/Bolt/Extras/DSL/Internal/Language.hs +68/−0
• src/Database/Bolt/Extras/DSL/Internal/Types.hs +106/−0

@@ -6,6 +6,10 @@  ## [Unreleased] +## [0.0.0.8] - 2018-05-14+### Added+- Added `DSL` for `Cypher`.+ ## [0.0.0.7] - 2018-04-23 ### Added - Added ability to delete nodes by their `BoltId`s.

@@ -1,5 +1,5 @@ name:           hasbolt-extras-version:        0.0.0.7+version:        0.0.0.8 synopsis:       Extras for hasbolt library description:    Extras for hasbolt library homepage:       https://github.com/biocad/hasbolt-extras#readme@@ -30,6 +30,7 @@                      , Database.Bolt.Extras.Query                      , Database.Bolt.Extras.Template                      , Database.Bolt.Extras.Utils+                     , Database.Bolt.Extras.DSL   other-modules:       Database.Bolt.Extras.Query.Get                      , Database.Bolt.Extras.Query.Put                      , Database.Bolt.Extras.Query.Set@@ -40,14 +41,21 @@                      , Database.Bolt.Extras.Template.Types                      , Database.Bolt.Extras.Template.Instances                      , Database.Bolt.Extras.Template.Converters++                     , Database.Bolt.Extras.DSL.Internal.Types+                     , Database.Bolt.Extras.DSL.Internal.Language+                     , Database.Bolt.Extras.DSL.Internal.Executer+                     , Database.Bolt.Extras.DSL.Internal.Instances                      build-depends:       base >=4.7 && <5-                     , text-                     , hasbolt                      , containers+                     , free+                     , hasbolt+                     , lens+                     , mtl                      , neat-interpolation                      , template-haskell+                     , text                      , th-lift-instances-                     , lens   ghc-options:     -Wall -O2   default-language: Haskell2010

@@ -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 ()

@@ -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

@@ -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

@@ -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 ())

@@ -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+                                             }