Skip to content

Commit

Permalink
Add doctestWith / doctestWithResult
Browse files Browse the repository at this point in the history
  • Loading branch information
sol committed Jul 15, 2023
1 parent cfa77ba commit 14da19e
Show file tree
Hide file tree
Showing 9 changed files with 92 additions and 56 deletions.
2 changes: 2 additions & 0 deletions .ghci
Original file line number Diff line number Diff line change
@@ -1 +1,3 @@
:set -DTEST -isrc -itest -packageghc -XHaskell2010
:set -XNamedFieldPuns
:set -XRecordWildCards
9 changes: 9 additions & 0 deletions doctest.cabal

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

4 changes: 4 additions & 0 deletions package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,10 @@ maintainer: Simon Hengel <[email protected]>

github: sol/doctest

default-extensions:
- NamedFieldPuns
- RecordWildCards

extra-source-files:
- example/**/*
- test/parse/**/*
Expand Down
1 change: 0 additions & 1 deletion src/Language/Haskell/GhciWrapper.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
{-# LANGUAGE RecordWildCards #-}
module Language.Haskell.GhciWrapper (
Interpreter
, Config(..)
Expand Down
35 changes: 23 additions & 12 deletions src/Options.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,8 @@
module Options (
Result(..)
, Run(..)
, Config(..)
, defaultConfig
, parseOptions
#ifdef TEST
, defaultRun
Expand Down Expand Up @@ -49,13 +51,25 @@ 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"
Expand All @@ -72,30 +86,27 @@ nonInteractiveGhcOptions = [
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
Expand Down
59 changes: 36 additions & 23 deletions src/Run.hs
Original file line number Diff line number Diff line change
@@ -1,17 +1,25 @@
{-# LANGUAGE CPP #-}
module Run (
doctest

, Config(..)
, defaultConfig
, doctestWith

, Summary(..)
, isSuccess
, evaluateSummary
, doctestWithResult

#ifdef TEST
, doctestWithOptions
, Summary
, expandDirs
#endif
) where

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)
Expand All @@ -32,6 +40,7 @@ import PackageDBs
import Parse
import Options
import Runner
import Location
import qualified Interpreter

-- | Run doctest with given list of arguments.
Expand All @@ -51,7 +60,7 @@ doctest :: [String] -> IO ()
doctest args0 = case parseOptions args0 of
ProxyToGhc args -> rawSystem Interpreter.ghc args >>= E.throwIO
Output s -> putStr s
Result (Run warnings args_ magicMode fastMode preserveIt verbose) -> do
Result (Run warnings magicMode config) -> do
mapM_ (hPutStrLn stderr) warnings
hFlush stderr

Expand All @@ -60,22 +69,14 @@ doctest args0 = case parseOptions args0 of
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]
Expand Down Expand Up @@ -128,14 +129,26 @@ getAddDistArgs = do
else id) rest
else return id

doctestWith :: Config -> IO ()
doctestWith = doctestWithResult >=> evaluateSummary

isSuccess :: Summary -> Bool
isSuccess s = sErrors s == 0 && sFailures s == 0

doctestWithOptions :: Bool -> Bool -> Bool -> [String] -> IO Summary
doctestWithOptions fastMode preserveIt verbose args = do

-- get examples from Haddock comments
modules <- getDocTests args

Interpreter.withInterpreter args $ \repl -> withCP65001 $ do
evaluateSummary :: Summary -> IO ()
evaluateSummary r = when (not $ isSuccess r) exitFailure

doctestWithResult :: Config -> IO Summary
doctestWithResult config = do
(getDocTests (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

runDocTests :: Config -> [Module [Located DocTest]] -> IO Summary
runDocTests Config{..} modules = do
Interpreter.withInterpreter ghcOptions $ \repl -> withCP65001 $ do
runModules fastMode preserveIt verbose repl modules
7 changes: 3 additions & 4 deletions test/MainSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,6 @@ import Test.HUnit (assertEqual, Assertion)
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
Expand All @@ -24,11 +23,11 @@ doctest :: HasCallStack => FilePath -> [String] -> Summary -> Assertion
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
Expand Down
22 changes: 11 additions & 11 deletions test/OptionsSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ import Prelude.Compat
import Data.List.Compat

import Test.Hspec
import Test.QuickCheck
import Test.QuickCheck hiding (verbose)

import Options

Expand All @@ -20,10 +20,10 @@ spec = do
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" $
Expand All @@ -45,10 +45,10 @@ spec = do
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
Expand All @@ -62,20 +62,20 @@ spec = do
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
Expand All @@ -92,8 +92,8 @@ spec = do
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
9 changes: 4 additions & 5 deletions test/RunSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,9 +19,6 @@ import qualified Options

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
Expand Down Expand Up @@ -119,9 +116,11 @@ spec = do
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)
Expand Down

0 comments on commit 14da19e

Please sign in to comment.