diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,6 @@ +Changes in 0.22.0 + - Export more internals + Changes in 0.21.1 - GHC 9.6 compatibility. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009-2022 Simon Hengel +Copyright (c) 2009-2023 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: doctest -version: 0.21.1 +version: 0.22.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,9 +18,9 @@ homepage: https://github.com/sol/doctest#readme license: MIT license-file: LICENSE -copyright: (c) 2009-2022 Simon Hengel +copyright: (c) 2009-2023 Simon Hengel author: Simon Hengel -maintainer: quasicomputational@gmail.com, Andreas Abel +maintainer: Simon Hengel build-type: Simple extra-source-files: example/example.cabal @@ -111,8 +111,16 @@ ghc-options: -Wall hs-source-dirs: src + default-extensions: + NamedFieldPuns + RecordWildCards + DeriveFunctor exposed-modules: Test.DocTest + Test.DocTest.Internal.Extract + Test.DocTest.Internal.Location + Test.DocTest.Internal.Parse + Test.DocTest.Internal.Run other-modules: Extract GhcUtil @@ -151,6 +159,10 @@ ghc-options: -Wall -threaded hs-source-dirs: driver + default-extensions: + NamedFieldPuns + RecordWildCards + DeriveFunctor build-depends: base >=4.5 && <5 , base-compat >=0.7.0 @@ -177,7 +189,6 @@ LocationSpec MainSpec OptionsSpec - Orphans PackageDBsSpec ParseSpec PropertySpec @@ -199,6 +210,10 @@ Runner Runner.Example Test.DocTest + Test.DocTest.Internal.Extract + Test.DocTest.Internal.Location + Test.DocTest.Internal.Parse + Test.DocTest.Internal.Run Util Paths_doctest type: exitcode-stdio-1.0 @@ -207,6 +222,10 @@ hs-source-dirs: test src + default-extensions: + NamedFieldPuns + RecordWildCards + DeriveFunctor c-sources: test/integration/with-cbits/foo.c build-tool-depends: diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} +{-# LANGUAGE CPP #-} module Extract (Module(..), extract) where import Prelude hiding (mod, concat) @@ -83,7 +83,7 @@ moduleName :: String , moduleSetup :: Maybe a , moduleContent :: [a] -} deriving (Eq, Functor) +} deriving (Eq, Show, Functor) instance NFData a => NFData (Module a) where rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` () diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} - module Interpreter ( Interpreter , safeEval diff --git a/src/Language/Haskell/GhciWrapper.hs b/src/Language/Haskell/GhciWrapper.hs --- a/src/Language/Haskell/GhciWrapper.hs +++ b/src/Language/Haskell/GhciWrapper.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} module Language.Haskell.GhciWrapper ( Interpreter , Config(..) diff --git a/src/Location.hs b/src/Location.hs --- a/src/Location.hs +++ b/src/Location.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveFunctor #-} +{-# LANGUAGE CPP #-} module Location where import Control.DeepSeq (deepseq, NFData(rnf)) diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} module Options ( Result(..) , Run(..) +, Config(..) +, defaultConfig , parseOptions #ifdef TEST , defaultRun @@ -42,20 +43,32 @@ , " --info output machine-readable version information and exit" ] -data Result a = RunGhc [String] | Output String | Result a +data Result a = ProxyToGhc [String] | Output String | Result a deriving (Eq, Show, Functor) type Warning = String data Run = Run { runWarnings :: [Warning] -, runOptions :: [String] , runMagicMode :: Bool -, runFastMode :: Bool -, runPreserveIt :: Bool -, runVerbose :: Bool +, runConfig :: Config } deriving (Eq, Show) +data Config = Config { + ghcOptions :: [String] +, fastMode :: Bool +, preserveIt :: Bool +, verbose :: Bool +} deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = Config { + ghcOptions = [] +, fastMode = False +, preserveIt = False +, verbose = False +} + nonInteractiveGhcOptions :: [String] nonInteractiveGhcOptions = [ "--numeric-version" @@ -72,37 +85,34 @@ defaultRun :: Run defaultRun = Run { runWarnings = [] -, runOptions = [] , runMagicMode = False -, runFastMode = False -, runPreserveIt = False -, runVerbose = False +, runConfig = defaultConfig } modifyWarnings :: ([String] -> [String]) -> Run -> Run modifyWarnings f run = run { runWarnings = f (runWarnings run) } setOptions :: [String] -> Run -> Run -setOptions opts run = run { runOptions = opts } +setOptions ghcOptions run@Run{..} = run { runConfig = runConfig { ghcOptions } } setMagicMode :: Bool -> Run -> Run setMagicMode magic run = run { runMagicMode = magic } setFastMode :: Bool -> Run -> Run -setFastMode fast run = run { runFastMode = fast } +setFastMode fastMode run@Run{..} = run { runConfig = runConfig { fastMode } } setPreserveIt :: Bool -> Run -> Run -setPreserveIt preserveIt run = run { runPreserveIt = preserveIt } +setPreserveIt preserveIt run@Run{..} = run { runConfig = runConfig { preserveIt } } setVerbose :: Bool -> Run -> Run -setVerbose verbose run = run { runVerbose = verbose } +setVerbose verbose run@Run{..} = run { runConfig = runConfig { verbose } } parseOptions :: [String] -> Result Run parseOptions args | on "--info" = Output info | on "--interactive" = runRunOptionsParser (discard "--interactive" args) defaultRun $ do commonRunOptions - | on `any` nonInteractiveGhcOptions = RunGhc args + | on `any` nonInteractiveGhcOptions = ProxyToGhc args | on "--help" = Output usage | on "--version" = Output versionInfo | otherwise = runRunOptionsParser args defaultRun {runMagicMode = True} $ do diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Parse ( Module (..) , DocTest (..) -, Interaction , Expression , ExpectedResult , ExpectedLine (..) , LineChunk (..) -, getDocTests +, extractDocTests +, parseModules --- * exported for testing +#ifdef TEST , parseInteractions , parseProperties , mkLineChunks +#endif ) where import Data.Char (isSpace) @@ -44,12 +45,15 @@ type Interaction = (Expression, ExpectedResult) - -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules. -getDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's -getDocTests args = parseModules <$> extract args +-- +-- @ +-- extractDocTests = fmap `parseModules` . `extract` +-- @ +extractDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's +extractDocTests = fmap parseModules . extract parseModules :: [Module (Located String)] -> [Module [Located DocTest]] parseModules = filter (not . isEmpty) . map parseModule diff --git a/src/Property.hs b/src/Property.hs --- a/src/Property.hs +++ b/src/Property.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE PatternGuards #-} module Property ( runProperty , PropertyResult (..) diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -1,9 +1,19 @@ {-# LANGUAGE CPP #-} module Run ( doctest + +, Config(..) +, defaultConfig +, doctestWith + +, Result +, Summary(..) +, isSuccess +, evaluateResult +, doctestWithResult + +, runDocTests #ifdef TEST -, doctestWithOptions -, Summary , expandDirs #endif ) where @@ -11,7 +21,7 @@ import Prelude () import Prelude.Compat -import Control.Monad (when, unless) +import Control.Monad import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) import System.Environment (getEnvironment) import System.Exit (exitFailure, exitSuccess) @@ -30,8 +40,10 @@ import PackageDBs import Parse -import Options +import Options hiding (Result(..)) +import qualified Options import Runner +import Location import qualified Interpreter -- | Run doctest with given list of arguments. @@ -49,9 +61,9 @@ -- inside of it, ignoring hidden entries. doctest :: [String] -> IO () doctest args0 = case parseOptions args0 of - RunGhc args -> rawSystem Interpreter.ghc args >>= E.throwIO - Output s -> putStr s - Result (Run warnings args_ magicMode fastMode preserveIt verbose) -> do + Options.ProxyToGhc args -> rawSystem Interpreter.ghc args >>= E.throwIO + Options.Output s -> putStr s + Options.Result (Run warnings magicMode config) -> do mapM_ (hPutStrLn stderr) warnings hFlush stderr @@ -60,22 +72,14 @@ hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests" exitSuccess - args <- case magicMode of - False -> return args_ + opts <- case magicMode of + False -> return (ghcOptions config) True -> do - expandedArgs <- concat <$> mapM expandDirs args_ + expandedArgs <- concat <$> mapM expandDirs (ghcOptions config) packageDBArgs <- getPackageDBArgs addDistArgs <- getAddDistArgs return (addDistArgs $ packageDBArgs ++ expandedArgs) - - r <- doctestWithOptions fastMode preserveIt verbose args `E.catch` \e -> do - case fromException e of - Just (UsageError err) -> do - hPutStrLn stderr ("doctest: " ++ err) - hPutStrLn stderr "Try `doctest --help' for more information." - exitFailure - _ -> E.throwIO e - when (not $ isSuccess r) exitFailure + doctestWith config{ghcOptions = opts} -- | Expand a reference to a directory to all .hs and .lhs files within it. expandDirs :: String -> IO [String] @@ -128,14 +132,28 @@ else id) rest else return id -isSuccess :: Summary -> Bool +doctestWith :: Config -> IO () +doctestWith = doctestWithResult >=> evaluateResult + +type Result = Summary + +isSuccess :: Result -> Bool isSuccess s = sErrors s == 0 && sFailures s == 0 -doctestWithOptions :: Bool -> Bool -> Bool -> [String] -> IO Summary -doctestWithOptions fastMode preserveIt verbose args = do +evaluateResult :: Result -> IO () +evaluateResult r = when (not $ isSuccess r) exitFailure - -- get examples from Haddock comments - modules <- getDocTests args +doctestWithResult :: Config -> IO Result +doctestWithResult config = do + (extractDocTests (ghcOptions config) >>= runDocTests config) `E.catch` \e -> do + case fromException e of + Just (UsageError err) -> do + hPutStrLn stderr ("doctest: " ++ err) + hPutStrLn stderr "Try `doctest --help' for more information." + exitFailure + _ -> E.throwIO e - Interpreter.withInterpreter args $ \repl -> withCP65001 $ do +runDocTests :: Config -> [Module [Located DocTest]] -> IO Result +runDocTests Config{..} modules = do + Interpreter.withInterpreter ghcOptions $ \repl -> withCP65001 $ do runModules fastMode preserveIt verbose repl modules diff --git a/src/Runner.hs b/src/Runner.hs --- a/src/Runner.hs +++ b/src/Runner.hs @@ -215,6 +215,8 @@ examples :: [Located Interaction] examples = [Located loc (e, r) | Located loc (Example e r) <- tests] +type Interaction = (Expression, ExpectedResult) + -- | -- Execute all expressions from given example in given 'Interpreter' and verify -- the output. diff --git a/src/Test/DocTest.hs b/src/Test/DocTest.hs --- a/src/Test/DocTest.hs +++ b/src/Test/DocTest.hs @@ -1,5 +1,4 @@ module Test.DocTest ( doctest ) where - -import Run +import Test.DocTest.Internal.Run diff --git a/src/Test/DocTest/Internal/Extract.hs b/src/Test/DocTest/Internal/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Extract.hs @@ -0,0 +1,4 @@ +module Test.DocTest.Internal.Extract ( + module Extract +) where +import Extract diff --git a/src/Test/DocTest/Internal/Location.hs b/src/Test/DocTest/Internal/Location.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Location.hs @@ -0,0 +1,4 @@ +module Test.DocTest.Internal.Location ( + module Location +) where +import Location diff --git a/src/Test/DocTest/Internal/Parse.hs b/src/Test/DocTest/Internal/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Parse.hs @@ -0,0 +1,4 @@ +module Test.DocTest.Internal.Parse ( + module Parse +) where +import Parse diff --git a/src/Test/DocTest/Internal/Run.hs b/src/Test/DocTest/Internal/Run.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Run.hs @@ -0,0 +1,4 @@ +module Test.DocTest.Internal.Run ( + module Run +) where +import Run diff --git a/test/ExtractSpec.hs b/test/ExtractSpec.hs --- a/test/ExtractSpec.hs +++ b/test/ExtractSpec.hs @@ -18,8 +18,6 @@ import Location import System.FilePath -import Orphans () - shouldGive :: HasCallStack => (String, String) -> [Module String] -> Assertion (d, m) `shouldGive` expected = do r <- map (fmap unLoc) `fmap` extract ["-i" ++ dir, dir m] diff --git a/test/MainSpec.hs b/test/MainSpec.hs --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -8,7 +8,6 @@ import Control.Exception import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.FilePath -import Runner (Summary(..)) import Run hiding (doctest) import System.IO.Silently import System.IO @@ -24,11 +23,11 @@ doctest = doctestWithPreserveIt False doctestWithPreserveIt :: HasCallStack => Bool -> FilePath -> [String] -> Summary -> Assertion -doctestWithPreserveIt preserveIt workingDir args expected = do - actual <- withCurrentDirectory ("test/integration" workingDir) (hSilence [stderr] $ doctestWithOptions False preserveIt False args) +doctestWithPreserveIt preserveIt workingDir ghcOptions expected = do + actual <- withCurrentDirectory ("test/integration" workingDir) (hSilence [stderr] $ doctestWithResult defaultConfig {ghcOptions, preserveIt}) assertEqual label expected actual where - label = workingDir ++ " " ++ show args + label = workingDir ++ " " ++ show ghcOptions cases :: Int -> Summary cases n = Summary n n 0 0 diff --git a/test/OptionsSpec.hs b/test/OptionsSpec.hs --- a/test/OptionsSpec.hs +++ b/test/OptionsSpec.hs @@ -5,7 +5,7 @@ import Data.List.Compat import Test.Hspec -import Test.QuickCheck +import Test.QuickCheck hiding (verbose) import Options @@ -20,10 +20,10 @@ describe "parseOptions" $ do let run :: [String] -> Run - run options = defaultRun { + run ghcOptions = defaultRun { runWarnings = ["WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."] - , runOptions = options , runMagicMode = True + , runConfig = defaultConfig { ghcOptions } } it "strips --optghc" $ @@ -33,10 +33,10 @@ parseOptions ["--optghc=foobar"] `shouldBe` Result (run ["foobar"]) context "with ghc options that are not valid with --interactive" $ do - it "returns RunGhc" $ do + it "returns ProxyToGhc" $ do property $ \ (NonInteractive x) xs -> do let options = x : xs - parseOptions options `shouldBe` RunGhc options + parseOptions options `shouldBe` ProxyToGhc options context "with --interactive" $ do let options = ["--interactive", "--foo", "--bar"] @@ -45,10 +45,10 @@ runMagicMode <$> parseOptions options `shouldBe` Result False it "filters out --interactive" $ do - runOptions <$> parseOptions options `shouldBe` Result ["--foo", "--bar"] + ghcOptions . runConfig <$> parseOptions options `shouldBe` Result ["--foo", "--bar"] it "accepts --fast" $ do - runFastMode <$> parseOptions ("--fast" : options) `shouldBe` Result True + fastMode . runConfig <$> parseOptions ("--fast" : options) `shouldBe` Result True describe "--no-magic" $ do context "without --no-magic" $ do @@ -62,20 +62,20 @@ describe "--fast" $ do context "without --fast" $ do it "disables fast mode" $ do - runFastMode <$> parseOptions [] `shouldBe` Result False + fastMode . runConfig <$> parseOptions [] `shouldBe` Result False context "with --fast" $ do it "enabled fast mode" $ do - runFastMode <$> parseOptions ["--fast"] `shouldBe` Result True + fastMode . runConfig <$> parseOptions ["--fast"] `shouldBe` Result True describe "--preserve-it" $ do context "without --preserve-it" $ do it "does not preserve the `it` variable" $ do - runPreserveIt <$> parseOptions [] `shouldBe` Result False + preserveIt . runConfig <$> parseOptions [] `shouldBe` Result False context "with --preserve-it" $ do it "preserves the `it` variable" $ do - runPreserveIt <$> parseOptions ["--preserve-it"] `shouldBe` Result True + preserveIt . runConfig <$> parseOptions ["--preserve-it"] `shouldBe` Result True context "with --help" $ do it "outputs usage information" $ do @@ -92,8 +92,8 @@ describe "--verbose" $ do context "without --verbose" $ do it "is not verbose by default" $ do - runVerbose <$> parseOptions [] `shouldBe` Result False + verbose . runConfig <$> parseOptions [] `shouldBe` Result False context "with --verbose" $ do it "parses verbose option" $ do - runVerbose <$> parseOptions ["--verbose"] `shouldBe` Result True + verbose . runConfig <$> parseOptions ["--verbose"] `shouldBe` Result True diff --git a/test/Orphans.hs b/test/Orphans.hs deleted file mode 100644 --- a/test/Orphans.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Orphans where - -import Parse -import Location - --- The generic form --- --- > deriving instance Show a => Show (Module a) --- --- fails with GHC 7.0.1 due to an overlapping instance (leaked by the GHC API), --- this is why we derive the things we need individually. -deriving instance Show (Module String) -deriving instance Show (Module [DocTest]) -deriving instance Show (Module [Located DocTest]) diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs --- a/test/ParseSpec.hs +++ b/test/ParseSpec.hs @@ -9,8 +9,6 @@ import Parse import Location -import Orphans () - main :: IO () main = hspec spec @@ -31,9 +29,9 @@ spec :: Spec spec = do - describe "getDocTests" $ do + describe "extractDocTests" $ do it "extracts properties from a module" $ do - getDocTests ["test/parse/property/Fib.hs"] `shouldGive` do + extractDocTests ["test/parse/property/Fib.hs"] `shouldGive` do module_ "Fib" $ do group $ do prop_ "foo" @@ -41,7 +39,7 @@ prop_ "baz" it "extracts examples from a module" $ do - getDocTests ["test/parse/simple/Fib.hs"] `shouldGive` do + extractDocTests ["test/parse/simple/Fib.hs"] `shouldGive` do module_ "Fib" $ do group $ do ghci "putStrLn \"foo\"" @@ -52,7 +50,7 @@ "baz" it "extracts examples from documentation for non-exported names" $ do - getDocTests ["test/parse/non-exported/Fib.hs"] `shouldGive` do + extractDocTests ["test/parse/non-exported/Fib.hs"] `shouldGive` do module_ "Fib" $ do group $ do ghci "putStrLn \"foo\"" @@ -63,7 +61,7 @@ "baz" it "extracts multiple examples from a module" $ do - getDocTests ["test/parse/multiple-examples/Foo.hs"] `shouldGive` do + extractDocTests ["test/parse/multiple-examples/Foo.hs"] `shouldGive` do module_ "Foo" $ do group $ do ghci "foo" @@ -73,17 +71,17 @@ "42" it "returns an empty list, if documentation contains no examples" $ do - getDocTests ["test/parse/no-examples/Fib.hs"] >>= (`shouldBe` []) + extractDocTests ["test/parse/no-examples/Fib.hs"] >>= (`shouldBe` []) it "sets setup code to Nothing, if it does not contain any tests" $ do - getDocTests ["test/parse/setup-empty/Foo.hs"] `shouldGive` do + extractDocTests ["test/parse/setup-empty/Foo.hs"] `shouldGive` do module_ "Foo" $ do group $ do ghci "foo" "23" it "keeps modules that only contain setup code" $ do - getDocTests ["test/parse/setup-only/Foo.hs"] `shouldGive` do + extractDocTests ["test/parse/setup-only/Foo.hs"] `shouldGive` do tell [Module "Foo" (Just [Example "foo" ["23"]]) []] describe "parseInteractions (an internal function)" $ do diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -19,9 +19,6 @@ import Run -doctestWithDefaultOptions :: [String] -> IO Summary -doctestWithDefaultOptions = doctestWithOptions False False False - withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory workingDir action = do E.bracket getCurrentDirectory setCurrentDirectory $ \_ -> do @@ -119,9 +116,11 @@ hSilence [stderr] $ doctest ["-fdiagnostics-color=always", "test/integration/color/Foo.hs"] #endif - describe "doctestWithOptions" $ do + describe "doctestWithResult" $ do context "on parse error" $ do - let action = withCurrentDirectory "test/integration/parse-error" (doctestWithDefaultOptions ["Foo.hs"]) + let + action = withCurrentDirectory "test/integration/parse-error" $ do + doctestWithResult defaultConfig { ghcOptions = ["Foo.hs"] } it "aborts with (ExitFailure 1)" $ do hSilence [stderr] action `shouldThrow` (== ExitFailure 1)