packages feed

greskell (empty) → 0.1.0.0

raw patch · 30 files changed

+2977/−0 lines, 30 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, doctest, doctest-discover, gremlin-haskell, greskell, greskell-core, hint, hspec, scientific, semigroups, text, transformers, unordered-containers

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for greskell++## 0.1.0.0  -- 2018-03-12++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 <debug.ito@gmail.com>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ greskell.cabal view
@@ -0,0 +1,113 @@+name:                   greskell+version:                0.1.0.0+author:                 Toshio Ito <debug.ito@gmail.com>+maintainer:             Toshio Ito <debug.ito@gmail.com>+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
+ src/Data/Greskell.hs view
@@ -0,0 +1,23 @@+-- |+-- Module: Data.Greskell+-- Description: Haskell binding for Gremlin graph query language+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- 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
+ src/Data/Greskell/Binder.hs view
@@ -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 <debug.ito@gmail.com>+--+-- +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)
+ src/Data/Greskell/GTraversal.hs view
@@ -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 <debug.ito@gmail.com>+--+-- 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" []
+ src/Data/Greskell/Graph.hs view
@@ -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 <debug.ito@gmail.com>+--+-- 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+
+ src/Data/Greskell/Gremlin.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}+-- |+-- Module: Data.Greskell.Gremlin+-- Description: Gremlin (Groovy/Java) utility classes+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- 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"
+ test/Data/Greskell/BinderSpec.hs view
@@ -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")+                                    ]
+ test/Data/Greskell/GTraversalSpec.hs view
@@ -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))"
+ test/Data/Greskell/GraphSpec.hs view
@@ -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
+ test/Data/Greskell/GremlinSpec.hs view
@@ -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)"
+ test/DocTest.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF doctest-discover #-}
+ test/HintTest.hs view
@@ -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"
+ test/ServerTest.hs view
@@ -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]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/graphson/edge_v1.json view
@@ -0,0 +1,12 @@+{+  "id" : 13,+  "label" : "develops",+  "type" : "edge",+  "inVLabel" : "software",+  "outVLabel" : "person",+  "inV" : 10,+  "outV" : 1,+  "properties" : {+    "since" : 2009+  }+}
+ test/graphson/edge_v2.json view
@@ -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+      }+    }+  }+}
+ test/graphson/edge_v3.json view
@@ -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+          }+        }+      }+    }+  }+}
+ test/graphson/property_v1.json view
@@ -0,0 +1,4 @@+{+  "key" : "since",+  "value" : 2009+}
+ test/graphson/property_v2.json view
@@ -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+        }+      }+    }+  }+}
+ test/graphson/property_v3.json view
@@ -0,0 +1,10 @@+{+  "@type" : "g:Property",+  "@value" : {+    "key" : "since",+    "value" : {+      "@type" : "g:Int32",+      "@value" : 2009+    }+  }+}
+ test/graphson/vertex_property_v1.json view
@@ -0,0 +1,5 @@+{+  "id" : 0,+  "value" : "marko",+  "label" : "name"+}
+ test/graphson/vertex_property_v2.json view
@@ -0,0 +1,15 @@+{+  "@type" : "g:VertexProperty",+  "@value" : {+    "id" : {+      "@type" : "g:Int64",+      "@value" : 0+    },+    "value" : "marko",+    "vertex" : {+      "@type" : "g:Int32",+      "@value" : 1+    },+    "label" : "name"+  }+}
+ test/graphson/vertex_property_v3.json view
@@ -0,0 +1,11 @@+{+  "@type" : "g:VertexProperty",+  "@value" : {+    "id" : {+      "@type" : "g:Int64",+      "@value" : 0+    },+    "value" : "marko",+    "label" : "name"+  }+}
+ test/graphson/vertex_v1.json view
@@ -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+      }+    } ]+  }+}
+ test/graphson/vertex_v2.json view
@@ -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+            }+          }+        }+      } ]+    }+  }+}
+ test/graphson/vertex_v3.json view
@@ -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+            }+          }+        }+      } ]+    }+  }+}