Add doctestWith / doctestWithResult

Author: sol

.ghci

@@ -1 +1,3 @@
 :set -DTEST -isrc -itest -packageghc -XHaskell2010
+:set -XNamedFieldPuns
+:set -XRecordWildCards

doctest.cabal

@@ -16,6 +16,10 @@ maintainer:       Simon Hengel <[email protected]>
 
 github: sol/doctest
 
+default-extensions:
+  - NamedFieldPuns
+  - RecordWildCards
+
 extra-source-files:
 - example/**/*
 - test/parse/**/*

package.yaml

@@ -1,4 +1,3 @@
-{-# LANGUAGE RecordWildCards #-}
 module Language.Haskell.GhciWrapper (
   Interpreter
 , Config(..)

src/Language/Haskell/GhciWrapper.hs

@@ -3,6 +3,8 @@
 module Options (
   Result(..)
 , Run(..)
+, Config(..)
+, defaultConfig
 , parseOptions
 #ifdef TEST
 , defaultRun
@@ -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"
@@ -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

src/Options.hs

@@ -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)
@@ -32,6 +40,7 @@ import           PackageDBs
 import           Parse
 import           Options
 import           Runner
+import           Location
 import qualified Interpreter
 
 -- | Run doctest with given list of arguments.
@@ -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
 
@@ -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]
@@ -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

src/Run.hs

@@ -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
@@ -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

test/MainSpec.hs

@@ -5,7 +5,7 @@ import           Prelude.Compat
 import           Data.List.Compat
 
 import           Test.Hspec
-import           Test.QuickCheck
+import           Test.QuickCheck hiding (verbose)
 
 import           Options
 
@@ -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" $
@@ -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
@@ -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
@@ -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

test/OptionsSpec.hs

@@ -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
@@ -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)