From 0ad7c887da21afe2ba4d460f98edf2d8544c2fcc Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 19 Nov 2024 17:08:50 -0700 Subject: [PATCH 1/3] Remove `ImpSpec` from the repository * New home for the `ImpSpec` testing library is here: https://github.com/input-output-hk/ImpSpec * It is also released to Hackage: https://hackage.haskell.org/package/ImpSpec --- cabal.project | 1 - libs/ImpSpec/CHANGELOG.md | 5 - libs/ImpSpec/ImpSpec.cabal | 65 --- libs/ImpSpec/Setup.hs | 3 - libs/ImpSpec/src/Test/ImpSpec.hs | 8 - libs/ImpSpec/src/Test/ImpSpec/Expectations.hs | 163 -------- .../src/Test/ImpSpec/Expectations/Lifted.hs | 148 ------- libs/ImpSpec/src/Test/ImpSpec/Internal.hs | 388 ------------------ libs/ImpSpec/src/Test/ImpSpec/Main.hs | 31 -- libs/ImpSpec/src/Test/ImpSpec/Random.hs | 81 ---- libs/ImpSpec/test/Main.hs | 7 - libs/ImpSpec/test/Test/Suite/ImpSpec.hs | 21 - 12 files changed, 921 deletions(-) delete mode 100644 libs/ImpSpec/CHANGELOG.md delete mode 100644 libs/ImpSpec/ImpSpec.cabal delete mode 100644 libs/ImpSpec/Setup.hs delete mode 100644 libs/ImpSpec/src/Test/ImpSpec.hs delete mode 100644 libs/ImpSpec/src/Test/ImpSpec/Expectations.hs delete mode 100644 libs/ImpSpec/src/Test/ImpSpec/Expectations/Lifted.hs delete mode 100644 libs/ImpSpec/src/Test/ImpSpec/Internal.hs delete mode 100644 libs/ImpSpec/src/Test/ImpSpec/Main.hs delete mode 100644 libs/ImpSpec/src/Test/ImpSpec/Random.hs delete mode 100644 libs/ImpSpec/test/Main.hs delete mode 100644 libs/ImpSpec/test/Test/Suite/ImpSpec.hs diff --git a/cabal.project b/cabal.project index 83bc444b000..353dc2e74e5 100644 --- a/cabal.project +++ b/cabal.project @@ -69,7 +69,6 @@ packages: libs/cardano-data libs/set-algebra libs/vector-map - libs/ImpSpec -- == Byron era == -- byron-spec-chain: diff --git a/libs/ImpSpec/CHANGELOG.md b/libs/ImpSpec/CHANGELOG.md deleted file mode 100644 index 2e062d91441..00000000000 --- a/libs/ImpSpec/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Version history for `ImpSpec` - -## 0.1.0.0 - -* diff --git a/libs/ImpSpec/ImpSpec.cabal b/libs/ImpSpec/ImpSpec.cabal deleted file mode 100644 index 5f18cec5d7c..00000000000 --- a/libs/ImpSpec/ImpSpec.cabal +++ /dev/null @@ -1,65 +0,0 @@ -cabal-version: 3.0 -name: ImpSpec -version: 0.1.0.0 -license: Apache-2.0 -maintainer: operations@iohk.io -author: IOHK -homepage: https://github.com/intersectmbo/cardano-ledger -synopsis: - Imperative approach of testing that extends HSpec and QuickCheck - -category: Control -build-type: Simple -extra-source-files: CHANGELOG.md - -source-repository head - type: git - location: https://github.com/intersectmbo/cardano-ledger - subdir: libs/ImpSpec - -library - exposed-modules: - Test.ImpSpec - Test.ImpSpec.Expectations - Test.ImpSpec.Expectations.Lifted - Test.ImpSpec.Main - Test.ImpSpec.Random - - hs-source-dirs: src - other-modules: Test.ImpSpec.Internal - default-language: Haskell2010 - ghc-options: - -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints -Wunused-packages - - build-depends: - base >=4.14 && <5, - bytestring, - deepseq, - hspec, - hspec-core, - hspec-expectations-lifted, - HUnit, - mtl, - QuickCheck, - quickcheck-transformer, - prettyprinter, - prettyprinter-ansi-terminal, - random, - text, - unliftio - -test-suite tests - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - other-modules: Test.Suite.ImpSpec - default-language: Haskell2010 - ghc-options: - -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints -Wunused-packages - -threaded -rtsopts - - build-depends: - base, - ImpSpec diff --git a/libs/ImpSpec/Setup.hs b/libs/ImpSpec/Setup.hs deleted file mode 100644 index e8ef27dbba9..00000000000 --- a/libs/ImpSpec/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/libs/ImpSpec/src/Test/ImpSpec.hs b/libs/ImpSpec/src/Test/ImpSpec.hs deleted file mode 100644 index 9630fcbe4db..00000000000 --- a/libs/ImpSpec/src/Test/ImpSpec.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Test.ImpSpec (module X) where - -import Test.Hspec as X (Spec, SpecWith, describe, fdescribe, fit, it, xdescribe, xit) -import Test.Hspec.QuickCheck as X (fprop, prop, xprop) -import Test.ImpSpec.Expectations.Lifted as X -import Test.ImpSpec.Internal as X -import Test.ImpSpec.Main as X -import Test.ImpSpec.Random as X diff --git a/libs/ImpSpec/src/Test/ImpSpec/Expectations.hs b/libs/ImpSpec/src/Test/ImpSpec/Expectations.hs deleted file mode 100644 index 144e3a694d1..00000000000 --- a/libs/ImpSpec/src/Test/ImpSpec/Expectations.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -module Test.ImpSpec.Expectations ( - -- * Expectations - - -- ** Common - assertBool, - assertFailure, - expectationFailure, - shouldBe, - shouldSatisfy, - shouldStartWith, - shouldEndWith, - shouldContain, - shouldMatchList, - shouldReturn, - shouldNotBe, - shouldNotSatisfy, - shouldNotContain, - shouldNotReturn, - shouldThrow, - Selector, - - -- ** Custom - assertColorFailure, - - -- *** Either - shouldBeRight, - shouldBeLeft, - expectRight, - expectRightDeep, - expectRightDeep_, - expectLeft, - expectLeftDeep, - expectLeftDeep_, - - -- *** Maybe - shouldBeJust, - expectJust, - expectJustDeep, - expectJustDeep_, - expectNothing, - - -- * CallStack helpers - callStackToLocation, - srcLocToLocation, -) where - -import Control.DeepSeq (NFData) -import Control.Monad (void, (>=>)) -import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack) -import Test.HUnit.Base (assertBool, assertFailure) -import Test.Hspec ( - Expectation, - Selector, - expectationFailure, - shouldBe, - shouldContain, - shouldEndWith, - shouldMatchList, - shouldNotBe, - shouldNotContain, - shouldNotReturn, - shouldNotSatisfy, - shouldReturn, - shouldSatisfy, - shouldStartWith, - shouldThrow, - ) -import Test.Hspec.Core.Spec (FailureReason (ColorizedReason), Location (..), ResultStatus (Failure)) -import UnliftIO.Exception (evaluateDeep, throwIO) - -infix 1 `shouldBeRight` - , `shouldBeLeft` - --- | Similar to `assertFailure`, except hspec will not interfer with any escape sequences --- that indicate color output. -assertColorFailure :: HasCallStack => String -> IO a -assertColorFailure msg = - throwIO $ Failure (callStackToLocation ?callStack) (ColorizedReason msg) - --- | Return value on the `Right` and fail otherwise. --- --- Difference from @`shouldSatisfy` action `Data.Either.isRight`@ in that `expectRight` --- will force the content of the `Right` to WHNF and return it. This expectation will also --- show the content of the `Left` when expectation fails. -expectRight :: (HasCallStack, Show a) => Either a b -> IO b -expectRight (Right r) = pure $! r -expectRight (Left l) = assertFailure $ "Expected Right, got Left:\n" <> show l - --- | Same as `expectRight`, but also evaluate the returned value to NF -expectRightDeep :: (HasCallStack, Show a, NFData b) => Either a b -> IO b -expectRightDeep = expectRight >=> evaluateDeep - --- | Same as `expectRightDeep`, but discards the result -expectRightDeep_ :: (HasCallStack, Show a, NFData b) => Either a b -> IO () -expectRightDeep_ = void . expectRightDeep - --- | Same as `shouldBe`, except it checks that the value is `Right` -shouldBeRight :: (HasCallStack, Show a, Show b, Eq b) => Either a b -> b -> Expectation -shouldBeRight e x = expectRight e >>= (`shouldBe` x) - --- | Return value on the `Left` an fail otherwise --- --- Difference from @`shouldSatisfy` action `Data.Either.isLeft`@ in that `expectLeft` will --- force the content of the `Left` to WHNF and and return it. This expectation will also --- show the content of the `Right` when expectation fails. -expectLeft :: (HasCallStack, Show b) => Either a b -> IO a -expectLeft (Left l) = pure $! l -expectLeft (Right r) = assertFailure $ "Expected Left, got Right:\n" <> show r - --- | Same as `expectLeft`, but also evaluate the returned value to NF -expectLeftDeep :: (HasCallStack, NFData a, Show b) => Either a b -> IO a -expectLeftDeep = expectLeft >=> evaluateDeep - --- | Same as `expectLeftDeep`, but discards the result -expectLeftDeep_ :: (HasCallStack, NFData a, Show b) => Either a b -> IO () -expectLeftDeep_ = void . expectLeftDeep - --- | Same as `shouldBe`, except it checks that the value is `Left` -shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b) => Either a b -> a -> Expectation -shouldBeLeft e x = expectLeft e >>= (`shouldBe` x) - --- | Same as `shouldBe`, except it checks that the value is `Just` -shouldBeJust :: (HasCallStack, Show a, Eq a) => Maybe a -> a -> Expectation -shouldBeJust e x = expectJust e >>= (`shouldBe` x) - --- | Return value from the `Just` an fail otherwise --- --- Difference from @`shouldSatisfy` action `isJust`@ in that `expectJust` will force the --- content of the `Just` to WHNF and it will also return it. -expectJust :: HasCallStack => Maybe a -> IO a -expectJust (Just x) = pure $! x -expectJust Nothing = assertFailure "Expected Just, got Nothing" - --- | Same as `expectJust`, but will force the value to NF -expectJustDeep :: (HasCallStack, NFData a) => Maybe a -> IO a -expectJustDeep = expectJust >=> evaluateDeep - --- | Same as `expectJustDeep`, but will discard the forced contents of `Just` -expectJustDeep_ :: (HasCallStack, NFData a) => Maybe a -> IO () -expectJustDeep_ = void . expectJustDeep - --- | Same as @`shouldSatisfy` action `Data.Maybe.isNothing`@ -expectNothing :: (HasCallStack, Show a) => Maybe a -> IO () -expectNothing (Just x) = assertFailure $ "Expected Nothing, got Just: " ++ show x -expectNothing Nothing = pure () - --- | Convert the top call from the `CallStack` to hspec's `Location` -callStackToLocation :: CallStack -> Maybe Location -callStackToLocation cs = - case getCallStack cs of - [] -> Nothing - (_, loc) : _ -> Just $ srcLocToLocation loc - --- | Convert `SrcLoc` to hspec's `Location` -srcLocToLocation :: SrcLoc -> Location -srcLocToLocation loc = - Location - { locationFile = srcLocFile loc - , locationLine = srcLocStartLine loc - , locationColumn = srcLocStartCol loc - } diff --git a/libs/ImpSpec/src/Test/ImpSpec/Expectations/Lifted.hs b/libs/ImpSpec/src/Test/ImpSpec/Expectations/Lifted.hs deleted file mode 100644 index cd77b05e495..00000000000 --- a/libs/ImpSpec/src/Test/ImpSpec/Expectations/Lifted.hs +++ /dev/null @@ -1,148 +0,0 @@ -module Test.ImpSpec.Expectations.Lifted ( - -- * Lifted Expectations - io, - - -- ** Common - assertBool, - assertFailure, - expectationFailure, - shouldBe, - shouldSatisfy, - shouldStartWith, - shouldEndWith, - shouldContain, - shouldMatchList, - shouldReturn, - shouldNotBe, - shouldNotSatisfy, - shouldNotContain, - shouldNotReturn, - shouldThrow, - IO.Selector, - - -- ** Custom - assertColorFailure, - - -- *** Either - shouldBeRight, - shouldBeLeft, - expectRight, - expectRightDeep, - expectRightDeep_, - expectLeft, - expectLeftDeep, - expectLeftDeep_, - - -- *** Maybe - shouldBeJust, - expectJust, - expectJustDeep, - expectJustDeep_, - expectNothing, -) where - -import Control.DeepSeq (NFData) -import GHC.Stack (HasCallStack) -import Test.Hspec.Expectations.Lifted ( - expectationFailure, - shouldBe, - shouldContain, - shouldEndWith, - shouldMatchList, - shouldNotBe, - shouldNotContain, - shouldNotReturn, - shouldNotSatisfy, - shouldReturn, - shouldSatisfy, - shouldStartWith, - ) -import qualified Test.ImpSpec.Expectations as IO -import UnliftIO (Exception, MonadIO (liftIO), MonadUnliftIO, withRunInIO) - -infix 1 `shouldThrow` - , `shouldBeRight` - , `shouldBeLeft` - --- | Enforce the type of expectation --- --- Useful with polymorphic expectations that are defined below. --- --- ===__Example__ --- --- Because `shouldBeExpr` is polymorphic in `m`, compiler will choke with a unification --- error. This is due to the fact that hspec's `it` expects a polymorphic `Example`. --- --- > it "MyTest" $ do --- > "foo" `shouldBeExpr` "bar" --- --- However, this is easily solved by `io`: --- --- > it "MyTest" $ io $ do --- > "foo" `shouldBeExpr` "bar" -io :: IO a -> IO a -io = id - --- | Just like `expectationFailure`, but does not force the return type to unit. Lifted --- version of `H.assertFailure` -assertFailure :: (HasCallStack, MonadIO m) => String -> m a -assertFailure = liftIO . IO.assertFailure - -assertColorFailure :: (HasCallStack, MonadIO m) => String -> m a -assertColorFailure = liftIO . IO.assertColorFailure - --- | Lifted version of `H.assertBool` -assertBool :: (HasCallStack, MonadIO m) => String -> Bool -> m () -assertBool msg = liftIO . IO.assertBool msg - --- | Lifted version of `shouldThrow`. -shouldThrow :: (HasCallStack, Exception e, MonadUnliftIO m) => m a -> IO.Selector e -> m () -shouldThrow f s = withRunInIO $ \run -> IO.shouldThrow (run f) s - --- | Return value on the `Right` and fail otherwise. Lifted version of `H.expectRight`. -expectRight :: (HasCallStack, Show a, MonadIO m) => Either a b -> m b -expectRight = liftIO . IO.expectRight - --- | Same as `expectRight`, but also evaluate the returned value to NF -expectRightDeep :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m b -expectRightDeep = liftIO . IO.expectRightDeep - --- | Same as `expectRightDeep`, but discards the result -expectRightDeep_ :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m () -expectRightDeep_ = liftIO . IO.expectRightDeep_ - --- | Same as `shouldBe`, except it checks that the value is `Right` -shouldBeRight :: (HasCallStack, Show a, Show b, Eq b, MonadIO m) => Either a b -> b -> m () -shouldBeRight e = liftIO . IO.shouldBeRight e - --- | Return value on the `Left` and fail otherwise -expectLeft :: (HasCallStack, Show b, MonadIO m) => Either a b -> m a -expectLeft = liftIO . IO.expectLeft - --- | Same as `expectLeftDeep`, but discards the result -expectLeftDeep_ :: (HasCallStack, NFData a, Show b, MonadIO m) => Either a b -> m () -expectLeftDeep_ = liftIO . IO.expectLeftDeep_ - --- | Same as `expectLeft`, but also evaluate the returned value to NF -expectLeftDeep :: (HasCallStack, NFData a, Show b, MonadIO m) => Either a b -> m a -expectLeftDeep = liftIO . IO.expectLeftDeep - --- | Same as `shouldBe`, except it checks that the value is `Left` -shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b, MonadIO m) => Either a b -> a -> m () -shouldBeLeft e x = liftIO $ e `IO.shouldBeLeft` x - --- | Same as `shouldBe`, except it checks that the value is `Just` -shouldBeJust :: (HasCallStack, Show a, Eq a, MonadIO m) => Maybe a -> a -> m () -shouldBeJust e x = liftIO $ e `IO.shouldBeJust` x - -expectJust :: (HasCallStack, MonadIO m) => Maybe a -> m a -expectJust = liftIO . IO.expectJust - -expectJustDeep :: (HasCallStack, NFData a, MonadIO m) => Maybe a -> m a -expectJustDeep = liftIO . IO.expectJustDeep - -expectJustDeep_ :: (HasCallStack, NFData a, MonadIO m) => Maybe a -> m () -expectJustDeep_ = liftIO . IO.expectJustDeep_ - -expectNothing :: (HasCallStack, Show a, MonadIO m) => Maybe a -> m () -expectNothing = liftIO . IO.expectNothing diff --git a/libs/ImpSpec/src/Test/ImpSpec/Internal.hs b/libs/ImpSpec/src/Test/ImpSpec/Internal.hs deleted file mode 100644 index cb9e58c7970..00000000000 --- a/libs/ImpSpec/src/Test/ImpSpec/Internal.hs +++ /dev/null @@ -1,388 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Test.ImpSpec.Internal where - -import Control.DeepSeq (NFData) -import Control.Monad (void) -import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) -import Control.Monad.State.Strict (MonadState (..)) -import Data.Kind (Type) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import qualified Data.Text.Lazy as TL -import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack) -import Prettyprinter ( - Doc, - Pretty (..), - annotate, - defaultLayoutOptions, - hcat, - indent, - layoutPretty, - line, - vsep, - ) -import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, renderLazy) -import System.Random (randomR, split) -import System.Random.Stateful (IOGenM, applyIOGen, newIOGenM) -import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..)) -import Test.Hspec (Spec, SpecWith, beforeAll, beforeAllWith) -import Test.Hspec.Core.Spec ( - Example (..), - Result (..), - paramsQuickCheckArgs, - ) -import qualified Test.Hspec.Core.Spec as H -import Test.ImpSpec.Expectations -import Test.ImpSpec.Random -import Test.QuickCheck (Arbitrary, Args (chatty, replay), Testable (..), counterexample, ioProperty) -import Test.QuickCheck.Gen (Gen (..)) -import Test.QuickCheck.GenT (MonadGen (..)) -import Test.QuickCheck.Random (QCGen (..), integerVariant, mkQCGen) -import UnliftIO (MonadIO (liftIO), MonadUnliftIO (..)) -import UnliftIO.Exception ( - Exception (..), - SomeException (..), - catchAny, - catchAnyDeep, - throwIO, - ) -import UnliftIO.IORef - -data ImpState t = ImpState - { impStateSpecState :: !(ImpSpecState t) - , impStateLog :: !(Doc AnsiStyle) - } - -data ImpEnv t = ImpEnv - { impEnvSpecEnv :: !(ImpSpecEnv t) - , impEnvStateRef :: !(IORef (ImpState t)) - , impEnvQCGenRef :: !(IOGenM QCGen) - , impEnvQCSize :: !Int - } - -class ImpSpec t where - type ImpSpecEnv t = (r :: Type) | r -> t - type ImpSpecEnv t = Proxy t - type ImpSpecState t = (r :: Type) | r -> t - type ImpSpecState t = Proxy t - - impInitIO :: QCGen -> IO (ImpInit t) - default impInitIO :: (ImpSpecEnv t ~ Proxy t, ImpSpecState t ~ Proxy t) => QCGen -> IO (ImpInit t) - impInitIO _ = pure $ ImpInit Proxy Proxy - - -- | This will be the very first action that will run in all `ImpM` specs. - impPrepAction :: ImpM t () - impPrepAction = pure () - -data ImpInit t = ImpInit - { impInitEnv :: ImpSpecEnv t - , impInitState :: ImpSpecState t - } -deriving instance (Eq (ImpSpecEnv t), Eq (ImpSpecState t)) => Eq (ImpInit t) -deriving instance (Ord (ImpSpecEnv t), Ord (ImpSpecState t)) => Ord (ImpInit t) -deriving instance (Show (ImpSpecEnv t), Show (ImpSpecState t)) => Show (ImpInit t) - --- | Stores extra information about the failure of the unit test -data ImpException = ImpException - { ieAnnotation :: [Doc AnsiStyle] - -- ^ Description of the IO action that caused the failure - , ieThrownException :: SomeException - -- ^ Exception that caused the test to fail - } - deriving (Show) - -instance Exception ImpException where - displayException = ansiDocToString . prettyImpException - -prettyImpException :: ImpException -> Doc AnsiStyle -prettyImpException (ImpException ann e) = - vsep $ - mconcat - [ ["Annotations:"] - , zipWith indent [0, 2 ..] ann - , ["Failed with Exception:", indent 4 $ pretty (displayException e)] - ] - -newtype ImpM t a = ImpM {unImpM :: ReaderT (ImpEnv t) IO a} - deriving - ( Functor - , Applicative - , Monad - , MonadIO - , MonadUnliftIO - ) - -instance env ~ ImpSpecEnv t => MonadReader env (ImpM t) where - ask = impEnvSpecEnv <$> ImpM ask - local f = ImpM . local (\e -> e {impEnvSpecEnv = f (impEnvSpecEnv e)}) . unImpM - -instance MonadFail (ImpM t) where - fail = liftIO . assertFailure - -instance s ~ ImpSpecState t => MonadState s (ImpM t) where - state f = do - ImpEnv {impEnvStateRef} <- ImpM ask - curState <- readIORef impEnvStateRef - let !(result, !newSpecState) = f $ impStateSpecState curState - writeIORef impEnvStateRef (curState {impStateSpecState = newSpecState}) - pure result - get = fmap impStateSpecState . readIORef . impEnvStateRef =<< ImpM ask - -instance MonadGen (ImpM t) where - liftGen (MkGen f) = do - qcSize <- ImpM $ asks impEnvQCSize - qcGen <- applyQCGen split - pure $ f qcGen qcSize - variant n action = do - applyQCGen $ \qcGen -> ((), integerVariant (toInteger n) qcGen) - action - sized f = ImpM (asks impEnvQCSize) >>= f - resize n (ImpM f) = ImpM $ local (\env -> env {impEnvQCSize = n}) f - choose r = applyQCGen (randomR r) - -instance HasStatefulGen (IOGenM QCGen) (ImpM t) where - askStatefulGen = ImpM $ asks impEnvQCGenRef - -instance (ImpSpec t, Testable a) => Testable (ImpM t a) where - property m = property $ MkGen $ \qcGen qcSize -> - ioProperty $ do - let (qcGen1, qcGen2) = split qcGen - impInit <- impInitIO qcGen1 - evalImpM (Just qcGen2) (Just qcSize) impInit m - -instance (ImpSpec t, Testable p) => Example (ImpM t p) where - type Arg (ImpM t p) = ImpInit t - - evaluateExample impTest = evaluateExample (\() -> impTest) - -instance (Arbitrary a, Show a, ImpSpec t, Testable p) => Example (a -> ImpM t p) where - type Arg (a -> ImpM t p) = ImpInit t - - evaluateExample impTest params hook progressCallback = do - let runImpExample impInit = property $ \x -> do - let args = paramsQuickCheckArgs params - mQC = replay (paramsQuickCheckArgs params) - - (r, testable, logs) <- evalImpM (fst <$> mQC) (snd <$> mQC) impInit $ do - t <- impTest x - qcSize <- ImpM $ asks impEnvQCSize - qcGen <- applyQCGen split - logs <- getLogs - pure (Just (qcGen, qcSize), t, logs) - let params' = params {paramsQuickCheckArgs = args {replay = r, chatty = False}} - res <- - evaluateExample - (counterexample (ansiDocToString logs) testable) - params' - (\f -> hook (\_st -> f ())) - progressCallback - void $ throwIO $ resultStatus res - evaluateExample runImpExample params hook progressCallback - -applyQCGen :: (QCGen -> (b, QCGen)) -> ImpM t b -applyQCGen f = do - qcGenRef <- ImpM $ asks impEnvQCGenRef - applyIOGen f qcGenRef - -getLogs :: ImpM t (Doc AnsiStyle) -getLogs = do - ref <- ImpM $ asks impEnvStateRef - impStateLog <$> readIORef ref - -modifyLogs :: (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t () -modifyLogs f = do - ref <- ImpM $ asks impEnvStateRef - modifyIORef ref $ \s -> s {impStateLog = f (impStateLog s)} - --- | Override the QuickCheck generator using a fixed seed. -impSetSeed :: Int -> ImpM t () -impSetSeed seed = applyQCGen $ \_ -> ((), mkQCGen seed) - -evalImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO b) -evalImpGenM impInit = fmap (fmap fst) . runImpGenM impInit - -evalImpM :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b -evalImpM mQCGen mQCSize impInit = fmap fst . runImpM mQCGen mQCSize impInit - -execImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (ImpState t)) -execImpGenM impInit = fmap (fmap snd) . runImpGenM impInit - -execImpM :: - ImpSpec t => - Maybe QCGen -> - Maybe Int -> - ImpInit t -> - ImpM t b -> - IO (ImpState t) -execImpM mQCGen mQCSize impInit = fmap snd . runImpM mQCGen mQCSize impInit - -runImpGenM_ :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO ()) -runImpGenM_ impInit = fmap void . runImpGenM impInit - -runImpM_ :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO () -runImpM_ mQCGen mQCSize impInit = void . runImpM mQCGen mQCSize impInit - -runImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t)) -runImpGenM impInit m = - MkGen $ \qcGen qcSize -> runImpM (Just qcGen) (Just qcSize) impInit m - -runImpM :: - ImpSpec t => - Maybe QCGen -> - Maybe Int -> - ImpInit t -> - ImpM t b -> - IO (b, ImpState t) -runImpM mQCGen mQCSize ImpInit {impInitEnv, impInitState} action = do - let qcSize = fromMaybe 30 mQCSize - qcGen = fromMaybe (mkQCGen 2024) mQCGen - ioRef <- - newIORef $ - ImpState - { impStateSpecState = impInitState - , impStateLog = mempty - } - qcGenRef <- newIOGenM qcGen - let - env = - ImpEnv - { impEnvSpecEnv = impInitEnv - , impEnvStateRef = ioRef - , impEnvQCGenRef = qcGenRef - , impEnvQCSize = qcSize - } - res <- - runReaderT (unImpM (impPrepAction >> action)) env `catchAny` \exc -> do - logs <- impStateLog <$> readIORef ioRef - let x my = case my of - Nothing -> x - Just y -> x ++ [pretty y] - uncaughtException header excThrown = - H.ColorizedReason $ - ansiDocToString $ - vsep $ - header ++ [pretty $ "Uncaught Exception: " <> displayException excThrown] - fromHUnitFailure header (HUnitFailure mSrcLoc failReason) = - case failReason of - Reason msg -> - H.Failure (srcLocToLocation <$> mSrcLoc) $ - H.ColorizedReason $ - ansiDocToString $ - vsep $ - header ++ [annotate (color Red) (pretty msg)] - ExpectedButGot mMsg expected got -> - H.Failure (srcLocToLocation <$> mSrcLoc) $ - H.ExpectedButGot (Just (ansiDocToString $ vsep (header mMsg))) expected got - adjustFailureReason header = \case - H.Failure mLoc failureReason -> - H.Failure mLoc $ - case failureReason of - H.NoReason -> - H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) "NoReason"] - H.Reason msg -> - H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) (pretty msg)] - H.ColorizedReason msg -> - H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [pretty msg] - H.ExpectedButGot mPreface expected actual -> - H.ExpectedButGot (Just (ansiDocToString $ vsep (header mPreface))) expected actual - H.Error mInfo excThrown -> uncaughtException (header mInfo) excThrown - result -> result - newExc - | Just hUnitExc <- fromException exc = fromHUnitFailure [logs] hUnitExc - | Just hspecFailure <- fromException exc = adjustFailureReason [logs] hspecFailure - | Just (ImpException ann excThrown) <- fromException exc = - let annLen = length ann - header = - logs - : [ let prefix - | annLen <= 1 = "╺╸" - | n <= 0 = "┏╸" - | n + 1 == annLen = indent (n - 1) "┗━╸" - | otherwise = indent (n - 1) "┗┳╸" - in annotate (color Red) prefix <> annotate (color Yellow) a - | (n, a) <- zip [0 ..] ann - ] - ++ [""] - in case fromException excThrown of - Just hUnitExc -> fromHUnitFailure header hUnitExc - Nothing -> - case fromException excThrown of - Just hspecFailure -> adjustFailureReason header hspecFailure - Nothing -> H.Failure Nothing $ uncaughtException header excThrown - | otherwise = H.Failure Nothing $ uncaughtException [logs] exc - throwIO newExc - endState <- readIORef ioRef - pure (res, endState) - -ansiDocToString :: Doc AnsiStyle -> String -ansiDocToString = TL.unpack . renderLazy . layoutPretty defaultLayoutOptions - -withImpInit :: ImpSpec t => SpecWith (ImpInit t) -> Spec -withImpInit = beforeAll (impInitIO (mkQCGen 2024)) - -modifyImpInit :: (ImpInit t -> ImpInit t) -> SpecWith (ImpInit t) -> SpecWith (ImpInit t) -modifyImpInit f = beforeAllWith (pure . f) - --- | Annotation for when failure happens. All the logging done within annotation will be --- discarded if there no failures within the annotation. -impAnn :: NFData a => String -> ImpM t a -> ImpM t a -impAnn msg = impAnnDoc (pretty msg) - -impAnnDoc :: NFData a => Doc AnsiStyle -> ImpM t a -> ImpM t a -impAnnDoc msg m = do - logs <- getLogs - res <- catchAnyDeep m $ \exc -> - throwIO $ - case fromException exc of - Just (ImpException ann origExc) -> ImpException (msg : ann) origExc - Nothing -> ImpException [msg] exc - modifyLogs (const logs) - pure res - --- | Adds a source location and Doc to the log, which are only shown if the test fails -logWithCallStack :: CallStack -> Doc AnsiStyle -> ImpM t () -logWithCallStack callStack entry = - modifyLogs (<> stack <> line <> indent 2 entry <> line) - where - prettySrcLoc' SrcLoc {srcLocModule, srcLocStartLine} = - hcat - [ annotate (color c) d - | (c, d) <- - [ (Yellow, "[") - , (Blue, pretty srcLocModule) - , (Yellow, ":") - , (Magenta, pretty srcLocStartLine) - , (Yellow, "]") - ] - ] - prefix n = if n <= 0 then "" else indent (n - 1) "└" - stack = - vsep - [prefix n <> prettySrcLoc' loc | (n, (_, loc)) <- zip [0, 2 ..] . reverse $ getCallStack callStack] - --- | Adds a Doc to the log, which is only shown if the test fails -logDoc :: HasCallStack => Doc AnsiStyle -> ImpM t () -logDoc = logWithCallStack ?callStack - --- | Adds a Text to the log, which is only shown if the test fails -logText :: HasCallStack => Text -> ImpM t () -logText = logWithCallStack ?callStack . pretty - --- | Adds a String to the log, which is only shown if the test fails -logString :: HasCallStack => String -> ImpM t () -logString = logWithCallStack ?callStack . pretty diff --git a/libs/ImpSpec/src/Test/ImpSpec/Main.hs b/libs/ImpSpec/src/Test/ImpSpec/Main.hs deleted file mode 100644 index e9962441662..00000000000 --- a/libs/ImpSpec/src/Test/ImpSpec/Main.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Test.ImpSpec.Main ( - impSpecMain, - impSpecConfig, - impSpecMainWithConfig, -) where - -import System.IO ( - BufferMode (LineBuffering), - hSetBuffering, - hSetEncoding, - stdout, - utf8, - ) -import Test.Hspec -import Test.Hspec.Core.Runner (ColorMode (ColorAlways), Config (..), defaultConfig, hspecWith) - -impSpecConfig :: Config -impSpecConfig = - defaultConfig - { configTimes = True - , configColorMode = ColorAlways - } - -impSpecMainWithConfig :: Config -> Spec -> IO () -impSpecMainWithConfig conf spec = do - hSetBuffering stdout LineBuffering - hSetEncoding stdout utf8 - hspecWith conf spec - -impSpecMain :: Spec -> IO () -impSpecMain = impSpecMainWithConfig impSpecConfig diff --git a/libs/ImpSpec/src/Test/ImpSpec/Random.hs b/libs/ImpSpec/src/Test/ImpSpec/Random.hs deleted file mode 100644 index aa5805bcd3d..00000000000 --- a/libs/ImpSpec/src/Test/ImpSpec/Random.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Test.ImpSpec.Random where - -import Control.Monad (replicateM) -import Control.Monad.Reader (MonadReader (ask), ReaderT (..)) -import Data.ByteString (ByteString) -import Data.ByteString.Short (ShortByteString) -import qualified System.Random.Stateful as R -import qualified Test.QuickCheck as QC (Arbitrary (arbitrary)) -import Test.QuickCheck.GenT (MonadGen (liftGen)) - -class R.StatefulGen g m => HasStatefulGen g m | m -> g where - askStatefulGen :: m g - default askStatefulGen :: MonadReader g m => m g - askStatefulGen = ask - -class HasGenEnv env g | env -> g where - getGenEnv :: env -> g - -instance HasGenEnv g g where - getGenEnv = id - -instance - (HasGenEnv env g, R.StatefulGen g (ReaderT env m), Monad m) => - HasStatefulGen g (ReaderT env m) - where - askStatefulGen = ReaderT (pure . getGenEnv) - -uniformM :: - ( HasStatefulGen g m - , R.Uniform a - ) => - m a -uniformM = askStatefulGen >>= R.uniformM -{-# INLINE uniformM #-} - -uniformRM :: - ( HasStatefulGen g m - , R.UniformRange a - ) => - (a, a) -> - m a -uniformRM r = askStatefulGen >>= R.uniformRM r -{-# INLINE uniformRM #-} - -uniformListM :: - ( HasStatefulGen g m - , R.Uniform a - ) => - Int -> - m [a] -uniformListM n = askStatefulGen >>= R.uniformListM n -{-# INLINE uniformListM #-} - -uniformListRM :: - (HasStatefulGen g m, R.UniformRange a) => - (a, a) -> - Int -> - m [a] -uniformListRM r n = askStatefulGen >>= replicateM n . R.uniformRM r -{-# INLINE uniformListRM #-} - -uniformByteStringM :: HasStatefulGen a m => Int -> m ByteString -uniformByteStringM n = askStatefulGen >>= R.uniformByteStringM n -{-# INLINE uniformByteStringM #-} - -uniformShortByteStringM :: HasStatefulGen a m => Int -> m ShortByteString -uniformShortByteStringM n = askStatefulGen >>= R.uniformShortByteString n -{-# INLINE uniformShortByteStringM #-} - --- | Lifted version of `QC.arbitrary`. -arbitrary :: (QC.Arbitrary a, MonadGen m) => m a -arbitrary = liftGen QC.arbitrary diff --git a/libs/ImpSpec/test/Main.hs b/libs/ImpSpec/test/Main.hs deleted file mode 100644 index 3cc2dae209e..00000000000 --- a/libs/ImpSpec/test/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Test.ImpSpec -import Test.Suite.ImpSpec (spec) - -main :: IO () -main = impSpecMain $ describe "ImpSpec" spec diff --git a/libs/ImpSpec/test/Test/Suite/ImpSpec.hs b/libs/ImpSpec/test/Test/Suite/ImpSpec.hs deleted file mode 100644 index 040cbbfce2f..00000000000 --- a/libs/ImpSpec/test/Test/Suite/ImpSpec.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - -module Test.Suite.ImpSpec (spec) where - -import Test.ImpSpec - -data I - -instance ImpSpec I - -spec :: Spec -spec = - describe "ImpSpec" $ do - describe "Expectations" $ do - it "shouldBeLeft" $ io $ do - Left @() @Int () `shouldBeLeft` () - withImpInit @I $ - describe "ImpM" $ do - it "impSetSeed" $ do - impSetSeed 1234 - arbitrary `shouldReturn` 'F' From 0b5aa06a924a3be71d56e3ead4e2dfb57d2a2588 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 19 Nov 2024 19:48:55 -0700 Subject: [PATCH 2/3] Update hackage index-state to bring in ImpSpec --- cabal.project | 2 +- flake.lock | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 353dc2e74e5..1eedce77dd9 100644 --- a/cabal.project +++ b/cabal.project @@ -44,7 +44,7 @@ source-repository-package index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2024-11-07T23:54:03Z + , hackage.haskell.org 2024-11-20T00:00:00Z -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2024-11-05T09:09:23Z diff --git a/flake.lock b/flake.lock index 0fc5d4fa4b4..fa00a0cce70 100644 --- a/flake.lock +++ b/flake.lock @@ -242,11 +242,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1731371270, - "narHash": "sha256-9hAGzHPyc6EncczyVrDrjElS6H9wwlR4j1fj4JRTigw=", + "lastModified": 1732062550, + "narHash": "sha256-7WEgL74nWqnuue00ZgFCRdmB9ZFMCdN94pMS8OJUUZE=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "c96fd8da826bb383b7fa36cfe7d386013f070fa4", + "rev": "ad8f3fa0751f7e50ca7c1a6b49410ea92ccf003e", "type": "github" }, "original": { From f4e5a77b4b3aa1300157cef69d4c12ddd5c5c426 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 19 Nov 2024 19:54:51 -0700 Subject: [PATCH 3/3] Remove remnants of ImpSpec from CI and hie file --- .github/workflows/haskell.yml | 1 - hie.yaml | 6 ------ 2 files changed, 7 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 8efbc8d1dcb..553677c6f53 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -213,7 +213,6 @@ jobs: - set-algebra - small-steps - vector-map - - ImpSpec ghc: ["8.10.7", "9.2.8", "9.6.6", "9.8.2", "9.10.1"] os: [ubuntu-latest] fail-fast: false diff --git a/hie.yaml b/hie.yaml index 08034031a9f..6d9fd7d996c 100644 --- a/hie.yaml +++ b/hie.yaml @@ -174,12 +174,6 @@ cradle: - path: "eras/shelley-ma/test-suite/test" component: "cardano-ledger-shelley-ma-test:test:cardano-ledger-shelley-ma-test" - - path: "libs/ImpSpec/src" - component: "lib:ImpSpec" - - - path: "libs/ImpSpec/test" - component: "ImpSpec:test:tests" - - path: "libs/cardano-data/src" component: "lib:cardano-data"