diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for greskell + +## 0.1.0.0 -- 2018-03-12 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Toshio Ito + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Toshio Ito nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# greskell + +Haskell binding for Gremlin query language. + +See the package description, or [project README](https://github.com/debug-ito/greskell/blob/master/README.md). + +## Author + +Toshio Ito diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/greskell.cabal b/greskell.cabal new file mode 100644 --- /dev/null +++ b/greskell.cabal @@ -0,0 +1,113 @@ +name: greskell +version: 0.1.0.0 +author: Toshio Ito +maintainer: Toshio Ito +license: BSD3 +license-file: LICENSE +synopsis: Haskell binding for Gremlin graph query language +description: Haskell binding for [Gremlin graph query language](http://tinkerpop.apache.org/gremlin.html). + See [README.md](https://github.com/debug-ito/greskell/blob/master/README.md) for detail. + . + This package is the main entry point of greskell family. It re-exports @greskell-core@ package, + and adds some useful functions to it. +category: Data +cabal-version: >= 1.10 +build-type: Simple +extra-source-files: README.md, ChangeLog.md, + test/graphson/*.json +homepage: https://github.com/debug-ito/greskell/ +bug-reports: https://github.com/debug-ito/greskell/issues/ + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -fno-warn-unused-imports + -- default-extensions: + other-extensions: OverloadedStrings, GeneralizedNewtypeDeriving, + FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeFamilies, + GADTs, DeriveTraversable + exposed-modules: Data.Greskell, + Data.Greskell.Gremlin, + Data.Greskell.Binder, + Data.Greskell.Graph, + Data.Greskell.GTraversal + -- other-modules: + build-depends: base >=4.9.0.0 && <4.11, + greskell-core >=0.1.0.0 && <0.2, + text >=1.2.2.1 && <1.3, + transformers >=0.5.2 && <0.6, + aeson >=0.11.2.1 && <1.4, + unordered-containers >=0.2.7.1 && <0.3, + semigroups >=0.18.2 && <0.19 + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" + main-is: Spec.hs + -- default-extensions: + other-extensions: OverloadedStrings + other-modules: Data.Greskell.BinderSpec, + Data.Greskell.GTraversalSpec, + Data.Greskell.GremlinSpec, + Data.Greskell.GraphSpec + build-depends: base, text, aeson, unordered-containers, + greskell, greskell-core, + hspec >=2.2.3, + bytestring >=0.10.8.1 && <0.11 + +test-suite doctest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" + main-is: DocTest.hs + build-depends: base, + doctest >=0.11 && <0.15, + doctest-discover >=0.1.0.8 && <0.2 + + +flag hint-test + description: Do tests that use Haskell interpreter + default: True + +test-suite hint-test-suite + if !flag(hint-test) + buildable: False + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" + main-is: HintTest.hs + build-depends: base, hspec, + greskell, + hint >=0.6 && <0.8 + + +flag server-test + description: Do tests with Gremlin Server. + default: False + +test-suite server-test-suite + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" + main-is: ServerTest.hs + -- default-extensions: + other-extensions: OverloadedStrings + -- other-modules: + if flag(server-test) + -- Explicitly remove dependency. See https://github.com/haskell/cabal/issues/1725 + build-depends: base, aeson, hspec, text, + greskell, greskell-core, + scientific >=0.3.4.9 && <0.4, + gremlin-haskell >=0.1.0.2 && <0.2 + else + buildable: False + + +source-repository head + type: git + location: https://github.com/debug-ito/greskell.git diff --git a/src/Data/Greskell.hs b/src/Data/Greskell.hs new file mode 100644 --- /dev/null +++ b/src/Data/Greskell.hs @@ -0,0 +1,23 @@ +-- | +-- Module: Data.Greskell +-- Description: Haskell binding for Gremlin graph query language +-- Maintainer: Toshio Ito +-- +-- Data.Greskell is a Haskell support to use the Gremlin graph query +-- language. For more information, see [project README](https://github.com/debug-ito/greskell). +module Data.Greskell + ( + module Data.Greskell.Greskell, + module Data.Greskell.Binder, + module Data.Greskell.GTraversal, + module Data.Greskell.Gremlin, + module Data.Greskell.Graph, + module Data.Greskell.GraphSON + ) where + +import Data.Greskell.Greskell +import Data.Greskell.Binder +import Data.Greskell.GTraversal +import Data.Greskell.Gremlin +import Data.Greskell.Graph +import Data.Greskell.GraphSON diff --git a/src/Data/Greskell/Binder.hs b/src/Data/Greskell/Binder.hs new file mode 100644 --- /dev/null +++ b/src/Data/Greskell/Binder.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +-- | +-- Module: Data.Greskell.Binder +-- Description: Binder monad to make binding between Gremlin variables and JSON values +-- Maintainer: Toshio Ito +-- +-- +module Data.Greskell.Binder + ( -- * Types + Binder, + Binding, + -- * Actions + newBind, + -- * Runners + runBinder + ) where + +import Control.Monad.Trans.State (State) +import qualified Control.Monad.Trans.State as State +import Data.Aeson (Value, ToJSON(toJSON), Object) +import Data.Monoid ((<>)) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text.Lazy as TL + +import Data.Greskell.Greskell (unsafeGreskellLazy, Greskell) + +-- $setup +-- +-- >>> import Control.Applicative ((<$>), (<*>)) +-- >>> import Data.Greskell.Greskell (toGremlin) +-- >>> import Data.List (sortBy) +-- >>> import Data.Ord (comparing) +-- >>> import qualified Data.HashMap.Strict as HashMap + +-- | A Monad that manages binding variables to values. +-- +-- >>> let binder = (,) <$> newBind (10 :: Int) <*> newBind "hoge" +-- >>> let ((var_int, var_str), binding) = runBinder binder +-- >>> toGremlin var_int +-- "__v0" +-- >>> toGremlin var_str +-- "__v1" +-- >>> sortBy (comparing fst) $ HashMap.toList binding +-- [("__v0",Number 10.0),("__v1",String "hoge")] +newtype Binder a = Binder { unBinder :: State (PlaceHolderIndex, [Value]) a } + deriving (Functor, Applicative, Monad) + +-- | Binding between Gremlin variable names and JSON values. +type Binding = Object + +-- | Create a new Gremlin variable bound to the given value. +-- +-- The value @v@ is kept in the monadic context. The returned +-- 'Greskell' is a Gremlin variable pointing to the @v@. The Gremlin +-- variable is guaranteed to be unique in the current monadic context. +newBind :: ToJSON v + => v -- ^ bound value + -> Binder (Greskell v) -- ^ variable +newBind val = Binder $ do + (next_index, values) <- State.get + State.put (succ next_index, values ++ [toJSON val]) + return $ unsafePlaceHolder next_index + +-- | Execute the given 'Binder' monad to obtain 'Binding'. +runBinder :: Binder a -> (a, Binding) +runBinder binder = (ret, binding) + where + (ret, (_, values)) = State.runState (unBinder binder) (0, []) + binding = HM.fromList $ zip (map toPlaceHolderVariableStrict [0 ..]) $ values + toPlaceHolderVariableStrict = TL.toStrict . toPlaceHolderVariable + +-- | __This type is only for internal use.__ +type PlaceHolderIndex = Int + +-- | __This function is only for internal use.__ +-- +-- Unsafely create a placeholder variable of arbitrary type with the +-- given index. +unsafePlaceHolder :: PlaceHolderIndex -> Greskell a +unsafePlaceHolder = unsafeGreskellLazy . toPlaceHolderVariable + +-- | __This function is only for internal use.__ +-- +-- Create placeholder variable string from the index. +toPlaceHolderVariable :: PlaceHolderIndex -> TL.Text +toPlaceHolderVariable i = TL.pack ("__v" ++ show i) diff --git a/src/Data/Greskell/GTraversal.hs b/src/Data/Greskell/GTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Greskell/GTraversal.hs @@ -0,0 +1,894 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeFamilies, GADTs #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +-- | +-- Module: Data.Greskell.GTraversal +-- Description: Gremlin traversal/step types. +-- Maintainer: Toshio Ito +-- +-- This module defines 'GTraversal', greskell counterpart of +-- @GraphTraversal@ class object, and a DSL of composing graph +-- traversal steps. +module Data.Greskell.GTraversal + ( -- * Types + -- ** GraphTraversal and others + GTraversal(..), + GraphTraversal, + ToGTraversal(..), + Walk, + GraphTraversalSource, + -- ** Walk types + WalkType, + Filter, + Transform, + SideEffect, + Lift, + Split, + -- * GraphTraversalSource + source, + sV, + sV', + sE, + sE', + -- * GTraversal + (&.), + ($.), + unsafeGTraversal, + -- * Walk/Steps + + -- | + -- Functions for TinkerPop graph traversal steps. + -- __For now greskell does not cover all graph traversal steps.__ + -- If you want some steps added, just open an issue. + -- + -- There may be multiple versions of Haskell functions for a + -- single step. This is because Gremlin steps are too + -- polymorphic for Haskell. greskell should be type-safe so + -- that incorrect combination of steps is detected in compile + -- time. + + -- ** Low-level functions + unsafeWalk, + modulateWith, + -- ** Filter steps + gIdentity, + gIdentity', + gFilter, + -- ** Has steps + gHas1, + gHas1', + gHas2, + gHas2', + gHas2P, + gHas2P', + gHasLabel, + gHasLabel', + gHasLabelP, + gHasLabelP', + gHasId, + gHasId', + gHasIdP, + gHasIdP', + gHasKey, + gHasKey', + gHasKeyP, + gHasKeyP', + gHasValue, + gHasValue', + gHasValueP, + gHasValueP', + -- ** Logic steps + gAnd, + gOr, + gNot, + -- ** Sorting steps + gOrder, + -- ** Paging steps + gRange, + -- ** Transformation steps + gFlatMap, + -- ** Accessor steps + gValues, + gProperties, + -- ** Summarizing steps + gFold, + gCount, + -- ** Graph traversal steps + gOut, + gOut', + gOutE, + gOutE', + gIn, + gIn', + gInE, + gInE', + -- ** Side-effect steps + gSideEffect, + gSideEffect', + -- ** Graph manipulation steps + gAddV, + gAddV', + gDrop, + gDropP, + -- ** @.by@ steps + + -- | @.by@ steps are not 'Walk' on their own because they are + -- always used in conjunction with other steps like 'gOrder'. + ByProjection(..), + ProjectionLike(..), + ByComparator(..), + gBy, + gBy1, + gBy2 + ) where + +import Control.Category (Category, (>>>)) +-- (below) to import Category methods without conflict with Prelude +import qualified Control.Category as Category +import Data.Aeson (Value) +import Data.Bifunctor (Bifunctor(bimap)) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Monoid ((<>), mconcat, Monoid(..)) +import Data.Semigroup (Semigroup, sconcat) +import qualified Data.Semigroup as Semigroup +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Greskell.Graph + ( Element(..), Vertex, Edge, Property(..), + AVertex, AEdge, + T, Key + ) +import Data.Greskell.Gremlin + ( Comparator(..), + P + ) +import Data.Greskell.Greskell + ( Greskell, ToGreskell(..), unsafeGreskellLazy, unsafeGreskell, unsafeFunCall, + toGremlinLazy, toGremlin + ) + +-- $setup +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Function ((&)) +-- >>> import qualified Data.Aeson as Aeson +-- >>> import Data.Greskell.Greskell (value) +-- >>> import Data.Greskell.Gremlin (pBetween, pEq, pLte, oDecr, oIncr) +-- >>> import Data.Greskell.Graph (tId) + +-- | @GraphTraversal@ class object of TinkerPop. It takes data @s@ +-- from upstream and emits data @e@ to downstream. Type @c@ is called +-- \"walk type\", a marker to describe the effect of the traversal. +-- +-- 'GTraversal' is NOT a 'Category'. Because a @GraphTraversal@ object +-- keeps some context data, the starting (left-most) @GraphTraversal@ +-- object controls most of the behavior of entire composition of +-- traversals and steps. This violates 'Category' law. +newtype GTraversal c s e = GTraversal { unGTraversal :: Greskell (GraphTraversal c s e) } + deriving (Show) + +-- | Unsafely convert output type. +instance Functor (GTraversal c s) where + fmap f (GTraversal g) = GTraversal $ fmap (fmap f) g + +-- | Unsafely convert input and output types. +instance Bifunctor (GTraversal c) where + bimap f1 f2 (GTraversal g) = GTraversal $ fmap (bimap f1 f2) g + +-- | Unwrap 'GTraversal' data constructor. +instance ToGreskell (GTraversal c s e) where + type GreskellReturn (GTraversal c s e) = GraphTraversal c s e + toGreskell = unGTraversal + +-- | Phantom type for @GraphTraversal@ class. In greskell, we usually +-- use 'GTraversal' instead of 'Greskell' 'GraphTraversal'. +data GraphTraversal c s e = GraphTraversal + deriving (Show) + +-- | Unsafely convert output type. +instance Functor (GraphTraversal c s) where + fmap _ GraphTraversal = GraphTraversal + +-- | Unsafely convert input and output types. +instance Bifunctor (GraphTraversal c) where + bimap _ _ GraphTraversal = GraphTraversal + +-- | Types that can convert to 'GTraversal'. +class ToGTraversal g where + toGTraversal :: WalkType c => g c s e -> GTraversal c s e + liftWalk :: (WalkType from, WalkType to, Lift from to) => g from s e -> g to s e + -- ^ Lift 'WalkType' @from@ to @to@. Use this for type matching. + +instance ToGTraversal GTraversal where + toGTraversal = id + liftWalk (GTraversal g) = GTraversal $ unsafeGreskellLazy $ toGremlinLazy g + + +-- | A chain of one or more Gremlin steps. Like 'GTraversal', type @s@ +-- is the input, type @e@ is the output, and type @c@ is a marker to +-- describe the step. +-- +-- 'Walk' represents a chain of method calls such as +-- @.has(x).outE()@. Because this is not a Gremlin (Groovy) +-- expression, we use bare 'Walk', not 'Greskell' 'Walk'. +-- +-- 'Walk' is a 'Category'. You can use functions from +-- "Control.Category" to compose 'Walk's. This is equivalent to making +-- a chain of method calls in Gremlin. +-- +-- 'Walk' is not an 'Eq', because it's difficult to define true +-- equality between Gremlin method calls. If we define it naively, it +-- might have conflict with 'Category' law. +newtype Walk c s e = Walk TL.Text + deriving (Show) + +-- | 'id' is 'gIdentity'. +instance WalkType c => Category (Walk c) where + id = gIdentity + (Walk bc) . (Walk ab) = Walk (ab <> bc) + +-- | Based on 'Category'. 'Semigroup.<>' is 'Category.>>>'. +instance WalkType c => Semigroup (Walk c s s) where + (<>) = (Category.>>>) + +-- | Based on 'Category' and 'Semigroup'. 'mempty' is 'Category.id'. +instance WalkType c => Monoid (Walk c s s) where + mempty = Category.id + mappend = (Semigroup.<>) + +-- | Unsafely convert output type +instance Functor (Walk c s) where + fmap _ (Walk t) = Walk t + +-- | Unsafely convert input and output types. +instance Bifunctor (Walk c) where + bimap _ _ (Walk t) = Walk t + +-- | To convert a 'Walk' to 'GTraversal', it calls its static method +-- version on @__@ class. +instance ToGTraversal Walk where + toGTraversal (Walk t) = GTraversal $ unsafeGreskellLazy ("__" <> t) + liftWalk (Walk t) = Walk t + +-- | The 'Walk' is first converted to 'GTraversal', and it's converted +-- to 'Greskell'. +instance WalkType c => ToGreskell (Walk c s e) where + type GreskellReturn (Walk c s e) = GraphTraversal c s e + toGreskell = toGreskell . toGTraversal + +-- | Class of phantom type markers to describe the effect of the +-- walk/traversals. +class WalkType t + +-- | WalkType for filtering steps. +-- +-- A filtering step is a step that does filtering only. It takes input +-- and emits some of them without any modification, reordering, +-- traversal actions, or side-effects. Filtering decision must be +-- solely based on each element. +-- +-- A 'Walk' @w@ is 'Filter' type iff: +-- +-- > (gSideEffect w == gIdentity) AND (gFilter w == w) +-- +-- If 'Walk's @w1@ and @w2@ are 'Filter' type, then +-- +-- > gAnd [w1, w2] == w1 >>> w2 == w2 >>> w1 +data Filter + +instance WalkType Filter + +-- | WalkType for steps without any side-effects. This includes +-- transformations, reordring, injections and graph traversal actions. +-- +-- A 'Walk' @w@ is 'Transform' type iff: +-- +-- > gSideEffect w == gIdentity +-- +-- Obviously, every 'Filter' type 'Walk's are also 'Transform' type. +data Transform + +instance WalkType Transform + +-- | WalkType for steps that may have side-effects. +-- +-- A side-effect here means manipulation of the \"sideEffect\" in +-- Gremlin context (i.e. the stash of data kept in a Traversal +-- object), as well as interaction with the world outside the +-- Traversal object. +-- +-- For example, the following steps (in Gremlin) all have +-- side-effects. +-- +-- > .addE('label') +-- > .aggregate('x') +-- > .sideEffect(System.out.&println) +-- > .map { some_variable += 1 } +data SideEffect + +instance WalkType SideEffect + +-- | Relation of 'WalkType's where one includes the other. @from@ can +-- be lifted to @to@, because @to@ is more powerful than @from@. +class Lift from to + +instance (WalkType c) => Lift Filter c +instance Lift Transform Transform +instance Lift Transform SideEffect +instance Lift SideEffect SideEffect + +-- | Relation of 'WalkType's where the child walk @c@ is split from +-- the parent walk @p@. +-- +-- When splitting, transformation effect done in the child walk is +-- rolled back (canceled) in the parent walk. +class Split c p + +instance (WalkType p) => Split Filter p +instance (WalkType p) => Split Transform p +-- ^ 'Transform' effect in the child walk is rolled back in the parent +-- walk. +instance Split SideEffect SideEffect +-- ^ 'SideEffect' in the child walk remains in the parent walk. + + +-- | @GraphTraversalSource@ class object of TinkerPop. It is a factory +-- object of 'GraphTraversal's. +data GraphTraversalSource = GraphTraversalSource + deriving (Show) + + +-- | Create 'GraphTraversalSource' from a varible name in Gremlin +-- +-- >>> toGremlin $ source "g" +-- "g" +source :: Text -- ^ variable name of 'GraphTraversalSource' + -> Greskell GraphTraversalSource +source = unsafeGreskell + +sourceMethod :: Text -> [Greskell a] -> Greskell GraphTraversalSource -> Greskell b +sourceMethod method_name args src = + unsafeGreskellLazy $ (toGremlinLazy src <> methodCallText method_name (map toGremlin args)) + +-- | @.V()@ method on 'GraphTraversalSource'. +sV :: Vertex v + => [Greskell (ElementID v)] -- ^ vertex IDs + -> Greskell GraphTraversalSource + -> GTraversal Transform () v +sV ids src = GTraversal $ sourceMethod "V" ids src + +-- | Monomorphic version of 'sV'. +-- +-- >>> toGremlin (source "g" & sV' (map (value . Aeson.Number) [1,2,3])) +-- "g.V(1.0,2.0,3.0)" +sV' :: [Greskell Value] + -> Greskell GraphTraversalSource + -> GTraversal Transform () AVertex +sV' = sV + +-- | @.E()@ method on 'GraphTraversalSource'. +sE :: Edge e + => [Greskell (ElementID e)] -- ^ edge IDs + -> Greskell GraphTraversalSource + -> GTraversal Transform () e +sE ids src = GTraversal $ sourceMethod "E" ids src + +-- | Monomorphic version of 'sE'. +-- +-- >>> toGremlin (source "g" & sE' (map (value . Aeson.Number) [1])) +-- "g.E(1.0)" +sE' :: [Greskell Value] + -> Greskell GraphTraversalSource + -> GTraversal Transform () AEdge +sE' = sE + +-- | Unsafely create 'GTraversal' from the given raw Gremlin script. +-- +-- >>> toGremlin $ unsafeGTraversal "g.V().count()" +-- "g.V().count()" +unsafeGTraversal :: Text -> GTraversal c s e +unsafeGTraversal = GTraversal . unsafeGreskell + +infixl 1 &. + +-- | Apply the 'Walk' to the 'GTraversal'. In Gremlin, this means +-- calling a chain of methods on the Traversal object. +-- +-- >>> toGremlin (source "g" & sV' [] &. gValues ["age"]) +-- "g.V().values(\"age\")" +(&.) :: GTraversal c a b -> Walk c b d -> GTraversal c a d +(GTraversal gt) &. (Walk twalk) = GTraversal $ unsafeGreskellLazy (toGremlinLazy gt <> twalk) + +infixr 0 $. + +-- | Same as '&.' with arguments flipped. +-- +-- >>> toGremlin (gValues ["age"] $. sV' [] $ source "g") +-- "g.V().values(\"age\")" +($.) :: Walk c b d -> GTraversal c a b -> GTraversal c a d +gs $. gt = gt &. gs + +-- -- $walk-steps +-- -- + +methodCallText :: Text -- ^ method name + -> [Text] -- ^ args + -> TL.Text +methodCallText name args = ("." <>) $ toGremlinLazy $ unsafeFunCall name args + +-- | Unsafely create a 'Walk' that represents a single method call on +-- a @GraphTraversal@. +-- +-- >>> toGremlin (source "g" & sV' [] &. unsafeWalk "valueMap" ["'foo'", "'bar'"]) +-- "g.V().valueMap('foo','bar')" +unsafeWalk :: WalkType c + => Text -- ^ step method name (e.g. "outE") + -> [Text] -- ^ step method arguments + -> Walk c s e +unsafeWalk name args = Walk $ methodCallText name args + +-- | Optionally modulate the main 'Walk' with some modulating 'Walk's. +-- +-- >>> toGremlin (source "g" & sV' [] &. modulateWith (unsafeWalk "path" []) [unsafeWalk "by" ["'name'"], unsafeWalk "by" ["'age'"]]) +-- "g.V().path().by('name').by('age')" +modulateWith :: (WalkType c) + => Walk c s e -- ^ the main 'Walk' + -> [Walk c e e] -- ^ the modulating 'Walk's + -> Walk c s e +modulateWith w [] = w +modulateWith w (m:rest) = w >>> sconcat (m :| rest) + +-- | @.identity@ step. +gIdentity :: WalkType c => Walk c s s +gIdentity = liftWalk $ gIdentity' + +-- | Monomorphic version of 'gIdentity'. +gIdentity' :: Walk Filter s s +gIdentity' = unsafeWalk "identity" [] + +travToG :: (ToGTraversal g, WalkType c) => g c s e -> Text +travToG = toGremlin . unGTraversal . toGTraversal + +-- | @.filter@ step that takes a traversal. +-- +-- >>> toGremlin (source "g" & sV' [] &. gFilter (gOut' ["knows"])) +-- "g.V().filter(__.out(\"knows\"))" +gFilter :: (ToGTraversal g, WalkType c, WalkType p, Split c p) => g c s e -> Walk p s s +gFilter walk = unsafeWalk "filter" [travToG walk] + + +-- TODO +-- gValueMap, gProperty etc. should use Key type as an argument. +-- Note that .property step is very tricky. Read the doc carefully. +-- + +-- | @.has@ step with one argument. +-- +-- >>> toGremlin (source "g" & sV' [] &. gHas1 "age") +-- "g.V().has(\"age\")" +gHas1 :: (WalkType c, Element s) + => Key s v -- ^ property key + -> Walk c s s +gHas1 = liftWalk . gHas1' + +-- | Monomorphic version of 'gHas1'. +gHas1' :: (Element s) => Key s v -> Walk Filter s s +gHas1' key = unsafeWalk "has" [toGremlin key] + +-- | @.has@ step with two arguments. +-- +-- >>> toGremlin (source "g" & sV' [] &. gHas2 "age" (31 :: Greskell Int)) +-- "g.V().has(\"age\",31)" +gHas2 :: (WalkType c, Element s) => Key s v -> Greskell v -> Walk c s s +gHas2 k v = liftWalk $ gHas2' k v + +-- | Monomorphic verson of 'gHas2'. +gHas2' :: (Element s) => Key s v -> Greskell v -> Walk Filter s s +gHas2' k v = unsafeWalk "has" [toGremlin k, toGremlin v] + +-- | @.has@ step with two arguments and 'P' type. +-- +-- >>> toGremlin (source "g" & sV' [] &. gHas2P "age" (pBetween (30 :: Greskell Int) 40)) +-- "g.V().has(\"age\",P.between(30,40))" +gHas2P :: (WalkType c, Element s) + => Key s v -- ^ property key + -> Greskell (P v) -- ^ predicate on the property value + -> Walk c s s +gHas2P k p = liftWalk $ gHas2P' k p + +-- | Monomorphic version of 'gHas2P'. +gHas2P' :: (Element s) => Key s v -> Greskell (P v) -> Walk Filter s s +gHas2P' key p = unsafeWalk "has" [toGremlin key, toGremlin p] + +-- TODO: has(Key,Traversal), has(Label,Key,P) + +-- | @.hasLabel@ step. +-- +-- >>> toGremlin (source "g" & sV' [] &. gHasLabel "person") +-- "g.V().hasLabel(\"person\")" +gHasLabel :: (Element s, WalkType c) => Greskell Text -> Walk c s s +gHasLabel = liftWalk . gHasLabel' + +-- | Monomorphic version of 'gHasLabel'. +gHasLabel' :: (Element s) => Greskell Text -> Walk Filter s s +gHasLabel' l = unsafeWalk "hasLabel" [toGremlin l] + +-- | @.hasLabel@ step with 'P' type. Supported since TinkerPop 3.2.7. +-- +-- >>> toGremlin (source "g" & sV' [] &. gHasLabelP (pEq "person")) +-- "g.V().hasLabel(P.eq(\"person\"))" +gHasLabelP :: (Element s, WalkType c) + => Greskell (P Text) -- ^ predicate on Element label. + -> Walk c s s +gHasLabelP = liftWalk . gHasLabelP' + +-- | Monomorphic version of 'gHasLabelP'. +gHasLabelP' :: Element s + => Greskell (P Text) + -> Walk Filter s s +gHasLabelP' p = unsafeWalk "hasLabel" [toGremlin p] + +-- | @.hasId@ step. +-- +-- >>> toGremlin (source "g" & sV' [] &. gHasId (value $ Aeson.Number 7)) +-- "g.V().hasId(7.0)" +gHasId :: (Element s, WalkType c) => Greskell (ElementID s) -> Walk c s s +gHasId = liftWalk . gHasId' + +-- | Monomorphic version of 'gHasId'. +gHasId' :: Element s => Greskell (ElementID s) -> Walk Filter s s +gHasId' i = unsafeWalk "hasId" [toGremlin i] + +-- | @.hasId@ step with 'P' type. Supported since TinkerPop 3.2.7. +-- +-- >>> toGremlin (source "g" & sV' [] &. gHasIdP (pLte $ value $ Aeson.Number 100)) +-- "g.V().hasId(P.lte(100.0))" +gHasIdP :: (Element s, WalkType c) + => Greskell (P (ElementID s)) + -> Walk c s s +gHasIdP = liftWalk . gHasIdP' + +-- | Monomorphic version of 'gHasIdP'. +gHasIdP' :: Element s + => Greskell (P (ElementID s)) + -> Walk Filter s s +gHasIdP' p = unsafeWalk "hasId" [toGremlin p] + +-- | @.hasKey@ step. The input type should be a VertexProperty. +-- +-- >>> toGremlin (source "g" & sV' [] &. gProperties [] &. gHasKey "age") +-- "g.V().properties().hasKey(\"age\")" +gHasKey :: (Element (p v), Property p, WalkType c) => Greskell Text -> Walk c (p v) (p v) +gHasKey = liftWalk . gHasKey' + +-- | Monomorphic version of 'gHasKey'. +gHasKey' :: (Element (p v), Property p) => Greskell Text -> Walk Filter (p v) (p v) +gHasKey' k = unsafeWalk "hasKey" [toGremlin k] + +-- | @.hasKey@ step with 'P' type. Supported since TinkerPop 3.2.7. +gHasKeyP :: (Element (p v), Property p, WalkType c) + => Greskell (P Text) -- ^ predicate on the VertexProperty's key. + -> Walk c (p v) (p v) +gHasKeyP = liftWalk . gHasKeyP' + +-- | Monomorphic version of 'gHasKeyP'. +gHasKeyP' :: (Element (p v), Property p) => Greskell (P Text) -> Walk Filter (p v) (p v) +gHasKeyP' p = unsafeWalk "hasKey" [toGremlin p] + +-- | @.hasValue@ step. The input type should be a VertexProperty. +-- +-- >>> toGremlin (source "g" & sV' [] &. gProperties ["age"] &. gHasValue (32 :: Greskell Int)) +-- "g.V().properties(\"age\").hasValue(32)" +gHasValue :: (Element (p v), Property p, WalkType c) => Greskell v -> Walk c (p v) (p v) +gHasValue = liftWalk . gHasValue' + +-- | Monomorphic version of 'gHasValue'. +gHasValue' :: (Element (p v), Property p) => Greskell v -> Walk Filter (p v) (p v) +gHasValue' v = unsafeWalk "hasValue" [toGremlin v] + +-- | @.hasValue@ step with 'P' type. Supported since TinkerPop 3.2.7. +-- +-- >>> toGremlin (source "g" & sV' [] &. gProperties ["age"] &. gHasValueP (pBetween (30 :: Greskell Int) 40)) +-- "g.V().properties(\"age\").hasValue(P.between(30,40))" +gHasValueP :: (Element (p v), Property p, WalkType c) + => Greskell (P v) -- ^ predicate on the VertexProperty's value + -> Walk c (p v) (p v) +gHasValueP = liftWalk . gHasValueP' + +-- | Monomorphic version of 'gHasValueP'. +gHasValueP' :: (Element (p v), Property p) => Greskell (P v) -> Walk Filter (p v) (p v) +gHasValueP' p = unsafeWalk "hasValue" [toGremlin p] + +multiLogic :: (ToGTraversal g, WalkType c, WalkType p, Split c p) + => Text -- ^ method name + -> [g c s e] + -> Walk p s s +multiLogic method_name = unsafeWalk method_name . map travToG + +-- | @.and@ step. +-- +-- >>> toGremlin (source "g" & sV' [] &. gAnd [gOut' ["knows"], gHas1 "age"]) +-- "g.V().and(__.out(\"knows\"),__.has(\"age\"))" +gAnd :: (ToGTraversal g, WalkType c, WalkType p, Split c p) => [g c s e] -> Walk p s s +gAnd = multiLogic "and" + +-- | @.or@ step. +-- +-- >>> toGremlin (source "g" & sV' [] &. gOr [gOut' ["knows"], gHas1 "age"]) +-- "g.V().or(__.out(\"knows\"),__.has(\"age\"))" +gOr :: (ToGTraversal g, WalkType c, WalkType p, Split c p) => [g c s e] -> Walk p s s +gOr = multiLogic "or" + +-- | @.not@ step. +-- +-- >>> toGremlin (source "g" & sV' [] &. gNot (gOut' ["knows"])) +-- "g.V().not(__.out(\"knows\"))" +gNot :: (ToGTraversal g, WalkType c, WalkType p, Split c p) => g c s e -> Walk p s s +gNot cond = unsafeWalk "not" [travToG cond] + +-- | @.range@ step. This step is not a 'Filter', because the filtering +-- decision by this step is based on position of each element, not the +-- element itself. This violates 'Filter' law. +-- +-- >>> toGremlin (source "g" & sV' [] &. gRange 0 100) +-- "g.V().range(0,100)" +gRange :: Greskell Int + -- ^ min + -> Greskell Int + -- ^ max + -> Walk Transform s s +gRange min_g max_g = unsafeWalk "range" $ map toGremlin [min_g, max_g] + +-- | Data types that mean a projection from one type to another. +class ProjectionLike p where + type ProjectionLikeStart p + -- ^ The start type of the projection. + type ProjectionLikeEnd p + -- ^ The end type of the projection. + +instance ProjectionLike (Walk Filter s e) where + type ProjectionLikeStart (Walk Filter s e) = s + type ProjectionLikeEnd (Walk Filter s e) = e + +instance ProjectionLike (GTraversal Filter s e) where + type ProjectionLikeStart (GTraversal Filter s e) = s + type ProjectionLikeEnd (GTraversal Filter s e) = e + +instance ProjectionLike (Greskell (GraphTraversal Filter s e)) where + type ProjectionLikeStart (Greskell (GraphTraversal Filter s e)) = s + type ProjectionLikeEnd (Greskell (GraphTraversal Filter s e)) = e + +instance ProjectionLike (Walk Transform s e) where + type ProjectionLikeStart (Walk Transform s e) = s + type ProjectionLikeEnd (Walk Transform s e) = e + +instance ProjectionLike (GTraversal Transform s e) where + type ProjectionLikeStart (GTraversal Transform s e) = s + type ProjectionLikeEnd (GTraversal Transform s e) = e + +instance ProjectionLike (Greskell (GraphTraversal Transform s e)) where + type ProjectionLikeStart (Greskell (GraphTraversal Transform s e)) = s + type ProjectionLikeEnd (Greskell (GraphTraversal Transform s e)) = e + +instance ProjectionLike (Key s e) where + type ProjectionLikeStart (Key s e) = s + type ProjectionLikeEnd (Key s e) = e + +instance ProjectionLike (Greskell (T s e)) where + type ProjectionLikeStart (Greskell (T s e)) = s + type ProjectionLikeEnd (Greskell (T s e)) = e + +instance ProjectionLike (Greskell (s -> e)) where + type ProjectionLikeStart (Greskell (s -> e)) = s + type ProjectionLikeEnd (Greskell (s -> e)) = e + +instance ProjectionLike (ByProjection s e) where + type ProjectionLikeStart (ByProjection s e) = s + type ProjectionLikeEnd (ByProjection s e) = e + +-- | Projection from type @s@ to type @e@ used in @.by@ step. You can +-- also use 'gBy' to construct 'ByProjection'. +data ByProjection s e where + ByProjection :: (ProjectionLike p, ToGreskell p) => p -> ByProjection (ProjectionLikeStart p) (ProjectionLikeEnd p) + +-- | Projection by literal property key. +instance IsString (ByProjection s e) where + fromString = ByProjection . toKey + where + toKey :: String -> Key s e + toKey = fromString + +-- | @.by@ step with 1 argument, used for projection. +gBy :: (ProjectionLike p, ToGreskell p) => p -> ByProjection (ProjectionLikeStart p) (ProjectionLikeEnd p) +gBy = ByProjection + +-- | Comparison of type @s@ used in @.by@ step. You can also use +-- 'gBy1' and 'gBy2' to construct 'ByComparator'. +data ByComparator s where + -- | Type @s@ is projected to type @e@, and compared by the natural + -- comparator of type @e@. + ByComparatorProj :: ByProjection s e -> ByComparator s + + -- | Type @s@ is compared by the 'Comparator' @comp@. + ByComparatorComp :: Comparator comp => Greskell comp -> ByComparator (CompareArg comp) + + -- | Type @s@ is projected to type @CompareArg comp@, and compared + -- by the 'Comparator' @comp@. + ByComparatorProjComp :: Comparator comp => ByProjection s (CompareArg comp) -> Greskell comp -> ByComparator s + +-- | 'ByComparatorProj' by literal property key. +instance IsString (ByComparator s) where + fromString = ByComparatorProj . fromString + +-- | @.by@ step with 1 argumernt, used for comparison. +gBy1 :: (ProjectionLike p, ToGreskell p) => p -> ByComparator (ProjectionLikeStart p) +gBy1 = ByComparatorProj . gBy + +-- | @.by@ step with 2 arguments, used for comparison. +gBy2 :: (ProjectionLike p, ToGreskell p, Comparator comp, ProjectionLikeEnd p ~ CompareArg comp) + => p + -> Greskell comp + -> ByComparator (ProjectionLikeStart p) +gBy2 p c = ByComparatorProjComp (gBy p) c + +-- | @.order@ step. +-- +-- >>> let key_age = ("age" :: Key AVertex Int) +-- >>> toGremlin (source "g" & sV' [] &. gOrder [gBy1 key_age]) +-- "g.V().order().by(\"age\")" +-- >>> toGremlin (source "g" & sV' [] &. gOrder [gBy2 key_age oDecr, gBy1 tId]) +-- "g.V().order().by(\"age\",Order.decr).by(T.id)" +-- >>> toGremlin (source "g" & sV' [] &. gOrder [gBy2 (gOut' ["knows"] >>> gCount) oIncr, gBy2 tId oIncr]) +-- "g.V().order().by(__.out(\"knows\").count(),Order.incr).by(T.id,Order.incr)" +gOrder :: [ByComparator s] -- ^ following @.by@ steps. + -> Walk Transform s s +gOrder bys = modulateWith order_step by_steps + where + order_step = unsafeWalk "order" [] + by_steps = map (unsafeWalk "by" . toByArgs) bys + toByArgs :: ByComparator s -> [Text] + toByArgs bc = case bc of + ByComparatorProj (ByProjection p) -> [toGremlin p] + ByComparatorComp comp -> [toGremlin comp] + ByComparatorProjComp (ByProjection p) comp -> [toGremlin p, toGremlin comp] + +-- | @.flatMap@ step. +-- +-- @.flatMap@ step is a 'Transform' step even if the child walk is +-- 'Filter' type. This is because @.flatMap@ step always modifies the +-- path of the Traverser. +-- +-- >>> toGremlin (source "g" & sV' [] &. gFlatMap (gOut' ["knows"] >>> gOut' ["created"])) +-- "g.V().flatMap(__.out(\"knows\").out(\"created\"))" +gFlatMap :: (ToGTraversal g) => g Transform s e -> Walk Transform s e +gFlatMap gt = unsafeWalk "flatMap" [travToG gt] + +-- -- | Polymorphic version of 'gFlatMap'. The following constraint is +-- -- accurate and semantic, but it's not allowed even if +-- -- FlexibleContexts is enabled. Probably it's because the type @m@ is +-- -- left ambiguous. +-- gFlatMap' :: (ToGTraversal g, Split c m, Lift Transform p, Lift m p) => g c s e -> Walk p s e +-- gFlatMap = undefined + + +-- | @.values@ step. +-- +-- >>> toGremlin (source "g" & sV' [] &. gValues ["name", "age"]) +-- "g.V().values(\"name\",\"age\")" +gValues :: Element s + => [Key s e] + -- ^ property keys + -> Walk Transform s e +gValues = unsafeWalk "values" . map toGremlin + +-- | @.properties@ step. +-- +-- >>> toGremlin (source "g" & sV' [] &. gProperties ["age"]) +-- "g.V().properties(\"age\")" +gProperties :: (Element s, Property p, ElementProperty s ~ p) + => [Key s v] + -> Walk Transform s (p v) +gProperties = unsafeWalk "properties" . map toGremlin + +-- | @.fold@ step. +gFold :: Walk Transform a [a] +gFold = unsafeWalk "fold" [] + +-- | @.count@ step. +gCount :: Walk Transform a Int +gCount = unsafeWalk "count" [] + +genericTraversalWalk :: Vertex v => Text -> [Greskell Text] -> Walk Transform v e +genericTraversalWalk method_name = unsafeWalk method_name . map toGremlin + +-- | @.out@ step +gOut :: (Vertex v1, Vertex v2) + => [Greskell Text] -- ^ edge labels + -> Walk Transform v1 v2 +gOut = genericTraversalWalk "out" + +-- | Monomorphic version of 'gOut'. +-- +-- >>> toGremlin (source "g" & sV' ["person"] &. gOut' ["knows"]) +-- "g.V(\"person\").out(\"knows\")" +gOut' :: (Vertex v) + => [Greskell Text] + -> Walk Transform v AVertex +gOut' = gOut + +-- | @.outE@ step +gOutE :: (Vertex v, Edge e) + => [Greskell Text] -- ^ edge labels + -> Walk Transform v e +gOutE = genericTraversalWalk "outE" + +-- | Monomorphic version of 'gOutE' +gOutE' :: (Vertex v) + => [Greskell Text] + -> Walk Transform v AEdge +gOutE' = gOutE + +-- | @.in@ step +gIn :: (Vertex v1, Vertex v2) + => [Greskell Text] -- ^ edge labels + -> Walk Transform v1 v2 +gIn = genericTraversalWalk "in" + +-- | Monomorphic version of 'gIn'. +gIn' :: (Vertex v) + => [Greskell Text] + -> Walk Transform v AVertex +gIn' = gIn + +-- | @.inE@ step. +gInE :: (Vertex v, Edge e) + => [Greskell Text] -- ^ edge labels + -> Walk Transform v e +gInE = genericTraversalWalk "inE" + +-- | Monomorphic version of 'gInE'. +gInE' :: (Vertex v) + => [Greskell Text] -- ^ edge labels + -> Walk Transform v AEdge +gInE' = gInE + +-- | @.sideEffect@ step that takes a traversal. +gSideEffect :: (ToGTraversal g, WalkType c, WalkType p, Split c p) => g c s e -> Walk p s s +gSideEffect walk = unsafeWalk "sideEffect" [travToG walk] + +-- | Monomorphic version of 'gSideEffect'. The result walk is always +-- 'SideEffect' type. +-- +-- >>> toGremlin (source "g" & sV' [] & liftWalk &. gHas2 "name" "marko" &. gSideEffect' (gAddV' "toshio")) +-- "g.V().has(\"name\",\"marko\").sideEffect(__.addV(\"toshio\"))" +gSideEffect' :: (ToGTraversal g, WalkType c, Split c SideEffect) => g c s e -> Walk SideEffect s s +gSideEffect' w = gSideEffect w + +---- -- probably we can implement .as() step like this. GBuilder generates +---- -- some 'Label', which is passed to .as() step and can be passed later +---- -- to .select() step etc. +---- gAs :: GBuilder (Label, Walk Filter s s) +---- gAs = undefined + +-- | @.addV@ step with a label. +gAddV :: Vertex v => Greskell Text -> Walk SideEffect a v +gAddV label = unsafeWalk "addV" [toGremlin label] + +-- | Monomorphic version of 'gAddV'. +gAddV' :: Greskell Text -> Walk SideEffect a AVertex +gAddV' = gAddV + +-- | @.drop@ step on 'Element'. +-- +-- >>> toGremlin (source "g" & sV' [] &. gHas2 "name" "marko" & liftWalk &. gDrop) +-- "g.V().has(\"name\",\"marko\").drop()" +gDrop :: Element e => Walk SideEffect e e +gDrop = unsafeWalk "drop" [] + +-- | @.drop@ step on 'Property'. +-- +-- >>> toGremlin (source "g" & sE' [] &. gProperties ["weight"] & liftWalk &. gDropP) +-- "g.E().properties(\"weight\").drop()" +gDropP :: Property p => Walk SideEffect (p a) (p a) +gDropP = unsafeWalk "drop" [] diff --git a/src/Data/Greskell/Graph.hs b/src/Data/Greskell/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Data/Greskell/Graph.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE TypeFamilies, OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveTraversable #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +-- | +-- Module: Data.Greskell.Graph +-- Description: Haskell counterpart of Gremlin graph structure data types +-- Maintainer: Toshio Ito +-- +-- This module defines types and functions about TinkerPop graph +-- structure API. +module Data.Greskell.Graph + ( -- * TinkerPop graph structure types + Element(..), + Vertex, + Edge(..), + Property(..), + -- * T Enum + T, + tId, + tKey, + tLabel, + tValue, + -- * Typed Key (accessor of a Property) + Key(..), + key, + -- * Concrete data types + -- + -- $concrete_types + -- + -- ** Vertex + AVertex(..), + -- ** Edge + AEdge(..), + -- ** VertexProperty + AVertexProperty(..), + -- ** Property + AProperty(..), + -- ** PropertyMap + PropertyMap(..), + PropertyMapSingle, + PropertyMapList, + lookupOneValue, + lookupListValues, + parseOneValue, + parseListValues, + parseNonEmptyValues, + fromProperties, + -- * Internal use + FromJSONWithKey + ) where + +import Control.Applicative (empty, (<$>), (<*>), (<|>)) +import Data.Aeson (Value(..), FromJSON(..), (.:), (.:?), Object) +import Data.Aeson.Types (Parser) +import Data.Foldable (toList, Foldable(foldr), foldlM) +import qualified Data.HashMap.Lazy as HM +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NL +import Data.Maybe (listToMaybe) +import Data.Monoid (Monoid) +import Data.Semigroup ((<>), Semigroup) +import qualified Data.Semigroup as Semigroup +import Data.String (IsString(..)) +import Data.Text (Text, unpack) +import Data.Traversable (Traversable(traverse)) + +import Data.Greskell.GraphSON (GraphSON(..), GraphSONTyped(..), parseTypedGraphSON) +import Data.Greskell.Greskell + ( Greskell, unsafeGreskellLazy, string, + ToGreskell(..) + ) + +-- | @org.apache.tinkerpop.gremlin.structure.Element@ interface in a +-- TinkerPop graph. +class Element e where + type ElementID e + -- ^ ID type of the 'Element'. This depends on graph database + -- implementation and its settings. + type ElementProperty e :: * -> * + -- ^ Property type of the 'Element'. It should be of 'Property' + -- class. If you don't care, use 'AVertexProperty' if type @e@ is an + -- 'Vertex' and use 'AProperty' if type @e@ is an 'Edge' or + -- VertexProperty. + +-- | @org.apache.tinkerpop.gremlin.structure.Vertex@ interface in a +-- TinkerPop graph. +class (Element v) => Vertex v + +-- | @org.apache.tinkerpop.gremlin.structure.Edge@ interface in a +-- TinkerPop graph. +class (Element e) => Edge e where + type EdgeVertexID e + -- ^ ID type of the 'Vertex' this edge connects. + + +-- | @org.apache.tinkerpop.gremlin.structure.Property@ interface in a +-- TinkerPop graph. +class Property p where + propertyKey :: p v -> Text + -- ^ Get key of this property. + propertyValue :: p v -> v + -- ^ Get value of this property. + +-- | @org.apache.tinkerpop.gremlin.structure.T@ enum. +-- +-- 'T' is a token to get data @b@ from an Element @a@. +data T a b + +instance GraphSONTyped (T a b) where + gsonTypeFor _ = "g:T" + + +-- | @T.id@ token. +tId :: Element a => Greskell (T a (ElementID a)) +tId = unsafeGreskellLazy "T.id" + +-- | @T.key@ token. +tKey :: (Element (p v), Property p) => Greskell (T (p v) Text) +tKey = unsafeGreskellLazy "T.key" + +-- | @T.label@ token. +tLabel :: Element a => Greskell (T a Text) +tLabel = unsafeGreskellLazy "T.label" + +-- | @T.value@ token. +tValue :: (Element (p v), Property p) => Greskell (T (p v) v) +tValue = unsafeGreskellLazy "T.value" + + +-- | A property key accessing value @b@ in an Element @a@. In Gremlin, +-- it's just a String type. +newtype Key a b = Key { unKey :: Greskell Text } + deriving (Show,Eq) + +-- | Unsafely convert the value type @b@. +instance Functor (Key a) where + fmap _ (Key t) = Key t + +-- | Gremlin String literal as a 'Key'. +instance IsString (Key a b) where + fromString = Key . fromString + +-- | Unwrap 'Key' constructor. +instance ToGreskell (Key a b) where + type GreskellReturn (Key a b) = Text + toGreskell = unKey + +-- | Create a 'Key' from a literal string. +key :: Text -> Key a b +key = Key . string + +-- $concrete_types +-- +-- Concrete data types based on aeson 'Value's. +-- +-- Element IDs and property values are all 'Value', because they are +-- highly polymorphic. They are wrapped with 'GraphSON', so that you +-- can inspect 'gsonType' field if present. 'ElementID' and +-- 'EdgeVertexID' are bare 'Value' type for convenience. +-- +-- As for properties, you can use 'PropertyMap' and other type-classes +-- to manipulate them. +-- +-- If you want to define your own graph structure types, see +-- [README.md](https://github.com/debug-ito/greskell#make-your-own-graph-structure-types) +-- for detail. + + +-- | General vertex type you can use for 'Vertex' class, based on +-- aeson data types. +data AVertex = + AVertex + { avId :: GraphSON Value, + -- ^ ID of this vertex + avLabel :: Text, + -- ^ Label of this vertex + avProperties :: PropertyMapList AVertexProperty (GraphSON Value) + -- ^ Properties of this vertex. + } + deriving (Show,Eq) + +instance Element AVertex where + type ElementID AVertex = Value + type ElementProperty AVertex = AVertexProperty + +instance Vertex AVertex + +instance GraphSONTyped AVertex where + gsonTypeFor _ = "g:Vertex" + +instance FromJSON AVertex where + parseJSON (Object o) = AVertex + <$> (o .: "id") + <*> (o .: "label") + <*> (o `optionalMonoid` "properties") + parseJSON _ = empty + +-- | General edge type you can use for 'Edge' class, based on aeson +-- data types. +data AEdge = + AEdge + { aeId :: GraphSON Value, + -- ^ ID of this edge. + aeLabel :: Text, + -- ^ Label of this edge. + aeInVLabel :: Text, + -- ^ Label of this edge's destination vertex. + aeOutVLabel :: Text, + -- ^ Label of this edge's source vertex. + aeInV :: GraphSON Value, + -- ^ ID of this edge's destination vertex. + aeOutV :: GraphSON Value, + -- ^ ID of this edge's source vertex. + aeProperties :: PropertyMapSingle AProperty (GraphSON Value) + -- ^ Properties of this edge. + } + deriving (Show,Eq) + +instance Element AEdge where + type ElementID AEdge = Value + type ElementProperty AEdge = AProperty + +instance Edge AEdge where + type EdgeVertexID AEdge = Value + +instance GraphSONTyped AEdge where + gsonTypeFor _ = "g:Edge" + +instance FromJSON AEdge where + parseJSON (Object o) = + AEdge + <$> (o .: "id") + <*> (o .: "label") + <*> (o .: "inVLabel") + <*> (o .: "outVLabel") + <*> (o .: "inV") + <*> (o .: "outV") + <*> (o `optionalMonoid` "properties") + parseJSON _ = empty + +optionalMonoid :: (Monoid m, FromJSON m) => Object -> Text -> Parser m +optionalMonoid obj field_name = fmap (maybe mempty id) (obj .:? field_name) + +-- | __This typeclass is for internal use.__ +-- +-- JSON parser with a property key given from outside. +class FromJSONWithKey a where + parseJSONWithKey :: Text -> Value -> Parser a + + +-- | General simple property type you can use for 'Property' class. +data AProperty v = + AProperty + { apKey :: Text, + apValue :: v + } + deriving (Show,Eq,Ord) + +-- | Parse Property of GraphSON 1.0. +instance FromJSON v => FromJSON (AProperty v) where + parseJSON (Object o) = + AProperty <$> (o .: "key") <*> (o .: "value") + parseJSON _ = empty + +instance FromJSON v => FromJSONWithKey (AProperty v) where + parseJSONWithKey k v = AProperty k <$> parseJSON v + +instance Property AProperty where + propertyKey = apKey + propertyValue = apValue + +instance GraphSONTyped (AProperty v) where + gsonTypeFor _ = "g:Property" + +instance Functor AProperty where + fmap f sp = sp { apValue = f $ apValue sp } + +instance Foldable AProperty where + foldr f start sp = f (apValue sp) start + +instance Traversable AProperty where + traverse f sp = fmap (\v -> sp { apValue = v } ) $ f $ apValue sp + +-- | General vertex property type you can use for VertexProperty, +-- based on aeson data types. +data AVertexProperty v = + AVertexProperty + { avpId :: GraphSON Value, + -- ^ ID of this vertex property. + avpLabel :: Text, + -- ^ Label and key of this vertex property. + avpValue :: v, + -- ^ Value of this vertex property. + avpProperties :: PropertyMapSingle AProperty (GraphSON Value) + -- ^ (meta)properties of this vertex property. + } + deriving (Show,Eq) + +instance FromJSON v => FromJSON (AVertexProperty v) where + parseJSON v@(Object o) = do + label <- o .: "label" + parseJSONWithKey label v + parseJSON _ = empty + +instance FromJSON v => FromJSONWithKey (AVertexProperty v) where + parseJSONWithKey k (Object o) = AVertexProperty + <$> (o .: "id") + <*> pure k + <*> (o .: "value") + <*> (o `optionalMonoid` "properties") + parseJSONWithKey _ _ = empty + + +instance GraphSONTyped (AVertexProperty v) where + gsonTypeFor _ = "g:VertexProperty" + +instance Element (AVertexProperty v) where + type ElementID (AVertexProperty v) = Value + type ElementProperty (AVertexProperty v) = AProperty + +instance Property AVertexProperty where + propertyKey = avpLabel + propertyValue = avpValue + +instance Functor AVertexProperty where + fmap f vp = vp { avpValue = f $ avpValue vp } + +instance Foldable AVertexProperty where + foldr f start vp = f (avpValue vp) start + +instance Traversable AVertexProperty where + traverse f vp = fmap (\v -> vp { avpValue = v }) $ f $ avpValue vp + + +-- -- We could define the following constraint synonym with +-- -- ConstraintKinds extension, although its semantics is not exactly +-- -- correct.. +-- type VertexProperty p v = (Element (p v), Property p) + + +-- | Common basic operations supported by maps of properties. +class PropertyMap m where + lookupOne :: Text -> m p v -> Maybe (p v) + -- ^ Look up a property associated with the given key. + lookupOne k m = listToMaybe $ lookupList k m + lookupList :: Text -> m p v -> [p v] + -- ^ Look up all properties associated with the given key. + putProperty :: Property p => p v -> m p v -> m p v + -- ^ Put a property into the map. + removeProperty :: Text -> m p v -> m p v + -- ^ Remove all properties associated with the given key. + allProperties :: m p v -> [p v] + -- ^ Return all properties in the map. + +-- | Lookup a property value from a 'PropertyMap' by key. +lookupOneValue :: (PropertyMap m, Property p) => Text -> m p v -> Maybe v +lookupOneValue k = fmap propertyValue . lookupOne k + +-- | Lookup a list of property values from a 'PropertyMap' by key. +lookupListValues :: (PropertyMap m, Property p) => Text -> m p v -> [v] +lookupListValues k = fmap propertyValue . lookupList k + +notExistErrorMsg :: Text -> String +notExistErrorMsg k = "Property '" ++ unpack k ++ "' does not exist." + +-- | Lookup a property 'Value' by the given key, and parse it. +parseOneValue :: (PropertyMap m, Property p, FromJSON v) => Text -> m p (GraphSON Value) -> Parser v +parseOneValue k pm = maybe (fail err_msg) (parseJSON . gsonValue) $ lookupOneValue k pm + where + err_msg = notExistErrorMsg k + +-- | Lookup a list of property values from a 'PropertyMap' by the +-- given key, and parse them. +parseListValues :: (PropertyMap m, Property p, FromJSON v) => Text -> m p (GraphSON Value) -> Parser [v] +parseListValues k pm = mapM (parseJSON . gsonValue) $ lookupListValues k pm + +-- | Like 'parseListValues', but this function 'fail's when there is +-- no property with the given key. +parseNonEmptyValues :: (PropertyMap m, Property p, FromJSON v) => Text -> m p (GraphSON Value) -> Parser (NonEmpty v) +parseNonEmptyValues k pm = toNonEmpty =<< parseListValues k pm + where + toNonEmpty [] = fail $ notExistErrorMsg k + toNonEmpty (x : rest) = return (x :| rest) + +-- | Create a 'PropertyMap' from list of 'Property's. +fromProperties :: (PropertyMap m, Property p, Monoid (m p v)) + => [p v] + -> m p v +fromProperties = foldr putProperty mempty + +-- | Generic implementation of 'PropertyMap'. @t@ is the type of +-- cardinality, @p@ is the type of 'Property' class and @v@ is the +-- type of the property value. +newtype PropertyMapGeneric t p v = PropertyMapGeneric (HM.HashMap Text (t (p v))) + deriving (Show,Eq) + +instance Semigroup (t (p v)) => Monoid (PropertyMapGeneric t p v) where + mempty = PropertyMapGeneric mempty + mappend (PropertyMapGeneric a) (PropertyMapGeneric b) = + PropertyMapGeneric $ HM.unionWith (<>) a b + +instance (Functor t, Functor p) => Functor (PropertyMapGeneric t p) where + fmap f (PropertyMapGeneric hm) = PropertyMapGeneric $ (fmap . fmap . fmap) f hm + +instance (Foldable t, Foldable p) => Foldable (PropertyMapGeneric t p) where + foldr f start (PropertyMapGeneric hm) = foldr f2 start hm + where + f2 t start2 = foldr f3 start2 t + f3 p start3 = foldr f start3 p + +instance (Traversable t, Traversable p) => Traversable (PropertyMapGeneric t p) where + traverse f (PropertyMapGeneric hm) = fmap PropertyMapGeneric $ (traverse . traverse . traverse) f hm + +putPropertyGeneric :: (Semigroup (t (p v)), Applicative t, Property p) => p v -> PropertyMapGeneric t p v -> PropertyMapGeneric t p v +putPropertyGeneric prop (PropertyMapGeneric hm) = + PropertyMapGeneric $ HM.insertWith (<>) (propertyKey prop) (pure prop) hm + +removePropertyGeneric :: Text -> PropertyMapGeneric t p v -> PropertyMapGeneric t p v +removePropertyGeneric k (PropertyMapGeneric hm) = PropertyMapGeneric $ HM.delete k hm + +allPropertiesGeneric :: Foldable t => PropertyMapGeneric t p v -> [p v] +allPropertiesGeneric (PropertyMapGeneric hm) = concat $ map toList $ HM.elems hm + +parsePropertiesGeneric :: (Property p, PropertyMap m, Monoid (m p v), GraphSONTyped (p v), FromJSON (p v), FromJSONWithKey (p v)) + => (Value -> Parser [Value]) + -> Value + -> Parser (m p v) +parsePropertiesGeneric normalizeCardinality (Object obj) = foldlM folder mempty $ HM.toList obj + where + folder pm (k, value) = fmap (foldr putProperty pm) $ traverse (parseProperty k) =<< normalizeCardinality value + parseProperty k value = (fmap gsonValue $ parseTypedGraphSON value) <|> parseJSONWithKey k value +parsePropertiesGeneric _ _ = empty + +expectAesonArray :: Value -> Parser [Value] +expectAesonArray (Array a) = return $ toList a +expectAesonArray _ = empty + +-- | A 'PropertyMap' that has a single value per key. +-- +-- 'putProperty' replaces the old property by the given property. +-- +-- '<>' returns the union of the two given property maps. If the two +-- property maps share some same keys, the value from the left map +-- wins. +newtype PropertyMapSingle p v = PropertyMapSingle (PropertyMapGeneric Semigroup.First p v) + deriving (Show,Eq,Monoid,Functor,Foldable,Traversable) + +instance PropertyMap PropertyMapSingle where + lookupOne k (PropertyMapSingle (PropertyMapGeneric hm)) = fmap Semigroup.getFirst $ HM.lookup k hm + lookupList k m = maybe [] return $ lookupOne k m + putProperty p (PropertyMapSingle pg) = PropertyMapSingle $ putPropertyGeneric p pg + removeProperty t (PropertyMapSingle pg) = PropertyMapSingle $ removePropertyGeneric t pg + allProperties (PropertyMapSingle pg) = allPropertiesGeneric pg + +instance (Property p, GraphSONTyped (p v), FromJSON (p v), FromJSONWithKey (p v)) + => FromJSON (PropertyMapSingle p v) where + parseJSON = parsePropertiesGeneric (return . return) + +-- | A 'PropertyMap' that can keep more than one values per key. +-- +-- 'lookupOne' returns the first property associated with the given +-- key. +-- +-- 'putProperty' prepends the given property to the property list. +-- +-- '<>' returns the union of the two given property maps. If the two +-- property maps share some same keys, those property lists are +-- concatenated. +newtype PropertyMapList p v = PropertyMapList (PropertyMapGeneric NonEmpty p v) + deriving (Show,Eq,Monoid,Functor,Foldable,Traversable) + +instance PropertyMap PropertyMapList where + lookupList k (PropertyMapList (PropertyMapGeneric hm)) = maybe [] NL.toList $ HM.lookup k hm + putProperty p (PropertyMapList pg) = PropertyMapList $ putPropertyGeneric p pg + removeProperty t (PropertyMapList pg) = PropertyMapList $ removePropertyGeneric t pg + allProperties (PropertyMapList pg) = allPropertiesGeneric pg + +instance (Property p, GraphSONTyped (p v), FromJSON (p v), FromJSONWithKey (p v)) + => FromJSON (PropertyMapList p v) where + parseJSON v = parsePropertiesGeneric expectAesonArray v + diff --git a/src/Data/Greskell/Gremlin.hs b/src/Data/Greskell/Gremlin.hs new file mode 100644 --- /dev/null +++ b/src/Data/Greskell/Gremlin.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies #-} +-- | +-- Module: Data.Greskell.Gremlin +-- Description: Gremlin (Groovy/Java) utility classes +-- Maintainer: Toshio Ito +-- +-- This modules defines types and functions for utility classes in +-- Gremlin. +module Data.Greskell.Gremlin + ( -- * Predicate + Predicate(..), + PredicateA(..), + -- ** P class + P, + pNot, + pEq, + pNeq, + pLt, + pLte, + pGt, + pGte, + pInside, + pOutside, + pBetween, + pWithin, + pWithout, + -- * Comparator + Comparator(..), + ComparatorA(..), + -- ** Order enum + Order, + oDecr, + oIncr, + oShuffle, + ) where + +import Data.Aeson (Value) +import Data.Monoid ((<>)) +import Data.Greskell.GraphSON (GraphSONTyped(..)) +import Data.Greskell.Greskell + ( Greskell, unsafeGreskellLazy, + toGremlin, toGremlinLazy, unsafeMethodCall, unsafeFunCall + ) + +-- $setup +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Greskell.Greskell (number, string) + +-- | @java.util.function.Predicate@ interface. +-- +-- A 'Predicate' @p@ is a function that takes 'PredicateArg' @p@ and +-- returns 'Bool'. +class Predicate p where + type PredicateArg p + -- | @.and@ method. + pAnd :: Greskell p -> Greskell p -> Greskell p + pAnd p1 p2 = unsafeMethodCall p1 "and" [toGremlin p2] + -- | @.or@ method. + pOr :: Greskell p -> Greskell p -> Greskell p + pOr o1 o2 = unsafeMethodCall o1 "or" [toGremlin o2] + -- | @.test@ method. + pTest :: Greskell p -> Greskell (PredicateArg p) -> Greskell Bool + pTest p arg = unsafeMethodCall p "test" [toGremlin arg] + -- | @.nagate@ method. + pNegate :: Greskell p -> Greskell p + pNegate p = unsafeMethodCall p "negate" [] + +-- | Type for anonymous class of @Predicate@ interface. +newtype PredicateA a = PredicateA { unPredicateA :: a -> Bool } + +instance Predicate (PredicateA a) where + type PredicateArg (PredicateA a) = a + +-- | @org.apache.tinkerpop.gremlin.process.traversal.P@ class. +-- +-- @P a@ keeps data of type @a@ and compares it with data of type @a@ +-- given as the Predicate argument. +data P a + +instance Predicate (P a) where + type PredicateArg (P a) = a + +instance GraphSONTyped (P a) where + gsonTypeFor _ = "g:P" + + +-- | @P.not@ static method. +-- +-- >>> toGremlin $ pNot $ pEq $ number 10 +-- "P.not(P.eq(10.0))" +pNot :: Greskell (P a) -> Greskell (P a) +pNot a = unsafeFunCall "P.not" [toGremlin a] + +-- | @P.eq@ static method. +-- +-- >>> toGremlin $ pEq $ string "hoge" +-- "P.eq(\"hoge\")" +pEq :: Greskell a -> Greskell (P a) +pEq arg = unsafeFunCall "P.eq" [toGremlin arg] + +-- | @P.neq@ static method. +pNeq :: Greskell a -> Greskell (P a) +pNeq arg = unsafeFunCall "P.neq" [toGremlin arg] + +-- | @P.lt@ static method. +pLt :: Greskell a -> Greskell (P a) +pLt arg = unsafeFunCall "P.lt" [toGremlin arg] + +-- | @P.lte@ static method. +pLte :: Greskell a -> Greskell (P a) +pLte arg = unsafeFunCall "P.lte" [toGremlin arg] + +-- | @P.gt@ static method. +pGt :: Greskell a -> Greskell (P a) +pGt arg = unsafeFunCall "P.gt" [toGremlin arg] + +-- | @P.gte@ static method. +pGte :: Greskell a -> Greskell (P a) +pGte arg = unsafeFunCall "P.gte" [toGremlin arg] + +-- | @P.inside@ static method. +-- +-- >>> toGremlin $ pInside (number 10) (number 20) +-- "P.inside(10.0,20.0)" +pInside :: Greskell a -> Greskell a -> Greskell (P a) +pInside a b = unsafeFunCall "P.inside" $ map toGremlin [a, b] + +-- | @P.outside@ static method. +pOutside :: Greskell a -> Greskell a -> Greskell (P a) +pOutside a b = unsafeFunCall "P.outside" $ map toGremlin [a, b] + +-- | @P.between@ static method. +pBetween :: Greskell a -> Greskell a -> Greskell (P a) +pBetween a b = unsafeFunCall "P.between" $ map toGremlin [a, b] + +-- | @P.within@ static method. +-- +-- >>> toGremlin $ pWithin (["foo", "bar", "hoge"] :: [Greskell String]) +-- "P.within(\"foo\",\"bar\",\"hoge\")" +pWithin :: [Greskell a] -> Greskell (P a) +pWithin = unsafeFunCall "P.within" . map toGremlin + +-- | @P.without@ static method. +pWithout :: [Greskell a] -> Greskell (P a) +pWithout = unsafeFunCall "P.without" . map toGremlin + +-- | @java.util.Comparator@ interface. +-- +-- 'Comparator' compares two data of type 'CompareArg' @c@. +class Comparator c where + type CompareArg c + -- | @.compare@ method. + cCompare :: Greskell c -> Greskell (CompareArg c) -> Greskell (CompareArg c) -> Greskell Int + cCompare cmp a b = unsafeMethodCall cmp "compare" $ map toGremlin [a, b] + -- | @.reverse@ method. + cReversed :: Greskell c -> Greskell c + cReversed cmp = unsafeMethodCall cmp "reversed" [] + -- | @.thenComparing@ method. + cThenComparing :: Greskell c -> Greskell c -> Greskell c + cThenComparing cmp1 cmp2 = unsafeMethodCall cmp1 "thenComparing" [toGremlin cmp2] + +-- | Type for anonymous class of @Comparator@ interface. +newtype ComparatorA a = ComparatorA { unComparatorA :: a -> a -> Int } + +instance Comparator (ComparatorA a) where + type CompareArg (ComparatorA a) = a + +-- | @org.apache.tinkerpop.gremlin.process.traversal.Order@ enum. +data Order a + +-- | @Order a@ compares the type @a@. +instance Comparator (Order a) where + type CompareArg (Order a) = a + +instance GraphSONTyped (Order a) where + gsonTypeFor _ = "g:Order" + +-- | @decr@ order. +-- +-- >>> toGremlin oDecr +-- "Order.decr" +oDecr :: Greskell (Order a) +oDecr = unsafeGreskellLazy "Order.decr" + +-- | @incr@ order. +oIncr :: Greskell (Order a) +oIncr = unsafeGreskellLazy "Order.incr" + +-- | @shuffle@ order. +oShuffle :: Greskell (Order a) +oShuffle = unsafeGreskellLazy "Order.shuffle" diff --git a/test/Data/Greskell/BinderSpec.hs b/test/Data/Greskell/BinderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Greskell/BinderSpec.hs @@ -0,0 +1,50 @@ +module Data.Greskell.BinderSpec (main,spec) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (forM_) +import Data.Aeson (toJSON) +import qualified Data.HashMap.Strict as HM +import Data.Text (unpack) +import Test.Hspec + +import Data.Greskell.Greskell (toGremlin, unsafeGreskell, Greskell) +import Data.Greskell.Binder (newBind, runBinder) + +main :: IO () +main = hspec spec + +shouldBeVariable :: Greskell a -> IO () +shouldBeVariable got_greskell = + case unpack $ toGremlin got_greskell of + [] -> expectationFailure "Expect a Gremlin variable, but got empty script." + (h : rest) -> do + h `shouldSatisfy` (`elem` variableHeads) + forM_ rest (`shouldSatisfy` (`elem` variableRests)) + where + variableHeads = '_' : (['a' .. 'z'] ++ ['A' .. 'Z']) + variableRests = variableHeads ++ ['0' .. '9'] + + +spec :: Spec +spec = describe "Binder" $ do + it "should keep bound values" $ do + let b = do + v1 <- newBind (100 :: Int) + v2 <- newBind "hogehoge" + return (v1, v2) + ((got_v1, got_v2), got_bind) = runBinder b + toGremlin got_v1 `shouldNotBe` toGremlin got_v2 + shouldBeVariable got_v1 + shouldBeVariable got_v2 + got_bind `shouldBe` HM.fromList [ (toGremlin got_v1, toJSON (100 :: Int)), + (toGremlin got_v2, toJSON "hogehoge") + ] + it "should compose and produce new variables" $ do + let b = newBind "foobar" + ((got_v1, got_v2), got_bind) = runBinder $ ((,) <$> b <*> b) + toGremlin got_v1 `shouldNotBe` toGremlin got_v2 + shouldBeVariable got_v1 + shouldBeVariable got_v2 + got_bind `shouldBe` HM.fromList [ (toGremlin got_v1, toJSON "foobar"), + (toGremlin got_v2, toJSON "foobar") + ] diff --git a/test/Data/Greskell/GTraversalSpec.hs b/test/Data/Greskell/GTraversalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Greskell/GTraversalSpec.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.Greskell.GTraversalSpec (main,spec) where + +import Control.Category ((>>>), (<<<)) +import Data.Aeson (ToJSON(..), Value(Number)) +import Data.Function ((&)) +import Data.Text (Text) +import System.IO (stderr, hPutStrLn) + +import Test.Hspec + +import Data.Greskell.Gremlin + ( oIncr, oDecr, oShuffle, + pEq, pNeq, pInside, pGte + ) +import Data.Greskell.Graph + ( Element, + Key, key, + tLabel, tId + ) +import Data.Greskell.Greskell + ( toGremlin, Greskell, value) +import Data.Greskell.GTraversal + ( Walk, Transform, + source, (&.), ($.), sV', sE', + gHas1, gHas2, gHas2P, gHasLabelP, gHasIdP, + gOut', gRange, gValues, gNot, gIn', + gOrder, + gProperties, gHasKeyP, gHasValueP, + ByComparator(..), gBy2, gBy1, gBy + ) + + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + spec_GraphTraversalSource + spec_order_by + spec_compose_steps + spec_has + + +spec_GraphTraversalSource :: Spec +spec_GraphTraversalSource = describe "GraphTraversalSource" $ do + specify "g.V()" $ do + (toGremlin $ sV' [] $ source "g") `shouldBe` ("g.V()") + specify "g.V(1,2,3)" $ do + let ids = [1,2,3] :: [Greskell Int] + (toGremlin $ sV' (map (fmap toJSON) ids) $ source "g") `shouldBe` ("g.V(1,2,3)") + +spec_order_by :: Spec +spec_order_by = describe "gOrder" $ do + let gv = source "g" & sV' [] + specify "no arg" $ do + toGremlin (gv &. gOrder []) `shouldBe` "g.V().order()" + specify "empty projection" $ do + -- This case is relatively rare (I think), so the API is not so convenient for now. + toGremlin (gv &. gOrder [ByComparatorComp oIncr]) `shouldBe` "g.V().order().by(Order.incr)" + specify "traversal projection" $ do + toGremlin (gv &. gOrder [gBy2 (gOut' ["foo"] >>> gIn' ["bar"]) oShuffle]) + `shouldBe` "g.V().order().by(__.out(\"foo\").in(\"bar\"),Order.shuffle)" + specify "value projection" $ do + let nameKey :: Key e Text + nameKey = "name" + toGremlin (gv &. gOrder [gBy2 nameKey oDecr]) `shouldBe` "g.V().order().by(\"name\",Order.decr)" + specify "T token projection" $ do + toGremlin (gv &. gOrder [gBy2 tLabel oIncr]) `shouldBe` "g.V().order().by(T.label,Order.incr)" + specify "multiple .by steps of different comparison types" $ do + let ageKey :: Key e Int + ageKey = "age" + toGremlin (gv &. gOrder [gBy2 ageKey oDecr, gBy2 tId oDecr, gBy1 (gOut' ["foo"])]) + `shouldBe` "g.V().order().by(\"age\",Order.decr).by(T.id,Order.decr).by(__.out(\"foo\"))" + specify "gBy1" $ do + toGremlin (gv &. gOrder [gBy1 (key "name")]) `shouldBe` "g.V().order().by(\"name\")" + specify "IsString instance of ByComparator" $ do + toGremlin (gv &. gOrder ["age"]) `shouldBe` "g.V().order().by(\"age\")" + specify "gBy" $ do + toGremlin (gv &. gOrder [ByComparatorProj $ gBy tLabel]) `shouldBe` "g.V().order().by(T.label)" + specify "IsString instance of ByProjection" $ do + toGremlin (gv &. gOrder [ByComparatorProjComp ("name") oIncr]) + `shouldBe` "g.V().order().by(\"name\",Order.incr)" + +spec_compose_steps :: Spec +spec_compose_steps = describe "DSL to compose steps" $ do + specify "(&) and (&.)" $ do + let gt = source "g" & sV' [] &. gHas2P ("x" :: Key e Int) (pEq 100) &. gOut' [] &. gRange 0 100 + toGremlin gt `shouldBe` "g.V().has(\"x\",P.eq(100)).out().range(0,100)" + specify "(&) and (&.) and (>>>)" $ do + let gt = source "g" & sV' [value $ Number 200] &. (gOut' [] >>> gOut' ["friends_to"] >>> gValues ["name"]) + toGremlin gt `shouldBe` "g.V(200.0).out().out(\"friends_to\").values(\"name\")" + specify "($) and ($.)" $ do + let gt = gRange 20 30 $. gNot (gOut' ["friends_to"]) $. sV' [] $ source "g" + toGremlin gt `shouldBe` "g.V().not(__.out(\"friends_to\")).range(20,30)" + specify "($) and ($.) and (<<<)" $ do + let gt = gHas2P (key "name" :: Key e Text) (pEq "hoge") <<< gIn' ["foo", "bar"] <<< gIn' [] $. sV' [] $ source "g" + toGremlin gt `shouldBe` "g.V().in().in(\"foo\",\"bar\").has(\"name\",P.eq(\"hoge\"))" + +spec_has :: Spec +spec_has = do + describe "gHas1" $ do + specify "IsString Key" $ do + toGremlin (source "g" & sV' [] &. gHas1 "foo") `shouldBe` "g.V().has(\"foo\")" + describe "gHas2" $ do + specify "simple equality" $ do + toGremlin (source "g" & sV' [] &. gHas2 "name" ("hoge" :: Greskell Text)) + `shouldBe` "g.V().has(\"name\",\"hoge\")" + describe "gHas2P" $ do + specify "IsString Key and P" $ do + toGremlin (source "g" & sV' [] &. gHas2P ("name" :: Key e Text) (pNeq "hoge")) + `shouldBe` "g.V().has(\"name\",P.neq(\"hoge\"))" + describe "gHasLabelP" $ do + specify "P" $ do + toGremlin (source "g" & sE' [] &. gHasLabelP (pNeq "friends_to")) + `shouldBe` "g.E().hasLabel(P.neq(\"friends_to\"))" + describe "gHasIdP" $ do + specify "P" $ do + toGremlin (source "g" & sV' [] &. gHasIdP (pInside (value $ Number 10) (value $ Number 20))) + `shouldBe` "g.V().hasId(P.inside(10.0,20.0))" + describe "gHasKeyP, gProperties" $ do + specify "P" $ do + toGremlin (source "g" & sV' [] &. gProperties [] &. gHasKeyP (pEq "hoge")) + `shouldBe` "g.V().properties().hasKey(P.eq(\"hoge\"))" + describe "gHasValueP, gProperties" $ do + specify "P" $ do + toGremlin (source "g" & sV' [] &. gProperties ["age" :: Key e Int] &. gHasValueP (pGte 20)) + `shouldBe` "g.V().properties(\"age\").hasValue(P.gte(20))" diff --git a/test/Data/Greskell/GraphSpec.hs b/test/Data/Greskell/GraphSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Greskell/GraphSpec.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.Greskell.GraphSpec (main,spec) where + +import Data.Aeson (toJSON, FromJSON) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.Monoid (Monoid(..), (<>)) +import Data.Text (Text) +import Test.Hspec + +import Data.Greskell.Graph + ( AProperty(..), PropertyMapSingle, PropertyMapList, + PropertyMap(..), + AEdge(..), AVertexProperty(..), AVertex(..) + ) +import Data.Greskell.GraphSON + ( nonTypedGraphSON, typedGraphSON, typedGraphSON' + ) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + spec_PropertyMap + spec_AEdge + spec_AProperty + spec_AVertexProperty + spec_AVertex + +spec_PropertyMap :: Spec +spec_PropertyMap = do + describe "PropertyMapSingle" $ do + let pm :: PropertyMapSingle AProperty Int + pm = putProperty (AProperty "buzz" 300) + $ putProperty (AProperty "bar" 200) + $ putProperty (AProperty "foo" 100) mempty + specify "allProperties" $ do + allProperties pm `shouldMatchList` + [ AProperty "buzz" 300, + AProperty "bar" 200, + AProperty "foo" 100 + ] + specify "lookupOne existing" $ do + lookupOne "foo" pm `shouldBe` (Just $ AProperty "foo" 100) + specify "lookupOne non-existing" $ do + lookupOne "HOGE" pm `shouldBe` Nothing + specify "lookupList existing" $ do + lookupList "bar" pm `shouldBe` [AProperty "bar" 200] + specify "lookupList non-existing" $ do + lookupList "HOGE" pm `shouldBe` [] + specify "putProperty overrides" $ do + let pm2 = putProperty (AProperty "foo" 500) pm + lookupOne "foo" pm2 `shouldBe` Just (AProperty "foo" 500) + lookupList "foo" pm2 `shouldBe` [AProperty "foo" 500] + specify "removeProperty" $ do + let pm2 = removeProperty "HOGE" $ removeProperty "bar" pm + lookupList "bar" pm2 `shouldBe` [] + specify "mappend prefers the left" $ do + let pm2 :: PropertyMapSingle AProperty Int + pm2 = putProperty (AProperty "hoge" 600) + $ putProperty (AProperty "bar" 500) mempty + pm3 = pm <> pm2 + allProperties pm3 `shouldMatchList` + [ AProperty "buzz" 300, + AProperty "bar" 200, + AProperty "foo" 100, + AProperty "hoge" 600 + ] + describe "PropertyMapList" $ do + let pm :: PropertyMapList AProperty Int + pm = putProperty (AProperty "foo" 100) + $ putProperty (AProperty "foo" 200) + $ putProperty (AProperty "bar" 300) + $ putProperty (AProperty "foo" 400) mempty + specify "allProperties" $ do + allProperties pm `shouldMatchList` + [ AProperty "foo" 100, + AProperty "foo" 200, + AProperty "bar" 300, + AProperty "foo" 400 + ] + specify "lookupOne existing" $ do + lookupOne "foo" pm `shouldBe` Just (AProperty "foo" 100) + specify "lookupOne non-existing" $ do + lookupOne "HOGE" pm `shouldBe` Nothing + specify "lookupList existing" $ do + lookupList "foo" pm `shouldBe` map (AProperty "foo") [100,200,400] + specify "lookupList non-existing" $ do + lookupList "HOGE" pm `shouldBe` [] + specify "putProperty appends" $ do + let pm2 = putProperty (AProperty "bar" 500) pm + lookupOne "bar" pm2 `shouldBe` Just (AProperty "bar" 500) + lookupList "bar" pm2 `shouldBe` map (AProperty "bar") [500,300] + specify "removeProperty" $ do + let pm2 = removeProperty "foo" $ removeProperty "HOGE" pm + lookupOne "foo" pm2 `shouldBe` Nothing + lookupList "foo" pm2 `shouldBe` [] + specify "mappend appends" $ do + let pm2 :: PropertyMapList AProperty Int + pm2 = putProperty (AProperty "bar" 500) + $ putProperty (AProperty "buzz" 600) + $ putProperty (AProperty "foo" 700) mempty + pm3 = pm <> pm2 + lookupList "foo" pm3 `shouldBe` map (AProperty "foo") [100,200,400,700] + lookupList "bar" pm3 `shouldBe` map (AProperty "bar") [300,500] + allProperties pm3 `shouldMatchList` + [ AProperty "foo" 100, + AProperty "foo" 200, + AProperty "foo" 400, + AProperty "foo" 700, + AProperty "bar" 300, + AProperty "bar" 500, + AProperty "buzz" 600 + ] + + +loadGraphSON :: FromJSON a => FilePath -> IO (Either String a) +loadGraphSON filename = fmap Aeson.eitherDecode $ BSL.readFile ("test/graphson/" ++ filename) + +spec_AEdge :: Spec +spec_AEdge = describe "AEdge" $ do + it "should parse GraphSON v1" $ do + let expected = nonTypedGraphSON + $ AEdge + { aeId = nonTypedGraphSON $ toJSON (13 :: Int), + aeLabel = "develops", + aeInVLabel = "software", + aeOutVLabel = "person", + aeInV = nonTypedGraphSON $ toJSON (10 :: Int), + aeOutV = nonTypedGraphSON $ toJSON (1 :: Int), + aeProperties = putProperty + (AProperty "since" $ nonTypedGraphSON $ toJSON (2009 :: Int)) + $ mempty + } + loadGraphSON "edge_v1.json" `shouldReturn` Right expected + let expected_v23 = typedGraphSON + $ AEdge + { aeId = typedGraphSON' "g:Int32" $ toJSON (13 :: Int), + aeLabel = "develops", + aeInVLabel = "software", + aeOutVLabel = "person", + aeInV = typedGraphSON' "g:Int32" $ toJSON (10 :: Int), + aeOutV = typedGraphSON' "g:Int32" $ toJSON (1 :: Int), + aeProperties = putProperty + (AProperty "since" $ typedGraphSON' "g:Int32" $ toJSON (2009 :: Int)) + $ mempty + } + it "should parse GraphSON v2" $ do + loadGraphSON "edge_v2.json" `shouldReturn` Right expected_v23 + it "should parse GraphSON v3" $ do + loadGraphSON "edge_v3.json" `shouldReturn` Right expected_v23 + +spec_AProperty :: Spec +spec_AProperty = describe "AProperty" $ do + it "should parse GraphSON v1" $ do + let ex = nonTypedGraphSON $ AProperty "since" $ nonTypedGraphSON (2009 :: Int) + loadGraphSON "property_v1.json" `shouldReturn` Right ex + let ex23 = typedGraphSON $ AProperty "since" $ typedGraphSON' "g:Int32" (2009 :: Int) + it "should parse GraphSON v2" $ do + loadGraphSON "property_v2.json" `shouldReturn` Right ex23 + it "should parse GraphSON v3" $ do + loadGraphSON "property_v3.json" `shouldReturn` Right ex23 + +spec_AVertexProperty :: Spec +spec_AVertexProperty = describe "AVertexProperty" $ do + it "should parse GraphSON v1" $ do + let ex = nonTypedGraphSON $ + AVertexProperty + { avpId = nonTypedGraphSON $ toJSON (0 :: Int), + avpLabel = "name", + avpValue = nonTypedGraphSON $ toJSON ("marko" :: Text), + avpProperties = mempty + } + loadGraphSON "vertex_property_v1.json" `shouldReturn` Right ex + let ex23 = typedGraphSON $ + AVertexProperty + { avpId = typedGraphSON' "g:Int64" $ toJSON (0 :: Int), + avpLabel = "name", + avpValue = nonTypedGraphSON $ toJSON ("marko" :: Text), + avpProperties = mempty + } + it "should parse GraphSON v2" $ do + loadGraphSON "vertex_property_v2.json" `shouldReturn` Right ex23 + it "should parse GraphSON v3" $ do + loadGraphSON "vertex_property_v3.json" `shouldReturn` Right ex23 + +spec_AVertex :: Spec +spec_AVertex = describe "AVertex" $ do + it "should parse GraphSON v1" $ do + let ex = nonTypedGraphSON $ + AVertex + { avId = nonTypedGraphSON $ toJSON (1 :: Int), + avLabel = "person", + avProperties = foldr putProperty mempty + [ AVertexProperty + { avpId = nonTypedGraphSON $ toJSON (0 :: Int), + avpLabel = "name", + avpValue = nonTypedGraphSON $ toJSON ("marko" :: Text), + avpProperties = mempty + }, + AVertexProperty + { avpId = nonTypedGraphSON $ toJSON (6 :: Int), + avpLabel = "location", + avpValue = nonTypedGraphSON $ toJSON ("san diego" :: Text), + avpProperties = foldr putProperty mempty + [ AProperty "startTime" $ nonTypedGraphSON $ toJSON (1997 :: Int), + AProperty "endTime" $ nonTypedGraphSON $ toJSON (2001 :: Int) + ] + }, + AVertexProperty + { avpId = nonTypedGraphSON $ toJSON (7 :: Int), + avpLabel = "location", + avpValue = nonTypedGraphSON $ toJSON ("santa cruz" :: Text), + avpProperties = foldr putProperty mempty + [ AProperty "startTime" $ nonTypedGraphSON $ toJSON (2001 :: Int), + AProperty "endTime" $ nonTypedGraphSON $ toJSON (2004 :: Int) + ] + }, + AVertexProperty + { avpId = nonTypedGraphSON $ toJSON (8 :: Int), + avpLabel = "location", + avpValue = nonTypedGraphSON $ toJSON ("brussels" :: Text), + avpProperties = foldr putProperty mempty + [ AProperty "startTime" $ nonTypedGraphSON $ toJSON (2004 :: Int), + AProperty "endTime" $ nonTypedGraphSON $ toJSON (2005 :: Int) + ] + }, + AVertexProperty + { avpId = nonTypedGraphSON $ toJSON (9 :: Int), + avpLabel = "location", + avpValue = nonTypedGraphSON $ toJSON ("santa fe" :: Text), + avpProperties = foldr putProperty mempty + [ AProperty "startTime" $ nonTypedGraphSON $ toJSON (2005 :: Int) + ] + } + ] + } + loadGraphSON "vertex_v1.json" `shouldReturn` Right ex + let ex23 = typedGraphSON $ + AVertex + { avId = typedGraphSON' "g:Int32" $ toJSON (1 :: Int), + avLabel = "person", + avProperties = foldr putProperty mempty + [ AVertexProperty + { avpId = typedGraphSON' "g:Int64" $ toJSON (0 :: Int), + avpLabel = "name", + avpValue = nonTypedGraphSON $ toJSON ("marko" :: Text), + avpProperties = mempty + }, + AVertexProperty + { avpId = typedGraphSON' "g:Int64" $ toJSON (6 :: Int), + avpLabel = "location", + avpValue = nonTypedGraphSON $ toJSON ("san diego" :: Text), + avpProperties = foldr putProperty mempty + [ AProperty "startTime" $ typedGraphSON' "g:Int32" $ toJSON (1997 :: Int), + AProperty "endTime" $ typedGraphSON' "g:Int32" $ toJSON (2001 :: Int) + ] + }, + AVertexProperty + { avpId = typedGraphSON' "g:Int64" $ toJSON (7 :: Int), + avpLabel = "location", + avpValue = nonTypedGraphSON $ toJSON ("santa cruz" :: Text), + avpProperties = foldr putProperty mempty + [ AProperty "startTime" $ typedGraphSON' "g:Int32" $ toJSON (2001 :: Int), + AProperty "endTime" $ typedGraphSON' "g:Int32" $ toJSON (2004 :: Int) + ] + }, + AVertexProperty + { avpId = typedGraphSON' "g:Int64" $ toJSON (8 :: Int), + avpLabel = "location", + avpValue = nonTypedGraphSON $ toJSON ("brussels" :: Text), + avpProperties = foldr putProperty mempty + [ AProperty "startTime" $ typedGraphSON' "g:Int32" $ toJSON (2004 :: Int), + AProperty "endTime" $ typedGraphSON' "g:Int32" $ toJSON (2005 :: Int) + ] + }, + AVertexProperty + { avpId = typedGraphSON' "g:Int64" $ toJSON (9 :: Int), + avpLabel = "location", + avpValue = nonTypedGraphSON $ toJSON ("santa fe" :: Text), + avpProperties = foldr putProperty mempty + [ AProperty "startTime" $ typedGraphSON' "g:Int32" $ toJSON (2005 :: Int) + ] + } + ] + } + it "should parse GraphSON v2" $ do + loadGraphSON "vertex_v2.json" `shouldReturn` Right ex23 + it "should parse GraphSON v3" $ do + loadGraphSON "vertex_v3.json" `shouldReturn` Right ex23 diff --git a/test/Data/Greskell/GremlinSpec.hs b/test/Data/Greskell/GremlinSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Greskell/GremlinSpec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.Greskell.GremlinSpec (main,spec) where + +import Test.Hspec + +import Data.Greskell.Gremlin + ( pBetween, pAnd, pOr, pNegate, pWithin, pGte, pTest + ) +import Data.Greskell.Greskell (toGremlin, Greskell) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "P and Predicate" $ do + specify "P and Predicate methods" $ do + let expr = (pBetween (10 :: Greskell Int) 50 `pAnd` ((pNegate (pWithin [5, 15, 25, 35])) `pOr` pGte 20)) `pTest` 50 + toGremlin expr `shouldBe` + "((P.between(10,50)).and(((P.within(5,15,25,35)).negate()).or(P.gte(20)))).test(50)" diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF doctest-discover #-} diff --git a/test/HintTest.hs b/test/HintTest.hs new file mode 100644 --- /dev/null +++ b/test/HintTest.hs @@ -0,0 +1,76 @@ +module Main (main,spec) where + +import Data.Either (isRight) +import Language.Haskell.Interpreter + ( loadModules, OptionVal((:=)), set, searchPath, + setTopLevelModules, runInterpreter, InterpreterError, + typeOf + ) +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = spec_WalkType_classes + +spec_WalkType_classes :: Spec +spec_WalkType_classes = do + describe "Split typeclass" $ do + let c = checkSplitCompatible + c "Filter" "Filter" True + c "Filter" "Transform" True + c "Filter" "SideEffect" True + c "Transform" "Filter" True + c "Transform" "Transform" True + c "Transform" "SideEffect" True + c "SideEffect" "Filter" False + c "SideEffect" "Transform" False + c "SideEffect" "SideEffect" True + describe "Lift typeclass" $ do + let c = checkLiftCompatible + c "Filter" "Filter" True + c "Filter" "Transform" True + c "Filter" "SideEffect" True + c "Transform" "Filter" False + c "Transform" "Transform" True + c "Transform" "SideEffect" True + c "SideEffect" "Filter" False + c "SideEffect" "Transform" False + c "SideEffect" "SideEffect" True + +toErrString :: Either InterpreterError a -> Either String a +toErrString (Right a) = Right a +toErrString (Left e) = Left $ show e + +checkWalkTypeRelation :: (String -> String -> String) -> String -> String -> Bool -> Spec +checkWalkTypeRelation makeCode child parent expect_ok = specify label $ doCheck + where + label = child ++ " -> " ++ parent + doCheck = do + result <- fmap toErrString $ runInterpreter compiledParent + -- hPutStrLn stderr ("## " ++ label ++ ": " ++ show result) + isRight result `shouldBe` expect_ok + compiledParent = do + set [searchPath := ["src"]] + loadModules ["src/Data/Greskell/GTraversal.hs"] + setTopLevelModules ["Data.Greskell.GTraversal"] + typeOf $ makeCode child parent + +checkSplitCompatible :: String -> String -> Bool -> Spec +checkSplitCompatible = checkWalkTypeRelation makeCode + where + makeCode child parent = + "let f :: Walk " ++ child ++ " s s -> Walk " ++ parent ++ " s s; " + ++ "f = gFilter; " + ++ "child :: Walk " ++ child ++ " s s; " + ++ "child = undefined; " + ++ "in f child" + +checkLiftCompatible :: String -> String -> Bool -> Spec +checkLiftCompatible = checkWalkTypeRelation makeCode + where + makeCode child parent = + "let f :: Walk " ++ child ++ " s e -> Walk " ++ parent ++ " s e; " + ++ "f = liftWalk; " + ++ "in f" diff --git a/test/ServerTest.hs b/test/ServerTest.hs new file mode 100644 --- /dev/null +++ b/test/ServerTest.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main,spec) where + +import Control.Category ((<<<)) +import qualified Data.Aeson as Aeson +import Data.Either (isRight) +import Data.Monoid (mempty, (<>)) +import Data.Scientific (Scientific) +import Data.Text (unpack, Text) +import qualified Database.TinkerPop as TP +import qualified Database.TinkerPop.Types as TP (Connection) +import System.Environment (lookupEnv) +import Test.Hspec + +import Data.Greskell.Gremlin + ( oIncr, oDecr, cCompare, Order, + Predicate(..), pLt, pAnd, pGte, pNot, pEq, pTest + ) +import Data.Greskell.Greskell + ( toGremlin, Greskell, + true, false, list, value, single, number, + unsafeMethodCall + ) +import Data.Greskell.Graph + ( AVertex, T, tId, tLabel, tKey, tValue + ) +import Data.Greskell.GTraversal + ( Walk, GTraversal, + source, sV', ($.), gOrder, gBy1, + Transform, unsafeWalk, unsafeGTraversal, + gProperties + ) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = withEnv $ do + spec_basics + spec_comparator + spec_predicate + spec_T + spec_P + + +spec_basics :: SpecWith (String,Int) +spec_basics = do + ---- Note: Currently these tests do not support GraphSON 2.0 or + ---- later. Try them with GraphSON 1.0 serializer. + describe "Num" $ do + let checkInt :: Greskell Int -> Int -> SpecWith (String,Int) + checkInt = checkOne + checkInt 100 100 + checkInt (20 + 30) (20 + 30) + checkInt (10 - 3 * 6) (10 - 3 * 6) + checkInt (-99) (-99) + checkInt (abs (-53)) (abs (-53)) + checkInt (signum 0) (signum 0) + checkInt (signum 99) (signum 99) + checkInt (signum (-12)) (signum (-12)) + describe "Fractional" $ do + let checkFrac :: Greskell Scientific -> Scientific -> SpecWith (String,Int) + checkFrac = checkOne + checkFrac (20.5) (20.5) + checkFrac (20.123) (20.123) + checkFrac (32.25 / 2.5) (32.25 / 2.5) + checkFrac (19.2 * recip 12.5) (19.2 * recip 12.5) + describe "Monoid" $ do + let checkT :: Greskell Text -> Text -> SpecWith (String,Int) + checkT = checkOne + checkT mempty mempty + checkT ("hello, " <> "world!") ("hello, " <> "world!") + checkT ("!\"#$%&'()=~\\|><+*;:@{}[]/?_\r\n\t ") ("!\"#$%&'()=~\\|><+*;:@{}[]/?_\r\n\t ") + describe "Bool" $ do + let checkB :: Greskell Bool -> Bool -> SpecWith (String,Int) + checkB = checkOne + checkB true True + checkB false False + describe "list" $ do + let checkL :: Greskell [Int] -> [Int] -> SpecWith (String,Int) + checkL = checkRaw + checkL (list []) [] + checkL (list [20,30,20,10]) [20,30,20,10] + describe "number" $ do + let checkN :: Greskell Scientific -> Scientific -> SpecWith (String,Int) + checkN = checkOne + checkN (number 3.1415) (3.1415) + checkN (number 2.31e12) (2.31e12) + checkN (number (-434.23e-19)) (-434.23e-19) + describe "value (object)" $ do + let checkV :: Greskell Aeson.Value -> Aeson.Value -> SpecWith (String,Int) + checkV i e = checkRaw (single i) [e] + checkV (value $ Aeson.object []) (Aeson.object []) + + let simple_nonempty = Aeson.object [("foo", Aeson.String "hoge"), ("bar", Aeson.Number 20)] + checkV (value simple_nonempty) simple_nonempty + + let array_in_obj = Aeson.object [("foo", Aeson.toJSON [(3 :: Int), 2, 1]), ("hoge", Aeson.toJSON [("a" :: Text), "b", "c"])] + checkV (value array_in_obj) array_in_obj + +shouldReturnA :: (Aeson.ToJSON a, Show e, Eq e) => IO (Either e [Aeson.Value]) -> [a] -> IO () +shouldReturnA act expected = act `shouldReturn` Right (map Aeson.toJSON expected) + +checkRaw :: Aeson.ToJSON b => Greskell a -> [b] -> SpecWith (String, Int) +checkRaw input expected = specify label $ withConn $ \conn -> do + TP.submit conn (toGremlin input) Nothing `shouldReturnA` expected + where + label = unpack $ toGremlin input + +checkOne :: Aeson.ToJSON a => Greskell a -> a -> SpecWith (String, Int) +checkOne input expected = checkRaw input [expected] + +requireEnv :: String -> IO String +requireEnv env_key = maybe bail return =<< lookupEnv env_key + where + bail = pendingWith msg >> return "" + where + msg = "Set environment variable "++ env_key ++ " for Server test. " + +withEnv :: SpecWith (String, Int) -> Spec +withEnv = before $ do + hostname <- requireEnv "GRESKELL_TEST_HOST" + port <- fmap read $ requireEnv "GRESKELL_TEST_PORT" + return (hostname, port) + +withConn :: (TP.Connection -> IO ()) -> (String, Int) -> IO () +withConn act (host, port) = TP.run host port act + +spec_comparator :: SpecWith (String,Int) +spec_comparator = do + let oIncr' :: Greskell (Order Int) + oIncr' = oIncr + oDecr' :: Greskell (Order Int) + oDecr' = oDecr + checkOne (cCompare oIncr' 20 20) 0 + checkOne (cCompare oIncr' 10 20) (-1) + checkOne (cCompare oIncr' 20 10) 1 + checkOne (cCompare oDecr' 20 20) 0 + checkOne (cCompare oDecr' 10 20) 1 + checkOne (cCompare oDecr' 20 10) (-1) + +spec_predicate :: SpecWith (String,Int) +spec_predicate = do + checkOne (pTest (pLt 20 `pAnd` pGte 10) (5 :: Greskell Int)) False + checkOne (pTest (pLt 20 `pAnd` pGte 10) (10 :: Greskell Int)) True + checkOne (pTest (pLt 20 `pAnd` pGte 10) (15 :: Greskell Int)) True + checkOne (pTest (pLt 20 `pAnd` pGte 10) (20 :: Greskell Int)) False + +spec_T :: SpecWith (String,Int) +spec_T = describe "T enum" $ do + specFor "tId" (gMapT tId) [Aeson.Number 10] + specFor "tLabel" (gMapT tLabel) ["VLABEL"] + specFor "tKey" (gMapT tKey <<< gProperties ["vprop"]) ["vprop"] + specFor "tValue" (gMapT tValue <<< gProperties ["vprop"]) [Aeson.Number 400] + where + gMapT :: Greskell (T a b) -> Walk Transform a b + gMapT t = unsafeWalk "map" ["{ " <> toGremlin (unsafeMethodCall t "apply" ["it.get()"]) <> " }"] + specFor :: Aeson.ToJSON a => String -> Walk Transform AVertex a -> [a] -> SpecWith (String,Int) + specFor desc mapper expected = specify desc $ withConn $ \conn -> do + let prelude = + ( "graph = org.apache.tinkerpop.gremlin.tinkergraph.structure.TinkerGraph.open(); " + <> "v = graph.addVertex(id, 10, label, \"VLABEL\"); " + <> "v.property(\"vprop\", 400, \"a\", \"A\", \"b\", \"B\"); " + <> "g = graph.traversal(); " + ) + body = toGremlin $ mapper $. sV' [] $ source "g" + TP.submit conn (prelude <> body) Nothing `shouldReturnA` expected + +spec_P :: SpecWith (String,Int) +spec_P = describe "P class" $ specify "pNot, pEq, pTest" $ withConn $ \conn -> do + let p = pNot $ pEq $ number 10 + test v = toGremlin $ pTest p $ v + TP.submit conn (test $ number 10) Nothing `shouldReturnA` [False] + TP.submit conn (test $ number 15) Nothing `shouldReturnA` [True] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/graphson/edge_v1.json b/test/graphson/edge_v1.json new file mode 100644 --- /dev/null +++ b/test/graphson/edge_v1.json @@ -0,0 +1,12 @@ +{ + "id" : 13, + "label" : "develops", + "type" : "edge", + "inVLabel" : "software", + "outVLabel" : "person", + "inV" : 10, + "outV" : 1, + "properties" : { + "since" : 2009 + } +} diff --git a/test/graphson/edge_v2.json b/test/graphson/edge_v2.json new file mode 100644 --- /dev/null +++ b/test/graphson/edge_v2.json @@ -0,0 +1,26 @@ +{ + "@type" : "g:Edge", + "@value" : { + "id" : { + "@type" : "g:Int32", + "@value" : 13 + }, + "label" : "develops", + "inVLabel" : "software", + "outVLabel" : "person", + "inV" : { + "@type" : "g:Int32", + "@value" : 10 + }, + "outV" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "properties" : { + "since" : { + "@type" : "g:Int32", + "@value" : 2009 + } + } + } +} diff --git a/test/graphson/edge_v3.json b/test/graphson/edge_v3.json new file mode 100644 --- /dev/null +++ b/test/graphson/edge_v3.json @@ -0,0 +1,32 @@ +{ + "@type" : "g:Edge", + "@value" : { + "id" : { + "@type" : "g:Int32", + "@value" : 13 + }, + "label" : "develops", + "inVLabel" : "software", + "outVLabel" : "person", + "inV" : { + "@type" : "g:Int32", + "@value" : 10 + }, + "outV" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "properties" : { + "since" : { + "@type" : "g:Property", + "@value" : { + "key" : "since", + "value" : { + "@type" : "g:Int32", + "@value" : 2009 + } + } + } + } + } +} diff --git a/test/graphson/property_v1.json b/test/graphson/property_v1.json new file mode 100644 --- /dev/null +++ b/test/graphson/property_v1.json @@ -0,0 +1,4 @@ +{ + "key" : "since", + "value" : 2009 +} diff --git a/test/graphson/property_v2.json b/test/graphson/property_v2.json new file mode 100644 --- /dev/null +++ b/test/graphson/property_v2.json @@ -0,0 +1,28 @@ +{ + "@type" : "g:Property", + "@value" : { + "key" : "since", + "value" : { + "@type" : "g:Int32", + "@value" : 2009 + }, + "element" : { + "@type" : "g:Edge", + "@value" : { + "id" : { + "@type" : "g:Int32", + "@value" : 13 + }, + "label" : "develops", + "outV" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "inV" : { + "@type" : "g:Int32", + "@value" : 10 + } + } + } + } +} diff --git a/test/graphson/property_v3.json b/test/graphson/property_v3.json new file mode 100644 --- /dev/null +++ b/test/graphson/property_v3.json @@ -0,0 +1,10 @@ +{ + "@type" : "g:Property", + "@value" : { + "key" : "since", + "value" : { + "@type" : "g:Int32", + "@value" : 2009 + } + } +} diff --git a/test/graphson/vertex_property_v1.json b/test/graphson/vertex_property_v1.json new file mode 100644 --- /dev/null +++ b/test/graphson/vertex_property_v1.json @@ -0,0 +1,5 @@ +{ + "id" : 0, + "value" : "marko", + "label" : "name" +} diff --git a/test/graphson/vertex_property_v2.json b/test/graphson/vertex_property_v2.json new file mode 100644 --- /dev/null +++ b/test/graphson/vertex_property_v2.json @@ -0,0 +1,15 @@ +{ + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 0 + }, + "value" : "marko", + "vertex" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "label" : "name" + } +} diff --git a/test/graphson/vertex_property_v3.json b/test/graphson/vertex_property_v3.json new file mode 100644 --- /dev/null +++ b/test/graphson/vertex_property_v3.json @@ -0,0 +1,11 @@ +{ + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 0 + }, + "value" : "marko", + "label" : "name" + } +} diff --git a/test/graphson/vertex_v1.json b/test/graphson/vertex_v1.json new file mode 100644 --- /dev/null +++ b/test/graphson/vertex_v1.json @@ -0,0 +1,39 @@ +{ + "id" : 1, + "label" : "person", + "type" : "vertex", + "properties" : { + "name" : [ { + "id" : 0, + "value" : "marko" + } ], + "location" : [ { + "id" : 6, + "value" : "san diego", + "properties" : { + "startTime" : 1997, + "endTime" : 2001 + } + }, { + "id" : 7, + "value" : "santa cruz", + "properties" : { + "startTime" : 2001, + "endTime" : 2004 + } + }, { + "id" : 8, + "value" : "brussels", + "properties" : { + "startTime" : 2004, + "endTime" : 2005 + } + }, { + "id" : 9, + "value" : "santa fe", + "properties" : { + "startTime" : 2005 + } + } ] + } +} diff --git a/test/graphson/vertex_v2.json b/test/graphson/vertex_v2.json new file mode 100644 --- /dev/null +++ b/test/graphson/vertex_v2.json @@ -0,0 +1,120 @@ +{ + "@type" : "g:Vertex", + "@value" : { + "id" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "label" : "person", + "properties" : { + "name" : [ { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 0 + }, + "value" : "marko", + "vertex" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "label" : "name" + } + } ], + "location" : [ { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 6 + }, + "value" : "san diego", + "vertex" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "label" : "location", + "properties" : { + "startTime" : { + "@type" : "g:Int32", + "@value" : 1997 + }, + "endTime" : { + "@type" : "g:Int32", + "@value" : 2001 + } + } + } + }, { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 7 + }, + "value" : "santa cruz", + "vertex" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "label" : "location", + "properties" : { + "startTime" : { + "@type" : "g:Int32", + "@value" : 2001 + }, + "endTime" : { + "@type" : "g:Int32", + "@value" : 2004 + } + } + } + }, { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 8 + }, + "value" : "brussels", + "vertex" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "label" : "location", + "properties" : { + "startTime" : { + "@type" : "g:Int32", + "@value" : 2004 + }, + "endTime" : { + "@type" : "g:Int32", + "@value" : 2005 + } + } + } + }, { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 9 + }, + "value" : "santa fe", + "vertex" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "label" : "location", + "properties" : { + "startTime" : { + "@type" : "g:Int32", + "@value" : 2005 + } + } + } + } ] + } + } +} diff --git a/test/graphson/vertex_v3.json b/test/graphson/vertex_v3.json new file mode 100644 --- /dev/null +++ b/test/graphson/vertex_v3.json @@ -0,0 +1,100 @@ +{ + "@type" : "g:Vertex", + "@value" : { + "id" : { + "@type" : "g:Int32", + "@value" : 1 + }, + "label" : "person", + "properties" : { + "name" : [ { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 0 + }, + "value" : "marko", + "label" : "name" + } + } ], + "location" : [ { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 6 + }, + "value" : "san diego", + "label" : "location", + "properties" : { + "startTime" : { + "@type" : "g:Int32", + "@value" : 1997 + }, + "endTime" : { + "@type" : "g:Int32", + "@value" : 2001 + } + } + } + }, { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 7 + }, + "value" : "santa cruz", + "label" : "location", + "properties" : { + "startTime" : { + "@type" : "g:Int32", + "@value" : 2001 + }, + "endTime" : { + "@type" : "g:Int32", + "@value" : 2004 + } + } + } + }, { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 8 + }, + "value" : "brussels", + "label" : "location", + "properties" : { + "startTime" : { + "@type" : "g:Int32", + "@value" : 2004 + }, + "endTime" : { + "@type" : "g:Int32", + "@value" : 2005 + } + } + } + }, { + "@type" : "g:VertexProperty", + "@value" : { + "id" : { + "@type" : "g:Int64", + "@value" : 9 + }, + "value" : "santa fe", + "label" : "location", + "properties" : { + "startTime" : { + "@type" : "g:Int32", + "@value" : 2005 + } + } + } + } ] + } + } +}