diff --git a/hspec-core.cabal b/hspec-core.cabal --- a/hspec-core.cabal +++ b/hspec-core.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hspec-core -version: 2.11.13 +version: 2.11.14 license: MIT license-file: LICENSE copyright: (c) 2011-2025 Simon Hengel, @@ -90,7 +90,6 @@ Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Pretty Test.Hspec.Core.Formatters.Pretty.Parser - Test.Hspec.Core.Formatters.Pretty.Parser.Parser Test.Hspec.Core.Formatters.Pretty.Unicode Test.Hspec.Core.Formatters.V1.Free Test.Hspec.Core.Formatters.V1.Internal @@ -140,7 +139,7 @@ , filepath , haskell-lexer , hspec-expectations ==0.8.4.* - , hspec-meta ==2.11.13 + , hspec-meta ==2.11.14 , process , quickcheck-io >=0.2.0 , random @@ -180,7 +179,6 @@ Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Pretty Test.Hspec.Core.Formatters.Pretty.Parser - Test.Hspec.Core.Formatters.Pretty.Parser.Parser Test.Hspec.Core.Formatters.Pretty.Unicode Test.Hspec.Core.Formatters.V1 Test.Hspec.Core.Formatters.V1.Free diff --git a/src/Test/Hspec/Core/Example.hs b/src/Test/Hspec/Core/Example.hs --- a/src/Test/Hspec/Core/Example.hs +++ b/src/Test/Hspec/Core/Example.hs @@ -40,12 +40,66 @@ import Test.Hspec.Core.QuickCheck.Util (liftHook) import Test.Hspec.Core.Example.Location --- | A type class for examples +-- | A type class for examples, that is to say, test bodies as used in +-- `Test.Hspec.Core.Spec.it` and similar functions. class Example e where + -- | The argument type that is needed to run this `Example`. + -- If `Arg` is @()@, no argument is required and the `Example` can be run + -- as-is. + -- + -- The value of `Arg` is the difference between `Test.Hspec.Core.Spec.Spec` + -- (aka @`Test.Hspec.Core.Hspec.SpecWith` ()@), which can be executed, and + -- @`Test.Hspec.Core.Spec.SpecWith` a@, which cannot be executed without + -- turning it into `Test.Hspec.Core.Spec.Spec` first. + -- + -- To supply an argument to examples, use the functions in + -- "Test.Hspec.Core.Hooks" such as `Test.Hspec.Core.Hooks.around', + -- `Test.Hspec.Core.Hooks.before', `Test.Hspec.Core.Hooks.mapSubject' and + -- similar. type Arg e type Arg e = () - evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result + -- | Evaluates an example. + -- + -- `evaluateExample` is expected to execute the test body inside the IO action + -- passed to the hook. It's often necessary to use an `IORef` to pass data + -- out like whether the test succeeded to the outer IO action so it can be + -- returned as a `Result`. + -- + -- Example: + -- + -- @ + -- newtype MyAction = MyAction (Int -> IO Bool) + -- + -- instance Example MyAction where + -- type Arg MyAction = Int + -- + -- evaluateExample (MyAction act) _params hook _progress = do + -- result <- newIORef (Result "" Success) + -- hook $ \arg -> do + -- -- e.g. determines if arg is 42 + -- ok <- act arg + -- let result' = Result "" $ if ok then Success else Failure Nothing NoReason + -- writeIORef result result' + -- readIORef result + -- @ + evaluateExample + :: e + -- ^ The example being evaluated + -> Params + -- ^ QuickCheck/SmallCheck settings + -> (ActionWith (Arg e) -> IO ()) + -- ^ Hook: takes an @`ActionWith` (`Arg` e)@, namely, the IO action to run + -- the test body, obtains @`Arg` e@ from somewhere, then executes the test + -- body (or possibly decides not to execute it!). + -- + -- This is used to implement `Test.Hspec.Core.Hooks.around` and similar + -- hook functionality. + -> ProgressCallback + -- ^ Callback for composite tests like QuickCheck to report their progress. + -> IO Result + +-- | QuickCheck and SmallCheck related parameters. data Params = Params { paramsQuickCheckArgs :: QC.Args , paramsSmallCheckDepth :: Maybe Int @@ -57,10 +111,17 @@ , paramsSmallCheckDepth = Nothing } +-- | @(CurrentItem, TotalItems)@ tuple. type Progress = (Int, Int) +-- | Callback used by composite test items that contain many tests to report +-- their progress towards finishing them all. +-- +-- This is used, for example, to report how many QuickCheck examples are finished. type ProgressCallback = Progress -> IO () --- | An `IO` action that expects an argument of type @a@ +-- | An `IO` action that expects an argument of type @a@. +-- +-- This type is what `Example`s are ultimately unlifted into for execution. type ActionWith a = a -> IO () -- | The result of running an example diff --git a/src/Test/Hspec/Core/Formatters/Pretty.hs b/src/Test/Hspec/Core/Formatters/Pretty.hs --- a/src/Test/Hspec/Core/Formatters/Pretty.hs +++ b/src/Test/Hspec/Core/Formatters/Pretty.hs @@ -56,8 +56,8 @@ go value = case value of Char _ -> False String _ -> True - Rational _ _ -> False Number _ -> False + Operator _ _ _ -> True Record _ _ -> True Constructor _ xs -> any go xs Tuple xs -> any go xs @@ -97,8 +97,8 @@ render indentation = \ case Char c -> shows c String str -> if unicode then Builder $ ushows str else shows str - Rational n d -> render indentation n <> " % " <> render indentation d Number n -> fromString n + Operator a name b -> render indentation a <> " " <> fromString name <> " " <> render indentation b Record name fields -> fromString name <> renderFields fields Constructor name values -> intercalate " " (fromString name : map (render indentation) values) Tuple [e@Record{}] -> render indentation e diff --git a/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs b/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs --- a/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs +++ b/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs @@ -1,107 +1,171 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.Formatters.Pretty.Parser ( Value(..) , parseValue ) where import Prelude () -import Test.Hspec.Core.Compat - -import Test.Hspec.Core.Formatters.Pretty.Parser.Parser hiding (Parser) -import qualified Test.Hspec.Core.Formatters.Pretty.Parser.Parser as P +import Test.Hspec.Core.Compat hiding (Alternative(..), read, exp) -import Language.Haskell.Lexer hiding (Pos(..)) +import Language.Haskell.Lexer hiding (Token, Pos(..)) +import qualified Language.Haskell.Lexer as Lexer type Name = String data Value = Char Char | String String - | Rational Value Value | Number String + | Operator Value Name Value | Record Name [(Name, Value)] | Constructor Name [Value] | Tuple [Value] | List [Value] deriving (Eq, Show) -type Parser = P.Parser (Token, String) +type Token = (TokenType, String) +type TokenType = Lexer.Token + +newtype Parser a = Parser { + runParser :: [Token] -> Maybe (a, [Token]) +} deriving Functor + +instance Applicative Parser where + pure a = Parser $ \ input -> Just (a, input) + (<*>) = ap + +instance Monad Parser where + return = pure + p1 >>= p2 = Parser $ runParser p1 >=> uncurry (runParser . p2) + parseValue :: String -> Maybe Value -parseValue input = case runParser value (tokenize input) of +parseValue input = case runParser exp (tokenize input) of Just (v, []) -> Just v _ -> Nothing -value :: Parser Value -value = - char - <|> string - <|> rational - <|> number - <|> record - <|> constructor - <|> tuple - <|> list +tokenize :: String -> [Token] +tokenize = go . map (fmap snd) . rmSpace . lexerPass0 + where + go :: [Token] -> [Token] + go tokens = case tokens of + [] -> [] + (Varsym, "-") : (IntLit, n) : xs -> (IntLit, "-" ++ n) : go xs + (Varsym, "-") : (FloatLit, n) : xs -> (FloatLit, "-" ++ n) : go xs + x : xs -> x : go xs -char :: Parser Value -char = Char <$> (token CharLit >>= readA) +exp :: Parser Value +exp = infixexp -string :: Parser Value -string = String <$> (token StringLit >>= readA) +infixexp :: Parser Value +infixexp = aexp accept reject + where + accept :: Value -> Parser Value + accept value = peek >>= \ case + (Varsym, "%") -> skip >> Operator value "%" <$> exp + (Consym, name) -> skip >> Operator value name <$> exp + _ -> return value -rational :: Parser Value -rational = Rational <$> (number <|> tuple) <* require (Varsym, "%") <*> number + reject :: Parser Value + reject = next >>= unexpected -number :: Parser Value -number = integer <|> float +aexp :: forall a. (Value -> Parser a) -> Parser a -> Parser a +aexp continue done = peek >>= \ case + (CharLit, value) -> read Char value + (StringLit, value) -> read String value + (IntLit, value) -> number value + (FloatLit, value) -> number value + (Conid, name) -> accept $ constructor name + (Special, "(") -> accept tuple + (Special, "[") -> accept list + _ -> done where - integer :: Parser Value - integer = Number <$> token IntLit + read :: Read v => (v -> Value) -> String -> Parser a + read c v = skip >> c <$> readValue v >>= continue - float :: Parser Value - float = Number <$> token FloatLit + number :: String -> Parser a + number value = skip >> continue (Number value) -record :: Parser Value -record = Record <$> token Conid <* special "{" <*> fields <* special "}" - where - fields :: Parser [(Name, Value)] - fields = field `sepBy1` comma + accept :: Parser Value -> Parser a + accept action = skip >> action >>= continue - field :: Parser (Name, Value) - field = (,) <$> token Varid <* equals <*> value +constructor :: String -> Parser Value +constructor name = peek >>= \ case + (Special, "{") -> skip >> Record name <$> commaSeparated field "}" + where + field :: Parser (Name, Value) + field = (,) <$> require Varid <* equals <*> exp -constructor :: Parser Value -constructor = Constructor <$> token Conid <*> many value + _ -> Constructor name <$> parameters + where + parameters :: Parser [Value] + parameters = aexp more done + more :: Value -> Parser [Value] + more v = (:) v <$> parameters + + done :: Parser [Value] + done = return [] + tuple :: Parser Value -tuple = Tuple <$> (special "(" *> items) <* special ")" +tuple = Tuple <$> commaSeparated exp ")" list :: Parser Value -list = List <$> (special "[" *> items) <* special "]" - -items :: Parser [Value] -items = value `sepBy` comma +list = List <$> commaSeparated exp "]" -special :: String -> Parser () -special s = require (Special, s) +commaSeparated :: forall a. Parser a -> String -> Parser [a] +commaSeparated item close = peek >>= \ case + (Special, c) | c == close -> skip >> return [] + _ -> items + where + items :: Parser [a] + items = (:) <$> item <*> moreItems -comma :: Parser () -comma = special "," + moreItems :: Parser [a] + moreItems = next >>= \ case + (Special, c) + | c == "," -> items + | c == close -> return [] + t -> unexpected t equals :: Parser () -equals = require (Reservedop, "=") +equals = requireToken (Reservedop, "=") -token :: Token -> Parser String -token t = snd <$> satisfy (fst >>> (== t)) +require :: TokenType -> Parser String +require expected = next >>= \ case + (token, v) | token == expected -> return v + token -> unexpected token -require :: (Token, String) -> Parser () -require t = void $ satisfy (== t) +requireToken :: Token -> Parser () +requireToken expected = next >>= \ case + token | token == expected -> return () + token -> unexpected token -tokenize :: String -> [(Token, String)] -tokenize = go . map (fmap snd) . rmSpace . lexerPass0 - where - go :: [(Token, String)] -> [(Token, String)] - go tokens = case tokens of - [] -> [] - (Varsym, "-") : (IntLit, n) : xs -> (IntLit, "-" ++ n) : go xs - (Varsym, "-") : (FloatLit, n) : xs -> (FloatLit, "-" ++ n) : go xs - x : xs -> x : go xs +peek :: Parser Token +peek = Parser $ \ input -> case input of + t : _ -> Just (t, input) + [] -> Just ((GotEOF, ""), input) + +next :: Parser Token +next = Parser $ \ case + t : ts -> Just (t, ts) + ts -> Just ((GotEOF, ""), ts) + +skip :: Parser () +skip = Parser $ \ case + _ : ts -> Just ((), ts) + ts -> Just ((), ts) + +empty :: Parser a +empty = Parser $ const Nothing + +readValue :: Read a => String -> Parser a +readValue = maybe empty pure . readMaybe + +unexpected :: Token -> Parser a +unexpected _ = empty + +-- unexpected :: HasCallStack => (Token, String) -> Parser a +-- unexpected = error . show diff --git a/src/Test/Hspec/Core/Formatters/Pretty/Parser/Parser.hs b/src/Test/Hspec/Core/Formatters/Pretty/Parser/Parser.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/Formatters/Pretty/Parser/Parser.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Test.Hspec.Core.Formatters.Pretty.Parser.Parser where - -import Prelude () -import Test.Hspec.Core.Compat - -newtype Parser token a = Parser { runParser :: [token] -> Maybe (a, [token]) } - deriving Functor - -instance Applicative (Parser token) where - pure a = Parser $ \ input -> Just (a, input) - (<*>) = ap - -instance Monad (Parser token) where - return = pure - p1 >>= p2 = Parser $ runParser p1 >=> uncurry (runParser . p2) - -instance Alternative (Parser token) where - empty = Parser $ const Nothing - p1 <|> p2 = Parser $ \ input -> runParser p1 input <|> runParser p2 input - -satisfy :: (token -> Bool) -> Parser token token -satisfy p = Parser $ \ input -> case input of - t : ts | p t -> Just (t, ts) - _ -> Nothing - -sepBy :: Alternative m => m a -> m sep -> m [a] -sepBy p sep = sepBy1 p sep <|> pure [] - -sepBy1 :: Alternative m => m a -> m sep -> m [a] -sepBy1 p sep = (:) <$> p <*> many (sep *> p) - -readA :: (Alternative m, Read a) => String -> m a -readA = maybe empty pure . readMaybe diff --git a/src/Test/Hspec/Core/Hooks.hs b/src/Test/Hspec/Core/Hooks.hs --- a/src/Test/Hspec/Core/Hooks.hs +++ b/src/Test/Hspec/Core/Hooks.hs @@ -96,8 +96,18 @@ after_ :: IO () -> SpecWith a -> SpecWith a after_ action = after $ \_ -> action --- | Run a custom action before and/or after every spec item. -around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec +-- | Run a custom action before and/or after every spec item, supplying it with +-- an argument obtained via IO. +-- +-- This is useful for tasks like creating a file handle or similar resource +-- before a test and destroying it after the test. +around + :: (ActionWith a -> IO ()) + -- ^ Function provided with an action to run the spec item as argument. It + -- should return the action to actually execute the item. + -> SpecWith a + -- ^ Spec to modify + -> Spec around action = aroundWith $ \e () -> action e -- | Run a custom action after the last spec item. diff --git a/src/Test/Hspec/Core/QuickCheck/Util.hs b/src/Test/Hspec/Core/QuickCheck/Util.hs --- a/src/Test/Hspec/Core/QuickCheck/Util.hs +++ b/src/Test/Hspec/Core/QuickCheck/Util.hs @@ -37,7 +37,16 @@ import Test.Hspec.Core.Util -liftHook :: r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r +liftHook + :: r + -- ^ Default result, taken if the hook decides to not run the test + -> ((a -> IO ()) -> IO ()) + -- ^ Hook: given an action to actually run the test, potentially does + -- some IO actions before the test, runs it while supplying an argument (or + -- skips it!), then may execute some more actions after running it. + -> (a -> IO r) + -- ^ The actual test being run, producing a result + -> IO r liftHook def hook inner = do ref <- newIORef def hook $ inner >=> writeIORef ref diff --git a/src/Test/Hspec/Core/Spec.hs b/src/Test/Hspec/Core/Spec.hs --- a/src/Test/Hspec/Core/Spec.hs +++ b/src/Test/Hspec/Core/Spec.hs @@ -19,6 +19,10 @@ , xdescribe , xcontext +-- * Focused spec items #focus# +-- | +-- During a test run, when a spec contains /focused/ spec items, all other spec +-- items are ignored. , focus , fit , fspecify @@ -125,6 +129,16 @@ -- > describe "absolute" $ do -- > it "returns a positive number when given a negative number" $ -- > absolute (-1) == 1 +-- +-- @`Example` a@ optionally accepts an argument @`Arg` a@, which is then given +-- to the test body. This is useful for provisioning resources for a test which +-- are created and cleaned up outside the test itself. See `Arg` for details. +-- +-- Note that this function is often on the scene of nasty type errors due to GHC failing +-- to infer the type of @do@ notation in the test body. +-- It can be helpful to use +-- [TypeApplications](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_applications.html) +-- to explicitly specify the intended `Example` type. it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it label action = fromSpecList [specItem label action] @@ -149,6 +163,7 @@ focus :: SpecWith a -> SpecWith a focus = mapSpecForest focusForest +-- | Marks an entire spec forest as focused if nothing in it is already focused. focusForest :: [SpecTree a] -> [SpecTree a] focusForest xs | any (any itemIsFocused) xs = xs diff --git a/src/Test/Hspec/Core/Spec/Monad.hs b/src/Test/Hspec/Core/Spec/Monad.hs --- a/src/Test/Hspec/Core/Spec/Monad.hs +++ b/src/Test/Hspec/Core/Spec/Monad.hs @@ -32,8 +32,24 @@ import Test.Hspec.Core.Config.Definition (Config) +-- | A `SpecWith` that can be evaluated directly by the +-- `Test.Hspec.Core.Runner.hspec` function as it does not require any +-- parameters. type Spec = SpecWith () +-- | A @'SpecWith' a@ represents a test or group of tests that require an @a@ +-- value to run. +-- +-- In the common case, a 'Spec' is a @'SpecWith' ()@ which requires @()@ and +-- can thus be executed with `Test.Hspec.Core.Runner.hspec'. +-- +-- To supply an argument to `SpecWith` tests to turn them into `Spec`, use +-- functions from "Test.Hspec.Core.Hooks" such as +-- `Test.Hspec.Core.Hooks.around`, `Test.Hspec.Core.Hooks.before', +-- `Test.Hspec.Core.Hooks.mapSubject' and similar. +-- +-- Values of this type are created by `Test.Hspec.Core.Spec.it`, +-- `Test.Hspec.Core.Spec.describe` and similar. type SpecWith a = SpecM a () -- | @@ -41,7 +57,13 @@ modifyConfig :: (Config -> Config) -> SpecWith a modifyConfig f = SpecM $ tell (Endo f, mempty) --- | A writer monad for `SpecTree` forests +-- | A writer monad for `SpecTree` forests. +-- +-- This is used by `Test.Hspec.Core.Spec.describe` and is used +-- to construct the forest of spec items. +-- +-- It allows for dynamically generated spec trees, for example, by using data +-- obtained by performing IO actions with 'runIO'. newtype SpecM a r = SpecM { unSpecM :: WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r } deriving (Functor, Applicative, Monad) @@ -60,7 +82,7 @@ -- | Run an IO action while constructing the spec tree. -- -- `SpecM` is a monad to construct a spec tree, without executing any spec --- items. @runIO@ allows you to run IO actions during this construction phase. +-- items itself. @runIO@ allows you to run IO actions during this construction phase. -- The IO action is always run when the spec tree is constructed (e.g. even -- when @--dry-run@ is specified). -- If you do not need the result of the IO action to construct the spec tree, @@ -79,12 +101,19 @@ mapSpecItem_ :: (Item a -> Item b) -> SpecWith a -> SpecWith b mapSpecItem_ = mapSpecForest . bimapForest id +-- | Modifies the `Params` on the spec items to be generated by `SpecWith`. modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)} newtype Env = Env { + -- | The path of _parent_ `Hspec.Core.Spec.describe` labels from innermost to + -- outermost. envSpecDescriptionPath :: [String] } +-- | Applies a function to modify the `Env` of items being written by a child +-- spec writer. +-- +-- This is used to implement `Hspec.Core.Spec.describe`. withEnv :: (Env -> Env) -> SpecM a r -> SpecM a r withEnv f = SpecM . WriterT . local f . runWriterT . unSpecM diff --git a/test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs b/test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs --- a/test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs +++ b/test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs @@ -12,6 +12,9 @@ import Test.Hspec.Core.Formatters.Pretty.Parser +data OperatorType = String :*: Int + deriving (Eq, Show) + data Person = Person { personName :: String , personAge :: Int @@ -50,11 +53,14 @@ show "foo" `shouldParseAs` String "foo" it "accepts rationals" $ do - show (0.5 :: Rational) `shouldParseAs` Rational (Number "1") (Number "2") + show (0.5 :: Rational) `shouldParseAs` Operator (Number "1") "%" (Number "2") it "accepts negative rationals" $ do - show (-0.5 :: Rational) `shouldParseAs` Rational (parentheses $ Number "-1") (Number "2") + show (-0.5 :: Rational) `shouldParseAs` Operator (parentheses $ Number "-1") "%" (Number "2") + it "accepts constructor symbols" $ do + show ("foo" :*: 23) `shouldParseAs` Operator (String "foo") ":*:" (Number "23") + it "accepts integers" $ do "23" `shouldParseAs` Number "23" @@ -91,3 +97,41 @@ , ("addressPostalCode", Number "50000") ]]]) ] + + context "with deeply nested data structures" $ do + it "completes in O(n) time" $ do + let + input = show ( + "0", ( + "1", ( + "2", ( + "3", ( + "4", ( + "5", ( + "6", ( + "7", ( + "8", ( + "9", ( + "10", ( + "11", ( + "12", ( + "13", ( + "14", ( + "15", ( + "16", ( + "17", ( + "18", ( + "19", ( + "20", ( + "21", ( + "22", ( + "23", ( + "24", ( + "25", ( + "26", ( + "27", ( + "28", ( + "29", ( + ))))))))))))))))))))))))))))))) + r <- timeout 1 $ evaluate (parseValue input) + (join r :: Maybe Value) `shouldSatisfy` isJust diff --git a/version.yaml b/version.yaml --- a/version.yaml +++ b/version.yaml @@ -1,4 +1,4 @@ -version: &version 2.11.13 +version: &version 2.11.14 synopsis: A Testing Framework for Haskell author: Simon Hengel maintainer: Simon Hengel