diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`. diff --git a/greskell.cabal b/greskell.cabal --- a/greskell.cabal +++ b/greskell.cabal @@ -1,5 +1,5 @@ name: greskell -version: 1.2.0.2 +version: 2.0.0.0 author: Toshio Ito maintainer: Toshio Ito 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 diff --git a/src/Data/Greskell/Binder.hs b/src/Data/Greskell/Binder.hs --- a/src/Data/Greskell/Binder.hs +++ b/src/Data/Greskell/Binder.hs @@ -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 diff --git a/src/Data/Greskell/Extra.hs b/src/Data/Greskell/Extra.hs --- a/src/Data/Greskell/Extra.hs +++ b/src/Data/Greskell/Extra.hs @@ -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 diff --git a/src/Data/Greskell/GTraversal.hs b/src/Data/Greskell/GTraversal.hs --- a/src/Data/Greskell/GTraversal.hs +++ b/src/Data/Greskell/GTraversal.hs @@ -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 diff --git a/src/Data/Greskell/Graph/PropertyMap.hs b/src/Data/Greskell/Graph/PropertyMap.hs --- a/src/Data/Greskell/Graph/PropertyMap.hs +++ b/src/Data/Greskell/Graph/PropertyMap.hs @@ -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 diff --git a/test/Data/Greskell/BinderSpec.hs b/test/Data/Greskell/BinderSpec.hs --- a/test/Data/Greskell/BinderSpec.hs +++ b/test/Data/Greskell/BinderSpec.hs @@ -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) diff --git a/test/Data/Greskell/ExtraSpec.hs b/test/Data/Greskell/ExtraSpec.hs --- a/test/Data/Greskell/ExtraSpec.hs +++ b/test/Data/Greskell/ExtraSpec.hs @@ -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") ] diff --git a/test/HintTest.hs b/test/HintTest.hs deleted file mode 100644 --- a/test/HintTest.hs +++ /dev/null @@ -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" diff --git a/test/Typecheck.hs b/test/Typecheck.hs new file mode 100644 --- /dev/null +++ b/test/Typecheck.hs @@ -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)