greskell 0.2.3.1 → 1.0.0.0

raw patch · 17 files changed

+1489/−671 lines, 17 filesdep +hashabledep ~greskell-corePVP ok

version bump matches the API change (PVP)

Dependencies added: hashable

Dependency ranges changed: greskell-core

API changes (from Hackage documentation)

Files

• ChangeLog.md +80/−0
• greskell.cabal +14/−7
• src/Data/Greskell.hs +6/−1
• src/Data/Greskell/AsLabel.hs +21/−42
• src/Data/Greskell/Extra.hs +97/−12
• src/Data/Greskell/GTraversal.hs +93/−33
• src/Data/Greskell/Graph.hs +180/−304
• src/Data/Greskell/Graph/PropertyMap.hs +242/−0
• src/Data/Greskell/NonEmptyLike.hs +44/−0
• src/Data/Greskell/PMap.hs +246/−0
• test/Data/Greskell/ExtraSpec.hs +12/−2
• test/Data/Greskell/GTraversalSpec.hs +7/−4
• test/Data/Greskell/Graph/PropertyMapSpec.hs +100/−0
• test/Data/Greskell/GraphSpec.hs +16/−205
• test/Data/Greskell/PMapSpec.hs +127/−0
• test/ServerBehaviorTest.hs +67/−3
• test/ServerTest.hs +137/−58

@@ -1,5 +1,85 @@ # Revision history for greskell +## 1.0.0.0  -- 2019-12-27++* Add some test cases to server-behavior-test+* Add PMap and NonEmptyLike modules.++### Data.Greskell module++* Export PMap module.++### Graph module - Element class and ElementID++* [BREAKING CHANGE] Now `ElementID` is a newtype for `GValue`. It was+  an associated type family in `Element` class. However, I think there+  was no point to make it polymorphic.+* [BREAKING CHANGE] Remove `EdgeVertexID` type family from `Edge` class.+* [BREAKING CHANGE] Add `ElementData` class, and set it as a super class of `Element`.+* [BREAKING CHANGE] Type of the ID field for `AVertex`, `AEdge` and+  `AVertexProperty` is now `ElementID`, not `GValue`.+* Add `unsafeCastElementID` function.+* Add `ElementPropertyContainer` type family to `Element` class. It's+  necessary for `gValueMap` traversal.++### Graph module - "reference" model for graph element types++Now the graph element types don't contain properties. They only have+their ID and label (and the value if it's a VertexProperty). This is+because some graph implementation of TinkerPop don't return properties+when it returns graph elements. See #6.++* [BREAKING CHANGE] Remove `avProperties` field from `AVertex`.+* [BREAKING CHANGE] Remove `aeInVLabel`, `aeOutVLabel`, `aeInV`,+  `aeOutV` and `aeProperties` fields from `AEdge`.+* [BREAKING CHANGE] Remove `avpProperties` field from `AVertexProperty`.+* [BREAKING CHANGE] Move `PropertyMap` class, `FromGraphSONWithKey`+  class, `PropertyMapSingle` type, `PropertyMapList` types and related+  functions to `Graph.PropertyMap` module. They are now all+  deprecated. Use `PMap` module instead.++### Graph module - Key for element property++* [BREAKING CHANGE] Internal of `Key` is modified from `Greskell Text`+  to `Text`, so that it can be an instance of `PMapKey` class.+* [BREAKING CHANGE] Add `KeyNoValue` data constructor for `KeyValue`+  type.+* Add `unsafeCastKey` function.+* Add `Keys` type and related functions.++### GTraversal module++* [BREAKING CHANGE] Change the signature of the following functions+  because now `ElementID` is a newtype, not a type alias.+    * `sV'`+    * `gV'`+    * `sE'`+* Add `gValueMap`, `gProject` and `gByL` functions.+* Add `LabeledByProjection` type.+* Add `unsafeCastStart` and `unsafeCastEnd` functions to `ToGTraversal` class.++### Extra module++* [BREAKING CHANGE] Remove `writeAllProperties` because `PropertyMap`+  is deprecated.+* Add `writeKeyValues` function.+* Add `writePMapProperties` function.+* Add `(<=:>)` and `(<=?>)` operators.+* Re-export property reader functions such as `lookupAs`.++### AsLabel module++* Now `SelectedMap` is a specialized type alias for `PMap`.+* [BREAKING CHANGE] `lookup`, `lookupM`, `lookupAs` and `lookupAsM`+  are now re-exports from `PMap` module, whose signature is more+  polymorphic than the original ones and have a different exception+  type.+* [BREAKING CHANGE] `AsLookupException` is removed. Use+  `PMapLookupException` instead.+* Make `AsLabel` an instance of `PMapKey`.+* Add `IsString` instance to `AsLabel`.++ ## 0.2.3.1  -- 2019-10-02  * Confirm test with `semigroups-0.19.1`.

@@ -1,5 +1,5 @@ name:                   greskell-version:                0.2.3.1+version:                1.0.0.0 author:                 Toshio Ito <debug.ito@gmail.com> maintainer:             Toshio Ito <debug.ito@gmail.com> license:                BSD3@@ -26,30 +26,34 @@   -- default-extensions:      other-extensions:     OverloadedStrings, GeneralizedNewtypeDeriving,                         FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeFamilies,-                        GADTs, DeriveTraversable+                        GADTs, DeriveTraversable, DeriveGeneric   exposed-modules:      Data.Greskell,                         Data.Greskell.Gremlin,                         Data.Greskell.Binder,                         Data.Greskell.Graph,+                        Data.Greskell.Graph.PropertyMap,                         Data.Greskell.GTraversal,                         Data.Greskell.AsLabel,-                        Data.Greskell.Extra+                        Data.Greskell.Extra,+                        Data.Greskell.PMap,+                        Data.Greskell.NonEmptyLike   -- other-modules:           build-depends:        base >=4.9.0.0 && <4.13,-                        greskell-core >=0.1.2.0 && <0.2,+                        greskell-core >=0.1.3.0 && <0.2,                         text >=1.2.2.1 && <1.3,                         transformers >=0.5.2 && <0.6,                         aeson >=0.11.2.1 && <1.5,                         unordered-containers >=0.2.7.1 && <0.3,                         semigroups >=0.18.2 && <0.20,                         vector >=0.12.0.1 && <0.13,-                        exceptions >=0.8.3 && <0.11+                        exceptions >=0.8.3 && <0.11,+                        hashable >=1.2.7.0 && <1.4  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"+  ghc-options:          -Wall -fno-warn-unused-imports -fno-warn-deprecations "-with-rtsopts=-M512m"   main-is:              Spec.hs   -- default-extensions:      other-extensions:     OverloadedStrings@@ -57,7 +61,9 @@                         Data.Greskell.GTraversalSpec,                         Data.Greskell.GremlinSpec,                         Data.Greskell.GraphSpec,-                        Data.Greskell.ExtraSpec+                        Data.Greskell.Graph.PropertyMapSpec,+                        Data.Greskell.ExtraSpec,+                        Data.Greskell.PMapSpec   build-depends:        base, text, aeson,  unordered-containers,                         greskell, greskell-core,                         hspec >=2.2.3,@@ -120,6 +126,7 @@  flag server-behavior-test   description: Tests about the behavior of Gremlin Server, rather than greskell.+               Note that this test clears the content of the Gremlin Server.   default: False   manual: True 

@@ -10,6 +10,9 @@ -- packages. The following modules are excluded from re-export: -- -- - "Data.Greskell.Extra": extra utility functions.+-- - "Data.Greskell.NonEmptyLike": NonEmptyLike class, which is a+--   class of non-empty containers.+-- - "Data.Greskell.Graph.PropertyMap": deprecated PropertyMap class. module Data.Greskell        (          module Data.Greskell.Greskell,@@ -20,7 +23,8 @@          module Data.Greskell.GraphSON,          module Data.Greskell.GMap,          module Data.Greskell.AsIterator,-         module Data.Greskell.AsLabel+         module Data.Greskell.AsLabel,+         module Data.Greskell.PMap        ) where  import Data.Greskell.Greskell@@ -32,3 +36,4 @@ import Data.Greskell.GMap import Data.Greskell.AsIterator import Data.Greskell.AsLabel+import Data.Greskell.PMap

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, GeneralizedNewtypeDeriving, DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-} -- | -- Module: Data.Greskell.AsLabel -- Description: Label string used in .as step@@ -6,13 +6,15 @@ -- -- @since 0.2.2.0 module Data.Greskell.AsLabel-       ( AsLabel(..),+       ( -- * AsLabel+         AsLabel(..),          SelectedMap,+         -- * Re-exports          lookup,          lookupM,          lookupAs,          lookupAsM,-         AsLookupException(..)+         PMapLookupException(..)        ) where  import Prelude hiding (lookup)@@ -25,14 +27,24 @@ import Data.Greskell.GraphSON (GValue, GraphSONTyped(..), FromGraphSON(..), parseEither) import Data.Greskell.Greskell (ToGreskell(..)) import qualified Data.Greskell.Greskell as Greskell+import Data.String (IsString(..)) import Data.Text (Text) import Data.Traversable (Traversable) +import Data.Greskell.PMap+  ( PMap, PMapKey(..), Single,+    lookup, lookupM, lookupAs, lookupAsM, PMapLookupException(..)+  )+ -- | 'AsLabel' @a@ represents a label string used in @.as@ step -- pointing to the data of type @a@. newtype AsLabel a = AsLabel { unAsLabel :: Text }                deriving (Show,Eq,Ord) +-- | @since 1.0.0.0+instance IsString (AsLabel a) where+  fromString = AsLabel . fromString+ -- | Returns the 'Text' as a Gremlin string. instance ToGreskell (AsLabel a) where   type GreskellReturn (AsLabel a) = Text@@ -42,45 +54,12 @@ instance Functor AsLabel where   fmap _ (AsLabel t) = AsLabel t +-- | @since 1.0.0.0+instance PMapKey (AsLabel a) where+  type PMapValue (AsLabel a) = a+  keyText = unAsLabel+ -- | A map keyed with 'AsLabel'. Obtained from @.select@ step, for -- example.-newtype SelectedMap a = SelectedMap (HashMap Text a)-                    deriving (Show,Eq,Functor,Foldable,Traversable)--instance GraphSONTyped (SelectedMap a) where-  gsonTypeFor _ = "g:Map"--instance FromGraphSON a => FromGraphSON (SelectedMap a) where-  parseGraphSON gv = fmap SelectedMap $ parseGraphSON gv---- | An 'Exception' raised by 'lookupM' and 'lookupAsM'.-data AsLookupException = NoSuchAsLabel-                         -- ^ The 'SelectedMap' does not have the-                         -- given 'AsLabel' as the key.-                       | ParseError String-                         -- ^ Failed to parse the value into the type-                         -- that the 'AsLabel' indicates. The 'String'-                         -- is the error message.-                       deriving (Show,Eq,Ord)--instance Exception AsLookupException---- | Get value from 'SelectedMap'.-lookup :: AsLabel a -> SelectedMap b -> Maybe b-lookup (AsLabel l) (SelectedMap m) = HM.lookup l m---- | 'MonadThrow' version of 'lookup'. If there is no value for the--- 'AsLabel', it throws 'NoSuchAsLabel'.-lookupM :: MonadThrow m => AsLabel a -> SelectedMap b -> m b-lookupM l m = maybe (throwM NoSuchAsLabel) return $ lookup l m---- | Get value from 'SelectedMap' and parse the value into @a@.-lookupAs :: FromGraphSON a => AsLabel a -> SelectedMap GValue -> Either AsLookupException a-lookupAs l m =-  case lookup l m of-   Nothing -> Left NoSuchAsLabel-   Just gv -> either (Left . ParseError) Right $ parseEither gv+type SelectedMap = PMap Single --- | 'MonadThrow' version of 'lookupAs'.-lookupAsM :: (MonadThrow m, FromGraphSON a) => AsLabel a -> SelectedMap GValue -> m a-lookupAsM l m = either throwM return $ lookupAs l m

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | -- Module: Data.Greskell.Extra -- Description: Extra utility functions implemented by Greskell@@ -7,35 +8,119 @@ -- -- @since 0.2.3.0 module Data.Greskell.Extra-  ( writePropertyKeyValues,-    writeAllProperties+  ( -- * Property readers+    -- $readers+    lookupAs,+    lookupAs',+    lookupListAs,+    lookupListAs',+    pMapToFail,+    -- * Property writers+    writeKeyValues,+    (<=:>),+    (<=?>),+    writePropertyKeyValues,+    writePMapProperties   ) where  import Data.Aeson (ToJSON)+import Data.Foldable (Foldable) import Data.Greskell.Binder (Binder, newBind) import Data.Greskell.Graph-  ( PropertyMap(..), Property(..), Element+  ( Property(..), Element, KeyValue(..), (=:), Key   ) import qualified Data.Greskell.Graph as Graph import Data.Greskell.GTraversal (Walk, SideEffect, gProperty)+import Data.Greskell.PMap+  ( PMap, pMapToList,+    lookupAs,+    lookupAs',+    lookupListAs,+    lookupListAs',+    pMapToFail+  ) import Data.Monoid (mconcat) import Data.Text (Text) +-- $setup+--+-- >>> :set -XOverloadedStrings+-- >>> import Data.Greskell.Binder (runBinder)+-- >>> import Data.Greskell.Greskell (toGremlin)+-- >>> import Data.Greskell.Graph (AVertex)+-- >>> import Data.List (sortBy)+-- >>> import Data.Ord (comparing)+-- >>> import qualified Data.HashMap.Strict as HashMap++-- $readers+--+-- Re-export property readers.+--+-- @since 1.0.0.0+ -- | Make a series of @.property@ steps to write the given key-value -- pairs as properties. -- -- @since 0.2.3.0+--+-- >>> let binder = (writePropertyKeyValues [("age", (21 :: Int))] :: Binder (Walk SideEffect AVertex AVertex))+-- >>> let (walk, binding) = runBinder binder+-- >>> toGremlin walk+-- "__.property(\"age\",__v0).identity()"+-- >>> sortBy (comparing fst) $ HashMap.toList binding+-- [("__v0",Number 21.0)] writePropertyKeyValues :: (ToJSON v, Element e) => [(Text, v)] -> Binder (Walk SideEffect e e)-writePropertyKeyValues pairs = fmap mconcat $ mapM toPropStep pairs+writePropertyKeyValues pairs = fmap writeKeyValues $ mapM toKeyValue pairs   where-    toPropStep (key, value) = fmap (gProperty $ Graph.key key) $ newBind value+    toKeyValue (key, value) = Graph.key key <=:> value --- | Make a series of @.property@ steps to write all properties in the--- given 'PropertyMap'.+-- | Make a series of @.property@ steps to write the given key-value+-- pairs as properties. Use '<=:>' and '<=?>' to make a 'KeyValue'+-- within 'Binder'. ----- @since 0.2.3.0-writeAllProperties :: (PropertyMap m, Property p, ToJSON v, Element e)-                   => m p v -> Binder (Walk SideEffect e e)-writeAllProperties ps = writePropertyKeyValues $ map toPair $ allProperties ps+-- >>> let keyAge = ("age" :: Key AVertex Int)+-- >>> let keyName = ("name" :: Key AVertex Text)+-- >>> let (walk, binding) = runBinder $ writeKeyValues <$> sequence [keyAge <=:> 21, keyName <=:> "Josh"]+-- >>> toGremlin walk+-- "__.property(\"age\",__v0).property(\"name\",__v1).identity()"+-- >>> sortBy (comparing fst) $ HashMap.toList binding+-- [("__v0",Number 21.0),("__v1",String "Josh")]+--+-- @since 1.0.0.0+writeKeyValues :: Element e => [KeyValue e] -> Walk SideEffect e e+writeKeyValues pairs = mconcat $ toPropStep =<< pairs   where-    toPair prop = (propertyKey prop, propertyValue prop)+    toPropStep (KeyValue k v) = [gProperty k v]+    toPropStep (KeyNoValue _) = []++-- | Make a series of @.property@ steps to write all properties in the+-- given 'PMap'.+--+-- @since 1.0.0.0+writePMapProperties :: (Foldable c, ToJSON v, Element e)+                    => PMap c v -> Binder (Walk SideEffect e e)+writePMapProperties = writePropertyKeyValues . pMapToList++-- | Like '=:', but this one takes a real value, binds it into a+-- 'Greskell' value and returns 'KeyValue'.+--+-- @since 1.0.0.0+(<=:>) :: ToJSON b => Key a b -> b -> Binder (KeyValue a)+(<=:>) k v = (=:) k <$> newBind v++-- | Like '<=:>', but this one is for an optional property. If the+-- value is 'Just', it's equivalent to '<=:>'. If the value is+-- 'Nothing', it returns 'KeyNoValue'.+--+-- >>> let keyNName = ("nickname" :: Key AVertex (Maybe Text))+-- >>> let keyCompany = ("company" :: Key AVertex (Maybe Text))+-- >>> let (walk, binding) = runBinder $ writeKeyValues <$> sequence [keyNName <=?> Nothing, keyCompany <=?> Just "foobar.com"]+-- >>> toGremlin walk+-- "__.property(\"company\",__v0).identity()"+-- >>> sortBy (comparing fst) $ HashMap.toList binding+-- [("__v0",String "foobar.com")]+--+-- @since 1.0.0.0+(<=?>) :: ToJSON b => Key a (Maybe b) -> Maybe b -> Binder (KeyValue a)+(<=?>) k v@(Just _) = k <=:> v+(<=?>) k Nothing = return $ KeyNoValue k

@@ -102,10 +102,12 @@          gProperties,          gId,          gLabel,+         gValueMap,          gSelect1,          gSelectN,          gSelectBy1,          gSelectByN,+         gProject,          -- ** Summarizing steps          gFold,          gCount,@@ -144,9 +146,11 @@          ByProjection(..),          ProjectionLike(..),          ByComparator(..),+         LabeledByProjection(..),          gBy,          gBy1,-         gBy2+         gBy2,+         gByL        ) where  import Control.Applicative ((<$>), (<*>))@@ -155,6 +159,7 @@ import qualified Control.Category as Category import Data.Aeson (Value) import Data.Bifunctor (Bifunctor(bimap))+import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid ((<>), mconcat, Monoid(..)) import Data.Semigroup (Semigroup, sconcat)@@ -165,12 +170,12 @@ import qualified Data.Text.Lazy as TL  import Data.Greskell.Graph-  ( Element(..), Vertex, Edge, Property(..),-    AVertex, AEdge,+  ( Element(..), Property(..), ElementID(..), Vertex, Edge,+    AVertex, AEdge, AVertexProperty,     T, Key, Cardinality,-    KeyValue(..)+    KeyValue(..), Keys(..)   )-import Data.Greskell.GraphSON (GValue)+import Data.Greskell.GraphSON (GValue, FromGraphSON) import Data.Greskell.Gremlin   ( Comparator(..),     P@@ -181,6 +186,7 @@   ) import Data.Greskell.AsIterator (AsIterator(IteratorItem)) import Data.Greskell.AsLabel (AsLabel, SelectedMap)+import Data.Greskell.PMap (PMap, Single)  -- $setup --@@ -188,7 +194,7 @@ -- >>> import Data.Function ((&)) -- >>> import Data.Greskell.Greskell (gvalueInt) -- >>> import Data.Greskell.Gremlin (pBetween, pEq, pLte, oDecr, oIncr)--- >>> import Data.Greskell.Graph (tId, cList, (=:), AVertex, AVertexProperty)+-- >>> import Data.Greskell.Graph (tId, cList, (=:), AVertex, AVertexProperty, (-:)) -- >>> import Data.Greskell.GraphSON (GValueBody(..))  -- | @GraphTraversal@ class object of TinkerPop. It takes data @s@@@ -237,11 +243,27 @@   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.+  +  unsafeCastStart :: WalkType c => g c s1 e -> g c s2 e+  -- ^ Unsafely cast the start type @s1@ into @s2@.+  --+  -- It is recommended that @s2@ is coercible to @s1@ in terms of+  -- 'FromGraphSON'. That is, if @s2@ can parse a 'GValue', @s1@+  -- should also be able to parse that 'GValue'.+  --+  -- @since 1.0.0.0 +  unsafeCastEnd :: WalkType c => g c s e1 -> g c s e2+  -- ^ Unsafely cast the end type @e1@ into @e2@. See+  -- 'unsafeCastStart'.+  --+  -- @since 1.0.0.0+ instance ToGTraversal GTraversal where   toGTraversal = id   liftWalk (GTraversal g) = GTraversal $ unsafeGreskellLazy $ toGremlinLazy g-+  unsafeCastStart (GTraversal g) = GTraversal $ unsafeGreskellLazy $ toGremlinLazy g+  unsafeCastEnd (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@@ -288,6 +310,8 @@ instance ToGTraversal Walk where   toGTraversal (Walk t) = GTraversal $ unsafeGreskellLazy ("__" <> t)   liftWalk (Walk t) = Walk t+  unsafeCastStart (Walk t) = Walk t+  unsafeCastEnd (Walk t) = Walk t  -- | The 'Walk' is first converted to 'GTraversal', and it's converted -- to 'Greskell'.@@ -398,9 +422,9 @@  -- | Monomorphic version of 'sV'. ----- >>> toGremlin (source "g" & sV' (map gvalueInt ([1,2,3] :: [Int])))+-- >>> toGremlin (source "g" & sV' (map (fmap ElementID . gvalueInt) ([1,2,3] :: [Int]))) -- "g.V(1,2,3)"-sV' :: [Greskell GValue]+sV' :: [Greskell (ElementID AVertex)] -- ^ vertex IDs     -> Greskell GraphTraversalSource     -> GTraversal Transform () AVertex sV' = sV@@ -414,11 +438,11 @@  -- | Monomorphic version of 'sE'. ----- >>> toGremlin (source "g" & sE' (map gvalueInt ([1] :: [Int])))+-- >>> toGremlin (source "g" & sE' (map (fmap ElementID . gvalueInt) ([1] :: [Int]))) -- "g.E(1)"-sE' :: [Greskell GValue]-       -> Greskell GraphTraversalSource-       -> GTraversal Transform () AEdge+sE' :: [Greskell (ElementID AEdge)] -- ^ edge IDs+    -> Greskell GraphTraversalSource+    -> GTraversal Transform () AEdge sE' = sE  -- | @.addV()@ method on 'GraphTraversalSource'.@@ -529,12 +553,6 @@ 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")@@ -603,7 +621,7 @@  -- | @.hasId@ step. ----- >>> toGremlin (source "g" & sV' [] &. gHasId (gvalueInt $ (7 :: Int)))+-- >>> toGremlin (source "g" & sV' [] &. gHasId (fmap ElementID $ gvalueInt $ (7 :: Int))) -- "g.V().hasId(7)" gHasId :: (Element s, WalkType c) => Greskell (ElementID s) -> Walk c s s gHasId = liftWalk . gHasId'@@ -614,7 +632,7 @@  -- | @.hasId@ step with 'P' type. Supported since TinkerPop 3.2.7. ----- >>> toGremlin (source "g" & sV' [] &. gHasIdP (pLte $ gvalueInt (100 :: Int)))+-- >>> toGremlin (source "g" & sV' [] &. gHasIdP (pLte $ fmap ElementID $ gvalueInt (100 :: Int))) -- "g.V().hasId(P.lte(100))" gHasIdP :: (Element s, WalkType c)         => Greskell (P (ElementID s))@@ -850,6 +868,19 @@       ByComparatorComp comp -> [toGremlin comp]       ByComparatorProjComp (ByProjection p) comp -> [toGremlin p, toGremlin comp] +-- | A 'ByProjection' associated with an 'AsLabel'. You can construct+-- it by 'gByL'.+--+-- @since 1.0.0.0+data LabeledByProjection s where+  LabeledByProjection :: AsLabel a -> ByProjection s a -> LabeledByProjection s++-- | @.by@ step associated with an 'AsLabel'.+--+-- @since 1.0.0.0+gByL :: (ProjectionLike p, ToGreskell p) => AsLabel (ProjectionLikeEnd p) -> p -> LabeledByProjection (ProjectionLikeStart p)+gByL l p = LabeledByProjection l $ gBy p+ -- | @.flatMap@ step. -- -- @.flatMap@ step is a 'Transform' step even if the child walk is@@ -880,7 +911,7 @@ -- | Monomorphic version of 'gV'. -- -- @since 0.2.0.0-gV' :: [Greskell GValue] -> Walk Transform s AVertex+gV' :: [Greskell (ElementID AVertex)] -> Walk Transform s AVertex gV' = gV  -- | @.as@ step.@@ -923,6 +954,22 @@ gLabel :: Element s => Walk Transform s Text gLabel = unsafeWalk "label" [] +-- | @.valueMap@ step.+--+-- >>> toGremlin (source "g" & sV' [] &. gValueMap KeysNil)+-- "g.V().valueMap()"+-- >>> toGremlin (source "g" & sV' [] &. gValueMap ("name" -: "age" -: KeysNil))+-- "g.V().valueMap(\"name\",\"age\")"+--+-- @since 1.0.0.0+gValueMap :: Element s+          => Keys s+          -> Walk Transform s (PMap (ElementPropertyContainer s) GValue)+gValueMap keys = unsafeWalk "valueMap" $ toGremlinKeys keys+  where+    toGremlinKeys KeysNil = []+    toGremlinKeys (KeysCons k rest) = toGremlin k : toGremlinKeys rest+ -- | @.select@ step with one argument. -- -- @since 0.2.2.0@@ -954,6 +1001,24 @@ gSelectByN :: AsLabel a -> AsLabel a -> [AsLabel a] -> ByProjection a b -> Walk Transform s (SelectedMap b) gSelectByN l1 l2 ls bp = modulateWith (unsafeChangeEnd $ gSelectN l1 l2 ls) [byStep bp] +-- | @.project@ step.+--+-- >>> let name_label = ("a" :: AsLabel Text)+-- >>> let name_key = ("name" :: Key AVertex Text)+-- >>> let count_label = ("b" :: AsLabel Int)+-- >>> toGremlin (source "g" & sV' [] &. gProject (gByL name_label name_key) [gByL count_label (gOut' [] >>> gCount), gByL "c" tId])+-- "g.V().project(\"a\",\"b\",\"c\").by(\"name\").by(__.out().count()).by(T.id)"+--+-- @since 1.0.0.0+gProject :: LabeledByProjection s -> [LabeledByProjection s] -> Walk Transform s (PMap Single GValue)+gProject lp_head lps = foldl' f (unsafeWalk "project" labels) (lp_head : lps)+  where+    labels = map toLabelGremlin (lp_head : lps)+    toLabelGremlin (LabeledByProjection l _) = toGremlin l+    f acc lp = acc >>> toByStep lp+    toByStep :: LabeledByProjection s -> Walk Transform a a+    toByStep (LabeledByProjection _ (ByProjection p)) = unsafeWalk "by" [toGremlin p]+ -- | @.fold@ step. gFold :: Walk Transform a [a] gFold = unsafeWalk "fold" []@@ -973,10 +1038,10 @@  -- | Monomorphic version of 'gOut'. ----- >>> toGremlin (source "g" & sV' [gvalueInt (8 :: Int)] &. gOut' ["knows"])+-- >>> toGremlin (source "g" & sV' [fmap ElementID $ gvalueInt (8 :: Int)] &. gOut' ["knows"]) -- "g.V(8).out(\"knows\")" gOut' :: (Vertex v)-      => [Greskell Text]+      => [Greskell Text] -- ^ edge labels       -> Walk Transform v AVertex gOut' = gOut @@ -986,7 +1051,7 @@       -> Walk Transform v e gOutE = genericTraversalWalk "outE" --- | Monomorphic version of 'gOutE'+-- | Monomorphic version of 'gOutE'. gOutE' :: (Vertex v)        => [Greskell Text]        -> Walk Transform v AEdge@@ -1052,12 +1117,6 @@ 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]@@ -1080,7 +1139,7 @@ gDropP :: Property p => Walk SideEffect (p a) (p a) gDropP = unsafeWalk "drop" [] --- | simple @.property@ step. It adds a value to the property.+-- | Simple @.property@ step. It adds a value to the property. -- -- >>> toGremlin (source "g" & sV' [] & liftWalk &. gProperty "age" (20 :: Greskell Int)) -- "g.V().property(\"age\",20)"@@ -1114,6 +1173,7 @@     arg_metaprops = expand =<< metaprops       where         expand (KeyValue meta_key meta_val) = [toGremlin meta_key, toGremlin meta_val]+        expand (KeyNoValue _) = []  -- | Vertex anchor for 'gAddE'. It corresponds to @.from@ or @.to@ -- step following an @.addE@ step.@@ -1155,7 +1215,7 @@       -> Walk SideEffect vs e gAddE label anch = (unsafeWalk "addE" [toGremlin label]) >>> anchorStep anch --- | Monomorphic version of 'gAddE'+-- | Monomorphic version of 'gAddE'. --  -- @since 0.2.0.0 gAddE' :: Greskell Text -> AddAnchor AVertex AVertex -> Walk SideEffect AVertex AEdge

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveTraversable, GADTs #-}+{-# LANGUAGE TypeFamilies, OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveTraversable, GADTs, DeriveGeneric #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- | -- Module: Data.Greskell.Graph@@ -8,10 +8,14 @@ -- This module defines types and functions about TinkerPop graph -- structure API. module Data.Greskell.Graph-       ( -- * TinkerPop graph structure types+       ( -- * Element          Element(..),+         ElementData(..),+         ElementID(..),+         unsafeCastElementID,          Vertex,-         Edge(..),+         Edge,+         -- * Property          Property(..),          -- * T Enum          T,@@ -24,12 +28,19 @@          cList,          cSet,          cSingle,+          -- * Typed Key (accessor of a Property)          Key(..),          key,-         -- ** key-value pair+         unsafeCastKey,+         -- ** Key-value pair          KeyValue(..),          (=:),+         -- ** Heterogeneous list of keys+         Keys(..),+         singletonKeys,+         (-:),+          -- * Concrete data types          -- $concrete_types          @@ -40,36 +51,26 @@          -- ** VertexProperty          AVertexProperty(..),          -- ** Property-         AProperty(..),-         -- ** PropertyMap-         PropertyMap(..),-         PropertyMapSingle,-         PropertyMapList,-         lookupOneValue,-         lookupListValues,-         parseOneValue,-         parseListValues,-         parseNonEmptyValues,-         fromProperties,-         -- * Internal use-         FromGraphSONWithKey+         AProperty(..)        ) where  import Control.Applicative (empty, (<$>), (<*>), (<|>))-import Data.Aeson (Value(..), FromJSON(..))+import Data.Aeson (Value(..), FromJSON(..), ToJSON(..)) import Data.Aeson.Types (Parser) import Data.Foldable (toList, Foldable(foldr), foldlM)+import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HM import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NL import Data.Maybe (listToMaybe)-import Data.Monoid (Monoid)+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.Vector (Vector)+import GHC.Generics (Generic)  import Data.Greskell.GraphSON   ( GraphSON(..), GraphSONTyped(..), FromGraphSON(..),@@ -81,42 +82,75 @@   ( Greskell, unsafeGreskellLazy, string,     ToGreskell(..)   )+import Data.Greskell.NonEmptyLike (NonEmptyLike)+import Data.Greskell.PMap (PMapKey(..), Single, Multi)  -- $setup -- -- >>> import Data.Greskell.Greskell (toGremlin) +-- | ID of a graph element @e@ (vertex, edge and vertex property).+--+-- @since 1.0.0.0+newtype ElementID e =+  ElementID+  { unElementID :: GValue+    -- ^ Although it's exposed, it is recommended NOT to rely on the+    -- internal of 'ElementID'. That's because it depends on graph+    -- implementation.+  }+                    deriving (Show,Eq,Generic, ToJSON, FromJSON, FromGraphSON, Hashable) +-- | Unsafely convert the element type.+instance Functor ElementID where+  fmap _ e = unsafeCastElementID e++-- | Unsafely cast the phantom type of 'ElementID'.+--+-- @since 1.0.0.0+unsafeCastElementID :: ElementID a -> ElementID b+unsafeCastElementID (ElementID e) = ElementID e++-- | Types that keep reference to TinkerPop graph Elements.+--+-- @since 1.0.0.0+class ElementData e where+  -- | ID of this Element.+  elementId :: e -> ElementID e+  -- | Label of this Element.+  elementLabel :: e -> Text+ -- | @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.+--+-- Since greskell-1.0.0.0, 'ElementData' is a super-class of+-- 'Element'.+class ElementData e => Element e where+  -- | Property type of the 'Element'. It should be of 'Property'+  -- class.   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. +  -- | Container type of the properties of the 'Element'. It should be+  -- of 'NonEmptyLike' class.+  --+  -- @since 1.0.0.0+  type ElementPropertyContainer e :: * -> *+ -- | @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.-+class (Element e) => Edge e  -- | @org.apache.tinkerpop.gremlin.structure.Property@ interface in a -- TinkerPop graph. class Property p where+  -- | Get key of this property.   propertyKey :: p v -> Text-  -- ^ Get key of this property.+  -- | Get value of this property.   propertyValue :: p v -> v-  -- ^ Get value of this property.  -- | @org.apache.tinkerpop.gremlin.structure.T@ enum. --@@ -182,28 +216,48 @@  -- | 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 }+--+-- >>> toGremlin ("age" :: Key AVertex Int)+-- "\"age\""+-- >>> toGremlin (key "created_at" :: Key AEdge Text)+-- "\"created_at\""+-- >>> keyText ("name" :: Key AVertex Text)+-- "name"+--+-- Since greskell-1.0.0.0, 'Key' is newtype of 'Text'. Before that, it+-- was newtype of 'Greskell' 'Text'.+newtype Key a b = Key { unKey :: 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.+-- | Return Gremlin String literal. instance ToGreskell (Key a b) where   type GreskellReturn (Key a b) = Text-  toGreskell = unKey+  toGreskell = string . unKey --- | Create a 'Key' from a literal string.+-- | @since 1.0.0.0+instance PMapKey (Key a b) where+  type PMapValue (Key a b) = b+  keyText (Key t) = t++-- | Create a 'Key' a text. key :: Text -> Key a b-key = Key . string+key = Key +-- | Unsafely cast the type signature of the 'Key'.+--+-- @since 1.0.0.0+unsafeCastKey :: Key a1 b1 -> Key a2 b2+unsafeCastKey = Key . unKey --- | Pair of 'Key' and its value.+-- | Pair of 'Key' and its value. Mainly used for writing properties+-- into the database. -- -- Type @a@ is the type of 'Element' that keeps the 'KeyValue' -- pair. It drops the type of the value, so that you can construct a@@ -211,7 +265,12 @@ -- -- @since 0.2.0.0 data KeyValue a where+  -- | Key and value   KeyValue :: Key a b -> Greskell b -> KeyValue a+  -- | Key without value+  --+  -- @since 1.0.0.0+  KeyNoValue :: Key a b -> KeyValue a  -- | Constructor operator of 'KeyValue'. --@@ -219,43 +278,75 @@ (=:) :: Key a b -> Greskell b -> KeyValue a (=:) = KeyValue --- $concrete_types--- Concrete data types based on Aeson data types.+-- | Heterogeneous list of 'Key's. It keeps the parent type @a@, but+-- discards the value type @b@. ----- Element IDs and property values are all 'GValue', because they are--- highly polymorphic. 'ElementID' and 'EdgeVertexID' are 'GValue',--- too.+-- @since 1.0.0.0+data Keys a where+  -- | Empty 'Keys'.+  KeysNil :: Keys a+  -- | Add a 'Key' to 'Keys'.+  KeysCons :: Key a b -> Keys a -> Keys a++instance Semigroup (Keys a) where+  a <> b =+    case a of+      KeysNil -> b+      KeysCons x rest -> KeysCons x (rest <> b)++instance Monoid (Keys a) where+  mempty = KeysNil+  mappend = (<>)++-- | 'Keys' with a single 'Key'. ----- As for properties, you can use 'PropertyMap' and other type-classes--- to manipulate them.+-- @since 1.0.0.0+singletonKeys :: Key a b -> Keys a+singletonKeys k = KeysCons k KeysNil++-- | Prepend a 'Key' to 'Keys'. ----- If you want to define your own graph structure types, see+-- @since 1.0.0.0+(-:) :: Key a b -> Keys a -> Keys a+(-:) = KeysCons++infixr 5 -:++-- $concrete_types+-- Graph structure data types based on Aeson.+--+-- You can use those types directly in your programs. You can also+-- define your own graph types by wrapping those with @newtype@. See -- [README.md](https://github.com/debug-ito/greskell#make-your-own-graph-structure-types)--- for detail. Basically you can use 'FromGraphSON' instances of these--- concrete data types to implement parsers for your own types.+-- for detail. ----- NOTE: In version 0.1.1.0 and before, these conrete data types were--- based on @GraphSON Value@. In version 0.2.0.0, this was changed to--- 'GValue', so that it can parse nested data structures encoded in--- GraphSON.-+-- Historical note:+--+-- - Since version 1.0.0.0, the concrete data types don't keep+--   properties, and IDs are of 'ElementID' type.+-- - In version 0.1.1.0 and before, these conrete data types were+--   based on @GraphSON Value@. In version 0.2.0.0, this was changed to+--   'GValue', so that it can parse nested data structures encoded in+--   GraphSON. --- | General vertex type you can use for 'Vertex' class, based on--- Aeson data types.+-- | General vertex type you can use for 'Vertex' class. data AVertex =   AVertex-  { avId :: GValue,+  { avId :: ElementID AVertex,     -- ^ ID of this vertex-    avLabel :: Text,+    avLabel :: Text     -- ^ Label of this vertex-    avProperties :: PropertyMapList AVertexProperty GValue-    -- ^ Properties of this vertex.   }   deriving (Show,Eq) +-- | @since 1.0.0.0+instance ElementData AVertex where+  elementId = avId+  elementLabel = avLabel+ instance Element AVertex where-  type ElementID AVertex = GValue   type ElementProperty AVertex = AVertexProperty+  type ElementPropertyContainer AVertex = Multi  instance Vertex AVertex @@ -270,36 +361,28 @@     GObject o -> AVertex                  <$> (o .: "id")                  <*> (o .: "label")-                 <*> (o `optionalMonoid` "properties")     _ -> empty --- | General edge type you can use for 'Edge' class, based on Aeson--- data types.+-- | General edge type you can use for 'Edge' class. data AEdge =   AEdge-  { aeId :: GValue,+  { aeId :: ElementID AEdge,     -- ^ ID of this edge.-    aeLabel :: Text,+    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 :: GValue,-    -- ^ ID of this edge's destination vertex.-    aeOutV :: GValue,-    -- ^ ID of this edge's source vertex.-    aeProperties :: PropertyMapSingle AProperty GValue-    -- ^ Properties of this edge.   }   deriving (Show,Eq) +-- | @since 1.0.0.0+instance ElementData AEdge where+  elementId = aeId+  elementLabel = aeLabel+ instance Element AEdge where-  type ElementID AEdge = GValue   type ElementProperty AEdge = AProperty+  type ElementPropertyContainer AEdge = Single -instance Edge AEdge where-  type EdgeVertexID AEdge = GValue+instance Edge AEdge  instance GraphSONTyped AEdge where   gsonTypeFor _ = "g:Edge"@@ -312,29 +395,8 @@     GObject o -> AEdge                  <$> (o .: "id")                  <*> (o .: "label")-                 <*> (o .: "inVLabel")-                 <*> (o .: "outVLabel")-                 <*> (o .: "inV")-                 <*> (o .: "outV")-                 <*> (o `optionalMonoid` "properties")     _ -> empty -optionalMonoid :: (Monoid m, FromGraphSON m) => HM.HashMap Text GValue -> Text -> Parser m-optionalMonoid obj field_name = maybe (return mempty) parseGraphSON $ nullToNothing =<< HM.lookup field_name obj-  where-    nullToNothing gv = case gValueBody gv of-      GNull -> Nothing-      _ -> Just gv---- | __This typeclass is for internal use.__------ GraphSON parser with a property key given from outside.------ @since 0.2.0.0-class FromGraphSONWithKey a where-  parseGraphSONWithKey :: Text -> GValue -> Parser a-- -- | General simple property type you can use for 'Property' class. -- -- If you are not sure about the type @v@, just use 'GValue'.@@ -358,9 +420,6 @@     GObject o -> AProperty <$> (o .: "key") <*> (o .: "value")     _ -> empty -instance FromGraphSON v => FromGraphSONWithKey (AProperty v) where-  parseGraphSONWithKey k v = AProperty k <$> parseGraphSON v- instance Property AProperty where   propertyKey = apKey   propertyValue = apValue@@ -377,20 +436,17 @@ 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.+-- | General vertex property type you can use for VertexProperty. -- -- If you are not sure about the type @v@, just use 'GValue'. data AVertexProperty v =   AVertexProperty-  { avpId :: GValue,+  { avpId :: ElementID (AVertexProperty v),     -- ^ ID of this vertex property.     avpLabel :: Text,     -- ^ Label and key of this vertex property.-    avpValue :: v,+    avpValue :: v     -- ^ Value of this vertex property.-    avpProperties :: PropertyMapSingle AProperty GValue-    -- ^ (meta)properties of this vertex property.   }   deriving (Show,Eq) @@ -401,220 +457,40 @@  instance FromGraphSON v => FromGraphSON (AVertexProperty v) where   parseGraphSON gv = case gValueBody gv of-    GObject o -> do-      label <- o .: "label"-      parseGraphSONWithKey label gv-    _ -> empty--instance FromGraphSON v => FromGraphSONWithKey (AVertexProperty v) where-  parseGraphSONWithKey k gv = case gValueBody gv of     GObject o -> AVertexProperty                  <$> (o .: "id")-                 <*> pure k+                 <*> (o .: "label")                  <*> (o .: "value")-                 <*> (o `optionalMonoid` "properties")     _ -> empty  instance GraphSONTyped (AVertexProperty v) where   gsonTypeFor _ = "g:VertexProperty" +-- | @since 1.0.0.0+instance ElementData (AVertexProperty v) where+  elementId = avpId+  elementLabel = avpLabel+ instance Element (AVertexProperty v) where-  type ElementID (AVertexProperty v) = GValue   type ElementProperty (AVertexProperty v) = AProperty+  type ElementPropertyContainer (AVertexProperty v) = Single  instance Property AVertexProperty where   propertyKey = avpLabel   propertyValue = avpValue +-- | Map the property value. instance Functor AVertexProperty where-  fmap f vp = vp { avpValue = f $ avpValue vp }+  fmap f vp = vp { avpValue = f $ avpValue vp,+                   avpId = unsafeCastElementID $ avpId vp+                 }  instance Foldable AVertexProperty where   foldr f start vp = f (avpValue vp) start +-- | Traverse the property value. 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 'GValue' by the given key, and parse it.--- --- In version 0.1.1.0 and before, this function took an argument @m p (GraphSON Value)@.--- This has changed, because property types for 'AVertex' etc have changed.-parseOneValue :: (PropertyMap m, Property p, FromGraphSON v) => Text -> m p GValue -> Parser v-parseOneValue k pm = maybe (fail err_msg) parseGraphSON $ lookupOneValue k pm-  where-    err_msg = notExistErrorMsg k---- | Lookup a list of property values from a 'PropertyMap' by the--- given key, and parse them.--- --- In version 0.1.1.0 and before, this function took an argument @m p (GraphSON Value)@.--- This has changed, because property types for 'AVertex' etc have changed.-parseListValues :: (PropertyMap m, Property p, FromGraphSON v) => Text -> m p GValue -> Parser [v]-parseListValues k pm = mapM parseGraphSON $ lookupListValues k pm---- | Like 'parseListValues', but this function 'fail's when there is--- no property with the given key.------ In version 0.1.1.0 and before, this function took an argument @m p (GraphSON Value)@.--- This has changed, because property types for 'AVertex' etc have changed.-parseNonEmptyValues :: (PropertyMap m, Property p, FromGraphSON v) => Text -> m p GValue -> 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)) => Semigroup (PropertyMapGeneric t p v) where-  (PropertyMapGeneric a) <> (PropertyMapGeneric b) = PropertyMapGeneric $ HM.unionWith (<>) a b--instance Semigroup (t (p v)) => Monoid (PropertyMapGeneric t p v) where-  mempty = PropertyMapGeneric mempty-  mappend = (<>)--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+  traverse f vp = fmap setValue $ f $ avpValue vp     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), FromGraphSON (p v), FromGraphSONWithKey (p v))-                       => (GValue -> Parser (Vector GValue))-                       -> GValue-                       -> Parser (m p v)-parsePropertiesGeneric normalizeCardinality gv = case gValueBody gv of-  GObject obj -> foldlM folder mempty $ HM.toList obj-  _ -> empty-  where-    folder pm (k, value) = fmap (foldr putProperty pm) $ traverse (parseProperty k) =<< normalizeCardinality value-    parseProperty k value = parseTypedGValue value <|> parseGraphSONWithKey k value---- parhaps we might as well place it in GraphSON module and let it export.-parseTypedGValue :: (GraphSONTyped v, FromGraphSON v) => GValue -> Parser v-parseTypedGValue  gv = do-  prop <- parseGraphSON gv-  let exp_type = gsonTypeFor prop-      mgot_type = gValueType gv-  if mgot_type /= Just exp_type-    then fail ("Expected @type field of " ++ unpack exp_type ++ ", but got " ++ show mgot_type)-    else return prop--expectAesonArray :: GValue -> Parser (Vector GValue)-expectAesonArray gv = case gValueBody gv of-  GArray a -> return a-  _ -> 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,Semigroup,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---- | In version 0.1.1.0 and before, the constraint was @FromJSON v@.--- This has changed.-instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))-         => FromJSON (PropertyMapSingle p v) where-  parseJSON = parseJSONViaGValue--instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))-         => FromGraphSON (PropertyMapSingle p v) where-  parseGraphSON = 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,Semigroup,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---- | In version 0.1.1.0 and before, the constraint was @FromJSON v@.--- This has changed.-instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))-         => FromJSON (PropertyMapList p v) where-  parseJSON = parseJSONViaGValue--instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))-         => FromGraphSON (PropertyMapList p v) where-  parseGraphSON v = parsePropertiesGeneric expectAesonArray v+      setValue v = vp { avpValue = v, avpId = unsafeCastElementID $ avpId vp } 

@@ -0,0 +1,242 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveTraversable, OverloadedStrings #-}+-- |+-- Module: Data.Greskell.Graph.PropertyMap+-- Description: [Deprecated] PropertyMap class and types+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- 'PropertyMap' was used in greskell prior than 1.0.0.0, but is now+-- deprecated. Use "Data.Greskell.PMap" instead.+module Data.Greskell.Graph.PropertyMap {-# DEPRECATED "Use PMap instead" #-}+  ( -- ** PropertyMap+    PropertyMap(..),+    PropertyMapSingle,+    PropertyMapList,+    lookupOneValue,+    lookupListValues,+    parseOneValue,+    parseListValues,+    parseNonEmptyValues,+    fromProperties,+    -- * Internal use+    FromGraphSONWithKey,+    -- * Re-exports+    AProperty(..),+    AVertexProperty(..)+  ) where++import Control.Applicative (empty, (<|>))+import Data.Aeson (FromJSON(..))+import Data.Aeson.Types (Parser)+import Data.Foldable (Foldable(..), foldlM)+import Data.Greskell.GraphSON+  ( FromGraphSON(..), GValue, GraphSONTyped(..), (.:),+    parseJSONViaGValue+  )+import Data.Greskell.GraphSON.GValue (gValueBody, gValueType, GValueBody(..))+import qualified Data.HashMap.Strict 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.Text (Text, unpack)+import Data.Traversable (Traversable(..))+import Data.Vector (Vector)++import Data.Greskell.Graph (Property(..), AProperty(..), AVertexProperty(..))++-- | 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 'GValue' by the given key, and parse it.+-- +-- In version 0.1.1.0 and before, this function took an argument @m p (GraphSON Value)@.+-- This has changed, because property types for 'AVertex' etc have changed.+parseOneValue :: (PropertyMap m, Property p, FromGraphSON v) => Text -> m p GValue -> Parser v+parseOneValue k pm = maybe (fail err_msg) parseGraphSON $ lookupOneValue k pm+  where+    err_msg = notExistErrorMsg k++-- | Lookup a list of property values from a 'PropertyMap' by the+-- given key, and parse them.+-- +-- In version 0.1.1.0 and before, this function took an argument @m p (GraphSON Value)@.+-- This has changed, because property types for 'AVertex' etc have changed.+parseListValues :: (PropertyMap m, Property p, FromGraphSON v) => Text -> m p GValue -> Parser [v]+parseListValues k pm = mapM parseGraphSON $ lookupListValues k pm++-- | Like 'parseListValues', but this function 'fail's when there is+-- no property with the given key.+--+-- In version 0.1.1.0 and before, this function took an argument @m p (GraphSON Value)@.+-- This has changed, because property types for 'AVertex' etc have changed.+parseNonEmptyValues :: (PropertyMap m, Property p, FromGraphSON v) => Text -> m p GValue -> 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)) => Semigroup (PropertyMapGeneric t p v) where+  (PropertyMapGeneric a) <> (PropertyMapGeneric b) = PropertyMapGeneric $ HM.unionWith (<>) a b++instance Semigroup (t (p v)) => Monoid (PropertyMapGeneric t p v) where+  mempty = PropertyMapGeneric mempty+  mappend = (<>)++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), FromGraphSON (p v), FromGraphSONWithKey (p v))+                       => (GValue -> Parser (Vector GValue))+                       -> GValue+                       -> Parser (m p v)+parsePropertiesGeneric normalizeCardinality gv = case gValueBody gv of+  GObject obj -> foldlM folder mempty $ HM.toList obj+  _ -> empty+  where+    folder pm (k, value) = fmap (foldr putProperty pm) $ traverse (parseProperty k) =<< normalizeCardinality value+    parseProperty k value = parseTypedGValue value <|> parseGraphSONWithKey k value++-- parhaps we might as well place it in GraphSON module and let it export.+parseTypedGValue :: (GraphSONTyped v, FromGraphSON v) => GValue -> Parser v+parseTypedGValue  gv = do+  prop <- parseGraphSON gv+  let exp_type = gsonTypeFor prop+      mgot_type = gValueType gv+  if mgot_type /= Just exp_type+    then fail ("Expected @type field of " ++ unpack exp_type ++ ", but got " ++ show mgot_type)+    else return prop++expectAesonArray :: GValue -> Parser (Vector GValue)+expectAesonArray gv = case gValueBody gv of+  GArray a -> return a+  _ -> 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,Semigroup,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++-- | In version 0.1.1.0 and before, the constraint was @FromJSON v@.+-- This has changed.+instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))+         => FromJSON (PropertyMapSingle p v) where+  parseJSON = parseJSONViaGValue++instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))+         => FromGraphSON (PropertyMapSingle p v) where+  parseGraphSON = 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,Semigroup,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++-- | In version 0.1.1.0 and before, the constraint was @FromJSON v@.+-- This has changed.+instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))+         => FromJSON (PropertyMapList p v) where+  parseJSON = parseJSONViaGValue++instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))+         => FromGraphSON (PropertyMapList p v) where+  parseGraphSON v = parsePropertiesGeneric expectAesonArray v++-- | __This typeclass is for internal use.__+--+-- GraphSON parser with a property key given from outside.+--+-- @since 0.2.0.0+class FromGraphSONWithKey a where+  parseGraphSONWithKey :: Text -> GValue -> Parser a++instance FromGraphSON v => FromGraphSONWithKey (AProperty v) where+  parseGraphSONWithKey k v = AProperty k <$> parseGraphSON v++instance FromGraphSON v => FromGraphSONWithKey (AVertexProperty v) where+  parseGraphSONWithKey k gv = case gValueBody gv of+    GObject o -> AVertexProperty+                 <$> (o .: "id")+                 <*> pure k+                 <*> (o .: "value")+    _ -> empty

@@ -0,0 +1,44 @@+-- |+-- Module: Data.Greskell.NonEmptyLike+-- Description: Class of non-empty containers+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- @since 1.0.0.0+module Data.Greskell.NonEmptyLike+  ( NonEmptyLike(..)+  ) where++import qualified Data.Foldable as F+import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup (Semigroup, (<>))+import qualified Data.Semigroup as S++-- | Non-empty containers. Its cardinality is one or more.+--+-- @since 1.0.0.0+class F.Foldable t => NonEmptyLike t where+  -- | Make a container with a single value.+  singleton :: a -> t a+  -- | Append two containers.+  append :: t a -> t a -> t a+  -- | Convert the container to 'NonEmpty' list.+  toNonEmpty :: t a -> NonEmpty a++-- | 'append' is '<>' from 'Semigroup'.+instance NonEmptyLike NonEmpty where+  singleton a = a :| []+  append = (<>)+  toNonEmpty = id+  +-- | 'append' is '<>' from 'Semigroup'.+instance NonEmptyLike S.First where+  singleton = S.First+  append = (<>)+  toNonEmpty (S.First a) = singleton a++-- | 'append' is '<>' from 'Semigroup'.+instance NonEmptyLike S.Last where+  singleton = S.Last+  append = (<>)+  toNonEmpty (S.Last a) = singleton a+

@@ -0,0 +1,246 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveTraversable, TypeFamilies, OverloadedStrings #-}+-- |+-- Module: Data.Greskell.PMap+-- Description: Property map, a map with Text keys and cardinality options+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- This module defines 'PMap', a map with 'Text' keys and cardinality+-- options. +--+-- @since 1.0.0.0+module Data.Greskell.PMap+  ( -- * PMap+    PMap,+    -- ** Single lookup+    lookup,+    lookupM,+    lookupAs,+    lookupAs',+    lookupAsM,+    -- ** List lookup+    lookupList,+    lookupListAs,+    lookupListAs',+    -- ** Others+    pMapInsert,+    pMapDelete,+    pMapLookup,+    pMapToList,+    pMapFromList,+    -- * Cardinality+    Single,+    Multi,+    -- * PMapKey+    PMapKey(..),+    -- * Errors+    PMapLookupException(..),+    pMapDecribeError,+    pMapToThrow,+    pMapToFail+  ) where++import Prelude hiding (lookup)++import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))+import Control.Monad.Fail (MonadFail)+import Data.Aeson.Types (Parser)+import qualified Data.Foldable as F+import Data.Functor.Identity (Identity)+import Data.Greskell.AsIterator (AsIterator(..))+import Data.Greskell.GMap (GMapEntry)+import Data.Greskell.GraphSON (GValue, GraphSONTyped(..), FromGraphSON(..), parseEither)+import qualified Data.HashMap.Strict as HM+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Maybe (listToMaybe)+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup((<>)))+import qualified Data.Semigroup as S+import Data.Traversable (Traversable(traverse))+import Data.Text (Text, unpack)++import Data.Greskell.NonEmptyLike (NonEmptyLike)+import qualified Data.Greskell.NonEmptyLike as NEL++-- | A property map, which has text keys and @v@ values. @c@ specifies+-- the cardinality of each item, and should be an instance of+-- 'NonEmptyLike'.+--+-- You can look up values from 'PMap' using key types of 'PMapKey'+-- class.+--+-- @since 1.0.0.0+newtype PMap c v = PMap (HM.HashMap Text (c v))+                 deriving (Show,Eq,Functor,Foldable,Traversable)++instance GraphSONTyped (PMap c v) where+  gsonTypeFor _ = "g:Map"++instance FromGraphSON (c v) => FromGraphSON (PMap c v) where+  parseGraphSON gv = fmap PMap $ parseGraphSON gv++-- | Make a union of the two 'PMap's. If the two 'PMap's share some+-- keys, those values are merged by 'NEL.append' method from+-- 'NonEmptyLike'.+instance NonEmptyLike c => Semigroup (PMap c v) where+  (PMap a) <> (PMap b) = PMap (HM.unionWith NEL.append a b)++instance NonEmptyLike c => Monoid (PMap c v) where+  mempty = PMap $ HM.empty+  mappend = (<>)++instance AsIterator (PMap c v) where+  type IteratorItem (PMap c v) = GMapEntry Text (c v)++-- | Insert a key-value pair to 'PMap'. If it already has some items+-- for that key, 'NEL.append' method of the 'NonEmptyLike' type @c@+-- determines its behavior.+pMapInsert :: NonEmptyLike c => Text -> v -> PMap c v -> PMap c v+pMapInsert k v (PMap hm) = PMap $ HM.insertWith NEL.append k (NEL.singleton v) hm++-- | Delete a key and all values associated with it.+pMapDelete :: Text -> PMap c v -> PMap c v+pMapDelete k (PMap hm) = PMap $ HM.delete k hm++-- | Lookup all items for the key (low-level function). If there is no+-- item for the key, it returns an empty list.+pMapLookup :: NonEmptyLike c => Text -> PMap c v -> [v]+pMapLookup k (PMap hm) = maybe [] (F.toList . NEL.toNonEmpty) $ HM.lookup k hm++-- | List up all entries.+pMapToList :: F.Foldable c => PMap c v -> [(Text, v)]+pMapToList (PMap hm) = expandValues =<< HM.toList hm+  where+    expandValues (k, cv) = map ((,) k) $ F.toList cv++-- | Make a 'PMap' from list of entries.+pMapFromList :: NonEmptyLike c => [(Text, v)] -> PMap c v+pMapFromList = F.foldr f mempty+  where+    f (k, v) pm = pMapInsert k v pm++-- | Lookup the first value for the key from 'PMap'.+lookup :: (PMapKey k, NonEmptyLike c) => k -> PMap c v -> Maybe v+lookup k pm = listToMaybe $ lookupList k pm++-- | 'MonadThrow' version of 'lookup'. If there is no value for the+-- key, it throws 'PMapNoSuchKey'.+lookupM :: (PMapKey k, NonEmptyLike c, MonadThrow m) => k -> PMap c v -> m v+lookupM k pm = maybe (throwM $ PMapNoSuchKey $ keyText k) return $ lookup k pm++-- | Lookup the value and parse it into @a@.+lookupAs :: (PMapKey k, NonEmptyLike c, PMapValue k ~ a, FromGraphSON a)+         => k -> PMap c GValue -> Either PMapLookupException a+lookupAs k pm =+  case lookup k pm of+    Nothing -> Left $ PMapNoSuchKey kt+    Just gv -> either (Left . PMapParseError kt) Right $ parseEither gv+  where+    kt = keyText k++-- | Similar to 'lookupAs', but this function converts a @null@ result+-- into 'Nothing'.+--+-- A @null@ result is either (1) the key @k@ is not found in the map,+-- or (2) the key is found, but the value is @null@.+lookupAs' :: (PMapKey k, NonEmptyLike c, PMapValue k ~ (Maybe a), FromGraphSON a)+          => k -> PMap c GValue -> Either PMapLookupException (Maybe a)+lookupAs' k pm = either fromError Right $ lookupAs k pm+  where+    fromError (PMapNoSuchKey _) = Right Nothing+    fromError e = Left e++-- | 'MonadThrow' version of 'lookupAs'.+lookupAsM :: (PMapKey k, NonEmptyLike c, PMapValue k ~ a, FromGraphSON a, MonadThrow m)+          => k -> PMap c GValue -> m a+lookupAsM k pm = pMapToThrow $ lookupAs k pm++-- | Lookup all items for the key. If there is no item for the key, it+-- returns an empty list.+lookupList :: (PMapKey k, NonEmptyLike c) => k -> PMap c v -> [v]+lookupList k pm = pMapLookup (keyText k) pm++-- | Look up the values and parse them into @a@.+lookupListAs :: (PMapKey k, NonEmptyLike c, PMapValue k ~ a, FromGraphSON a)+             => k -> PMap c GValue -> Either PMapLookupException (NonEmpty a)+lookupListAs k pm =+  case lookupList k pm of+    [] -> Left $ PMapNoSuchKey kt+    (x : rest) -> either (Left . PMapParseError kt) Right $ traverse parseEither (x :| rest)+  where+    kt = keyText k++-- | Similar to 'lookupListAs', but this function accepts @null@+-- results.+--+-- If the key @k@ is not found in the map, it returns an empty+-- list. If the key @k@ is found and @null@s are included in the+-- values, they are obtained as 'Nothing'.+lookupListAs' :: (PMapKey k, NonEmptyLike c, PMapValue k ~ (Maybe a), FromGraphSON a)+              => k -> PMap c GValue -> Either PMapLookupException [Maybe a]+lookupListAs' k pm = either fromError (Right . F.toList) $ lookupListAs k pm+  where+    fromError (PMapNoSuchKey _) = Right []+    fromError e = Left e++-- | The single cardinality for 'PMap'. 'pMapInsert' method replaces+-- the old value. '<>' on 'PMap' prefers the items from the left+-- 'PMap'. 'pMapFromList' prefers the first item for each key.+--+-- @since 1.0.0.0+type Single = S.First++-- | The \"one or more\" cardinality for 'PMap'. 'pMapInsert' method+-- prepends the new value at the head. '<>' on 'PMap' appends the+-- right items to the tail of the left items. 'pMapFromList' preserves+-- the order of the items for each key.+--+-- @since 1.0.0.0+newtype Multi a = Multi (NonEmpty a)+              deriving (Show,Eq,Ord,Functor,Semigroup,Foldable,Traversable,NonEmptyLike,FromGraphSON)++-- | A typed key for 'PMap'.+--+-- @since 1.0.0.0+class PMapKey k where+  -- | Type of the value associated with the key.+  type PMapValue k :: *++  -- | 'Text' representation of the key.+  keyText :: k -> Text++-- | For simple 'Text', the 'GValue' is returned without being parsed.+instance PMapKey Text where+  type PMapValue Text = GValue+  keyText = id++-- | An 'Exception' raised when looking up values from 'PMap'.+--+-- @since 1.0.0.0+data PMapLookupException =+    PMapNoSuchKey Text+  -- ^ The 'PMap' doesn't have the given key.+  | PMapParseError Text String+  -- ^ Failed to parse the value into the type that the 'PMapKey'+  -- indicates. The 'Text' is the key, and the 'String' is the error+  -- message.+  deriving (Show,Eq,Ord)++instance Exception PMapLookupException++-- | Make a human-readable description on 'PMapLookupException'.+pMapDecribeError :: PMapLookupException -> String+pMapDecribeError (PMapNoSuchKey k) = "Property '" ++ unpack k ++ "' does not exist."+pMapDecribeError (PMapParseError k pe) = "Parse error of property '" ++ unpack k ++ "': " ++ pe++-- | Convert the lookup result into a 'MonadThrow'. It throws+-- 'PMapLookupException'.+pMapToThrow :: MonadThrow m => Either PMapLookupException a -> m a+pMapToThrow (Left e) = throwM e+pMapToThrow (Right a) = return a++-- | Convert the lookup result into a 'MonadFail'. It fails with the+-- description returned by 'pMapDecribeError'.+pMapToFail :: MonadFail m => Either PMapLookupException a -> m a+pMapToFail (Left e) = fail $ pMapDecribeError e+pMapToFail (Right a) = return a

@@ -7,8 +7,8 @@  import Data.Aeson (Value(..)) import Data.Greskell.Binder (Binder, Binding, runBinder)-import Data.Greskell.Extra (writePropertyKeyValues)-import Data.Greskell.Graph (AVertex)+import Data.Greskell.Extra (writePropertyKeyValues, writeKeyValues)+import Data.Greskell.Graph (AVertex, (=:), Key, KeyValue) import Data.Greskell.Greskell (toGremlin) import Data.Greskell.GTraversal (Walk, WalkType) import qualified Data.HashMap.Strict as HM@@ -46,3 +46,13 @@                                    ("__v2", String "bar")                                  ]                    )+  describe "writeKeyValues" $ do+    specify "empty" $ do+      (toGremlin $ writeKeyValues ([] :: [KeyValue AVertex])) `shouldBe` "__.identity()"+    specify "key-values" $ do+      let name :: Key AVertex Text+          name = "name"+          age :: Key AVertex Int+          age = "age"+          input = writeKeyValues [name =: "toshio", age =: 30]+      (toGremlin input) `shouldBe` "__.property(\"name\",\"toshio\").property(\"age\",30).identity()"

@@ -14,7 +14,7 @@     pEq, pNeq, pInside, pGte   ) import Data.Greskell.Graph-  ( Element,+  ( Element, ElementID(..), AVertex,     Key, key,     tLabel, tId   )@@ -48,7 +48,7 @@   specify "g.V()" $ do     (toGremlin $ sV' [] $ source "g") `shouldBe` ("g.V()")   specify "g.V(1,2,3)" $ do-    let ids = map gvalueInt $ ([1,2,3] :: [Int])+    let ids = map (fmap ElementID . gvalueInt) $ ([1,2,3] :: [Int])     (toGremlin $ sV' ids $ source "g") `shouldBe` ("g.V(1,2,3)")  spec_order_by :: Spec@@ -89,7 +89,8 @@     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' [gvalueInt (200 :: Int)] &. (gOut' [] >>> gOut' ["friends_to"] >>> gValues ["name"])+    let vid = fmap ElementID $ gvalueInt (200 :: Int)+        gt = source "g" & sV' [vid] &. (gOut' [] >>> gOut' ["friends_to"] >>> gValues ["name"])     toGremlin gt `shouldBe` "g.V(200).out().out(\"friends_to\").values(\"name\")"   specify "($) and ($.)" $ do     let gt = gRange 20 30 $. gNot (gOut' ["friends_to"]) $. sV' [] $ source "g"@@ -117,7 +118,9 @@         `shouldBe` "g.E().hasLabel(P.neq(\"friends_to\"))"   describe "gHasIdP" $ do     specify "P" $ do-      toGremlin (source "g" & sV' [] &. gHasIdP (pInside (gvalueInt (10 :: Int)) (gvalueInt (20 :: Int))))+      let toID :: Int -> Greskell (ElementID AVertex)+          toID = fmap ElementID . gvalueInt+      toGremlin (source "g" & sV' [] &. gHasIdP (pInside (toID 10) (toID 20)))         `shouldBe` "g.V().hasId(P.inside(10,20))"   describe "gHasKeyP, gProperties" $ do     specify "P" $ do

@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Greskell.Graph.PropertyMapSpec (main,spec) where++import Data.Monoid (mempty, (<>))+import Test.Hspec++import Data.Greskell.Graph.PropertyMap+  ( PropertyMapSingle, PropertyMapList, AProperty(..),+    PropertyMap(..)+  )++main :: IO ()+main = hspec spec++spec :: Spec+spec = 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+        ]+

@@ -9,9 +9,10 @@ import Test.Hspec  import Data.Greskell.Graph-  ( AProperty(..), PropertyMapSingle, PropertyMapList,-    PropertyMap(..),-    AEdge(..), AVertexProperty(..), AVertex(..)+  ( AProperty(..),+    -- PropertyMapSingle, PropertyMapList,+    AEdge(..), AVertexProperty(..), AVertex(..),+    ElementID(..)   ) import Data.Greskell.GraphSON   ( nonTypedGraphSON, typedGraphSON, typedGraphSON',@@ -23,99 +24,11 @@  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) @@ -124,28 +37,14 @@   it "should parse GraphSON v1" $ do     let expected = nonTypedGraphSON                    $ AEdge-                   { aeId = nonTypedGValue $ GNumber 13,-                     aeLabel = "develops",-                     aeInVLabel = "software",-                     aeOutVLabel = "person",-                     aeInV = nonTypedGValue $ GNumber 10,-                     aeOutV = nonTypedGValue $ GNumber 1,-                     aeProperties = putProperty-                                    (AProperty "since" $ nonTypedGValue $ GNumber 2009)-                                    $ mempty+                   { aeId = ElementID $ nonTypedGValue $ GNumber 13,+                     aeLabel = "develops"                    }     loadGraphSON "edge_v1.json" `shouldReturn` Right expected   let expected_v23 = typedGraphSON                      $ AEdge-                     { aeId = typedGValue' "g:Int32" $ GNumber 13,-                       aeLabel = "develops",-                       aeInVLabel = "software",-                       aeOutVLabel = "person",-                       aeInV = typedGValue' "g:Int32" $ GNumber 10,-                       aeOutV = typedGValue' "g:Int32" $ GNumber 1,-                       aeProperties = putProperty-                                      (AProperty "since" $ typedGValue' "g:Int32" $ GNumber 2009)-                                      $ mempty+                     { aeId = ElementID $ typedGValue' "g:Int32" $ GNumber 13,+                       aeLabel = "develops"                      }   it "should parse GraphSON v2" $ do     loadGraphSON "edge_v2.json" `shouldReturn` Right expected_v23@@ -176,18 +75,16 @@   it "should parse GraphSON v1" $ do     let ex = nonTypedGraphSON $              AVertexProperty-             { avpId = nonTypedGValue $ GNumber 0,+             { avpId = ElementID $ nonTypedGValue $ GNumber 0,                avpLabel = "name",-               avpValue = nonTypedGValue $ GString "marko",-               avpProperties = mempty+               avpValue = nonTypedGValue $ GString "marko"              }     loadGraphSON "vertex_property_v1.json" `shouldReturn` Right ex   let ex23 = typedGraphSON $              AVertexProperty-             { avpId = typedGValue' "g:Int64" $ GNumber 0,+             { avpId = ElementID $ typedGValue' "g:Int64" $ GNumber 0,                avpLabel = "name",-               avpValue = nonTypedGValue $ GString "marko",-               avpProperties = mempty+               avpValue = nonTypedGValue $ GString "marko"              }   it "should parse GraphSON v2" $ do     loadGraphSON "vertex_property_v2.json" `shouldReturn` Right ex23@@ -199,100 +96,14 @@   it "should parse GraphSON v1" $ do     let ex = nonTypedGraphSON $              AVertex-             { avId = nonTypedGValue $ GNumber 1,-               avLabel = "person",-               avProperties = foldr putProperty mempty-                              [ AVertexProperty-                                { avpId = nonTypedGValue $ GNumber 0,-                                  avpLabel = "name",-                                  avpValue = nonTypedGValue $ GString "marko",-                                  avpProperties = mempty-                                },-                                AVertexProperty-                                { avpId = nonTypedGValue $ GNumber 6,-                                  avpLabel = "location",-                                  avpValue = nonTypedGValue $ GString "san diego",-                                  avpProperties = foldr putProperty mempty-                                                  [ AProperty "startTime" $ nonTypedGValue $ GNumber 1997,-                                                    AProperty "endTime" $ nonTypedGValue $ GNumber 2001-                                                  ]-                                },-                                AVertexProperty-                                { avpId = nonTypedGValue $ GNumber 7,-                                  avpLabel = "location",-                                  avpValue = nonTypedGValue $ GString "santa cruz",-                                  avpProperties = foldr putProperty mempty-                                                  [ AProperty "startTime" $ nonTypedGValue $ GNumber 2001,-                                                    AProperty "endTime" $ nonTypedGValue $ GNumber 2004-                                                  ]-                                },-                                AVertexProperty-                                { avpId = nonTypedGValue $ GNumber 8,-                                  avpLabel = "location",-                                  avpValue = nonTypedGValue $ GString "brussels",-                                  avpProperties = foldr putProperty mempty-                                                  [ AProperty "startTime" $ nonTypedGValue $ GNumber 2004,-                                                    AProperty "endTime" $ nonTypedGValue $ GNumber 2005-                                                  ]-                                },-                                AVertexProperty-                                { avpId = nonTypedGValue $ GNumber 9,-                                  avpLabel = "location",-                                  avpValue = nonTypedGValue $ GString "santa fe",-                                  avpProperties = foldr putProperty mempty-                                                  [ AProperty "startTime" $ nonTypedGValue $ GNumber 2005-                                                  ]-                                }-                              ]+             { avId = ElementID $ nonTypedGValue $ GNumber 1,+               avLabel = "person"              }     loadGraphSON "vertex_v1.json" `shouldReturn` Right ex   let ex23 = typedGraphSON $              AVertex-             { avId = typedGValue' "g:Int32" $ GNumber 1,-               avLabel = "person",-               avProperties = foldr putProperty mempty-                              [ AVertexProperty-                                { avpId = typedGValue' "g:Int64" $ GNumber 0,-                                  avpLabel = "name",-                                  avpValue = nonTypedGValue $ GString "marko",-                                  avpProperties = mempty-                                },-                                AVertexProperty-                                { avpId = typedGValue' "g:Int64" $ GNumber 6,-                                  avpLabel = "location",-                                  avpValue = nonTypedGValue $ GString "san diego",-                                  avpProperties = foldr putProperty mempty-                                                  [ AProperty "startTime" $ typedGValue' "g:Int32" $ GNumber 1997,-                                                    AProperty "endTime" $ typedGValue' "g:Int32" $ GNumber 2001-                                                  ]-                                },-                                AVertexProperty-                                { avpId = typedGValue' "g:Int64" $ GNumber 7,-                                  avpLabel = "location",-                                  avpValue = nonTypedGValue $ GString "santa cruz",-                                  avpProperties = foldr putProperty mempty-                                                  [ AProperty "startTime" $ typedGValue' "g:Int32" $ GNumber 2001,-                                                    AProperty "endTime" $ typedGValue' "g:Int32" $ GNumber 2004-                                                  ]-                                },-                                AVertexProperty-                                { avpId = typedGValue' "g:Int64" $ GNumber 8,-                                  avpLabel = "location",-                                  avpValue = nonTypedGValue $ GString "brussels",-                                  avpProperties = foldr putProperty mempty-                                                  [ AProperty "startTime" $ typedGValue' "g:Int32" $ GNumber 2004,-                                                    AProperty "endTime" $ typedGValue' "g:Int32" $ GNumber 2005-                                                  ]-                                },-                                AVertexProperty-                                { avpId = typedGValue' "g:Int64" $ GNumber 9,-                                  avpLabel = "location",-                                  avpValue = nonTypedGValue $ GString "santa fe",-                                  avpProperties = foldr putProperty mempty-                                                  [ AProperty "startTime" $ typedGValue' "g:Int32" $ GNumber 2005-                                                  ]-                                }-                              ]+             { avId = ElementID $ typedGValue' "g:Int32" $ GNumber 1,+               avLabel = "person"              }   it "should parse GraphSON v2" $ do     loadGraphSON "vertex_v2.json" `shouldReturn` Right ex23

@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Greskell.PMapSpec (main,spec) where++import Prelude hiding (lookup)++import Data.Text (Text)+import Test.Hspec++import Data.Greskell.PMap+  ( PMap, Single, Multi,+    pMapFromList, pMapToList, pMapInsert, pMapDelete,+    lookup, lookupList+  )++main :: IO ()+main = hspec spec++-- the tests are based on PropertyMapSpec.++spec :: Spec+spec = do+  describe "PMap Single" $ do+    let pm :: PMap Single Int+        pm = pMapFromList+             [ ("buzz", 300),+               ("bar", 200),+               ("foo", 100)+             ]+    specify "pMapToList" $ do+      pMapToList pm `shouldMatchList`+        [ ("buzz", 300),+          ("bar", 200),+          ("foo", 100)+        ]+    specify "lookup existing" $ do+      lookup ("foo" :: Text) pm `shouldBe` Just 100+    specify "lookup non-existing" $ do+      lookup ("HOGE" :: Text) pm `shouldBe` Nothing+    specify "lookupList existing" $ do+      lookupList ("foo" :: Text) pm `shouldBe` [100]+    specify "lookupList non-existing" $ do+      lookupList ("HOGE" :: Text) pm `shouldBe` []+    specify "pMapInsert overrides" $ do+      let pm2 = pMapInsert "foo" 500 pm+      pMapToList pm2 `shouldMatchList`+        [ ("buzz", 300),+          ("bar", 200),+          ("foo", 500)+        ]+    specify "pMapFromList prefers the first value" $ do+      let pm2 :: PMap Single Int+          pm2 = pMapFromList+                [("foo", 100), ("foo", 200), ("foo", 300), ("bar", 400)]+      pMapToList pm2 `shouldMatchList` [("foo", 100), ("bar", 400)]+    specify "pMapDelete" $ do+      let pm2 = pMapDelete "HOGE" $ pMapDelete "bar" $ pm+      pMapToList pm2 `shouldMatchList`+        [ ("buzz", 300),+          ("foo", 100)+        ]+    specify "<> prefers the left" $ do+      let pm2 = pMapFromList [("hoge", 600), ("bar", 500)]+          pm3 = pm <> pm2+      pMapToList pm3 `shouldMatchList`+        [ ("buzz", 300),+          ("bar", 200),+          ("foo", 100),+          ("hoge", 600)+        ]+  describe "PMap Multi" $ do+    let pm :: PMap Multi Int+        pm = pMapFromList+             [ ("foo", 100),+               ("foo", 200),+               ("bar", 300),+               ("foo", 400)+             ]+    specify "pMapToList" $ do+      pMapToList pm `shouldMatchList`+        [ ("foo", 100),+          ("foo", 200),+          ("bar", 300),+          ("foo", 400)+        ]+    specify "lookup existing" $ do+      lookup ("foo" :: Text) pm `shouldBe` Just 100+    specify "lookup non-existing" $ do+      lookup ("HOGE" :: Text) pm `shouldBe` Nothing+    specify "lookupList existing" $ do+      lookupList ("foo" :: Text) pm `shouldBe` [100,200,400]+    specify "lookupList non-existing" $ do+      lookupList ("HOGE" :: Text) pm `shouldBe` []+    specify "pMapInsert prepends" $ do+      let pm2 = pMapInsert "bar" 500 pm+      pMapToList pm2 `shouldMatchList`+        [ ("bar", 500),+          ("foo", 100),+          ("foo", 200),+          ("bar", 300),+          ("foo", 400)+        ]+      lookup ("bar" :: Text) pm2 `shouldBe` Just 500+      lookupList ("bar" :: Text) pm2 `shouldBe` [500, 300]+    specify "pMapDelete" $ do+      let pm2 = pMapDelete "HOGE" $ pMapDelete "foo" pm+      pMapToList pm2 `shouldMatchList` [("bar", 300)]+      let pm3 = pMapDelete "bar" pm2+      pMapToList pm3 `shouldMatchList` []+    specify "<> appends" $ do+      let pm2 = pMapFromList+                [ ("bar", 500),+                  ("buzz", 600),+                  ("foo", 700)+                ]+          pm3 = pm <> pm2+      lookupList ("foo" :: Text) pm3 `shouldBe` [100, 200, 400, 700]+      lookupList ("bar" :: Text) pm3 `shouldBe` [300, 500]+      pMapToList pm3 `shouldMatchList`+        [ ("foo", 100),+          ("foo", 200),+          ("bar", 300),+          ("foo", 400),+          ("bar", 500),+          ("buzz", 600),+          ("foo", 700)+        ]+    

@@ -3,16 +3,23 @@  import qualified Data.Vector as V import qualified Network.Greskell.WebSocket.Client as WS+import System.IO (hPutStrLn, stderr) import Test.Hspec +import Control.Category ((<<<))+import Control.Monad (void)+import Data.Text (Text) import Data.Greskell.Binder (newBind, runBinder) import Data.Greskell.Graph-  ( AVertex, Key,+  ( AVertex(..), Key, AEdge, Property(propertyKey, propertyValue),+    AVertexProperty(..)   )+import Data.Greskell.GraphSON (parseEither) import Data.Greskell.GTraversal   ( Walk, GTraversal, SideEffect,-    source, sV', sAddV', gProperty, gId, gValues, gHasId, gHasLabel, gHas2,-    ($.), liftWalk+    source, sV', sE', sAddV', gProperty, gId, gValues, gHasId, gHasLabel, gHas2,+    ($.), liftWalk,+    gAddE', gTo, gV', gProperties   )  import ServerTest.Common (withEnv, withClient)@@ -23,6 +30,8 @@ spec :: Spec spec = withEnv $ do   spec_values_type+  spec_generic_element_ID+  spec_vertex_with_props  clearGraph :: WS.Client -> IO () clearGraph client = WS.drainResults =<< WS.submitRaw client "g.V().drop()" Nothing@@ -52,3 +61,58 @@     got_ids <- putProp     got <- getProp (got_ids V.! 0)     V.toList got `shouldBe` [100]++spec_generic_element_ID :: SpecWith (String, Int)+spec_generic_element_ID = do+  specify "get Vertex ID as GValue, query Vertex by GValue" $ withClient $ \client -> do+    let prop_key :: Key AVertex Int+        prop_key = "sample"+        prop_val = 125+        make_v = liftWalk gId $. gProperty prop_key prop_val $. (sAddV' "test" $ source "g")+    clearGraph client+    got_ids <- fmap V.toList $ WS.slurpResults =<< WS.submit client make_v Nothing+    hPutStrLn stderr ("Got Vertex IDs: " <> show got_ids)+    length got_ids `shouldBe` 1+    let (q, qbind) = runBinder $ do+          vid <- newBind (got_ids !! 0)+          return $ gValues [prop_key] $. (sV' [vid] $ source "g")+    got_vals <- fmap V.toList $ WS.slurpResults =<< WS.submit client q (Just qbind)+    got_vals `shouldBe` [125]+  specify "get Edge ID as GValue, query Edge by GValue" $ withClient $ \client -> do+    let vname_key :: Key AVertex Text+        vname_key = "name"+        ename_key :: Key AEdge Text+        ename_key = "name"+        makeV n = (liftWalk $ gProperty vname_key n) $. (sAddV' "test_v" $ source "g")+        makeE fn tn = liftWalk gId+                      $. gProperty ename_key "e_test"+                      $. gAddE' "test_e" (gTo $ gHas2 vname_key tn <<< gV' [])+                      $. gHas2 vname_key fn+                      $. (liftWalk $ sV' [] $ source "g")+    clearGraph client+    void $ WS.slurpResults =<< WS.submit client (makeV "v_from") Nothing+    void $ WS.slurpResults =<< WS.submit client (makeV "v_to") Nothing+    got_ids <- fmap V.toList $ WS.slurpResults =<< WS.submit client (makeE "v_from" "v_to") Nothing+    hPutStrLn stderr ("Got Edge IDs: " <> show got_ids)+    length got_ids `shouldBe` 1+    let (q, qbind) = runBinder $ do+          eid <- newBind (got_ids !! 0)+          return $ gValues [ename_key] $. (sE' [eid] $ source "g")+    got_vals <- fmap V.toList $ WS.slurpResults =<< WS.submit client q (Just qbind)+    got_vals `shouldBe` ["e_test"]+    +spec_vertex_with_props :: SpecWith (String, Int)+spec_vertex_with_props = do+  let prop_key :: Key AVertex Int+      prop_key = "sample"+      makeV = gProperty prop_key 1132 $. (sAddV' "test" $ source "g")+      getProps vid = gProperties [prop_key] $. (sV' [vid] $ source "g")+  specify "get Vertex element as AVertex, VertexProperty element as AVertexProperty" $ withClient $ \client -> do+    clearGraph client+    got_vs <- fmap V.toList $ WS.slurpResults =<< WS.submit client makeV Nothing+    (fmap avLabel $ got_vs) `shouldBe` ["test"]+    let (query, bindings) = runBinder $ do+          vid <- newBind $ avId (got_vs !! 0)+          return $ getProps vid+    got_vps <- fmap V.toList $ WS.slurpResults =<< WS.submit client query (Just bindings)+    map (\vp -> (avpLabel vp, avpValue vp)) got_vps `shouldBe` [("sample", 1132)]

@@ -1,12 +1,13 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies #-} module Main (main,spec) where -import Control.Category ((<<<))+import Control.Category ((<<<), (>>>)) import qualified Data.Aeson as Aeson import Data.Either (isRight)+import Data.Foldable (toList) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM-import Data.List (sortBy)+import Data.List (sort) import Data.Monoid (mempty, (<>)) import Data.Scientific (Scientific) import Data.Text (unpack, Text)@@ -14,7 +15,7 @@ import qualified Network.Greskell.WebSocket.Client as WS import Test.Hspec -import Data.Greskell.AsLabel (AsLabel(..), lookupAsM)+import Data.Greskell.AsLabel (AsLabel(..)) import qualified Data.Greskell.AsLabel as As import Data.Greskell.AsIterator   ( AsIterator(IteratorItem)@@ -32,9 +33,9 @@   ) import Data.Greskell.Graph   ( AVertex(..), AEdge(..), AProperty(..), AVertexProperty(..),-    PropertyMapSingle, Key,+    Key, Keys(..), (-:), singletonKeys,     T, tId, tLabel, tKey, tValue, cList, (=:),-    fromProperties, allProperties+    ElementID(..)   ) import Data.Greskell.GraphSON   ( FromGraphSON, nonTypedGValue, GValue,@@ -43,12 +44,15 @@ import Data.Greskell.GTraversal   ( Walk, GTraversal, SideEffect,     source, sV', sE', gV', sAddV', gAddE', gTo,-    ($.), gOrder, gBy1, gBy,+    ($.), gOrder, gBy1, gBy, gByL,     Transform, unsafeWalk, unsafeGTraversal,-    gProperties, gProperty, gPropertyV, liftWalk,+    gProperties, gProperty, gPropertyV, liftWalk, gValues,     gAs, gSelect1, gSelectN, gSelectBy1, gSelectByN,-    gFilter, gOut'+    gFilter, gOut', gOutV, gOutV', gInV, gInV', gId, gLabel, gProject,+    gValueMap,+    gProject, gByL   )+import Data.Greskell.PMap (lookupAsM, lookupListAs, pMapToThrow)  import ServerTest.Common (withEnv, withClient) @@ -65,7 +69,7 @@   spec_graph   spec_as   spec_selectBy-+  spec_project  spec_basics :: SpecWith (String,Int) spec_basics = do@@ -174,7 +178,7 @@  spec_T :: SpecWith (String,Int) spec_T = describe "T enum" $ do-  specFor' "tId" (gMapT tId) parseEither [(Right 10 :: Either String Int)]+  specFor' "tId" (gMapT tId) (parseEither . unElementID) [(Right 10 :: Either String Int)]   specFor "tLabel" (gMapT tLabel) ["VLABEL"]   specFor "tKey" (gMapT tKey <<< gProperties ["vprop"]) ["vprop"]   specFor' "tValue" (gMapT tValue <<< gProperties ["vprop"]) parseEither [(Right 400 :: Either String Int)]@@ -238,55 +242,87 @@     got <- WS.slurpResults =<< WS.submit client (withPrelude' trav) Nothing     (map (fmap parseEither) $ V.toList got) `shouldMatchList` expected   specify "AEdge" $ withClient $ \client -> do-    let trav = sE' [] $ source "g"-        expE :: Int -> Int -> Text -> (Text,Text,Text,Either String Int, Either String Int, PropertyMapSingle AProperty (Either String Text))-        expE outv inv cond = ("depends_on", "package", "package", Right outv, Right inv, props)-          where-            props = fromProperties [AProperty "condition" $ Right cond]-        getE e = ( aeLabel e, aeInVLabel e, aeOutVLabel e,-                   parseEither $ aeOutV e, parseEither $ aeInV e,-                   fmap parseEither $ aeProperties e-                 )-        expected = [ expE 1 2 ">=0.11.2.1",-                     expE 1 3 ">=1.2.2.1",-                     expE 2 3 ">=1.2.3"+    let lOutV :: AsLabel Text+        lOutV = "outV_name"+        lInV :: AsLabel Text+        lInV = "inV_name"+        lProps = "props"+        lEdge = "edge"+        lProj = "projections"+        kCond :: Key AEdge Text+        kCond = "condition"+        trav = gSelectN lEdge lProj [] $. gAs lProj $.+               ( gProject+                 ( gByL lOutV (gOutV' >>> gValues ["name"]) )+                 [ gByL lInV  (gInV'  >>> gValues ["name"]),+                   gByL lProps (gValueMap KeysNil)+                 ]+               ) $.+               gAs lEdge $. sE' [] $ source "g"+        parseResult pm = do+          edge <- lookupAsM lEdge pm+          pj <- lookupAsM lProj pm+          (,,,) (aeLabel edge)+            <$> (lookupAsM lOutV pj)+            <*> (lookupAsM lInV pj)+            <*> (lookupAsM kCond =<< lookupAsM lProps pj)+        expected = [ ("depends_on", "greskell", "aeson", ">=0.11.2.1"),+                     ("depends_on", "greskell", "text", ">=1.2.2.1"),+                     ("depends_on", "aeson", "text", ">=1.2.3")                    ]-    got <- WS.slurpResults =<< WS.submit client (withPrelude' trav) Nothing-    (map getE $ V.toList got) `shouldMatchList` expected-  let getVP vp = (avpLabel vp, parseEither $ avpValue vp, fmap parseEither $ avpProperties vp)+    got <- traverse parseResult =<< WS.slurpResults =<< WS.submit client (withPrelude' trav) Nothing+    V.toList got `shouldMatchList` expected   specify "AVertexProperty" $ withClient $ \client -> do-    let trav = gProperties [] $. sV' [] $ source "g"-        expName :: Text -> (Text,Either String Text, PropertyMapSingle AProperty (Either String Text))-        expName val = ("name", Right val, mempty)-        expVer :: Text -> Text -> (Text,Either String Text, PropertyMapSingle AProperty (Either String Text))-        expVer val date = ("version", Right val, fromProperties [AProperty "date" $ Right date])-        expected = [ expName "greskell",-                     expName "aeson",-                     expName "text",-                     expVer "0.1.1.0" "2018-04-08",-                     expVer "1.3.1.1" "2018-05-10",-                     expVer "1.2.2.0" "2017-09-20",-                     expVer "1.2.3.0" "2017-12-27",-                     expVer "1.2.2.0" "2017-12-23"+    let lAV = "vertex_property"+        lProps = "props"+        kDate :: Key (AVertexProperty GValue) Text+        kDate = "date"+        trav = gSelectN lAV lProps [] $. gAs lProps $. gValueMap (singletonKeys kDate) $.+               gAs lAV $. gProperties [] $. sV' [] $ source "g"+        parseResult pm = do+          av <- lookupAsM lAV pm+          let label = avpLabel av+              e_val = parseEither $ avpValue av+          m_date <- if label == "version"+                    then fmap Just (lookupAsM kDate =<< lookupAsM lProps pm)+                    else return Nothing+          return (label, e_val, m_date)+        expected :: [(Text, Either String Text, Maybe Text)]+        expected = [ ("name", Right "greskell", Nothing),+                     ("name", Right "aeson", Nothing),+                     ("name", Right "text", Nothing),+                     ("version", Right "0.1.1.0", Just "2018-04-08"),+                     ("version", Right "1.3.1.1", Just "2018-05-10"),+                     ("version", Right "1.2.2.0", Just "2017-09-20"),+                     ("version", Right "1.2.3.0", Just "2017-12-27"),+                     ("version", Right "1.2.2.0", Just "2017-12-23")                    ]-    got <- WS.slurpResults =<< WS.submit client (withPrelude' trav) Nothing-    (map getVP $ V.toList got) `shouldMatchList` expected+    got <- traverse parseResult =<< WS.slurpResults =<< WS.submit client (withPrelude' trav) Nothing+    V.toList got `shouldMatchList` expected   specify "AVertex" $ withClient $ \client -> do-    let trav = sV' [] $ source "g"-        getV v = ( parseEither $ avId v,-                   avLabel v,-                   sort' $ map getVP $ allProperties $ avProperties v-                 )-        sort' = sortBy $ \(k1, v1, _) (k2, v2, _) -> compare (show k1,show v1) (show k2,show v2)-        expV :: Int -> Text -> [(Text, Text)] -> (Either String Int,Text,[(Text,Either String Text,PropertyMapSingle AProperty (Either String Text))])-        expV vid name ver_dates = (Right vid, "package", ("name", Right name, mempty) : map toVP ver_dates)-        toVP (ver, date) = ("version", Right ver, fromProperties [AProperty "date" $ Right date])-        expected = [ expV 1 "greskell" [("0.1.1.0", "2018-04-08")],-                     expV 2 "aeson" [("1.2.2.0", "2017-09-20"), ("1.3.1.1", "2018-05-10")],-                     expV 3 "text" [("1.2.2.0", "2017-12-23"), ("1.2.3.0", "2017-12-27")]+    let lVertex = "vertex"+        kName :: Key AVertex Text+        kName = "name"+        kVer :: Key AVertex Text+        kVer = "version"+        lProps = "props"+        trav = gSelectN lVertex lProps [] $. gAs lProps $. gValueMap (kName -: kVer -: KeysNil) $.+               gAs lVertex $. sV' [] $ source "g"+        parseResult pm = do+          v <- lookupAsM lVertex pm+          let label = avLabel v+              evid = parseEither $ unElementID $ avId v+          props <- lookupAsM lProps pm+          names <- fmap toList $ pMapToThrow $ lookupListAs kName props+          vers <- fmap (sort . toList) $ pMapToThrow $ lookupListAs kVer props+          return (evid, label, names, vers)+        expected :: [(Either String Int, Text, [Text], [Text])]+        expected = [ (Right 1, "package", ["greskell"], ["0.1.1.0"]),+                     (Right 2, "package", ["aeson"], ["1.2.2.0", "1.3.1.1"]),+                     (Right 3, "package", ["text"], ["1.2.2.0", "1.2.3.0"])                    ]-    got <- WS.slurpResults =<< WS.submit client (withPrelude' trav) Nothing-    (map getV $ V.toList got) `shouldMatchList` expected+    got <- traverse parseResult =<< WS.slurpResults =<< WS.submit client (withPrelude' trav) Nothing+    V.toList got `shouldMatchList` expected   where     withPrelude' :: (ToGreskell a) => a -> Greskell (GreskellReturn a)     withPrelude' = withPrelude prelude@@ -312,8 +348,8 @@               )     finalize :: GTraversal c s e -> Text     finalize gt = toGremlin $ iterateTraversal gt-    num :: Integer -> Greskell GValue-    num = gvalueInt+    num :: Integer -> Greskell (ElementID AVertex)+    num = fmap ElementID . gvalueInt     setName :: Integer -> Greskell Text -> GTraversal SideEffect () AVertex     setName vid name = gProperty "name" name $. liftWalk $ sV' [num vid] $ source "g"     dependsOn :: Integer -> Integer -> Greskell Text -> GTraversal SideEffect () AEdge@@ -326,13 +362,14 @@       [ finalize $ gPropertyV (Just cList) "version" ver ["date" =: date] $. liftWalk $ sV' [num vid] $ source "g"       ] +multiplyWalk :: Greskell Int -> Walk Transform Int Int+multiplyWalk factor = unsafeWalk "map" ["{ it.get() * " <> toGremlin factor <> " }"]  spec_as :: SpecWith (String,Int) spec_as = do   let start :: GTraversal Transform () Int       start = unsafeGTraversal "__(1,2,3)"-      mult :: Greskell Int -> Walk Transform Int Int-      mult factor = unsafeWalk "map" ["{ it.get() * " <> toGremlin factor <> " }"]+      mult = multiplyWalk   specify "gAs and gSelect1" $ withClient $ \client -> do     let label :: AsLabel Int         label = AsLabel "a"@@ -375,3 +412,45 @@     got <- fmap V.toList $ WS.slurpResults =<< WS.submit client (withPrelude prelude gt) Nothing     map (As.lookup src) got `shouldBe` [Just 23]     map (As.lookup dest) got `shouldBe` [Just 18]++spec_project :: SpecWith (String,Int)+spec_project = do+  let start :: GTraversal Transform () Int+      start = unsafeGTraversal "__(1,2,3)"+  specify "gProject with single item" $ withClient $ \client -> do+    let l2 = "l2"+        trav = gProject (gByL l2 $ multiplyWalk 2) [] $. start+    got <- fmap V.toList $ WS.slurpResults =<< WS.submit client trav Nothing+    got_l2 <- traverse (lookupAsM l2) got+    got_l2 `shouldBe` [2,4,6]+  specify "gProject with two items" $ withClient $ \client -> do+    let l2 = "l2"+        l3 = "l3"+        trav = gProject (gByL l2 $ multiplyWalk 2) [gByL l3 $ multiplyWalk 3] $. start+    got <- fmap V.toList $ WS.slurpResults =<< WS.submit client trav Nothing+    got_l2 <- traverse (lookupAsM l2) got+    got_l2 `shouldBe` [2,4,6]+    got_l3 <- traverse (lookupAsM l3) got+    got_l3 `shouldBe` [3,6,9]+  specify "gProject with more than one items in 'by' traversal" $ withClient $ \client -> do+    let rep_mul3 :: Walk Transform Int Int+        rep_mul3 = unsafeWalk "flatMap" ["{ def a = it.get(); return [a * 3, a * 4, a * 5].iterator() }"]+        lab = "rep_mul3"+        trav = gProject (gByL lab $ rep_mul3) [] $. start+    got_simple <- fmap V.toList $ WS.slurpResults =<< WS.submit client (rep_mul3 $. start) Nothing+    got_simple `shouldBe` [3, 4, 5, 6, 8, 10, 9, 12, 15]+    got <- fmap V.toList $ WS.slurpResults =<< WS.submit client trav Nothing+    got_l <- traverse (lookupAsM lab) got+    got_l `shouldBe` [3, 6, 9]+    -- only the first item from the by-projection traversal.+  specify "gProject with gSelect1 in by-projection" $ withClient $ \client -> do+    let as_orig = "as_orig"+        l_orig = "orig"+        l_mapped = "mapped"+        trav = gProject+               (gByL l_mapped $ multiplyWalk 4)+               [gByL l_orig $ gSelect1 as_orig ] $.+               gAs as_orig $. start+    got <- fmap V.toList $ WS.slurpResults =<< WS.submit client trav Nothing+    traverse (lookupAsM l_mapped) got `shouldReturn` [4, 8, 12]+    traverse (lookupAsM l_orig) got `shouldReturn` [1, 2, 3]