doctest 0.22.10 → 0.25.0
raw patch · 23 files changed
Files
- CHANGES.markdown +18/−0
- LICENSE +1/−1
- doctest.cabal +13/−9
- src/Cabal.hs +1/−1
- src/Cabal/Options.hs +1/−1
- src/Cabal/ReplOptions.hs +11/−7
- src/Extract.hs +14/−34
- src/GhcUtil.hs +13/−18
- src/Imports.hs +3/−6
- src/Interpreter.hs +5/−6
- src/Language/Haskell/GhciWrapper.hs +13/−10
- src/Options.hs +9/−1
- src/Run.hs +18/−7
- src/Runner.hs +50/−33
- test/Language/Haskell/GhciWrapperSpec.hs +12/−12
- test/MainSpec.hs +28/−9
- test/OptionsSpec.hs +10/−1
- test/RunSpec.hs +42/−19
- test/RunnerSpec.hs +2/−3
- test/integration/fail-fast/Bar.hs +8/−0
- test/integration/fail-fast/Foo.hs +24/−0
- test/integration/fail-fast/SetupBar.hs +12/−0
- test/integration/fail-fast/SetupFoo.hs +29/−0
CHANGES.markdown view
@@ -1,3 +1,21 @@+Changes in 0.25.0+ - Full GHC 9.14 compatibility / `-unit`-support++Changes in 0.24.3+ - Allow building with GHC 9.14 (#478)++Changes in 0.24.2+ - Use `GHC.ResponseFile.expandResponse`++Changes in 0.24.1+ - Interpret GHC response files++Changes in 0.24.0+ - cabal-doctest: Add support for cabal-install 3.14.*++Changes in 0.23.0+ - Add `--fail-fast`+ Changes in 0.22.10 - Make progress reporting more robust
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009-2024 Simon Hengel <sol@typeful.net>+Copyright (c) 2009-2026 Simon Hengel <sol@typeful.net> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
doctest.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: doctest-version: 0.22.10+version: 0.25.0 synopsis: Test interactive Haskell examples description: `doctest` is a tool that checks [examples](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744) and [properties](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810771856)@@ -18,7 +18,7 @@ homepage: https://github.com/sol/doctest#readme license: MIT license-file: LICENSE-copyright: (c) 2009-2024 Simon Hengel+copyright: (c) 2009-2026 Simon Hengel author: Simon Hengel <sol@typeful.net> maintainer: Simon Hengel <sol@typeful.net> build-type: Simple@@ -67,6 +67,10 @@ test/integration/custom-package-conf/foo/doctest-foo.cabal test/integration/custom-package-conf/foo/Foo.hs test/integration/dos-line-endings/Fib.hs+ test/integration/fail-fast/Bar.hs+ test/integration/fail-fast/Foo.hs+ test/integration/fail-fast/SetupBar.hs+ test/integration/fail-fast/SetupFoo.hs test/integration/failing-multiple/Foo.hs test/integration/failing/Foo.hs test/integration/it/Foo.hs@@ -150,14 +154,14 @@ Util Paths_doctest build-depends:- base >=4.7 && <5+ base >=4.12 && <5 , code-page >=0.1 , containers , deepseq , directory , exceptions , filepath- , ghc >=8.0 && <9.12+ , ghc >=8.6 && <9.16 , ghc-paths >=0.1.0.9 , process , syb >=0.3@@ -180,7 +184,7 @@ NoImplicitPrelude ghc-options: -Wall -threaded build-depends:- base >=4.7 && <5+ base >=4.12 && <5 , doctest default-language: Haskell2010 if impl(ghc >= 9.0)@@ -203,7 +207,7 @@ DeriveFunctor NoImplicitPrelude build-depends:- base >=4.7 && <5+ base >=4.12 && <5 , doctest default-language: Haskell2010 if impl(ghc >= 9.0)@@ -275,14 +279,14 @@ build-depends: HUnit , QuickCheck >=2.13.1- , base >=4.7 && <5+ , base >=4.12 && <5 , code-page >=0.1 , containers , deepseq , directory , exceptions , filepath- , ghc >=8.0 && <9.12+ , ghc >=8.6 && <9.16 , ghc-paths >=0.1.0.9 , hspec >=2.3.0 , hspec-core >=2.3.0
src/Cabal.hs view
@@ -66,7 +66,7 @@ withSystemTempDirectory "cabal-doctest" $ \ dir -> do repl ["--keep-temp-files", "--repl-multi-file", dir] files <- filter (isSuffixOf "-inplace") <$> listDirectory dir- options <- concat <$> mapM (fmap lines . readFile . combine dir) files+ let options = concatMap (\ file -> ["-unit", '@' : dir </> file]) files call doctest ("--no-magic" : options) writeFileAtomically :: FilePath -> String -> IO ()
src/Cabal/Options.hs view
@@ -31,7 +31,7 @@ , "--no-transitive-deps" , "--enable-multi-repl" , "--disable-multi-repl"- , "--keep-temp-files"+ , "--with-repl" ] rejectUnsupportedOptions :: [String] -> IO ()
src/Cabal/ReplOptions.hs view
@@ -21,10 +21,10 @@ Option "help" (Just 'h') NoArgument "Show this help text" , Option "verbose" (Just 'v') (OptionalArgument "n") "Control verbosity (n is 0--3, default verbosity level is 1)" , Option "builddir" Nothing (Argument "DIR") "The directory where Cabal puts generated build files (default dist)"+ , Option "keep-temp-files" Nothing NoArgument "Keep temporary files." , Option "ghc" (Just 'g') NoArgument "compile with GHC" , Option "ghcjs" Nothing NoArgument "compile with GHCJS" , Option "uhc" Nothing NoArgument "compile with UHC"- , Option "haskell-suite" Nothing NoArgument "compile with a haskell-suite compiler" , Option "with-compiler" (Just 'w') (Argument "PATH") "give the path to a particular compiler" , Option "with-hc-pkg" Nothing (Argument "PATH") "give the path to the package tool" , Option "prefix" Nothing (Argument "DIR") "bake this prefix in preparation of installation"@@ -56,6 +56,8 @@ , Option "disable-executable-static" Nothing NoArgument "Disable Executable fully static linking" , Option "enable-profiling" Nothing NoArgument "Enable Executable and library profiling" , Option "disable-profiling" Nothing NoArgument "Disable Executable and library profiling"+ , Option "enable-profiling-shared" Nothing NoArgument "Enable Build profiling shared libraries"+ , Option "disable-profiling-shared" Nothing NoArgument "Disable Build profiling shared libraries" , Option "enable-executable-profiling" Nothing NoArgument "Enable Executable profiling (DEPRECATED)" , Option "disable-executable-profiling" Nothing NoArgument "Disable Executable profiling (DEPRECATED)" , Option "profiling-detail" Nothing (Argument "level") "Profiling detail level for executable and library (default, none, exported-functions, toplevel-functions, all-functions, late)."@@ -104,6 +106,7 @@ , Option "disable-response-files" Nothing NoArgument "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" , Option "allow-depending-on-private-libs" Nothing NoArgument "Allow depending on private libraries. If set, the library visibility check MUST be done externally." , Option "coverage-for" Nothing (Argument "UNITID") "A list of unit-ids of libraries to include in the Haskell Program Coverage report."+ , Option "ignore-build-tools" Nothing NoArgument "Ignore build tool dependencies. If set, declared build tools needn't be found for compilation to proceed." , Option "cabal-lib-version" Nothing (Argument "VERSION") "Select which version of the Cabal lib to use to build packages (useful for testing)." , Option "enable-append" Nothing NoArgument "Enable appending the new config to the old config file" , Option "disable-append" Nothing NoArgument "Disable appending the new config to the old config file"@@ -165,27 +168,28 @@ , Option "haddock-hscolour-css" Nothing (Argument "PATH") "Use PATH as the HsColour stylesheet" , Option "haddock-contents-location" Nothing (Argument "URL") "Bake URL in as the location for the contents page" , Option "haddock-base-url" Nothing (Argument "URL") "Base URL for static files."- , Option "haddock-lib" Nothing (Argument "DIR") "location of Haddocks static / auxiliary files"+ , Option "haddock-resources-dir" Nothing (Argument "DIR") "location of Haddocks static / auxiliary files" , Option "haddock-output-dir" Nothing (Argument "DIR") "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases."+ , Option "haddock-use-unicode" Nothing NoArgument "Pass --use-unicode option to haddock" , Option "test-log" Nothing (Argument "TEMPLATE") "Log all test suite results to file (name template can use $pkgid, $compiler, $os, $arch, $test-suite, $result)" , Option "test-machine-log" Nothing (Argument "TEMPLATE") "Produce a machine-readable log file (name template can use $pkgid, $compiler, $os, $arch, $result)" , Option "test-show-details" Nothing (Argument "FILTER") "'always': always show results of individual test cases. 'never': never show results of individual test cases. 'failures': show results of failing test cases. 'streaming': show results of test cases in real time.'direct': send results of test cases in real time; no log file." , Option "test-keep-tix-files" Nothing NoArgument "keep .tix files for HPC between test runs" , Option "test-wrapper" Nothing (Argument "FILE") "Run test through a wrapper." , Option "test-fail-when-no-test-suites" Nothing NoArgument "Exit with failure when no test suites are found."- , Option "test-options" Nothing (Argument "TEMPLATES") "give extra options to test executables (name templates can use $pkgid, $compiler, $os, $arch, $test-suite)"- , Option "test-option" Nothing (Argument "TEMPLATE") "give extra option to test executables (no need to quote options containing spaces, name template can use $pkgid, $compiler, $os, $arch, $test-suite)"- , Option "benchmark-options" Nothing (Argument "TEMPLATES") "give extra options to benchmark executables (name templates can use $pkgid, $compiler, $os, $arch, $benchmark)"- , Option "benchmark-option" Nothing (Argument "TEMPLATE") "give extra option to benchmark executables (no need to quote options containing spaces, name template can use $pkgid, $compiler, $os, $arch, $benchmark)"+ , Option "test-options" Nothing (Argument "TEMPLATES") "give extra options to test executables (split on spaces, use \"\" to prevent splitting; name templates can use $pkgid, $compiler, $os, $arch, $test-suite)"+ , Option "test-option" Nothing (Argument "TEMPLATE") "give extra option to test executables (passed directly as a single argument; name template can use $pkgid, $compiler, $os, $arch, $test-suite)"+ , Option "benchmark-options" Nothing (Argument "TEMPLATES") "give extra options to benchmark executables (split on spaces, use \"\" to prevent splitting; name templates can use $pkgid, $compiler, $os, $arch, $benchmark)"+ , Option "benchmark-option" Nothing (Argument "TEMPLATE") "give extra option to benchmark executables (passed directly as a single argument; name template can use $pkgid, $compiler, $os, $arch, $benchmark)" , Option "project-dir" Nothing (Argument "DIR") "Set the path of the project directory" , Option "project-file" Nothing (Argument "FILE") "Set the path of the cabal.project file (relative to the project directory when relative)" , Option "ignore-project" (Just 'z') NoArgument "Ignore local project configuration (unless --project-dir or --project-file is also set)" , Option "repl-no-load" Nothing NoArgument "Disable loading of project modules at REPL startup." , Option "repl-options" Nothing (Argument "FLAG") "Use the option(s) for the repl" , Option "repl-multi-file" Nothing (Argument "DIR") "Write repl options to this directory rather than starting repl mode"+ , Option "with-repl" Nothing (Argument "PATH") "Give the path to a program to use for REPL" , Option "build-depends" (Just 'b') (Argument "DEPENDENCIES") "Include additional packages in the environment presented to GHCi." , Option "no-transitive-deps" Nothing NoArgument "Don't automatically include transitive dependencies of requested packages." , Option "enable-multi-repl" Nothing NoArgument "Enable multi-component repl sessions" , Option "disable-multi-repl" Nothing NoArgument "Disable multi-component repl sessions"- , Option "keep-temp-files" Nothing NoArgument "Keep temporary files" ]
src/Extract.hs view
@@ -29,10 +29,6 @@ import System.Directory import System.FilePath -#if __GLASGOW_HASKELL__ < 805-import FastString (unpackFS)-#endif- import System.Posix.Internals (c_getpid) import GhcUtil (withGhc)@@ -41,13 +37,11 @@ import Util (convertDosLineEndings) import PackageDBs (getPackageDBArgs) -#if __GLASGOW_HASKELL__ >= 806 #if __GLASGOW_HASKELL__ < 900 import DynamicLoading (initializePlugins) #else import GHC.Runtime.Loader (initializePlugins) #endif-#endif #if __GLASGOW_HASKELL__ >= 901 import GHC.Unit.Module.Graph@@ -55,7 +49,9 @@ -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException+#if __GLASGOW_HASKELL__ < 912 deriving Typeable+#endif instance Show ExtractError where show (ExtractError e) =@@ -85,15 +81,6 @@ instance NFData a => NFData (Module a) where rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` () -#if __GLASGOW_HASKELL__ < 803-type GhcPs = RdrName-#endif--#if __GLASGOW_HASKELL__ < 805-addQuoteInclude :: [String] -> [String] -> [String]-addQuoteInclude includes new = new ++ includes-#endif- -- | Parse a list of modules. parse :: [String] -> IO [ParsedModule] parse args = withGhc args $ \modules_ -> withTempOutputDir $ do@@ -108,7 +95,11 @@ Nothing) mods <- depanal [] False - let sortedMods = flattenSCCs+ let sortedMods =+#if __GLASGOW_HASKELL__ >= 914+ mapMaybe maybeModSummaryFromModuleNodeInfo $+#endif+ flattenSCCs #if __GLASGOW_HASKELL__ >= 901 $ filterToposortToModules #endif@@ -154,7 +145,6 @@ , includePaths = addQuoteInclude (includePaths d) [f] } -#if __GLASGOW_HASKELL__ >= 806 -- Since GHC 8.6, plugins are initialized on a per module basis loadModPlugins modsum = do _ <- setSessionDynFlags (GHC.ms_hspp_opts modsum)@@ -168,9 +158,6 @@ dynflags' <- liftIO (initializePlugins hsc_env (GHC.ms_hspp_opts modsum)) return $ modsum { ms_hspp_opts = dynflags' } # endif-#else- loadModPlugins = return-#endif -- | Extract all docstrings from given list of files/modules. --@@ -208,6 +195,13 @@ (setup, docs) = partition isSetup (docStringsFromModule m) name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m +#if __GLASGOW_HASKELL__ >= 914+maybeModSummaryFromModuleNodeInfo :: ModuleNodeInfo -> Maybe ModSummary+maybeModSummaryFromModuleNodeInfo i = case i of+ ModuleNodeCompile summary -> Just summary+ ModuleNodeFixed _ _ -> Nothing+#endif+ #if __GLASGOW_HASKELL__ >= 904 unpackHDS :: HsDocString -> String unpackHDS = renderHsDocString@@ -239,11 +233,7 @@ #else exports = [ (Nothing, L (locA loc) doc) #endif-#if __GLASGOW_HASKELL__ < 805- | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)-#else | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source)-#endif ] decls :: [(Maybe String, LHsDocString)] decls = extractDocStrings (hsmodDecls source)@@ -281,11 +271,7 @@ -- Top-level documentation has to be treated separately, because it has -- no location information attached. The location information is -- attached to HsDecl instead.-#if __GLASGOW_HASKELL__ < 805- DocD x-#else DocD _ x-#endif -> select (fromDocDecl (locA loc) x) _ -> (extractDocStrings decl, True)@@ -311,12 +297,6 @@ -- | Collect given value and descend into subtree. select :: a -> ([a], Bool) select x = ([x], False)-#endif--#if __GLASGOW_HASKELL__ < 805--- | Convert a docstring to a plain string.-unpackHDS :: HsDocString -> String-unpackHDS (HsDocString s) = unpackFS s #endif #if __GLASGOW_HASKELL__ < 901
src/GhcUtil.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-}-module GhcUtil (withGhc) where+{-# LANGUAGE LambdaCase #-}+module GhcUtil (withGhc, expandUnits) where import Imports @@ -23,12 +24,9 @@ import GHC.Utils.Monad (liftIO) #endif +import GHC.ResponseFile (expandResponse) import System.Exit (exitFailure) -#if __GLASGOW_HASKELL__ < 801-import StaticFlags (discardStaticFlags)-#endif- -- Catch GHC source errors, print them and exit. handleSrcErrors :: Ghc a -> Ghc a handleSrcErrors action' = flip handleSourceError action' $ \err -> do@@ -37,20 +35,17 @@ -- | Run a GHC action in Haddock mode withGhc :: [String] -> ([String] -> Ghc a) -> IO a-withGhc flags action = do- flags_ <- handleStaticFlags flags-- runGhc (Just libdir) $ do- handleDynamicFlags flags_ >>= handleSrcErrors . action+withGhc flags action = runGhc (Just libdir) $ do+ liftIO (expandUnits flags) >>= handleDynamicFlags >>= handleSrcErrors . action -handleStaticFlags :: [String] -> IO [Located String]-#if __GLASGOW_HASKELL__ < 801-handleStaticFlags flags = return $ map noLoc $ discardStaticFlags flags-#else-handleStaticFlags flags = return $ map noLoc $ flags-#endif+expandUnits :: [String] -> IO [String]+expandUnits = \ case+ [] -> return []+ "-unit" : file@('@' : _) : args -> (++) <$> expandResponse [file] <*> expandUnits args+ file@('@' : _) : args -> (++) <$> expandResponse [file] <*> expandUnits args+ x : xs -> (:) x <$> expandUnits xs -handleDynamicFlags :: GhcMonad m => [Located String] -> m [String]+handleDynamicFlags :: GhcMonad m => [String] -> m [String] handleDynamicFlags flags = do #if __GLASGOW_HASKELL__ >= 901 logger <- getLogger@@ -58,7 +53,7 @@ #else let parseDynamicFlags' = parseDynamicFlags #endif- (dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= (`parseDynamicFlags'` flags)+ (dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= (`parseDynamicFlags'` map noLoc flags) _ <- setSessionDynFlags dynflags -- We basically do the same thing as `ghc/Main.hs` to distinguish
src/Imports.hs view
@@ -14,16 +14,13 @@ import System.Exit import System.Process -#if __GLASGOW_HASKELL__ >= 804 import Data.Functor as Imports ((<&>))-#else-infixl 1 <&>-(<&>) :: Functor f => f a -> (a -> b) -> f b-(<&>) = flip fmap-#endif pass :: Monad m => m () pass = return ()++equals :: Eq a => a -> a -> Bool+equals = (==) strip :: String -> String strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace
src/Interpreter.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} module Interpreter ( Interpreter+, PreserveIt(..) , safeEval-, safeEvalIt+, safeEvalWith , withInterpreter , ghc , interpreterSupported@@ -45,10 +46,8 @@ let args = flags ++ [ xTemplateHaskell-#if __GLASGOW_HASKELL__ >= 802 , "-fdiagnostics-color=never" , "-fno-diagnostics-show-caret"-#endif #if __GLASGOW_HASKELL__ >= 810 && __GLASGOW_HASKELL__ < 904 , "-Wno-unused-packages" #endif@@ -65,10 +64,10 @@ -- -- An exception may e.g. be caused on unterminated multiline expressions. safeEval :: Interpreter -> String -> IO (Either String String)-safeEval repl = either (return . Left) (fmap Right . eval repl) . filterExpression+safeEval = safeEvalWith NoPreserveIt -safeEvalIt :: Interpreter -> String -> IO (Either String String)-safeEvalIt repl = either (return . Left) (fmap Right . evalIt repl) . filterExpression+safeEvalWith :: PreserveIt -> Interpreter -> String -> IO (Either String String)+safeEvalWith preserveIt repl = either (return . Left) (fmap Right . evalWith preserveIt repl) . filterExpression filterExpression :: String -> Either String String filterExpression e =
src/Language/Haskell/GhciWrapper.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE ViewPatterns #-} module Language.Haskell.GhciWrapper ( Interpreter , Config(..) , defaultConfig+, PreserveIt(..) , new , close , eval-, evalIt+, evalWith , evalEcho ) where @@ -29,6 +31,9 @@ , configIgnoreDotGhci = True } +data PreserveIt = NoPreserveIt | PreserveIt+ deriving Eq+ -- | Truly random marker, used to separate expressions. -- -- IMPORTANT: This module relies upon the fact that this marker is unique. It@@ -109,8 +114,8 @@ when (e /= ExitSuccess) $ do throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")") -putExpression :: Interpreter -> Bool -> String -> IO ()-putExpression Interpreter{hIn = stdin} preserveIt e = do+putExpression :: Interpreter -> PreserveIt -> String -> IO ()+putExpression Interpreter{hIn = stdin} (equals PreserveIt -> preserveIt) e = do hPutStrLn stdin e when preserveIt $ hPutStrLn stdin $ "let " ++ itMarker ++ " = it" hPutStrLn stdin (marker ++ " :: Data.String.String")@@ -140,18 +145,16 @@ -- | Evaluate an expression eval :: Interpreter -> String -> IO String-eval repl expr = do- putExpression repl False expr- getResult False repl+eval = evalWith NoPreserveIt -- | Like 'eval', but try to preserve the @it@ variable-evalIt :: Interpreter -> String -> IO String-evalIt repl expr = do- putExpression repl True expr+evalWith :: PreserveIt -> Interpreter -> String -> IO String+evalWith preserveIt repl expr = do+ putExpression repl preserveIt expr getResult False repl -- | Evaluate an expression evalEcho :: Interpreter -> String -> IO String evalEcho repl expr = do- putExpression repl False expr+ putExpression repl NoPreserveIt expr getResult True repl
src/Options.hs view
@@ -28,7 +28,7 @@ usage :: String usage = unlines [ "Usage:"- , " doctest [ --fast | --preserve-it | --no-magic | --verbose | GHC OPTION | MODULE ]..."+ , " doctest [ --fast | --preserve-it | --fail-fast | --no-magic | --verbose | GHC OPTION | MODULE ]..." , " doctest --help" , " doctest --version" , " doctest --info"@@ -36,6 +36,8 @@ , "Options:" , " --fast disable :reload between example groups" , " --preserve-it preserve the `it` variable between examples"+ , " --fail-fast abort on first failure"+ , " --no-magic disable magic mode" , " --verbose print each test as it is run" , " --help display this help and exit" , " --version output version information and exit"@@ -57,6 +59,7 @@ ghcOptions :: [String] , fastMode :: Bool , preserveIt :: Bool+, failFast :: Bool , verbose :: Bool , repl :: (String, [String]) } deriving (Eq, Show)@@ -66,6 +69,7 @@ ghcOptions = [] , fastMode = False , preserveIt = False+, failFast = False , verbose = False , repl = (ghc, ["--interactive"]) }@@ -105,6 +109,9 @@ setPreserveIt :: Bool -> Run -> Run setPreserveIt preserveIt run@Run{..} = run { runConfig = runConfig { preserveIt } } +setFailFastMode :: Bool -> Run -> Run+setFailFastMode failFast run@Run{..} = run { runConfig = runConfig { failFast } }+ setVerbose :: Bool -> Run -> Run setVerbose verbose run@Run{..} = run { runConfig = runConfig { verbose } } @@ -134,6 +141,7 @@ commonRunOptions = do parseFlag "--fast" (setFastMode True) parseFlag "--preserve-it" (setPreserveIt True)+ parseFlag "--fail-fast" (setFailFastMode True) parseFlag "--verbose" (setVerbose True) parseFlag :: String -> (Run -> Run) -> RunOptionsParser
src/Run.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} module Run ( doctest , doctestWithRepl@@ -37,6 +38,10 @@ import GHC.Utils.Panic #endif +#if __GLASGOW_HASKELL__ < 904+import GhcUtil (expandUnits)+#endif+ import PackageDBs import Parse import Options hiding (Result(..))@@ -62,7 +67,13 @@ doctest = doctestWithRepl (repl defaultConfig) doctestWithRepl :: (String, [String]) -> [String] -> IO ()-doctestWithRepl repl args0 = case parseOptions args0 of+#if __GLASGOW_HASKELL__ < 904+-- GHC versions prior to 9.4.1 don't support response files. For that reason+-- we want to expand early, so that GHCi gets expanded args.+doctestWithRepl repl = expandUnits >=> parseOptions >>> \ case+#else+doctestWithRepl repl = parseOptions >>> \ case+#endif Options.ProxyToGhc args -> exec Interpreter.ghc args Options.Output s -> putStr s Options.Result (Run warnings magicMode config) -> do@@ -136,9 +147,6 @@ type Result = Summary -isSuccess :: Result -> Bool-isSuccess s = sErrors s == 0 && sFailures s == 0- evaluateResult :: Result -> IO () evaluateResult r = unless (isSuccess r) exitFailure @@ -155,6 +163,9 @@ runDocTests :: Config -> [Module [Located DocTest]] -> IO Result runDocTests Config{..} modules = do Interpreter.withInterpreter ((<> ghcOptions) <$> repl) $ \ interpreter -> withCP65001 $ do- let- v = if verbose then Verbose else NonVerbose- runModules fastMode preserveIt v interpreter modules+ runModules+ (if fastMode then FastMode else NoFastMode)+ (if preserveIt then PreserveIt else NoPreserveIt)+ (if failFast then FailFast else NoFailFast)+ (if verbose then Verbose else NonVerbose)+ interpreter modules
src/Runner.hs view
@@ -2,13 +2,18 @@ {-# LANGUAGE LambdaCase #-} module Runner ( runModules+, FastMode(..)+, PreserveIt(..)+, FailFast(..) , Verbose(..) , Summary(..)+, isSuccess , formatSummary #ifdef TEST , Report , ReportState(..)+, runReport , Interactive(..) , report , reportTransient@@ -21,11 +26,14 @@ import Text.Printf (printf) import System.IO hiding (putStr, putStrLn) -import Control.Monad.Trans.State+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State (StateT, evalStateT)+import qualified Control.Monad.Trans.State as State import Control.Monad.IO.Class import Data.IORef -import Interpreter (Interpreter)+import Interpreter (Interpreter, PreserveIt(..), safeEvalWith) import qualified Interpreter import Parse import Location@@ -43,6 +51,9 @@ instance Show Summary where show = formatSummary +isSuccess :: Summary -> Bool+isSuccess s = sErrors s == 0 && sFailures s == 0+ formatSummary :: Summary -> String formatSummary (Summary examples tried errors failures) = printf "Examples: %d Tried: %d Errors: %d Failures: %d" examples tried errors failures@@ -50,13 +61,8 @@ -- | Sum up summaries. instance Monoid Summary where mempty = Summary 0 0 0 0-#if __GLASGOW_HASKELL__ < 804- mappend-#else instance Semigroup Summary where- (<>)-#endif- (Summary x1 x2 x3 x4) (Summary y1 y2 y3 y4) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4)+ Summary x1 x2 x3 x4 <> Summary y1 y2 y3 y4 = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) withLineBuffering :: Handle -> IO c -> IO c withLineBuffering h action = bracket (hGetBuffering h) (hSetBuffering h) $ \ _ -> do@@ -64,8 +70,8 @@ action -- | Run all examples from a list of modules.-runModules :: Bool -> Bool -> Verbose -> Interpreter -> [Module [Located DocTest]] -> IO Summary-runModules fastMode preserveIt verbose repl modules = withLineBuffering stderr $ do+runModules :: FastMode -> PreserveIt -> FailFast -> Verbose -> Interpreter -> [Module [Located DocTest]] -> IO Summary+runModules fastMode preserveIt failFast verbose repl modules = withLineBuffering stderr $ do interactive <- hIsTerminalDevice stderr <&> \ case False -> NonInteractive@@ -80,7 +86,7 @@ hPutStrLn stderr (formatSummary final) run :: IO ()- run = flip evalStateT (ReportState interactive verbose summary) $ do+ run = runReport (ReportState interactive failFast verbose summary) $ do reportProgress forM_ modules $ runModule fastMode preserveIt repl verboseReport "# Final summary:"@@ -95,22 +101,32 @@ countExpressions :: Module [Located DocTest] -> Int countExpressions (Module _ setup tests) = sum (map length tests) + maybe 0 length setup -type Report = StateT ReportState IO+type Report = MaybeT (StateT ReportState IO) data Interactive = NonInteractive | Interactive +data FastMode = NoFastMode | FastMode++data FailFast = NoFailFast | FailFast+ data Verbose = NonVerbose | Verbose- deriving (Eq, Show) data ReportState = ReportState { reportStateInteractive :: Interactive+, reportStateFailFast :: FailFast , reportStateVerbose :: Verbose , reportStateSummary :: IORef Summary } +runReport :: ReportState -> Report () -> IO ()+runReport st = void . flip evalStateT st . runMaybeT+ getSummary :: Report Summary getSummary = gets reportStateSummary >>= liftIO . readIORef +gets :: (ReportState -> a) -> Report a+gets = lift . State.gets+ -- | Add output to the report. report :: String -> Report () report = liftIO . hPutStrLn stderr@@ -128,7 +144,7 @@ hPutStr stderr $ '\r' : (replicate (length msg) ' ') ++ "\r" -- | Run all examples from given module.-runModule :: Bool -> Bool -> Interpreter -> Module [Located DocTest] -> Report ()+runModule :: FastMode -> PreserveIt -> Interpreter -> Module [Located DocTest] -> Report () runModule fastMode preserveIt repl (Module module_ setup examples) = do Summary _ _ e0 f0 <- getSummary@@ -140,23 +156,23 @@ -- only run tests, if setup does not produce any errors/failures when (e0 == e1 && f0 == f1) $- forM_ examples $- runTestGroup preserveIt repl setup_+ forM_ examples $ runTestGroup preserveIt repl setup_ where reload :: IO () reload = do- unless fastMode $- -- NOTE: It is important to do the :reload first! See- -- https://gitlab.haskell.org/ghc/ghc/-/issues/5904, which results in a- -- panic on GHC 7.4.1 if you do the :reload second.- void $ Interpreter.safeEval repl ":reload"+ case fastMode of+ NoFastMode -> void $ Interpreter.safeEval repl ":reload"+ FastMode -> pass void $ Interpreter.safeEval repl $ ":m *" ++ module_ - when preserveIt $- -- Evaluate a dumb expression to populate the 'it' variable NOTE: This is- -- one reason why we cannot have safeEval = safeEvalIt: 'it' isn't set in- -- a fresh GHCi session.- void $ Interpreter.safeEval repl $ "()"+ case preserveIt of+ NoPreserveIt -> pass+ PreserveIt -> do+ -- Evaluate a dumb expression to populate the 'it' variable.+ --+ -- NOTE: This is one reason why we cannot just always use PreserveIt:+ -- 'it' isn't set in a fresh GHCi session.+ void $ Interpreter.safeEval repl $ "()" setup_ :: IO () setup_ = do@@ -198,7 +214,13 @@ ref <- gets reportStateSummary liftIO $ modifyIORef' ref $ mappend summary reportProgress+ gets reportStateFailFast >>= \ case+ NoFailFast -> pass+ FailFast -> unless (isSuccess summary) abort +abort :: Report ()+abort = MaybeT $ return Nothing+ reportProgress :: Report () reportProgress = gets reportStateVerbose >>= \ case NonVerbose -> do@@ -210,7 +232,7 @@ -- -- The interpreter state is zeroed with @:reload@ first. This means that you -- can reuse the same 'Interpreter' for several test groups.-runTestGroup :: Bool -> Interpreter -> IO () -> [Located DocTest] -> Report ()+runTestGroup :: PreserveIt -> Interpreter -> IO () -> [Located DocTest] -> Report () runTestGroup preserveIt repl setup tests = do liftIO setup runExampleGroup preserveIt repl examples@@ -238,7 +260,7 @@ -- | -- Execute all expressions from given example in given 'Interpreter' and verify -- the output.-runExampleGroup :: Bool -> Interpreter -> [Located Interaction] -> Report ()+runExampleGroup :: PreserveIt -> Interpreter -> [Located Interaction] -> Report () runExampleGroup preserveIt repl = go where go ((Located loc (expression, expected)) : xs) = do@@ -254,8 +276,3 @@ reportSuccess go xs go [] = return ()--safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String)-safeEvalWith preserveIt- | preserveIt = Interpreter.safeEvalIt- | otherwise = Interpreter.safeEval
test/Language/Haskell/GhciWrapperSpec.hs view
@@ -8,7 +8,7 @@ import Data.List -import Language.Haskell.GhciWrapper (Interpreter, Config(..), defaultConfig)+import Language.Haskell.GhciWrapper (Interpreter, Config(..), defaultConfig, PreserveIt(..)) import qualified Language.Haskell.GhciWrapper as Interpreter main :: IO ()@@ -30,11 +30,12 @@ withInterpreterConfig defaultConfig [] $ \ghci -> do (capture $ Interpreter.evalEcho ghci ("putStr" ++ show "foo\nbar")) `shouldReturn` ("foo\nbar", "foo\nbar") - describe "evalIt" $ do- it "preserves it" $ do- withInterpreterConfig defaultConfig [] $ \ghci -> do- Interpreter.evalIt ghci "23" `shouldReturn` "23\n"- Interpreter.eval ghci "it" `shouldReturn` "23\n"+ describe "evalWith" $ do+ context "with PreserveIt" $ do+ it "preserves it" $ do+ withInterpreterConfig defaultConfig [] $ \ghci -> do+ Interpreter.evalWith PreserveIt ghci "23" `shouldReturn` "23\n"+ Interpreter.eval ghci "it" `shouldReturn` "23\n" describe "eval" $ do it "shows literals" $ withInterpreter $ \ghci -> do@@ -77,20 +78,19 @@ it "shows exceptions" $ withInterpreter $ \ghci -> do ghci "import Control.Exception" `shouldReturn` ""+#if __GLASGOW_HASKELL__ >= 912+ ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n\nHasCallStack backtrace:\n throwIO, called at <interactive>:25:1 in interactive:Ghci22\n\n"+#else ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n"+#endif it "shows exceptions (ExitCode)" $ withInterpreter $ \ghci -> do ghci "import System.Exit" `shouldReturn` "" ghci "exitWith $ ExitFailure 10" `shouldReturn` "*** Exception: ExitFailure 10\n" it "gives an error message for identifiers that are not in scope" $ withInterpreter $ \ghci -> do-#if __GLASGOW_HASKELL__ >= 800 ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo")-#elif __GLASGOW_HASKELL__ >= 707- ghci "foo" >>= (`shouldSatisfy` isSuffixOf "Not in scope: \8216foo\8217\n")-#else- ghci "foo" >>= (`shouldSatisfy` isSuffixOf "Not in scope: `foo'\n")-#endif+ context "when configVerbose is True" $ do it "prints prompt" $ do withInterpreterConfig defaultConfig{configVerbose = True} [] $ \ghci -> do
test/MainSpec.hs view
@@ -9,7 +9,7 @@ import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.FilePath-import Run hiding (doctest)+import Run hiding (doctest, doctestWith) import System.IO.Silently import System.IO @@ -19,13 +19,18 @@ setCurrentDirectory workingDir action --- | Construct a doctest specific 'Assertion'. doctest :: HasCallStack => FilePath -> [String] -> Summary -> Assertion-doctest = doctestWithPreserveIt False+doctest = doctestWith False False -doctestWithPreserveIt :: HasCallStack => Bool -> FilePath -> [String] -> Summary -> Assertion-doctestWithPreserveIt preserveIt workingDir ghcOptions expected = do- actual <- withCurrentDirectory ("test/integration" </> workingDir) (hSilence [stderr] $ doctestWithResult defaultConfig {ghcOptions, preserveIt})+doctestWithPreserveIt :: HasCallStack => FilePath -> [String] -> Summary -> Assertion+doctestWithPreserveIt = doctestWith True False++doctestWithFailFast :: HasCallStack => FilePath -> [String] -> Summary -> Assertion+doctestWithFailFast = doctestWith False True++doctestWith :: HasCallStack => Bool -> Bool -> FilePath -> [String] -> Summary -> Assertion+doctestWith preserveIt failFast workingDir ghcOptions expected = do+ actual <- withCurrentDirectory ("test/integration" </> workingDir) (hSilence [stderr] $ doctestWithResult defaultConfig {ghcOptions, preserveIt, failFast}) assertEqual label (formatSummary expected) (formatSummary actual) where label = workingDir ++ " " ++ show ghcOptions@@ -44,20 +49,34 @@ (cases 1) it "it-variable" $ do- doctestWithPreserveIt True "." ["it/Foo.hs"]+ doctestWithPreserveIt "." ["it/Foo.hs"] (cases 5) it "it-variable in $setup" $ do- doctestWithPreserveIt True "." ["it/Setup.hs"]+ doctestWithPreserveIt "." ["it/Setup.hs"] (cases 5) it "failing" $ do doctest "." ["failing/Foo.hs"] (cases 1) {sFailures = 1} - it "skips subsequent examples from the same group if an example fails" $+ it "skips subsequent examples from the same group if an example fails" $ do doctest "." ["failing-multiple/Foo.hs"] (cases 4) {sTried = 2, sFailures = 1}++ context "without --fail-fast" $ do+ it "continuous even if some tests fail" $ do+ doctest "fail-fast" ["Foo.hs"]+ (cases 4) {sTried = 4, sFailures = 1}++ context "with --fail-fast" $ do+ it "stops after the first failure" $ do+ doctestWithFailFast "fail-fast" ["Foo.hs"]+ (cases 4) {sTried = 2, sFailures = 1}++ it "stops after failures in $setup" $ do+ doctestWithFailFast "fail-fast" ["SetupFoo.hs"]+ (cases 6) {sTried = 1, sFailures = 1} it "testImport" $ do doctest "testImport" ["ModuleA.hs"]
test/OptionsSpec.hs view
@@ -65,7 +65,7 @@ fastMode . runConfig <$> parseOptions [] `shouldBe` Result False context "with --fast" $ do- it "enabled fast mode" $ do+ it "enables fast mode" $ do fastMode . runConfig <$> parseOptions ["--fast"] `shouldBe` Result True describe "--preserve-it" $ do@@ -76,6 +76,15 @@ context "with --preserve-it" $ do it "preserves the `it` variable" $ do preserveIt . runConfig <$> parseOptions ["--preserve-it"] `shouldBe` Result True++ describe "--fail-fast" $ do+ context "without --fail-fast" $ do+ it "disables fail-fast mode" $ do+ failFast . runConfig <$> parseOptions [] `shouldBe` Result False++ context "with --fail-fast" $ do+ it "enables fail-fast mode" $ do+ failFast . runConfig <$> parseOptions ["--fail-fast"] `shouldBe` Result True context "with --help" $ do it "outputs usage information" $ do
test/RunSpec.hs view
@@ -9,8 +9,8 @@ import qualified Control.Exception as E import System.FilePath import System.Directory (getCurrentDirectory, setCurrentDirectory)+import System.IO.Temp (withSystemTempDirectory) import Data.List (isPrefixOf, sort)-import Data.Char import System.IO.Silently import System.IO (stderr)@@ -35,6 +35,17 @@ removeLoadedPackageEnvironment = id #endif +verboseFibOutput :: String+verboseFibOutput = unlines [+ "### Started execution at test/integration/testSimple/Fib.hs:5."+ , "### example:"+ , "fib 10"+ , "### Successful!"+ , ""+ , "# Final summary:"+ , "Examples: 1 Tried: 1 Errors: 0 Failures: 0"+ ]+ spec :: Spec spec = do describe "doctest" $ do@@ -70,17 +81,18 @@ , "Try `doctest --help' for more information." ] + it "interprets GHC response files" $ do+ withSystemTempDirectory "hspec" $ \ dir -> do+ let file = dir </> "response-file"+ writeFile file $ unlines [+ "test/integration/testSimple/Fib.hs"+ ]+ (r, ()) <- hCapture [stderr] $ doctest ["--verbose", '@':file]+ removeLoadedPackageEnvironment r `shouldBe` verboseFibOutput+ it "prints verbose description of a specification" $ do (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "test/integration/testSimple/Fib.hs"]- removeLoadedPackageEnvironment r `shouldBe` unlines [- "### Started execution at test/integration/testSimple/Fib.hs:5."- , "### example:"- , "fib 10"- , "### Successful!"- , ""- , "# Final summary:"- , "Examples: 1 Tried: 1 Errors: 0 Failures: 0"- ]+ removeLoadedPackageEnvironment r `shouldBe` verboseFibOutput it "prints verbose description of a property" $ do (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "test/integration/property-bool/Foo.hs"]@@ -118,15 +130,33 @@ describe "doctestWithResult" $ do context "on parse error" $ do let+ action :: IO Result action = withCurrentDirectory "test/integration/parse-error" $ do- doctestWithResult defaultConfig { ghcOptions = ["Foo.hs"] }+ doctestWithResult defaultConfig {+ ghcOptions = [+ "Foo.hs" + -- This is necessary due to:+ --+ -- https://gitlab.haskell.org/ghc/ghc/-/commit/88f38b03025386f0f1e8f5861eed67d80495168a+ --+ -- It will be fixed by:+ --+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15995+ --+ , "-fdiagnostics-color=never"+#if __GLASGOW_HASKELL__ >= 910+ , "-fprint-error-index-links=never"+#endif+ ]+ }+ it "aborts with (ExitFailure 1)" $ do hSilence [stderr] action `shouldThrow` (== ExitFailure 1) it "prints a useful error message" $ do (r, _) <- hCapture [stderr] (E.try action :: IO (Either ExitCode Summary))- stripAnsiColors (removeLoadedPackageEnvironment r) `shouldBe` unlines (+ removeLoadedPackageEnvironment r `shouldBe` unlines ( #if __GLASGOW_HASKELL__ < 910 "" : #endif@@ -155,10 +185,3 @@ let x = "foo bar baz bin" res <- expandDirs x res `shouldBe` [x]--stripAnsiColors :: String -> String-stripAnsiColors xs = case xs of- '\ESC' : '[' : ';' : ys | 'm' : zs <- dropWhile isNumber ys -> stripAnsiColors zs- '\ESC' : '[' : ys | 'm' : zs <- dropWhile isNumber ys -> stripAnsiColors zs- y : ys -> y : stripAnsiColors ys- [] -> []
test/RunnerSpec.hs view
@@ -8,13 +8,12 @@ import Data.IORef import System.IO import System.IO.Silently (hCapture_)-import Control.Monad.Trans.State import Runner -capture :: Interactive -> Report a -> IO String+capture :: Interactive -> Report () -> IO String capture interactive action = do ref <- newIORef mempty- hCapture_ [stderr] (evalStateT action (ReportState interactive NonVerbose ref))+ hCapture_ [stderr] (runReport (ReportState interactive NoFailFast NonVerbose ref) action) spec :: Spec spec = do
+ test/integration/fail-fast/Bar.hs view
@@ -0,0 +1,8 @@+module Bar where++-- | bar+-- a passing test+-- >>> bar+-- 42+bar :: Int+bar = 42
+ test/integration/fail-fast/Foo.hs view
@@ -0,0 +1,24 @@+module Foo where++import Bar++-- | A passing example+--+-- >>> 23+-- 23+test1 :: a+test1 = undefined++-- | A failing example+--+-- >>> 23+-- 42+test2 :: a+test2 = undefined++-- | Another passing example+--+-- >>> 23+-- 23+test3 :: a+test3 = undefined
+ test/integration/fail-fast/SetupBar.hs view
@@ -0,0 +1,12 @@+module SetupBar where++-- $setup+-- >>> 23+-- 23++-- | bar+-- a passing test+-- >>> bar+-- 42+bar :: Int+bar = 42
+ test/integration/fail-fast/SetupFoo.hs view
@@ -0,0 +1,29 @@+module SetupFoo where++import SetupBar+++-- $setup+-- >>> 24+-- 23++-- | A passing example+--+-- >>> 23+-- 23+test1 :: a+test1 = undefined++-- | A failing example+--+-- >>> 23+-- 42+test2 :: a+test2 = undefined++-- | Another passing example+--+-- >>> 23+-- 23+test3 :: a+test3 = undefined