diff --git a/CHANGES.markdown b/CHANGES.markdown new file mode 100644 --- /dev/null +++ b/CHANGES.markdown @@ -0,0 +1,3 @@ +Changes in 0.1 + - First release! + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2009-2018 Simon Hengel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -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 ``. 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?" +-- +-- "Every one of whom do you think?" +-- +-- "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 +:39:3: + Not in scope: ‘polyQuickCheck’ + In the splice: $(polyQuickCheck (mkName "doctest_prop")) + +: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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/doctest-parallel.cabal b/doctest-parallel.cabal new file mode 100644 --- /dev/null +++ b/doctest-parallel.cabal @@ -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 (). + . + Documentation is at . +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 +maintainer: Martijn Bastiaan +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 diff --git a/example/example.cabal b/example/example.cabal new file mode 100644 --- /dev/null +++ b/example/example.cabal @@ -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 diff --git a/example/src/Example.hs b/example/src/Example.hs new file mode 100644 --- /dev/null +++ b/example/src/Example.hs @@ -0,0 +1,11 @@ +module Example (foo, bar) where + +-- | +-- >>> foo +-- 23 +foo = 23 + +-- | +-- >>> bar +-- 42 +bar = 42 diff --git a/example/test/doctests.hs b/example/test/doctests.hs new file mode 100644 --- /dev/null +++ b/example/test/doctests.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.DocTest (mainFromCabal) +import System.Environment (getArgs) + +main :: IO () +main = mainFromCabal "example" =<< getArgs diff --git a/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs b/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs new file mode 100644 --- /dev/null +++ b/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs @@ -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 diff --git a/src/Test/DocTest.hs b/src/Test/DocTest.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest.hs @@ -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 diff --git a/src/Test/DocTest/Helpers.hs b/src/Test/DocTest/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Helpers.hs @@ -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 diff --git a/src/Test/DocTest/Internal/Extract.hs b/src/Test/DocTest/Internal/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Extract.hs @@ -0,0 +1,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 diff --git a/src/Test/DocTest/Internal/GhcUtil.hs b/src/Test/DocTest/Internal/GhcUtil.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/GhcUtil.hs @@ -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 + } diff --git a/src/Test/DocTest/Internal/Interpreter.hs b/src/Test/DocTest/Internal/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Interpreter.hs @@ -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 diff --git a/src/Test/DocTest/Internal/Location.hs b/src/Test/DocTest/Internal/Location.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Location.hs @@ -0,0 +1,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 "") + +-- | 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 diff --git a/src/Test/DocTest/Internal/Options.hs b/src/Test/DocTest/Internal/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Options.hs @@ -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) diff --git a/src/Test/DocTest/Internal/Parse.hs b/src/Test/DocTest/Internal/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Parse.hs @@ -0,0 +1,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 + "" -> "" + "..." -> 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 diff --git a/src/Test/DocTest/Internal/Property.hs b/src/Test/DocTest/Internal/Property.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Property.hs @@ -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 diff --git a/src/Test/DocTest/Internal/Runner.hs b/src/Test/DocTest/Internal/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Runner.hs @@ -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 diff --git a/src/Test/DocTest/Internal/Runner/Example.hs b/src/Test/DocTest/Internal/Runner/Example.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Runner/Example.hs @@ -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 diff --git a/src/Test/DocTest/Internal/Util.hs b/src/Test/DocTest/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Util.hs @@ -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 diff --git a/test/ExtractSpec.hs b/test/ExtractSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExtractSpec.hs @@ -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 []] diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs new file mode 100644 --- /dev/null +++ b/test/InterpreterSpec.hs @@ -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" diff --git a/test/LocationSpec.hs b/test/LocationSpec.hs new file mode 100644 --- /dev/null +++ b/test/LocationSpec.hs @@ -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 "" + + it "works for a SrcLoc with bad locations" $ do + toLocation (mkSrcSpan noSrcLoc noSrcLoc) + `shouldBe` UnhelpfulLocation "" + + 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] diff --git a/test/MainSpec.hs b/test/MainSpec.hs new file mode 100644 --- /dev/null +++ b/test/MainSpec.hs @@ -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) diff --git a/test/OptionsSpec.hs b/test/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/OptionsSpec.hs @@ -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 diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParseSpec.hs @@ -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 + ] diff --git a/test/PropertySpec.hs b/test/PropertySpec.hs new file mode 100644 --- /dev/null +++ b/test/PropertySpec.hs @@ -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 + ":4:1: Not in scope: `x'" + `shouldBe` ["x"] + + it "ignores duplicates" $ do + parseNotInScope . build $ do + ":4:1: Not in scope: `x'" + "" + ":4:6: Not in scope: `x'" + `shouldBe` ["x"] + + it "works for variable names that contain a prime" $ do + parseNotInScope . build $ do + ":2:1: Not in scope: x'" + "" + ":2:7: Not in scope: y'" + `shouldBe` ["x'", "y'"] + + it "works for error messages with suggestions" $ do + parseNotInScope . build $ do + ":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 + ":1:1: error: Variable not in scope: x" + `shouldBe` ["x"] + + it "ignores duplicates" $ do + parseNotInScope . build $ do + ":1:1: error: Variable not in scope: x :: ()" + "" + ":1:6: error: Variable not in scope: x :: ()" + `shouldBe` ["x"] + + it "works for variable names that contain a prime" $ do + parseNotInScope . build $ do + ":1:1: error: Variable not in scope: x' :: ()" + "" + ":1:7: error: Variable not in scope: y'' :: ()" + `shouldBe` ["x'", "y''"] + + it "works for error messages with suggestions" $ do + parseNotInScope . build $ do + ":1:1: error:" + " • Variable not in scope: length_" + " • Perhaps you meant ‘length’ (imported from Prelude)" + `shouldBe` ["length_"] diff --git a/test/RunSpec.hs b/test/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/RunSpec.hs @@ -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" + -- ] diff --git a/test/Runner/ExampleSpec.hs b/test/Runner/ExampleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Runner/ExampleSpec.hs @@ -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^" + ] diff --git a/test/RunnerSpec.hs b/test/RunnerSpec.hs new file mode 100644 --- /dev/null +++ b/test/RunnerSpec.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilSpec.hs @@ -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" diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.DocTest (mainFromCabal) +import System.Environment (getArgs) + +main :: IO () +main = mainFromCabal "doctest-parallel" =<< getArgs diff --git a/test/integration/BugfixImportHierarchical/ModuleA.hs b/test/integration/BugfixImportHierarchical/ModuleA.hs new file mode 100644 --- /dev/null +++ b/test/integration/BugfixImportHierarchical/ModuleA.hs @@ -0,0 +1,7 @@ +-- | +-- >>> import BugfixImportHierarchical.ModuleB +-- >>> fib 10 +-- 55 +module BugfixImportHierarchical.ModuleA where + +import BugfixImportHierarchical.ModuleB () diff --git a/test/integration/BugfixImportHierarchical/ModuleB.hs b/test/integration/BugfixImportHierarchical/ModuleB.hs new file mode 100644 --- /dev/null +++ b/test/integration/BugfixImportHierarchical/ModuleB.hs @@ -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) diff --git a/test/integration/BugfixMultipleModules/ModuleA.hs b/test/integration/BugfixMultipleModules/ModuleA.hs new file mode 100644 --- /dev/null +++ b/test/integration/BugfixMultipleModules/ModuleA.hs @@ -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 diff --git a/test/integration/BugfixMultipleModules/ModuleB.hs b/test/integration/BugfixMultipleModules/ModuleB.hs new file mode 100644 --- /dev/null +++ b/test/integration/BugfixMultipleModules/ModuleB.hs @@ -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) diff --git a/test/integration/BugfixOutputToStdErr/Fib.hs b/test/integration/BugfixOutputToStdErr/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/BugfixOutputToStdErr/Fib.hs @@ -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 diff --git a/test/integration/Color/Foo.hs b/test/integration/Color/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/Color/Foo.hs @@ -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] diff --git a/test/integration/DosLineEndings/Fib.hs b/test/integration/DosLineEndings/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/DosLineEndings/Fib.hs @@ -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) diff --git a/test/integration/Failing/Foo.hs b/test/integration/Failing/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/Failing/Foo.hs @@ -0,0 +1,8 @@ +module Failing.Foo where + +-- | A failing example +-- +-- >>> 23 +-- 42 +test :: a +test = undefined diff --git a/test/integration/FailingMultiple/Foo.hs b/test/integration/FailingMultiple/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/FailingMultiple/Foo.hs @@ -0,0 +1,16 @@ +module FailingMultiple.Foo where + +-- | A failing example +-- +-- >>> 23 +-- 23 +-- +-- >>> 23 +-- 42 +-- +-- >>> 23 +-- 23 +-- >>> 23 +-- 23 +test :: a +test = undefined diff --git a/test/integration/It/Foo.hs b/test/integration/It/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/It/Foo.hs @@ -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 diff --git a/test/integration/It/Setup.hs b/test/integration/It/Setup.hs new file mode 100644 --- /dev/null +++ b/test/integration/It/Setup.hs @@ -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 diff --git a/test/integration/LocalStderrBinding/A.hs b/test/integration/LocalStderrBinding/A.hs new file mode 100644 --- /dev/null +++ b/test/integration/LocalStderrBinding/A.hs @@ -0,0 +1,11 @@ +module LocalStderrBinding.A where + +stderr :: Bool +stderr = True + +stdout :: String +stdout = "hello" + +-- | +-- >>> 3 + 3 +-- 6 diff --git a/test/integration/ModuleIsolation/TestA.hs b/test/integration/ModuleIsolation/TestA.hs new file mode 100644 --- /dev/null +++ b/test/integration/ModuleIsolation/TestA.hs @@ -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 diff --git a/test/integration/ModuleIsolation/TestB.hs b/test/integration/ModuleIsolation/TestB.hs new file mode 100644 --- /dev/null +++ b/test/integration/ModuleIsolation/TestB.hs @@ -0,0 +1,8 @@ +module ModuleIsolation.TestB (bar) where + +-- | Example usage: +-- +-- >>> bar @Int +-- 3 +bar :: Num a => a +bar = 3 diff --git a/test/integration/Multiline/Multiline.hs b/test/integration/Multiline/Multiline.hs new file mode 100644 --- /dev/null +++ b/test/integration/Multiline/Multiline.hs @@ -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 diff --git a/test/integration/PropertyBool/Foo.hs b/test/integration/PropertyBool/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/PropertyBool/Foo.hs @@ -0,0 +1,5 @@ +module PropertyBool.Foo where + +-- | +-- prop> True +foo = undefined diff --git a/test/integration/PropertyBoolWithTypeSignature/Foo.hs b/test/integration/PropertyBoolWithTypeSignature/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/PropertyBoolWithTypeSignature/Foo.hs @@ -0,0 +1,5 @@ +module PropertyBoolWithTypeSignature.Foo where + +-- | +-- prop> True :: Bool +foo = undefined diff --git a/test/integration/PropertyFailing/Foo.hs b/test/integration/PropertyFailing/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/PropertyFailing/Foo.hs @@ -0,0 +1,5 @@ +module PropertyFailing.Foo where + +-- | +-- prop> abs x == x +foo = undefined diff --git a/test/integration/PropertyImplicitlyQuantified/Foo.hs b/test/integration/PropertyImplicitlyQuantified/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/PropertyImplicitlyQuantified/Foo.hs @@ -0,0 +1,5 @@ +module PropertyImplicitlyQuantified.Foo where + +-- | +-- prop> abs x == abs (abs x) +foo = undefined diff --git a/test/integration/PropertyQuantified/Foo.hs b/test/integration/PropertyQuantified/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/PropertyQuantified/Foo.hs @@ -0,0 +1,5 @@ +module PropertyQuantified.Foo where + +-- | +-- prop> \x -> abs x == abs (abs x) +foo = undefined diff --git a/test/integration/PropertySetup/Foo.hs b/test/integration/PropertySetup/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/PropertySetup/Foo.hs @@ -0,0 +1,9 @@ +module PropertySetup.Foo where + +-- $setup +-- >>> import Test.QuickCheck +-- >>> let arbitraryEven = (* 2) `fmap` arbitrary + +-- | +-- prop> forAll arbitraryEven even +foo = undefined diff --git a/test/integration/Setup/Foo.hs b/test/integration/Setup/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/Setup/Foo.hs @@ -0,0 +1,10 @@ +module Setup.Foo where + +-- $setup +-- >>> let x = 23 :: Int + +-- | +-- >>> x + foo +-- 65 +foo :: Int +foo = 42 diff --git a/test/integration/SetupSkipOnFailure/Foo.hs b/test/integration/SetupSkipOnFailure/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/SetupSkipOnFailure/Foo.hs @@ -0,0 +1,17 @@ +module SetupSkipOnFailure.Foo where + +-- $setup +-- >>> x +-- 23 + +-- | +-- >>> foo +-- 42 +foo :: Int +foo = 42 + +-- | +-- >>> y +-- 42 +bar :: Int +bar = 42 diff --git a/test/integration/SystemIoImported/A.hs b/test/integration/SystemIoImported/A.hs new file mode 100644 --- /dev/null +++ b/test/integration/SystemIoImported/A.hs @@ -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 diff --git a/test/integration/TemplateHaskell/Foo.hs b/test/integration/TemplateHaskell/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/TemplateHaskell/Foo.hs @@ -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 : 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 |] diff --git a/test/integration/TestBlankline/Fib.hs b/test/integration/TestBlankline/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestBlankline/Fib.hs @@ -0,0 +1,10 @@ +module TestBlankline.Fib where + +-- | Calculate Fibonacci number of given 'Num'. +-- +-- >>> putStrLn "foo\n\nbar" +-- foo +-- +-- bar +fib :: (Num t, Num t1) => t -> t1 +fib _ = undefined diff --git a/test/integration/TestCombinedExample/Fib.hs b/test/integration/TestCombinedExample/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestCombinedExample/Fib.hs @@ -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) diff --git a/test/integration/TestCommentLocation/Foo.hs b/test/integration/TestCommentLocation/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestCommentLocation/Foo.hs @@ -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 diff --git a/test/integration/TestDocumentationForArguments/Fib.hs b/test/integration/TestDocumentationForArguments/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestDocumentationForArguments/Fib.hs @@ -0,0 +1,7 @@ +module TestDocumentationForArguments.Fib where + +fib :: Int -- ^ + -- >>> 23 + -- 23 + -> Int +fib _ = undefined diff --git a/test/integration/TestFailOnMultiline/Fib.hs b/test/integration/TestFailOnMultiline/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestFailOnMultiline/Fib.hs @@ -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 diff --git a/test/integration/TestImport/ModuleA.hs b/test/integration/TestImport/ModuleA.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestImport/ModuleA.hs @@ -0,0 +1,6 @@ +-- | +-- >>> import TestImport.ModuleB +-- >>> fib 10 +-- 55 +module TestImport.ModuleA where + diff --git a/test/integration/TestImport/ModuleB.hs b/test/integration/TestImport/ModuleB.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestImport/ModuleB.hs @@ -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) diff --git a/test/integration/TestPutStr/Fib.hs b/test/integration/TestPutStr/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestPutStr/Fib.hs @@ -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 diff --git a/test/integration/TestSimple/Fib.hs b/test/integration/TestSimple/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/TestSimple/Fib.hs @@ -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) diff --git a/test/integration/TrailingWhitespace/Foo.hs b/test/integration/TrailingWhitespace/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/TrailingWhitespace/Foo.hs @@ -0,0 +1,8 @@ +module TrailingWhitespace.Foo where + +-- | A failing example +-- +-- >>> putStrLn "foo " +-- foo +test :: a +test = undefined diff --git a/test/integration/WithCbits/Bar.hs b/test/integration/WithCbits/Bar.hs new file mode 100644 --- /dev/null +++ b/test/integration/WithCbits/Bar.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module WithCbits.Bar where + +import Foreign.C + +-- | +-- >>> foo +-- 23 +foreign import ccall foo :: CInt diff --git a/test/integration/WithCbits/foo.c b/test/integration/WithCbits/foo.c new file mode 100644 --- /dev/null +++ b/test/integration/WithCbits/foo.c @@ -0,0 +1,3 @@ +int foo() { + return 23; +}