diff --git a/CHANGES.markdown b/CHANGES.markdown new file mode 100644 --- /dev/null +++ b/CHANGES.markdown @@ -0,0 +1,224 @@ +Changes in 0.25.0 + - Full GHC 9.14 compatibility / `-unit`-support + +Changes in 0.24.3 + - Allow building with GHC 9.14 (#478) + +Changes in 0.24.2 + - Use `GHC.ResponseFile.expandResponse` + +Changes in 0.24.1 + - Interpret GHC response files + +Changes in 0.24.0 + - cabal-doctest: Add support for cabal-install 3.14.* + +Changes in 0.23.0 + - Add `--fail-fast` + +Changes in 0.22.10 + - Make progress reporting more robust + +Changes in 0.22.9 + - Use `-fprint-error-index-links=never` for GHC `>=9.10` + +Changes in 0.22.8 + - cabal-doctest: Fix handling of options with optional arguments + +Changes in 0.22.7 + - cabal-doctest: Accept component + - cabal-doctest: Get rid of separate `cabal build` step + - cabal-doctest: Add support for `--list-options` + +Changes in 0.22.6 + - cabal-doctest: Take `with-compiler:` from `cabal-project` into account + - cabal-doctest: Add support for `--with-compiler` + - cabal-doctest: Fix `ghc-pkg` discovery logic + - cabal-doctest: Cache `doctest` executables + +Changes in 0.22.5 + - Add (experimental) `cabal-doctest` executable. This is guarded behind a + flag for now, use `cabal install doctest -f cabal-doctest` to install it. + +Changes in 0.22.4 + - Use `-Wno-unused-packages` for GHC `8.10` / `9.0` / `9.2` + +Changes in 0.22.3 + - Use `-Wno-unused-packages` when extracting comments + +Changes in 0.22.2 + - GHC 9.8 compatibility + +Changes in 0.22.1 + - Add `Test.DocTest.Internal.Run.doctestWithRepl` + +Changes in 0.22.0 + - Export more internals + +Changes in 0.21.1 + - GHC 9.6 compatibility. + +Changes in 0.21.0 + - Accept `--fast`, `--preserve-it` and `--verbose` via `--repl-options` + +Changes in 0.20.1 + - GHC 9.4 compatibility. (#382) + +Changes in 0.20.0 + - Allow doctest to be invoked via `cabal repl --with-compiler=doctest` + - Include `ghc --info` output in `--info` + - Make `--info` output formatting consistent with GHC + +Changes in 0.19.0 + - Better support for `cabal v2-*` + +Changes in 0.18.2 + - GHC 9.2 compatibility. (#305, thanks to Ryan Scott and Matthew Pickering) + +Changes in 0.18.1 + - GHC 9.0 compatibility. (#275) + +Changes in 0.18 + - Don't use unqualified references to `stderr` or `stdout` which may collide with definitions in user code. (#201) + - Remove support for cabal-install sandboxes. They have been obsoleted in practice by Nix-style builds in cabal-install (i.e., the `v2-*` commands) and stack. + +Changes in 0.17 + - #266: + - doctest now annotates its internal marker string as a `String`, to prevent misbehaviour in `OverloadedStrings` environments. This has a theoretical chance of breakage; if you're affected, please open an issue. + - `evalEcho` no longer preserves `it`. + +Changes in 0.16.3 + - Add a cursor to highlight the differing portion between the + expected and actual output. (#249) + - GHC 8.10 compatibility. (#247, #257) + +Changes in 0.16.2 + - Add doctest's necessary-for-operation options to GHC's command + line at the end, so that they over-ride anything provided by the + user. (#233) + - Allow GHC 8.8. + +Changes in 0.16.1 + - Fix loading plugins in doctests. (#224) + - Require QuickCheck 2.13.1 or newer. + - Remove dependency on `with-location` + +Changes in 0.16.0.1 + - Bump bounds to allow GHC 8.6. (#210) + +Changes in 0.16.0 + - Output format has changed to (hopefully) be more machine consumable. (#200) + +Changes in 0.15.0 + - Add `--verbose` for printing each test as it is run + +Changes in 0.14.1 + - Add test assets to source tarball (see #189) + +Changes in 0.14.0 + - GHC 8.4 compatibility. + +Changes in 0.13.0 + - Add `--preserve-it` for allowing the `it` variable to be preserved between examples + +Changes in 0.12.0 + - Preserve the 'it' variable between examples + +Changes in 0.11.4 + - Add `--fast`, which disables running `:reload` between example groups + +Changes in 0.11.3 + - Add `--info` + - Add `--no-magic` + +Changes in 0.11.2 + - Make `...` match zero lines + +Changes in 0.11.1 + - Fix an issue with Unicode output on Windows (see #149) + +Changes in 0.11.0 + - Support for GHC 8.0.1-rc2 + +Changes in 0.10.1 + - Automatically expand directories into contained Haskell source files (thanks @snoyberg) + - Add cabal_macros.h and autogen dir by default (thanks @snoyberg) + +Changes in 0.10.0 + - Support HASKELL_PACKAGE_SANDBOXES (thanks @snoyberg) + +Changes in 0.9.13 + - Add ellipsis as wildcard + +Changes in 0.9.12 + - Add support for GHC 7.10 + +Changes in 0.9.11 + - Defaults ambiguous type variables to Integer (#74) + +Changes in 0.9.10 + - Add support for the upcoming GHC 7.8 release + +Changes in 0.9.9 + - Add support for multi-line statements + +Changes in 0.9.8 + - Support for GHC HEAD (7.7) + +Changes in 0.9.7 + - Ignore trailing whitespace when matching example output + +Changes in 0.9.6 + - Fail gracefully if GHCi is not supported (#46) + +Changes in 0.9.5 + - Fix a GHC panic with GHC 7.6.1 (#41) + +Changes in 0.9.4 + - Respect HASKELL_PACKAGE_SANDBOX (#39) + - Print path to ghc on --version + +Changes in 0.9.3 + - Properly handle additional object files (#38) + +Changes in 0.9.2 + - Add support for QuickCheck properties + +Changes in 0.9.1 + - Fix an issue with GHC 7.6.1 and type families + +Changes in 0.9.0 + - Add support for setup code (see README). + - There is no distinction between example/interaction anymore. Each + expression is counted as an example in the summary. + +Changes in 0.8.0 + - Doctest now directly accepts arbitrary GHC options, prefixing GHC options + with --optghc is no longer necessary + +Changes in 0.7.0 + - Print source location for failing tests + - Output less clutter on failing examples + - Expose Doctest's functionality through a very simplistic API, which can be + used for cabal integration + +Changes in 0.6.1 + - Fix a parser bug with CR+LF line endings + +Changes in 0.6.0 + - Support for ghc-7.4 + - Doctest now comes with it's own parser and does not depend on Haddock + anymore + +Changes in 0.5.2 + - Proper handling of singular/plural when printing stats + - Improve handling of invalid command line options + +Changes in 0.5.1 + - Adapted for ghc-7.2 + +Changes in 0.5.0 + - Print number of interactions to stderr before running tests + - Exit with exitFailure on failed tests + - Improve documentation + - Give a useful error message if ghc is not executable diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009-2017 Simon Hengel +Copyright (c) 2009-2026 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,612 @@ +# Doctest: Test interactive Haskell examples + +`doctest` is a tool that checks +[examples](https://haskell-haddock.readthedocs.io/latest/markup.html#examples) +and +[properties](https://haskell-haddock.readthedocs.io/latest/markup.html#properties) +in Haddock comments. +It is similar in spirit to the [popular Python module with the same name](https://docs.python.org/3/library/doctest.html). + +* [Getting started](#getting-started) + * [Installation](#installation) + * [A basic example](#a-basic-example) +* [Running doctest for a Cabal package](#running-doctest-for-a-cabal-package) + * [Passing doctest options to cabal repl](#passing-doctest-options-to-cabal-repl) + * [Cabal integration](#cabal-integration) +* [Writing examples and properties](#writing-examples-and-properties) + * [Example groups](#example-groups) + * [A note on performance](#a-note-on-performance) + * [Setup code](#setup-code) + * [Multi-line input](#multi-line-input) + * [Multi-line output](#multi-line-output) + * [Matching arbitrary output](#matching-arbitrary-output) + * [QuickCheck properties](#quickcheck-properties) + * [Hiding examples from Haddock](#hiding-examples-from-haddock) + * [Using GHC extensions](#using-ghc-extensions) +* [Limitations](#limitations) +* [Doctest in the wild](#doctest-in-the-wild) +* [Development](#development) +* [Contributors](#contributors) + + +# Getting started + +## Installation + +`doctest` is available from +[Hackage](https://hackage.haskell.org/package/doctest). +Install it with: + + cabal update && cabal install --ignore-project doctest + +Make sure that Cabal's `installdir` is on your `PATH`. + +On Linux / macOS / BSD: + +```bash + # requires cabal-install version 3.12, or later +export PATH="$(cabal -v0 path --installdir):$PATH" +``` +or +```bash +export PATH="$HOME/.local/bin:$PATH" +``` + +On Windows with PowerShell: + +```pwsh +# requires cabal-install version 3.12, or later +$Env:PATH = "$(cabal -v0 path --installdir)" + ";" + $Env:PATH +``` + +## A basic example + +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 +-- src/Fib.hs +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](https://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop) (e.g. ghci) +prints to `stdout` and `stderr` when evaluating that expression.) + +With `doctest` you can check whether the implementation satisfies the given +examples: + +``` +doctest src/Fib.hs +``` + + +# Running `doctest` for a Cabal package + +The easiest way to run `doctest` for a Cabal package is via `cabal repl --with-compiler=doctest`. + +This doesn't make a big difference for a simple package, but in more involved +situations `cabal` will make sure that all dependencies are available and it +will pass any required GHC options to `doctest`. + +A simple `.cabal` file for `Fib` looks like this: + +```cabal +-- fib.cabal +cabal-version: 1.12 + +name: fib +version: 0.0.0 +build-type: Simple + +library + build-depends: base == 4.* + hs-source-dirs: src + exposed-modules: Fib + default-language: Haskell2010 + +``` + +With a `.cabal` file in place, it is possible to run `doctest` via `cabal repl`: + +```bash +$ cabal repl --with-compiler=doctest +... +Examples: 2 Tried: 2 Errors: 0 Failures: 0 +``` + + +Notes: + +- If you use properties you need to pass `--build-depends=QuickCheck` and + `--build-depends=template-haskell` to `cabal repl`. + +- You likely want to reset the warning strategy for `cabal repl` with + `--repl-options='-w -Wdefault'`. + +- `doctest` always uses the version of GHC it was compiled with. Reinstalling + `doctest` with `cabal install doctest --overwrite-policy=always` before each + invocation ensures that it uses the same version of GHC as is on the `PATH`. + +- Technically, `cabal build` is not necessary. `cabal repl --with-compiler=doctest` + will build any dependencies as needed. However, it's more robust to run + `cabal build` first (specifically it is not a good idea to build + `ghc-paths` with `--with-compiler=doctest`). + +So a more robust way to call `doctest` is as follows: + +``` +cabal install doctest --ignore-project --overwrite-policy=always && cabal build && cabal repl --build-depends=QuickCheck --build-depends=template-haskell --with-compiler=doctest --repl-options='-w -Wdefault' +``` + +(This is what you want to use on CI.) + +## Passing `doctest` options to `cabal repl` + +You can pass `doctest` options like `--fast`, `--preserve-it` and `--verbose` to +`cabal repl` via `--repl-options`. + +Example: + +```bash +$ cabal repl --with-compiler=doctest --repl-options=--verbose +### Started execution at src/Fib.hs:7. +### example: +fib 10 +### Successful! + +### Started execution at src/Fib.hs:10. +### example: +fib 5 +### Successful! + +# Final summary: +Examples: 2 Tried: 2 Errors: 0 Failures: 0 +``` + +## Cabal integration + +***NOTE:*** This feature is experimental. + +***NOTE:*** This feature requires `cabal-install` version 3.12 or later. + + +```bash +$ cabal install --ignore-project doctest --flag cabal-doctest +``` + +```bash +$ cabal doctest +Examples: 2 Tried: 2 Errors: 0 Failures: 0 +``` + +```bash +$ cabal doctest -w ghc-8.6.5 +Examples: 2 Tried: 2 Errors: 0 Failures: 0 +``` + +```bash +$ cabal doctest --repl-options=--verbose +### Started execution at src/Fib.hs:7. +### example: +fib 10 +### Successful! + +### Started execution at src/Fib.hs:10. +### example: +fib 5 +### Successful! + +# Final summary: +Examples: 2 Tried: 2 Errors: 0 Failures: 0 +``` + +```bash +$ cabal doctest --build-depends transformers +Examples: 2 Tried: 2 Errors: 0 Failures: 0 +``` + +# Writing examples and properties + +## 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 skipped, because `let n = x + y` fails (as `y` is not in scope). + +### A note on performance + +By default, `doctest` calls `:reload` between each group to clear GHCi's scope +of any local definitions. This ensures that previous examples cannot influence +later ones. However, it can lead to performance penalties if you are using +`doctest` in a project with many modules. One possible remedy is to pass the +`--fast` flag to `doctest`, which disables calling `:reload` between groups. +If `doctest`s are running too slowly, you might consider using `--fast`. +(With the caveat that the order in which groups appear now matters!) + +However, note that due to a +[bug on GHC 8.2.1 or later](https://gitlab.haskell.org/ghc/ghc/-/issues/14052), +the performance of `--fast` suffers significantly when combined with the +`--preserve-it` flag (which keeps the value of GHCi's `it` value between +examples). + +## 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 inbetween 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 inbetween 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 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](https://hackage.haskell.org/package/QuickCheck) is visible to +`doctest` (e.g. by passing `--build-depends=QuickCheck` to `cabal repl`). + +```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]: https://haskell-haddock.readthedocs.io/latest/markup.html#named-chunks + +## Using GHC extensions + +There's two sets of GHC extensions involved when running Doctest: + +1. The set of GHC extensions that are active when compiling the module code + (excluding the doctest examples). The easiest way to specify these + extensions is through [LANGUAGE pragmas][language-pragma] in your source + files. + +1. The set of GHC extensions that are active when executing the Doctest + examples. (These are not influenced by the LANGUAGE pragmas in the file.) + The recommended way to enable extensions for Doctest examples is to switch + them on like this: + +```haskell +-- | +-- >>> :seti -XTupleSections +-- >>> fst' $ (1,) 2 +-- 1 +fst' :: (a, b) -> a +fst' = fst +``` + +Alternatively you can pass any GHC options to Doctest, e.g.: + + doctest -XCPP Foo.hs + +These options will affect both the loading of the module and the execution of +the Doctest examples. + +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 +-- $ +-- >>> :seti -XTupleSections +``` + +[language-pragma]: https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/pragmas.html#language-pragma + +# Limitations + + +- Doctests only works on platforms that have support for GHC's `--interactive` mode (`ghci`). + + +- Due to [a GHC bug](https://gitlab.haskell.org/ghc/ghc/-/issues/20670), running + `:set -XTemplateHaskell` within `ghci` may unload any modules that were + specified on the command-line. + + To address this `doctest >= 0.19.0` does two things: + + 1. Doctest always enables `-XTemplateHaskell`. So it is safe to use Template + Haskell in examples without enabling the extension explicitly. + 1. Doctest filters out `-XTemplateHaskell` from single-line `:set`-statements. + So it is still safe to include `:set -XTemplateHaskell` in examples for + documentation purposes. It may just not work as intended in `ghci` due to + that GHC bug. + + Doctest does not filter out `-XTemplateHaskell` from multi-line + `:set`-statements. So if you e.g. use + + ``` + >>> :{ + :set -XTemplateHaskell + :} + ``` + then you are on your own. + + Note that all platforms that support `--interactive` also support + `-XTemplateHaskell`. So this approach does not reduce Doctest's platform + support. + +- Modules that are rejected by `haddock` will not work with `doctest`. This + can mean that `doctest` fails on input that is accepted by GHC (e.g. + [#251](https://github.com/sol/doctest/issues/251)). + +- Doctest works best with UTF-8. If your locale is e.g. `LC_ALL=C`, you may + want to invoke `doctest` with `LC_ALL=C.UTF-8`. + +# Doctest in the wild + +You can find real world examples of `Doctest` being used below: + + * [base Data/Maybe.hs](https://github.com/ghc/ghc/blob/669cbef03c220de43b0f88f2b2238bf3c02ed64c/libraries/base/Data/Maybe.hs#L36-L79) + * [base Data/Functor.hs](https://github.com/ghc/ghc/blob/669cbef03c220de43b0f88f2b2238bf3c02ed64c/libraries/base/Data/Functor.hs#L34-L64) + + +# Development + +Discuss your ideas first, ideally by opening an issue on GitHub. + +Add tests for new features, and make sure that the test suite passes with your +changes. + + cabal build && cabal exec $(cabal list-bin spec) + + +# Contributors + + * Simon Hengel + * quasicomputational + * Kazu Yamamoto + * Andreas Abel + * Michael Snoyman + * Michael Orlitzky + * Sakari Jokinen + * Adam Vogt + * Ryan Scott + * Oleg Grenrus + * Sönke Hahn + * Edward Kmett + * Elliot Marsden + * Greg Pfeil + * Ignat Insarov + * Julian K. Arni + * Takano Akio + * Joachim Breitner + * Alan Zimmerman + * Alexander Bernauer + * Alexandre Esteves + * Anders Persson + * Ankit Ahuja + * Artyom Kazak + * Gabor Greif + * Guillaume Bouchard + * Hiroki Hattori + * Jens Petersen + * John Chee + * João Cristóvão + * Leon Schoorl + * Levent Erkok + * Luke Murphy + * Matvey Aksenov + * Mitchell Rosen + * Nick Smallbone + * Nikos Baxevanis + * Tamar Christina + * Veronika Romashkina + +For up-to-date list, query + + git shortlog -s diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -1,121 +1,304 @@ -name: doctest -version: 0.13.0 -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/sol/doctest/issues -homepage: https://github.com/sol/doctest#readme -license: MIT -license-file: LICENSE -copyright: (c) 2009-2017 Simon Hengel -author: Simon Hengel -maintainer: Simon Hengel -build-type: Simple -cabal-version: >= 1.8 -extra-source-files: example/example.cabal - , example/src/Example.hs - , example/test/doctests.hs +cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack + +name: doctest +version: 0.25.0 +synopsis: Test interactive Haskell examples +description: `doctest` is a tool that checks [examples](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744) + and [properties](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810771856) + in Haddock comments. + It is similar in spirit to the [popular Python module with the same name](https://docs.python.org/3/library/doctest.html). + . + Documentation is at . +category: Testing +bug-reports: https://github.com/sol/doctest/issues +homepage: https://github.com/sol/doctest#readme +license: MIT +license-file: LICENSE +copyright: (c) 2009-2026 Simon Hengel +author: Simon Hengel +maintainer: Simon Hengel +build-type: Simple +extra-source-files: + example/example.cabal + example/src/Example.hs + example/test/doctests.hs + test/parse/multiple-examples/Foo.hs + test/parse/no-examples/Fib.hs + test/parse/non-exported/Fib.hs + test/parse/property/Fib.hs + test/parse/setup-empty/Foo.hs + test/parse/setup-only/Foo.hs + test/parse/simple/Fib.hs + test/extract/argument-list/Foo.hs + test/extract/comment-order/Foo.hs + test/extract/declaration/Foo.hs + test/extract/dos-line-endings/Foo.hs + test/extract/export-list/Foo.hs + test/extract/imported-module/Bar.hs + test/extract/imported-module/Baz.hs + test/extract/module-header/Foo.hs + test/extract/named-chunks/Foo.hs + test/extract/regression/Fixity.hs + test/extract/regression/ForeignImport.hs + test/extract/regression/ParallelListComp.hs + test/extract/regression/ParallelListCompClass.hs + test/extract/regression/RewriteRules.hs + test/extract/regression/RewriteRulesWithSigs.hs + test/extract/setup/Foo.hs + test/extract/th/Bar.hs + test/extract/th/Foo.hs + test/extract/type-class-args/Foo.hs + test/extract/type-class/Foo.hs + test/extract/type-families/Foo.hs + test/integration/bugfixImportHierarchical/ModuleA.hs + test/integration/bugfixImportHierarchical/ModuleB.hs + test/integration/bugfixMultipleModules/ModuleA.hs + test/integration/bugfixMultipleModules/ModuleB.hs + test/integration/bugfixOutputToStdErr/Fib.hs + test/integration/bugfixWorkingDirectory/description + test/integration/bugfixWorkingDirectory/examples/Fib.hs + test/integration/bugfixWorkingDirectory/Fib.hs + test/integration/color/Foo.hs + test/integration/custom-package-conf/Bar.hs + test/integration/custom-package-conf/foo/doctest-foo.cabal + test/integration/custom-package-conf/foo/Foo.hs + test/integration/dos-line-endings/Fib.hs + test/integration/fail-fast/Bar.hs + test/integration/fail-fast/Foo.hs + test/integration/fail-fast/SetupBar.hs + test/integration/fail-fast/SetupFoo.hs + test/integration/failing-multiple/Foo.hs + test/integration/failing/Foo.hs + test/integration/it/Foo.hs + test/integration/it/Setup.hs + test/integration/local-stderr-binding/A.hs + test/integration/multiline/Multiline.hs + test/integration/parse-error/Foo.hs + test/integration/property-bool-with-type-signature/Foo.hs + test/integration/property-bool/Foo.hs + test/integration/property-failing/Foo.hs + test/integration/property-implicitly-quantified/Foo.hs + test/integration/property-quantified/Foo.hs + test/integration/property-setup/Foo.hs + test/integration/setup-skip-on-failure/Foo.hs + test/integration/setup/Foo.hs + test/integration/system-io-imported/A.hs + test/integration/template-haskell-bugfix/Main.hs + test/integration/template-haskell-bugfix/Printf.hs + test/integration/template-haskell/Foo.hs + test/integration/test-options/Foo.hs + test/integration/testBlankline/Fib.hs + test/integration/testCombinedExample/Fib.hs + test/integration/testCommentLocation/Foo.hs + test/integration/testCPP/Foo.hs + test/integration/testDocumentationForArguments/Fib.hs + test/integration/testFailOnMultiline/Fib.hs + test/integration/testImport/ModuleA.hs + test/integration/testImport/ModuleB.hs + test/integration/testPutStr/Fib.hs + test/integration/testSimple/Fib.hs + test/integration/trailing-whitespace/Foo.hs + test/integration/with-cbits/Bar.hs + test/integration/with-cbits/foo.c + CHANGES.markdown + README.md + source-repository head type: git location: https://github.com/sol/doctest +flag cabal-doctest + description: Install (experimental) cabal-doctest executable + manual: True + default: False + library + ghc-options: -Wall + hs-source-dirs: + src + default-extensions: + NamedFieldPuns + RecordWildCards + DeriveFunctor + NoImplicitPrelude exposed-modules: Test.DocTest - ghc-options: - -Wall - hs-source-dirs: - src, ghci-wrapper/src + Test.DocTest.Internal.Extract + Test.DocTest.Internal.Location + Test.DocTest.Internal.Parse + Test.DocTest.Internal.Run + Test.DocTest.Internal.Cabal other-modules: + Cabal + Cabal.Options + Cabal.Paths + Cabal.ReplOptions Extract - , GhcUtil - , Interpreter - , Location - , Options - , PackageDBs - , Parse - , Paths_doctest - , Property - , Runner - , Runner.Example - , Run - , Util - , Sandbox - , Language.Haskell.GhciWrapper + GhcUtil + Imports + Info + Interpreter + Language.Haskell.GhciWrapper + Location + Options + PackageDBs + Parse + Property + Run + Runner + Runner.Example + Util + Paths_doctest build-depends: - base == 4.* - , base-compat >= 0.7.0 - , ghc >= 7.0 && < 8.4 - , syb >= 0.3 - , code-page >= 0.1 + base >=4.12 && <5 + , code-page >=0.1 + , containers , deepseq , directory + , exceptions , filepath + , ghc >=8.6 && <9.16 + , ghc-paths >=0.1.0.9 , process - , ghc-paths >= 0.1.0.9 + , syb >=0.3 + , temporary , transformers + default-language: Haskell2010 + if impl(ghc >= 9.0) + ghc-options: -fwarn-unused-packages + if impl(ghc >= 9.8) + ghc-options: -fno-warn-x-partial +executable cabal-doctest + main-is: driver/cabal-doctest.hs + other-modules: + Paths_doctest + default-extensions: + NamedFieldPuns + RecordWildCards + DeriveFunctor + NoImplicitPrelude + ghc-options: -Wall -threaded + build-depends: + base >=4.12 && <5 + , doctest + default-language: Haskell2010 + if impl(ghc >= 9.0) + ghc-options: -fwarn-unused-packages + if impl(ghc >= 9.8) + ghc-options: -fno-warn-x-partial + if flag(cabal-doctest) + buildable: True + else + buildable: False + executable doctest - main-is: - Main.hs - ghc-options: - -Wall -threaded - hs-source-dirs: - driver + main-is: driver/doctest.hs + other-modules: + Paths_doctest + ghc-options: -Wall -threaded + default-extensions: + NamedFieldPuns + RecordWildCards + DeriveFunctor + NoImplicitPrelude build-depends: - base == 4.* + base >=4.12 && <5 , doctest + default-language: Haskell2010 + if impl(ghc >= 9.0) + ghc-options: -fwarn-unused-packages + if impl(ghc >= 9.8) + ghc-options: -fno-warn-x-partial test-suite spec - main-is: - Spec.hs - type: - exitcode-stdio-1.0 - ghc-options: - -Wall -threaded - cpp-options: - -DTEST + main-is: Spec.hs + other-modules: + Cabal.OptionsSpec + Cabal.PathsSpec + Cabal.ReplOptionsSpec + ExtractSpec + InfoSpec + InterpreterSpec + Language.Haskell.GhciWrapperSpec + LocationSpec + MainSpec + OptionsSpec + PackageDBsSpec + ParseSpec + PropertySpec + Runner.ExampleSpec + RunnerSpec + RunSpec + UtilSpec + Cabal + Cabal.Options + Cabal.Paths + Cabal.ReplOptions + Extract + GhcUtil + Imports + Info + Interpreter + Language.Haskell.GhciWrapper + Location + Options + PackageDBs + Parse + Property + Run + Runner + Runner.Example + Test.DocTest + Test.DocTest.Internal.Cabal + Test.DocTest.Internal.Extract + Test.DocTest.Internal.Location + Test.DocTest.Internal.Parse + Test.DocTest.Internal.Run + Util + Paths_doctest + type: exitcode-stdio-1.0 + ghc-options: -Wall -threaded + cpp-options: -DTEST hs-source-dirs: - test, src, ghci-wrapper/src + test + src + default-extensions: + NamedFieldPuns + RecordWildCards + DeriveFunctor + NoImplicitPrelude c-sources: test/integration/with-cbits/foo.c + build-tool-depends: + hspec-discover:hspec-discover build-depends: - base - , ghc - , syb - , code-page + HUnit + , QuickCheck >=2.13.1 + , base >=4.12 && <5 + , code-page >=0.1 + , containers , deepseq , directory + , exceptions , filepath + , ghc >=8.6 && <9.16 + , ghc-paths >=0.1.0.9 + , hspec >=2.3.0 + , hspec-core >=2.3.0 + , mockery , process - , ghc-paths + , silently >=1.2.4 + , stringbuilder >=0.4 + , syb >=0.3 + , temporary , transformers - - , base-compat - , HUnit - , hspec >= 1.5.1 - , QuickCheck >= 2.8.2 - , stringbuilder >= 0.4 - , silently >= 1.2.4 - , setenv - , with-location - , mockery - -test-suite doctests - main-is: - doctests.hs - type: - exitcode-stdio-1.0 - ghc-options: - -Wall -threaded - hs-source-dirs: - test - build-depends: - base - , doctest + default-language: Haskell2010 + if impl(ghc >= 9.0) + ghc-options: -fwarn-unused-packages + if impl(ghc >= 9.8) + ghc-options: -fno-warn-x-partial diff --git a/driver/Main.hs b/driver/Main.hs deleted file mode 100644 --- a/driver/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where -import Test.DocTest -import System.Environment (getArgs) - -main :: IO () -main = getArgs >>= doctest diff --git a/driver/cabal-doctest.hs b/driver/cabal-doctest.hs new file mode 100644 --- /dev/null +++ b/driver/cabal-doctest.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import Prelude +import qualified Test.DocTest.Internal.Cabal as Cabal +import System.Environment (getArgs) + +main :: IO () +main = getArgs >>= Cabal.doctest diff --git a/driver/doctest.hs b/driver/doctest.hs new file mode 100644 --- /dev/null +++ b/driver/doctest.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import Prelude +import Test.DocTest +import System.Environment (getArgs) + +main :: IO () +main = getArgs >>= doctest diff --git a/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs b/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs deleted file mode 100644 --- a/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -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 System.IO" - _ <- eval interpreter "import GHC.IO.Handle" - -- The buffering of stdout and stderr is NoBuffering - _ <- eval interpreter "hDuplicateTo stdout 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 "hSetBuffering stdout LineBuffering" - _ <- eval interpreter "hSetBuffering stderr LineBuffering" - - -- this is required on systems that don't use utf8 as default encoding (e.g. - -- Windows) - _ <- eval interpreter "hSetEncoding stdout utf8" - _ <- eval interpreter "hSetEncoding stderr 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 - 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 - then do - let xs = stripMarker line - echo xs - return xs - else 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 True expr - getResult True repl diff --git a/src/Cabal.hs b/src/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Cabal.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE LambdaCase #-} +module Cabal (externalCommand) where + +import Imports + +import Data.List +import Data.Version (makeVersion) +import System.IO +import System.IO.Temp +import System.Environment +import System.Directory +import System.FilePath +import System.Process + +import qualified Info +import Cabal.Paths +import Cabal.Options + +externalCommand :: [String] -> IO () +externalCommand args = do + lookupEnv "CABAL" >>= \ case + Nothing -> run "cabal" args + Just cabal -> run cabal (drop 1 args) + +run :: String -> [String] -> IO () +run cabal args = do + rejectUnsupportedOptions args + + Paths{..} <- paths cabal (discardReplOptions args) + + let + doctest = cache "doctest" <> "-" <> Info.version + script = cache "init-ghci-" <> Info.version + + doesFileExist doctest >>= \ case + True -> pass + False -> callProcess cabal [ + "install" , "doctest-" <> Info.version + , "--flag", "-cabal-doctest" + , "--ignore-project" + , "--installdir", cache + , "--program-suffix", "-" <> Info.version + , "--install-method=copy" + , "--with-compiler", ghc + ] + + doesFileExist script >>= \ case + True -> pass + False -> writeFileAtomically script ":seti -w -Wdefault" + + callProcess doctest ["--version"] + + let + repl extraArgs = call cabal ("repl" + : "--build-depends=QuickCheck" + : "--build-depends=template-haskell" + : ("--repl-options=-ghci-script=" <> script) + : args ++ extraArgs) + + case ghcVersion < makeVersion [9,4] of + True -> do + callProcess cabal ("build" : "--only-dependencies" : discardReplOptions args) + repl ["--with-compiler", doctest, "--with-hc-pkg", ghcPkg] + + False -> do + withSystemTempDirectory "cabal-doctest" $ \ dir -> do + repl ["--keep-temp-files", "--repl-multi-file", dir] + files <- filter (isSuffixOf "-inplace") <$> listDirectory dir + let options = concatMap (\ file -> ["-unit", '@' : dir file]) files + call doctest ("--no-magic" : options) + +writeFileAtomically :: FilePath -> String -> IO () +writeFileAtomically name contents = do + (tmp, h) <- openTempFile (takeDirectory name) (takeFileName name) + hPutStr h contents + hClose h + renameFile tmp name diff --git a/src/Cabal/Options.hs b/src/Cabal/Options.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Options.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +module Cabal.Options ( + rejectUnsupportedOptions +, discardReplOptions + +#ifdef TEST +, replOnlyOptions +#endif +) where + +import Imports + +import System.Exit +import System.Console.GetOpt + +import Data.Set (Set) +import qualified Data.Set as Set + +import qualified Cabal.ReplOptions as Repl + +replOnlyOptions :: Set String +replOnlyOptions = Set.fromList [ + "-z" + , "--ignore-project" + , "--repl-no-load" + , "--repl-options" + , "--repl-multi-file" + , "-b" + , "--build-depends" + , "--no-transitive-deps" + , "--enable-multi-repl" + , "--disable-multi-repl" + , "--with-repl" + ] + +rejectUnsupportedOptions :: [String] -> IO () +rejectUnsupportedOptions args = case getOpt' Permute options args of + (xs, _, _, _) | ListOptions `elem` xs -> do + let + names :: [String] + names = concat [map (\ c -> ['-', c]) short ++ map ("--" <> ) long | Option short long _ _ <- documentedOptions] + putStr (unlines names) + exitSuccess + (_, _, unsupported : _, _) -> do + die $ "Error: cabal: unrecognized 'doctest' option `" <> unsupported <> "'" + _ -> pass + +data Argument = Argument String (Maybe String) | ListOptions + deriving (Eq, Show) + +options :: [OptDescr Argument] +options = + Option [] ["list-options"] (NoArg ListOptions) "" + : documentedOptions + +documentedOptions :: [OptDescr Argument] +documentedOptions = map toOptDescr Repl.options + where + toOptDescr :: Repl.Option -> OptDescr Argument + toOptDescr (Repl.Option long short arg help) = Option (maybeToList short) [long] (toArgDescr long arg) help + + toArgDescr :: String -> Repl.Argument -> ArgDescr Argument + toArgDescr long = \ case + Repl.Argument name -> ReqArg (argument . Just) name + Repl.NoArgument -> NoArg (argument Nothing) + Repl.OptionalArgument name -> OptArg argument name + where + argument :: Maybe String -> Argument + argument value = Argument ("--" <> long) value + +discardReplOptions :: [String] -> [String] +discardReplOptions args = case getOpt Permute options args of + (xs, _, _) -> [renderArgument name value | Argument name value <- xs, Set.notMember name replOnlyOptions] + where + renderArgument name = \ case + Nothing -> name + Just value -> name <> "=" <> value diff --git a/src/Cabal/Paths.hs b/src/Cabal/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Paths.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StrictData #-} +module Cabal.Paths ( + Paths(..) +, paths +) where + +import Imports + +import Data.Char +import Data.Tuple +import Data.Version hiding (parseVersion) +import qualified Data.Version as Version +import System.Exit hiding (die) +import System.Directory +import System.FilePath +import System.IO +import System.Process +import Text.ParserCombinators.ReadP + +data Paths = Paths { + ghcVersion :: Version +, ghc :: FilePath +, ghcPkg :: FilePath +, cache :: FilePath +} deriving (Eq, Show) + +paths :: FilePath -> [String] -> IO Paths +paths cabal args = do + cabalVersion <- strip <$> readProcess cabal ["--numeric-version"] "" + + let + required :: Version + required = makeVersion [3, 12] + + when (parseVersion cabalVersion < Just required) $ do + die $ "'cabal-install' version " <> showVersion required <> " or later is required, but 'cabal --numeric-version' returned " <> cabalVersion <> "." + + values <- parseFields <$> readProcess cabal ("path" : args ++ ["-v0"]) "" + + let + getPath :: String -> String -> IO FilePath + getPath subject key = case lookup key values of + Nothing -> die $ "Cannot determine the path to " <> subject <> ". Running 'cabal path' did not return a value for '" <> key <> "'." + Just path -> canonicalizePath path + + ghc <- getPath "'ghc'" "compiler-path" + + ghcVersionString <- strip <$> readProcess ghc ["--numeric-version"] "" + + ghcVersion <- case parseVersion ghcVersionString of + Nothing -> die $ "Cannot determine GHC version from '" <> ghcVersionString <> "'." + Just version -> return version + + let + ghcPkg :: FilePath + ghcPkg = takeDirectory ghc "ghc-pkg-" <> ghcVersionString +#ifdef mingw32_HOST_OS + <.> "exe" +#endif + + doesFileExist ghcPkg >>= \ case + True -> pass + False -> die $ "Cannot determine the path to 'ghc-pkg' from '" <> ghc <> "'. File '" <> ghcPkg <> "' does not exist." + + abi <- strip <$> readProcess ghcPkg ["--no-user-package-db", "field", "base", "abi", "--simple-output"] "" + + cache_home <- getPath "Cabal's cache directory" "cache-home" + let cache = cache_home "doctest" "ghc-" <> ghcVersionString <> "-" <> abi + + createDirectoryIfMissing True cache + + return Paths { + ghcVersion + , ghc + , ghcPkg + , cache + } + where + parseFields :: String -> [(String, FilePath)] + parseFields = map parseField . lines + + parseField :: String -> (String, FilePath) + parseField input = case break (== ':') input of + (key, ':' : value) -> (key, dropWhile isSpace value) + (key, _) -> (key, "") + +die :: String -> IO a +die message = do + hPutStrLn stderr "Error: [cabal-doctest]" + hPutStrLn stderr message + exitFailure + +parseVersion :: String -> Maybe Version +parseVersion = lookup "" . map swap . readP_to_S Version.parseVersion diff --git a/src/Cabal/ReplOptions.hs b/src/Cabal/ReplOptions.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/ReplOptions.hs @@ -0,0 +1,195 @@ +module Cabal.ReplOptions ( + Option(..) +, Argument(..) +, options +) where + +import Imports + +data Option = Option { + optionName :: String +, optionShortName :: Maybe Char +, optionArgument :: Argument +, optionHelp :: String +} deriving (Eq, Show) + +data Argument = Argument String | NoArgument | OptionalArgument String + deriving (Eq, Show) + +options :: [Option] +options = [ + Option "help" (Just 'h') NoArgument "Show this help text" + , Option "verbose" (Just 'v') (OptionalArgument "n") "Control verbosity (n is 0--3, default verbosity level is 1)" + , Option "builddir" Nothing (Argument "DIR") "The directory where Cabal puts generated build files (default dist)" + , Option "keep-temp-files" Nothing NoArgument "Keep temporary files." + , Option "ghc" (Just 'g') NoArgument "compile with GHC" + , Option "ghcjs" Nothing NoArgument "compile with GHCJS" + , Option "uhc" Nothing NoArgument "compile with UHC" + , Option "with-compiler" (Just 'w') (Argument "PATH") "give the path to a particular compiler" + , Option "with-hc-pkg" Nothing (Argument "PATH") "give the path to the package tool" + , Option "prefix" Nothing (Argument "DIR") "bake this prefix in preparation of installation" + , Option "bindir" Nothing (Argument "DIR") "installation directory for executables" + , Option "libdir" Nothing (Argument "DIR") "installation directory for libraries" + , Option "libsubdir" Nothing (Argument "DIR") "subdirectory of libdir in which libs are installed" + , Option "dynlibdir" Nothing (Argument "DIR") "installation directory for dynamic libraries" + , Option "libexecdir" Nothing (Argument "DIR") "installation directory for program executables" + , Option "libexecsubdir" Nothing (Argument "DIR") "subdirectory of libexecdir in which private executables are installed" + , Option "datadir" Nothing (Argument "DIR") "installation directory for read-only data" + , Option "datasubdir" Nothing (Argument "DIR") "subdirectory of datadir in which data files are installed" + , Option "docdir" Nothing (Argument "DIR") "installation directory for documentation" + , Option "htmldir" Nothing (Argument "DIR") "installation directory for HTML documentation" + , Option "haddockdir" Nothing (Argument "DIR") "installation directory for haddock interfaces" + , Option "sysconfdir" Nothing (Argument "DIR") "installation directory for configuration files" + , Option "program-prefix" Nothing (Argument "PREFIX") "prefix to be applied to installed executables" + , Option "program-suffix" Nothing (Argument "SUFFIX") "suffix to be applied to installed executables" + , Option "enable-library-vanilla" Nothing NoArgument "Enable Vanilla libraries" + , Option "disable-library-vanilla" Nothing NoArgument "Disable Vanilla libraries" + , Option "enable-library-profiling" (Just 'p') NoArgument "Enable Library profiling" + , Option "disable-library-profiling" Nothing NoArgument "Disable Library profiling" + , Option "enable-shared" Nothing NoArgument "Enable Shared library" + , Option "disable-shared" Nothing NoArgument "Disable Shared library" + , Option "enable-static" Nothing NoArgument "Enable Static library" + , Option "disable-static" Nothing NoArgument "Disable Static library" + , Option "enable-executable-dynamic" Nothing NoArgument "Enable Executable dynamic linking" + , Option "disable-executable-dynamic" Nothing NoArgument "Disable Executable dynamic linking" + , Option "enable-executable-static" Nothing NoArgument "Enable Executable fully static linking" + , Option "disable-executable-static" Nothing NoArgument "Disable Executable fully static linking" + , Option "enable-profiling" Nothing NoArgument "Enable Executable and library profiling" + , Option "disable-profiling" Nothing NoArgument "Disable Executable and library profiling" + , Option "enable-profiling-shared" Nothing NoArgument "Enable Build profiling shared libraries" + , Option "disable-profiling-shared" Nothing NoArgument "Disable Build profiling shared libraries" + , Option "enable-executable-profiling" Nothing NoArgument "Enable Executable profiling (DEPRECATED)" + , Option "disable-executable-profiling" Nothing NoArgument "Disable Executable profiling (DEPRECATED)" + , Option "profiling-detail" Nothing (Argument "level") "Profiling detail level for executable and library (default, none, exported-functions, toplevel-functions, all-functions, late)." + , Option "library-profiling-detail" Nothing (Argument "level") "Profiling detail level for libraries only." + , Option "enable-optimization" (Just 'O') (OptionalArgument "n") "Build with optimization (n is 0--2, default is 1)" + , Option "disable-optimization" Nothing NoArgument "Build without optimization" + , Option "enable-debug-info" Nothing (OptionalArgument "n") "Emit debug info (n is 0--3, default is 0)" + , Option "disable-debug-info" Nothing NoArgument "Don't emit debug info" + , Option "enable-build-info" Nothing NoArgument "Enable build information generation during project building" + , Option "disable-build-info" Nothing NoArgument "Disable build information generation during project building" + , Option "enable-library-for-ghci" Nothing NoArgument "Enable compile library for use with GHCi" + , Option "disable-library-for-ghci" Nothing NoArgument "Disable compile library for use with GHCi" + , Option "enable-split-sections" Nothing NoArgument "Enable compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" + , Option "disable-split-sections" Nothing NoArgument "Disable compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" + , Option "enable-split-objs" Nothing NoArgument "Enable split library into smaller objects to reduce binary sizes (GHC 6.6+)" + , Option "disable-split-objs" Nothing NoArgument "Disable split library into smaller objects to reduce binary sizes (GHC 6.6+)" + , Option "enable-executable-stripping" Nothing NoArgument "Enable strip executables upon installation to reduce binary sizes" + , Option "disable-executable-stripping" Nothing NoArgument "Disable strip executables upon installation to reduce binary sizes" + , Option "enable-library-stripping" Nothing NoArgument "Enable strip libraries upon installation to reduce binary sizes" + , Option "disable-library-stripping" Nothing NoArgument "Disable strip libraries upon installation to reduce binary sizes" + , Option "configure-option" Nothing (Argument "OPT") "Extra option for configure" + , Option "user" Nothing NoArgument "Enable doing a per-user installation" + , Option "global" Nothing NoArgument "Disable doing a per-user installation" + , Option "package-db" Nothing (Argument "DB") "Append the given package database to the list of package databases used (to satisfy dependencies and register into). May be a specific file, 'global' or 'user'. The initial list is ['global'], ['global', 'user'], or ['global', $sandbox], depending on context. Use 'clear' to reset the list to empty. See the user guide for details." + , Option "flags" (Just 'f') (Argument "FLAGS") "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + , Option "extra-include-dirs" Nothing (Argument "PATH") "A list of directories to search for header files" + , Option "enable-deterministic" Nothing NoArgument "Enable Try to be as deterministic as possible (used by the test suite)" + , Option "disable-deterministic" Nothing NoArgument "Disable Try to be as deterministic as possible (used by the test suite)" + , Option "ipid" Nothing (Argument "IPID") "Installed package ID to compile this package as" + , Option "cid" Nothing (Argument "CID") "Installed component ID to compile this component as" + , Option "extra-lib-dirs" Nothing (Argument "PATH") "A list of directories to search for external libraries" + , Option "extra-lib-dirs-static" Nothing (Argument "PATH") "A list of directories to search for external libraries when linking fully static executables" + , Option "extra-framework-dirs" Nothing (Argument "PATH") "A list of directories to search for external frameworks (OS X only)" + , Option "extra-prog-path" Nothing (Argument "PATH") "A list of directories to search for required programs (in addition to the normal search locations)" + , Option "instantiate-with" Nothing (Argument "NAME=MOD") "A mapping of signature names to concrete module instantiations." + , Option "enable-tests" Nothing NoArgument "Enable dependency checking and compilation for test suites listed in the package description file." + , Option "disable-tests" Nothing NoArgument "Disable dependency checking and compilation for test suites listed in the package description file." + , Option "enable-coverage" Nothing NoArgument "Enable build package with Haskell Program Coverage. (GHC only)" + , Option "disable-coverage" Nothing NoArgument "Disable build package with Haskell Program Coverage. (GHC only)" + , Option "enable-library-coverage" Nothing NoArgument "Enable build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + , Option "disable-library-coverage" Nothing NoArgument "Disable build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + , Option "enable-benchmarks" Nothing NoArgument "Enable dependency checking and compilation for benchmarks listed in the package description file." + , Option "disable-benchmarks" Nothing NoArgument "Disable dependency checking and compilation for benchmarks listed in the package description file." + , Option "enable-relocatable" Nothing NoArgument "Enable building a package that is relocatable. (GHC only)" + , Option "disable-relocatable" Nothing NoArgument "Disable building a package that is relocatable. (GHC only)" + , Option "disable-response-files" Nothing NoArgument "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" + , Option "allow-depending-on-private-libs" Nothing NoArgument "Allow depending on private libraries. If set, the library visibility check MUST be done externally." + , Option "coverage-for" Nothing (Argument "UNITID") "A list of unit-ids of libraries to include in the Haskell Program Coverage report." + , Option "ignore-build-tools" Nothing NoArgument "Ignore build tool dependencies. If set, declared build tools needn't be found for compilation to proceed." + , Option "cabal-lib-version" Nothing (Argument "VERSION") "Select which version of the Cabal lib to use to build packages (useful for testing)." + , Option "enable-append" Nothing NoArgument "Enable appending the new config to the old config file" + , Option "disable-append" Nothing NoArgument "Disable appending the new config to the old config file" + , Option "enable-backup" Nothing NoArgument "Enable the backup of the config file before any alterations" + , Option "disable-backup" Nothing NoArgument "Disable the backup of the config file before any alterations" + , Option "constraint" (Just 'c') (Argument "CONSTRAINT") "Specify constraints on a package (version, installed/source, flags)" + , Option "preference" Nothing (Argument "CONSTRAINT") "Specify preferences (soft constraints) on the version of a package" + , Option "solver" Nothing (Argument "SOLVER") "Select dependency solver to use (default: modular). Choices: modular." + , Option "allow-older" Nothing (OptionalArgument "DEPS") "Ignore lower bounds in all dependencies or DEPS" + , Option "allow-newer" Nothing (OptionalArgument "DEPS") "Ignore upper bounds in all dependencies or DEPS" + , Option "write-ghc-environment-files" Nothing (Argument "always|never|ghc8.4.4+") "Whether to create a .ghc.environment file after a successful build (v2-build only)" + , Option "enable-documentation" Nothing NoArgument "Enable building of documentation" + , Option "disable-documentation" Nothing NoArgument "Disable building of documentation" + , Option "doc-index-file" Nothing (Argument "TEMPLATE") "A central index of haddock API documentation (template cannot use $pkgid)" + , Option "dry-run" Nothing NoArgument "Do not install anything, only print what would be installed." + , Option "only-download" Nothing NoArgument "Do not build anything, only fetch the packages." + , Option "max-backjumps" Nothing (Argument "NUM") "Maximum number of backjumps allowed while solving (default: 4000). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely." + , Option "reorder-goals" Nothing NoArgument "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." + , Option "count-conflicts" Nothing NoArgument "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." + , Option "fine-grained-conflicts" Nothing NoArgument "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." + , Option "minimize-conflict-set" Nothing NoArgument "When there is no solution, try to improve the error message by finding a minimal conflict set (default: false). May increase run time significantly." + , Option "independent-goals" Nothing NoArgument "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." + , Option "prefer-oldest" Nothing NoArgument "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section." + , Option "shadow-installed-packages" Nothing NoArgument "If multiple package instances of the same version are installed, treat all but one as shadowed." + , Option "strong-flags" Nothing NoArgument "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." + , Option "allow-boot-library-installs" Nothing NoArgument "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." + , Option "reject-unconstrained-dependencies" Nothing (Argument "none|all") "Require these packages to have constraints on them if they are to be selected (default: none)." + , Option "reinstall" Nothing NoArgument "Install even if it means installing the same version again." + , Option "avoid-reinstalls" Nothing NoArgument "Do not select versions that would destructively overwrite installed packages." + , Option "force-reinstalls" Nothing NoArgument "Reinstall packages even if they will most likely break other installed packages." + , Option "upgrade-dependencies" Nothing NoArgument "Pick the latest version for all dependencies, rather than trying to pick an installed version." + , Option "only-dependencies" Nothing NoArgument "Install only the dependencies necessary to build the given packages" + , Option "dependencies-only" Nothing NoArgument "A synonym for --only-dependencies" + , Option "index-state" Nothing (Argument "STATE") "Use source package index state as it existed at a previous time. Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps (e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD')." + , Option "root-cmd" Nothing (Argument "COMMAND") "(No longer supported, do not use.)" + , Option "build-summary" Nothing (Argument "TEMPLATE") "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + , Option "build-log" Nothing (Argument "TEMPLATE") "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + , Option "remote-build-reporting" Nothing (Argument "LEVEL") "Generate build reports to send to a remote server (none, anonymous or detailed)." + , Option "report-planning-failure" Nothing NoArgument "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." + , Option "enable-per-component" Nothing NoArgument "Enable Per-component builds when possible" + , Option "disable-per-component" Nothing NoArgument "Disable Per-component builds when possible" + , Option "run-tests" Nothing NoArgument "Run package test suites during installation." + , Option "semaphore" Nothing NoArgument "Use a semaphore so GHC can compile components in parallel" + , Option "jobs" (Just 'j') (OptionalArgument "NUM") "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." + , Option "keep-going" Nothing NoArgument "After a build failure, continue to build other unaffected packages." + , Option "offline" Nothing NoArgument "Don't download packages from the Internet." + , Option "haddock-hoogle" Nothing NoArgument "Generate a hoogle database" + , Option "haddock-html" Nothing NoArgument "Generate HTML documentation (the default)" + , Option "haddock-html-location" Nothing (Argument "URL") "Location of HTML documentation for pre-requisite packages" + , Option "haddock-for-hackage" Nothing NoArgument "Collection of flags to generate documentation suitable for upload to hackage" + , Option "haddock-executables" Nothing NoArgument "Run haddock for Executables targets" + , Option "haddock-tests" Nothing NoArgument "Run haddock for Test Suite targets" + , Option "haddock-benchmarks" Nothing NoArgument "Run haddock for Benchmark targets" + , Option "haddock-all" Nothing NoArgument "Run haddock for all targets" + , Option "haddock-internal" Nothing NoArgument "Run haddock for internal modules and include all symbols" + , Option "haddock-css" Nothing (Argument "PATH") "Use PATH as the haddock stylesheet" + , Option "haddock-hyperlink-source" Nothing NoArgument "Hyperlink the documentation to the source code" + , Option "haddock-quickjump" Nothing NoArgument "Generate an index for interactive documentation navigation" + , Option "haddock-hscolour-css" Nothing (Argument "PATH") "Use PATH as the HsColour stylesheet" + , Option "haddock-contents-location" Nothing (Argument "URL") "Bake URL in as the location for the contents page" + , Option "haddock-base-url" Nothing (Argument "URL") "Base URL for static files." + , Option "haddock-resources-dir" Nothing (Argument "DIR") "location of Haddocks static / auxiliary files" + , Option "haddock-output-dir" Nothing (Argument "DIR") "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases." + , Option "haddock-use-unicode" Nothing NoArgument "Pass --use-unicode option to haddock" + , Option "test-log" Nothing (Argument "TEMPLATE") "Log all test suite results to file (name template can use $pkgid, $compiler, $os, $arch, $test-suite, $result)" + , Option "test-machine-log" Nothing (Argument "TEMPLATE") "Produce a machine-readable log file (name template can use $pkgid, $compiler, $os, $arch, $result)" + , Option "test-show-details" Nothing (Argument "FILTER") "'always': always show results of individual test cases. 'never': never show results of individual test cases. 'failures': show results of failing test cases. 'streaming': show results of test cases in real time.'direct': send results of test cases in real time; no log file." + , Option "test-keep-tix-files" Nothing NoArgument "keep .tix files for HPC between test runs" + , Option "test-wrapper" Nothing (Argument "FILE") "Run test through a wrapper." + , Option "test-fail-when-no-test-suites" Nothing NoArgument "Exit with failure when no test suites are found." + , Option "test-options" Nothing (Argument "TEMPLATES") "give extra options to test executables (split on spaces, use \"\" to prevent splitting; name templates can use $pkgid, $compiler, $os, $arch, $test-suite)" + , Option "test-option" Nothing (Argument "TEMPLATE") "give extra option to test executables (passed directly as a single argument; name template can use $pkgid, $compiler, $os, $arch, $test-suite)" + , Option "benchmark-options" Nothing (Argument "TEMPLATES") "give extra options to benchmark executables (split on spaces, use \"\" to prevent splitting; name templates can use $pkgid, $compiler, $os, $arch, $benchmark)" + , Option "benchmark-option" Nothing (Argument "TEMPLATE") "give extra option to benchmark executables (passed directly as a single argument; name template can use $pkgid, $compiler, $os, $arch, $benchmark)" + , Option "project-dir" Nothing (Argument "DIR") "Set the path of the project directory" + , Option "project-file" Nothing (Argument "FILE") "Set the path of the cabal.project file (relative to the project directory when relative)" + , Option "ignore-project" (Just 'z') NoArgument "Ignore local project configuration (unless --project-dir or --project-file is also set)" + , Option "repl-no-load" Nothing NoArgument "Disable loading of project modules at REPL startup." + , Option "repl-options" Nothing (Argument "FLAG") "Use the option(s) for the repl" + , Option "repl-multi-file" Nothing (Argument "DIR") "Write repl options to this directory rather than starting repl mode" + , Option "with-repl" Nothing (Argument "PATH") "Give the path to a program to use for REPL" + , Option "build-depends" (Just 'b') (Argument "DEPENDENCIES") "Include additional packages in the environment presented to GHCi." + , Option "no-transitive-deps" Nothing NoArgument "Don't automatically include transitive dependencies of requested packages." + , Option "enable-multi-repl" Nothing NoArgument "Enable multi-component repl sessions" + , Option "disable-multi-repl" Nothing NoArgument "Disable multi-component repl sessions" + ] diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -1,40 +1,33 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} +{-# LANGUAGE CPP #-} module Extract (Module(..), extract) where -import Prelude hiding (mod, concat) -import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Exception +import Imports hiding (mod, concat) import Data.List (partition, isSuffixOf) -import Data.Maybe -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (concat) -#endif import Control.DeepSeq (deepseq, NFData(rnf)) import Data.Generics -#if __GLASGOW_HASKELL__ < 707 -import GHC hiding (flags, Module, Located) -import MonadUtils (liftIO, MonadIO) -#else +#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 -import Exception (ExceptionMonad) -import System.Directory -import System.FilePath -#if __GLASGOW_HASKELL__ < 710 -import NameSet (NameSet) -import Coercion (Coercion) +#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 FastString (unpackFS) -import Digraph (flattenSCCs) +import System.Directory +import System.FilePath import System.Posix.Internals (c_getpid) @@ -44,9 +37,21 @@ import Util (convertDosLineEndings) import PackageDBs (getPackageDBArgs) +#if __GLASGOW_HASKELL__ < 900 +import DynamicLoading (initializePlugins) +#else +import GHC.Runtime.Loader (initializePlugins) +#endif + +#if __GLASGOW_HASKELL__ >= 901 +import GHC.Unit.Module.Graph +#endif + -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException +#if __GLASGOW_HASKELL__ < 912 deriving Typeable +#endif instance Show ExtractError where show (ExtractError e) = @@ -71,54 +76,46 @@ moduleName :: String , moduleSetup :: Maybe a , moduleContent :: [a] -} deriving (Eq, Functor) +} deriving (Eq, Show, Functor) instance NFData a => NFData (Module a) where rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` () -- | Parse a list of modules. -parse :: [String] -> IO [TypecheckedModule] +parse :: [String] -> IO [ParsedModule] parse args = withGhc args $ \modules_ -> withTempOutputDir $ do -- ignore additional object files let modules = filter (not . isSuffixOf ".o") modules_ - mapM (`guessTarget` Nothing) modules >>= setTargets + setTargets =<< forM modules (\ m -> guessTarget m +#if __GLASGOW_HASKELL__ >= 903 + Nothing +#endif + Nothing) mods <- depanal [] False - mods' <- if needsTemplateHaskell mods then enableCompilation mods else return mods - - let sortedMods = flattenSCCs (topSortModuleGraph False mods' Nothing) - reverse <$> mapM (parseModule >=> typecheckModule >=> loadModule) sortedMods - where - -- copied from Haddock/Interface.hs - enableCompilation :: ModuleGraph -> Ghc ModuleGraph - enableCompilation modGraph = do -#if __GLASGOW_HASKELL__ < 707 - let enableComp d = d { hscTarget = defaultObjectTarget } -#else - let enableComp d = let platform = targetPlatform d - in d { hscTarget = defaultObjectTarget platform } + let sortedMods = +#if __GLASGOW_HASKELL__ >= 914 + mapMaybe maybeModSummaryFromModuleNodeInfo $ #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' = map upd modGraph - return modGraph' + flattenSCCs +#if __GLASGOW_HASKELL__ >= 901 + $ filterToposortToModules +#endif + $ topSortModuleGraph False mods Nothing + reverse <$> mapM (loadModPlugins >=> parseModule) sortedMods + where -- copied from Haddock/GhcUtils.hs modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () modifySessionDynFlags f = do dflags <- getSessionDynFlags -#if __GLASGOW_HASKELL__ < 707 - _ <- setSessionDynFlags (f dflags) -#else -- GHCi 7.7 now uses dynamic linking. let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of Just "YES" -> gopt_set dflags Opt_BuildDynamicToo _ -> dflags _ <- setSessionDynFlags (f dflags') -#endif return () withTempOutputDir :: Ghc a -> Ghc a @@ -135,15 +132,33 @@ -- | 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 = f : includePaths d + , includePaths = addQuoteInclude (includePaths d) [f] } + -- Since GHC 8.6, plugins are initialized on a per module basis + loadModPlugins modsum = do + _ <- setSessionDynFlags (GHC.ms_hspp_opts modsum) + hsc_env <- getSession + +# if __GLASGOW_HASKELL__ >= 902 + hsc_env' <- liftIO (initializePlugins hsc_env) + setSession hsc_env' + return modsum +# else + dynflags' <- liftIO (initializePlugins hsc_env (GHC.ms_hspp_opts modsum)) + return $ modsum { ms_hspp_opts = dynflags' } +# endif + -- | Extract all docstrings from given list of files/modules. -- -- This includes the docstrings of all local modules that are imported from @@ -151,9 +166,17 @@ extract :: [String] -> IO [Module (Located String)] extract args = do packageDBArgs <- getPackageDBArgs - let args' = args ++ packageDBArgs + let + args' = args ++ +#if __GLASGOW_HASKELL__ >= 810 + -- `ghci` ignores unused packages in certain situation. This ensures + -- that we don't fail in situations where `ghci` would not. + "-Wno-unused-packages" : +#endif + packageDBArgs + mods <- parse args' - let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule . tm_parsed_module) mods + let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule) mods (docs `deepseq` return docs) `catches` [ -- Re-throw AsyncException, otherwise execution will not terminate on @@ -172,82 +195,94 @@ (setup, docs) = partition isSetup (docStringsFromModule m) name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m +#if __GLASGOW_HASKELL__ >= 914 +maybeModSummaryFromModuleNodeInfo :: ModuleNodeInfo -> Maybe ModSummary +maybeModSummaryFromModuleNodeInfo i = case i of + ModuleNodeCompile summary -> Just summary + ModuleNodeFixed _ _ -> Nothing +#endif + +#if __GLASGOW_HASKELL__ >= 904 +unpackHDS :: HsDocString -> String +unpackHDS = renderHsDocString +#endif + -- | Extract all docstrings from given module. docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)] -docStringsFromModule mod = map (fmap (toLocated . fmap unpackDocString)) docs +docStringsFromModule mod = map (fmap (toLocated . fmap unpackHDS)) docs where source = (unLoc . pm_parsed_source) mod -- we use dlist-style concatenation here + docs :: [(Maybe String, LHsDocString)] 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. +#if __GLASGOW_HASKELL__ >= 906 + header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader (hsmodExt source)]] +#elif __GLASGOW_HASKELL__ >= 904 + header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader (source)]] +#else header = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]] -#if __GLASGOW_HASKELL__ < 710 - exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- concat (hsmodExports source)] +#endif + exports :: [(Maybe String, LHsDocString)] +#if __GLASGOW_HASKELL__ >= 904 + exports = [ (Nothing, L (locA loc) (hsDocString (unLoc doc))) #else - exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)] + exports = [ (Nothing, L (locA loc) doc) #endif + | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source) + ] + decls :: [(Maybe String, LHsDocString)] decls = extractDocStrings (hsmodDecls source) -type Selector a = a -> ([(Maybe String, LHsDocString)], Bool) - -#if __GLASGOW_HASKELL__ < 710 --- | Ignore a subtree. -ignore :: Selector a -ignore = const ([], True) -#endif - --- | 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 -#if __GLASGOW_HASKELL__ < 710 - `extQ` (ignore :: Selector NameSet) - `extQ` (ignore :: Selector PostTcKind) - - -- HsExpr never contains any documentation, but it may contain error thunks. - -- - -- Problematic are (non comprehensive): - -- - -- * parallel list comprehensions - -- * infix operators - -- - `extQ` (ignore :: Selector (HsExpr RdrName)) - - -- undefined before type checking - `extQ` (ignore :: Selector Coercion) +extractDocStrings d = +#if __GLASGOW_HASKELL__ >= 904 + let + docStrs = extractAll extractDocDocString d + docStrNames = catMaybes $ extractAll extractDocName d + in + flip fmap docStrs $ \docStr -> (lookup (getLoc docStr) docStrNames, docStr) + where + extractAll z = everything (++) (mkQ [] ((:[]) . z)) -#if __GLASGOW_HASKELL__ >= 706 - -- hswb_kvs and hswb_tvs may be error thunks - `extQ` (ignore :: Selector (HsWithBndrs [LHsType RdrName])) - `extQ` (ignore :: Selector (HsWithBndrs [LHsType Name])) - `extQ` (ignore :: Selector (HsWithBndrs (LHsType RdrName))) - `extQ` (ignore :: Selector (HsWithBndrs (LHsType Name))) -#endif + extractDocDocString :: LHsDoc GhcPs -> LHsDocString + extractDocDocString = fmap hsDocString -#endif - ) + extractDocName :: DocDecl GhcPs -> Maybe (SrcSpan, String) + extractDocName docDecl = case docDecl of + DocCommentNamed name y -> + Just (getLoc y, name) + _ -> + Nothing +#else + everythingBut (++) (([], False) `mkQ` fromLHsDecl + `extQ` fromLDocDecl + `extQ` fromLHsDocString + ) d where - fromLHsDecl :: Selector (LHsDecl RdrName) + 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. - DocD x -> select (fromDocDecl loc x) + DocD _ x + -> select (fromDocDecl (locA loc) x) _ -> (extractDocStrings decl, True) - fromLDocDecl :: Selector LDocDecl - fromLDocDecl (L loc x) = select (fromDocDecl loc x) + fromLDocDecl :: Selector +#if __GLASGOW_HASKELL__ >= 901 + (LDocDecl GhcPs) +#else + LDocDecl +#endif + fromLDocDecl (L loc x) = select (fromDocDecl (locA loc) x) fromLHsDocString :: Selector LHsDocString fromLHsDocString x = select (Nothing, x) @@ -257,6 +292,14 @@ DocCommentNamed name doc -> (Just name, L loc doc) _ -> (Nothing, L loc $ docDeclDoc x) --- | Convert a docstring to a plain string. -unpackDocString :: HsDocString -> String -unpackDocString (HsDocString s) = unpackFS s +type Selector a = a -> ([(Maybe String, LHsDocString)], Bool) + +-- | Collect given value and descend into subtree. +select :: a -> ([a], Bool) +select x = ([x], False) +#endif + +#if __GLASGOW_HASKELL__ < 901 +locA :: SrcSpan -> SrcSpan +locA = id +#endif diff --git a/src/GhcUtil.hs b/src/GhcUtil.hs --- a/src/GhcUtil.hs +++ b/src/GhcUtil.hs @@ -1,72 +1,59 @@ {-# LANGUAGE CPP #-} -module GhcUtil (withGhc) where +{-# LANGUAGE LambdaCase #-} +module GhcUtil (withGhc, expandUnits) where +import Imports + import GHC.Paths (libdir) -#if __GLASGOW_HASKELL__ < 707 -import Control.Exception -import GHC hiding (flags) -import DynFlags (dopt_set) -#else import GHC +#if __GLASGOW_HASKELL__ < 900 import DynFlags (gopt_set) +#else +import GHC.Driver.Session (gopt_set) #endif -import Panic (throwGhcException) -import MonadUtils (liftIO) -import System.Exit (exitFailure) - -#if __GLASGOW_HASKELL__ < 702 -import StaticFlags (v_opt_C_ready) -import Data.IORef (writeIORef) -#elif __GLASGOW_HASKELL__ < 707 -import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) -#elif __GLASGOW_HASKELL__ < 801 -import StaticFlags (discardStaticFlags) +#if __GLASGOW_HASKELL__ < 900 +import Panic (throwGhcException) +#else +import GHC.Utils.Panic (throwGhcException) #endif - --- | Save static flag globals, run action, and restore them. -bracketStaticFlags :: IO a -> IO a -#if __GLASGOW_HASKELL__ < 702 --- GHC < 7.2 does not provide saveStaticFlagGlobals/restoreStaticFlagGlobals, --- so we need to modifying v_opt_C_ready directly -bracketStaticFlags action = action `finally` writeIORef v_opt_C_ready False -#elif __GLASGOW_HASKELL__ < 707 -bracketStaticFlags action = bracket saveStaticFlagGlobals restoreStaticFlagGlobals (const action) +#if __GLASGOW_HASKELL__ < 900 +import MonadUtils (liftIO) #else -bracketStaticFlags action = action +import GHC.Utils.Monad (liftIO) #endif +import GHC.ResponseFile (expandResponse) +import System.Exit (exitFailure) + -- Catch GHC source errors, print them and exit. handleSrcErrors :: Ghc a -> Ghc a handleSrcErrors action' = flip handleSourceError action' $ \err -> do -#if __GLASGOW_HASKELL__ < 702 - printExceptionAndWarnings err -#else printException err -#endif liftIO exitFailure -- | Run a GHC action in Haddock mode withGhc :: [String] -> ([String] -> Ghc a) -> IO a -withGhc flags action = bracketStaticFlags $ do - flags_ <- handleStaticFlags flags +withGhc flags action = runGhc (Just libdir) $ do + liftIO (expandUnits flags) >>= handleDynamicFlags >>= handleSrcErrors . action - runGhc (Just libdir) $ do - handleDynamicFlags flags_ >>= handleSrcErrors . action +expandUnits :: [String] -> IO [String] +expandUnits = \ case + [] -> return [] + "-unit" : file@('@' : _) : args -> (++) <$> expandResponse [file] <*> expandUnits args + file@('@' : _) : args -> (++) <$> expandResponse [file] <*> expandUnits args + x : xs -> (:) x <$> expandUnits xs -handleStaticFlags :: [String] -> IO [Located String] -#if __GLASGOW_HASKELL__ < 707 -handleStaticFlags flags = fst `fmap` parseStaticFlags (map noLoc flags) -#elif __GLASGOW_HASKELL__ < 801 -handleStaticFlags flags = return $ map noLoc $ discardStaticFlags flags +handleDynamicFlags :: GhcMonad m => [String] -> m [String] +handleDynamicFlags flags = do +#if __GLASGOW_HASKELL__ >= 901 + logger <- getLogger + let parseDynamicFlags' = parseDynamicFlags logger #else -handleStaticFlags flags = return $ map noLoc $ flags + let parseDynamicFlags' = parseDynamicFlags #endif - -handleDynamicFlags :: GhcMonad m => [Located String] -> m [String] -handleDynamicFlags flags = do - (dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags + (dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= (`parseDynamicFlags'` map noLoc flags) _ <- setSessionDynFlags dynflags -- We basically do the same thing as `ghc/Main.hs` to distinguish @@ -78,12 +65,14 @@ _ -> return srcs setHaddockMode :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ < 707 -setHaddockMode dynflags = (dopt_set dynflags Opt_Haddock) { -#else setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) { -#endif +#if __GLASGOW_HASKELL__ >= 906 + backend = noBackend +#elif __GLASGOW_HASKELL__ >= 901 + backend = NoBackend +#else hscTarget = HscNothing +#endif , ghcMode = CompManager , ghcLink = NoLink } diff --git a/src/Imports.hs b/src/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Imports.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +module Imports (module Imports) where + +import Prelude as Imports +import Data.Monoid as Imports +import Data.Maybe as Imports +import Control.Monad as Imports hiding (forM_) +import Control.Exception as Imports +import Data.Foldable as Imports (forM_) +import Control.Arrow as Imports + +import Data.Char +import System.Exit +import System.Process + +import Data.Functor as Imports ((<&>)) + +pass :: Monad m => m () +pass = return () + +equals :: Eq a => a -> a -> Bool +equals = (==) + +strip :: String -> String +strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +call :: FilePath -> [FilePath] -> IO () +call name args = rawSystem name args >>= \ case + ExitSuccess -> pass + err -> exitWith err + +exec :: FilePath -> [FilePath] -> IO () +exec name args = rawSystem name args >>= exitWith diff --git a/src/Info.hs b/src/Info.hs new file mode 100644 --- /dev/null +++ b/src/Info.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +module Info ( + versionInfo +, info +, version +#ifdef TEST +, formatInfo +#endif +) where + +import Imports + +import Data.List +import System.Process +import System.IO.Unsafe + +#if __GLASGOW_HASKELL__ < 900 +import Config as GHC +#else +import GHC.Settings.Config as GHC +#endif + +import Interpreter (ghc) + +#ifdef TEST + +version :: String +version = "0.0.0" + +#else + +import Data.Version (showVersion) +import qualified Paths_doctest + +version :: String +version = showVersion Paths_doctest.version + +#endif + +ghcVersion :: String +ghcVersion = GHC.cProjectVersion + +versionInfo :: String +versionInfo = unlines [ + "doctest version " ++ version + , "using version " ++ ghcVersion ++ " of the GHC API" + , "using " ++ ghc + ] + +info :: String +info = formatInfo $ + ("version", version) + : ("ghc_version", ghcVersion) + : ("ghc", ghc) + : ghcInfo + +type Info = [(String, String)] + +ghcInfo :: Info +ghcInfo = read $ unsafePerformIO (readProcess ghc ["--info"] "") + +formatInfo :: Info -> String +formatInfo xs = " [" ++ (intercalate "\n ," $ map show xs) ++ "\n ]\n" diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} - module Interpreter ( Interpreter +, PreserveIt(..) , safeEval -, safeEvalIt +, safeEvalWith , withInterpreter , ghc , interpreterSupported @@ -11,16 +11,13 @@ -- exported for testing , ghcInfo , haveInterpreterKey +, filterExpression ) where +import Imports + import System.Process import System.Directory (getPermissions, executable) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Monad -import Control.Exception hiding (handle) -import Data.Char import GHC.Paths (ghc) import Language.Haskell.GhciWrapper @@ -39,40 +36,51 @@ unless (executable x) $ do fail $ ghc ++ " is not executable!" - maybe False (== "YES") . lookup haveInterpreterKey <$> ghcInfo + (== Just "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 + :: (String, [String]) -> (Interpreter -> IO a) -- ^ Action to run -> IO a -- ^ Result of action -withInterpreter flags action = do - let args = ["--interactive"] ++ flags - bracket (new defaultConfig{configGhci = ghc} args) close action +withInterpreter (command, flags) action = do + let + args = flags ++ [ + xTemplateHaskell + , "-fdiagnostics-color=never" + , "-fno-diagnostics-show-caret" +#if __GLASGOW_HASKELL__ >= 810 && __GLASGOW_HASKELL__ < 904 + , "-Wno-unused-packages" +#endif +#if __GLASGOW_HASKELL__ >= 910 + , "-fprint-error-index-links=never" +#endif + ] + bracket (new defaultConfig{configGhci = command} args) close action +xTemplateHaskell :: String +xTemplateHaskell = "-XTemplateHaskell" + -- | 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 +safeEval = safeEvalWith NoPreserveIt -safeEvalIt :: Interpreter -> String -> IO (Either String String) -safeEvalIt repl = either (return . Left) (fmap Right . evalIt repl) . filterExpression +safeEvalWith :: PreserveIt -> Interpreter -> String -> IO (Either String String) +safeEvalWith preserveIt repl = either (return . Left) (fmap Right . evalWith preserveIt repl) . filterExpression filterExpression :: String -> Either String String filterExpression e = case lines e of [] -> Right e - l -> if firstLine == ":{" && lastLine /= ":}" then fail_ else Right e + l -> if firstLine == ":{" && lastLine /= ":}" then err else Right (filterXTemplateHaskell 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 + err = Left "unterminated multi-line command" + +filterXTemplateHaskell :: String -> String +filterXTemplateHaskell input = case words input of + [":set", setting] | setting == xTemplateHaskell -> "" + ":set" : xs | xTemplateHaskell `elem` xs -> unwords $ ":set" : filter (/= xTemplateHaskell) xs + _ -> input diff --git a/src/Language/Haskell/GhciWrapper.hs b/src/Language/Haskell/GhciWrapper.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhciWrapper.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE ViewPatterns #-} +module Language.Haskell.GhciWrapper ( + Interpreter +, Config(..) +, defaultConfig +, PreserveIt(..) +, new +, close +, eval +, evalWith +, evalEcho +) where + +import Imports + +import System.IO hiding (stdin, stdout, stderr) +import System.Process +import System.Exit +import Data.List (isSuffixOf) + +data Config = Config { + configGhci :: String +, configVerbose :: Bool +, configIgnoreDotGhci :: Bool +} deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = Config { + configGhci = "ghci" +, configVerbose = False +, configIgnoreDotGhci = True +} + +data PreserveIt = NoPreserveIt | PreserveIt + deriving Eq + +-- | 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} + evalThrow interpreter "import qualified System.IO" + evalThrow interpreter "import qualified GHC.IO.Encoding" + evalThrow interpreter "import qualified GHC.IO.Handle" + -- The buffering of stdout and stderr is NoBuffering + evalThrow 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. + evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering" + evalThrow 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) + evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8" + evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8" + + evalThrow interpreter ":m - System.IO" + evalThrow interpreter ":m - GHC.IO.Encoding" + evalThrow 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 + + evalThrow :: Interpreter -> String -> IO () + evalThrow interpreter expr = do + output <- eval interpreter expr + unless (null output || configVerbose) $ do + close interpreter + throwIO (ErrorCall output) + +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 -> PreserveIt -> String -> IO () +putExpression Interpreter{hIn = stdin} (equals PreserveIt -> 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 + then do + let xs = stripMarker line + echo xs + return xs + else 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 = \ _ -> return () + +-- | Evaluate an expression +eval :: Interpreter -> String -> IO String +eval = evalWith NoPreserveIt + +-- | Like 'eval', but try to preserve the @it@ variable +evalWith :: PreserveIt -> Interpreter -> String -> IO String +evalWith preserveIt repl expr = do + putExpression repl preserveIt expr + getResult False repl + +-- | Evaluate an expression +evalEcho :: Interpreter -> String -> IO String +evalEcho repl expr = do + putExpression repl NoPreserveIt expr + getResult True repl diff --git a/src/Location.hs b/src/Location.hs --- a/src/Location.hs +++ b/src/Location.hs @@ -1,13 +1,18 @@ -{-# LANGUAGE CPP, DeriveFunctor #-} +{-# LANGUAGE CPP #-} module Location where +import Imports + import Control.DeepSeq (deepseq, NFData(rnf)) + +#if __GLASGOW_HASKELL__ < 900 import SrcLoc hiding (Located) import qualified SrcLoc as GHC import FastString (unpackFS) - -#if __GLASGOW_HASKELL__ < 702 -import Outputable (showPpr) +#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. @@ -54,14 +59,12 @@ -- | Convert a GHC source span to a location. toLocation :: SrcSpan -> Location -#if __GLASGOW_HASKELL__ < 702 -toLocation loc - | isGoodSrcLoc start = Location (unpackFS $ srcLocFile start) (srcLocLine start) - | otherwise = (UnhelpfulLocation . showPpr) start - where - start = srcSpanStart loc -#else +#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/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -1,34 +1,34 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} module Options ( Result(..) , Run(..) -, defaultMagic -, defaultFastMode -, defaultPreserveIt +, Config(..) +, defaultConfig , parseOptions #ifdef TEST +, defaultRun , usage , info , versionInfo +, nonInteractiveGhcOptions #endif ) where -import Prelude () -import Prelude.Compat +import Imports -import Data.List.Compat -import Data.Maybe +import Control.Monad.Trans.RWS (RWS, execRWS) +import qualified Control.Monad.Trans.RWS as RWS -import qualified Paths_doctest -import Data.Version (showVersion) -import Config as GHC -import Interpreter (ghc) +import Data.List (stripPrefix) +import GHC.Paths (ghc) + +import Info + usage :: String usage = unlines [ "Usage:" - , " doctest [ --fast | --preserve-it | --no-magic | GHC OPTION | MODULE ]..." + , " doctest [ --fast | --preserve-it | --fail-fast | --no-magic | --verbose | GHC OPTION | MODULE ]..." , " doctest --help" , " doctest --version" , " doctest --info" @@ -36,83 +36,133 @@ , "Options:" , " --fast disable :reload between example groups" , " --preserve-it preserve the `it` variable between examples" + , " --fail-fast abort on first failure" + , " --no-magic disable magic mode" + , " --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.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 = Output String | Result a +data Result a = ProxyToGhc [String] | Output String | Result a deriving (Eq, Show, Functor) type Warning = String data Run = Run { runWarnings :: [Warning] -, runOptions :: [String] , runMagicMode :: Bool -, runFastMode :: Bool -, runPreserveIt :: Bool +, runConfig :: Config } deriving (Eq, Show) -defaultMagic :: Bool -defaultMagic = True +data Config = Config { + ghcOptions :: [String] +, fastMode :: Bool +, preserveIt :: Bool +, failFast :: Bool +, verbose :: Bool +, repl :: (String, [String]) +} deriving (Eq, Show) -defaultFastMode :: Bool -defaultFastMode = False +defaultConfig :: Config +defaultConfig = Config { + ghcOptions = [] +, fastMode = False +, preserveIt = False +, failFast = False +, verbose = False +, repl = (ghc, ["--interactive"]) +} -defaultPreserveIt :: Bool -defaultPreserveIt = False +nonInteractiveGhcOptions :: [String] +nonInteractiveGhcOptions = [ + "--numeric-version" + , "--supported-languages" + , "--info" + , "--print-global-package-db" + , "--print-libdir" + , "-c" + , "-o" + , "--make" + , "--abi-hash" + ] +defaultRun :: Run +defaultRun = Run { + runWarnings = [] +, runMagicMode = False +, runConfig = defaultConfig +} + +modifyWarnings :: ([String] -> [String]) -> Run -> Run +modifyWarnings f run = run { runWarnings = f (runWarnings run) } + +setOptions :: [String] -> Run -> Run +setOptions ghcOptions run@Run{..} = run { runConfig = runConfig { ghcOptions } } + +setMagicMode :: Bool -> Run -> Run +setMagicMode magic run = run { runMagicMode = magic } + +setFastMode :: Bool -> Run -> Run +setFastMode fastMode run@Run{..} = run { runConfig = runConfig { fastMode } } + +setPreserveIt :: Bool -> Run -> Run +setPreserveIt preserveIt run@Run{..} = run { runConfig = runConfig { preserveIt } } + +setFailFastMode :: Bool -> Run -> Run +setFailFastMode failFast run@Run{..} = run { runConfig = runConfig { failFast } } + +setVerbose :: Bool -> Run -> Run +setVerbose verbose run@Run{..} = run { runConfig = runConfig { verbose } } + parseOptions :: [String] -> Result Run parseOptions args - | "--help" `elem` args = Output usage - | "--info" `elem` args = Output info - | "--version" `elem` args = Output versionInfo - | otherwise = case fmap (fmap stripOptGhc) - . fmap stripPreserveIt - . stripFast - <$> stripNoMagic args of - (magicMode, (fastMode, (preserveIt, (warning, xs)))) -> - Result (Run (maybeToList warning) xs magicMode fastMode preserveIt) + | on "--info" = Output info + | on "--interactive" = runRunOptionsParser (discard "--interactive" args) defaultRun $ do + commonRunOptions + | on `any` nonInteractiveGhcOptions = ProxyToGhc args + | on "--help" = Output usage + | on "--version" = Output versionInfo + | otherwise = runRunOptionsParser args defaultRun {runMagicMode = True} $ do + commonRunOptions + parseFlag "--no-magic" (setMagicMode False) + parseOptGhc + where + on option = option `elem` args -stripNoMagic :: [String] -> (Bool, [String]) -stripNoMagic = stripFlag (not defaultMagic) "--no-magic" +type RunOptionsParser = RWS () (Endo Run) [String] () -stripFast :: [String] -> (Bool, [String]) -stripFast = stripFlag (not defaultFastMode) "--fast" +runRunOptionsParser :: [String] -> Run -> RunOptionsParser -> Result Run +runRunOptionsParser args def parse = case execRWS parse () args of + (xs, Endo setter) -> + Result (setOptions xs $ setter def) -stripPreserveIt :: [String] -> (Bool, [String]) -stripPreserveIt = stripFlag (not defaultPreserveIt) "--preserve-it" +commonRunOptions :: RunOptionsParser +commonRunOptions = do + parseFlag "--fast" (setFastMode True) + parseFlag "--preserve-it" (setPreserveIt True) + parseFlag "--fail-fast" (setFailFastMode True) + parseFlag "--verbose" (setVerbose True) -stripFlag :: Bool -> String -> [String] -> (Bool, [String]) -stripFlag enableIt flag args = ((flag `elem` args) == enableIt, filter (/= flag) args) +parseFlag :: String -> (Run -> Run) -> RunOptionsParser +parseFlag flag setter = do + args <- RWS.get + when (flag `elem` args) $ + RWS.tell (Endo setter) + RWS.put (discard flag args) -stripOptGhc :: [String] -> (Maybe Warning, [String]) -stripOptGhc = go +parseOptGhc :: RunOptionsParser +parseOptGhc = do + issueWarning <- RWS.state go + when issueWarning $ + RWS.tell $ Endo $ modifyWarnings (++ [warning]) where go args = case args of - [] -> (Nothing, []) - "--optghc" : opt : rest -> (Just warning, opt : snd (go rest)) - opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (Just warning, x : xs)) (stripPrefix "--optghc=" opt) (go rest) + [] -> (False, []) + "--optghc" : opt : rest -> (True, opt : snd (go rest)) + opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (True, x : xs)) (stripPrefix "--optghc=" opt) (go rest) warning = "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly." + +discard :: String -> [String] -> [String] +discard flag = filter (/= flag) diff --git a/src/PackageDBs.hs b/src/PackageDBs.hs --- a/src/PackageDBs.hs +++ b/src/PackageDBs.hs @@ -1,84 +1,49 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE PatternGuards #-} -- | Manage GHC package databases -module PackageDBs - ( PackageDBs (..) - , ArgStyle (..) - , dbArgs - , buildArgStyle - , getPackageDBsFromEnv - , getPackageDBArgs - ) where +module PackageDBs ( + getPackageDBArgs +#ifdef TEST +, PackageDBs (..) +, getPackageDBsFromEnv +#endif +) where +import Imports + import System.Environment (getEnvironment) import System.FilePath (splitSearchPath, searchPathSeparator) -import qualified Sandbox -import Control.Exception (try, SomeException) -import System.Directory (getCurrentDirectory) -- | Full stack of GHC package databases data PackageDBs = PackageDBs { includeUser :: Bool - -- | Unsupported on GHC < 7.6 , includeGlobal :: Bool , extraDBs :: [FilePath] } deriving (Show, Eq) --- | Package database handling switched between GHC 7.4 and 7.6 -data ArgStyle = Pre76 | Post76 - deriving (Show, Eq) - -- | Determine command line arguments to be passed to GHC to set databases correctly -- --- >>> dbArgs Post76 (PackageDBs False True []) +-- >>> dbArgs (PackageDBs False True []) -- ["-no-user-package-db"] -- --- >>> dbArgs Pre76 (PackageDBs True True ["somedb"]) --- ["-package-conf","somedb"] -dbArgs :: ArgStyle -> PackageDBs -> [String] -dbArgs Post76 (PackageDBs user global extras) = +-- >>> dbArgs (PackageDBs True True ["somedb"]) +-- ["-package-db","somedb"] +dbArgs :: PackageDBs -> [String] +dbArgs (PackageDBs user global extras) = (if user then id else ("-no-user-package-db":)) $ (if global then id else ("-no-global-package-db":)) $ concatMap (\extra -> ["-package-db", extra]) extras -dbArgs Pre76 (PackageDBs _ False _) = - error "Global package database must be included with GHC < 7.6" -dbArgs Pre76 (PackageDBs user True extras) = - (if user then id else ("-no-user-package-conf":)) $ - concatMap (\extra -> ["-package-conf", extra]) extras --- | The argument style to be used with the current GHC version -buildArgStyle :: ArgStyle -#if __GLASGOW_HASKELL__ >= 706 -buildArgStyle = Post76 -#else -buildArgStyle = Pre76 -#endif - --- | Determine the PackageDBs based on the environment and cabal sandbox --- information +-- | Determine the PackageDBs based on the environment. getPackageDBsFromEnv :: IO PackageDBs getPackageDBsFromEnv = do env <- getEnvironment - case () of + return $ case () of () - | Just sandboxes <- lookup "HASKELL_PACKAGE_SANDBOXES" env - -> return $ fromEnvMulti sandboxes - | Just extra <- lookup "HASKELL_PACKAGE_SANDBOX" env - -> return PackageDBs - { includeUser = True - , includeGlobal = True - , extraDBs = [extra] - } - | Just sandboxes <- lookup "GHC_PACKAGE_PATH" env - -> return $ fromEnvMulti sandboxes - | otherwise -> do - eres <- try $ getCurrentDirectory - >>= Sandbox.getSandboxConfigFile - >>= Sandbox.getPackageDbDir - return $ case eres :: Either SomeException FilePath of - Left _ -> PackageDBs True True [] - Right db -> PackageDBs False True [db] + | Just packageDBs <- lookup "GHC_PACKAGE_PATH" env + -> fromEnvMulti packageDBs + | otherwise + -> PackageDBs True True [] where fromEnvMulti s = PackageDBs { includeUser = False @@ -96,4 +61,4 @@ getPackageDBArgs :: IO [String] getPackageDBArgs = do dbs <- getPackageDBsFromEnv - return $ dbArgs buildArgStyle dbs + return $ dbArgs dbs diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -1,29 +1,27 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Parse ( Module (..) , DocTest (..) -, Interaction , Expression , ExpectedResult , ExpectedLine (..) , LineChunk (..) -, getDocTests +, extractDocTests +, parseModules --- * exported for testing +#ifdef TEST , parseInteractions , parseProperties , mkLineChunks +#endif ) where +import Imports + import Data.Char (isSpace) -import Data.List -import Data.Maybe +import Data.List (isPrefixOf, stripPrefix) import Data.String -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Extract import Location @@ -48,12 +46,15 @@ type Interaction = (Expression, ExpectedResult) - -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules. -getDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's -getDocTests args = parseModules <$> extract args +-- +-- @ +-- extractDocTests = fmap `parseModules` . `extract` +-- @ +extractDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's +extractDocTests = fmap parseModules . extract parseModules :: [Module (Located String)] -> [Module [Located DocTest]] parseModules = filter (not . isEmpty) . map parseModule @@ -173,8 +174,3 @@ 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/Property.hs b/src/Property.hs --- a/src/Property.hs +++ b/src/Property.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE PatternGuards #-} module Property ( runProperty , PropertyResult (..) @@ -9,8 +8,9 @@ #endif ) where +import Imports + import Data.List -import Data.Maybe import Data.Foldable import Util @@ -30,7 +30,6 @@ _ <- 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 @@ -68,7 +67,5 @@ -- | Remove quotes from given name, if any. unquote ('`':xs) = init xs -#if __GLASGOW_HASKELL__ >= 707 unquote ('\8216':xs) = init xs -#endif unquote xs = xs diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -1,17 +1,28 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module Run ( doctest +, doctestWithRepl + +, Config(..) +, defaultConfig +, doctestWith + +, Result +, Summary(..) +, formatSummary +, isSuccess +, evaluateResult +, doctestWithResult + +, runDocTests #ifdef TEST -, doctestWithOptions -, Summary , expandDirs #endif ) where -import Prelude () -import Prelude.Compat +import Imports -import Control.Monad (when, unless) import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) import System.Environment (getEnvironment) import System.Exit (exitFailure, exitSuccess) @@ -20,12 +31,23 @@ import System.IO.CodePage (withCP65001) import qualified Control.Exception as E + +#if __GLASGOW_HASKELL__ < 900 import Panic +#else +import GHC.Utils.Panic +#endif +#if __GLASGOW_HASKELL__ < 904 +import GhcUtil (expandUnits) +#endif + import PackageDBs import Parse -import Options +import Options hiding (Result(..)) +import qualified Options import Runner +import Location import qualified Interpreter -- | Run doctest with given list of arguments. @@ -33,6 +55,7 @@ -- Example: -- -- >>> doctest ["-iexample/src", "example/src/Example.hs"] +-- ... -- Examples: 2 Tried: 2 Errors: 0 Failures: 0 -- -- This can be used to create a Cabal test suite that runs doctest for your @@ -41,9 +64,19 @@ -- If a directory is given, it is traversed to find all .hs and .lhs files -- inside of it, ignoring hidden entries. doctest :: [String] -> IO () -doctest args0 = case parseOptions args0 of - Output s -> putStr s - Result (Run warnings args_ magicMode fastMode preserveIt) -> do +doctest = doctestWithRepl (repl defaultConfig) + +doctestWithRepl :: (String, [String]) -> [String] -> IO () +#if __GLASGOW_HASKELL__ < 904 +-- GHC versions prior to 9.4.1 don't support response files. For that reason +-- we want to expand early, so that GHCi gets expanded args. +doctestWithRepl repl = expandUnits >=> parseOptions >>> \ case +#else +doctestWithRepl repl = parseOptions >>> \ case +#endif + Options.ProxyToGhc args -> exec Interpreter.ghc args + Options.Output s -> putStr s + Options.Result (Run warnings magicMode config) -> do mapM_ (hPutStrLn stderr) warnings hFlush stderr @@ -52,22 +85,14 @@ hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests" exitSuccess - args <- case magicMode of - False -> return args_ + opts <- case magicMode of + False -> return (ghcOptions config) True -> do - expandedArgs <- concat <$> mapM expandDirs args_ + expandedArgs <- concat <$> mapM expandDirs (ghcOptions config) packageDBArgs <- getPackageDBArgs addDistArgs <- getAddDistArgs return (addDistArgs $ packageDBArgs ++ expandedArgs) - - r <- doctestWithOptions fastMode preserveIt args `E.catch` \e -> do - case fromException e of - Just (UsageError err) -> do - hPutStrLn stderr ("doctest: " ++ err) - hPutStrLn stderr "Try `doctest --help' for more information." - exitFailure - _ -> E.throwIO e - when (not $ isSuccess r) exitFailure + doctestWith config{repl, ghcOptions = opts} -- | Expand a reference to a directory to all .hs and .lhs files within it. expandDirs :: String -> IO [String] @@ -101,10 +126,7 @@ getAddDistArgs :: IO ([String] -> [String]) getAddDistArgs = do env <- getEnvironment - let dist = - case lookup "HASKELL_DIST_DIR" env of - Nothing -> "dist" - Just x -> x + let dist = fromMaybe "dist" $ lookup "HASKELL_DIST_DIR" env autogen = dist ++ "/build/autogen/" cabalMacros = autogen ++ "cabal_macros.h" @@ -120,14 +142,30 @@ else id) rest else return id -isSuccess :: Summary -> Bool -isSuccess s = sErrors s == 0 && sFailures s == 0 +doctestWith :: Config -> IO () +doctestWith = doctestWithResult >=> evaluateResult -doctestWithOptions :: Bool -> Bool -> [String] -> IO Summary -doctestWithOptions fastMode preserveIt args = do +type Result = Summary - -- get examples from Haddock comments - modules <- getDocTests args +evaluateResult :: Result -> IO () +evaluateResult r = unless (isSuccess r) exitFailure - Interpreter.withInterpreter args $ \repl -> withCP65001 $ do - runModules fastMode preserveIt repl modules +doctestWithResult :: Config -> IO Result +doctestWithResult config = do + (extractDocTests (ghcOptions config) >>= runDocTests config) `E.catch` \e -> do + case fromException e of + Just (UsageError err) -> do + hPutStrLn stderr ("doctest: " ++ err) + hPutStrLn stderr "Try `doctest --help' for more information." + exitFailure + _ -> E.throwIO e + +runDocTests :: Config -> [Module [Located DocTest]] -> IO Result +runDocTests Config{..} modules = do + Interpreter.withInterpreter ((<> ghcOptions) <$> repl) $ \ interpreter -> withCP65001 $ do + runModules + (if fastMode then FastMode else NoFastMode) + (if preserveIt then PreserveIt else NoPreserveIt) + (if failFast then FailFast else NoFailFast) + (if verbose then Verbose else NonVerbose) + interpreter modules diff --git a/src/Runner.hs b/src/Runner.hs --- a/src/Runner.hs +++ b/src/Runner.hs @@ -1,32 +1,39 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module Runner ( runModules +, FastMode(..) +, PreserveIt(..) +, FailFast(..) +, Verbose(..) , Summary(..) +, isSuccess +, formatSummary #ifdef TEST , Report -, ReportState (..) +, ReportState(..) +, runReport +, Interactive(..) , report -, report_ +, reportTransient #endif ) where -import Prelude hiding (putStr, putStrLn, error) - -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -import Control.Applicative -#endif +import Prelude () +import Imports hiding (putStr, putStrLn, error) -import Control.Monad hiding (forM_) import Text.Printf (printf) -import System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice) -import Data.Foldable (forM_) +import System.IO hiding (putStr, putStrLn) -import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State (StateT, evalStateT) +import qualified Control.Monad.Trans.State as State import Control.Monad.IO.Class +import Data.IORef -import Interpreter (Interpreter) +import Interpreter (Interpreter, PreserveIt(..), safeEvalWith) import qualified Interpreter import Parse import Location @@ -35,107 +42,137 @@ -- | Summary of a test run. data Summary = Summary { - sExamples :: Int -, sTried :: Int -, sErrors :: Int -, sFailures :: Int + sExamples :: !Int +, sTried :: !Int +, sErrors :: !Int +, sFailures :: !Int } deriving Eq --- | Format a summary. instance Show Summary where - show (Summary examples tried errors failures) = - printf "Examples: %d Tried: %d Errors: %d Failures: %d" examples tried errors failures + show = formatSummary +isSuccess :: Summary -> Bool +isSuccess s = sErrors s == 0 && sFailures s == 0 + +formatSummary :: Summary -> String +formatSummary (Summary examples tried errors failures) = + printf "Examples: %d Tried: %d Errors: %d Failures: %d" examples tried errors failures + -- | Sum up summaries. instance Monoid Summary where mempty = Summary 0 0 0 0 - (Summary x1 x2 x3 x4) `mappend` (Summary y1 y2 y3 y4) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) +instance Semigroup Summary where + Summary x1 x2 x3 x4 <> Summary y1 y2 y3 y4 = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) +withLineBuffering :: Handle -> IO c -> IO c +withLineBuffering h action = bracket (hGetBuffering h) (hSetBuffering h) $ \ _ -> do + hSetBuffering h LineBuffering + action + -- | Run all examples from a list of modules. -runModules :: Bool -> Bool -> Interpreter -> [Module [Located DocTest]] -> IO Summary -runModules fastMode preserveIt repl modules = do - isInteractive <- hIsTerminalDevice stderr - ReportState _ _ s <- (`execStateT` ReportState 0 isInteractive mempty {sExamples = c}) $ do - forM_ modules $ runModule fastMode preserveIt repl +runModules :: FastMode -> PreserveIt -> FailFast -> Verbose -> Interpreter -> [Module [Located DocTest]] -> IO Summary +runModules fastMode preserveIt failFast verbose repl modules = withLineBuffering stderr $ do - -- report final summary - gets (show . reportStateSummary) >>= report + interactive <- hIsTerminalDevice stderr <&> \ case + False -> NonInteractive + True -> Interactive - return s + summary <- newIORef mempty {sExamples = n} + + let + reportFinalResult :: IO () + reportFinalResult = do + final <- readIORef summary + hPutStrLn stderr (formatSummary final) + + run :: IO () + run = runReport (ReportState interactive failFast verbose summary) $ do + reportProgress + forM_ modules $ runModule fastMode preserveIt repl + verboseReport "# Final summary:" + + run `finally` reportFinalResult + + readIORef summary where - c = (sum . map count) modules + n :: Int + n = sum (map countExpressions modules) --- | Count number of expressions in given module. -count :: Module [Located DocTest] -> Int -count (Module _ setup tests) = sum (map length tests) + maybe 0 length setup +countExpressions :: Module [Located DocTest] -> Int +countExpressions (Module _ setup tests) = sum (map length tests) + maybe 0 length setup --- | A monad for generating test reports. -type Report = StateT ReportState IO +type Report = MaybeT (StateT ReportState IO) +data Interactive = NonInteractive | Interactive + +data FastMode = NoFastMode | FastMode + +data FailFast = NoFailFast | FailFast + +data Verbose = NonVerbose | Verbose + data ReportState = ReportState { - reportStateCount :: Int -- ^ characters on the current line -, reportStateInteractive :: Bool -- ^ should intermediate results be printed? -, reportStateSummary :: Summary -- ^ test summary + reportStateInteractive :: Interactive +, reportStateFailFast :: FailFast +, reportStateVerbose :: Verbose +, reportStateSummary :: IORef Summary } +runReport :: ReportState -> Report () -> IO () +runReport st = void . flip evalStateT st . runMaybeT + +getSummary :: Report Summary +getSummary = gets reportStateSummary >>= liftIO . readIORef + +gets :: (ReportState -> a) -> Report a +gets = lift . State.gets + -- | 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}) +report = liftIO . hPutStrLn stderr -- | 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) +reportTransient :: String -> Report () +reportTransient msg = gets reportStateInteractive >>= \ case + NonInteractive -> pass + Interactive -> liftIO $ do + hPutStr stderr msg + hFlush stderr + hPutStr stderr $ '\r' : (replicate (length msg) ' ') ++ "\r" -- | Run all examples from given module. -runModule :: Bool -> Bool -> Interpreter -> Module [Located DocTest] -> Report () +runModule :: FastMode -> PreserveIt -> Interpreter -> Module [Located DocTest] -> Report () runModule fastMode preserveIt repl (Module module_ setup examples) = do - Summary _ _ e0 f0 <- gets reportStateSummary + Summary _ _ e0 f0 <- getSummary forM_ setup $ runTestGroup preserveIt repl reload - Summary _ _ e1 f1 <- gets reportStateSummary + Summary _ _ e1 f1 <- getSummary -- only run tests, if setup does not produce any errors/failures when (e0 == e1 && f0 == f1) $ - forM_ examples $ - runTestGroup preserveIt repl setup_ + forM_ examples $ runTestGroup preserveIt repl setup_ where reload :: IO () reload = do - unless fastMode $ - -- NOTE: It is important to do the :reload first! See - -- https://ghc.haskell.org/trac/ghc/ticket/5904, which results in a - -- panic on GHC 7.4.1 if you do the :reload second. - void $ Interpreter.safeEval repl ":reload" + case fastMode of + NoFastMode -> void $ Interpreter.safeEval repl ":reload" + FastMode -> pass void $ Interpreter.safeEval repl $ ":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 $ "()" + case preserveIt of + NoPreserveIt -> pass + PreserveIt -> do + -- Evaluate a dumb expression to populate the 'it' variable. + -- + -- NOTE: This is one reason why we cannot just always use PreserveIt: + -- 'it' isn't set in a fresh GHCi session. + void $ Interpreter.safeEval repl $ "()" setup_ :: IO () setup_ = do @@ -144,78 +181,98 @@ Property _ -> return () Example e _ -> void $ safeEvalWith preserveIt repl e -reportFailure :: Location -> Expression -> Report () -reportFailure loc expression = do - report (printf "### Failure in %s: expression `%s'" (show loc) expression) +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 :: Location -> Expression -> [String] -> Report () +reportFailure loc expression err = do + report (printf "%s: failure in expression `%s'" (show loc) expression) + mapM_ report err + report "" updateSummary (Summary 0 1 0 1) reportError :: Location -> Expression -> String -> Report () reportError loc expression err = do - report (printf "### Error in %s: expression `%s'" (show loc) expression) + report (printf "%s: error in expression `%s'" (show loc) expression) report err + report "" updateSummary (Summary 0 1 1 0) reportSuccess :: Report () -reportSuccess = +reportSuccess = do + verboseReport "### Successful!\n" updateSummary (Summary 0 1 0 0) +verboseReport :: String -> Report () +verboseReport msg = gets reportStateVerbose >>= \ case + NonVerbose -> pass + Verbose -> report msg + updateSummary :: Summary -> Report () updateSummary summary = do - ReportState n f s <- get - put (ReportState n f $ s `mappend` summary) + ref <- gets reportStateSummary + liftIO $ modifyIORef' ref $ mappend summary + reportProgress + gets reportStateFailFast >>= \ case + NoFailFast -> pass + FailFast -> unless (isSuccess summary) abort +abort :: Report () +abort = MaybeT $ return Nothing + +reportProgress :: Report () +reportProgress = gets reportStateVerbose >>= \ case + NonVerbose -> do + summary <- getSummary + reportTransient (formatSummary summary) + Verbose -> pass + -- | 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 :: Bool -> Interpreter -> IO () -> [Located DocTest] -> Report () +runTestGroup :: PreserveIt -> Interpreter -> IO () -> [Located DocTest] -> Report () runTestGroup preserveIt repl setup tests = do - - -- report intermediate summary - gets (show . reportStateSummary) >>= report_ - liftIO setup runExampleGroup preserveIt repl examples forM_ properties $ \(loc, expression) -> do - r <- liftIO $ do - setup - runProperty repl expression + r <- do + liftIO setup + reportStart loc expression "property" + liftIO $ runProperty repl expression case r of Success -> reportSuccess Error err -> do reportError loc expression err Failure msg -> do - reportFailure loc expression - report msg + reportFailure loc expression [msg] where properties = [(loc, p) | Located loc (Property p) <- tests] examples :: [Located Interaction] examples = [Located loc (e, r) | Located loc (Example e r) <- tests] +type Interaction = (Expression, ExpectedResult) + -- | -- Execute all expressions from given example in given 'Interpreter' and verify -- the output. -runExampleGroup :: Bool -> Interpreter -> [Located Interaction] -> Report () +runExampleGroup :: PreserveIt -> Interpreter -> [Located Interaction] -> Report () runExampleGroup preserveIt repl = go where go ((Located loc (expression, expected)) : xs) = do + reportStart loc expression "example" r <- fmap lines <$> liftIO (safeEvalWith preserveIt repl expression) case r of Left err -> do reportError loc expression err Right actual -> case mkResult expected actual of NotEqual err -> do - reportFailure loc expression - mapM_ report err + reportFailure loc expression err Equal -> do reportSuccess go xs go [] = return () - -safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String) -safeEvalWith preserveIt - | preserveIt = Interpreter.safeEvalIt - | otherwise = Interpreter.safeEval diff --git a/src/Runner/Example.hs b/src/Runner/Example.hs --- a/src/Runner/Example.hs +++ b/src/Runner/Example.hs @@ -3,62 +3,151 @@ , mkResult ) where +import Imports + import Data.Char -import Data.List +import Data.List (isPrefixOf) import Util import 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 - | expected `matches` actual = Equal - | otherwise = NotEqual (formatNotEqual expected actual) +mkResult expected_ actual_ = + case expected `matches` actual of + Full -> Equal + Partial partial -> NotEqual (formatNotEqual expected actual partial) where - chunksMatch :: [LineChunk] -> String -> Bool - chunksMatch [] "" = True - chunksMatch [LineChunk xs] ys = stripEnd xs == stripEnd ys + -- 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 = - x `isPrefixOf` ys && xs `chunksMatch` drop (length x) 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) = - xs `chunksMatch` ys || zs `chunksMatch` ys - chunksMatch _ _ = False + -- 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 "" "") - matches :: ExpectedResult -> [String] -> Bool - matches (ExpectedLine x : xs) (y : ys) = x `chunksMatch` y && xs `matches` ys - matches (WildCardLine : xs) ys | xs `matches` ys = True - matches zs@(WildCardLine : _) (_ : ys) = zs `matches` ys - matches [] [] = True - matches [] _ = False - matches _ [] = False + 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 "") -formatNotEqual :: ExpectedResult -> [String] -> [String] -formatNotEqual expected_ actual = formatLines "expected: " expected ++ formatLines " but got: " actual +-- 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_ - -- use show to escape special characters in output lines if any output line - -- contains any unsafe character - escapeOutput - | any (not . isSafe) (concat $ expected ++ actual) = map show - | otherwise = id - - isSafe :: Char -> Bool - isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) - formatLines :: String -> [String] -> [String] - formatLines message xs = case escapeOutput xs of + 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/Sandbox.hs b/src/Sandbox.hs deleted file mode 100644 --- a/src/Sandbox.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} - -module Sandbox - ( getSandboxArguments - , getPackageDbDir - , getSandboxConfigFile - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor ((<$>)) -#endif -import Control.Exception as E (catch, SomeException, throwIO) -import Data.Char (isSpace) -import Data.List (isPrefixOf, tails) -import System.Directory (getCurrentDirectory, doesFileExist) -import System.FilePath ((), takeDirectory, takeFileName) - -configFile :: String -configFile = "cabal.sandbox.config" - -pkgDbKey :: String -pkgDbKey = "package-db:" - -pkgDbKeyLen :: Int -pkgDbKeyLen = length pkgDbKey - -getSandboxArguments :: IO [String] -getSandboxArguments = (sandboxArguments <$> getPkgDb) `E.catch` handler - where - getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir - handler :: SomeException -> IO [String] - handler _ = return [] - --- | Find a sandbox config file by tracing ancestor directories. --- Exception is thrown if not found -getSandboxConfigFile :: FilePath -> IO FilePath -getSandboxConfigFile dir = do - let cfile = dir configFile - exist <- doesFileExist cfile - if exist then - return cfile - else do - let dir' = takeDirectory dir - if dir == dir' then - throwIO $ userError "sandbox config file not found" - else - getSandboxConfigFile dir' - --- | Extract a package db directory from the sandbox config file. --- Exception is thrown if the sandbox config file is broken. -getPackageDbDir :: FilePath -> IO FilePath -getPackageDbDir sconf = do - -- Be strict to ensure that an error can be caught. - !path <- extractValue . parse <$> readFile sconf - return path - where - parse = head . filter ("package-db:" `isPrefixOf`) . lines - extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen - --- | Adding necessary GHC options to the package db. --- Exception is thrown if the string argument is incorrect. --- --- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" --- ["-no-user-package-db","-package-db","/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"] --- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d" --- ["-no-user-package-conf","-package-conf","/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"] -sandboxArguments :: FilePath -> [String] -sandboxArguments pkgDb = [noUserPkgDbOpt, pkgDbOpt, pkgDb] - where - ver = extractGhcVer pkgDb - (pkgDbOpt,noUserPkgDbOpt) - | ver < 706 = ("-package-conf","-no-user-package-conf") - | otherwise = ("-package-db", "-no-user-package-db") - --- | Extracting GHC version from the path of package db. --- Exception is thrown if the string argument is incorrect. --- --- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" --- 706 -extractGhcVer :: String -> Int -extractGhcVer dir = ver - where - file = takeFileName dir - findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails - (verStr1,_:left) = break (== '.') $ findVer file - (verStr2,_) = break (== '.') left - ver = read verStr1 * 100 + read verStr2 diff --git a/src/Test/DocTest.hs b/src/Test/DocTest.hs --- a/src/Test/DocTest.hs +++ b/src/Test/DocTest.hs @@ -1,5 +1,4 @@ module Test.DocTest ( doctest ) where - -import Run +import Test.DocTest.Internal.Run diff --git a/src/Test/DocTest/Internal/Cabal.hs b/src/Test/DocTest/Internal/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Cabal.hs @@ -0,0 +1,10 @@ +module Test.DocTest.Internal.Cabal ( + doctest +) where + +import Imports + +import qualified Cabal + +doctest :: [String] -> IO () +doctest = Cabal.externalCommand diff --git a/src/Test/DocTest/Internal/Extract.hs b/src/Test/DocTest/Internal/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Extract.hs @@ -0,0 +1,4 @@ +module Test.DocTest.Internal.Extract ( + module Extract +) where +import Extract diff --git a/src/Test/DocTest/Internal/Location.hs b/src/Test/DocTest/Internal/Location.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Location.hs @@ -0,0 +1,4 @@ +module Test.DocTest.Internal.Location ( + module Location +) where +import Location diff --git a/src/Test/DocTest/Internal/Parse.hs b/src/Test/DocTest/Internal/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Parse.hs @@ -0,0 +1,4 @@ +module Test.DocTest.Internal.Parse ( + module Parse +) where +import Parse diff --git a/src/Test/DocTest/Internal/Run.hs b/src/Test/DocTest/Internal/Run.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Internal/Run.hs @@ -0,0 +1,4 @@ +module Test.DocTest.Internal.Run ( + module Run +) where +import Run diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -1,4 +1,7 @@ module Util where + +import Imports + import Data.Char convertDosLineEndings :: String -> String diff --git a/test/Cabal/OptionsSpec.hs b/test/Cabal/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cabal/OptionsSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +module Cabal.OptionsSpec (spec) where + +import Imports + +import Test.Hspec + +import System.IO +import System.IO.Silently +import System.Exit +import System.Process +import Data.Set ((\\)) +import qualified Data.Set as Set + +import qualified Cabal.ReplOptionsSpec as Repl + +import Cabal.Options + +spec :: Spec +spec = do + describe "replOnlyOptions" $ do + it "is the set of options that are unique to 'cabal repl'" $ do + build <- Set.fromList . lines <$> readProcess "cabal" ["build", "--list-options"] "" + repl <- Set.fromList . lines <$> readProcess "cabal" ["repl", "--list-options"] "" + Set.toList replOnlyOptions `shouldMatchList` Set.toList (repl \\ build) + + describe "rejectUnsupportedOptions" $ do + it "produces error messages that are consistent with 'cabal repl'" $ do + let + shouldFail :: HasCallStack => String -> IO a -> Expectation + shouldFail command action = do + hCapture_ [stderr] (action `shouldThrow` (== ExitFailure 1)) + `shouldReturn` "Error: cabal: unrecognized '" <> command <> "' option `--installdir'\n" + +#ifndef mingw32_HOST_OS + shouldFail "repl" $ call "cabal" ["repl", "--installdir"] +#endif + shouldFail "doctest" $ rejectUnsupportedOptions ["--installdir"] + + context "with --list-options" $ do + it "lists supported command-line options" $ do + repl <- Set.fromList . lines <$> readProcess "cabal" ["repl", "--list-options"] "" + doctest <- Set.fromList . lines <$> capture_ (rejectUnsupportedOptions ["--list-options"] `shouldThrow` (== ExitSuccess)) + Set.toList (doctest \\ repl) `shouldMatchList` [] + Set.toList (repl \\ doctest) `shouldMatchList` Set.toList Repl.unsupported + + describe "discardReplOptions" $ do + it "discards 'cabal repl'-only options" $ do + discardReplOptions [ + "-w", "ghc-9.10" + , "--build-depends=foo" + , "--build-depends", "foo" + , "-bfoo" + , "-b", "foo" + , "--disable-optimization" + , "--enable-multi-repl" + , "--repl-options", "foo" + , "--repl-options=foo" + , "--allow-newer" + ] `shouldBe` ["--with-compiler=ghc-9.10", "--disable-optimization", "--allow-newer"] diff --git a/test/Cabal/PathsSpec.hs b/test/Cabal/PathsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cabal/PathsSpec.hs @@ -0,0 +1,22 @@ +module Cabal.PathsSpec (spec) where + +import Imports + +import Test.Hspec + +import System.Directory + +import Cabal () +import Cabal.Paths + +spec :: Spec +spec = do + describe "paths" $ do + it "returns the path to 'ghc'" $ do + (paths "cabal" [] >>= doesFileExist . ghc) `shouldReturn` True + + it "returns the path to 'ghc-pkg'" $ do + (paths "cabal" [] >>= doesFileExist . ghcPkg) `shouldReturn` True + + it "returns the path to Cabal's cache directory" $ do + (paths "cabal" [] >>= doesDirectoryExist . cache) `shouldReturn` True diff --git a/test/Cabal/ReplOptionsSpec.hs b/test/Cabal/ReplOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cabal/ReplOptionsSpec.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +module Cabal.ReplOptionsSpec (spec, unsupported) where + +import Imports + +import Test.Hspec + +import Data.List +import System.Process +import Data.Set (Set) +import qualified Data.Set as Set + +import Cabal.ReplOptions + +phony :: [String] +phony = [ + "with-PROG" + , "PROG-option" + , "PROG-options" + ] + +undocumented :: Set String +undocumented = Set.fromList [ + "--enable-optimisation" + , "--disable-optimisation" + , "--haddock-hyperlink-sources" + , "--haddock-hyperlinked-source" + ] + +unsupported :: Set String +unsupported = undocumented <> Set.fromList (map ("--" <>) phony) + +spec :: Spec +spec = do + describe "options" $ do + it "is the list of documented 'repl' options" $ do + documentedOptions <- parseOptions <$> readProcess "cabal" ["help", "repl"] "" + options `shouldBe` filter (optionName >>> (`notElem` phony)) documentedOptions + + it "is consistent with 'cabal repl --list-options'" $ do + let + optionNames :: Option -> [String] + optionNames option = reverse $ "--" <> optionName option : case optionShortName option of + Nothing -> [] + Just c -> [['-', c]] + + repl <- filter (`Set.notMember` unsupported) . lines <$> readProcess "cabal" ["repl", "--list-options"] "" + concatMap optionNames options `shouldBe` repl + +parseOptions :: String -> [Option] +parseOptions = map parseOption . takeOptions + where + parseOption :: String -> Option + parseOption input = case input of + longAndHelp@('-':'-':_) -> parseLongOption Nothing longAndHelp + '-':short:',':' ':longAndHelp -> parseLongOption (Just short) longAndHelp + '-':short:'[':(breakOn ']' -> + (_arg, ']':',':' ':longAndHelp)) -> parseLongOption (Just short) longAndHelp + '-':short:' ':(breakOn ' ' -> + (arg, ' ':'o':'r':' ':(stripPrefix ('-':short:arg) -> + Just (',':' ':longAndHelp)))) -> parseLongOption (Just short) longAndHelp + _ -> err + where + parseLongOption :: Maybe Char -> String -> Option + parseLongOption short longAndHelp = case breakOnAny " [=" longAndHelp of + ('-':'-':long, ' ':help) -> accept long NoArgument help + ('-':'-':long, '[':'=': (breakOn ']' -> + (arg, ']':help))) -> accept long (OptionalArgument arg) help + ('-':'-':long, '=':(breakOn ' ' -> + (arg, ' ':help))) -> accept long (Argument arg) help + _ -> err + where + accept :: String -> Argument -> String -> Option + accept long arg help = Option long short arg (strip help) + + err :: HasCallStack => Option + err = error input + + breakOn c = break (== c) + breakOnAny xs = break (`elem` xs) + + takeOptions :: String -> [String] + takeOptions input = map strip . joinLines $ case break (== "Flags for repl:") (lines input) of + (_, "Flags for repl:" : xs) -> case break (== "") xs of + (ys, "" : _) -> ys + _ -> undefined + _ -> undefined + + joinLines :: [String] -> [String] + joinLines = go + where + go = \ case + x : y : ys | isOption y -> x : go (y : ys) + x : y : ys -> go $ (x ++ ' ' : strip y) : ys + x : xs -> x : xs + [] -> [] + + isOption = isPrefixOf " -" diff --git a/test/ExtractSpec.hs b/test/ExtractSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExtractSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module ExtractSpec (main, spec) where + +import Imports + +import Test.Hspec +import Test.HUnit + + +#if __GLASGOW_HASKELL__ < 900 +import Panic (GhcException (..)) +#else +import GHC.Utils.Panic (GhcException (..)) +#endif + +import Extract +import 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/InfoSpec.hs b/test/InfoSpec.hs new file mode 100644 --- /dev/null +++ b/test/InfoSpec.hs @@ -0,0 +1,17 @@ +module InfoSpec (spec) where + +import Imports + +import Test.Hspec + +import System.Process + +import Info (formatInfo) +import Interpreter (ghc) + +spec :: Spec +spec = do + describe "formatInfo" $ do + it "formats --info output" $ do + info <- readProcess ghc ["--info"] "" + formatInfo (read info) `shouldBe` info diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs new file mode 100644 --- /dev/null +++ b/test/InterpreterSpec.hs @@ -0,0 +1,40 @@ +module InterpreterSpec (spec) where + +import Imports + +import Test.Hspec + +import Interpreter (Interpreter, interpreterSupported, haveInterpreterKey, ghcInfo, ghc, safeEval, filterExpression) +import qualified Interpreter + +withInterpreter :: (Interpreter -> IO a) -> IO a +withInterpreter = Interpreter.withInterpreter (Interpreter.ghc, ["--interactive"]) + +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 multi-line command" + + describe "filterExpression" $ do + it "removes :set -XTemplateHaskell" $ do + filterExpression ":set -XTemplateHaskell" `shouldBe` Right "" + + it "filters -XTemplateHaskell" $ do + filterExpression ":set -XTemplateHaskell -XCPP" `shouldBe` Right ":set -XCPP" + + it "leaves :set-statement that do not set -XTemplateHaskell alone " $ do + filterExpression ":set -XFoo -XBar" `shouldBe` Right ":set -XFoo -XBar" diff --git a/test/Language/Haskell/GhciWrapperSpec.hs b/test/Language/Haskell/GhciWrapperSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/GhciWrapperSpec.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE CPP #-} +module Language.Haskell.GhciWrapperSpec (main, spec) where + +import Imports + +import Test.Hspec +import System.IO.Silently + +import Data.List + +import Language.Haskell.GhciWrapper (Interpreter, Config(..), defaultConfig, PreserveIt(..)) +import qualified Language.Haskell.GhciWrapper as Interpreter + +main :: IO () +main = hspec spec + +withInterpreterConfig :: Config -> [String] -> (Interpreter -> IO a) -> IO a +withInterpreterConfig config args = bracket (Interpreter.new config args) Interpreter.close + +withInterpreterArgs :: [String] -> ((String -> IO String) -> IO a) -> IO a +withInterpreterArgs args action = withInterpreterConfig defaultConfig args $ action . Interpreter.eval + +withInterpreter :: ((String -> IO String) -> IO a) -> IO a +withInterpreter = withInterpreterArgs [] + +spec :: Spec +spec = do + describe "evalEcho" $ do + it "prints result to stdout" $ do + withInterpreterConfig defaultConfig [] $ \ghci -> do + (capture $ Interpreter.evalEcho ghci ("putStr" ++ show "foo\nbar")) `shouldReturn` ("foo\nbar", "foo\nbar") + + describe "evalWith" $ do + context "with PreserveIt" $ do + it "preserves it" $ do + withInterpreterConfig defaultConfig [] $ \ghci -> do + Interpreter.evalWith PreserveIt ghci "23" `shouldReturn` "23\n" + Interpreter.eval ghci "it" `shouldReturn` "23\n" + + describe "eval" $ do + it "shows literals" $ withInterpreter $ \ghci -> do + ghci "23" `shouldReturn` "23\n" + + it "shows string literals containing Unicode" $ withInterpreter $ \ghci -> do + ghci "\"λ\"" `shouldReturn` "\"\\955\"\n" + + it "evaluates simple expressions" $ withInterpreter $ \ghci -> do + ghci "23 + 42" `shouldReturn` "65\n" + + it "supports let bindings" $ withInterpreter $ \ghci -> do + ghci "let x = 10" `shouldReturn` "" + ghci "x" `shouldReturn` "10\n" + + it "allows import statements" $ withInterpreter $ \ghci -> do + ghci "import Data.Maybe" `shouldReturn` "" + ghci "fromJust (Just 20)" `shouldReturn` "20\n" + + it "captures stdout" $ withInterpreter $ \ghci -> do + ghci "putStr \"foo\"" `shouldReturn` "foo" + + it "captures stdout (Unicode)" $ withInterpreter $ \ghci -> do + ghci "putStrLn \"λ\"" `shouldReturn` "λ\n" + + it "captures stdout (empty line)" $ withInterpreter $ \ghci -> do + ghci "putStrLn \"\"" `shouldReturn` "\n" + + it "captures stdout (multiple lines)" $ withInterpreter $ \ghci -> do + ghci "putStrLn \"foo\" >> putStrLn \"bar\" >> putStrLn \"baz\"" + `shouldReturn` "foo\nbar\nbaz\n" + + it "captures stderr" $ withInterpreter $ \ghci -> do + ghci "import System.IO" `shouldReturn` "" + ghci "hPutStrLn stderr \"foo\"" `shouldReturn` "foo\n" + + it "captures stderr (Unicode)" $ withInterpreter $ \ghci -> do + ghci "import System.IO" `shouldReturn` "" + ghci "hPutStrLn stderr \"λ\"" `shouldReturn` "λ\n" + + it "shows exceptions" $ withInterpreter $ \ghci -> do + ghci "import Control.Exception" `shouldReturn` "" +#if __GLASGOW_HASKELL__ >= 912 + ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n\nHasCallStack backtrace:\n throwIO, called at :25:1 in interactive:Ghci22\n\n" +#else + ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n" +#endif + + it "shows exceptions (ExitCode)" $ withInterpreter $ \ghci -> do + ghci "import System.Exit" `shouldReturn` "" + ghci "exitWith $ ExitFailure 10" `shouldReturn` "*** Exception: ExitFailure 10\n" + + it "gives an error message for identifiers that are not in scope" $ withInterpreter $ \ghci -> do + ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo") + + context "when configVerbose is True" $ do + it "prints prompt" $ do + withInterpreterConfig defaultConfig{configVerbose = True} [] $ \ghci -> do + Interpreter.eval ghci "print 23" >>= (`shouldSatisfy` + (`elem` [ "Prelude> 23\nPrelude> " + , "ghci> 23\nghci> " + ])) + + context "with -XOverloadedStrings, -Wall and -Werror" $ do + it "does not fail on marker expression (bug fix)" $ withInterpreter $ \ghci -> do + ghci ":seti -XOverloadedStrings -Wall -Werror" `shouldReturn` "" + ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" + + context "with NoImplicitPrelude" $ do + it "works" $ withInterpreterArgs ["-XNoImplicitPrelude"] $ \ghci -> do + ghci "putStrLn \"foo\"" >>= (`shouldContain` "Variable not in scope: putStrLn") + ghci "23" `shouldReturn` "23\n" + + context "with a strange String type" $ do + it "works" $ withInterpreter $ \ghci -> do + ghci "type String = Int" `shouldReturn` "" + ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" diff --git a/test/LocationSpec.hs b/test/LocationSpec.hs new file mode 100644 --- /dev/null +++ b/test/LocationSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} + +module LocationSpec (main, spec) where + +import Imports + +import Test.Hspec + +import 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,204 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +module MainSpec (main, spec) where + +import Imports + +import Test.Hspec +import Test.HUnit (assertEqual, Assertion) + +import System.Directory (getCurrentDirectory, setCurrentDirectory) +import System.FilePath +import Run hiding (doctest, doctestWith) +import System.IO.Silently +import System.IO + +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory workingDir action = do + bracket getCurrentDirectory setCurrentDirectory $ \_ -> do + setCurrentDirectory workingDir + action + +doctest :: HasCallStack => FilePath -> [String] -> Summary -> Assertion +doctest = doctestWith False False + +doctestWithPreserveIt :: HasCallStack => FilePath -> [String] -> Summary -> Assertion +doctestWithPreserveIt = doctestWith True False + +doctestWithFailFast :: HasCallStack => FilePath -> [String] -> Summary -> Assertion +doctestWithFailFast = doctestWith False True + +doctestWith :: HasCallStack => Bool -> Bool -> FilePath -> [String] -> Summary -> Assertion +doctestWith preserveIt failFast workingDir ghcOptions expected = do + actual <- withCurrentDirectory ("test/integration" workingDir) (hSilence [stderr] $ doctestWithResult defaultConfig {ghcOptions, preserveIt, failFast}) + assertEqual label (formatSummary expected) (formatSummary actual) + where + label = workingDir ++ " " ++ show ghcOptions + +cases :: Int -> Summary +cases n = Summary n n 0 0 + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "doctest" $ do + it "testSimple" $ do + doctest "." ["testSimple/Fib.hs"] + (cases 1) + + it "it-variable" $ do + doctestWithPreserveIt "." ["it/Foo.hs"] + (cases 5) + + it "it-variable in $setup" $ do + doctestWithPreserveIt "." ["it/Setup.hs"] + (cases 5) + + it "failing" $ do + doctest "." ["failing/Foo.hs"] + (cases 1) {sFailures = 1} + + it "skips subsequent examples from the same group if an example fails" $ do + doctest "." ["failing-multiple/Foo.hs"] + (cases 4) {sTried = 2, sFailures = 1} + + context "without --fail-fast" $ do + it "continuous even if some tests fail" $ do + doctest "fail-fast" ["Foo.hs"] + (cases 4) {sTried = 4, sFailures = 1} + + context "with --fail-fast" $ do + it "stops after the first failure" $ do + doctestWithFailFast "fail-fast" ["Foo.hs"] + (cases 4) {sTried = 2, sFailures = 1} + + it "stops after failures in $setup" $ do + doctestWithFailFast "fail-fast" ["SetupFoo.hs"] + (cases 6) {sTried = 1, sFailures = 1} + + it "testImport" $ do + doctest "testImport" ["ModuleA.hs"] + (cases 3) + doctest ".." ["-iintegration/testImport", "integration/testImport/ModuleA.hs"] + (cases 3) + + it "testCommentLocation" $ do + doctest "." ["testCommentLocation/Foo.hs"] + (cases 11) + + it "testPutStr" $ do + doctest "testPutStr" ["Fib.hs"] + (cases 3) + + it "fails on multi-line expressions, introduced with :{" $ do + doctest "testFailOnMultiline" ["Fib.hs"] + (cases 2) {sErrors = 2} + + it "testBlankline" $ do + doctest "testBlankline" ["Fib.hs"] + (cases 1) + + it "examples from the same Haddock comment share the same scope" $ do + doctest "testCombinedExample" ["Fib.hs"] + (cases 4) + + it "testDocumentationForArguments" $ do + doctest "testDocumentationForArguments" ["Fib.hs"] + (cases 1) + + it "template-haskell" $ do + doctest "template-haskell" ["Foo.hs"] + (cases 2) + + it "handles source files with CRLF line endings" $ do + doctest "dos-line-endings" ["Fib.hs"] + (cases 1) + + it "runs $setup before each test group" $ do + doctest "setup" ["Foo.hs"] + (cases 2) + + it "skips subsequent tests from a module, if $setup fails" $ do + doctest "setup-skip-on-failure" ["Foo.hs"] + (cases 3) {sTried = 1, sFailures = 1} + + -- Andreas, 2021-02-27, see issue #294. + -- This test case contains a hard-wired path that does not work + -- with v2-cabal. + -- I tested it under v2-cabal with a very non-portable path. + -- Deactivating the test case until a systematic solution is found... + -- + -- it "works with additional object files" $ do + -- -- -- Path for v1-cabal: + -- -- doctest "with-cbits" ["Bar.hs", "../../../dist/build/spec/spec-tmp/test/integration/with-cbits/foo.o"] + -- -- -- Path for v2-cabal with ghc-9.0.1 + -- -- doctest "with-cbits" ["Bar.hs", "../../../dist-newstyle/build/x86_64-osx/ghc-9.0.1/doctest-0.19/t/spec/build/spec/spec-tmp/Test/integration/with-cbits/foo.o"] + -- (cases 1) + + it "ignores trailing whitespace when matching test output" $ do + doctest "trailing-whitespace" ["Foo.hs"] + (cases 1) + + describe "doctest as a runner for QuickCheck properties" $ do + it "runs a boolean property" $ do + doctest "property-bool" ["Foo.hs"] + (cases 1) + + it "runs an explicitly quantified property" $ do + doctest "property-quantified" ["Foo.hs"] + (cases 1) + + it "runs an implicitly quantified property" $ do + doctest "property-implicitly-quantified" ["Foo.hs"] + (cases 1) + + it "reports a failing property" $ do + doctest "property-failing" ["Foo.hs"] + (cases 1) {sFailures = 1} + + it "runs a boolean property with an explicit type signature" $ do + doctest "property-bool-with-type-signature" ["Foo.hs"] + (cases 1) + + it "runs $setup before each property" $ do + doctest "property-setup" ["Foo.hs"] + (cases 3) + + describe "doctest (regression tests)" $ do + it "bugfixWorkingDirectory" $ do + doctest "bugfixWorkingDirectory" ["Fib.hs"] + (cases 1) + doctest "bugfixWorkingDirectory" ["examples/Fib.hs"] + (cases 2) + + it "bugfixOutputToStdErr" $ do + doctest "bugfixOutputToStdErr" ["Fib.hs"] + (cases 2) + + it "bugfixImportHierarchical" $ do + doctest "bugfixImportHierarchical" ["ModuleA.hs", "ModuleB.hs"] + (cases 3) + + it "bugfixMultipleModules" $ do + doctest "bugfixMultipleModules" ["ModuleA.hs"] + (cases 5) + + it "testCPP" $ do + doctest "testCPP" ["-cpp", "Foo.hs"] + (cases 1) {sFailures = 1} + doctest "testCPP" ["-cpp", "-DFOO", "Foo.hs"] + (cases 1) + + it "template-haskell-bugfix" $ do + doctest "template-haskell-bugfix" ["Main.hs"] + (cases 2) + + it "doesn't clash with user bindings of stdout/stderr" $ do + doctest "local-stderr-binding" ["A.hs"] + (cases 1) + + it "doesn't get confused by doctests using System.IO imports" $ do + doctest "system-io-imported" ["A.hs"] + (cases 1) diff --git a/test/OptionsSpec.hs b/test/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/OptionsSpec.hs @@ -0,0 +1,108 @@ +module OptionsSpec (spec) where + +import Imports + +import Data.List + +import Test.Hspec +import Test.QuickCheck hiding (verbose) + +import Options + +newtype NonInteractive = NonInteractive String + deriving (Eq, Show) + +instance Arbitrary NonInteractive where + arbitrary = NonInteractive <$> elements (nonInteractiveGhcOptions \\ ["--info"]) + +spec :: Spec +spec = do + describe "parseOptions" $ do + let + run :: [String] -> Run + run ghcOptions = defaultRun { + runWarnings = ["WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."] + , runMagicMode = True + , runConfig = defaultConfig { ghcOptions } + } + + it "strips --optghc" $ + parseOptions ["--optghc", "foobar"] `shouldBe` Result (run ["foobar"]) + + it "strips --optghc=" $ + parseOptions ["--optghc=foobar"] `shouldBe` Result (run ["foobar"]) + + context "with ghc options that are not valid with --interactive" $ do + it "returns ProxyToGhc" $ do + property $ \ (NonInteractive x) xs -> do + let options = x : xs + parseOptions options `shouldBe` ProxyToGhc options + + context "with --interactive" $ do + let options = ["--interactive", "--foo", "--bar"] + + it "disables magic mode" $ do + runMagicMode <$> parseOptions options `shouldBe` Result False + + it "filters out --interactive" $ do + ghcOptions . runConfig <$> parseOptions options `shouldBe` Result ["--foo", "--bar"] + + it "accepts --fast" $ do + fastMode . runConfig <$> parseOptions ("--fast" : options) `shouldBe` Result True + + describe "--no-magic" $ do + context "without --no-magic" $ do + it "enables magic mode" $ do + runMagicMode <$> parseOptions [] `shouldBe` Result True + + context "with --no-magic" $ do + it "disables magic mode" $ do + runMagicMode <$> parseOptions ["--no-magic"] `shouldBe` Result False + + describe "--fast" $ do + context "without --fast" $ do + it "disables fast mode" $ do + fastMode . runConfig <$> parseOptions [] `shouldBe` Result False + + context "with --fast" $ do + it "enables fast mode" $ do + fastMode . runConfig <$> parseOptions ["--fast"] `shouldBe` Result True + + describe "--preserve-it" $ do + context "without --preserve-it" $ do + it "does not preserve the `it` variable" $ do + preserveIt . runConfig <$> parseOptions [] `shouldBe` Result False + + context "with --preserve-it" $ do + it "preserves the `it` variable" $ do + preserveIt . runConfig <$> parseOptions ["--preserve-it"] `shouldBe` Result True + + describe "--fail-fast" $ do + context "without --fail-fast" $ do + it "disables fail-fast mode" $ do + failFast . runConfig <$> parseOptions [] `shouldBe` Result False + + context "with --fail-fast" $ do + it "enables fail-fast mode" $ do + failFast . runConfig <$> parseOptions ["--fail-fast"] `shouldBe` Result True + + context "with --help" $ do + it "outputs usage information" $ do + parseOptions ["--help"] `shouldBe` Output usage + + context "with --version" $ do + it "outputs version information" $ do + parseOptions ["--version"] `shouldBe` Output versionInfo + + context "with --info" $ do + it "outputs machine readable version information" $ do + parseOptions ["--info"] `shouldBe` Output info + + describe "--verbose" $ do + context "without --verbose" $ do + it "is not verbose by default" $ do + verbose . runConfig <$> parseOptions [] `shouldBe` Result False + + context "with --verbose" $ do + it "parses verbose option" $ do + verbose . runConfig <$> parseOptions ["--verbose"] `shouldBe` Result True diff --git a/test/PackageDBsSpec.hs b/test/PackageDBsSpec.hs new file mode 100644 --- /dev/null +++ b/test/PackageDBsSpec.hs @@ -0,0 +1,40 @@ +module PackageDBsSpec (main, spec) where + +import Imports + +import qualified Control.Exception as E +import Data.List (intercalate) +import PackageDBs +import System.Environment +import System.FilePath (searchPathSeparator) +import Test.Hspec + +import Test.Mockery.Directory + +main :: IO () +main = hspec spec + +withEnv :: String -> String -> IO a -> IO a +withEnv k v action = E.bracket save restore $ \_ -> do + setEnv k v >> action + where + save = lookup k <$> getEnvironment + restore = maybe (unsetEnv k) (setEnv k) + +clearEnv :: IO a -> IO a +clearEnv = + withEnv "GHC_PACKAGE_PATH" "" + +combineDirs :: [FilePath] -> String +combineDirs = intercalate [searchPathSeparator] + +spec :: Spec +spec = around_ clearEnv $ do + describe "getPackageDBsFromEnv" $ do + around_ (inTempDirectory) $ do + it "uses global and user when no env used" $ do + getPackageDBsFromEnv `shouldReturn` PackageDBs True True [] + + it "respects GHC_PACKAGE_PATH" $ + withEnv "GHC_PACKAGE_PATH" (combineDirs ["foo", "bar", ""]) $ do + getPackageDBsFromEnv `shouldReturn` PackageDBs False True ["foo", "bar"] diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParseSpec.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedStrings #-} +module ParseSpec (main, spec) where + +import Imports + +import Test.Hspec +import Data.String +import Data.String.Builder (Builder, build) +import Control.Monad.Trans.Writer + +import Parse +import 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 "extractDocTests" $ do + it "extracts properties from a module" $ do + extractDocTests ["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 + extractDocTests ["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 + extractDocTests ["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 + extractDocTests ["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 + extractDocTests ["test/parse/no-examples/Fib.hs"] >>= (`shouldBe` []) + + it "sets setup code to Nothing, if it does not contain any tests" $ do + extractDocTests ["test/parse/setup-empty/Foo.hs"] `shouldGive` do + module_ "Foo" $ do + group $ do + ghci "foo" + "23" + + it "keeps modules that only contain setup code" $ do + extractDocTests ["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,126 @@ +{-# LANGUAGE OverloadedStrings #-} +module PropertySpec (spec) where + +import Imports + +import Test.Hspec +import Data.String.Builder + +import Property +import Interpreter (Interpreter) +import qualified Interpreter + +withInterpreter :: (Interpreter -> IO a) -> IO a +withInterpreter = Interpreter.withInterpreter (Interpreter.ghc, ["--interactive"]) + +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,187 @@ +{-# LANGUAGE CPP #-} +module RunSpec (main, spec) where + +import Imports + +import Test.Hspec +import System.Exit + +import qualified Control.Exception as E +import System.FilePath +import System.Directory (getCurrentDirectory, setCurrentDirectory) +import System.IO.Temp (withSystemTempDirectory) +import Data.List (isPrefixOf, sort) + +import System.IO.Silently +import System.IO (stderr) +import qualified Options + +import Run + +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory workingDir action = do + E.bracket getCurrentDirectory setCurrentDirectory $ \_ -> do + setCurrentDirectory workingDir + action + +main :: IO () +main = hspec spec + + +removeLoadedPackageEnvironment :: String -> String +#if __GLASGOW_HASKELL__ < 810 +removeLoadedPackageEnvironment = unlines . filter (not . isPrefixOf "Loaded package environment from ") . lines +#else +removeLoadedPackageEnvironment = id +#endif + +verboseFibOutput :: String +verboseFibOutput = unlines [ + "### Started execution at test/integration/testSimple/Fib.hs:5." + , "### example:" + , "fib 10" + , "### Successful!" + , "" + , "# Final summary:" + , "Examples: 1 Tried: 1 Errors: 0 Failures: 0" + ] + +spec :: Spec +spec = do + describe "doctest" $ do + it "exits with ExitFailure if at least one test case fails" $ do + hSilence [stderr] (doctest ["test/integration/failing/Foo.hs"]) `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 "accepts arbitrary GHC options" $ do + hSilence [stderr] $ doctest ["-cpp", "-DFOO", "test/integration/test-options/Foo.hs"] + + it "accepts GHC options with --optghc" $ do + hSilence [stderr] $ doctest ["--optghc=-cpp", "--optghc=-DFOO", "test/integration/test-options/Foo.hs"] + + it "prints a deprecation message for --optghc" $ do + (r, _) <- hCapture [stderr] $ doctest ["--optghc=-cpp", "--optghc=-DFOO", "test/integration/test-options/Foo.hs"] + lines r `shouldSatisfy` isPrefixOf [ + "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options" + , "directly." + ] + + 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) + removeLoadedPackageEnvironment r `shouldBe` unlines [ + "doctest: unrecognized option `--foo'" + , "Try `doctest --help' for more information." + ] + + it "interprets GHC response files" $ do + withSystemTempDirectory "hspec" $ \ dir -> do + let file = dir "response-file" + writeFile file $ unlines [ + "test/integration/testSimple/Fib.hs" + ] + (r, ()) <- hCapture [stderr] $ doctest ["--verbose", '@':file] + removeLoadedPackageEnvironment r `shouldBe` verboseFibOutput + + it "prints verbose description of a specification" $ do + (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "test/integration/testSimple/Fib.hs"] + removeLoadedPackageEnvironment r `shouldBe` verboseFibOutput + + it "prints verbose description of a property" $ do + (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "test/integration/property-bool/Foo.hs"] + removeLoadedPackageEnvironment r `shouldBe` unlines [ + "### Started execution at test/integration/property-bool/Foo.hs:4." + , "### property:" + , "True" + , "### Successful!" + , "" + , "# Final summary:" + , "Examples: 1 Tried: 1 Errors: 0 Failures: 0" + ] + + it "prints verbose error" $ do + (r, e) <- hCapture [stderr] . E.try $ doctest ["--verbose", "test/integration/failing/Foo.hs"] + e `shouldBe` Left (ExitFailure 1) + removeLoadedPackageEnvironment 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 Failures: 1" + ] + +#if __GLASGOW_HASKELL__ >= 802 + it "can deal with potentially problematic GHC options" $ do + hSilence [stderr] $ doctest ["-fdiagnostics-color=always", "test/integration/color/Foo.hs"] +#endif + + describe "doctestWithResult" $ do + context "on parse error" $ do + let + action :: IO Result + action = withCurrentDirectory "test/integration/parse-error" $ do + doctestWithResult defaultConfig { + ghcOptions = [ + "Foo.hs" + + -- This is necessary due to: + -- + -- https://gitlab.haskell.org/ghc/ghc/-/commit/88f38b03025386f0f1e8f5861eed67d80495168a + -- + -- It will be fixed by: + -- + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15995 + -- + , "-fdiagnostics-color=never" +#if __GLASGOW_HASKELL__ >= 910 + , "-fprint-error-index-links=never" +#endif + ] + } + + it "aborts with (ExitFailure 1)" $ do + hSilence [stderr] action `shouldThrow` (== ExitFailure 1) + + it "prints a useful error message" $ do + (r, _) <- hCapture [stderr] (E.try action :: IO (Either ExitCode Summary)) + removeLoadedPackageEnvironment r `shouldBe` unlines ( +#if __GLASGOW_HASKELL__ < 910 + "" : +#endif +#if __GLASGOW_HASKELL__ >= 906 + [ "Foo.hs:6:1: error: [GHC-58481]" +#else + [ "Foo.hs:6:1: error:" +#endif + , " parse error (possibly incorrect indentation or mismatched brackets)" +#if __GLASGOW_HASKELL__ >= 910 + , "" +#endif + ]) + + describe "expandDirs" $ do + it "expands a directory" $ do + res <- expandDirs "example" + sort res `shouldBe` + [ "example" "src" "Example.hs" + , "example" "test" "doctests.hs" + ] + it "ignores files" $ do + res <- expandDirs "doctest.cabal" + res `shouldBe` ["doctest.cabal"] + it "ignores random things" $ do + let x = "foo bar baz bin" + res <- expandDirs x + res `shouldBe` [x] 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,162 @@ +{-# LANGUAGE OverloadedStrings #-} +module Runner.ExampleSpec (main, spec) where + +import Imports + +import Data.String +import Test.Hspec +import Test.Hspec.Core.QuickCheck (modifyMaxSize) +import Test.QuickCheck + +import Parse +import 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,44 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +module RunnerSpec (spec) where + +import Imports + +import Test.Hspec + +import Data.IORef +import System.IO +import System.IO.Silently (hCapture_) +import Runner + +capture :: Interactive -> Report () -> IO String +capture interactive action = do + ref <- newIORef mempty + hCapture_ [stderr] (runReport (ReportState interactive NoFailFast NonVerbose ref) action) + +spec :: Spec +spec = do + describe "report" $ do + context "when mode is interactive" $ do + it "writes to stderr" $ do + capture Interactive $ do + report "foobar" + `shouldReturn` "foobar\n" + + context "when mode is non-interactive" $ do + it "writes to stderr" $ do + capture NonInteractive $ do + report "foobar" + `shouldReturn` "foobar\n" + + describe "report_" $ do + context "when mode is interactive" $ do + it "writes transient output to stderr" $ do + capture Interactive $ do + reportTransient "foobar" + `shouldReturn` "foobar\r \r" + + context "when mode is non-interactive" $ do + it "is ignored" $ do + capture NonInteractive $ do + reportTransient "foobar" + `shouldReturn` "" diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilSpec.hs @@ -0,0 +1,23 @@ +module UtilSpec (main, spec) where + +import Imports + +import Test.Hspec + +import 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 deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Main where - -import Test.DocTest - -main :: IO () -main = doctest [ - "-packageghc" - , "-isrc" - , "-ighci-wrapper/src" - , "-idist/build/autogen/" - , "-optP-include" - , "-optPdist/build/autogen/cabal_macros.h" - , "src/Run.hs" - , "src/PackageDBs.hs" - ] diff --git a/test/extract/argument-list/Foo.hs b/test/extract/argument-list/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/argument-list/Foo.hs @@ -0,0 +1,6 @@ +module Foo where + +foo :: Int -- ^ doc for arg1 + -> Int -- ^ doc for arg2 + -> Int +foo = undefined diff --git a/test/extract/comment-order/Foo.hs b/test/extract/comment-order/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/comment-order/Foo.hs @@ -0,0 +1,28 @@ +-- | module header +module Foo ( + +-- * some heading +-- | export list 1 + foo + +-- * some other heading +-- | export list 2 +, bar + +-- * one more heading +-- $foo +, baz +) where + +-- | foo +foo :: Int +foo = 23 + +-- $foo named chunk + +-- | bar +bar :: Int +bar = 23 + +baz :: Int +baz = 23 diff --git a/test/extract/declaration/Foo.hs b/test/extract/declaration/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/declaration/Foo.hs @@ -0,0 +1,5 @@ +module Foo where + +-- | Some documentation +foo :: Int +foo = 23 diff --git a/test/extract/dos-line-endings/Foo.hs b/test/extract/dos-line-endings/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/dos-line-endings/Foo.hs @@ -0,0 +1,8 @@ +module Foo where + +-- | +-- foo +-- bar +-- baz +foo :: Int +foo = 23 diff --git a/test/extract/export-list/Foo.hs b/test/extract/export-list/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/export-list/Foo.hs @@ -0,0 +1,12 @@ +module Foo ( +-- * some heading +-- | documentation from export list + foo +, bar +) where + +foo :: Int +foo = 23 + +bar :: Int +bar = 23 diff --git a/test/extract/imported-module/Bar.hs b/test/extract/imported-module/Bar.hs new file mode 100644 --- /dev/null +++ b/test/extract/imported-module/Bar.hs @@ -0,0 +1,7 @@ +module Bar where + +import Baz + +-- | documentation for bar +bar :: Int +bar = 23 diff --git a/test/extract/imported-module/Baz.hs b/test/extract/imported-module/Baz.hs new file mode 100644 --- /dev/null +++ b/test/extract/imported-module/Baz.hs @@ -0,0 +1,5 @@ +module Baz where + +-- | documentation for baz +baz :: Int +baz = 23 diff --git a/test/extract/module-header/Foo.hs b/test/extract/module-header/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/module-header/Foo.hs @@ -0,0 +1,5 @@ +-- | Some documentation +module Foo where + +foo :: Int +foo = 23 diff --git a/test/extract/named-chunks/Foo.hs b/test/extract/named-chunks/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/named-chunks/Foo.hs @@ -0,0 +1,15 @@ +module Foo ( + foo +, bar +) where + +-- $foo named chunk foo + +-- $bar +-- named chunk bar + +foo :: Int +foo = 23 + +bar :: Int +bar = 23 diff --git a/test/extract/regression/Fixity.hs b/test/extract/regression/Fixity.hs new file mode 100644 --- /dev/null +++ b/test/extract/regression/Fixity.hs @@ -0,0 +1,4 @@ +module Fixity where + +foo :: Int +foo = 23 + 42 diff --git a/test/extract/regression/ForeignImport.hs b/test/extract/regression/ForeignImport.hs new file mode 100644 --- /dev/null +++ b/test/extract/regression/ForeignImport.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module ForeignImport where +import Foreign.C + +import Prelude hiding (sin) + +-- pure function +foreign import ccall "sin" c_sin :: CDouble -> CDouble +sin :: Double -> Double +sin d = realToFrac (c_sin (realToFrac d)) diff --git a/test/extract/regression/ParallelListComp.hs b/test/extract/regression/ParallelListComp.hs new file mode 100644 --- /dev/null +++ b/test/extract/regression/ParallelListComp.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ParallelListComp #-} +module ParallelListComp where + +foo :: [Int] +foo = [x+y | x <- [1,2,3] | y <- [4,5,6]] diff --git a/test/extract/regression/ParallelListCompClass.hs b/test/extract/regression/ParallelListCompClass.hs new file mode 100644 --- /dev/null +++ b/test/extract/regression/ParallelListCompClass.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ParallelListComp #-} +module ParallelListCompClass where + +class Foo a where + foo :: a -> [Int] + +instance Foo Int where + foo _ = [x+y | x <- [1,2,3] | y <- [4,5,6]] diff --git a/test/extract/regression/RewriteRules.hs b/test/extract/regression/RewriteRules.hs new file mode 100644 --- /dev/null +++ b/test/extract/regression/RewriteRules.hs @@ -0,0 +1,7 @@ +module RewriteRules (foo) where + +{-# RULES "map/append" forall f xs ys. map f (xs ++ ys) = map f xs ++ map f ys #-} + +-- | doc for foo +foo :: Int +foo = 23 diff --git a/test/extract/regression/RewriteRulesWithSigs.hs b/test/extract/regression/RewriteRulesWithSigs.hs new file mode 100644 --- /dev/null +++ b/test/extract/regression/RewriteRulesWithSigs.hs @@ -0,0 +1,7 @@ +module RewriteRulesWithSigs (foo) where + +{-# RULES "map/append" forall f (xs :: [Int]) ys. map f (xs ++ ys) = map f xs ++ map f ys #-} + +-- | doc for foo +foo :: Int +foo = 23 diff --git a/test/extract/setup/Foo.hs b/test/extract/setup/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/setup/Foo.hs @@ -0,0 +1,16 @@ +module Foo where + +-- $setup +-- some setup code + +-- | foo +foo :: Int +foo = 42 + +-- | bar +bar :: Int +bar = 42 + +-- | baz +baz :: Int +baz = 42 diff --git a/test/extract/th/Bar.hs b/test/extract/th/Bar.hs new file mode 100644 --- /dev/null +++ b/test/extract/th/Bar.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Bar where + +import Language.Haskell.TH.Lib (ExpQ) + +bar :: ExpQ +bar = [| 23 |] diff --git a/test/extract/th/Foo.hs b/test/extract/th/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/th/Foo.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Foo where + +import Bar + +-- | some documentation +foo :: Int +foo = $(bar) diff --git a/test/extract/type-class-args/Foo.hs b/test/extract/type-class-args/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/type-class-args/Foo.hs @@ -0,0 +1,8 @@ +module Foo where + + +class Foo a where + + bar :: a -- ^ foo + -> Int -- ^ bar + -> String diff --git a/test/extract/type-class/Foo.hs b/test/extract/type-class/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/type-class/Foo.hs @@ -0,0 +1,7 @@ +module Foo where + + +class ToString a where + + -- | Convert given value to a string. + toString :: a -> String diff --git a/test/extract/type-families/Foo.hs b/test/extract/type-families/Foo.hs new file mode 100644 --- /dev/null +++ b/test/extract/type-families/Foo.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module Foo where + +type family Foo a + +type instance Foo Int = Int 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,6 @@ +-- | +-- >>> fib 10 +-- 55 +module ModuleA where + +import Foo.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 Foo.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,6 @@ +-- | +-- >>> fib 10 +-- 55 +module ModuleA where + +import ModuleB 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,20 @@ +module ModuleB (fib) where + + +-- | +-- >>> fib 10 +-- 55 +-- >>> fib 5 +-- 5 +fib :: Integer -> Integer +fib = foo + +-- | +-- >>> 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 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/bugfixWorkingDirectory/Fib.hs b/test/integration/bugfixWorkingDirectory/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/bugfixWorkingDirectory/Fib.hs @@ -0,0 +1,10 @@ +module Fib where + +-- | Calculate Fibonacci number of given 'Num'. +-- +-- >>> bar +-- 10 +fib :: (Num t, Num t1) => t -> t1 +fib _ = undefined + +bar = 10 diff --git a/test/integration/bugfixWorkingDirectory/description b/test/integration/bugfixWorkingDirectory/description new file mode 100644 --- /dev/null +++ b/test/integration/bugfixWorkingDirectory/description @@ -0,0 +1,10 @@ +Put the following files in the current working directory: + + ./Fib.hs + ./examples/Fib.hs + +Now run: + + doctest examples/Fib.hs + +Erroneously `./Fib.hs` will be tested instead of `examples/Fib.hs`. diff --git a/test/integration/bugfixWorkingDirectory/examples/Fib.hs b/test/integration/bugfixWorkingDirectory/examples/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/bugfixWorkingDirectory/examples/Fib.hs @@ -0,0 +1,22 @@ +module Fib where + + +-- | Calculate Fibonacci number of given 'Num'. +-- +-- Examples: +-- +-- >>> fib 10 +-- 55 +fib :: Integer -> Integer +fib 0 = 0 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) + +-- | +-- +-- Examples: +-- +-- >>> fib 10 +-- 55 +foo :: Int -> Int +foo = 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 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/custom-package-conf/Bar.hs b/test/integration/custom-package-conf/Bar.hs new file mode 100644 --- /dev/null +++ b/test/integration/custom-package-conf/Bar.hs @@ -0,0 +1,10 @@ +module Bar where + +import Foo + +-- | +-- >>> import Foo +-- >>> foo +-- 23 +bar :: Int +bar = 42 diff --git a/test/integration/custom-package-conf/foo/Foo.hs b/test/integration/custom-package-conf/foo/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/custom-package-conf/foo/Foo.hs @@ -0,0 +1,3 @@ +module Foo where +foo :: Int +foo = 23 diff --git a/test/integration/custom-package-conf/foo/doctest-foo.cabal b/test/integration/custom-package-conf/foo/doctest-foo.cabal new file mode 100644 --- /dev/null +++ b/test/integration/custom-package-conf/foo/doctest-foo.cabal @@ -0,0 +1,8 @@ +name: doctest-foo +version: 0.0.0 +build-type: Simple +cabal-version: >= 1.8 + +library + exposed-modules: Foo + build-depends: base diff --git a/test/integration/dos-line-endings/Fib.hs b/test/integration/dos-line-endings/Fib.hs new file mode 100644 --- /dev/null +++ b/test/integration/dos-line-endings/Fib.hs @@ -0,0 +1,10 @@ +module 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/fail-fast/Bar.hs b/test/integration/fail-fast/Bar.hs new file mode 100644 --- /dev/null +++ b/test/integration/fail-fast/Bar.hs @@ -0,0 +1,8 @@ +module Bar where + +-- | bar +-- a passing test +-- >>> bar +-- 42 +bar :: Int +bar = 42 diff --git a/test/integration/fail-fast/Foo.hs b/test/integration/fail-fast/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/fail-fast/Foo.hs @@ -0,0 +1,24 @@ +module Foo where + +import Bar + +-- | A passing example +-- +-- >>> 23 +-- 23 +test1 :: a +test1 = undefined + +-- | A failing example +-- +-- >>> 23 +-- 42 +test2 :: a +test2 = undefined + +-- | Another passing example +-- +-- >>> 23 +-- 23 +test3 :: a +test3 = undefined diff --git a/test/integration/fail-fast/SetupBar.hs b/test/integration/fail-fast/SetupBar.hs new file mode 100644 --- /dev/null +++ b/test/integration/fail-fast/SetupBar.hs @@ -0,0 +1,12 @@ +module SetupBar where + +-- $setup +-- >>> 23 +-- 23 + +-- | bar +-- a passing test +-- >>> bar +-- 42 +bar :: Int +bar = 42 diff --git a/test/integration/fail-fast/SetupFoo.hs b/test/integration/fail-fast/SetupFoo.hs new file mode 100644 --- /dev/null +++ b/test/integration/fail-fast/SetupFoo.hs @@ -0,0 +1,29 @@ +module SetupFoo where + +import SetupBar + + +-- $setup +-- >>> 24 +-- 23 + +-- | A passing example +-- +-- >>> 23 +-- 23 +test1 :: a +test1 = undefined + +-- | A failing example +-- +-- >>> 23 +-- 42 +test2 :: a +test2 = undefined + +-- | Another passing example +-- +-- >>> 23 +-- 23 +test3 :: a +test3 = undefined diff --git a/test/integration/failing-multiple/Foo.hs b/test/integration/failing-multiple/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/failing-multiple/Foo.hs @@ -0,0 +1,16 @@ +module Foo where + +-- | A failing example +-- +-- >>> 23 +-- 23 +-- +-- >>> 23 +-- 42 +-- +-- >>> 23 +-- 23 +-- >>> 23 +-- 23 +test :: a +test = undefined 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 Foo where + +-- | A failing example +-- +-- >>> 23 +-- 42 +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 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 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/local-stderr-binding/A.hs b/test/integration/local-stderr-binding/A.hs new file mode 100644 --- /dev/null +++ b/test/integration/local-stderr-binding/A.hs @@ -0,0 +1,11 @@ +module A where + +stderr :: Bool +stderr = True + +stdout :: String +stdout = "hello" + +-- | +-- >>> 3 + 3 +-- 6 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 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/parse-error/Foo.hs b/test/integration/parse-error/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/parse-error/Foo.hs @@ -0,0 +1,5 @@ +module Foo where + +-- | Some documentation +foo :: Int +foo = diff --git a/test/integration/property-bool-with-type-signature/Foo.hs b/test/integration/property-bool-with-type-signature/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/property-bool-with-type-signature/Foo.hs @@ -0,0 +1,5 @@ +module Foo where + +-- | +-- prop> True :: Bool +foo = undefined diff --git a/test/integration/property-bool/Foo.hs b/test/integration/property-bool/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/property-bool/Foo.hs @@ -0,0 +1,5 @@ +module Foo where + +-- | +-- prop> True +foo = undefined diff --git a/test/integration/property-failing/Foo.hs b/test/integration/property-failing/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/property-failing/Foo.hs @@ -0,0 +1,5 @@ +module Foo where + +-- | +-- prop> abs x == x +foo = undefined diff --git a/test/integration/property-implicitly-quantified/Foo.hs b/test/integration/property-implicitly-quantified/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/property-implicitly-quantified/Foo.hs @@ -0,0 +1,5 @@ +module Foo where + +-- | +-- prop> abs x == abs (abs x) +foo = undefined diff --git a/test/integration/property-quantified/Foo.hs b/test/integration/property-quantified/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/property-quantified/Foo.hs @@ -0,0 +1,5 @@ +module Foo where + +-- | +-- prop> \x -> abs x == abs (abs x) +foo = undefined diff --git a/test/integration/property-setup/Foo.hs b/test/integration/property-setup/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/property-setup/Foo.hs @@ -0,0 +1,9 @@ +module Foo where + +-- $setup +-- >>> import Test.QuickCheck +-- >>> let arbitraryEven = (* 2) `fmap` arbitrary + +-- | +-- prop> forAll arbitraryEven even +foo = undefined diff --git a/test/integration/setup-skip-on-failure/Foo.hs b/test/integration/setup-skip-on-failure/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/setup-skip-on-failure/Foo.hs @@ -0,0 +1,17 @@ +module Foo where + +-- $setup +-- >>> x +-- 23 + +-- | +-- >>> foo +-- 42 +foo :: Int +foo = 42 + +-- | +-- >>> y +-- 42 +bar :: Int +bar = 42 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 Foo where + +-- $setup +-- >>> let x = 23 :: Int + +-- | +-- >>> x + foo +-- 65 +foo :: Int +foo = 42 diff --git a/test/integration/system-io-imported/A.hs b/test/integration/system-io-imported/A.hs new file mode 100644 --- /dev/null +++ b/test/integration/system-io-imported/A.hs @@ -0,0 +1,10 @@ +module 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. + +-- | +-- >>> ReadMode +-- ReadMode + diff --git a/test/integration/template-haskell-bugfix/Main.hs b/test/integration/template-haskell-bugfix/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/template-haskell-bugfix/Main.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +-- Import our template "pr" +import Printf ( pr ) + +-- The splice operator $ takes the Haskell source code +-- generated at compile time by "pr" and splices it into +-- the argument of "putStrLn". +main = putStrLn ( $(pr "Hello") ) diff --git a/test/integration/template-haskell-bugfix/Printf.hs b/test/integration/template-haskell-bugfix/Printf.hs new file mode 100644 --- /dev/null +++ b/test/integration/template-haskell-bugfix/Printf.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} +-- +-- derived from: http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html#th-example +-- +module Printf (pr) where + +import Language.Haskell.TH + +data Format = D | S | L String + +parse :: String -> [Format] +parse s = [ L s ] + +gen :: [Format] -> Q Exp +gen [D] = [| \n -> show n |] +gen [S] = [| \s -> s |] +gen [L s] = stringE s + +-- | +-- +-- >>> :set -XTemplateHaskell +-- >>> putStrLn ( $(pr "Hello") ) +-- Hello +pr :: String -> Q Exp +pr s = gen (parse s) diff --git a/test/integration/template-haskell/Foo.hs b/test/integration/template-haskell/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/template-haskell/Foo.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +module 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/test-options/Foo.hs b/test/integration/test-options/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/test-options/Foo.hs @@ -0,0 +1,14 @@ +module Foo where + + +-- | +-- Examples: +-- +-- >>> foo +-- 23 +foo :: Int +#ifdef FOO +foo = 23 +#else +foo = 42 +#endif 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 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/testCPP/Foo.hs b/test/integration/testCPP/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/testCPP/Foo.hs @@ -0,0 +1,14 @@ +module Foo where + + +-- | +-- Examples: +-- +-- >>> foo +-- 23 +foo :: Int +#ifdef FOO +foo = 23 +#else +foo = 42 +#endif 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 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,79 @@ +-- | +-- 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 Foo ( + -- | Some documentation not attached to a particular Haskell entity + -- + -- >>> test 10 + -- *** Exception: Prelude.undefined + -- ... + test, + + -- | + -- >>> fib 10 + -- 55 + fib, + + -- | + -- >>> bar + -- "bar" + bar + ) 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 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 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 @@ +-- | +-- >>> fib 10 +-- 55 +module ModuleA where + +import ModuleB 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 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 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 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/trailing-whitespace/Foo.hs b/test/integration/trailing-whitespace/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/trailing-whitespace/Foo.hs @@ -0,0 +1,8 @@ +module Foo where + +-- | A failing example +-- +-- >>> putStrLn "foo " +-- foo +test :: a +test = undefined diff --git a/test/integration/with-cbits/Bar.hs b/test/integration/with-cbits/Bar.hs new file mode 100644 --- /dev/null +++ b/test/integration/with-cbits/Bar.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Bar where + +import Foreign.C + +-- | +-- >>> foo +-- 23 +foreign import ccall foo :: CInt diff --git a/test/parse/multiple-examples/Foo.hs b/test/parse/multiple-examples/Foo.hs new file mode 100644 --- /dev/null +++ b/test/parse/multiple-examples/Foo.hs @@ -0,0 +1,11 @@ +module Foo where + +-- | +-- >>> foo +-- 23 +foo = 23 + +-- | +-- >>> bar +-- 42 +bar = 42 diff --git a/test/parse/no-examples/Fib.hs b/test/parse/no-examples/Fib.hs new file mode 100644 --- /dev/null +++ b/test/parse/no-examples/Fib.hs @@ -0,0 +1,10 @@ +module Fib where + +-- | Calculate Fibonacci numbers. +-- @ +-- some code +-- @ +-- +-- foobar 23 +fib :: Int -> Int -> Int +fib _ = undefined diff --git a/test/parse/non-exported/Fib.hs b/test/parse/non-exported/Fib.hs new file mode 100644 --- /dev/null +++ b/test/parse/non-exported/Fib.hs @@ -0,0 +1,16 @@ +module Fib (foo) where + +foo :: Int +foo = 23 + +-- | 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/parse/property/Fib.hs b/test/parse/property/Fib.hs new file mode 100644 --- /dev/null +++ b/test/parse/property/Fib.hs @@ -0,0 +1,15 @@ +module Fib where + +-- | Calculate Fibonacci numbers. +-- +-- prop> foo +-- +-- some text +-- +-- prop> bar +-- +-- some more text +-- +-- prop> baz +fib :: Int -> Int -> Int +fib _ = undefined diff --git a/test/parse/setup-empty/Foo.hs b/test/parse/setup-empty/Foo.hs new file mode 100644 --- /dev/null +++ b/test/parse/setup-empty/Foo.hs @@ -0,0 +1,10 @@ +module Foo where + +-- $setup +-- some setup code + +-- | +-- >>> foo +-- 23 +foo :: Int +foo = 23 diff --git a/test/parse/setup-only/Foo.hs b/test/parse/setup-only/Foo.hs new file mode 100644 --- /dev/null +++ b/test/parse/setup-only/Foo.hs @@ -0,0 +1,9 @@ +module Foo where + +-- $setup +-- >>> foo +-- 23 + +-- | some documentation +foo :: Int +foo = 23 diff --git a/test/parse/simple/Fib.hs b/test/parse/simple/Fib.hs new file mode 100644 --- /dev/null +++ b/test/parse/simple/Fib.hs @@ -0,0 +1,13 @@ +module Fib where + +-- | Calculate Fibonacci numbers. +-- +-- >>> putStrLn "foo" +-- foo +-- >>> putStr "bar" +-- bar +-- +-- >>> putStrLn "baz" +-- baz +fib :: Int -> Int -> Int +fib _ = undefined