packages feed

doctest-parallel (empty) → 0.1

raw patch · 71 files changed

+4006/−0 lines, 71 filesdep +Cabaldep +Globdep +HUnitsetup-changed

Dependencies added: Cabal, Glob, HUnit, QuickCheck, base, base-compat, cabal-install-parsers, code-page, containers, deepseq, directory, doctest-parallel, exceptions, filepath, ghc, ghc-paths, hspec, hspec-core, hspec-discover, mockery, pretty, process, setenv, silently, stringbuilder, syb, template-haskell, transformers, unordered-containers

Files

+ CHANGES.markdown view
@@ -0,0 +1,3 @@+Changes in 0.1+  - First release!+
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2009-2018 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+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.markdown view
@@ -0,0 +1,356 @@++# Doctest parallel: Test interactive Haskell examples++`doctest-parallel` is a library that checks [examples in Haddock comments](http://www.haskell.org/haddock/doc/html/ch03s08.html#id566093).  It is similar to the [popular Python module with the same name](http://docs.python.org/library/doctest.html).++# Installation+`doctest-parallel` is available from [Hackage](https://hackage.haskell.org/package/doctest-parallel). It cannot be used as a standalone binary, rather, it expects to be integrated in a Cabal/Stack project. See [examples/](example/README.md) for more information on how to integrate `doctest-parallel` into your project.++# Usage+Below is a small Haskell module. The module contains a Haddock comment with some examples of interaction. The examples demonstrate how the module is supposed to be used.++```haskell+module Fib where++-- | Compute Fibonacci numbers+--+-- Examples:+--+-- >>> fib 10+-- 55+--+-- >>> fib 5+-- 5+fib :: Int -> Int+fib 0 = 0+fib 1 = 1+fib n = fib (n - 1) + fib (n - 2)+```++A comment line starting with `>>>` denotes an _expression_. All comment lines following an expression denote the _result_ of that expression. Result is defined by what a [REPL](http://en.wikipedia.org/wiki/Read-eval-print_loop) (e.g. ghci) prints to `stdout` and `stderr` when evaluating that expression.++`doctest-parallel` will fail on comments that `haddock` also doesn't like. Sometimes (e.g., [#251](https://github.com/sol/doctest/issues/251)), this means that `doctest-parallel` will fail on input that GHC accepts.++## Example groups++Examples from a single Haddock comment are grouped together and share the same+scope.  E.g. the following works:++```haskell+-- |+-- >>> let x = 23+-- >>> x + 42+-- 65+```++If an example fails, subsequent examples from the same group are skipped.  E.g.+for++```haskell+-- |+-- >>> let x = 23+-- >>> let n = x + y+-- >>> print n+```++`print n` is not tried, because `let n = x + y` fails (`y` is not in scope!).++## Setup code++You can put setup code in a [named chunk][named-chunks] with the name `$setup`.+The setup code is run before each example group.  If the setup code produces+any errors/failures, all tests from that module are skipped.++Here is an example:++```haskell+module Foo where++import Bar.Baz++-- $setup+-- >>> let x = 23 :: Int++-- |+-- >>> foo + x+-- 65+foo :: Int+foo = 42+```++Note that you should not place setup code in between the module header (`module+...  where`) and import declarations. GHC will not be able to parse it ([issue+ #167](https://github.com/sol/doctest/issues/167)). It is best to place setup+code right after import declarations, but due to its declarative nature you can+place it anywhere in between top level declarations as well.+++## Multi-line input+GHCi supports commands which span multiple lines, and the same syntax works for doctest:++```haskell+-- |+-- >>> :{+--  let+--    x = 1+--    y = 2+--  in x + y + multiline+-- :}+-- 6+multiline = 3+```++Note that `>>>` can be left off for the lines following the first: this is so that+haddock does not strip leading whitespace. The expected output has whitespace+stripped relative to the :}.++Some peculiarities on the ghci side mean that whitespace at the very start is lost.+This breaks the example `broken`, since the x and y aren't aligned from ghci's+perspective.  A workaround is to avoid leading space, or add a newline such+that the indentation does not matter:++```haskell+{- | >>> :{+let x = 1+    y = 2+  in x + y + works+:}+6+-}+works = 3++{- | >>> :{+ let x = 1+     y = 2+  in x + y + broken+:}+3+-}+broken = 3+```++## Multi-line output+If there are no blank lines in the output, multiple lines are handled+automatically.++```haskell+-- | >>> putStr "Hello\nWorld!"+-- Hello+-- World!+```++If however the output contains blank lines, they must be noted+explicitly with `<BLANKLINE>`. For example,++```haskell+import Data.List ( intercalate )++-- | Double-space a paragraph.+--+--   Examples:+--+--   >>> let s1 = "\"Every one of whom?\""+--   >>> let s2 = "\"Every one of whom do you think?\""+--   >>> let s3 = "\"I haven't any idea.\""+--   >>> let paragraph = unlines [s1,s2,s3]+--   >>> putStrLn $ doubleSpace paragraph+--   "Every one of whom?"+--   <BLANKLINE>+--   "Every one of whom do you think?"+--   <BLANKLINE>+--   "I haven't any idea."+--+doubleSpace :: String -> String+doubleSpace = (intercalate "\n\n") . lines+```++## Matching arbitrary output+Any lines containing only three dots (`...`) will match one or more lines with+arbitrary content. For instance,++```haskell+-- |+-- >>> putStrLn "foo\nbar\nbaz"+-- foo+-- ...+-- baz+```++If a line contains three dots and additional content, the three dots will match+anything *within that line*:++```haskell+-- |+-- >>> putStrLn "foo bar baz"+-- foo ... baz+```++## QuickCheck properties++Haddock (since version 2.13.0) has markup support for properties.  Doctest can+verify properties with QuickCheck.  A simple property looks like this:++```haskell+-- |+-- prop> \xs -> sort xs == (sort . sort) (xs :: [Int])+```++The lambda abstraction is optional and can be omitted:++```haskell+-- |+-- prop> sort xs == (sort . sort) (xs :: [Int])+```++A complete example that uses setup code is below:++```haskell+module Fib where++-- $setup+-- >>> import Control.Applicative+-- >>> import Test.QuickCheck+-- >>> newtype Small = Small Int deriving Show+-- >>> instance Arbitrary Small where arbitrary = Small . (`mod` 10) <$> arbitrary++-- | Compute Fibonacci numbers+--+-- The following property holds:+--+-- prop> \(Small n) -> fib n == fib (n + 2) - fib (n + 1)+fib :: Int -> Int+fib 0 = 0+fib 1 = 1+fib n = fib (n - 1) + fib (n - 2)+```++If you see an error like the following, ensure that [QuickCheck](http://hackage.haskell.org/package/QuickCheck) is a dependency of your test-suite.++```haskell+<interactive>:39:3:+    Not in scope: ‘polyQuickCheck’+    In the splice: $(polyQuickCheck (mkName "doctest_prop"))++<interactive>:39:3:+    GHC stage restriction:+      ‘polyQuickCheck’ is used in a top-level splice or annotation,+      and must be imported, not defined locally+    In the expression: polyQuickCheck (mkName "doctest_prop")+    In the splice: $(polyQuickCheck (mkName "doctest_prop"))+```++## Hiding examples from Haddock++You can put examples into [named chunks][named-chunks], and not refer to them+in the export list.  That way they will not be part of the generated Haddock+documentation, but Doctest will still find them.++```haskell+-- $+-- >>> 1 + 1+-- 2+```++[named-chunks]: http://www.haskell.org/haddock/doc/html/ch03s05.html++## Using GHC extensions++You can enable GHC extensions using the following syntax:++```haskell+-- >>> :set -XTupleSections+```++If you want to omit the information which language extensions are enabled from+the Doctest examples you can use the method described in [Hiding examples from+Haddock](#hiding-examples-from-haddock), e.g.:++```haskell+-- $+-- >>> :set -XTupleSections+```++[language-pragma]: http://www.haskell.org/ghc/docs/latest/html/users_guide/pragmas.html#language-pragma++## Using GHC plugins+You can enable GHC plugins using the following syntax:++```haskell+-- >>> :set -fplugin The.Plugin+```++## Hiding Prelude+You _hide_ the import of `Prelude` by using:++```haskell+-- >>> :m -Prelude+```++# Relation to [`doctest`](https://github.com/sol/doctest)+This is a fork of [sol/doctest](https://github.com/sol/doctest) that allows running tests in parallel and aims to provide a more robust project integration method. It is not backwards compatible and expects to be setup differently. At the time of writing it has a few advantages over the base project:++ * It runs tests in parallel+ * It runs tests against compiled code, instead of reinterpreting your whole project+ * It isolates examples in modules, ensuring your tests don't accidentally rely on each other+ * It parses cabal files to discover modules, no need for custom setup anymore!+ * A minor change: it does not count lines in setup blocks as test cases+ * A minor change: the testsuite has been ported to v2 commands++ There are two downsides to using this project:++ * Examples in non-exposed modules cannot be tested (but will nonetheless be detected and consequently fail)+ * Use of conditionals in a cabal file as well as CPP flags will be ignored (TODO?)++All in all, you can expect `doctest-parallel` to run about 1 or 2 orders of magnitude faster than `doctest` for large projects.++# Relation to [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec)+There is no direct relation between `doctest-parallel` and `cabal-docspec`. They are similar in some ways:++ * Both projects load code from precompiled modules+ * Both project aim to get rid of the need for custom setups++And different in others:++ * As a fork of `doctest`, `doctest-parallel` inherits the testsuite `doctest` accumulated over the years.+ * `doctest-parallel` parses Cabal project files, instead of parsing files from `dist-newstyle`. This makes it compatible with Stack, provided a `.cabal` is still present.+ * `doctest-parallel` uses the GHC API to parse comments. This should in theory be more reliable (though I doubt it will ever matter in practice).+ * `doctest-parallel` runs tests in parallel.++# Development+To run the tests:++```+cabal run spectests+cabal run doctests+```++# Future of this project++ * It would be lovely if we could get rid of the needs for `write-ghc-environment-files: always` option for Cabal. To properly do this, I think Cabal should do two things:+    1. Deprecate GHC environment files as a way to _implicitly_ setup environments. Instead, environment files should be written to the `dist-newstyle` directory and activated using some subcommand, e.g. `cabal shell`. This avoids the many problems GHC environment files have, while retaining their functionality for people who like them.+    2. Any subcommands should be run with `GHC_ENVIRONMENT` set - pointing to the GHC environment file. Like Stack, this would create a hassle free way of using Cabal in combination with projects/executables that use the GHC API (e.g., `clash-ghc`, `doctest-parallel`).+ * Cabal needs to expose more information _by default_ in order for `doctest-parallel` to properly work. Specifically, it needs to know the exact `default-extensions`, `ghc-options`, and `CPP` flags the project is compiled with. These options are obtainable by using a custom `Setup.hs`, but this has its own list of problems.+ * Hopefully many of the improvements made here can make their way back into `sol/doctest`.++ Of course, if you wish to add a feature that's not in this list, please feel free top open a pull request!++# Contributors++ * Adam Vogt+ * Anders Persson+ * Ankit Ahuja+ * Edward Kmett+ * Hiroki Hattori+ * Joachim Breitner+ * João Cristóvão+ * Julian Arni+ * Kazu Yamamoto+ * Levent Erkok+ * Luke Murphy+ * Matvey Aksenov+ * Michael Orlitzky+ * Michael Snoyman+ * Nick Smallbone+ * Sakari Jokinen+ * Simon Hengel+ * Sönke Hahn
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ doctest-parallel.cabal view
@@ -0,0 +1,182 @@+cabal-version:  3.0++name:           doctest-parallel+version:        0.1+synopsis:       Test interactive Haskell examples+description:    The doctest program checks examples in source code comments.  It is modeled+                after doctest for Python (<https://docs.python.org/3/library/doctest.html>).+                .+                Documentation is at <https://github.com/martijnbastiaan/doctest-parallel#readme>.+category:       Testing+bug-reports:    https://github.com/martijnbastiaan/doctest-parallel/issues+homepage:       https://github.com/martijnbastiaan/doctest-parallel#readme+license:        MIT+license-file:   LICENSE+copyright:      (c) 2009-2018 Simon Hengel, 2021 Martijn Bastiaan+author:         Martijn Bastiaan <martijn@hmbastiaan.nl>+maintainer:     Martijn Bastiaan <martijn@hmbastiaan.nl>+build-type:     Simple+tested-with:+    GHC == 8.2.2+  , GHC == 8.4.4+  , GHC == 8.6.5+  , GHC == 8.8.4+  , GHC == 8.10.7+  , GHC == 9.0.1+extra-source-files:+    example/example.cabal+    example/src/Example.hs+    example/test/doctests.hs+    CHANGES.markdown+    README.markdown++source-repository head+  type: git+  location: https://github.com/martijnbastiaan/doctest-parallel++library+  ghc-options: -Wall+  hs-source-dirs:+      src+      ghci-wrapper/src+  exposed-modules:+      Test.DocTest+      Test.DocTest.Helpers+      Test.DocTest.Internal.Extract+      Test.DocTest.Internal.GhcUtil+      Test.DocTest.Internal.Interpreter+      Test.DocTest.Internal.Location+      Test.DocTest.Internal.Options+      Test.DocTest.Internal.Parse+      Test.DocTest.Internal.Property+      Test.DocTest.Internal.Runner+      Test.DocTest.Internal.Runner.Example+      Test.DocTest.Internal.Util+      Language.Haskell.GhciWrapper+  other-modules:+      Paths_doctest_parallel+  autogen-modules:+      Paths_doctest_parallel+  build-depends:+      Cabal+    , Glob+    , base >=4.10 && <5+    , base-compat >=0.7.0+    , cabal-install-parsers+    , code-page >=0.1+    , containers+    , deepseq+    , directory+    , exceptions+    , filepath+    , ghc >=7.10 && <9.1+    , ghc-paths >=0.1.0.9+    , pretty+    , process+    , syb >=0.3+    , transformers+    , unordered-containers+  default-language: Haskell2010++test-suite doctests+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          doctests.hs+  ghc-options:      -threaded+  build-depends:    base, doctest-parallel+  default-language: Haskell2010+++library spectests-modules+  default-language: Haskell2010+  build-depends: base, doctest-parallel, template-haskell+  -- Too many warnings. TODO: fix.+  -- ghc-options: -Wall+  hs-source-dirs:+      test/integration+  c-sources:+      test/integration/WithCbits/foo.c+  exposed-modules:+    BugfixImportHierarchical.ModuleA+    BugfixImportHierarchical.ModuleB+    BugfixMultipleModules.ModuleA+    BugfixMultipleModules.ModuleB+    BugfixOutputToStdErr.Fib+    Color.Foo+    DosLineEndings.Fib+    Failing.Foo+    FailingMultiple.Foo+    It.Foo+    It.Setup+    LocalStderrBinding.A+    ModuleIsolation.TestA+    ModuleIsolation.TestB+    Multiline.Multiline+    PropertyBool.Foo+    PropertyBoolWithTypeSignature.Foo+    PropertyFailing.Foo+    PropertyImplicitlyQuantified.Foo+    PropertyQuantified.Foo+    PropertySetup.Foo+    Setup.Foo+    SetupSkipOnFailure.Foo+    SystemIoImported.A+    TemplateHaskell.Foo+    TestBlankline.Fib+    TestCombinedExample.Fib+    TestCommentLocation.Foo+    TestDocumentationForArguments.Fib+    TestFailOnMultiline.Fib+    TestImport.ModuleA+    TestImport.ModuleB+    TestPutStr.Fib+    TestSimple.Fib+    TrailingWhitespace.Foo+    WithCbits.Bar++test-suite spectests+  main-is: Spec.hs+  other-modules:+      ExtractSpec+      InterpreterSpec+      LocationSpec+      MainSpec+      OptionsSpec+      ParseSpec+      PropertySpec+      Runner.ExampleSpec+      RunnerSpec+      RunSpec+      UtilSpec+  type: exitcode-stdio-1.0+  ghc-options: -Wall -threaded+  cpp-options: -DTEST+  hs-source-dirs:+      test+  build-tool-depends:+    hspec-discover:hspec-discover+  build-depends:+      HUnit+    , QuickCheck >=2.13.1+    , base >=4.5 && <5+    , base-compat >=0.7.0+    , code-page >=0.1+    , doctest-parallel+    , deepseq+    , directory+    , exceptions+    , filepath+    , ghc >=7.0 && <9.1+    , ghc-paths >=0.1.0.9+    , hspec >=2.3.0+    , hspec-core >=2.3.0+    , hspec-discover+    , mockery+    , process+    , setenv+    , silently >=1.2.4+    , stringbuilder >=0.4+    , spectests-modules+    , syb >=0.3+    , transformers+  default-language: Haskell2010
+ example/example.cabal view
@@ -0,0 +1,17 @@+name:             example+version:          0.0.0+build-type:       Simple+cabal-version:    >= 1.8++library+  hs-source-dirs:   src+  exposed-modules:  Example+  build-depends:    base++test-suite doctests+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          doctests.hs+  ghc-options:      -threaded+  build-depends:    base, example, doctest-parallel >= 0.1+  default-language: Haskell2010
+ example/src/Example.hs view
@@ -0,0 +1,11 @@+module Example (foo, bar) where++-- |+-- >>> foo+-- 23+foo = 23++-- |+-- >>> bar+-- 42+bar = 42
+ example/test/doctests.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.DocTest (mainFromCabal)+import System.Environment (getArgs)++main :: IO ()+main = mainFromCabal "example" =<< getArgs
+ ghci-wrapper/src/Language/Haskell/GhciWrapper.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}++module Language.Haskell.GhciWrapper (+  Interpreter+, Config(..)+, defaultConfig+, new+, close+, eval+, evalIt+, evalEcho+) where++import           System.IO hiding (stdin, stdout, stderr)+import           System.Process+import           System.Exit+import           Control.Monad+import           Control.Exception+import           Data.List+import           Data.Maybe++data Config = Config {+  configGhci :: String+, configVerbose :: Bool+, configIgnoreDotGhci :: Bool+} deriving (Eq, Show)++defaultConfig :: Config+defaultConfig = Config {+  configGhci = "ghci"+, configVerbose = False+, configIgnoreDotGhci = True+}++-- | Truly random marker, used to separate expressions.+--+-- IMPORTANT: This module relies upon the fact that this marker is unique.  It+-- has been obtained from random.org.  Do not expect this module to work+-- properly, if you reuse it for any purpose!+marker :: String+marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"++itMarker :: String+itMarker = "d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a"++data Interpreter = Interpreter {+    hIn  :: Handle+  , hOut :: Handle+  , process :: ProcessHandle+  }++new :: Config -> [String] -> IO Interpreter+new Config{..} args_ = do+  (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit}+  setMode stdin_+  setMode stdout_+  let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle}+  _ <- eval interpreter "import qualified System.IO"+  _ <- eval interpreter "import qualified GHC.IO.Handle"+  -- The buffering of stdout and stderr is NoBuffering+  _ <- eval interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"+  -- Now the buffering of stderr is BlockBuffering Nothing+  -- In this situation, GHC 7.7 does not flush the buffer even when+  -- error happens.+  _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"+  _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"++  -- this is required on systems that don't use utf8 as default encoding (e.g.+  -- Windows)+  _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Handle.utf8"+  _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Handle.utf8"++  _ <- eval interpreter ":m - System.IO"+  _ <- eval interpreter ":m - GHC.IO.Handle"++  return interpreter+  where+    args = args_ ++ catMaybes [+        if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing+      , if configVerbose then Nothing else Just "-v0"+      ]+    setMode h = do+      hSetBinaryMode h False+      hSetBuffering h LineBuffering+      hSetEncoding h utf8++close :: Interpreter -> IO ()+close repl = do+  hClose $ hIn repl++  -- It is crucial not to close `hOut` before calling `waitForProcess`,+  -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang+  -- around consuming 100% CPU.  This happens when ghci tries to print+  -- something to stdout in its signal handler (e.g. when it is blocked in+  -- threadDelay it writes "Interrupted." on SIGINT).+  e <- waitForProcess $ process repl+  hClose $ hOut repl++  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+  hPutStrLn stdin e+  when preserveIt $ hPutStrLn stdin $ "let " ++ itMarker ++ " = it"+  hPutStrLn stdin (marker ++ " :: Data.String.String")+  when preserveIt $ hPutStrLn stdin $ "let it = " ++ itMarker+  hFlush stdin++getResult :: Bool -> Interpreter -> IO String+getResult echoMode Interpreter{hOut = stdout} = go+  where+    go = do+      line <- hGetLine stdout++      if+        | marker `isSuffixOf` line -> do+          let xs = stripMarker line+          echo xs+          return xs+#if __GLASGOW_HASKELL__ < 810+        -- For some (happy) reason newer GHCs don't decide to print this+        -- message - or at least we don't see it.+        | "Loaded package environment from " `isPrefixOf` line -> do+          go+#endif+        | otherwise -> do+          echo (line ++ "\n")+          result <- go+          return (line ++ "\n" ++ result)+    stripMarker l = take (length l - length marker) l++    echo :: String -> IO ()+    echo+      | echoMode = putStr+      | otherwise = (const $ return ())++-- | Evaluate an expression+eval :: Interpreter -> String -> IO String+eval repl expr = do+  putExpression repl False expr+  getResult False repl++-- | Like 'eval', but try to preserve the @it@ variable+evalIt :: Interpreter -> String -> IO String+evalIt repl expr = do+  putExpression repl True expr+  getResult False repl++-- | Evaluate an expression+evalEcho :: Interpreter -> String -> IO String+evalEcho repl expr = do+  putExpression repl False expr+  getResult True repl
+ src/Test/DocTest.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++module Test.DocTest where++import           Prelude ()+import           Prelude.Compat++import qualified Data.Set as Set++import           Control.Monad (unless)+import           System.Exit (exitFailure)+import           System.IO++import qualified Control.Exception as E++#if __GLASGOW_HASKELL__ < 900+import Panic+#else+import GHC.Utils.Panic+#endif++import Test.DocTest.Internal.Parse+import Test.DocTest.Internal.Options+import Test.DocTest.Internal.Runner++-- Cabal+import Distribution.Simple+  ( KnownExtension(ImplicitPrelude), Extension (DisableExtension) )++-- me+import Test.DocTest.Helpers+  ( Library (libDefaultExtensions), extractCabalLibrary, findCabalPackage+  , libraryToGhciArgs )++-- | Run doctest with given list of arguments.+--+-- Example:+--+-- mainFromCabal "my-project" =<< getArgs+--+mainFromCabal :: String -> [String] -> IO ()+mainFromCabal libName cmdArgs = do+  lib <- extractCabalLibrary =<< findCabalPackage libName+  mainFromLibrary lib cmdArgs++mainFromLibrary :: Library -> [String] -> IO ()+mainFromLibrary lib (parseOptions -> opts) =+  case opts of+    ResultStdout s -> putStr s+    ResultStderr s -> do+       hPutStrLn stderr ("doctest: " ++ s)+       hPutStrLn stderr "Try `doctest --help' for more information."+       exitFailure+    Result config -> do+      r <- main lib 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+      unless (isSuccess r) exitFailure++isSuccess :: Summary -> Bool+isSuccess s = sErrors s == 0 && sFailures s == 0++-- | Filter modules to be tested against a list of modules to be tested (specified+-- by the user on the command line). If list is empty, test all modules. Throws+-- and error if a non-existing module was specified.+filterModules :: [ModuleName] -> [Module a] -> [Module a]+filterModules [] mods = mods+filterModules wantedMods0 allMods0+  | (_:_) <- nonExistingMods = error ("Unknown modules specified: " <> show nonExistingMods)+  | otherwise = filter isSpecifiedMod allMods0+ where+  wantedMods1 = Set.fromList wantedMods0+  allMods1 = Set.fromList (map moduleName allMods0)++  nonExistingMods = Set.toList (wantedMods1 `Set.difference` allMods1)+  isSpecifiedMod Module{moduleName} = moduleName `Set.member` wantedMods1+++main :: Library -> Config -> IO Summary+main lib Config{..} = do+  let+    implicitPrelude = DisableExtension ImplicitPrelude `notElem` libDefaultExtensions lib+    (includeArgs, moduleArgs, otherGhciArgs) = libraryToGhciArgs lib+    evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"]++  -- get examples from Haddock comments+  allModules <- getDocTests (includeArgs ++ moduleArgs ++ otherGhciArgs)+  let modules = filterModules cfgModules allModules+  runModules cfgThreads cfgPreserveIt cfgVerbose implicitPrelude evalGhciArgs modules
+ src/Test/DocTest/Helpers.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++module Test.DocTest.Helpers where++import GHC.Stack (HasCallStack)++import System.Directory+  ( canonicalizePath, doesFileExist )+import System.FilePath ((</>), isDrive, takeDirectory)+import System.FilePath.Glob (glob)++#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#endif++-- Cabal+import Distribution.ModuleName (ModuleName)+import Distribution.Simple+  ( Extension (DisableExtension, EnableExtension, UnknownExtension) )+import Distribution.PackageDescription+  ( CondTree(CondNode, condTreeData), GenericPackageDescription (condLibrary)+  , exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package+  , packageDescription, condSubLibraries )+import Distribution.Pretty (prettyShow)+import Distribution.Types.UnqualComponentName (unUnqualComponentName)++#if MIN_VERSION_Cabal(3,6,0)+import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath)+#endif++-- cabal-install-parsers+import Cabal.Package (readPackage)++data Library = Library+  { libSourceDirectories :: [FilePath]+  , libModules :: [ModuleName]+  , libDefaultExtensions :: [Extension]+  }+  deriving (Show)++-- | Convert a "Library" to arguments suitable to be passed to GHCi.+libraryToGhciArgs :: Library -> ([String], [String], [String])+libraryToGhciArgs Library{..} = (srcArgs, modArgs, extArgs)+ where+  srcArgs = map ("-i" <>) libSourceDirectories+  modArgs = map prettyShow libModules+  extArgs = map showExt libDefaultExtensions++  showExt = \case+    EnableExtension ext -> "-X" <> show ext+    DisableExtension ext -> "-XNo" <> show ext+    UnknownExtension ext -> "-X" <> ext++-- | Drop a number of elements from the end of the list.+--+-- > dropEnd 3 "hello"  == "he"+-- > dropEnd 5 "bye"    == ""+-- > dropEnd (-1) "bye" == "bye"+-- > \i xs -> dropEnd i xs `isPrefixOf` xs+-- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i)+-- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..]+dropEnd :: Int -> [a] -> [a]+dropEnd i xs+  | i <= 0 = xs+  | otherwise = f xs (drop i xs)+ where+   f (a:as) (_:bs) = a : f as bs+   f _ _ = []++-- Searches for a file called @package.cabal@, where @package@ is given as an+-- argument. It will look for it in the current directory. If it can't find it+-- there, it will traverse up until it finds the file or a file called+-- @cabal.project@. In case of the latter, it will traverse down recursively+-- until it encounters a @package.cabal@.+--+-- The returned path points to the @package.cabal@. Errors if it could not+-- find @package.cabal@ anywhere, or when it found multiple.+--+findCabalPackage :: HasCallStack => String -> IO FilePath+findCabalPackage packageName = goUp =<< canonicalizePath packageName+ where+  goUp :: FilePath -> IO FilePath+  goUp path+    | isDrive path = error ("Could not find '" <> packageFilename <> "'")+    | otherwise = do+      packageExists <- doesFileExist (path </> packageFilename)+      projectExists <- doesFileExist (path </> projectFilename)++      if | packageExists -> pure (path </> packageFilename)+         | projectExists -> goDown path+         | otherwise -> goUp (takeDirectory path)++  goDown :: FilePath -> IO FilePath+  goDown path = do+    candidates <- glob (path </> "**" </> packageFilename)+    case candidates of+      [] -> error ("Could not find " <> packageFilename <> " in project " <> path)+      (_:_:_) -> error ("Ambiguous packages in project " <> path <> ": " <> show candidates)+      [c] -> pure c++  packageFilename = packageName <> ".cabal"+  projectFilename = "cabal.project"++#if MIN_VERSION_Cabal(3,6,0)+compatPrettyShow :: SymbolicPath PackageDir SourceDir -> FilePath+compatPrettyShow = prettyShow+#else+compatPrettyShow :: FilePath -> FilePath+compatPrettyShow = id+#endif++-- Given a filepath to a @package.cabal@, parse it, and yield a "Library". Yields+-- the default Library if first argument is Nothing, otherwise it will look for+-- a specific sublibrary.+extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library+extractSpecificCabalLibrary maybeLibName pkgPath = do+  pkg <- readPackage pkgPath+  case maybeLibName of+    Nothing ->+      case condLibrary pkg of+        Nothing ->+          let pkgDescription = package (packageDescription pkg) in+          error ("Could not find main library in: " <> show pkgDescription)+        Just lib ->+          go lib++    Just libName ->+      go (findSubLib pkg libName (condSubLibraries pkg))++ where+  findSubLib pkg targetLibName [] =+    let pkgDescription = package (packageDescription pkg) in+    error ("Could not find library " <> targetLibName <> " in " <> show pkgDescription)+  findSubLib pkg targetLibName ((libName, lib):libs)+    | unUnqualComponentName libName == targetLibName = lib+    | otherwise = findSubLib pkg targetLibName libs++  go CondNode{condTreeData=lib} =+    let+      buildInfo = libBuildInfo lib+      sourceDirs = hsSourceDirs buildInfo+      root = takeDirectory pkgPath+    in+      pure Library+        { libSourceDirectories = map ((root </>) . compatPrettyShow) sourceDirs+        , libModules = exposedModules lib+        , libDefaultExtensions = defaultExtensions buildInfo+        }+++-- Given a filepath to a @package.cabal@, parse it, and yield a "Library". Returns+-- and error if no library was specified in the cabal package file.+extractCabalLibrary :: FilePath -> IO Library+extractCabalLibrary = extractSpecificCabalLibrary Nothing
+ src/Test/DocTest/Internal/Extract.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}+module Test.DocTest.Internal.Extract (Module(..), extract) where++import           Prelude hiding (mod, concat)+import           Control.Monad+import           Control.Exception+import           Data.List (partition)+import           Data.Maybe++import           Control.DeepSeq (deepseq, NFData(rnf))+import           Data.Generics++#if __GLASGOW_HASKELL__ < 900+import           GHC hiding (Module, Located)+import           DynFlags+import           MonadUtils (liftIO)+#else+import           GHC hiding (Module, Located)+import           GHC.Driver.Session+import           GHC.Utils.Monad (liftIO)+#endif++#if __GLASGOW_HASKELL__ < 900+import           Digraph (flattenSCCs)+import           Exception (ExceptionMonad)+#else+import           GHC.Data.Graph.Directed (flattenSCCs)+import           GHC.Utils.Exception (ExceptionMonad)+import           Control.Monad.Catch (generalBracket)+#endif++import           System.Directory+import           System.FilePath++#if __GLASGOW_HASKELL__ < 805+import           FastString (unpackFS)+#endif++import           System.Posix.Internals (c_getpid)++import           Test.DocTest.Internal.GhcUtil (withGhc)+import           Test.DocTest.Internal.Location hiding (unLoc)+import           Test.DocTest.Internal.Util (convertDosLineEndings)++#if __GLASGOW_HASKELL__ >= 806+#if __GLASGOW_HASKELL__ < 900+import           DynamicLoading (initializePlugins)+#else+import           GHC.Runtime.Loader (initializePlugins)+#endif+#endif++-- | A wrapper around `SomeException`, to allow for a custom `Show` instance.+newtype ExtractError = ExtractError SomeException+  deriving Typeable++instance Show ExtractError where+  show (ExtractError e) =+    unlines [+        "Ouch! Hit an error thunk in GHC's AST while extracting documentation."+      , ""+      , "    " ++ msg+      , ""+      , "This is most likely a bug in doctest."+      , ""+      , "Please report it here: https://github.com/sol/doctest/issues/new"+      ]+    where+      msg = case fromException e of+        Just (Panic s) -> "GHC panic: " ++ s+        _              -> show e++instance Exception ExtractError++-- | Documentation for a module grouped together with the modules name.+data Module a = Module {+  moduleName    :: String+, moduleSetup   :: Maybe a+, moduleContent :: [a]+} deriving (Eq, Functor, Show)++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++needsTemplateHaskellOrQQ :: ModuleGraph -> Bool+needsTemplateHaskellOrQQ = needsTemplateHaskell++mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph+mapMG = map+#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++  mapM (`guessTarget` Nothing) modules >>= setTargets+  mods <- depanal [] False++  mods' <- if needsTemplateHaskellOrQQ mods then enableCompilation mods else return mods++  let sortedMods = flattenSCCs (topSortModuleGraph False mods' Nothing)+  reverse <$> mapM (loadModPlugins >=> parseModule) sortedMods+  where+    -- copied from Haddock/Interface.hs+    enableCompilation :: ModuleGraph -> Ghc ModuleGraph+    enableCompilation modGraph = do+#if __GLASGOW_HASKELL__ < 809+      let enableComp d = let platform = targetPlatform d+                         in d { hscTarget = defaultObjectTarget platform }+#else+      let enableComp d = d { hscTarget = defaultObjectTarget d }+#endif+      modifySessionDynFlags enableComp+      -- We need to update the DynFlags of the ModSummaries as well.+      let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }+      let modGraph' = mapMG upd modGraph+      return modGraph'++    -- copied from Haddock/GhcUtils.hs+    modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()+    modifySessionDynFlags f = do+      dflags <- getSessionDynFlags+      let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of+            Just "YES" -> gopt_set dflags Opt_BuildDynamicToo+            _          -> dflags+      _ <- setSessionDynFlags (f dflags')+      return ()++    withTempOutputDir :: Ghc a -> Ghc a+    withTempOutputDir action = do+      tmp <- liftIO getTemporaryDirectory+      x   <- liftIO c_getpid+      let dir = tmp </> ".doctest-" ++ show x+      modifySessionDynFlags (setOutputDir dir)+      gbracket_+        (liftIO $ createDirectory dir)+        (liftIO $ removeDirectoryRecursive dir)+        action++    -- | A variant of 'gbracket' where the return value from the first computation+    -- is not required.+    gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c+#if __GLASGOW_HASKELL__ < 900+    gbracket_ before_ after thing = gbracket before_ (const after) (const thing)+#else+    gbracket_ before_ after thing = fst <$> generalBracket before_ (\ _ _ -> after) (const thing)+#endif++    setOutputDir f d = d {+        objectDir  = Just f+      , hiDir      = Just f+      , stubDir    = Just f+      , includePaths = addQuoteInclude (includePaths d) [f]+      }++#if __GLASGOW_HASKELL__ >= 806+    -- Since GHC 8.6, plugins are initialized on a per module basis+    loadModPlugins modsum = do+      hsc_env <- getSession+      dynflags' <- liftIO (initializePlugins hsc_env (GHC.ms_hspp_opts modsum))+      return $ modsum { ms_hspp_opts = dynflags' }+#else+    loadModPlugins = return+#endif++-- | Extract all docstrings from given list of files/modules.+--+-- This includes the docstrings of all local modules that are imported from+-- those modules (possibly indirect).+extract :: [String] -> IO [Module (Located String)]+extract args = do+  mods <- parse args+  let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule) mods++  (docs `deepseq` return docs) `catches` [+      -- Re-throw AsyncException, otherwise execution will not terminate on+      -- SIGINT (ctrl-c).  All AsyncExceptions are re-thrown (not just+      -- UserInterrupt) because all of them indicate severe conditions and+      -- should not occur during normal operation.+      Handler (\e -> throw (e :: AsyncException))+    , Handler (throwIO . ExtractError)+    ]++-- | Extract all docstrings from given module and attach the modules name.+extractFromModule :: ParsedModule -> Module (Located String)+extractFromModule m = Module name (listToMaybe $ map snd setup) (map snd docs)+  where+    isSetup = (== Just "setup") . fst+    (setup, docs) = partition isSetup (docStringsFromModule m)+    name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m++-- | Extract all docstrings from given module.+docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]+docStringsFromModule mod = map (fmap (toLocated . fmap unpackHDS)) docs+  where+    source   = (unLoc . pm_parsed_source) mod++    -- we use dlist-style concatenation here+    docs     = header ++ exports ++ decls++    -- We process header, exports and declarations separately instead of+    -- traversing the whole source in a generic way, to ensure that we get+    -- everything in source order.+    header  = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]]+#if __GLASGOW_HASKELL__ < 805+    exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)]+#else+    exports = [(Nothing, L loc doc) | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source)]+#endif+    decls   = extractDocStrings (hsmodDecls source)++type Selector a = a -> ([(Maybe String, LHsDocString)], Bool)++-- | Collect given value and descend into subtree.+select :: a -> ([a], Bool)+select x = ([x], False)++-- | Extract all docstrings from given value.+extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)]+extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl+  `extQ` fromLDocDecl+  `extQ` fromLHsDocString+  )+  where+    fromLHsDecl :: Selector (LHsDecl GhcPs)+    fromLHsDecl (L loc decl) = case decl of++      -- 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 -> select (fromDocDecl loc x)+#else+      DocD _ x -> select (fromDocDecl loc x)+#endif++      _ -> (extractDocStrings decl, True)++    fromLDocDecl :: Selector LDocDecl+    fromLDocDecl (L loc x) = select (fromDocDecl loc x)++    fromLHsDocString :: Selector LHsDocString+    fromLHsDocString x = select (Nothing, x)++    fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)+    fromDocDecl loc x = case x of+      DocCommentNamed name doc -> (Just name, L loc doc)+      _                        -> (Nothing, L loc $ docDeclDoc x)++#if __GLASGOW_HASKELL__ < 805+-- | Convert a docstring to a plain string.+unpackHDS :: HsDocString -> String+unpackHDS (HsDocString s) = unpackFS s+#endif
+ src/Test/DocTest/Internal/GhcUtil.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}+module Test.DocTest.Internal.GhcUtil (withGhc) where++import           GHC.Paths (libdir)+import           GHC+#if __GLASGOW_HASKELL__ < 900+import           DynFlags (gopt_set)+#else+import           GHC.Driver.Session (gopt_set)+#endif++#if __GLASGOW_HASKELL__ < 900+import           Panic (throwGhcException)+#else+import           GHC.Utils.Panic (throwGhcException)+#endif++#if __GLASGOW_HASKELL__ < 900+import           MonadUtils (liftIO)+#else+import           GHC.Utils.Monad (liftIO)+#endif++import           System.Exit (exitFailure)++-- Catch GHC source errors, print them and exit.+handleSrcErrors :: Ghc a -> Ghc a+handleSrcErrors action' = flip handleSourceError action' $ \err -> do+  printException err+  liftIO exitFailure++-- | 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++handleStaticFlags :: [String] -> IO [Located String]+handleStaticFlags flags = return $ map noLoc $ flags++handleDynamicFlags :: GhcMonad m => [Located String] -> m [String]+handleDynamicFlags flags = do+  (dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags+  _ <- setSessionDynFlags dynflags++  -- We basically do the same thing as `ghc/Main.hs` to distinguish+  -- "unrecognised flags" from source files.+  let srcs = map unLoc locSrcs+      unknown_opts = [ f | f@('-':_) <- srcs ]+  case unknown_opts of+    opt : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'"))+    _       -> return srcs++setHaddockMode :: DynFlags -> DynFlags+setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) {+      hscTarget = HscNothing+    , ghcMode   = CompManager+    , ghcLink   = NoLink+    }
+ src/Test/DocTest/Internal/Interpreter.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}++module Test.DocTest.Internal.Interpreter (+  Interpreter+, safeEval+, safeEvalIt+, withInterpreter+, ghc+, interpreterSupported++-- exported for testing+, ghcInfo+, haveInterpreterKey+) where++import           System.Process+import           System.Directory (getPermissions, executable)+import           Control.Monad+import           Control.Exception hiding (handle)+import           Data.Char+import           GHC.Paths (ghc)++import           Language.Haskell.GhciWrapper++-- $setup+-- >>> import Language.Haskell.GhciWrapper (eval)++haveInterpreterKey :: String+haveInterpreterKey = "Have interpreter"++ghcInfo :: IO [(String, String)]+ghcInfo = read <$> readProcess ghc ["--info"] []++interpreterSupported :: IO Bool+interpreterSupported = do+  -- in a perfect world this permission check should never fail, but I know of+  -- at least one case where it did..+  x <- getPermissions ghc+  unless (executable x) $ do+    fail $ ghc ++ " is not executable!"++  maybe False (== "YES") . lookup haveInterpreterKey <$> ghcInfo++-- | Run an interpreter session.+--+-- Example:+--+-- >>> withInterpreter [] $ \i -> eval i "23 + 42"+-- "65\n"+withInterpreter+  :: [String]               -- ^ List of flags, passed to GHC+  -> (Interpreter -> IO a)  -- ^ Action to run+  -> IO a                   -- ^ Result of action+withInterpreter flags action = do+  let+    args = flags ++ [+        "--interactive"+#if __GLASGOW_HASKELL__ >= 802+      , "-fdiagnostics-color=never"+      , "-fno-diagnostics-show-caret"+#endif+      ]+  bracket (new defaultConfig{configGhci = ghc} args) close action++-- | Evaluate an expression; return a Left value on exceptions.+--+-- 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++safeEvalIt :: Interpreter -> String -> IO (Either String String)+safeEvalIt repl = either (return . Left) (fmap Right . evalIt repl) . filterExpression++filterExpression :: String -> Either String String+filterExpression e =+  case lines e of+    [] -> Right e+    l  -> if firstLine == ":{" && lastLine /= ":}" then fail_ else Right e+      where+        firstLine = strip $ head l+        lastLine  = strip $ last l+        fail_ = Left "unterminated multiline command"+  where+    strip :: String -> String+    strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+ src/Test/DocTest/Internal/Location.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP, DeriveFunctor #-}+module Test.DocTest.Internal.Location where++import           Control.DeepSeq (deepseq, NFData(rnf))++#if __GLASGOW_HASKELL__ < 900+import           SrcLoc hiding (Located)+import qualified SrcLoc as GHC+import           FastString (unpackFS)+#else+import           GHC.Types.SrcLoc hiding (Located)+import qualified GHC.Types.SrcLoc as GHC+import           GHC.Data.FastString (unpackFS)+#endif++-- | A thing with a location attached.+data Located a = Located Location a+  deriving (Eq, Show, Functor)++instance NFData a => NFData (Located a) where+  rnf (Located loc a) = loc `deepseq` a `deepseq` ()++-- | Convert a GHC located thing to a located thing.+toLocated :: GHC.Located a -> Located a+toLocated (L loc a) = Located (toLocation loc) a++-- | Discard location information.+unLoc :: Located a -> a+unLoc (Located _ a) = a++-- | Add dummy location information.+noLocation :: a -> Located a+noLocation = Located (UnhelpfulLocation "<no location info>")++-- | A line number.+type Line = Int++-- | A combination of file name and line number.+data Location = UnhelpfulLocation String | Location FilePath Line+  deriving Eq++instance Show Location where+  show (UnhelpfulLocation s) = s+  show (Location file line)  = file ++ ":" ++ show line++instance NFData Location where+  rnf (UnhelpfulLocation str) = str `deepseq` ()+  rnf (Location file line)    = file `deepseq` line `deepseq` ()++-- |+-- Create a list from a location, by repeatedly increasing the line number by+-- one.+enumerate :: Location -> [Location]+enumerate loc = case loc of+  UnhelpfulLocation _ -> repeat loc+  Location file line  -> map (Location file) [line ..]++-- | Convert a GHC source span to a location.+toLocation :: SrcSpan -> Location+#if __GLASGOW_HASKELL__ < 900+toLocation loc = case loc of+  UnhelpfulSpan str -> UnhelpfulLocation (unpackFS str)+  RealSrcSpan sp    -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp)+#else+toLocation loc = case loc of+  UnhelpfulSpan str -> UnhelpfulLocation (unpackFS $ unhelpfulSpanFS str)+  RealSrcSpan sp _  -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp)+#endif
+ src/Test/DocTest/Internal/Options.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}++module Test.DocTest.Internal.Options where++import           Prelude ()+import           Prelude.Compat++import           Data.List.Compat++import qualified Paths_doctest_parallel+import           Data.Version (showVersion)++#if __GLASGOW_HASKELL__ < 900+import           Config as GHC+#else+import           GHC.Settings.Config as GHC+#endif++import           Test.DocTest.Internal.Interpreter (ghc)+import           Text.Read (readMaybe)++usage :: String+usage = unlines [+    "Usage:"+  , "  doctest [ --fast | --preserve-it | --verbose | -jN ]..."+  , "  doctest --help"+  , "  doctest --version"+  , "  doctest --info"+  , ""+  , "Options:"+  , "  -jN                      number of threads to use"+  , "  --preserve-it            preserve the `it` variable between examples"+  , "  --verbose                print each test as it is run"+  , "  --help                   display this help and exit"+  , "  --version                output version information and exit"+  , "  --info                   output machine-readable version information and exit"+  ]++version :: String+version = showVersion Paths_doctest_parallel.version++ghcVersion :: String+ghcVersion = GHC.cProjectVersion++versionInfo :: String+versionInfo = unlines [+    "doctest version " ++ version+  , "using version " ++ ghcVersion ++ " of the GHC API"+  , "using " ++ ghc+  ]++info :: String+info = "[ " ++ (intercalate "\n, " . map show $ [+    ("version", version)+  , ("ghc_version", ghcVersion)+  , ("ghc", ghc)+  ]) ++ "\n]\n"++data Result a+  = ResultStderr String+  | ResultStdout String+  | Result a+  deriving (Eq, Show, Functor)++type Warning = String+type ModuleName = String++data Config = Config+  { cfgPreserveIt :: Bool+  -- ^ Preserve the @it@ variable between examples (default: @False@)+  , cfgVerbose :: Bool+  -- ^ Verbose output (default: @False@)+  , cfgModules :: [ModuleName]+  -- ^ Module names to test+  , cfgThreads :: Maybe Int+  -- ^ Number of threads to use. Defaults to autodetection based on the number+  -- of cores.+  } deriving (Show, Eq)++defaultConfig :: Config+defaultConfig = Config+  { cfgPreserveIt = False+  , cfgVerbose = False+  , cfgModules = []+  , cfgThreads = Nothing+  }++parseOptions :: [String] -> Result Config+parseOptions = go defaultConfig+ where+  go config [] = Result config+  go config (arg:args) =+    case arg of+      "--help" -> ResultStdout usage+      "--info" -> ResultStdout info+      "--version" -> ResultStdout versionInfo+      "--preserve-it" -> go config{cfgPreserveIt=True} args+      "--verbose" -> go config{cfgVerbose=True} args+      ('-':'j':n0) | Just n1 <- parseThreads n0 -> go config{cfgThreads=Just n1} args+      ('-':_) -> ResultStderr ("Unknown command line argument: " <> arg)+      mod_ -> go config{cfgModules=mod_ : cfgModules config} args++parseThreads :: String -> Maybe Int+parseThreads n0 = do+  n1 <- readMaybe n0+  if n1 > 0 then Just n1 else Nothing++-- | Parse a flag into its flag and argument component.+--+-- Example:+--+-- >>> parseFlag "--optghc=foo"+-- ("--optghc",Just "foo")+-- >>> parseFlag "--optghc="+-- ("--optghc",Nothing)+-- >>> parseFlag "--fast"+-- ("--fast",Nothing)+parseFlag :: String -> (String, Maybe String)+parseFlag arg =+  case break (== '=') arg of+    (flag, ['=']) -> (flag, Nothing)+    (flag, ('=':opt)) -> (flag, Just opt)+    (flag, _) -> (flag, Nothing)
+ src/Test/DocTest/Internal/Parse.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++module Test.DocTest.Internal.Parse (+  Module (..)+, DocTest (..)+, Interaction+, Expression+, ExpectedResult+, ExpectedLine (..)+, LineChunk (..)+, getDocTests++-- * exported for testing+, parseInteractions+, parseProperties+, mkLineChunks+) where++import           Data.Char (isSpace)+import           Data.List+import           Data.Maybe+import           Data.String++import           Test.DocTest.Internal.Extract+import           Test.DocTest.Internal.Location+++data DocTest = Example Expression ExpectedResult | Property Expression+  deriving (Eq, Show)++data LineChunk = LineChunk String | WildCardChunk+  deriving (Show, Eq)++instance IsString LineChunk where+    fromString = LineChunk++data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine+  deriving (Show, Eq)++instance IsString ExpectedLine where+    fromString = ExpectedLine . return . LineChunk++type Expression = String+type ExpectedResult = [ExpectedLine]++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++parseModules :: [Module (Located String)] -> [Module [Located DocTest]]+parseModules = filter (not . isEmpty) . map parseModule+  where+    isEmpty (Module _ setup tests) = null tests && isNothing setup++-- | Convert documentation to `Example`s.+parseModule :: Module (Located String) -> Module [Located DocTest]+parseModule m = case parseComment <$> m of+  Module name setup tests -> Module name setup_ (filter (not . null) tests)+    where+      setup_ = case setup of+        Just [] -> Nothing+        _       -> setup++parseComment :: Located String -> [Located DocTest]+parseComment c = properties ++ examples+  where+    examples   = map (fmap $ uncurry Example) (parseInteractions c)+    properties = map (fmap          Property) (parseProperties   c)++-- | Extract all properties from given Haddock comment.+parseProperties :: Located String -> [Located Expression]+parseProperties (Located loc input) = go $ zipWith Located (enumerate loc) (lines input)+  where+    isPrompt :: Located String -> Bool+    isPrompt = isPrefixOf "prop>" . dropWhile isSpace . unLoc++    go xs = case dropWhile (not . isPrompt) xs of+      prop:rest -> stripPrompt `fmap` prop : go rest+      [] -> []++    stripPrompt = strip . drop 5 . dropWhile isSpace++-- | Extract all interactions from given Haddock comment.+parseInteractions :: Located String -> [Located Interaction]+parseInteractions (Located loc input) = go $ zipWith Located (enumerate loc) (lines input)+  where+    isPrompt :: Located String -> Bool+    isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc++    isBlankLine :: Located String -> Bool+    isBlankLine  = null . dropWhile isSpace . unLoc++    isEndOfInteraction :: Located String -> Bool+    isEndOfInteraction x = isPrompt x || isBlankLine x+++    go :: [Located String] -> [Located Interaction]+    go xs = case dropWhile (not . isPrompt) xs of+      prompt:rest+       | ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))),+         (ys,zs) <- break isBlankLine rest ->+          toInteraction prompt ys : go zs++       | otherwise ->+        let+          (ys,zs) = break isEndOfInteraction rest+        in+          toInteraction prompt ys : go zs+      [] -> []++-- | Create an `Interaction`, strip superfluous whitespace as appropriate.+--+-- also merge lines between :{ and :}, preserving whitespace inside+-- the block (since this is useful for avoiding {;}).+toInteraction :: Located String -> [Located String] -> Located Interaction+toInteraction (Located loc x) xs = Located loc $+  (+    (strip   cleanedE)  -- we do not care about leading and trailing+                        -- whitespace in expressions, so drop them+  , map mkExpectedLine result_+  )+  where+    -- 1. drop trailing whitespace from the prompt, remember the prefix+    (prefix, e) = span isSpace x+    (ePrompt, eRest) = splitAt 3 e++    -- 2. drop, if possible, the exact same sequence of whitespace+    -- characters from each result line+    unindent pre = map (tryStripPrefix pre . unLoc)++    cleanBody line = fromMaybe (unLoc line)+                    (stripPrefix ePrompt (dropWhile isSpace (unLoc line)))++    (cleanedE, result_)+            | (body , endLine : rest) <- break+                    ( (==) [":}"] . take 1 . words . cleanBody)+                    xs+                = (unlines (eRest : map cleanBody body +++                                [dropWhile isSpace (cleanBody endLine)]),+                        unindent (takeWhile isSpace (unLoc endLine)) rest)+            | otherwise = (eRest, unindent prefix xs)+++tryStripPrefix :: String -> String -> String+tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys++mkExpectedLine :: String -> ExpectedLine+mkExpectedLine x = case x of+    "<BLANKLINE>" -> ""+    "..." -> WildCardLine+    _ -> ExpectedLine $ mkLineChunks x++mkLineChunks :: String -> [LineChunk]+mkLineChunks = finish . foldr go (0, [], [])+  where+    mkChunk :: String -> [LineChunk]+    mkChunk "" = []+    mkChunk x  = [LineChunk x]++    go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk])+    go '.' (count, acc, res) = if count == 2+          then (0, "", WildCardChunk : mkChunk acc ++ res)+          else (count + 1, acc, res)+    go c   (count, acc, res) = if count > 0+          then (0, c : replicate count '.' ++ acc, res)+          else (0, c : acc, res)+    finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res+++-- | Remove leading and trailing whitespace.+strip :: String -> String+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+ src/Test/DocTest/Internal/Property.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}++module Test.DocTest.Internal.Property where++import           Data.List+import           Data.Maybe+import           Data.Foldable++import           Test.DocTest.Internal.Util+import           Test.DocTest.Internal.Interpreter (Interpreter)+import qualified Test.DocTest.Internal.Interpreter as Interpreter+import           Test.DocTest.Internal.Parse++-- | The result of evaluating an interaction.+data PropertyResult =+    Success+  | Failure String+  | Error String+  deriving (Eq, Show)++runProperty :: Interpreter -> Expression -> IO PropertyResult+runProperty repl expression = do+  _ <- Interpreter.safeEval repl "import Test.QuickCheck ((==>))"+  _ <- Interpreter.safeEval repl "import Test.QuickCheck.All (polyQuickCheck)"+  _ <- Interpreter.safeEval repl "import Language.Haskell.TH (mkName)"+  _ <- Interpreter.safeEval repl ":set -XTemplateHaskell"+  r <- freeVariables repl expression >>=+       (Interpreter.safeEval repl . quickCheck expression)+  case r of+    Left err -> do+      return (Error err)+    Right res+      | "OK, passed" `isInfixOf` res -> return Success+      | otherwise -> do+          let msg =  stripEnd (takeWhileEnd (/= '\b') res)+          return (Failure msg)+  where+    quickCheck term vars =+      "let doctest_prop " ++ unwords vars ++ " = " ++ term ++ "\n" +++      "$(polyQuickCheck (mkName \"doctest_prop\"))"++-- | Find all free variables in given term.+--+-- GHCi is used to detect free variables.+freeVariables :: Interpreter -> String -> IO [String]+freeVariables repl term = do+  r <- Interpreter.safeEval repl (":type " ++ term)+  return (either (const []) (nub . parseNotInScope) r)++-- | Parse and return all variables that are not in scope from a ghc error+-- message.+parseNotInScope :: String -> [String]+parseNotInScope = nub . mapMaybe extractVariable . lines+  where+    -- | Extract variable name from a "Not in scope"-error.+    extractVariable :: String -> Maybe String+    extractVariable x+      | "Not in scope: " `isInfixOf` x = Just . unquote . takeWhileEnd (/= ' ') $ x+      | Just y <- (asum $ map (stripPrefix "Variable not in scope: ") (tails x)) = Just (takeWhile (/= ' ') y)+      | otherwise = Nothing++    -- | Remove quotes from given name, if any.+    unquote ('`':xs)     = init xs+    unquote ('\8216':xs) = init xs+    unquote xs           = xs
+ src/Test/DocTest/Internal/Runner.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}++module Test.DocTest.Internal.Runner where++import           Prelude hiding (putStr, putStrLn, error)++import           Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO)+import           Control.Exception (SomeException, catch)+import           Control.Monad hiding (forM_)+import           Data.Maybe (fromMaybe)+import           Text.Printf (printf)+import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice)+import           Data.Foldable (forM_)+import           GHC.Conc (numCapabilities)++import           Control.Monad.Trans.State+import           Control.Monad.IO.Class++import           Test.DocTest.Internal.Interpreter (Interpreter)+import qualified Test.DocTest.Internal.Interpreter as Interpreter+import           Test.DocTest.Internal.Parse+import           Test.DocTest.Internal.Options (ModuleName)+import           Test.DocTest.Internal.Location+import           Test.DocTest.Internal.Property+import           Test.DocTest.Internal.Runner.Example++import           System.IO.CodePage (withCP65001)++#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif++-- | Whether an "example" is part of setup block+data FromSetup = FromSetup | NotFromSetup++-- | Summary of a test run.+data Summary = Summary {+    sExamples :: Int  -- ^ Total number of lines of examples (excluding setup)+  , sTried    :: Int  -- ^ Executed /sTried/ lines so  far+  , sErrors   :: Int  -- ^ Couldn't execute /sErrors/ examples+  , sFailures :: Int  -- ^ Got unexpected output for /sFailures/ examples+} deriving Eq++emptySummary :: Summary+emptySummary = Summary 0 0 0 0++-- | Format a summary.+instance Show Summary where+  show (Summary examples tried errors failures) =+    printf "Examples: %d  Tried: %d  Errors: %d  Unexpected output: %d" examples tried errors failures+++-- | Sum up summaries.+instance Monoid Summary where+  mempty = Summary 0 0 0 0+#if __GLASGOW_HASKELL__ < 804+  mappend = (<>)+#endif++instance Semigroup Summary where+  (<>) (Summary x1 x2 x3 x4) (Summary y1 y2 y3 y4) =+    Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4)++-- | Run all examples from a list of modules.+runModules+  :: Maybe Int+  -- ^ Number of threads to use. Defaults to 'numCapabilities'.+  -> Bool+  -- ^ Preserve it+  -> Bool+  -- ^ Verbose+  -> Bool+  -- ^ Implicit Prelude+  -> [String]+  -- ^ Arguments passed to the GHCi process.+  -> [Module [Located DocTest]]+  -- ^ Modules under test+  -> IO Summary+runModules nThreads preserveIt verbose implicitPrelude args modules = do+  isInteractive <- hIsTerminalDevice stderr++  -- Start a thread pool. It sends status updates to this thread through 'output'.+  (input, output) <-+    makeThreadPool+      (fromMaybe numCapabilities nThreads)+      (runModule preserveIt implicitPrelude args)++  -- Send instructions to threads+  liftIO (mapM_ (writeChan input) modules)++  let+    nExamples = (sum . map count) modules+    initState = ReportState 0 isInteractive verbose mempty {sExamples = nExamples}++  ReportState _ _ _ s <- (`execStateT` initState) $ do+    consumeUpdates output (length modules)+    verboseReport "# Final summary:"+    gets (show . reportStateSummary) >>= report++  return s+ where+  consumeUpdates _output 0 = pure ()+  consumeUpdates output modsLeft = do+    update <- liftIO (readChan output)+    consumeUpdates output =<<+      case update of+        UpdateInternalError fs loc e -> reportInternalError fs loc e >> pure (modsLeft - 1)+        UpdateImportError modName -> reportImportError modName >> pure (modsLeft - 1)+        UpdateSuccess fs loc -> reportSuccess fs loc >> reportProgress >> pure modsLeft+        UpdateFailure fs loc expr errs -> reportFailure fs loc expr errs >> pure modsLeft+        UpdateError fs loc expr err -> reportError fs loc expr err >> pure modsLeft+        UpdateVerbose msg -> verboseReport msg >> pure modsLeft+        UpdateStart loc expr msg -> reportStart loc expr msg >> pure modsLeft+        UpdateModuleDone -> pure (modsLeft - 1)++-- | Count number of expressions in given module.+count :: Module [Located DocTest] -> Int+count (Module _ _ tests) = sum (map length tests)++-- | A monad for generating test reports.+type Report = StateT ReportState IO++data ReportState = ReportState {+  reportStateCount        :: Int     -- ^ characters on the current line+, reportStateInteractive  :: Bool    -- ^ should intermediate results be printed?+, reportStateVerbose      :: Bool+, reportStateSummary      :: Summary -- ^ test summary+}++-- | Add output to the report.+report :: String -> Report ()+report msg = do+  overwrite msg++  -- add a newline, this makes the output permanent+  liftIO $ hPutStrLn stderr ""+  modify (\st -> st {reportStateCount = 0})++-- | Add intermediate output to the report.+--+-- This will be overwritten by subsequent calls to `report`/`report_`.+-- Intermediate out may not contain any newlines.+report_ :: String -> Report ()+report_ msg = do+  f <- gets reportStateInteractive+  when f $ do+    overwrite msg+    modify (\st -> st {reportStateCount = length msg})++-- | Add output to the report, overwrite any intermediate out.+overwrite :: String -> Report ()+overwrite msg = do+  n <- gets reportStateCount+  let str | 0 < n     = "\r" ++ msg ++ replicate (n - length msg) ' '+          | otherwise = msg+  liftIO (hPutStr stderr str)++-- | Run all examples from given module.+runModule+  :: Bool+  -> Bool+  -> [String]+  -> Chan ReportUpdate+  -> Module [Located DocTest]+  -> IO ()+runModule preserveIt implicitPrelude ghciArgs output (Module module_ setup examples) = do+  Interpreter.withInterpreter ghciArgs $ \repl -> withCP65001 $ do+    -- Try to import this module, if it fails, something is off+    importResult <- Interpreter.safeEval repl importModule+    case importResult of+      Right "" -> do+        -- Run setup group+        successes <- mapM (runTestGroup FromSetup preserveIt repl (reload repl) output) setup++        -- only run tests, if setup does not produce any errors/failures+        when+          (and successes)+          (mapM_ (runTestGroup NotFromSetup preserveIt repl (setup_ repl) output) examples)+      _ ->+        writeChan output (UpdateImportError module_)++    -- Signal main thread a module has been tested+    writeChan output UpdateModuleDone++    pure ()++  where+    importModule = ":m +" ++ module_++    reload repl = do+      void $ Interpreter.safeEval repl ":reload"+      mapM_ (Interpreter.safeEval repl) $+        if implicitPrelude+        then [":m Prelude", importModule]+        else [":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 $ "()"++    setup_ repl = do+      reload repl+      forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of+        Property _  -> return ()+        Example e _ -> void $ safeEvalWith preserveIt repl e++data ReportUpdate+  = UpdateSuccess FromSetup Location+  -- ^ Test succeeded+  | UpdateFailure FromSetup Location Expression [String]+  -- ^ Test failed with unexpected result+  | UpdateError FromSetup Location Expression String+  -- ^ Test failed with an error+  | UpdateVerbose String+  -- ^ Message to send when verbose output is activated+  | UpdateModuleDone+  -- ^ All examples tested in module+  | UpdateStart Location Expression String+  -- ^ Indicate test has started executing (verbose output)+  | UpdateInternalError FromSetup (Module [Located DocTest]) SomeException+  -- ^ Exception caught while executing internal code+  | UpdateImportError ModuleName+  -- ^ Could not import module++makeThreadPool ::+  Int ->+  (Chan ReportUpdate -> Module [Located DocTest] -> IO ()) ->+  IO (Chan (Module [Located DocTest]), Chan ReportUpdate)+makeThreadPool nThreads mutator = do+  input <- newChan+  output <- newChan+  forM_ [1..nThreads] $ \_ ->+    forkIO $ forever $ do+      i <- readChan input+      catch+        (mutator output i)+        (\e -> writeChan output (UpdateInternalError NotFromSetup i e))+  return (input, output)++reportStart :: Location -> Expression -> String -> Report ()+reportStart loc expression testType = do+  verboseReport (printf "### Started execution at %s.\n### %s:\n%s" (show loc) testType expression)++reportFailure :: FromSetup -> Location -> Expression -> [String] -> Report ()+reportFailure fromSetup loc expression err = do+  report (printf "%s: failure in expression `%s'" (show loc) expression)+  mapM_ report err+  report ""+  updateSummary fromSetup (Summary 0 1 0 1)++reportError :: FromSetup -> Location -> Expression -> String -> Report ()+reportError fromSetup loc expression err = do+  report (printf "%s: error in expression `%s'" (show loc) expression)+  report err+  report ""+  updateSummary fromSetup (Summary 0 1 1 0)++reportInternalError :: FromSetup -> Module a -> SomeException -> Report ()+reportInternalError fs mod_ err = do+  report (printf "Internal error when executing tests in %s" (moduleName mod_))+  report (show err)+  report ""+  updateSummary fs emptySummary{sErrors=1}++reportImportError :: ModuleName -> Report ()+reportImportError modName = do+  report ("Could not import module: " <> modName <> ". This can be caused by a number of issues: ")+  report ""+  report " 1. A module found by GHC contained tests, but was not in 'exposed-modules'."+  report ""+  report " 2. For Cabal users: Cabal did not generate a GHC environment file. Either:"+  report "   * Run with '--write-ghc-environment-files=always'"+  report "   * Add 'write-ghc-environment-files: always' to your cabal.project"+  report ""+  report " 3. The testsuite executable does not have a dependency on your project library. Please add it to the 'build-depends' section of the testsuite executable."+  report ""+  report "See the example project at https://github.com/martijnbastiaan/doctest-parallel/tree/master/examples for more information."+  updateSummary FromSetup emptySummary{sErrors=1}++reportSuccess :: FromSetup -> Location -> Report ()+reportSuccess fromSetup loc = do+  verboseReport (printf "### Successful `%s'!\n" (show loc))+  updateSummary fromSetup (Summary 0 1 0 0)++verboseReport :: String -> Report ()+verboseReport xs = do+  verbose <- gets reportStateVerbose+  when verbose $ report xs++updateSummary :: FromSetup -> Summary -> Report ()+updateSummary FromSetup summary =+  -- Suppress counts, except for errors+  updateSummary NotFromSetup summary{sExamples=0, sTried=0, sFailures=0}+updateSummary NotFromSetup summary = do+  ReportState n f v s <- get+  put (ReportState n f v $ s `mappend` summary)++reportProgress :: Report ()+reportProgress = do+  verbose <- gets reportStateVerbose+  when (not verbose) $ gets (show . reportStateSummary) >>= report_++-- | Run given test group.+--+-- The interpreter state is zeroed with @:reload@ first.  This means that you+-- can reuse the same 'Interpreter' for several test groups.+runTestGroup ::+  FromSetup ->+  Bool ->+  Interpreter ->+  IO () ->+  Chan ReportUpdate ->+  [Located DocTest] ->+  IO Bool+runTestGroup fromSetup preserveIt repl setup output tests = do++  setup+  successExamples <- runExampleGroup fromSetup preserveIt repl output examples++  successesProperties <- forM properties $ \(loc, expression) -> do+    r <- do+      setup+      writeChan output (UpdateStart loc expression "property")+      runProperty repl expression++    case r of+      Success -> do+        writeChan output (UpdateSuccess fromSetup loc)+        pure True+      Error err -> do+        writeChan output (UpdateError fromSetup loc expression err)+        pure False+      Failure msg -> do+        writeChan output (UpdateFailure fromSetup loc expression [msg])+        pure False++  pure (successExamples && and successesProperties)+  where+    properties = [(loc, p) | Located loc (Property p) <- tests]++    examples :: [Located Interaction]+    examples = [Located loc (e, r) | Located loc (Example e r) <- tests]++-- |+-- Execute all expressions from given example in given 'Interpreter' and verify+-- the output.+runExampleGroup ::+  FromSetup ->+  Bool ->+  Interpreter ->+  Chan ReportUpdate ->+  [Located Interaction] ->+  IO Bool+runExampleGroup fromSetup preserveIt repl output = go+  where+    go ((Located loc (expression, expected)) : xs) = do+      writeChan output (UpdateStart loc expression "example")+      r <- fmap lines <$> safeEvalWith preserveIt repl expression+      case r of+        Left err -> do+          writeChan output (UpdateError fromSetup loc expression err)+          pure False+        Right actual -> case mkResult expected actual of+          NotEqual err -> do+            writeChan output (UpdateFailure fromSetup loc expression err)+            pure False+          Equal -> do+            writeChan output (UpdateSuccess fromSetup loc)+            go xs+    go [] =+      pure True++safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String)+safeEvalWith preserveIt+  | preserveIt = Interpreter.safeEvalIt+  | otherwise  = Interpreter.safeEval
+ src/Test/DocTest/Internal/Runner/Example.hs view
@@ -0,0 +1,151 @@+module Test.DocTest.Internal.Runner.Example (+  Result (..)+, mkResult+) where++import           Data.Char+import           Data.List++import           Test.DocTest.Internal.Util+import           Test.DocTest.Internal.Parse++maxBy :: (Ord a) => (b -> a) -> b -> b -> b+maxBy f x y = case compare (f x) (f y) of+  LT -> y+  EQ -> x+  GT -> x++data Result = Equal | NotEqual [String]+  deriving (Eq, Show)++mkResult :: ExpectedResult -> [String] -> Result+mkResult expected_ actual_ =+  case expected `matches` actual of+  Full            -> Equal+  Partial partial -> NotEqual (formatNotEqual expected actual partial)+  where+    -- use show to escape special characters in output lines if any output line+    -- contains any unsafe character+    escapeOutput+      | any (not . isSafe) $ concat (expectedAsString ++ actual_) = init . tail . show . stripEnd+      | otherwise = id++    actual :: [String]+    actual = fmap escapeOutput actual_++    expected :: ExpectedResult+    expected = fmap (transformExcpectedLine escapeOutput) expected_++    expectedAsString :: [String]+    expectedAsString = map (\x -> case x of+        ExpectedLine str -> concatMap lineChunkToString str+        WildCardLine -> "..." ) expected_++    isSafe :: Char -> Bool+    isSafe c = c == ' ' || (isPrint c && (not . isSpace) c)++    chunksMatch :: [LineChunk] -> String -> Match ChunksDivergence+    chunksMatch [] "" = Full+    chunksMatch [LineChunk xs] ys =+      if stripEnd xs == stripEnd ys+      then Full+      else Partial $ matchingPrefix xs ys+    chunksMatch (LineChunk x : xs) ys =+      if x `isPrefixOf` ys+      then fmap (prependText x) $ (xs `chunksMatch` drop (length x) ys)+      else Partial $ matchingPrefix x ys+    chunksMatch zs@(WildCardChunk : xs) (_:ys) =+      -- Prefer longer matches.+      fmap prependWildcard $ maxBy+        (fmap $ length . matchText)+        (chunksMatch xs ys)+        (chunksMatch zs ys)+    chunksMatch [WildCardChunk] [] = Full+    chunksMatch (WildCardChunk:_) [] = Partial (ChunksDivergence "" "")+    chunksMatch [] (_:_) = Partial (ChunksDivergence "" "")++    matchingPrefix xs ys =+      let common = fmap fst (takeWhile (\(x, y) -> x == y) (xs `zip` ys)) in+      ChunksDivergence common common++    matches :: ExpectedResult -> [String] -> Match LinesDivergence+    matches (ExpectedLine x : xs) (y : ys) =+      case x `chunksMatch` y of+      Full -> fmap incLineNo $ xs `matches` ys+      Partial partial -> Partial (LinesDivergence 1 (expandedWildcards partial))+    matches zs@(WildCardLine : xs) us@(_ : ys) =+      -- Prefer longer matches, and later ones of equal length.+      let matchWithoutWC = xs `matches` us in+      let matchWithWC    = fmap incLineNo (zs `matches` ys) in+      let key (LinesDivergence lineNo line) = (length line, lineNo) in+      maxBy (fmap key) matchWithoutWC matchWithWC+    matches [WildCardLine] [] = Full+    matches [] [] = Full+    matches [] _  = Partial (LinesDivergence 1 "")+    matches _  [] = Partial (LinesDivergence 1 "")++-- Note: order of constructors matters, so that full matches sort as+-- greater than partial.+data Match a = Partial a | Full+  deriving (Eq, Ord, Show)++instance Functor Match where+  fmap f (Partial a) = Partial (f a)+  fmap _ Full = Full++data ChunksDivergence = ChunksDivergence { matchText :: String, expandedWildcards :: String }+  deriving (Show)++prependText :: String -> ChunksDivergence -> ChunksDivergence+prependText s (ChunksDivergence mt wct) = ChunksDivergence (s++mt) (s++wct)++prependWildcard :: ChunksDivergence -> ChunksDivergence+prependWildcard (ChunksDivergence mt wct) = ChunksDivergence mt ('.':wct)++data LinesDivergence = LinesDivergence { _mismatchLineNo :: Int, _partialLine :: String }+  deriving (Show)++incLineNo :: LinesDivergence -> LinesDivergence+incLineNo (LinesDivergence lineNo partialLineMatch) = LinesDivergence (lineNo + 1) partialLineMatch++formatNotEqual :: ExpectedResult -> [String] -> LinesDivergence -> [String]+formatNotEqual expected_ actual partial = formatLines "expected: " expected ++ formatLines " but got: " (lineMarker wildcard partial actual)+  where+    expected :: [String]+    expected = map (\x -> case x of+        ExpectedLine str -> concatMap lineChunkToString str+        WildCardLine -> "..." ) expected_++    formatLines :: String -> [String] -> [String]+    formatLines message xs = case xs of+      y:ys -> (message ++ y) : map (padding ++) ys+      []   -> [message]+      where+        padding = replicate (length message) ' '++    wildcard :: Bool+    wildcard = any (\x -> case x of+        ExpectedLine xs -> any (\y -> case y of { WildCardChunk -> True; _ -> False }) xs+        WildCardLine -> True ) expected_++lineChunkToString :: LineChunk -> String+lineChunkToString WildCardChunk = "..."+lineChunkToString (LineChunk str) = str++transformExcpectedLine :: (String -> String) -> ExpectedLine -> ExpectedLine+transformExcpectedLine f (ExpectedLine xs) =+  ExpectedLine $ fmap (\el -> case el of+    LineChunk s -> LineChunk $ f s+    WildCardChunk -> WildCardChunk+  ) xs+transformExcpectedLine _ WildCardLine = WildCardLine++lineMarker :: Bool -> LinesDivergence -> [String] -> [String]+lineMarker wildcard (LinesDivergence row expanded) actual =+  let (pre, post) = splitAt row actual in+  pre +++  [(if wildcard && length expanded > 30+    -- show expanded pattern if match is long, to help understanding what matched what+    then expanded+    else replicate (length expanded) ' ') ++ "^"] +++  post
+ src/Test/DocTest/Internal/Util.hs view
@@ -0,0 +1,27 @@+module Test.DocTest.Internal.Util where++import           Data.Char++convertDosLineEndings :: String -> String+convertDosLineEndings = go+  where+    go input = case input of+      '\r':'\n':xs -> '\n' : go xs++      -- Haddock comments from source files with dos line endings end with a+      -- CR, so we strip that, too.+      "\r"         -> ""++      x:xs         -> x : go xs+      ""           -> ""++-- | Return the longest suffix of elements that satisfy a given predicate.+takeWhileEnd :: (a -> Bool) -> [a] -> [a]+takeWhileEnd p = reverse . takeWhile p . reverse++-- | Remove trailing white space from a string.+--+-- >>> stripEnd "foo   "+-- "foo"+stripEnd :: String -> String+stripEnd = reverse . dropWhile isSpace . reverse
+ test/ExtractSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module ExtractSpec (main, spec) where++import           Test.Hspec+import           Test.HUnit+++#if __GLASGOW_HASKELL__ < 900+import           Panic (GhcException (..))+#else+import           GHC.Utils.Panic (GhcException (..))+#endif++import           Test.DocTest.Internal.Extract+import           Test.DocTest.Internal.Location+import           System.FilePath+++shouldGive :: HasCallStack => (String, String) -> [Module String] -> Assertion+(d, m) `shouldGive` expected = do+  r <- map (fmap unLoc) `fmap` extract ["-i" ++ dir, dir </> m]+  r `shouldBe` expected+  where dir = "test/extract" </> d++main :: IO ()+main = hspec spec++spec :: Spec+spec = do++  describe "extract" $ do+    it "extracts documentation for a top-level declaration" $ do+      ("declaration", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Some documentation"]]++    it "extracts documentation from argument list" $ do+      ("argument-list", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" doc for arg1", " doc for arg2"]]++    it "extracts documentation for a type class function" $ do+      ("type-class", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Convert given value to a string."]]++    it "extracts documentation from the argument list of a type class function" $ do+      ("type-class-args", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" foo", " bar"]]++    it "extracts documentation from the module header" $ do+      ("module-header", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Some documentation"]]++    it "extracts documentation from imported modules" $ do+      ("imported-module", "Bar.hs") `shouldGive` [Module "Bar" Nothing [" documentation for bar"], Module "Baz" Nothing [" documentation for baz"]]++    it "extracts documentation from export list" $ do+      ("export-list", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" documentation from export list"]]++    it "extracts documentation from named chunks" $ do+      ("named-chunks", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" named chunk foo", "\n named chunk bar"]]++    it "returns docstrings in the same order they appear in the source" $ do+      ("comment-order", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]]++    it "extracts $setup code" $ do+      ("setup", "Foo.hs") `shouldGive` [Module "Foo" (Just "\n some setup code") [" foo", " bar", " baz"]]++    it "fails on invalid flags" $ do+      extract ["--foobar", "test/Foo.hs"] `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False)++  describe "extract (regression tests)" $ do+    it "works with infix operators" $ do+      ("regression", "Fixity.hs") `shouldGive` [Module "Fixity" Nothing []]++    it "works with parallel list comprehensions" $ do+      ("regression", "ParallelListComp.hs") `shouldGive` [Module "ParallelListComp" Nothing []]++    it "works with list comprehensions in instance definitions" $ do+      ("regression", "ParallelListCompClass.hs") `shouldGive` [Module "ParallelListCompClass" Nothing []]++    it "works with foreign imports" $ do+      ("regression", "ForeignImport.hs") `shouldGive` [Module "ForeignImport" Nothing []]++    it "works for rewrite rules" $ do+      ("regression", "RewriteRules.hs") `shouldGive` [Module "RewriteRules" Nothing [" doc for foo"]]++    it "works for rewrite rules with type signatures" $ do+      ("regression", "RewriteRulesWithSigs.hs") `shouldGive` [Module "RewriteRulesWithSigs" Nothing [" doc for foo"]]++    it "strips CR from dos line endings" $ do+      ("dos-line-endings", "Foo.hs") `shouldGive` [Module "Foo" Nothing ["\n foo\n bar\n baz"]]++    it "works with a module that splices in an expression from an other module" $ do+      ("th", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" some documentation"], Module "Bar" Nothing []]++    it "works for type families and GHC 7.6.1" $ do+      ("type-families", "Foo.hs") `shouldGive` [Module "Foo" Nothing []]
+ test/InterpreterSpec.hs view
@@ -0,0 +1,32 @@+module InterpreterSpec (main, spec) where++import           Prelude ()+import           Prelude.Compat++import           Test.Hspec++import qualified Test.DocTest.Internal.Interpreter as Interpreter+import           Test.DocTest.Internal.Interpreter+  (haveInterpreterKey, ghcInfo, withInterpreter)++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "interpreterSupported" $ do+    it "indicates whether GHCi is supported on current platform" $ do+      (Interpreter.interpreterSupported >> return ()) `shouldReturn` ()++  describe "ghcInfo" $ do+    it ("includes " ++ show haveInterpreterKey) $ do+      info <- ghcInfo+      lookup haveInterpreterKey info `shouldSatisfy`+        (||) <$> (== Just "YES") <*> (== Just "NO")++  describe "safeEval" $ do+    it "evaluates an expression" $ withInterpreter [] $ \ghci -> do+      Interpreter.safeEval ghci "23 + 42" `shouldReturn` Right "65\n"++    it "returns Left on unterminated multiline command" $ withInterpreter [] $ \ghci -> do+      Interpreter.safeEval ghci ":{\n23 + 42" `shouldReturn` Left "unterminated multiline command"
+ test/LocationSpec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}++module LocationSpec (main, spec) where++import           Test.Hspec++import           Test.DocTest.Internal.Location++#if __GLASGOW_HASKELL__ < 900+import           SrcLoc+import           FastString (fsLit)+#else+import           GHC.Types.SrcLoc+import           GHC.Data.FastString (fsLit)+#endif++main :: IO ()+main = hspec spec++spec :: Spec+spec = do++  describe "toLocation" $ do++    it "works for a regular SrcSpan" $ do+      toLocation (mkSrcSpan (mkSrcLoc (fsLit "Foo.hs") 2 5) (mkSrcLoc (fsLit "Foo.hs") 10 20))+        `shouldBe` Location "Foo.hs" 2++    it "works for a single-line SrcSpan" $ do+      toLocation (mkSrcSpan (mkSrcLoc (fsLit "Foo.hs") 2 5) (mkSrcLoc (fsLit "Foo.hs") 2 10))+        `shouldBe` Location "Foo.hs" 2++    it "works for a SrcSpan that corresponds to single point" $ do+      (toLocation . srcLocSpan) (mkSrcLoc (fsLit "Foo.hs") 10 20)+        `shouldBe` Location "Foo.hs" 10++    it "works for a bad SrcSpan" $ do+      toLocation noSrcSpan `shouldBe` UnhelpfulLocation "<no location info>"++    it "works for a SrcLoc with bad locations" $ do+      toLocation (mkSrcSpan noSrcLoc noSrcLoc)+        `shouldBe` UnhelpfulLocation "<no location info>"++  describe "enumerate" $ do+    it "replicates UnhelpfulLocation" $ do+      let loc = UnhelpfulLocation "foo"+      (take 10 $ enumerate loc) `shouldBe` replicate 10 loc++    it "enumerates Location" $ do+      let loc = Location "Foo.hs" 23+      (take 3 $ enumerate loc) `shouldBe` [Location "Foo.hs" 23, Location "Foo.hs" 24, Location "Foo.hs" 25]
+ test/MainSpec.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module MainSpec (main, spec) where++import           Test.Hspec+import           Test.HUnit (assertEqual, Assertion)++import qualified Test.DocTest as DocTest+import           Test.DocTest.Helpers (extractSpecificCabalLibrary, findCabalPackage)+import           Test.DocTest.Internal.Options+import           Test.DocTest.Internal.Runner+import           System.IO.Silently+import           System.IO++-- | Construct a doctest specific 'Assertion'.+doctest :: HasCallStack => [ModuleName] -> Summary -> Assertion+doctest = doctestWithOpts defaultConfig++doctestWithOpts :: HasCallStack => Config -> [ModuleName] -> Summary -> Assertion+doctestWithOpts config modNames expected = do+  pkg <- findCabalPackage "doctest-parallel"+  lib <- extractSpecificCabalLibrary (Just "spectests-modules") pkg+  actual <-+    hSilence [stderr] $+      DocTest.main lib config{cfgModules=modNames}+  assertEqual (show modNames) expected actual++cases :: Int -> Summary+cases n = Summary n n 0 0++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "doctest" $ do+    it "testSimple" $+      doctest ["TestSimple.Fib"]+        (cases 1)++    it "it-variable" $ do+      doctestWithOpts (defaultConfig{cfgPreserveIt=True}) ["It.Foo"]+        (cases 5)++    it "it-variable in $setup" $ do+      doctestWithOpts (defaultConfig{cfgPreserveIt=True}) ["It.Setup"]+        (cases 2)++    it "failing" $ do+      doctest ["Failing.Foo"]+        (cases 1) {sFailures = 1}++    it "skips subsequent examples from the same group if an example fails" $+      doctest ["FailingMultiple.Foo"]+        (cases 4) {sTried = 2, sFailures = 1}++    it "testImport" $ do+      doctest ["TestImport.ModuleA"]+        (cases 2)++    it "testCommentLocation" $ do+      doctest ["TestCommentLocation.Foo"]+        (cases 11)++    it "testPutStr" $ do+      doctest ["TestPutStr.Fib"]+        (cases 3)++    it "fails on multi-line expressions, introduced with :{" $ do+      doctest ["TestFailOnMultiline.Fib"]+        (cases 2) {sErrors = 2}++    it "testBlankline" $ do+      doctest ["TestBlankline.Fib"]+        (cases 1)++    it "examples from the same Haddock comment share the same scope" $ do+      doctest ["TestCombinedExample.Fib"]+        (cases 4)++    it "testDocumentationForArguments" $ do+      doctest ["TestDocumentationForArguments.Fib"]+        (cases 1)++    it "template-haskell" $ do+      doctest ["TemplateHaskell.Foo"]+        (cases 2)++    it "handles source files with CRLF line endings" $ do+      doctest ["DosLineEndings.Fib"]+        (cases 1)++    it "runs $setup before each test group" $ do+      doctest ["Setup.Foo"]+        (cases 1)++    it "skips subsequent tests from a module, if $setup fails" $ do+      doctest ["SetupSkipOnFailure.Foo"]+        -- TODO: Introduce "skipped"+        (cases 2) {sTried = 0, sFailures = 0}++    it "works with additional object files" $ do+      doctest ["WithCbits.Bar"]+        (cases 1)++    it "ignores trailing whitespace when matching test output" $ do+      doctest ["TrailingWhitespace.Foo"]+        (cases 1)++  describe "doctest as a runner for QuickCheck properties" $ do+    it "runs a boolean property" $ do+      doctest ["PropertyBool.Foo"]+        (cases 1)++    it "runs an explicitly quantified property" $ do+      doctest ["PropertyQuantified.Foo"]+        (cases 1)++    it "runs an implicitly quantified property" $ do+      doctest ["PropertyImplicitlyQuantified.Foo"]+        (cases 1)++    it "reports a failing property" $ do+      doctest ["PropertyFailing.Foo"]+        (cases 1) {sFailures = 1}++    it "runs a boolean property with an explicit type signature" $ do+      doctest ["PropertyBoolWithTypeSignature.Foo"]+        (cases 1)++    it "runs $setup before each property" $ do+      doctest ["PropertySetup.Foo"]+        (cases 1)++  describe "doctest (module isolation)" $ do+    it "should fail due to module isolation" $ do+      doctestWithOpts defaultConfig ["ModuleIsolation.TestA", "ModuleIsolation.TestB"]+        (cases 2) {sFailures = 1}++  describe "doctest (regression tests)" $ do+    it "bugfixOutputToStdErr" $ do+      doctest ["BugfixOutputToStdErr.Fib"]+        (cases 2)++    it "bugfixImportHierarchical" $ do+      doctest ["BugfixImportHierarchical.ModuleA", "BugfixImportHierarchical.ModuleB"]+        (cases 4)++    it "bugfixMultipleModules" $ do+      doctest ["BugfixMultipleModules.ModuleA", "BugfixMultipleModules.ModuleB"]+        -- TODO: Introduce "skipped"+        (cases 6) {sTried = 5, sFailures = 1}++    it "doesn't clash with user bindings of stdout/stderr" $ do+      doctest ["LocalStderrBinding.A"]+        (cases 1)++    it "doesn't get confused by doctests using System.IO imports" $ do+      doctest ["SystemIoImported.A"]+        (cases 2)
+ test/OptionsSpec.hs view
@@ -0,0 +1,41 @@+module OptionsSpec (spec) where++import           Prelude ()+import           Prelude.Compat++import           Test.Hspec++import           Test.DocTest.Internal.Options++spec :: Spec+spec = do+  describe "parseOptions" $ do+    describe "--preserve-it" $ do+      context "without --preserve-it" $ do+        it "does not preserve the `it` variable" $ do+          cfgPreserveIt <$> parseOptions [] `shouldBe` Result False++      context "with --preserve-it" $ do+        it "preserves the `it` variable" $ do+          cfgPreserveIt <$> parseOptions ["--preserve-it"] `shouldBe` Result True++    context "with --help" $ do+      it "outputs usage information" $ do+        parseOptions ["--help"] `shouldBe` ResultStdout usage++    context "with --version" $ do+      it "outputs version information" $ do+        parseOptions ["--version"] `shouldBe` ResultStdout versionInfo++    context "with --info" $ do+      it "outputs machine readable version information" $ do+        parseOptions ["--info"] `shouldBe` ResultStdout info++    describe "--verbose" $ do+      context "without --verbose" $ do+        it "is not verbose by default" $ do+          cfgVerbose <$> parseOptions [] `shouldBe` Result False++      context "with --verbose" $ do+        it "parses verbose option" $ do+          cfgVerbose <$> parseOptions ["--verbose"] `shouldBe` Result True
+ test/ParseSpec.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE OverloadedStrings #-}+module ParseSpec (main, spec) where++import           Test.Hspec+import           Data.String+import           Data.String.Builder (Builder, build)+import           Control.Monad.Trans.Writer++import           Test.DocTest.Internal.Parse+import           Test.DocTest.Internal.Location++main :: IO ()+main = hspec spec++group :: Writer [DocTest] () -> Writer [[DocTest]] ()+group g = tell [execWriter g]++ghci :: Expression -> Builder -> Writer [DocTest] ()+ghci expressions expected = tell [Example expressions $ (map fromString . lines . build) expected]++prop_ :: Expression -> Writer [DocTest] ()+prop_ e = tell [Property e]++module_ :: String -> Writer [[DocTest]] () -> Writer [Module [DocTest]] ()+module_ name gs = tell [Module name Nothing $ execWriter gs]++shouldGive :: IO [Module [Located DocTest]] -> Writer [Module [DocTest]] () -> Expectation+shouldGive action expected = map (fmap $ map unLoc) `fmap` action `shouldReturn` execWriter expected++spec :: Spec+spec = do+  describe "getDocTests" $ do+    it "extracts properties from a module" $ do+      getDocTests ["test/parse/property/Fib.hs"] `shouldGive` do+        module_ "Fib" $ do+          group $ do+            prop_ "foo"+            prop_ "bar"+            prop_ "baz"++    it "extracts examples from a module" $ do+      getDocTests ["test/parse/simple/Fib.hs"] `shouldGive` do+        module_ "Fib" $ do+          group $ do+            ghci "putStrLn \"foo\""+              "foo"+            ghci "putStr \"bar\""+              "bar"+            ghci "putStrLn \"baz\""+              "baz"++    it "extracts examples from documentation for non-exported names" $ do+      getDocTests ["test/parse/non-exported/Fib.hs"] `shouldGive` do+        module_ "Fib" $ do+          group $ do+            ghci "putStrLn \"foo\""+              "foo"+            ghci "putStr \"bar\""+              "bar"+            ghci "putStrLn \"baz\""+              "baz"++    it "extracts multiple examples from a module" $ do+      getDocTests ["test/parse/multiple-examples/Foo.hs"] `shouldGive` do+        module_ "Foo" $ do+          group $ do+            ghci "foo"+              "23"+          group $ do+            ghci "bar"+              "42"++    it "returns an empty list, if documentation contains no examples" $ do+      getDocTests ["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+        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+        tell [Module "Foo" (Just [Example "foo" ["23"]]) []]++  describe "parseInteractions (an internal function)" $ do++    let parse_ = map unLoc . parseInteractions . noLocation . build++    it "parses an interaction" $ do+      parse_ $ do+        ">>> foo"+        "23"+      `shouldBe` [("foo", ["23"])]++    it "drops whitespace as appropriate" $ do+      parse_ $ do+        "    >>> foo   "+        "    23"+      `shouldBe` [("foo", ["23"])]++    it "parses an interaction without a result" $ do+      parse_ $ do+        ">>> foo"+      `shouldBe` [("foo", [])]++    it "works with a complex example" $ do+      parse_ $ do+        "test"+        "foobar"+        ""+        ">>> foo"+        "23"+        ""+        ">>> baz"+        ""+        ">>> bar"+        "23"+        ""+        "baz"+      `shouldBe` [("foo", ["23"]), ("baz", []), ("bar", ["23"])]++    it "attaches location information to parsed interactions" $ do+      let loc = Located . Location "Foo.hs"+      r <- return . parseInteractions . loc 23 . build  $ do+        "1"+        "2"+        ""+        ">>> 4"+        "5"+        ""+        ">>> 7"+        ""+        ">>> 9"+        "10"+        ""+        "11"+      r `shouldBe` [loc 26 $ ("4", ["5"]), loc 29 $ ("7", []), loc 31 $ ("9", ["10"])]++    it "basic multiline" $ do+      parse_ $ do+        ">>> :{ first"+        " next"+        "some"+        ":}"+        "output"+      `shouldBe` [(":{ first\n next\nsome\n:}", ["output"])]++    it "multiline align output" $ do+      parse_ $ do+        ">>> :{ first"+        "  :}"+        "  output"+      `shouldBe` [(":{ first\n:}", ["output"])]++    it "multiline align output with >>>" $ do+      parse_ $ do+        " >>> :{ first"+        " >>> :}"+        " output"+      `shouldBe` [(":{ first\n:}", ["output"])]++    it "parses wild cards lines" $ do+      parse_ $ do+        " >>> action"+        " foo"+        " ..."+        " bar"+      `shouldBe` [("action", ["foo", WildCardLine, "bar"])]++    it "parses wild card chunks" $ do+      parse_ $ do+        " >>> action"+        " foo ... bar"+      `shouldBe` [("action", [ExpectedLine ["foo ", WildCardChunk, " bar"]])]++  describe " parseProperties (an internal function)" $ do+    let parse_ = map unLoc . parseProperties . noLocation . build++    it "parses a property" $ do+      parse_ $ do+        "prop> foo"+      `shouldBe` ["foo"]++  describe "mkLineChunks (an internal function)" $ do++    it "replaces ellipsis with WildCardChunks" $ do+      mkLineChunks "foo ... bar ... baz" `shouldBe`+        ["foo ", WildCardChunk, " bar ", WildCardChunk, " baz"]++    it "doesn't replace fewer than 3 consecutive dots" $ do+      mkLineChunks "foo .. bar .. baz" `shouldBe`+        ["foo .. bar .. baz"]++    it "handles leading and trailing dots" $ do+      mkLineChunks ".. foo bar .." `shouldBe` [".. foo bar .."]++    it "handles leading and trailing ellipsis" $ do+      mkLineChunks "... foo bar ..." `shouldBe` [ WildCardChunk+                                                , " foo bar "+                                                , WildCardChunk+                                                ]
+ test/PropertySpec.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+module PropertySpec (main, spec) where++import           Test.Hspec+import           Data.String.Builder++import           Test.DocTest.Internal.Property+import           Test.DocTest.Internal.Interpreter (withInterpreter)++main :: IO ()+main = hspec spec++isFailure :: PropertyResult -> Bool+isFailure (Failure _) = True+isFailure _ = False++spec :: Spec+spec = do+  describe "runProperty" $ do+    it "reports a failing property" $ withInterpreter [] $ \repl -> do+      runProperty repl "False" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):"++    it "runs a Bool property" $ withInterpreter [] $ \repl -> do+      runProperty repl "True" `shouldReturn` Success++    it "runs a Bool property with an explicit type signature" $ withInterpreter [] $ \repl -> do+      runProperty repl "True :: Bool" `shouldReturn` Success++    it "runs an implicitly quantified property" $ withInterpreter [] $ \repl -> do+      runProperty repl "(reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success++    it "runs an implicitly quantified property even with GHC 7.4" $+      -- ghc will include a suggestion (did you mean `id` instead of `is`) in+      -- the error message+      withInterpreter [] $ \repl -> do+        runProperty repl "foldr (+) 0 is == sum (is :: [Int])" `shouldReturn` Success++    it "runs an explicitly quantified property" $ withInterpreter [] $ \repl -> do+      runProperty repl "\\xs -> (reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success++    it "allows to mix implicit and explicit quantification" $ withInterpreter [] $ \repl -> do+      runProperty repl "\\x -> x + y == y + x" `shouldReturn` Success++    it "reports the value for which a property fails" $ withInterpreter [] $ \repl -> do+      runProperty repl "x == 23" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):\n0"++    it "reports the values for which a property that takes multiple arguments fails" $ withInterpreter [] $ \repl -> do+      let vals x = case x of (Failure r) -> tail (lines r); _ -> error "Property did not fail!"+      vals `fmap` runProperty repl "x == True && y == 10 && z == \"foo\"" `shouldReturn` ["False", "0", show ("" :: String)]++    it "defaults ambiguous type variables to Integer" $ withInterpreter [] $ \repl -> do+      runProperty repl "reverse xs == xs" >>= (`shouldSatisfy` isFailure)++  describe "freeVariables" $ do+    it "finds a free variables in a term" $ withInterpreter [] $ \repl -> do+      freeVariables repl "x" `shouldReturn` ["x"]++    it "ignores duplicates" $ withInterpreter [] $ \repl -> do+      freeVariables repl "x == x" `shouldReturn` ["x"]++    it "works for terms with multiple names" $ withInterpreter [] $ \repl -> do+      freeVariables repl "\\z -> x + y + z == foo 23" `shouldReturn` ["x", "y", "foo"]++    it "works for names that contain a prime" $ withInterpreter [] $ \repl -> do+      freeVariables repl "x' == y''" `shouldReturn` ["x'", "y''"]++    it "works for names that are similar to other names that are in scope" $ withInterpreter [] $ \repl -> do+      freeVariables repl "length_" `shouldReturn` ["length_"]++  describe "parseNotInScope" $ do+    context "when error message was produced by GHC 7.4.1" $ do+      it "extracts a variable name of variable that is not in scope from an error message" $ do+        parseNotInScope . build $ do+          "<interactive>:4:1: Not in scope: `x'"+        `shouldBe` ["x"]++      it "ignores duplicates" $ do+        parseNotInScope . build $ do+          "<interactive>:4:1: Not in scope: `x'"+          ""+          "<interactive>:4:6: Not in scope: `x'"+        `shouldBe` ["x"]++      it "works for variable names that contain a prime" $ do+        parseNotInScope . build $ do+          "<interactive>:2:1: Not in scope: x'"+          ""+          "<interactive>:2:7: Not in scope: y'"+        `shouldBe` ["x'", "y'"]++      it "works for error messages with suggestions" $ do+        parseNotInScope . build $ do+          "<interactive>:1:1:"+          "    Not in scope: `is'"+          "    Perhaps you meant `id' (imported from Prelude)"+        `shouldBe` ["is"]++    context "when error message was produced by GHC 8.0.1" $ do+      it "extracts a variable name of variable that is not in scope from an error message" $ do+        parseNotInScope . build $ do+          "<interactive>:1:1: error: Variable not in scope: x"+        `shouldBe` ["x"]++      it "ignores duplicates" $ do+        parseNotInScope . build $ do+          "<interactive>:1:1: error: Variable not in scope: x :: ()"+          ""+          "<interactive>:1:6: error: Variable not in scope: x :: ()"+        `shouldBe` ["x"]++      it "works for variable names that contain a prime" $ do+        parseNotInScope . build $ do+          "<interactive>:1:1: error: Variable not in scope: x' :: ()"+          ""+          "<interactive>:1:7: error: Variable not in scope: y'' :: ()"+        `shouldBe` ["x'", "y''"]++      it "works for error messages with suggestions" $ do+        parseNotInScope . build $ do+          "<interactive>:1:1: error:"+          "    • Variable not in scope: length_"+          "    • Perhaps you meant ‘length’ (imported from Prelude)"+        `shouldBe` ["length_"]
+ test/RunSpec.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+module RunSpec (main, spec) where++import           Prelude ()+import           Prelude.Compat++import           Test.Hspec+import           System.Exit++import qualified Control.Exception as E+import           Data.List.Compat++import           System.IO.Silently+import           System.IO (stderr)+import qualified Test.DocTest as DocTest+import           Test.DocTest.Helpers (findCabalPackage, extractSpecificCabalLibrary)+import qualified Test.DocTest.Internal.Options as Options++doctest :: HasCallStack => [String] -> IO ()+doctest args = do+  pkg <- findCabalPackage "doctest-parallel"+  lib <- extractSpecificCabalLibrary (Just "spectests-modules") pkg+  DocTest.mainFromLibrary lib args++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "doctest" $ do+    it "exits with ExitFailure if at least one test case fails" $ do+      hSilence [stderr] (doctest ["Failing.Foo"]) `shouldThrow` (== ExitFailure 1)++    it "prints help on --help" $ do+      (r, ()) <- capture (doctest ["--help"])+      r `shouldBe` Options.usage++    it "prints version on --version" $ do+      (r, ()) <- capture (doctest ["--version"])+      lines r `shouldSatisfy` any (isPrefixOf "doctest version ")++    it "prints error message on invalid option" $ do+      (r, e) <- hCapture [stderr] . E.try $ doctest ["--foo", "test/integration/test-options/Foo.hs"]+      e `shouldBe` Left (ExitFailure 1)+      r `shouldBe` unlines [+          "doctest: Unknown command line argument: --foo"+        , "Try `doctest --help' for more information."+        ]++    -- The commented tests fail, but only because `doctest-parallel` prints+    -- absolute paths.+    --+    -- TODO: Fix++    -- it "prints verbose description of a specification" $ do+    --   (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "TestSimple.Fib"]+    --   r `shouldBe` unlines [+    --       "### Started execution at test/integration/TestSimple/Fib.hs:5."+    --     , "### example:"+    --     , "fib 10"+    --     , "### Successful `test/integration/TestSimple/Fib.hs:5'!"+    --     , ""+    --     , "# Final summary:"+    --     , "Examples: 1  Tried: 1  Errors: 0  Unexpected output: 0"+    --     ]++    -- it "prints verbose description of a property" $ do+    --   (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "PropertyBool.Foo"]+    --   r `shouldBe` unlines [+    --       "### Started execution at test/integration/PropertyBool/Foo.hs:4."+    --     , "### property:"+    --     , "True"+    --     , "### Successful `test/integration/PropertyBool/Foo.hs:4'!"+    --     , ""+    --     , "# Final summary:"+    --     , "Examples: 1  Tried: 1  Errors: 0  Unexpected output: 0"+    --     ]++    -- it "prints verbose error" $ do+    --   (r, e) <- hCapture [stderr] . E.try $ doctest ["--verbose", "Failing.Foo"]+    --   e `shouldBe` Left (ExitFailure 1)+    --   r `shouldBe` unlines [+    --           "### Started execution at test/integration/Failing/Foo.hs:5."+    --         , "### example:"+    --         , "23"+    --         , "test/integration/Failing/Foo.hs:5: failure in expression `23'"+    --         , "expected: 42"+    --         , " but got: 23"+    --         , "          ^"+    --         , ""+    --         , "# Final summary:"+    --         , "Examples: 1  Tried: 1  Errors: 0  Unexpected output: 1"+    --     ]
+ test/Runner/ExampleSpec.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+module Runner.ExampleSpec (main, spec) where++import           Prelude ()+import           Prelude.Compat++import           Data.String+import           Test.Hspec+import           Test.Hspec.Core.QuickCheck (modifyMaxSize)+import           Test.QuickCheck++import           Test.DocTest.Internal.Parse+import           Test.DocTest.Internal.Runner.Example++main :: IO ()+main = hspec spec++data Line = PlainLine String | WildCardLines [String]+  deriving (Show, Eq)++instance Arbitrary Line where+    arbitrary = frequency [ (2, PlainLine <$> arbitrary)+                          , (1, WildCardLines . getNonEmpty <$> arbitrary)+                          ]++lineToExpected :: [Line] -> ExpectedResult+lineToExpected = map $ \x -> case x of+                                 PlainLine str -> fromString str+                                 WildCardLines _ -> WildCardLine++lineToActual :: [Line] -> [String]+lineToActual = concatMap $ \x -> case x of+                               PlainLine str -> [str]+                               WildCardLines xs -> xs++spec :: Spec+spec = do+  describe "mkResult" $ do+    it "returns Equal when output matches" $ do+      property $ \xs -> do+        mkResult (map fromString xs) xs `shouldBe` Equal++    it "ignores trailing whitespace" $ do+      mkResult ["foo\t"] ["foo  "] `shouldBe` Equal++    context "with WildCardLine" $ do+      it "matches zero lines" $ do+        mkResult ["foo", WildCardLine, "bar"] ["foo", "bar"]+            `shouldBe` Equal++      it "matches first zero line" $ do+        mkResult [WildCardLine, "foo", "bar"] ["foo", "bar"]+            `shouldBe` Equal++      it "matches final zero line" $ do+        mkResult ["foo", "bar", WildCardLine] ["foo", "bar"]+            `shouldBe` Equal++      it "matches an arbitrary number of lines" $ do+        mkResult ["foo", WildCardLine, "bar"] ["foo", "baz", "bazoom", "bar"]+            `shouldBe` Equal++      -- See https://github.com/sol/doctest/issues/259+      modifyMaxSize (const 8) $+        it "matches an arbitrary number of lines (quickcheck)" $ do+          property $ \xs -> mkResult (lineToExpected xs) (lineToActual xs)+              `shouldBe` Equal++    context "with WildCardChunk" $ do+      it "matches an arbitrary line chunk" $ do+        mkResult [ExpectedLine ["foo", WildCardChunk, "bar"]] ["foo baz bar"]+            `shouldBe` Equal++      it "matches an arbitrary line chunk at end" $ do+        mkResult [ExpectedLine ["foo", WildCardChunk]] ["foo baz bar"]+            `shouldBe` Equal++      it "does not match at end" $ do+        mkResult [ExpectedLine [WildCardChunk, "baz"]] ["foo baz bar"]+            `shouldBe` NotEqual [+                 "expected: ...baz"+               , " but got: foo baz bar"+               , "                 ^"+               ]++      it "does not match at start" $ do+        mkResult [ExpectedLine ["fuu", WildCardChunk]] ["foo baz bar"]+            `shouldBe` NotEqual [+                 "expected: fuu..."+               , " but got: foo baz bar"+               , "           ^"+               ]++    context "when output does not match" $ do+      it "constructs failure message" $ do+        mkResult ["foo"] ["bar"] `shouldBe` NotEqual [+            "expected: foo"+          , " but got: bar"+          , "          ^"+          ]++      it "constructs failure message for multi-line output" $ do+        mkResult ["foo", "bar"] ["foo", "baz"] `shouldBe` NotEqual [+            "expected: foo"+          , "          bar"+          , " but got: foo"+          , "          baz"+          , "            ^"+          ]++      context "when any output line contains \"unsafe\" characters" $ do+        it "uses show to format output lines" $ do+          mkResult ["foo\160bar"] ["foo bar"] `shouldBe` NotEqual [+              "expected: foo\\160bar"+            , " but got: foo bar"+            , "             ^"+            ]++      it "insert caret after last matching character on different lengths" $ do+        mkResult ["foo"] ["fo"] `shouldBe` NotEqual [+            "expected: foo"+          , " but got: fo"+          , "            ^"+          ]++      it "insert caret after mismatching line for multi-line output" $ do+        mkResult ["foo", "bar", "bat"] ["foo", "baz", "bax"] `shouldBe` NotEqual [+            "expected: foo"+          , "          bar"+          , "          bat"+          , " but got: foo"+          , "          baz"+          , "            ^"+          , "          bax"+          ]++      it "insert caret after mismatching line with the longest match for multi-line wildcard pattern" $ do+        mkResult ["foo", WildCardLine, "bar", "bat"] ["foo", "xxx", "yyy", "baz", "bxx"] `shouldBe` NotEqual [+            "expected: foo"+          , "          ..."+          , "          bar"+          , "          bat"+          , " but got: foo"+          , "          xxx"+          , "          yyy"+          , "          baz"+          , "            ^"+          , "          bxx"+          ]++      it "insert caret after longest match for wildcard" $ do+        mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo xxx yyy baz bxx"] `shouldBe` NotEqual [+            "expected: foo ... bar bat"+          , " but got: foo xxx yyy baz bxx"+          , "                        ^"+          ]++      it "show expanded pattern for long matches" $ do+        mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo 123456789 123456789 xxx yyy baz bxx"] `shouldBe` NotEqual [+            "expected: foo ... bar bat"+          , " but got: foo 123456789 123456789 xxx yyy baz bxx"+          , "          foo ........................... ba^"+          ]
+ test/RunnerSpec.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+module RunnerSpec (main, spec) where++import           Test.Hspec++import           System.IO+import           System.IO.Silently (hCapture)+import           Control.Monad.Trans.State+import           Test.DocTest.Internal.Runner++main :: IO ()+main = hspec spec++capture :: Report a -> IO String+capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 True False mempty)++-- like capture, but with interactivity set to False+capture_ :: Report a -> IO String+capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 False False mempty)++spec :: Spec+spec = do++  describe "report" $ do++    context "when mode is interactive" $ do++      it "writes to stderr" $ do+        capture $ do+          report "foobar"+        `shouldReturn` "foobar\n"++      it "overwrites any intermediate output" $ do+        capture $ do+          report_ "foo"+          report  "bar"+        `shouldReturn` "foo\rbar\n"++      it "blank out intermediate output if necessary" $ do+        capture $ do+          report_ "foobar"+          report  "baz"+        `shouldReturn` "foobar\rbaz   \n"++    context "when mode is non-interactive" $ do+      it "writes to stderr" $ do+        capture_ $ do+          report "foobar"+        `shouldReturn` "foobar\n"++  describe "report_" $ do++    context "when mode is interactive" $ do+      it "writes intermediate output to stderr" $ do+        capture $ do+          report_ "foobar"+        `shouldReturn` "foobar"++      it "overwrites any intermediate output" $ do+        capture $ do+          report_ "foo"+          report_ "bar"+        `shouldReturn` "foo\rbar"++      it "blank out intermediate output if necessary" $ do+        capture $ do+          report_ "foobar"+          report_  "baz"+        `shouldReturn` "foobar\rbaz   "++    context "when mode is non-interactive" $ do+      it "is ignored" $ do+        capture_ $ do+          report_ "foobar"+        `shouldReturn` ""++      it "does not influence a subsequent call to `report`" $ do+        capture_ $ do+          report_ "foo"+          report  "bar"+        `shouldReturn` "bar\n"++      it "does not require `report` to blank out any intermediate output" $ do+        capture_ $ do+          report_ "foobar"+          report  "baz"+        `shouldReturn` "baz\n"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/UtilSpec.hs view
@@ -0,0 +1,21 @@+module UtilSpec (main, spec) where++import           Test.Hspec++import           Test.DocTest.Internal.Util++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "convertDosLineEndings" $ do+    it "converts CRLF to LF" $ do+      convertDosLineEndings "foo\r\nbar\r\nbaz" `shouldBe` "foo\nbar\nbaz"++    it "strips a trailing CR" $ do+      convertDosLineEndings "foo\r" `shouldBe` "foo"++  describe "takeWhileEnd" $ do+    it "returns the longest suffix of elements that satisfy a given predicate" $ do+      takeWhileEnd (/= ' ') "foo bar" `shouldBe` "bar"
+ test/doctests.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.DocTest (mainFromCabal)+import System.Environment (getArgs)++main :: IO ()+main = mainFromCabal "doctest-parallel" =<< getArgs
+ test/integration/BugfixImportHierarchical/ModuleA.hs view
@@ -0,0 +1,7 @@+-- |+-- >>> import BugfixImportHierarchical.ModuleB+-- >>> fib 10+-- 55+module BugfixImportHierarchical.ModuleA where++import BugfixImportHierarchical.ModuleB ()
+ test/integration/BugfixImportHierarchical/ModuleB.hs view
@@ -0,0 +1,12 @@+module BugfixImportHierarchical.ModuleB (fib) where+++-- |+-- >>> fib 10+-- 55+-- >>> fib 5+-- 5+fib :: Integer -> Integer+fib 0 = 0+fib 1 = 1+fib n = fib (n - 1) + fib (n - 2)
+ test/integration/BugfixMultipleModules/ModuleA.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}++-- | The test below should fail, as ModuleB does not export it:+--+-- >>> import BugfixMultipleModules.ModuleB+-- >>> fib 10+-- 55+module BugfixMultipleModules.ModuleA where
+ test/integration/BugfixMultipleModules/ModuleB.hs view
@@ -0,0 +1,22 @@+module BugfixMultipleModules.ModuleB (fib) where+++-- |+-- >>> fib 10+-- 55+-- >>> fib 5+-- 5+fib :: Integer -> Integer+fib = foo++-- This test should fail, as foo is not exported:++-- |+-- >>> foo 10+-- 55+-- >>> foo 5+-- 5+foo :: Integer -> Integer+foo 0 = 0+foo 1 = 1+foo n = foo (n - 1) + foo (n - 2)
+ test/integration/BugfixOutputToStdErr/Fib.hs view
@@ -0,0 +1,9 @@+module BugfixOutputToStdErr.Fib where++-- | Calculate Fibonacci number of given 'Num'.+--+-- >>> import System.IO+-- >>> hPutStrLn stderr "foobar"+-- foobar+fib :: (Num t, Num t1) => t -> t1+fib _ = undefined
+ test/integration/Color/Foo.hs view
@@ -0,0 +1,8 @@+module Color.Foo where++import Data.Maybe++-- | Convert a map into list array.+-- prop> tabulate m !! fromEnum d == fromMaybe 0 (lookup d m)+tabulate :: [(Bool, Double)] -> [Double]+tabulate m = [fromMaybe 0 $ lookup False m, fromMaybe 0 $ lookup True m]
+ test/integration/DosLineEndings/Fib.hs view
@@ -0,0 +1,10 @@+module DosLineEndings.Fib where
+
+-- | Calculate Fibonacci numbers.
+--
+-- >>> fib 10
+-- 55
+fib :: Integer -> Integer
+fib 0 = 0
+fib 1 = 1
+fib n = fib (n - 1) + fib (n - 2)
+ test/integration/Failing/Foo.hs view
@@ -0,0 +1,8 @@+module Failing.Foo where++-- | A failing example+--+-- >>> 23+-- 42+test :: a+test = undefined
+ test/integration/FailingMultiple/Foo.hs view
@@ -0,0 +1,16 @@+module FailingMultiple.Foo where++-- | A failing example+--+-- >>> 23+-- 23+--+-- >>> 23+-- 42+--+-- >>> 23+-- 23+-- >>> 23+-- 23+test :: a+test = undefined
+ test/integration/It/Foo.hs view
@@ -0,0 +1,20 @@+module It.Foo where++-- |+--+-- >>> :t 'a'+-- 'a' :: Char+--+-- >>> "foo"+-- "foo"+--+-- >>> length it+-- 3+--+-- >>> it * it+-- 9+--+-- >>> :t it+-- it :: Int+--+foo = undefined
+ test/integration/It/Setup.hs view
@@ -0,0 +1,23 @@+module It.Setup where++-- $setup+-- >>> :t 'a'+-- 'a' :: Char+--+-- >>> 42 :: Int+-- 42+--+-- >>> it+-- 42++-- |+--+-- >>> it * it+-- 1764+foo = undefined++-- |+--+-- >>> it * it+-- 1764+bar = undefined
+ test/integration/LocalStderrBinding/A.hs view
@@ -0,0 +1,11 @@+module LocalStderrBinding.A where++stderr :: Bool+stderr = True++stdout :: String+stdout = "hello"++-- |+-- >>> 3 + 3+-- 6
+ test/integration/ModuleIsolation/TestA.hs view
@@ -0,0 +1,14 @@+module ModuleIsolation.TestA (foo) where++import ModuleIsolation.TestB ()++{- $setup+>>> :set -XTypeApplications+-}++-- | Example usage:+--+-- >>> foo @Int+-- 3+foo :: Num a => a+foo = 3
+ test/integration/ModuleIsolation/TestB.hs view
@@ -0,0 +1,8 @@+module ModuleIsolation.TestB (bar) where++-- | Example usage:+--+-- >>> bar @Int+-- 3+bar :: Num a => a+bar = 3
+ test/integration/Multiline/Multiline.hs view
@@ -0,0 +1,61 @@+module Multiline.Multiline where+++{- |++>>> :{+    let+     x = 1+     y = z+   in x + y+  :}+  3++-}+z = 2++{- |++Aligns with the closing++>>> :{+    let+     x = 1+     y = z+   in x + y+     :}+     3+-}+z2 = 2+++{- | Also works let that's for do:++>>> :{+let+     x = 1+     y = z+:}++>>> y+2++-}+z3 = 2++++{- | Handles repeated @>>>@ too, which is bad since haddock-2.13.2 currently+will strip the leading whitespace leading to something that will not copy-paste+(unless it uses explicit { ; } and the users manually strip the @>>>@)++>>> :{+>>> let+>>>      x = 1+>>>      y = z+>>> in x + y+>>> :}+3++-}+z4 = 4
+ test/integration/PropertyBool/Foo.hs view
@@ -0,0 +1,5 @@+module PropertyBool.Foo where++-- |+-- prop> True+foo = undefined
+ test/integration/PropertyBoolWithTypeSignature/Foo.hs view
@@ -0,0 +1,5 @@+module PropertyBoolWithTypeSignature.Foo where++-- |+-- prop> True :: Bool+foo = undefined
+ test/integration/PropertyFailing/Foo.hs view
@@ -0,0 +1,5 @@+module PropertyFailing.Foo where++-- |+-- prop> abs x == x+foo = undefined
+ test/integration/PropertyImplicitlyQuantified/Foo.hs view
@@ -0,0 +1,5 @@+module PropertyImplicitlyQuantified.Foo where++-- |+-- prop> abs x == abs (abs x)+foo = undefined
+ test/integration/PropertyQuantified/Foo.hs view
@@ -0,0 +1,5 @@+module PropertyQuantified.Foo where++-- |+-- prop> \x -> abs x == abs (abs x)+foo = undefined
+ test/integration/PropertySetup/Foo.hs view
@@ -0,0 +1,9 @@+module PropertySetup.Foo where++-- $setup+-- >>> import Test.QuickCheck+-- >>> let arbitraryEven = (* 2) `fmap` arbitrary++-- |+-- prop> forAll arbitraryEven even+foo = undefined
+ test/integration/Setup/Foo.hs view
@@ -0,0 +1,10 @@+module Setup.Foo where++-- $setup+-- >>> let x = 23 :: Int++-- |+-- >>> x + foo+-- 65+foo :: Int+foo = 42
+ test/integration/SetupSkipOnFailure/Foo.hs view
@@ -0,0 +1,17 @@+module SetupSkipOnFailure.Foo where++-- $setup+-- >>> x+-- 23++-- |+-- >>> foo+-- 42+foo :: Int+foo = 42++-- |+-- >>> y+-- 42+bar :: Int+bar = 42
+ test/integration/SystemIoImported/A.hs view
@@ -0,0 +1,10 @@+module SystemIoImported.A where++import System.IO++-- ghci-wrapper needs to poke around with System.IO itself, and unloads the module once it's done. Test to make sure legitimate uses of System.IO don't get lost in the wash.++-- |+-- >>> import System.IO+-- >>> ReadMode+-- ReadMode
+ test/integration/TemplateHaskell/Foo.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module TemplateHaskell.Foo where++import Language.Haskell.TH+import Text.Printf++-- | Report an error.+--+-- >>> :set -XTemplateHaskell+-- >>> $(logError "Something bad happened!")+-- ERROR <interactive>: Something bad happened!+logError :: String -> Q Exp+logError msg = do+  loc <- location+  let s = (printf "ERROR %s: %s" (loc_filename loc) msg) :: String+  [| putStrLn s |]
+ test/integration/TestBlankline/Fib.hs view
@@ -0,0 +1,10 @@+module TestBlankline.Fib where++-- | Calculate Fibonacci number of given 'Num'.+--+-- >>> putStrLn "foo\n\nbar"+-- foo+-- <BLANKLINE>+-- bar+fib :: (Num t, Num t1) => t -> t1+fib _ = undefined
+ test/integration/TestCombinedExample/Fib.hs view
@@ -0,0 +1,20 @@+module TestCombinedExample.Fib where++-- | Calculate Fibonacci number of given 'Num'.+--+-- First let's set `n` to ten:+--+-- >>> let n = 10+--+-- And now calculate the 10th Fibonacci number:+--+-- >>> fib n+-- 55+--+-- >>> let x = 10+-- >>> x+-- 10+fib :: Integer -> Integer+fib 0 = 0+fib 1 = 1+fib n = fib (n - 1) + fib (n - 2)
+ test/integration/TestCommentLocation/Foo.hs view
@@ -0,0 +1,81 @@+-- |+-- Examples in various locations...+--+-- Some random text.  Some random text.  Some random text.  Some random text.+-- Some random text.  Some random text.  Some random text.  Some random text.+-- Some random text.+--+-- >>> let x = 10+--+-- Some random text.  Some random text.  Some random text.  Some random text.+-- Some random text.  Some random text.  Some random text.  Some random text.+-- Some random text.+--+--+--   >>> baz+--   "foobar"++module TestCommentLocation.Foo (+  -- | Some documentation not attached to a particular Haskell entity+  --+  -- >>> test 10+  -- *** Exception: Prelude.undefined+  -- ...+  test,++  -- |+  -- >>> fib 10+  -- 55+  fib,++  -- |+  -- >>> bar+  -- "bar"+  bar,++  foo, baz+  ) where+++-- | My test+--+-- >>> test 20+-- *** Exception: Prelude.undefined+-- ...+test :: Integer -> Integer+test = undefined++-- | Note that examples for 'fib' include the two examples below+-- and the one example with ^ syntax after 'fix'+--+-- >>> foo+-- "foo"++{- |+    Example:++     >>> fib 10+     55+-}++-- | Calculate Fibonacci number of given `n`.+fib :: Integer  -- ^ given `n`+                --+                -- >>> fib 10+                -- 55++    -> Integer  -- ^ Fibonacci of given `n`+                --+                -- >>> baz+                -- "foobar"+fib 0 = 0+fib 1 = 1+fib n = fib (n - 1) + fib (n - 2)+-- ^ Example:+--+--   >>> fib 5+--   5++foo = "foo"+bar = "bar"+baz = foo ++ bar
+ test/integration/TestDocumentationForArguments/Fib.hs view
@@ -0,0 +1,7 @@+module TestDocumentationForArguments.Fib where++fib :: Int -- ^+           -- >>> 23+           -- 23+    -> Int+fib _ = undefined
+ test/integration/TestFailOnMultiline/Fib.hs view
@@ -0,0 +1,13 @@+module TestFailOnMultiline.Fib where++-- | The following interaction cause `doctest' to fail with an error:+--+-- >>> :{+foo :: Int+foo = 23++-- | The following interaction cause `doctest' to fail with an error:+--+-- >>>       :{+bar :: Int+bar = 23
+ test/integration/TestImport/ModuleA.hs view
@@ -0,0 +1,6 @@+-- |+-- >>> import TestImport.ModuleB+-- >>> fib 10+-- 55+module TestImport.ModuleA where+
+ test/integration/TestImport/ModuleB.hs view
@@ -0,0 +1,12 @@+module TestImport.ModuleB (fib) where+++-- |+-- >>> fib 10+-- 55+-- >>> fib 5+-- 5+fib :: Integer -> Integer+fib 0 = 0+fib 1 = 1+fib n = fib (n - 1) + fib (n - 2)
+ test/integration/TestPutStr/Fib.hs view
@@ -0,0 +1,13 @@+module TestPutStr.Fib where++-- | Calculate Fibonacci number of given 'Num'.+--+-- >>> putStrLn "foo"+-- foo+-- >>> putStr "bar"+-- bar+--+-- >>> putStrLn "baz"+-- baz+fib :: (Num t, Num t1) => t -> t1+fib _ = undefined
+ test/integration/TestSimple/Fib.hs view
@@ -0,0 +1,10 @@+module TestSimple.Fib where++-- | Calculate Fibonacci numbers.+--+-- >>> fib 10+-- 55+fib :: Integer -> Integer+fib 0 = 0+fib 1 = 1+fib n = fib (n - 1) + fib (n - 2)
+ test/integration/TrailingWhitespace/Foo.hs view
@@ -0,0 +1,8 @@+module TrailingWhitespace.Foo where++-- | A failing example+--+-- >>> putStrLn "foo   "+-- foo+test :: a+test = undefined
+ test/integration/WithCbits/Bar.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module WithCbits.Bar where++import Foreign.C++-- |+-- >>> foo+-- 23+foreign import ccall foo :: CInt
+ test/integration/WithCbits/foo.c view
@@ -0,0 +1,3 @@+int foo() {+  return 23;+}