greskell 1.2.0.2 → 2.0.0.0
raw patch · 10 files changed
+146/−136 lines, 10 filesdep +should-not-typecheckdep −hintdep ~aesondep ~doctestdep ~greskell-corePVP ok
version bump matches the API change (PVP)
Dependencies added: should-not-typecheck
Dependencies removed: hint
Dependency ranges changed: aeson, doctest, greskell-core, greskell-websocket, hashable, semigroups
API changes (from Hackage documentation)
+ Data.Greskell.GTraversal: showLift :: Lift from to => Proxy from -> Proxy to -> String
+ Data.Greskell.GTraversal: showSplit :: Split c p => Proxy c -> Proxy p -> String
+ Data.Greskell.GTraversal: showWalkType :: WalkType t => Proxy t -> String
Files
- ChangeLog.md +9/−0
- greskell.cabal +13/−24
- src/Data/Greskell/Binder.hs +6/−5
- src/Data/Greskell/Extra.hs +4/−4
- src/Data/Greskell/GTraversal.hs +45/−16
- src/Data/Greskell/Graph/PropertyMap.hs +4/−2
- test/Data/Greskell/BinderSpec.hs +9/−5
- test/Data/Greskell/ExtraSpec.hs +3/−3
- test/HintTest.hs +0/−77
- test/Typecheck.hs +53/−0
ChangeLog.md view
@@ -1,5 +1,14 @@ # Revision history for greskell +## 2.0.0.0 -- 2021-12-28++* **BREAKING CHANGE**: Now greskell uses `aeson-2.0`.+ As a result, now implementation of `Data.Aeson.Object` has been changed from `HashMap` to `KeyMap`.+ Some types in greskell (e.g. `Binding`) directly uses the `Object` type.+* Confirm test with `aeson-2.0.2.0`, `semigroups-0.20`, `hashable-1.4.0.1`, `doctest-0.19`, `doctest-0.20`.+* Add `showWalkType`, `showLift` and `showSplit` functions, but those are only for testing purposes.+* `hint-test-suite` is removed. Instead, `typecheck-test-suite` is added, which is more robust and lightweight.+ ## 1.2.0.2 -- 2021-11-08 * Confirm test with `base-4.15.0.0`.
greskell.cabal view
@@ -1,5 +1,5 @@ name: greskell-version: 1.2.0.2+version: 2.0.0.0 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> license: BSD3@@ -40,15 +40,15 @@ Data.Greskell.Logic -- other-modules: build-depends: base >=4.9.0.0 && <4.16,- greskell-core >=0.1.3.0 && <0.2,+ greskell-core >=0.1.3.0 && <1.1, text >=1.2.2.1 && <1.3, transformers >=0.5.2 && <0.6,- aeson >=0.11.2.1 && <1.6,+ aeson >=2.0.2.0 && <2.1, unordered-containers >=0.2.7.1 && <0.3,- semigroups >=0.18.2 && <0.20,+ semigroups >=0.18.2 && <0.21, vector >=0.12.0.1 && <0.13, exceptions >=0.8.3 && <0.11,- hashable >=1.2.7.0 && <1.4+ hashable >=1.2.7.0 && <1.5 test-suite spec type: exitcode-stdio-1.0@@ -67,7 +67,7 @@ Data.Greskell.PMapSpec, Data.Greskell.LogicSpec build-tool-depends: hspec-discover:hspec-discover- build-depends: base, text, aeson, unordered-containers,+ build-depends: base, text, aeson, unordered-containers, greskell, greskell-core, hspec >=2.2.3, bytestring >=0.10.8.1 && <0.11@@ -80,29 +80,18 @@ main-is: DocTest.hs build-tool-depends: doctest-discover:doctest-discover build-depends: base,- doctest >=0.11 && <0.19,+ doctest >=0.11 && <0.21, doctest-discover >=0.1.0.8 && <0.3 --flag hint-test- description: Do tests that use Haskell interpreter (hint package).- These tests depend on the behavior of the hint package, so it may be unstable.- Disable the flag to skip the tests. Or, maybe you should disable concurrent build.- default: True- manual: True--test-suite hint-test-suite- if !flag(hint-test)- buildable: False+test-suite typecheck-test-suite type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m"- main-is: HintTest.hs+ main-is: Typecheck.hs build-depends: base, hspec,- greskell, - hint >=0.6 && <0.10-+ greskell,+ should-not-typecheck >=2.1.0 && <2.2 flag server-test description: Do tests with Gremlin Server.@@ -122,7 +111,7 @@ build-depends: base, aeson, hspec, text, unordered-containers, vector, greskell, greskell-core, scientific >=0.3.4.9 && <0.4,- greskell-websocket >=0.1.0.0 && <0.2,+ greskell-websocket >=0.1.0.0 && <1.1, safe-exceptions >=0.1.6 && <0.2 else buildable: False@@ -147,7 +136,7 @@ build-depends: base, aeson, hspec, text, unordered-containers, vector, greskell, greskell-core, scientific >=0.3.4.9 && <0.4,- greskell-websocket >=0.1.0.0 && <0.2,+ greskell-websocket >=0.1.0.0 && <1.1, safe-exceptions >=0.1.6 && <0.2 else buildable: False
src/Data/Greskell/Binder.hs view
@@ -19,8 +19,9 @@ import Control.Monad.Trans.State (State) import qualified Control.Monad.Trans.State as State import Data.Aeson (Value, ToJSON(toJSON), Object)+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Key as Key import Data.Monoid ((<>))-import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -50,7 +51,7 @@ -- >>> import Data.Greskell.Greskell (toGremlin) -- >>> import Data.List (sortBy) -- >>> import Data.Ord (comparing)--- >>> import qualified Data.HashMap.Strict as HashMap+-- >>> import qualified Data.Aeson.KeyMap as KeyMap -- | A Monad that manages binding variables and labels to values. --@@ -60,7 +61,7 @@ -- "__v0" -- >>> toGremlin var_str -- "__v1"--- >>> sortBy (comparing fst) $ HashMap.toList binding+-- >>> sortBy (comparing fst) $ KeyMap.toList binding -- [("__v0",Number 10.0),("__v1",String "hoge")] newtype Binder a = Binder { unBinder :: State BinderS a } deriving (Functor, Applicative, Monad)@@ -91,8 +92,8 @@ where (ret, state) = State.runState (unBinder binder) initBinderS values = varBindings state- binding = HM.fromList $ zip (map toPlaceHolderVariableStrict [0 ..]) $ values- toPlaceHolderVariableStrict = TL.toStrict . toPlaceHolderVariable+ binding = KM.fromList $ zip (map toPlaceHolderVariableKey [0 ..]) $ values+ toPlaceHolderVariableKey = Key.fromText . TL.toStrict . toPlaceHolderVariable -- | __This type is only for internal use.__ type PlaceHolderIndex = Int
src/Data/Greskell/Extra.hs view
@@ -60,7 +60,7 @@ -- >>> import Data.Greskell.GTraversal (GTraversal, source, sV', gHas2, (&.), gAddV) -- >>> import Data.List (sortBy) -- >>> import Data.Ord (comparing)--- >>> import qualified Data.HashMap.Strict as HashMap+-- >>> import qualified Data.Aeson.KeyMap as KeyMap -- $readers --@@ -77,7 +77,7 @@ -- >>> let (walk, binding) = runBinder binder -- >>> toGremlin walk -- "__.property(\"age\",__v0).identity()"--- >>> sortBy (comparing fst) $ HashMap.toList binding+-- >>> sortBy (comparing fst) $ KeyMap.toList binding -- [("__v0",Number 21.0)] writePropertyKeyValues :: (ToJSON v, Element e) => [(Text, v)] -> Binder (Walk SideEffect e e) writePropertyKeyValues pairs = fmap writeKeyValues $ mapM toKeyValue pairs@@ -93,7 +93,7 @@ -- >>> 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+-- >>> sortBy (comparing fst) $ KeyMap.toList binding -- [("__v0",Number 21.0),("__v1",String "Josh")] -- -- @since 1.0.0.0@@ -127,7 +127,7 @@ -- >>> let (walk, binding) = runBinder $ writeKeyValues <$> sequence [keyNName <=?> Nothing, keyCompany <=?> Just "foobar.com"] -- >>> toGremlin walk -- "__.property(\"company\",__v0).identity()"--- >>> sortBy (comparing fst) $ HashMap.toList binding+-- >>> sortBy (comparing fst) $ KeyMap.toList binding -- [("__v0",String "foobar.com")] -- -- @since 1.0.0.0
src/Data/Greskell/GTraversal.hs view
@@ -199,7 +199,11 @@ gBy, gBy1, gBy2,- gByL+ gByL,+ -- * Only for tests+ showWalkType,+ showLift,+ showSplit ) where import Control.Applicative ((<$>), (<*>))@@ -211,6 +215,7 @@ import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid ((<>), mconcat, Monoid(..))+import Data.Proxy (Proxy) import Data.Semigroup (Semigroup, sconcat) import qualified Data.Semigroup as Semigroup import Data.String (IsString(..))@@ -373,7 +378,9 @@ -- | Class of phantom type markers to describe the effect of the -- walk/traversals.-class WalkType t+class WalkType t where+ -- | Only for tests.+ showWalkType :: Proxy t -> String -- | WalkType for filtering steps. --@@ -391,7 +398,8 @@ -- > gAnd [w1, w2] == w1 >>> w2 == w2 >>> w1 data Filter -instance WalkType Filter+instance WalkType Filter where+ showWalkType _ = "Filter" -- | WalkType for steps without any side-effects. This includes -- transformations, reordring, injections and graph traversal actions.@@ -403,7 +411,8 @@ -- Obviously, every 'Filter' type 'Walk's are also 'Transform' type. data Transform -instance WalkType Transform+instance WalkType Transform where+ showWalkType _ = "Transform" -- | WalkType for steps that may have side-effects. --@@ -421,30 +430,50 @@ -- > .map { some_variable += 1 } data SideEffect -instance WalkType SideEffect+instance WalkType SideEffect where+ showWalkType _ = "SideEffect" -- | Relation of 'WalkType's where one includes the other. @from@ can -- be lifted to @to@, because @to@ is more powerful than @from@.-class Lift from to+class Lift from to where+ -- | Only for tests.+ showLift :: Proxy from -> Proxy to -> String -instance (WalkType c) => Lift Filter c-instance Lift Transform Transform-instance Lift Transform SideEffect-instance Lift SideEffect SideEffect+genericShowLift :: (WalkType from, WalkType to) => Proxy from -> Proxy to -> String+genericShowLift f t = "Lift " <> showWalkType f <> " " <> showWalkType t +instance (WalkType c) => Lift Filter c where+ showLift = genericShowLift+instance Lift Transform Transform where+ showLift = genericShowLift+instance Lift Transform SideEffect where+ showLift = genericShowLift+instance Lift SideEffect SideEffect where+ showLift = genericShowLift+ -- | Relation of 'WalkType's where the child walk @c@ is split from -- the parent walk @p@. -- -- When splitting, transformation effect done in the child walk is -- rolled back (canceled) in the parent walk.-class Split c p+class Split c p where+ -- | Only for tests.+ showSplit :: Proxy c -> Proxy p -> String -instance (WalkType p) => Split Filter p-instance (WalkType p) => Split Transform p--- ^ 'Transform' effect in the child walk is rolled back in the parent+genericShowSplit :: (WalkType c, WalkType p) => Proxy c -> Proxy p -> String+genericShowSplit c p = "Split " <> showWalkType c <> " " <> showWalkType p++instance (WalkType p) => Split Filter p where+ showSplit = genericShowSplit++-- | 'Transform' effect in the child walk is rolled back in the parent -- walk.-instance Split SideEffect SideEffect--- ^ 'SideEffect' in the child walk remains in the parent walk.+instance (WalkType p) => Split Transform p where+ showSplit = genericShowSplit++-- | 'SideEffect' in the child walk remains in the parent walk.+instance Split SideEffect SideEffect where+ showSplit = genericShowSplit -- | @GraphTraversalSource@ class object of TinkerPop. It is a factory
src/Data/Greskell/Graph/PropertyMap.hs view
@@ -27,6 +27,8 @@ import Control.Applicative (empty, (<|>)) import Data.Aeson (FromJSON(..)) import Data.Aeson.Types (Parser)+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Key as Key import Data.Foldable (Foldable(..), foldlM) import Data.Greskell.GraphSON ( FromGraphSON(..), GValue, GraphSONTyped(..), (.:),@@ -145,11 +147,11 @@ -> GValue -> Parser (m p v) parsePropertiesGeneric normalizeCardinality gv = case gValueBody gv of- GObject obj -> foldlM folder mempty $ HM.toList obj+ GObject obj -> foldlM folder mempty $ KM.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+ parseProperty k value = parseTypedGValue value <|> parseGraphSONWithKey (Key.toText k) value -- parhaps we might as well place it in GraphSON module and let it export. parseTypedGValue :: (GraphSONTyped v, FromGraphSON v) => GValue -> Parser v
test/Data/Greskell/BinderSpec.hs view
@@ -3,7 +3,8 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad (forM_) import Data.Aeson (toJSON)-import qualified Data.HashMap.Strict as HM+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Key as Key import Data.Text (unpack) import Test.Hspec @@ -25,6 +26,9 @@ variableHeads = '_' : (['a' .. 'z'] ++ ['A' .. 'Z']) variableRests = variableHeads ++ ['0' .. '9'] +toKey :: Greskell a -> Key.Key+toKey = Key.fromText . toGremlin+ spec :: Spec spec = describe "Binder" $ do it "should keep bound values" $ do@@ -36,8 +40,8 @@ toGremlin got_v1 `shouldNotBe` toGremlin got_v2 shouldBeVariable got_v1 shouldBeVariable got_v2- got_bind `shouldBe` HM.fromList [ (toGremlin got_v1, toJSON (100 :: Int)),- (toGremlin got_v2, toJSON "hogehoge")+ got_bind `shouldBe` KM.fromList [ (toKey got_v1, toJSON (100 :: Int)),+ (toKey got_v2, toJSON "hogehoge") ] it "should compose and produce new variables" $ do let b = newBind "foobar"@@ -45,8 +49,8 @@ toGremlin got_v1 `shouldNotBe` toGremlin got_v2 shouldBeVariable got_v1 shouldBeVariable got_v2- got_bind `shouldBe` HM.fromList [ (toGremlin got_v1, toJSON "foobar"),- (toGremlin got_v2, toJSON "foobar")+ got_bind `shouldBe` KM.fromList [ (toKey got_v1, toJSON "foobar"),+ (toKey got_v2, toJSON "foobar") ] it "should also be able to produce AsLabels" $ do let newIntLabel :: Binder (AsLabel Int)
test/Data/Greskell/ExtraSpec.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Data.Greskell.ExtraSpec (main,spec) where +import qualified Data.Aeson.KeyMap as KM import Data.Monoid (mempty, (<>)) import Data.Text (Text) import Test.Hspec@@ -11,7 +12,6 @@ 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 main :: IO () main = hspec spec@@ -33,7 +33,7 @@ input = [("age", 24)] (runBoundWalk $ writePropertyKeyValues input) `shouldBe` ( "__.property(\"age\",__v0).identity()",- HM.fromList [("__v0", Number 24)]+ KM.fromList [("__v0", Number 24)] ) specify "multiple props" $ do let input :: [(Text, Value)]@@ -41,7 +41,7 @@ (runBoundWalk $ writePropertyKeyValues input) `shouldBe` ( "__.property(\"age\",__v0).property(\"name\",__v1)" <> ".property(\"foo\",__v2).identity()",- HM.fromList [ ("__v0", Number 24),+ KM.fromList [ ("__v0", Number 24), ("__v1", String "Toshio"), ("__v2", String "bar") ]
− test/HintTest.hs
@@ -1,77 +0,0 @@-module Main (main,spec) where--import Data.Either (isRight)-import Language.Haskell.Interpreter- ( loadModules, OptionVal((:=)), set, searchPath,- setTopLevelModules, runInterpreter, InterpreterError,- typeOf- )-import System.IO (hPutStrLn, stderr)-import Test.Hspec--main :: IO ()-main = hspec spec--spec :: Spec-spec = spec_WalkType_classes--spec_WalkType_classes :: Spec-spec_WalkType_classes = do- describe "Split typeclass" $ do- let c = checkSplitCompatible- c "Filter" "Filter" True- c "Filter" "Transform" True- c "Filter" "SideEffect" True- c "Transform" "Filter" True- c "Transform" "Transform" True- c "Transform" "SideEffect" True- c "SideEffect" "Filter" False- c "SideEffect" "Transform" False- c "SideEffect" "SideEffect" True- describe "Lift typeclass" $ do- let c = checkLiftCompatible- c "Filter" "Filter" True- c "Filter" "Transform" True- c "Filter" "SideEffect" True- c "Transform" "Filter" False- c "Transform" "Transform" True- c "Transform" "SideEffect" True- c "SideEffect" "Filter" False- c "SideEffect" "Transform" False- c "SideEffect" "SideEffect" True- -toErrString :: Either InterpreterError a -> Either String a-toErrString (Right a) = Right a-toErrString (Left e) = Left $ show e--checkWalkTypeRelation :: (String -> String -> String) -> String -> String -> Bool -> Spec-checkWalkTypeRelation makeCode child parent expect_ok = specify label $ doCheck- where- label = child ++ " -> " ++ parent- doCheck = do- result <- fmap toErrString $ runInterpreter compiledParent- -- hPutStrLn stderr ("## " ++ label ++ ": " ++ show result)- isRight result `shouldBe` expect_ok- compiledParent = do- set [searchPath := ["src"]]- loadModules ["src/Data/Greskell/GTraversal.hs"]- setTopLevelModules ["Data.Greskell.GTraversal"]- typeOf $ makeCode child parent--checkSplitCompatible :: String -> String -> Bool -> Spec-checkSplitCompatible = checkWalkTypeRelation makeCode- where- makeCode child parent =- "let f :: Walk " ++ child ++ " s s -> Walk " ++ parent ++ " s s; "- ++ "f = gFilter; "- ++ "child :: Walk " ++ child ++ " s s; "- ++ "child = undefined; "- ++ "in f child"--checkLiftCompatible :: String -> String -> Bool -> Spec-checkLiftCompatible = checkWalkTypeRelation makeCode- where- makeCode child parent =- "let f :: Walk " ++ child ++ " s e -> Walk " ++ parent ++ " s e; "- ++ "f = liftWalk; "- ++ "in f"
+ test/Typecheck.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}+module Main (main,spec) where++import Data.Proxy (Proxy(..))+import Test.Hspec+import Test.ShouldNotTypecheck (shouldNotTypecheck)++import Data.Greskell.GTraversal+ ( Walk, WalkType, Filter, Transform, SideEffect, Split,+ showSplit, showWalkType, showLift+ )++main :: IO ()+main = hspec spec++pF :: Proxy Filter+pF = Proxy++pT :: Proxy Transform+pT = Proxy++pS :: Proxy SideEffect+pS = Proxy++spec :: Spec+spec = do+ describe "Split typeclass" $ do+ specify (label pF pF) $ shouldTypecheck (showSplit pF pF)+ specify (label pF pT) $ shouldTypecheck (showSplit pF pT)+ specify (label pF pS) $ shouldTypecheck (showSplit pF pS)+ specify (label pT pF) $ shouldTypecheck (showSplit pT pF)+ specify (label pT pT) $ shouldTypecheck (showSplit pT pT)+ specify (label pT pS) $ shouldTypecheck (showSplit pT pS)+ specify (label pS pF) $ shouldNotTypecheck (showSplit pS pF)+ specify (label pS pT) $ shouldNotTypecheck (showSplit pS pT)+ specify (label pS pS) $ shouldTypecheck (showSplit pS pS)+ describe "Lift typeclass" $ do+ specify (label pF pF) $ shouldTypecheck (showLift pF pF)+ specify (label pF pT) $ shouldTypecheck (showLift pF pT)+ specify (label pF pS) $ shouldTypecheck (showLift pF pS)+ specify (label pT pF) $ shouldNotTypecheck (showLift pT pF)+ specify (label pT pT) $ shouldTypecheck (showLift pT pT)+ specify (label pT pS) $ shouldTypecheck (showLift pT pS)+ specify (label pS pF) $ shouldNotTypecheck (showLift pS pF)+ specify (label pS pT) $ shouldNotTypecheck (showLift pS pT)+ specify (label pS pS) $ shouldTypecheck (showLift pS pS)+ ++label :: (WalkType a, WalkType b) => Proxy a -> Proxy b -> String+label a b = showWalkType a ++ " -> " ++ showWalkType b++shouldTypecheck :: String -> Expectation+shouldTypecheck s = length s `shouldSatisfy` (> 0)