doctest-parallel-0.3.1.1/0000755000000000000000000000000007346545000013302 5ustar0000000000000000doctest-parallel-0.3.1.1/CHANGES.markdown0000644000000000000000000001020107346545000016110 0ustar0000000000000000# 0.3.1.1 * Add support for GHC 9.10 # 0.3.1 * Add support for GHC 9.8 * Drop support for GHC 8.2 * Add `--ghc-arg` as a command line argument, allowing users to pass additional arguments to GHC used to parse Haddock. # 0.3.0.1 * Add support for GHC 9.6 # 0.3.0 * Add support for Nix shell environments ([#58](https://github.com/martijnbastiaan/doctest-parallel/pull/58)) * `Language.Haskell.GhciWrapper` has been moved to `Test.DocTest.Internal.GhciWrapper`. This module was never intended to be part of the public API. ([#61](https://github.com/martijnbastiaan/doctest-parallel/pull/61)) * Add more elaborate debug options. You can now pass `--log-level=LEVEL` where `level` is one of `debug`, `verbose`, `info`, `warning`, or `error`. ([#14](https://github.com/martijnbastiaan/doctest-parallel/issues/14)) # 0.2.6 * `getNumProcessors` is now used to detect the (default) number of GHCi subprocesses to spawn. This should more reliably use all of a system's resources. Fixes [#53](https://github.com/martijnbastiaan/doctest-parallel/issues/53). * Add Nix support. If the environment variable `NIX_BUILD_TOP` is present an extra package database is added to `GHC_PACKAGE_PATH`. This isn't expected to break existing builds, but if it does consider passing `--no-nix`. ([#34](https://github.com/martijnbastiaan/doctest-parallel/issues/34)) * The QuickCheck example mentioned in the README now uses `abs` instead of `sort`. This prevents confusing errors when `sort` is not imported. Fixes [#50](https://github.com/martijnbastiaan/doctest-parallel/issues/50). # 0.2.5 * Loosen Cabal bounds to >= 2.4 && < 3.9 # 0.2.4 * Add support for GHC 9.4 ([#43](https://github.com/martijnbastiaan/doctest-parallel/pull/43)) # 0.2.3 * Conditionals in Cabal files are now solved ([#35](https://github.com/martijnbastiaan/doctest-parallel/pull/37)). Thanks to @philderbeast for the report and contributions. * Unexpected outputs in `$setup` blocks are no longer ignored ([#39](https://github.com/martijnbastiaan/doctest-parallel/pull/39)) # 0.2.2 * Command line arguments (such as `--randomize-order`) can now be overridden on a per-module basis ([#25](https://github.com/martijnbastiaan/doctest-parallel/pull/25)) * Implicit pre-test module imports can now be disabled using `--no-implicit-module-import`. This can help to test functions from non-exposed modules ([#26](https://github.com/martijnbastiaan/doctest-parallel/pull/26)) * `runModule` does not swallow import errors anymore ([#28](https://github.com/martijnbastiaan/doctest-parallel/issues/28)) * `autogen-modules` are not searched for tests anymore ([#30](https://github.com/martijnbastiaan/doctest-parallel/issues/30)) # 0.2.1 * C include directories (Cabal field: `include-dirs`) are now passed to GHC when parsing source files ([#7](https://github.com/martijnbastiaan/doctest-parallel/issues/7)) * A migration guide has been added ([#11](https://github.com/martijnbastiaan/doctest-parallel/issues/11)) * Test order can be randomized using `--randomize-order`. Test order can be made deterministic by adding an optional `--seed=N` argument ([#12](https://github.com/martijnbastiaan/doctest-parallel/pull/12)) * Any non-error output can now be surpressed by `--quiet` ([#20](https://github.com/martijnbastiaan/doctest-parallel/pull/20)) * Doctest can now be called using a record for option passing in addition to command line arguments. See `mainFromCabalWithConfig` and `mainFromLibraryWithConfig`. # 0.2 Changes: * Support for GHC 9.2 has been added ([#4](https://github.com/martijnbastiaan/doctest-parallel/pull/4)) * Support for GHC 8.2 has been dropped ([#3](https://github.com/martijnbastiaan/doctest-parallel/pull/3)) * The dependency `cabal-install-parsers` has been dropped. This trims the dependency tree quite a bit ([#3](https://github.com/martijnbastiaan/doctest-parallel/pull/3)) * The Hackage distribution now ships all files necessary to run `doctest-parallel`'s tests (Fixes [#1](https://github.com/martijnbastiaan/doctest-parallel/issues/1), PR [#2](https://github.com/martijnbastiaan/doctest-parallel/pull/2)) # 0.1 Fresh fork from `sol/doctest`. See the README for an overview of all the changes. doctest-parallel-0.3.1.1/LICENSE0000644000000000000000000000206707346545000014314 0ustar0000000000000000Copyright (c) 2009-2018 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. doctest-parallel-0.3.1.1/README.markdown0000644000000000000000000003236407346545000016013 0ustar0000000000000000 # Doctest parallel: Test interactive Haskell examples `doctest-parallel` is a library that checks [examples in Haddock comments](http://www.haskell.org/haddock/doc/html/ch03s08.html#id566093). It is similar to the [popular Python module with the same name](http://docs.python.org/library/doctest.html). # Installation `doctest-parallel` is available from [Hackage](https://hackage.haskell.org/package/doctest-parallel). It cannot be used as a standalone binary, rather, it expects to be integrated in a Cabal/Stack project. See [examples/](example/README.md) for more information on how to integrate `doctest-parallel` into your project. # Migrating from `doctest` See [issue #11](https://github.com/martijnbastiaan/doctest-parallel/issues/11) for more information. # Usage Below is a small Haskell module. The module contains a Haddock comment with some examples of interaction. The examples demonstrate how the module is supposed to be used. ```haskell module Fib where -- | Compute Fibonacci numbers -- -- Examples: -- -- >>> fib 10 -- 55 -- -- >>> fib 5 -- 5 fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) ``` A comment line starting with `>>>` denotes an _expression_. All comment lines following an expression denote the _result_ of that expression. Result is defined by what a [REPL](http://en.wikipedia.org/wiki/Read-eval-print_loop) (e.g. ghci) prints to `stdout` and `stderr` when evaluating that expression. `doctest-parallel` will fail on comments that `haddock` also doesn't like. Sometimes (e.g., [#251](https://github.com/sol/doctest/issues/251)), this means that `doctest-parallel` will fail on input that GHC accepts. ## Command line ``` Usage: doctest [ options ]... []... doctest --help doctest --version doctest --info Options: -jN number of threads to use --log-level=LEVEL one of: debug, verbose, info, warning, error. Default: info. --ghc-arg=ARG pass argument to GHC when parsing, pass multiple times for multiple flags † --implicit-module-import import module before testing it (default) † --randomize-order randomize order in which tests are run † --seed=N use a specific seed to randomize test order † --preserve-it preserve the `it` variable between examples --nix account for Nix build environments (default) --quiet set log level to `Error`, shorthand for `--log-level=error` --verbose set log level to `Verbose`, shorthand for `--log-level=verbose` --debug set log level to `Debug`, shorthand for `--log-level=debug` --help display this help and exit --version output version information and exit --info output machine-readable version information and exit Supported inverted options: --no-nix † --no-implicit-module-import † --no-randomize-order (default) † --no-preserve-it (default) Options marked with a dagger (†) can also be used to set module level options, using an ANN pragma like this: {-# ANN module "doctest-parallel: --no-randomize-order" #-} ``` ## Example groups Examples from a single Haddock comment are grouped together and share the same scope. E.g. the following works: ```haskell -- | -- >>> let x = 23 -- >>> x + 42 -- 65 ``` If an example fails, subsequent examples from the same group are skipped. E.g. for ```haskell -- | -- >>> let x = 23 -- >>> let n = x + y -- >>> print n ``` `print n` is not tried, because `let n = x + y` fails (`y` is not in scope!). ## Setup code You can put setup code in a [named chunk][named-chunks] with the name `$setup`. The setup code is run before each example group. If the setup code produces any errors/failures, all tests from that module are skipped. Here is an example: ```haskell module Foo where import Bar.Baz -- $setup -- >>> let x = 23 :: Int -- | -- >>> foo + x -- 65 foo :: Int foo = 42 ``` Note that you should not place setup code in between the module header (`module ... where`) and import declarations. GHC will not be able to parse it ([issue #167](https://github.com/sol/doctest/issues/167)). It is best to place setup code right after import declarations, but due to its declarative nature you can place it anywhere in between top level declarations as well. ## Multi-line input GHCi supports commands which span multiple lines, and the same syntax works for doctest: ```haskell -- | -- >>> :{ -- let -- x = 1 -- y = 2 -- in x + y + multiline -- :} -- 6 multiline = 3 ``` Note that `>>>` can be left off for the lines following the first: this is so that haddock does not strip leading whitespace. The expected output has whitespace stripped relative to the :}. Some peculiarities on the ghci side mean that whitespace at the very start is lost. This breaks the example `broken`, since the x and y aren't aligned from ghci's perspective. A workaround is to avoid leading space, or add a newline such that the indentation does not matter: ```haskell {- | >>> :{ let x = 1 y = 2 in x + y + works :} 6 -} works = 3 {- | >>> :{ let x = 1 y = 2 in x + y + broken :} 3 -} broken = 3 ``` ## Multi-line output If there are no blank lines in the output, multiple lines are handled automatically. ```haskell -- | >>> putStr "Hello\nWorld!" -- Hello -- World! ``` If however the output contains blank lines, they must be noted explicitly with ``. For example, ```haskell import Data.List ( intercalate ) -- | Double-space a paragraph. -- -- Examples: -- -- >>> let s1 = "\"Every one of whom?\"" -- >>> let s2 = "\"Every one of whom do you think?\"" -- >>> let s3 = "\"I haven't any idea.\"" -- >>> let paragraph = unlines [s1,s2,s3] -- >>> putStrLn $ doubleSpace paragraph -- "Every one of whom?" -- -- "Every one of whom do you think?" -- -- "I haven't any idea." -- doubleSpace :: String -> String doubleSpace = (intercalate "\n\n") . lines ``` ## Matching arbitrary output Any lines containing only three dots (`...`) will match one or more lines with arbitrary content. For instance, ```haskell -- | -- >>> putStrLn "foo\nbar\nbaz" -- foo -- ... -- baz ``` If a line contains three dots and additional content, the three dots will match anything *within that line*: ```haskell -- | -- >>> putStrLn "foo bar baz" -- foo ... baz ``` ## QuickCheck properties Haddock (since version 2.13.0) has markup support for properties. Doctest can verify properties with QuickCheck. A simple property looks like this: ```haskell -- | -- prop> \n -> abs n == abs (abs (n :: Int)) ``` The lambda abstraction is optional and can be omitted: ```haskell -- | -- prop> abs n == abs (abs (n :: Int)) ``` A complete example that uses setup code is below: ```haskell module Fib where -- $setup -- >>> import Control.Applicative -- >>> import Test.QuickCheck -- >>> newtype Small = Small Int deriving Show -- >>> instance Arbitrary Small where arbitrary = Small . (`mod` 10) <$> arbitrary -- | Compute Fibonacci numbers -- -- The following property holds: -- -- prop> \(Small n) -> fib n == fib (n + 2) - fib (n + 1) fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) ``` If you see an error like the following, ensure that [QuickCheck](http://hackage.haskell.org/package/QuickCheck) is a dependency of your test-suite. ```haskell :39:3: Not in scope: ‘polyQuickCheck’ In the splice: $(polyQuickCheck (mkName "doctest_prop")) :39:3: GHC stage restriction: ‘polyQuickCheck’ is used in a top-level splice or annotation, and must be imported, not defined locally In the expression: polyQuickCheck (mkName "doctest_prop") In the splice: $(polyQuickCheck (mkName "doctest_prop")) ``` ## Hiding examples from Haddock You can put examples into [named chunks][named-chunks], and not refer to them in the export list. That way they will not be part of the generated Haddock documentation, but Doctest will still find them. ```haskell -- $ -- >>> 1 + 1 -- 2 ``` [named-chunks]: http://www.haskell.org/haddock/doc/html/ch03s05.html ## Using GHC extensions You can enable GHC extensions using the following syntax: ```haskell -- >>> :set -XTupleSections ``` If you want to omit the information which language extensions are enabled from the Doctest examples you can use the method described in [Hiding examples from Haddock](#hiding-examples-from-haddock), e.g.: ```haskell -- $ -- >>> :set -XTupleSections ``` [language-pragma]: http://www.haskell.org/ghc/docs/latest/html/users_guide/pragmas.html#language-pragma ## Using GHC plugins You can enable GHC plugins using the following syntax: ```haskell -- >>> :set -fplugin The.Plugin ``` ## Hiding Prelude You _hide_ the import of `Prelude` by using: ```haskell -- >>> :m -Prelude ``` ## Per module options You can override command line flags per module by using a module annotation. For example, if you know a specific module does not support test order randomization, you can disable it with: ```haskell {-# ANN module "doctest-parallel: --no-randomize-order" #-} ``` ## Test non-exposed modules Generally, `doctest-parallel` cannot test binders that are part of non-exposed modules, unless they are re-exported from exposed modules. By default `doctest-parallel` will fail to do so (and report an error message), because it doesn't track whether functions are re-exported in such a way. To test a re-exported function, add the following to the _non-exposed_ module: ```haskell {-# ANN module "doctest-parallel: --no-implicit-module-import" #-} ``` This makes `doctest-parallel` omit the usual module import at the start of a test. Then, before a test -or in `$setup`- add: ```haskell >>> import Exposed.Module (someFunction) ``` # Relation to [`doctest`](https://github.com/sol/doctest) This is a fork of [sol/doctest](https://github.com/sol/doctest) that allows running tests in parallel and aims to provide a more robust project integration method. It is not backwards compatible and expects to be setup differently. At the time of writing it has a few advantages over the base project: * It runs tests in parallel * It runs tests against compiled code, instead of reinterpreting your whole project * It isolates examples in modules, ensuring your tests don't accidentally rely on each other * It parses cabal files to discover modules, no need for custom setup anymore! * A minor change: it does not count lines in setup blocks as test cases * A minor change: the testsuite has been ported to v2 commands All in all, you can expect `doctest-parallel` to run about 1 or 2 orders of magnitude faster than `doctest` for large projects. # Relation to [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) There is no direct relation between `doctest-parallel` and `cabal-docspec`. They are similar in some ways: * Both projects load code from precompiled modules * Both project aim to get rid of the need for custom setups And different in others: * As a fork of `doctest`, `doctest-parallel` inherits the testsuite `doctest` accumulated over the years. * `doctest-parallel` parses Cabal project files, instead of parsing files from `dist-newstyle`. This makes it compatible with Stack, provided a `.cabal` is still present. * `doctest-parallel` uses the GHC API to parse comments. This should in theory be more reliable (though I doubt it will ever matter in practice). * `doctest-parallel` runs tests in parallel. # Development To run the tests: ``` cabal run spectests cabal run doctests ``` # Future of this project * It would be lovely if we could get rid of the needs for `write-ghc-environment-files: always` option for Cabal. To properly do this, I think Cabal should do two things: 1. Deprecate GHC environment files as a way to _implicitly_ setup environments. Instead, environment files should be written to the `dist-newstyle` directory and activated using some subcommand, e.g. `cabal shell`. This avoids the many problems GHC environment files have, while retaining their functionality for people who like them. 2. Any subcommands should be run with `GHC_ENVIRONMENT` set - pointing to the GHC environment file. Like Stack, this would create a hassle free way of using Cabal in combination with projects/executables that use the GHC API (e.g., `clash-ghc`, `doctest-parallel`). * It would be nice if Cabal would expose more information _by default_ (probably through auto-generated modules) in order for `doctest-parallel` to properly work. Specifically, it needs to know the exact `default-extensions`, `ghc-options`, and `CPP` flags the project is compiled with. These options are obtainable by using a custom `Setup.hs`, but this has its own list of problems. * Alternatively, if comments could be included in and loaded from `.hi` files that'd solve all issues too. * Hopefully many of the improvements made here can make their way back into `sol/doctest`. Of course, if you wish to add a feature that's not in this list, please feel free top open a pull request! # Contributors * Adam Vogt * Anders Persson * Ankit Ahuja * Edward Kmett * Hiroki Hattori * Joachim Breitner * João Cristóvão * Julian Arni * Kazu Yamamoto * Levent Erkok * Luke Murphy * Matvey Aksenov * Michael Orlitzky * Michael Snoyman * Nick Smallbone * Phil de Joux * Sakari Jokinen * Simon Hengel * Sönke Hahn doctest-parallel-0.3.1.1/cabal.project0000644000000000000000000000044307346545000015735 0ustar0000000000000000packages: ./ write-ghc-environment-files: always tests: true source-repository-package type: git location: https://github.com/haskell-unordered-containers/unordered-containers.git tag: d52a0fd10bfa701cbbc9d7ac06bd7eb7664b3972 allow-newer: unordered-containers:template-haskell doctest-parallel-0.3.1.1/doctest-parallel.cabal0000644000000000000000000001337307346545000017534 0ustar0000000000000000cabal-version: 2.0 name: doctest-parallel version: 0.3.1.1 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python (). . Documentation is at . category: Testing bug-reports: https://github.com/martijnbastiaan/doctest-parallel/issues homepage: https://github.com/martijnbastiaan/doctest-parallel#readme license: MIT license-file: LICENSE copyright: (c) 2009-2018 Simon Hengel, 2021-2022 Martijn Bastiaan author: Martijn Bastiaan maintainer: Martijn Bastiaan build-type: Simple tested-with: GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.7 , GHC == 9.6.3 , GHC == 9.8.1 , GHC == 9.10.1 extra-source-files: example/example.cabal example/src/Example.hs example/test/doctests.hs cabal.project CHANGES.markdown README.markdown -- Rather annoyingly, Cabal implements arbitrary limitations in their file -- globbing, one of them being that a wildcard can't be used to match -- directories. Hence, we list them here individually. test/extract/argument-list/*.hs test/extract/comment-order/*.hs test/extract/declaration/*.hs test/extract/dos-line-endings/*.hs test/extract/export-list/*.hs test/extract/imported-module/*.hs test/extract/module-header/*.hs test/extract/module-options/*.hs test/extract/named-chunks/*.hs test/extract/regression/*.hs test/extract/setup/*.hs test/extract/th/*.hs test/extract/type-class/*.hs test/extract/type-class-args/*.hs test/extract/type-families/*.hs test/parse/multiple-examples/*.hs test/parse/no-examples/*.hs test/parse/non-exported/*.hs test/parse/property/*.hs test/parse/setup-empty/*.hs test/parse/setup-only/*.hs test/parse/simple/*.hs test/integration/WithCInclude/include/WithCInclude.h source-repository head type: git location: https://github.com/martijnbastiaan/doctest-parallel library ghc-options: -Wall hs-source-dirs: src exposed-modules: Test.DocTest Test.DocTest.Helpers Test.DocTest.Internal.Extract Test.DocTest.Internal.GhciWrapper Test.DocTest.Internal.GhcUtil Test.DocTest.Internal.Interpreter Test.DocTest.Internal.Location Test.DocTest.Internal.Logging Test.DocTest.Internal.Nix Test.DocTest.Internal.Options Test.DocTest.Internal.Parse Test.DocTest.Internal.Property Test.DocTest.Internal.Runner Test.DocTest.Internal.Runner.Example Test.DocTest.Internal.Util autogen-modules: Paths_doctest_parallel other-modules: Control.Monad.Extra Data.List.Extra Paths_doctest_parallel build-depends: Cabal >= 2.4 && < 3.11 , Glob , base >=4.10 && <5 , base-compat >=0.7.0 , code-page >=0.1 , containers , deepseq , directory , exceptions , filepath , ghc >=8.2 && <9.11 , ghc-paths >=0.1.0.9 , process , random >= 1.2 , syb >=0.3 , transformers , unordered-containers default-language: Haskell2010 test-suite doctests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: doctests.hs ghc-options: -threaded build-depends: base, doctest-parallel default-language: Haskell2010 library spectests-modules default-language: Haskell2010 build-depends: base, doctest-parallel, template-haskell -- Too many warnings. TODO: fix. -- ghc-options: -Wall hs-source-dirs: test/integration include-dirs: test/integration/WithCInclude/include c-sources: test/integration/WithCbits/foo.c exposed-modules: BugfixImportHierarchical.ModuleA BugfixImportHierarchical.ModuleB BugfixMultipleModules.ModuleA BugfixMultipleModules.ModuleB BugfixOutputToStdErr.Fib Color.Foo DosLineEndings.Fib Failing.Foo FailingMultiple.Foo GhcArg.Fib It.Foo It.Setup LocalStderrBinding.A ModuleIsolation.TestA ModuleIsolation.TestB ModuleOptions.Foo NonExposedModule.Exposed Multiline.Multiline PropertyBool.Foo PropertyBoolWithTypeSignature.Foo PropertyFailing.Foo PropertyImplicitlyQuantified.Foo PropertyQuantified.Foo PropertySetup.Foo Setup.Foo SetupSkipOnFailure.Foo SystemIoImported.A TemplateHaskell.Foo TestBlankline.Fib TestCombinedExample.Fib TestCommentLocation.Foo TestDocumentationForArguments.Fib TestFailOnMultiline.Fib TestImport.ModuleA TestImport.ModuleB TestPutStr.Fib TestSimple.Fib TrailingWhitespace.Foo WithCbits.Bar WithCInclude.Bar other-modules: NonExposedModule.NoImplicitImport test-suite spectests main-is: Spec.hs other-modules: ExtractSpec GhciWrapperSpec InterpreterSpec LocationSpec MainSpec OptionsSpec ParseSpec PropertySpec Runner.ExampleSpec RunnerSpec RunSpec UtilSpec type: exitcode-stdio-1.0 ghc-options: -Wall -threaded cpp-options: -DTEST hs-source-dirs: test build-depends: HUnit , QuickCheck >=2.13.1 , base , base-compat , code-page , containers , doctest-parallel , deepseq , directory , exceptions , filepath , ghc , ghc-paths , hspec >=2.3.0 , hspec-core >=2.3.0 , mockery , process , setenv , silently >=1.2.4 , stringbuilder >=0.4 , spectests-modules , syb , transformers default-language: Haskell2010 doctest-parallel-0.3.1.1/example/0000755000000000000000000000000007346545000014735 5ustar0000000000000000doctest-parallel-0.3.1.1/example/example.cabal0000644000000000000000000000065007346545000017355 0ustar0000000000000000name: example version: 0.0.0 build-type: Simple cabal-version: >= 1.8 library hs-source-dirs: src exposed-modules: Example build-depends: base test-suite doctests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: doctests.hs ghc-options: -threaded build-depends: base, example, doctest-parallel >= 0.1 default-language: Haskell2010 doctest-parallel-0.3.1.1/example/src/0000755000000000000000000000000007346545000015524 5ustar0000000000000000doctest-parallel-0.3.1.1/example/src/Example.hs0000644000000000000000000000014007346545000017446 0ustar0000000000000000module Example (foo, bar) where -- | -- >>> foo -- 23 foo = 23 -- | -- >>> bar -- 42 bar = 42 doctest-parallel-0.3.1.1/example/test/0000755000000000000000000000000007346545000015714 5ustar0000000000000000doctest-parallel-0.3.1.1/example/test/doctests.hs0000644000000000000000000000022507346545000020077 0ustar0000000000000000module Main where import Test.DocTest (mainFromCabal) import System.Environment (getArgs) main :: IO () main = mainFromCabal "example" =<< getArgs doctest-parallel-0.3.1.1/src/Control/Monad/0000755000000000000000000000000007346545000016547 5ustar0000000000000000doctest-parallel-0.3.1.1/src/Control/Monad/Extra.hs0000644000000000000000000000047407346545000020173 0ustar0000000000000000module Control.Monad.Extra where -- | Like @if@, but where the test can be monadic. ifM :: Monad m => m Bool -> m a -> m a -> m a ifM predicate t f = do b <- predicate; if b then t else f -- | Like 'when', but where the test can be monadic. whenM :: Monad m => m Bool -> m () -> m () whenM b t = ifM b t (pure ()) doctest-parallel-0.3.1.1/src/Data/List/0000755000000000000000000000000007346545000015655 5ustar0000000000000000doctest-parallel-0.3.1.1/src/Data/List/Extra.hs0000644000000000000000000000120707346545000017274 0ustar0000000000000000module Data.List.Extra (trim) where import Data.Char (isSpace) import Data.List (dropWhileEnd) -- | Remove spaces from either side of a string. A combination of 'trimEnd' and 'trimStart'. -- -- > trim " hello " == "hello" -- > trimStart " hello " == "hello " -- > trimEnd " hello " == " hello" -- > \s -> trim s == trimEnd (trimStart s) trim :: String -> String trim = trimEnd . trimStart -- | Remove spaces from the start of a string, see 'trim'. trimStart :: String -> String trimStart = dropWhile isSpace -- | Remove spaces from the end of a string, see 'trim'. trimEnd :: String -> String trimEnd = dropWhileEnd isSpace doctest-parallel-0.3.1.1/src/Test/0000755000000000000000000000000007346545000015010 5ustar0000000000000000doctest-parallel-0.3.1.1/src/Test/DocTest.hs0000644000000000000000000001174507346545000016721 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Test.DocTest ( mainFromCabal , mainFromLibrary , mainFromCabalWithConfig , mainFromLibraryWithConfig -- * Internal , filterModules , isSuccess , setSeed , run ) where import Prelude () import Prelude.Compat import qualified Data.Set as Set import Data.List (intercalate) import Control.Monad (unless) import Control.Monad.Extra (ifM) import System.Exit (exitFailure) import System.IO import System.Random (randomIO) import qualified Control.Exception as E #if __GLASGOW_HASKELL__ < 900 import Panic #else import GHC.Utils.Panic #endif import Test.DocTest.Internal.Parse import Test.DocTest.Internal.Options import Test.DocTest.Internal.Runner import Test.DocTest.Internal.Nix (getNixGhciArgs) -- Cabal import Distribution.Simple ( KnownExtension(ImplicitPrelude), Extension (DisableExtension) ) -- me import Test.DocTest.Helpers ( Library (libDefaultExtensions), extractCabalLibrary, findCabalPackage , libraryToGhciArgs ) import Test.DocTest.Internal.Logging (LogLevel(..)) import qualified Test.DocTest.Internal.Logging as Logging -- | Run doctest with given list of arguments. -- -- Example: -- -- @ -- mainFromCabal "my-project" =<< getArgs -- @ -- mainFromCabal :: String -> [String] -> IO () mainFromCabal libName cmdArgs = do lib <- extractCabalLibrary =<< findCabalPackage libName mainFromLibrary lib cmdArgs -- | Run doctest given config. -- -- Example: -- -- @ -- mainFromCabal "my-project" defaultConfig -- @ -- mainFromCabalWithConfig :: String -> Config -> IO () mainFromCabalWithConfig libName config = do lib <- extractCabalLibrary =<< findCabalPackage libName mainFromLibraryWithConfig lib config -- | Like 'mainFromCabal', but with a given library. mainFromLibrary :: Library -> [String] -> IO () mainFromLibrary lib (parseOptions -> opts) = case opts of ResultStdout s -> putStr s ResultStderr s -> do hPutStrLn stderr ("doctest: " ++ s) hPutStrLn stderr "Try `doctest --help' for more information." exitFailure Result config -> do mainFromLibraryWithConfig lib config -- | Run doctests with given library and config. mainFromLibraryWithConfig :: Library -> Config -> IO () mainFromLibraryWithConfig lib config = do r <- run lib config `E.catch` \e -> do case fromException e of Just (UsageError err) -> do hPutStrLn stderr ("doctest: " ++ err) hPutStrLn stderr "Try `doctest --help' for more information." exitFailure _ -> E.throwIO e unless (isSuccess r) exitFailure isSuccess :: Summary -> Bool isSuccess s = sErrors s == 0 && sFailures s == 0 -- | Filter modules to be tested against a list of modules to be tested (specified -- by the user on the command line). If list is empty, test all modules. Throws -- and error if a non-existing module was specified. filterModules :: [ModuleName] -> [Module a] -> [Module a] filterModules [] mods = mods filterModules wantedMods0 allMods0 | (_:_) <- nonExistingMods = error ("Unknown modules specified: " <> show nonExistingMods) | otherwise = filter isSpecifiedMod allMods0 where wantedMods1 = Set.fromList wantedMods0 allMods1 = Set.fromList (map moduleName allMods0) nonExistingMods = Set.toList (wantedMods1 `Set.difference` allMods1) isSpecifiedMod Module{moduleName} = moduleName `Set.member` wantedMods1 setSeed :: (?verbosity :: LogLevel) => ModuleConfig -> IO ModuleConfig setSeed cfg@ModuleConfig{cfgRandomizeOrder=True, cfgSeed=Nothing} = do -- Using an absolute number to prevent copy+paste errors seed <- abs <$> randomIO Logging.log Info ("Using freshly generated seed to randomize test order: " <> show seed) pure cfg{cfgSeed=Just seed} setSeed cfg = pure cfg -- | Run doctest for given library and config. Produce a summary of all tests. run :: Library -> Config -> IO Summary run lib Config{..} = do nixGhciArgs <- ifM (pure cfgNix) getNixGhciArgs (pure []) let implicitPrelude = DisableExtension ImplicitPrelude `notElem` libDefaultExtensions lib (includeArgs, moduleArgs, otherGhciArgs) = libraryToGhciArgs lib evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"] ++ nixGhciArgs parseGhcArgs = includeArgs ++ moduleArgs ++ otherGhciArgs ++ nixGhciArgs ++ cfgGhcArgs let ?verbosity = cfgLogLevel modConfig <- setSeed cfgModuleConfig -- Get examples from Haddock comments Logging.log Verbose "Parsing comments.." Logging.log Debug ("Calling GHC API with: " <> unwords parseGhcArgs) allModules <- getDocTests parseGhcArgs -- Run tests Logging.log Verbose "Running examples.." let filteredModules = filterModules cfgModules allModules filteredModulesMsg = intercalate ", " (map moduleName filteredModules) Logging.log Debug ("Running examples in modules: " <> filteredModulesMsg) runModules modConfig cfgThreads implicitPrelude evalGhciArgs filteredModules doctest-parallel-0.3.1.1/src/Test/DocTest/0000755000000000000000000000000007346545000016355 5ustar0000000000000000doctest-parallel-0.3.1.1/src/Test/DocTest/Helpers.hs0000644000000000000000000002074407346545000020322 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Test.DocTest.Helpers where import GHC.Stack (HasCallStack) import System.Directory ( canonicalizePath, doesFileExist ) import System.FilePath ((), isDrive, takeDirectory) import System.FilePath.Glob (glob) import System.Info (compilerVersion) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>)) #endif import qualified Data.Set as Set -- Cabal import Distribution.ModuleName (ModuleName) import Distribution.Simple ( Extension (DisableExtension, EnableExtension, UnknownExtension) ) import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) import Distribution.PackageDescription ( GenericPackageDescription (condLibrary) , exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package , packageDescription, condSubLibraries, includeDirs, autogenModules, ConfVar(..) ) import Distribution.Compiler (CompilerFlavor(GHC)) import Distribution.Pretty (prettyShow) import Distribution.System (buildArch, buildOS) import Distribution.Types.Condition (Condition(..)) import Distribution.Types.CondTree import Distribution.Types.Version (Version, mkVersion') import Distribution.Types.VersionRange (withinRange) import Distribution.Verbosity (silent) #if MIN_VERSION_Cabal(3,8,0) import Distribution.Simple.PackageDescription (readGenericPackageDescription) #else import Distribution.PackageDescription.Parsec (readGenericPackageDescription) #endif #if MIN_VERSION_Cabal(3,6,0) import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath) #endif -- | Efficient implementation of set like deletion on lists -- -- >>> "abcd" `rmList` "ad" -- "bc" -- >>> "aaabcccd" `rmList` "ad" -- "bccc" rmList :: Ord a => [a] -> [a] -> [a] rmList xs (Set.fromList -> ys) = filter (not . (`Set.member` ys)) xs data Library = Library { libSourceDirectories :: [FilePath] -- ^ Haskell source directories , libCSourceDirectories :: [FilePath] -- ^ C source directories , libModules :: [ModuleName] -- ^ Exposed modules , libDefaultExtensions :: [Extension] -- ^ Extensions enabled by default } deriving (Show) -- | Merge multiple libraries into one, by concatenating all their fields. mergeLibraries :: [Library] -> Library mergeLibraries libs = Library { libSourceDirectories = concatMap libSourceDirectories libs , libCSourceDirectories = concatMap libCSourceDirectories libs , libModules = concatMap libModules libs , libDefaultExtensions = concatMap libDefaultExtensions libs } -- | Convert a "Library" to arguments suitable to be passed to GHCi. libraryToGhciArgs :: Library -> ([String], [String], [String]) libraryToGhciArgs Library{..} = (hsSrcArgs <> cSrcArgs, modArgs, extArgs) where hsSrcArgs = map ("-i" <>) libSourceDirectories cSrcArgs = map ("-I" <>) libCSourceDirectories modArgs = map prettyShow libModules extArgs = map showExt libDefaultExtensions showExt = \case EnableExtension ext -> "-X" <> show ext DisableExtension ext -> "-XNo" <> show ext UnknownExtension ext -> "-X" <> ext -- | Drop a number of elements from the end of the list. -- -- > dropEnd 3 "hello" == "he" -- > dropEnd 5 "bye" == "" -- > dropEnd (-1) "bye" == "bye" -- > \i xs -> dropEnd i xs `isPrefixOf` xs -- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i) -- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..] dropEnd :: Int -> [a] -> [a] dropEnd i xs | i <= 0 = xs | otherwise = f xs (drop i xs) where f (a:as) (_:bs) = a : f as bs f _ _ = [] -- | Searches for a file called @package.cabal@, where @package@ is given as an -- argument. It will look for it in the current directory. If it can't find it -- there, it will traverse up until it finds the file or a file called -- @cabal.project@. In case of the latter, it will traverse down recursively -- until it encounters a @package.cabal@. -- -- The returned path points to the @package.cabal@. Errors if it could not -- find @package.cabal@ anywhere, or when it found multiple. -- findCabalPackage :: HasCallStack => String -> IO FilePath findCabalPackage packageName = goUp =<< canonicalizePath packageName where goUp :: FilePath -> IO FilePath goUp path | isDrive path = error ("Could not find '" <> packageFilename <> "'") | otherwise = do packageExists <- doesFileExist (path packageFilename) projectExists <- doesFileExist (path projectFilename) if | packageExists -> pure (path packageFilename) | projectExists -> goDown path | otherwise -> goUp (takeDirectory path) goDown :: FilePath -> IO FilePath goDown path = do candidates <- glob (path "**" packageFilename) case candidates of [] -> error ("Could not find " <> packageFilename <> " in project " <> path) (_:_:_) -> error ("Ambiguous packages in project " <> path <> ": " <> show candidates) [c] -> pure c packageFilename = packageName <> ".cabal" projectFilename = "cabal.project" #if MIN_VERSION_Cabal(3,6,0) compatPrettyShow :: SymbolicPath PackageDir SourceDir -> FilePath compatPrettyShow = prettyShow #else compatPrettyShow :: FilePath -> FilePath compatPrettyShow = id #endif -- | Traverse the given tree, solve predicates in branches, and return its -- contents. -- -- XXX: Branches guarded by Cabal flags are ignored. I'm not sure where we should -- get this info from. -- solveCondTree :: CondTree ConfVar c a -> [(c, a)] solveCondTree CondNode{condTreeData, condTreeConstraints, condTreeComponents} = (condTreeConstraints, condTreeData) : concatMap goBranch condTreeComponents where goBranch :: CondBranch ConfVar c a -> [(c, a)] goBranch (CondBranch condBranchCondition condBranchIfTrue condBranchIfFalse) = if goCondition condBranchCondition then solveCondTree condBranchIfTrue else maybe mempty solveCondTree condBranchIfFalse goCondition :: Condition ConfVar -> Bool goCondition = \case Var cv -> case cv of OS os -> os == buildOS Arch ar -> ar == buildArch Impl cf versionRange -> case cf of GHC -> withinRange buildGhc versionRange _ -> error ("Unrecognized compiler: " <> show cf) -- XXX: We currently ignore any flags passed to Cabal #if MIN_VERSION_Cabal(3,4,0) PackageFlag _fn -> False #else Flag _fn -> False #endif Lit b -> b CNot con -> not (goCondition con) COr con0 con1 -> goCondition con0 || goCondition con1 CAnd con0 con1 -> goCondition con0 && goCondition con1 -- | GHC version as Cabal's 'Version' data structure buildGhc :: Version buildGhc = mkVersion' compilerVersion -- | Given a filepath to a @package.cabal@, parse it, and yield a "Library". Yields -- the default Library if first argument is Nothing, otherwise it will look for -- a specific sublibrary. extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library extractSpecificCabalLibrary maybeLibName pkgPath = do pkg <- readGenericPackageDescription silent pkgPath case maybeLibName of Nothing -> case condLibrary pkg of Nothing -> let pkgDescription = package (packageDescription pkg) in error ("Could not find main library in: " <> show pkgDescription) Just lib -> pure (go lib) Just libName -> pure (go (findSubLib pkg libName (condSubLibraries pkg))) where findSubLib pkg targetLibName [] = let pkgDescription = package (packageDescription pkg) in error ("Could not find library " <> targetLibName <> " in " <> show pkgDescription) findSubLib pkg targetLibName ((libName, lib):libs) | unUnqualComponentName libName == targetLibName = lib | otherwise = findSubLib pkg targetLibName libs go condNode = mergeLibraries libs1 where libs0 = map snd (solveCondTree condNode) libs1 = map goLib libs0 goLib lib = Library { libSourceDirectories = map ((root ) . compatPrettyShow) sourceDirs , libCSourceDirectories = map (root ) cSourceDirs , libModules = exposedModules lib `rmList` autogenModules buildInfo , libDefaultExtensions = defaultExtensions buildInfo } where buildInfo = libBuildInfo lib sourceDirs = hsSourceDirs buildInfo cSourceDirs = includeDirs buildInfo root = takeDirectory pkgPath -- | Given a filepath to a @package.cabal@, parse it, and yield a "Library". Returns -- and error if no library was specified in the cabal package file. extractCabalLibrary :: FilePath -> IO Library extractCabalLibrary = extractSpecificCabalLibrary Nothing doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/0000755000000000000000000000000007346545000020131 5ustar0000000000000000doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Extract.hs0000644000000000000000000003253707346545000022111 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module Test.DocTest.Internal.Extract (Module(..), extract, eraseConfigLocation) where import Prelude hiding (mod, concat) import Control.Monad import Control.Exception import Data.List (partition, isPrefixOf) import Data.List.Extra (trim) import Data.Maybe import Control.DeepSeq (NFData, deepseq) import Data.Generics (Data, Typeable, extQ, mkQ, everythingBut) import qualified GHC #if __GLASGOW_HASKELL__ < 900 import GHC hiding (Module, Located, moduleName) import DynFlags import MonadUtils (liftIO) #else import GHC hiding (Module, Located, moduleName) import GHC.Driver.Session import GHC.Utils.Monad (liftIO) #endif #if __GLASGOW_HASKELL__ < 900 import Digraph (flattenSCCs) import Exception (ExceptionMonad) #else import GHC.Data.Graph.Directed (flattenSCCs) import GHC.Utils.Exception (ExceptionMonad) import Control.Monad.Catch (generalBracket) #endif import System.Directory import System.FilePath #if __GLASGOW_HASKELL__ < 900 import BasicTypes (SourceText(SourceText)) import FastString (unpackFS) #elif __GLASGOW_HASKELL__ < 902 import GHC.Data.FastString (unpackFS) import GHC.Types.Basic (SourceText(SourceText)) #elif __GLASGOW_HASKELL__ < 906 import GHC.Types.SourceText (SourceText(SourceText)) import GHC.Data.FastString (unpackFS) #else import GHC.Data.FastString (unpackFS) #endif import System.Posix.Internals (c_getpid) import Test.DocTest.Internal.GhcUtil (withGhc) import Test.DocTest.Internal.Location hiding (unLoc) import Test.DocTest.Internal.Util (convertDosLineEndings) #if __GLASGOW_HASKELL__ >= 806 #if __GLASGOW_HASKELL__ < 900 import DynamicLoading (initializePlugins) #else import GHC.Runtime.Loader (initializePlugins) #endif #endif #if __GLASGOW_HASKELL__ >= 901 import GHC.Unit.Module.Graph #endif import GHC.Generics (Generic) -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException deriving Typeable instance Show ExtractError where show (ExtractError e) = unlines [ "Ouch! Hit an error thunk in GHC's AST while extracting documentation." , "" , " " ++ msg , "" , "This is most likely a bug in doctest-parallel." , "" , "Please report it here: https://github.com/martijnbastiaan/doctest-parallel/issues/new" ] where msg = case fromException e of Just (Panic s) -> "GHC panic: " ++ s _ -> show e instance Exception ExtractError -- | Documentation for a module grouped together with the modules name. data Module a = Module { moduleName :: String , moduleSetup :: Maybe a , moduleContent :: [a] , moduleConfig :: [Located String] } deriving (Eq, Functor, Show, Generic, NFData) eraseConfigLocation :: Module a -> Module a eraseConfigLocation m@Module{moduleConfig} = m{moduleConfig=map go moduleConfig} where go (Located _ a) = noLocation a #if __GLASGOW_HASKELL__ < 803 type GhcPs = RdrName #endif #if __GLASGOW_HASKELL__ < 805 addQuoteInclude :: [String] -> [String] -> [String] addQuoteInclude includes new = new ++ includes #endif -- | Parse a list of modules. parse :: [String] -> IO [ParsedModule] parse args = withGhc args $ \modules -> withTempOutputDir $ do setTargets =<< forM modules (\ m -> guessTarget m #if __GLASGOW_HASKELL__ >= 903 Nothing #endif Nothing) mods <- depanal [] False let sortedMods = 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 let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of Just "YES" -> gopt_set dflags Opt_BuildDynamicToo _ -> dflags _ <- setSessionDynFlags (f dflags') return () withTempOutputDir :: Ghc a -> Ghc a withTempOutputDir action = do tmp <- liftIO getTemporaryDirectory x <- liftIO c_getpid let dir = tmp ".doctest-" ++ show x modifySessionDynFlags (setOutputDir dir) gbracket_ (liftIO $ createDirectory dir) (liftIO $ removeDirectoryRecursive dir) action -- | A variant of 'gbracket' where the return value from the first computation -- is not required. gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c #if __GLASGOW_HASKELL__ < 900 gbracket_ before_ after thing = gbracket before_ (const after) (const thing) #else gbracket_ before_ after thing = fst <$> generalBracket before_ (\ _ _ -> after) (const thing) #endif setOutputDir f d = d { objectDir = Just f , hiDir = Just f , stubDir = Just f , includePaths = addQuoteInclude (includePaths d) [f] } #if __GLASGOW_HASKELL__ >= 806 -- Since GHC 8.6, plugins are initialized on a per module basis loadModPlugins modsum = do _ <- setSessionDynFlags (GHC.ms_hspp_opts modsum) hsc_env <- getSession # if __GLASGOW_HASKELL__ >= 901 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 #else loadModPlugins = return #endif -- | Extract all docstrings from given list of files/modules. -- -- This includes the docstrings of all local modules that are imported from -- those modules (possibly indirect). extract :: [String] -> IO [Module (Located String)] extract args = do mods <- parse args let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule) mods (docs `deepseq` return docs) `catches` [ -- Re-throw AsyncException, otherwise execution will not terminate on -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just -- UserInterrupt) because all of them indicate severe conditions and -- should not occur during normal operation. Handler (\e -> throw (e :: AsyncException)) , Handler (throwIO . ExtractError) ] -- | Extract all docstrings from given module and attach the modules name. extractFromModule :: ParsedModule -> Module (Located String) extractFromModule m = Module { moduleName = name , moduleSetup = listToMaybe (map snd setup) , moduleContent = map snd docs , moduleConfig = moduleAnnsFromModule m } where isSetup = (== Just "setup") . fst (setup, docs) = partition isSetup (docStringsFromModule m) name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m -- | Extract all module annotations from given module. moduleAnnsFromModule :: ParsedModule -> [Located String] moduleAnnsFromModule mod = [fmap stripOptionString ann | ann <- anns, isOption ann] where optionPrefix = "doctest-parallel:" isOption (Located _ s) = optionPrefix `isPrefixOf` s stripOptionString s = trim (drop (length optionPrefix) s) anns = extractModuleAnns source source = (unLoc . pm_parsed_source) mod -- | Extract all docstrings from given module. docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)] docStringsFromModule mod = #if __GLASGOW_HASKELL__ < 904 map (fmap (toLocated . fmap unpackHDS)) docs #else map (fmap (toLocated . fmap renderHsDocString)) docs #endif 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. header :: [(Maybe String, LHsDocString)] #if __GLASGOW_HASKELL__ < 904 header = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]] #elif __GLASGOW_HASKELL__ < 906 header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader source]] #else header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader (hsmodExt source)]] #endif exports :: [(Maybe String, LHsDocString)] exports = [ (Nothing, L (locA loc) doc) #if __GLASGOW_HASKELL__ < 710 | L loc (IEDoc doc) <- concat (hsmodExports source) #elif __GLASGOW_HASKELL__ < 805 | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source) #elif __GLASGOW_HASKELL__ < 904 | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source) #else | L loc (IEDoc _ (unLoc . fmap hsDocString -> doc)) <- maybe [] unLoc (hsmodExports source) #endif ] decls :: [(Maybe String, LHsDocString)] decls = extractDocStrings (Right (hsmodDecls source)) type Selector b a = a -> ([b], Bool) type DocSelector a = Selector (Maybe String, LHsDocString) a type AnnSelector a = Selector (Located String) a -- | Collect given value and descend into subtree. select :: a -> ([a], Bool) select x = ([x], False) #if __GLASGOW_HASKELL__ >= 904 -- | Don't collect any values noSelect :: ([a], Bool) noSelect = ([], False) #endif -- | Extract module annotations from given value. extractModuleAnns :: Data a => a -> [Located String] extractModuleAnns = everythingBut (++) (([], False) `mkQ` fromLHsDecl) where fromLHsDecl :: AnnSelector (LHsDecl GhcPs) fromLHsDecl (L (locA -> loc) decl) = case decl of #if __GLASGOW_HASKELL__ < 805 AnnD (HsAnnotation (SourceText _) ModuleAnnProvenance (L _loc expr)) #elif __GLASGOW_HASKELL__ < 906 AnnD _ (HsAnnotation _ (SourceText _) ModuleAnnProvenance (L _loc expr)) #else AnnD _ (HsAnnotation _ ModuleAnnProvenance (L _loc expr)) #endif | Just s <- extractLit loc expr -> select s _ -> -- XXX: Shouldn't this be handled by 'everythingBut'? (extractModuleAnns decl, True) -- | Extract string literals. Looks through type annotations and parentheses. extractLit :: SrcSpan -> HsExpr GhcPs -> Maybe (Located String) extractLit loc = \case -- well this is a holy mess innit #if __GLASGOW_HASKELL__ < 805 HsPar (L l e) -> extractLit l e ExprWithTySig (L l e) _ -> extractLit l e HsOverLit OverLit{ol_val=HsIsString _ s} -> Just (toLocated (L loc (unpackFS s))) HsLit (HsString _ s) -> Just (toLocated (L loc (unpackFS s))) _ -> Nothing #else #if __GLASGOW_HASKELL__ < 904 HsPar _ (L l e) -> extractLit (locA l) e #elif __GLASGOW_HASKELL__ < 909 HsPar _ _ (L l e) _ -> extractLit (locA l) e #else HsPar _ (L l e) -> extractLit (locA l) e #endif #if __GLASGOW_HASKELL__ < 807 ExprWithTySig _ (L l e) -> extractLit l e #else ExprWithTySig _ (L l e) _ -> extractLit (locA l) e #endif HsOverLit _ OverLit{ol_val=HsIsString _ s} -> Just (toLocated (L loc (unpackFS s))) HsLit _ (HsString _ s) -> Just (toLocated (L loc (unpackFS s))) _ -> Nothing #endif -- | Extract all docstrings from given value. extractDocStrings :: Either (HsDecl GhcPs) [LHsDecl GhcPs] -> [(Maybe String, LHsDocString)] extractDocStrings = everythingBut (++) ( ([], False) `mkQ` fromLHsDecl `extQ` fromLDocDecl `extQ` fromLHsDocString #if __GLASGOW_HASKELL__ >= 904 `extQ` fromHsType #endif ) where fromLHsDecl :: DocSelector (LHsDecl GhcPs) fromLHsDecl (L loc decl) = case decl of -- Top-level documentation has to be treated separately, because it has -- no location information attached. The location information is -- attached to HsDecl instead. #if __GLASGOW_HASKELL__ < 805 DocD x #else DocD _ x #endif -> select (fromDocDecl (locA loc) x) _ -> (extractDocStrings (Left decl), True) fromLDocDecl :: DocSelector #if __GLASGOW_HASKELL__ >= 901 (LDocDecl GhcPs) #else LDocDecl #endif fromLDocDecl (L loc x) = select (fromDocDecl (locA loc) x) fromLHsDocString :: DocSelector LHsDocString fromLHsDocString x = select (Nothing, x) #if __GLASGOW_HASKELL__ >= 904 fromHsType :: DocSelector (HsType GhcPs) fromHsType x = case x of HsDocTy _ _ (L loc hsDoc) -> select (Nothing, L loc (hsDocString hsDoc)) _ -> noSelect #endif #if __GLASGOW_HASKELL__ < 904 fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString) #else fromDocDecl :: SrcSpan -> DocDecl GhcPs -> (Maybe String, LHsDocString) #endif fromDocDecl loc x = case x of #if __GLASGOW_HASKELL__ < 904 DocCommentNamed name doc -> (Just name, L loc doc) _ -> (Nothing, L loc $ docDeclDoc x) #else DocCommentNamed name doc -> (Just name, hsDocString <$> doc) _ -> (Nothing, L loc $ hsDocString $ unLoc $ docDeclDoc x) #endif #if __GLASGOW_HASKELL__ < 805 -- | Convert a docstring to a plain string. unpackHDS :: HsDocString -> String unpackHDS (HsDocString s) = unpackFS s #endif #if __GLASGOW_HASKELL__ < 901 locA :: SrcSpan -> SrcSpan locA = id #endif doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/GhcUtil.hs0000644000000000000000000000417507346545000022033 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.DocTest.Internal.GhcUtil (withGhc) where import GHC.Paths (libdir) import GHC #if __GLASGOW_HASKELL__ < 900 import DynFlags (gopt_set) #else import GHC.Driver.Session (gopt_set) #endif #if __GLASGOW_HASKELL__ < 900 import Panic (throwGhcException) #else import GHC.Utils.Panic (throwGhcException) #endif #if __GLASGOW_HASKELL__ < 900 import MonadUtils (liftIO) #else import GHC.Utils.Monad (liftIO) #endif import System.Exit (exitFailure) -- Catch GHC source errors, print them and exit. handleSrcErrors :: Ghc a -> Ghc a handleSrcErrors action' = flip handleSourceError action' $ \err -> do printException err liftIO exitFailure -- | Run a GHC action in Haddock mode withGhc :: [String] -> ([String] -> Ghc a) -> IO a withGhc flags action = do flags_ <- handleStaticFlags flags runGhc (Just libdir) $ do handleDynamicFlags flags_ >>= handleSrcErrors . action handleStaticFlags :: [String] -> IO [Located String] handleStaticFlags flags = return $ map noLoc $ flags handleDynamicFlags :: GhcMonad m => [Located String] -> m [String] handleDynamicFlags flags = do #if __GLASGOW_HASKELL__ >= 901 logger <- getLogger let parseDynamicFlags' = parseDynamicFlags logger #else let parseDynamicFlags' = parseDynamicFlags #endif dynflags0 <- setHaddockMode <$> getSessionDynFlags (dynflags1, locSrcs, _) <- parseDynamicFlags' dynflags0 flags _ <- setSessionDynFlags dynflags1 -- We basically do the same thing as `ghc/Main.hs` to distinguish -- "unrecognised flags" from source files. let srcs = map unLoc locSrcs unknown_opts = [ f | f@('-':_) <- srcs ] case unknown_opts of opt : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'")) _ -> return srcs setHaddockMode :: DynFlags -> DynFlags setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) { #if __GLASGOW_HASKELL__ >= 906 backend = noBackend #elif __GLASGOW_HASKELL__ >= 901 backend = NoBackend #else hscTarget = HscNothing #endif , ghcMode = CompManager , ghcLink = NoLink } doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/GhciWrapper.hs0000644000000000000000000001254107346545000022703 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} module Test.DocTest.Internal.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 import Test.DocTest.Internal.Logging (DebugLogger) 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 , logger :: DebugLogger } new :: DebugLogger -> Config -> [String] -> IO Interpreter new logger Config{..} args_ = do logger ("Calling: " ++ unwords (configGhci:args)) (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 , logger=logger } _ <- eval interpreter "import qualified System.IO" _ <- eval interpreter "import qualified GHC.IO.Handle" -- The buffering of stdout and stderr is NoBuffering _ <- eval interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr" -- Now the buffering of stderr is BlockBuffering Nothing -- In this situation, GHC 7.7 does not flush the buffer even when -- error happens. _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering" _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering" -- this is required on systems that don't use utf8 as default encoding (e.g. -- Windows) _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout System.IO.utf8" _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr System.IO.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 $ "Test.DocTest.Internal.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")") putExpression :: Interpreter -> Bool -> String -> IO () putExpression Interpreter{logger = logger, hIn = stdin} preserveIt e = do logger (">>> " ++ e) hPutStrLn stdin e when preserveIt $ do let e1 = "let " ++ itMarker ++ " = it" logger (">>> " ++ e1) hPutStrLn stdin e1 hPutStrLn stdin (marker ++ " :: Data.String.String") when preserveIt $ do let e3 = "let it = " ++ itMarker logger (">>> " ++ e3) hPutStrLn stdin e3 hFlush stdin getResult :: Bool -> Interpreter -> IO String getResult echoMode Interpreter{logger = logger, hOut = stdout} = do result <- go unless (result == mempty) $ logger result pure result where go = do line <- hGetLine stdout if | marker `isSuffixOf` line -> do let xs = stripMarker line echo xs return xs #if __GLASGOW_HASKELL__ < 810 -- For some (happy) reason newer GHCs don't decide to print this -- message - or at least we don't see it. | "Loaded package environment from " `isPrefixOf` line -> do go #endif | otherwise -> do echo (line ++ "\n") result <- go return (line ++ "\n" ++ result) stripMarker l = take (length l - length marker) l echo :: String -> IO () echo | echoMode = putStr | otherwise = (const $ return ()) -- | Evaluate an expression eval :: Interpreter -> String -> IO String eval repl expr = do putExpression repl False expr getResult False repl -- | Like 'eval', but try to preserve the @it@ variable evalIt :: Interpreter -> String -> IO String evalIt repl expr = do putExpression repl True expr getResult False repl -- | Evaluate an expression evalEcho :: Interpreter -> String -> IO String evalEcho repl expr = do putExpression repl False expr getResult True repl doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Interpreter.hs0000644000000000000000000000630107346545000022770 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ <= 906 {-# LANGUAGE LambdaCase #-} #endif module Test.DocTest.Internal.Interpreter ( Interpreter , safeEval , safeEvalIt , withInterpreter , ghc , interpreterSupported -- * exported for testing , ghcInfo , haveInterpreterKey ) where import System.Process import System.Directory (getPermissions, executable) import Control.Monad import Control.Exception hiding (handle) import Data.Char #if __GLASGOW_HASKELL__ > 906 import Data.List (unsnoc) #else import Data.Bifunctor (first) #endif import GHC.Paths (ghc) import Test.DocTest.Internal.GhciWrapper import Test.DocTest.Internal.Logging (DebugLogger) -- $setup -- >>> import Test.DocTest.Internal.GhciWrapper (eval) -- >>> import Test.DocTest.Internal.Logging (noLogger) #if __GLASGOW_HASKELL__ <= 906 -- | If the list is empty returns 'Nothing', otherwise returns the 'init' and the 'last'. -- -- > unsnoc "test" == Just ("tes",'t') -- > unsnoc "" == Nothing -- > \xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs) unsnoc :: [a] -> Maybe ([a], a) unsnoc = \case [] -> Nothing x:xs -> Just $ unsnoc1 x xs where unsnoc1 :: a -> [a] -> ([a], a) unsnoc1 x = \case [] -> ([], x) y:ys -> first (x:) $ unsnoc1 y ys #endif haveInterpreterKey :: String haveInterpreterKey = "Have interpreter" ghcInfo :: IO [(String, String)] ghcInfo = read <$> readProcess ghc ["--info"] [] interpreterSupported :: IO Bool interpreterSupported = do -- in a perfect world this permission check should never fail, but I know of -- at least one case where it did.. x <- getPermissions ghc unless (executable x) $ do fail $ ghc ++ " is not executable!" maybe False (== "YES") . lookup haveInterpreterKey <$> ghcInfo -- | Run an interpreter session. -- -- Example: -- -- >>> withInterpreter noLogger [] $ \i -> eval i "23 + 42" -- "65\n" withInterpreter :: DebugLogger -- ^ Debug logger -> [String] -- ^ List of flags, passed to GHC -> (Interpreter -> IO a) -- ^ Action to run -> IO a -- ^ Result of action withInterpreter logger flags action = do let args = flags ++ [ "--interactive" #if __GLASGOW_HASKELL__ >= 802 , "-fdiagnostics-color=never" , "-fno-diagnostics-show-caret" #endif ] bracket (new logger defaultConfig{configGhci = ghc} args) close action -- | Evaluate an expression; return a Left value on exceptions. -- -- An exception may e.g. be caused on unterminated multiline expressions. safeEval :: Interpreter -> String -> IO (Either String String) safeEval repl = either (return . Left) (fmap Right . eval repl) . filterExpression safeEvalIt :: Interpreter -> String -> IO (Either String String) safeEvalIt repl = either (return . Left) (fmap Right . evalIt repl) . filterExpression filterExpression :: String -> Either String String filterExpression e = case map strip (lines e) of [] -> Right e (firstLine:ls) -> let lastLine = maybe firstLine snd (unsnoc ls) in if firstLine == ":{" && lastLine /= ":}" then fail_ else Right e where fail_ = Left "unterminated multiline command" strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Location.hs0000644000000000000000000000415207346545000022237 0ustar0000000000000000{-# LANGUAGE CPP, DeriveFunctor #-} module Test.DocTest.Internal.Location where import Control.DeepSeq (deepseq, NFData(rnf)) #if __GLASGOW_HASKELL__ < 900 import SrcLoc hiding (Located) import qualified SrcLoc as GHC import FastString (unpackFS) #else import GHC.Types.SrcLoc hiding (Located) import qualified GHC.Types.SrcLoc as GHC import GHC.Data.FastString (unpackFS) #endif -- | A thing with a location attached. data Located a = Located Location a deriving (Eq, Show, Functor) instance NFData a => NFData (Located a) where rnf (Located loc a) = loc `deepseq` a `deepseq` () -- | Convert a GHC located thing to a located thing. toLocated :: GHC.Located a -> Located a toLocated (L loc a) = Located (toLocation loc) a -- | Discard location information. unLoc :: Located a -> a unLoc (Located _ a) = a -- | Add dummy location information. noLocation :: a -> Located a noLocation = Located (UnhelpfulLocation "") -- | A line number. type Line = Int -- | A combination of file name and line number. data Location = UnhelpfulLocation String | Location FilePath Line deriving Eq instance Show Location where show (UnhelpfulLocation s) = s show (Location file line) = file ++ ":" ++ show line instance NFData Location where rnf (UnhelpfulLocation str) = str `deepseq` () rnf (Location file line) = file `deepseq` line `deepseq` () -- | -- Create a list from a location, by repeatedly increasing the line number by -- one. enumerate :: Location -> [Location] enumerate loc = case loc of UnhelpfulLocation _ -> repeat loc Location file line -> map (Location file) [line ..] -- | Convert a GHC source span to a location. toLocation :: SrcSpan -> Location #if __GLASGOW_HASKELL__ < 900 toLocation loc = case loc of UnhelpfulSpan str -> UnhelpfulLocation (unpackFS str) RealSrcSpan sp -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) #else toLocation loc = case loc of UnhelpfulSpan str -> UnhelpfulLocation (unpackFS $ unhelpfulSpanFS str) RealSrcSpan sp _ -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) #endif doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Logging.hs0000644000000000000000000000662007346545000022057 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ViewPatterns #-} module Test.DocTest.Internal.Logging where import Control.Applicative (Alternative((<|>))) import Control.Concurrent (ThreadId, myThreadId) import Control.DeepSeq (NFData) import Data.Char (toLower, toUpper) import Data.List (intercalate) import GHC.Generics (Generic) import System.IO (hPutStrLn, stderr) import Text.Printf (printf) -- | Convenience type alias - not used in this module, but sprinkled across the -- project. type DebugLogger = String -> IO () -- | Discards any log message noLogger :: DebugLogger noLogger = const (pure ()) data LogLevel = Debug -- ^ Intended for debug runs | Verbose -- ^ Intended for debug runs, but without flooding the user with internal messages | Info -- ^ Default log level - print messages user is likely wanting to see | Warning -- ^ Only print warnings | Error -- ^ Only print errors deriving (Show, Eq, Enum, Generic, NFData, Ord, Bounded) -- | Case insensitive -- -- >>> parseLogLevel "Info" -- Just Info -- >>> parseLogLevel "info" -- Just Info -- >>> parseLogLevel "errox" -- Nothing -- parseLogLevel :: String -> Maybe LogLevel parseLogLevel (map toLower -> level) = foldl (<|>) Nothing (map go [minBound..]) where go :: LogLevel -> Maybe LogLevel go l | map toLower (show l) == level = Just l | otherwise = Nothing -- | Pretty print a 'LogLevel' in a justified manner, i.e., all outputs take the -- same amount of characters to display. -- -- >>> showJustifiedLogLevel Debug -- "Debug " -- >>> showJustifiedLogLevel Verbose -- "Verbose" -- >>> showJustifiedLogLevel Info -- "Info " -- >>> showJustifiedLogLevel Warning -- "Warning" -- >>> showJustifiedLogLevel Error -- "Error " -- showJustifiedLogLevel :: LogLevel -> String showJustifiedLogLevel = justifyLeft maxSizeLogLevel ' ' . show where maxSizeLogLevel :: Int maxSizeLogLevel = maximum (map (length . show) [(minBound :: LogLevel)..]) -- | Justify a list with a custom fill symbol -- -- >>> justifyLeft 10 'x' "foo" -- "fooxxxxxxx" -- >>> justifyLeft 3 'x' "foo" -- "foo" -- >>> justifyLeft 2 'x' "foo" -- "foo" -- justifyLeft :: Int -> a -> [a] -> [a] justifyLeft n c s = s ++ replicate (n - length s) c -- | /Prettily/ format a log message -- -- > threadId <- myThreadId -- > formatLog Debug threadId "some debug message" -- "[DEBUG ] [ThreadId 1277462] some debug message" -- formatLog :: ThreadId -> LogLevel -> String -> String formatLog threadId lvl msg = do intercalate "\n" (map go (lines msg)) where go line = printf "[%s] [%s] %s" (map toUpper (showJustifiedLogLevel lvl)) (show threadId) line -- | Like 'formatLog', but instantiates the /thread/ argument with the current 'ThreadId' -- -- > formatLogHere Debug "some debug message" -- "[DEBUG ] [ThreadId 1440849] some debug message" -- formatLogHere :: LogLevel -> String -> IO String formatLogHere lvl msg = do threadId <- myThreadId pure (formatLog threadId lvl msg) -- | Should a message be printed? For a given verbosity level and message log level. shouldLog :: (?verbosity :: LogLevel) => LogLevel -> Bool shouldLog lvl = ?verbosity <= lvl -- | Basic logging function. Uses 'formatLogHere'. Is not thread-safe. log :: (?verbosity :: LogLevel) => LogLevel -> String -> IO () log lvl msg | shouldLog lvl = hPutStrLn stderr =<< formatLogHere lvl msg | otherwise = pure () doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Nix.hs0000644000000000000000000001032207346545000021221 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} module Test.DocTest.Internal.Nix where import Control.Monad (msum) import Control.Monad.Extra (ifM) import Control.Monad.Trans.Maybe import Data.Bool (bool) import Data.List (intercalate, isSuffixOf) import Data.Maybe (isJust) import Data.Version import GHC.Base (mzero) import System.Directory import System.Environment (lookupEnv) import System.FilePath ((), isDrive, takeDirectory) import System.Process (readProcess) #if __GLASGOW_HASKELL__ >= 900 import GHC.Data.Maybe (liftMaybeT) import System.Info (fullCompilerVersion) #else import Maybes (liftMaybeT) import System.Info (compilerVersion) fullCompilerVersion :: Version fullCompilerVersion = case compilerVersion of Version majorMinor tags -> Version (majorMinor ++ [lvl1]) tags where lvl1 :: Int lvl1 = __GLASGOW_HASKELL_PATCHLEVEL1__ #endif -- | E.g. @9.0.2@ compilerVersionStr :: String compilerVersionStr = intercalate "." (map show (versionBranch fullCompilerVersion)) -- | Traverse upwards until one of the following conditions is met: -- -- * Current working directory is either root or a home directory -- * The predicate function returns 'Just' -- findDirectoryUp :: (FilePath -> IO (Maybe a)) -> MaybeT IO a findDirectoryUp f = do home <- liftMaybeT getHomeDirectory MaybeT (go home =<< getCurrentDirectory) where go home cwd | isDrive cwd = pure Nothing | cwd == home = pure Nothing | otherwise = f cwd >>= \case Just a -> pure (Just a) Nothing -> go home (takeDirectory cwd) -- | Like 'findDirectoryUp', but takes a predicate function instead. If the predicate -- yields 'True', the filepath is returned. findDirectoryUpPredicate :: (FilePath -> IO Bool) -> MaybeT IO FilePath findDirectoryUpPredicate f = findDirectoryUp (\fp -> bool Nothing (Just fp) <$> f fp) -- | Find the root of the Cabal project relative to the current directory. findCabalProjectRoot :: MaybeT IO FilePath findCabalProjectRoot = msum [ findDirectoryUpPredicate containsCabalProject , findDirectoryUpPredicate containsCabalPackage ] where containsCabalPackage :: FilePath -> IO Bool containsCabalPackage fp = elem "cabal.project" <$> getDirectoryContents fp containsCabalProject :: FilePath -> IO Bool containsCabalProject fp = any (".cabal" `isSuffixOf`) <$> getDirectoryContents fp -- | Find the local package database in @dist-newstyle@. findLocalPackageDb :: MaybeT IO FilePath findLocalPackageDb = do projectRoot <- findCabalProjectRoot let relDir = "dist-newstyle" "packagedb" ("ghc-" ++ compilerVersionStr) absDir = projectRoot relDir ifM (liftMaybeT (doesDirectoryExist absDir)) (return absDir) mzero -- | Are we running in a Nix shell? inNixShell :: IO Bool inNixShell = isJust <$> lookupEnv "IN_NIX_SHELL" -- | Are we running in a Nix build environment? inNixBuild :: IO Bool inNixBuild = isJust <$> lookupEnv "NIX_BUILD_TOP" getLocalCabalPackageDbArgs :: IO [String] getLocalCabalPackageDbArgs = do runMaybeT findLocalPackageDb >>= \case Nothing -> pure [] Just s -> pure ["-package-db", s] getLocalNixPackageDbArgs :: IO [String] getLocalNixPackageDbArgs = do pkgDb <- makeAbsolute ("dist" "package.conf.inplace") ifM (doesDirectoryExist pkgDb) (pure ["-package-db", pkgDb]) (pure []) -- | Get global package db; used in a NIX_SHELL context getGlobalPackageDb :: IO String getGlobalPackageDb = init <$> readProcess "ghc" ["--print-global-package-db"] "" -- | Get flags to be used when running in a Nix context (either in a build, or a -- shell). getNixGhciArgs :: IO [String] getNixGhciArgs = ifM inNixShell goShell (ifM inNixBuild goBuild (pure [])) where goShell = do globalPkgDb <- getGlobalPackageDb localPkgDbFlag <- getLocalCabalPackageDbArgs let globalDbFlag = ["-package-db", globalPkgDb] pure (defaultArgs ++ globalDbFlag ++ localPkgDbFlag) goBuild = do localDbFlag <- getLocalNixPackageDbArgs pure (defaultArgs ++ localDbFlag) defaultArgs = [ "-package-env", "-" -- Nix doesn't always expose the GHC library (_specifically_ the GHC lib) even -- if a package lists it as a dependency. This simply always exposes it as a -- workaround. , "-package", "ghc" ] doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Options.hs0000644000000000000000000002163007346545000022122 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} module Test.DocTest.Internal.Options where import Prelude () import Prelude.Compat import Control.DeepSeq (NFData) import Data.List.Compat import GHC.Generics (Generic) import Text.Read (readMaybe) import qualified Paths_doctest_parallel import Data.Version (showVersion) #if __GLASGOW_HASKELL__ < 900 import Config as GHC #else import GHC.Settings.Config as GHC #endif import Test.DocTest.Internal.Location (Located (Located), Location) import Test.DocTest.Internal.Interpreter (ghc) import Test.DocTest.Internal.Logging (LogLevel(..)) import qualified Test.DocTest.Internal.Logging as Logging usage :: String usage = unlines [ "Usage:" , " doctest [ options ]... []..." , " doctest --help" , " doctest --version" , " doctest --info" , "" , "Options:" , " -jN number of threads to use" , " --log-level=LEVEL one of: debug, verbose, info, warning, error. Default: info." , " --ghc-arg=ARG pass argument to GHC when parsing, pass multiple times for multiple flags" , "† --implicit-module-import import module before testing it (default)" , "† --randomize-order randomize order in which tests are run" , "† --seed=N use a specific seed to randomize test order" , "† --preserve-it preserve the `it` variable between examples" , " --nix account for Nix build environments (default)" , " --quiet set log level to `Error`, shorthand for `--log-level=error`" , " --verbose set log level to `Verbose`, shorthand for `--log-level=verbose`" , " --debug set log level to `Debug`, shorthand for `--log-level=debug`" , " --help display this help and exit" , " --version output version information and exit" , " --info output machine-readable version information and exit" , "" , "Supported inverted options:" , " --no-nix" , "† --no-implicit-module-import" , "† --no-randomize-order (default)" , "† --no-preserve-it (default)" , "" , "Options marked with a dagger (†) can also be used to set module level options, using" , "an ANN pragma like this:" , "" , " {-# ANN module \"doctest-parallel: --no-randomize-order\" #-} " , "" ] version :: String version = showVersion Paths_doctest_parallel.version ghcVersion :: String ghcVersion = GHC.cProjectVersion versionInfo :: String versionInfo = unlines [ "doctest version " ++ version , "using version " ++ ghcVersion ++ " of the GHC API" , "using " ++ ghc ] info :: String info = "[ " ++ (intercalate "\n, " . map show $ [ ("version", version) , ("ghc_version", ghcVersion) , ("ghc", ghc) ]) ++ "\n]\n" data Result a = ResultStderr String | ResultStdout String | Result a deriving (Eq, Show, Functor) type Warning = String type ModuleName = String data Config = Config { cfgLogLevel :: LogLevel -- ^ Verbosity level. , cfgModules :: [ModuleName] -- ^ Module names to test. An empty list means "test all modules". , cfgThreads :: Maybe Int -- ^ Number of threads to use. Defaults to autodetection based on the number -- of cores. , cfgModuleConfig :: ModuleConfig -- ^ Options specific to modules , cfgNix :: Bool -- ^ Detect Nix build environment and try to make GHC aware of the local package -- being tested. , cfgGhcArgs :: [String] -- ^ Extra arguments passed to GHC when parsing } deriving (Show, Eq, Generic, NFData) data ModuleConfig = ModuleConfig { cfgPreserveIt :: Bool -- ^ Preserve the @it@ variable between examples (default: @False@) , cfgRandomizeOrder :: Bool -- ^ Randomize the order in which test cases in a module are run (default: @False@) , cfgSeed :: Maybe Int -- ^ Initialize random number generator used to randomize test cases when -- 'cfgRandomizeOrder' is set. If set to 'Nothing', a random seed is picked -- from a system RNG source on startup. , cfgImplicitModuleImport :: Bool -- ^ Import a module before testing it. Can be disabled to enabled to test -- non-exposed modules. } deriving (Show, Eq, Generic, NFData) defaultModuleConfig :: ModuleConfig defaultModuleConfig = ModuleConfig { cfgPreserveIt = False , cfgRandomizeOrder = False , cfgSeed = Nothing , cfgImplicitModuleImport = True } defaultConfig :: Config defaultConfig = Config { cfgModules = [] , cfgThreads = Nothing , cfgLogLevel = Info , cfgModuleConfig = defaultModuleConfig , cfgNix = True , cfgGhcArgs = [] } parseLocatedModuleOptions :: ModuleName -> ModuleConfig -> [Located String] -> Either (Location, String) ModuleConfig parseLocatedModuleOptions _modName modConfig [] = Right modConfig parseLocatedModuleOptions modName modConfig0 (Located loc o:os) = case parseModuleOption modConfig0 o of Nothing -> Left (loc, o) Just modConfig1 -> parseLocatedModuleOptions modName modConfig1 os parseModuleOption :: ModuleConfig -> String -> Maybe ModuleConfig parseModuleOption config arg = case arg of "--randomize-order" -> Just config{cfgRandomizeOrder=True} "--no-randomize-order" -> Just config{cfgRandomizeOrder=False} "--preserve-it" -> Just config{cfgPreserveIt=True} "--no-preserve-it" -> Just config{cfgPreserveIt=False} "--implicit-module-import" -> Just config{cfgImplicitModuleImport=True} "--no-implicit-module-import" -> Just config{cfgImplicitModuleImport=False} ('-':_) | Just n <- parseSeed arg -> Just config{cfgSeed=Just n} _ -> Nothing parseOptions :: [String] -> Result Config parseOptions = fmap revGhcArgs . go defaultConfig where go config [] = Result config go config (arg:args) = case arg of "--help" -> ResultStdout usage "--info" -> ResultStdout info "--version" -> ResultStdout versionInfo "--quiet" -> go config{cfgLogLevel=Error} args "--verbose" -> go config{cfgLogLevel=Verbose} args "--debug" -> go config{cfgLogLevel=Debug} args "--nix" -> go config{cfgNix=True} args "--no-nix" -> go config{cfgNix=False} args ('-':_) | Just n <- parseThreads arg -> go config{cfgThreads=Just n} args ('-':_) | Just l <- parseLogLevel arg -> go config{cfgLogLevel=l} args ('-':_) | Just a <- parseGhcArg arg -> go (addGhcArg a config) args ('-':_) -- Module specific configuration options | Just modCfg <- parseModuleOption (cfgModuleConfig config) arg -> go config{cfgModuleConfig=modCfg} args ('-':_) -> ResultStderr ("Unknown command line argument: " <> arg) mod_ -> go config{cfgModules=mod_ : cfgModules config} args addGhcArg :: String -> Config -> Config addGhcArg arg Config{..} = Config{cfgGhcArgs=arg:cfgGhcArgs, ..} revGhcArgs :: Config -> Config revGhcArgs Config{..} = Config{cfgGhcArgs=reverse cfgGhcArgs, ..} -- | Parse ghc-arg argument -- -- >>> parseGhcArg "--ghc-arg=foobar" -- Just "foobar" -- >>> parseGhcArg "--ghc-arg=-DFOO=3" -- Just "-DFOO=3" -- parseGhcArg :: String -> Maybe String parseGhcArg arg = parseSpecificFlag arg "ghc-arg" -- | Parse seed argument -- -- >>> parseSeed "--seed=6" -- Just 6 -- >>> parseSeed "--seeeed=6" -- Nothing -- parseSeed :: String -> Maybe Int parseSeed arg = readMaybe =<< parseSpecificFlag arg "seed" -- | Parse seed argument -- -- >>> parseLogLevel "--log-level=Debug" -- Just Debug -- >>> parseLogLevel "--log-level=debug" -- Just Debug -- >>> parseSeed "---log-level=debug" -- Nothing parseLogLevel :: String -> Maybe LogLevel parseLogLevel arg = Logging.parseLogLevel =<< parseSpecificFlag arg "log-level" -- | Parse number of threads argument -- -- >>> parseThreads "-j6" -- Just 6 -- >>> parseThreads "-j-2" -- Nothing -- >>> parseThreads "-jA" -- Nothing -- parseThreads :: String -> Maybe Int parseThreads ('-':'j':n0) = do n1 <- readMaybe n0 if n1 > 0 then Just n1 else Nothing parseThreads _ = Nothing -- | Parse a specific flag with a value, or return 'Nothing' -- -- >>> parseSpecificFlag "--foo" "foo" -- Nothing -- >>> parseSpecificFlag "--foo=" "foo" -- Nothing -- >>> parseSpecificFlag "--foo=5" "foo" -- Just "5" -- >>> parseSpecificFlag "--foo=5" "bar" -- Nothing parseSpecificFlag :: String -> String -> Maybe String parseSpecificFlag arg flag = do case parseFlag arg of ('-':'-':f, value) | f == flag -> value _ -> Nothing -- | Parse a flag into its flag and argument component. -- -- Example: -- -- >>> parseFlag "--optghc=foo" -- ("--optghc",Just "foo") -- >>> parseFlag "--optghc=" -- ("--optghc",Nothing) -- >>> parseFlag "--fast" -- ("--fast",Nothing) parseFlag :: String -> (String, Maybe String) parseFlag arg = case break (== '=') arg of (flag, ['=']) -> (flag, Nothing) (flag, '=':opt) -> (flag, Just opt) (flag, _) -> (flag, Nothing) doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Parse.hs0000644000000000000000000001340407346545000021541 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Test.DocTest.Internal.Parse ( Module (..) , DocTest (..) , Interaction , Expression , ExpectedResult , ExpectedLine (..) , LineChunk (..) , getDocTests -- * exported for testing , parseInteractions , parseProperties , mkLineChunks ) where import Data.Char (isSpace) import Data.List import Data.Maybe import Data.String import Test.DocTest.Internal.Extract import Test.DocTest.Internal.Location data DocTest = Example Expression ExpectedResult | Property Expression deriving (Eq, Show) data LineChunk = LineChunk String | WildCardChunk deriving (Show, Eq) instance IsString LineChunk where fromString = LineChunk data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine deriving (Show, Eq) instance IsString ExpectedLine where fromString = ExpectedLine . return . LineChunk type Expression = String type ExpectedResult = [ExpectedLine] type Interaction = (Expression, ExpectedResult) -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules. getDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's getDocTests args = parseModules <$> extract args parseModules :: [Module (Located String)] -> [Module [Located DocTest]] parseModules = filter (not . isEmpty) . map parseModule where isEmpty (Module _ setup tests _) = null tests && isNothing setup -- | Convert documentation to `Example`s. parseModule :: Module (Located String) -> Module [Located DocTest] parseModule m = case parseComment <$> m of Module name setup tests cfg -> Module name setup_ (filter (not . null) tests) cfg where setup_ = case setup of Just [] -> Nothing _ -> setup parseComment :: Located String -> [Located DocTest] parseComment c = properties ++ examples where examples = map (fmap $ uncurry Example) (parseInteractions c) properties = map (fmap Property) (parseProperties c) -- | Extract all properties from given Haddock comment. parseProperties :: Located String -> [Located Expression] parseProperties (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) where isPrompt :: Located String -> Bool isPrompt = isPrefixOf "prop>" . dropWhile isSpace . unLoc go xs = case dropWhile (not . isPrompt) xs of prop:rest -> stripPrompt `fmap` prop : go rest [] -> [] stripPrompt = strip . drop 5 . dropWhile isSpace -- | Extract all interactions from given Haddock comment. parseInteractions :: Located String -> [Located Interaction] parseInteractions (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) where isPrompt :: Located String -> Bool isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc isBlankLine :: Located String -> Bool isBlankLine = null . dropWhile isSpace . unLoc isEndOfInteraction :: Located String -> Bool isEndOfInteraction x = isPrompt x || isBlankLine x go :: [Located String] -> [Located Interaction] go xs = case dropWhile (not . isPrompt) xs of prompt:rest | ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))), (ys,zs) <- break isBlankLine rest -> toInteraction prompt ys : go zs | otherwise -> let (ys,zs) = break isEndOfInteraction rest in toInteraction prompt ys : go zs [] -> [] -- | Create an `Interaction`, strip superfluous whitespace as appropriate. -- -- also merge lines between :{ and :}, preserving whitespace inside -- the block (since this is useful for avoiding {;}). toInteraction :: Located String -> [Located String] -> Located Interaction toInteraction (Located loc x) xs = Located loc $ ( (strip cleanedE) -- we do not care about leading and trailing -- whitespace in expressions, so drop them , map mkExpectedLine result_ ) where -- 1. drop trailing whitespace from the prompt, remember the prefix (prefix, e) = span isSpace x (ePrompt, eRest) = splitAt 3 e -- 2. drop, if possible, the exact same sequence of whitespace -- characters from each result line unindent pre = map (tryStripPrefix pre . unLoc) cleanBody line = fromMaybe (unLoc line) (stripPrefix ePrompt (dropWhile isSpace (unLoc line))) (cleanedE, result_) | (body , endLine : rest) <- break ( (==) [":}"] . take 1 . words . cleanBody) xs = (unlines (eRest : map cleanBody body ++ [dropWhile isSpace (cleanBody endLine)]), unindent (takeWhile isSpace (unLoc endLine)) rest) | otherwise = (eRest, unindent prefix xs) tryStripPrefix :: String -> String -> String tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys mkExpectedLine :: String -> ExpectedLine mkExpectedLine x = case x of "" -> "" "..." -> WildCardLine _ -> ExpectedLine $ mkLineChunks x mkLineChunks :: String -> [LineChunk] mkLineChunks = finish . foldr go (0, [], []) where mkChunk :: String -> [LineChunk] mkChunk "" = [] mkChunk x = [LineChunk x] go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk]) go '.' (count, acc, res) = if count == 2 then (0, "", WildCardChunk : mkChunk acc ++ res) else (count + 1, acc, res) go c (count, acc, res) = if count > 0 then (0, c : replicate count '.' ++ acc, res) else (0, c : acc, res) finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res -- | Remove leading and trailing whitespace. strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Property.hs0000644000000000000000000000451507346545000022316 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Test.DocTest.Internal.Property where import Data.List import Data.Maybe import Data.Foldable import Test.DocTest.Internal.Util import Test.DocTest.Internal.Interpreter (Interpreter) import qualified Test.DocTest.Internal.Interpreter as Interpreter import Test.DocTest.Internal.Parse -- | The result of evaluating an interaction. data PropertyResult = Success | Failure String | Error String deriving (Eq, Show) runProperty :: Interpreter -> Expression -> IO PropertyResult runProperty repl expression = do _ <- Interpreter.safeEval repl "import Test.QuickCheck ((==>))" _ <- Interpreter.safeEval repl "import Test.QuickCheck.All (polyQuickCheck)" _ <- Interpreter.safeEval repl "import Language.Haskell.TH (mkName)" _ <- Interpreter.safeEval repl ":set -XTemplateHaskell" r <- freeVariables repl expression >>= (Interpreter.safeEval repl . quickCheck expression) case r of Left err -> do return (Error err) Right res | "OK, passed" `isInfixOf` res -> return Success | otherwise -> do let msg = stripEnd (takeWhileEnd (/= '\b') res) return (Failure msg) where quickCheck term vars = "let doctest_prop " ++ unwords vars ++ " = " ++ term ++ "\n" ++ "$(polyQuickCheck (mkName \"doctest_prop\"))" -- | Find all free variables in given term. -- -- GHCi is used to detect free variables. freeVariables :: Interpreter -> String -> IO [String] freeVariables repl term = do r <- Interpreter.safeEval repl (":type " ++ term) return (either (const []) (nub . parseNotInScope) r) -- | Parse and return all variables that are not in scope from a ghc error -- message. parseNotInScope :: String -> [String] parseNotInScope = nub . mapMaybe extractVariable . lines where -- | Extract variable name from a "Not in scope"-error. extractVariable :: String -> Maybe String extractVariable x | "Not in scope: " `isInfixOf` x = Just . unquote . takeWhileEnd (/= ' ') $ x | Just y <- (asum $ map (stripPrefix "Variable not in scope: ") (tails x)) = Just (takeWhile (/= ' ') y) | otherwise = Nothing -- | Remove quotes from given name, if any. unquote ('`':xs) = init xs unquote ('\8216':xs) = init xs unquote xs = xs doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Runner.hs0000644000000000000000000004021107346545000021734 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} module Test.DocTest.Internal.Runner where import Prelude hiding (putStr, putStrLn, error) import Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO, ThreadId, myThreadId) import Control.Exception (SomeException, catch) import Control.Monad hiding (forM_) import Data.Foldable (forM_) import Data.Function (on) import Data.List (sortBy) import Data.Maybe (fromMaybe, maybeToList) import GHC.Conc (getNumProcessors) import System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice) import System.Random (randoms, mkStdGen) import Text.Printf (printf) import Control.Monad.Trans.State import Control.Monad.IO.Class import Test.DocTest.Internal.Interpreter (Interpreter) import qualified Test.DocTest.Internal.Interpreter as Interpreter import Test.DocTest.Internal.Parse import Test.DocTest.Internal.Options ( ModuleName, ModuleConfig (cfgPreserveIt), cfgSeed, cfgPreserveIt , cfgRandomizeOrder, cfgImplicitModuleImport, parseLocatedModuleOptions) import Test.DocTest.Internal.Location import qualified Test.DocTest.Internal.Property as Property import Test.DocTest.Internal.Runner.Example import Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog) import System.IO.CodePage (withCP65001) import Control.Monad.Extra (whenM) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif -- | Whether an "example" is part of setup block data FromSetup = FromSetup | NotFromSetup -- | Summary of a test run. data Summary = Summary { sExamples :: Int -- ^ Total number of lines of examples (excluding setup) , sTried :: Int -- ^ Executed /sTried/ lines so far , sErrors :: Int -- ^ Couldn't execute /sErrors/ examples , sFailures :: Int -- ^ Got unexpected output for /sFailures/ examples } deriving Eq emptySummary :: Summary emptySummary = Summary 0 0 0 0 -- | Format a summary. instance Show Summary where show (Summary examples tried errors failures) = printf "Examples: %d Tried: %d Errors: %d Unexpected output: %d" examples tried errors failures -- | Sum up summaries. instance Monoid Summary where mempty = Summary 0 0 0 0 #if __GLASGOW_HASKELL__ < 804 mappend = (<>) #endif instance Semigroup Summary where (<>) (Summary x1 x2 x3 x4) (Summary y1 y2 y3 y4) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) -- | Run all examples from a list of modules. runModules :: (?verbosity::LogLevel) => ModuleConfig -- ^ Configuration options specific to module -> Maybe Int -- ^ Number of threads to use. Defaults to 'getNumProcessors'. -> Bool -- ^ Implicit Prelude -> [String] -- ^ Arguments passed to the GHCi process. -> [Module [Located DocTest]] -- ^ Modules under test -> IO Summary runModules modConfig nThreads implicitPrelude args modules = do isInteractive <- hIsTerminalDevice stderr -- Start a thread pool. It sends status updates to this thread through 'output'. nCores <- getNumProcessors (input, output) <- makeThreadPool (fromMaybe nCores nThreads) (runModule modConfig implicitPrelude args) -- Send instructions to threads liftIO (mapM_ (writeChan input) modules) let nExamples = (sum . map count) modules initState = ReportState { reportStateCount = 0 , reportStateInteractive = isInteractive , reportStateSummary = mempty{sExamples=nExamples} } threadId <- myThreadId let ?threadId = threadId ReportState{reportStateSummary} <- (`execStateT` initState) $ do consumeUpdates output (length modules) gets (show . reportStateSummary) >>= report Info return reportStateSummary where consumeUpdates :: (?threadId :: ThreadId) => Chan (ThreadId, ReportUpdate) -> Int -> StateT ReportState IO () consumeUpdates _output 0 = pure () consumeUpdates output modsLeft = do (threadId, update) <- liftIO (readChan output) let ?threadId = threadId consumeUpdates output =<< case update of UpdateInternalError fs loc e -> reportInternalError fs loc e >> pure (modsLeft - 1) UpdateImportError modName result -> reportImportError modName result >> pure (modsLeft - 1) UpdateSuccess fs -> reportSuccess fs >> reportProgress >> pure modsLeft UpdateFailure fs loc expr errs -> reportFailure fs loc expr errs >> pure modsLeft UpdateError fs loc expr err -> reportError fs loc expr err >> pure modsLeft UpdateOptionError loc err -> reportOptionError loc err >> pure modsLeft UpdateModuleDone -> pure (modsLeft - 1) UpdateLog lvl msg -> report lvl msg >> pure modsLeft -- | Count number of expressions in given module. count :: Module [Located DocTest] -> Int count (Module _ _ tests _) = sum (map length tests) -- | A monad for generating test reports. type Report = StateT ReportState IO data ReportState = ReportState { reportStateCount :: Int -- ^ characters on the current line , reportStateInteractive :: Bool -- ^ should intermediate results be printed? , reportStateSummary :: Summary -- ^ test summary } -- | Add output to the report. report :: ( ?verbosity :: LogLevel , ?threadId :: ThreadId ) => LogLevel -> String -> Report () report lvl msg0 = when (shouldLog lvl) $ do let msg1 = formatLog ?threadId lvl msg0 overwrite msg1 -- add a newline, this makes the output permanent liftIO $ hPutStrLn stderr "" modify (\st -> st {reportStateCount = 0}) -- | Add intermediate output to the report. -- -- This will be overwritten by subsequent calls to `report`/`report_`. -- Intermediate out may not contain any newlines. report_ :: (?verbosity :: LogLevel) => LogLevel -> String -> Report () report_ lvl msg = when (shouldLog lvl) $ do whenM (gets reportStateInteractive) $ 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) -- | Shuffle a list given a seed for an RNG shuffle :: Int -> [a] -> [a] shuffle seed xs = map snd $ sortBy (compare `on` fst) $ zip (randoms @Int (mkStdGen seed)) xs -- | Run all examples from given module. runModule :: ModuleConfig -> Bool -> [String] -> Chan (ThreadId, ReportUpdate) -> Module [Located DocTest] -> IO () runModule modConfig0 implicitPrelude ghciArgs output mod_ = do threadId <- myThreadId let update r = writeChan output (threadId, r) case modConfig2 of Left (loc, flag) -> update (UpdateOptionError loc flag) Right modConfig3 -> do let examples1 | cfgRandomizeOrder modConfig3 = shuffle seed examples0 | otherwise = examples0 importModule | cfgImplicitModuleImport modConfig3 = Just (":m +" ++ module_) | otherwise = Nothing preserveIt = cfgPreserveIt modConfig3 seed = fromMaybe 0 (cfgSeed modConfig3) -- Should have been set already reload repl = do void $ Interpreter.safeEval repl ":reload" mapM_ (Interpreter.safeEval repl) $ if implicitPrelude then ":m Prelude" : maybeToList importModule else maybeToList importModule when preserveIt $ -- Evaluate a dumb expression to populate the 'it' variable NOTE: This is -- one reason why we cannot have safeEval = safeEvalIt: 'it' isn't set in -- a fresh GHCi session. void $ Interpreter.safeEval repl $ "()" setup_ repl = do reload repl forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of Property _ -> return () Example e _ -> void $ safeEvalWith preserveIt repl e let logger = update . UpdateLog Debug Interpreter.withInterpreter logger ghciArgs $ \repl -> withCP65001 $ do -- Try to import this module, if it fails, something is off importResult <- case importModule of Nothing -> pure (Right "") Just i -> Interpreter.safeEval repl i case importResult of Right "" -> do -- Run setup group successes <- mapM (runTestGroup FromSetup preserveIt repl (reload repl) update) setup -- only run tests, if setup does not produce any errors/failures when (and successes) (mapM_ (runTestGroup NotFromSetup preserveIt repl (setup_ repl) update) examples1) _ -> update (UpdateImportError module_ importResult) -- Signal main thread a module has been tested update UpdateModuleDone pure () where Module module_ setup examples0 modArgs = mod_ modConfig2 = parseLocatedModuleOptions module_ modConfig0 modArgs data ReportUpdate = UpdateSuccess FromSetup -- ^ Test succeeded | UpdateFailure FromSetup Location Expression [String] -- ^ Test failed with unexpected result | UpdateError FromSetup Location Expression String -- ^ Test failed with an error | UpdateModuleDone -- ^ All examples tested in module | UpdateInternalError FromSetup (Module [Located DocTest]) SomeException -- ^ Exception caught while executing internal code | UpdateImportError ModuleName (Either String String) -- ^ Could not import module | UpdateOptionError Location String -- ^ Unrecognized flag in module specific option | UpdateLog LogLevel String -- ^ Unstructured message makeThreadPool :: Int -> (Chan (ThreadId, ReportUpdate) -> Module [Located DocTest] -> IO ()) -> IO (Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate)) makeThreadPool nThreads mutator = do input <- newChan output <- newChan forM_ [1..nThreads] $ \_ -> forkIO $ forever $ do i <- readChan input threadId <- myThreadId catch (mutator output i) (\e -> writeChan output (threadId, UpdateInternalError NotFromSetup i e)) return (input, output) reportFailure :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Location -> Expression -> [String] -> Report () reportFailure fromSetup loc expression err = do report Error (printf "%s: failure in expression `%s'" (show loc) expression) mapM_ (report Error) err report Error "" updateSummary fromSetup (Summary 0 1 0 1) reportError :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Location -> Expression -> String -> Report () reportError fromSetup loc expression err = do report Error (printf "%s: error in expression `%s'" (show loc) expression) report Error err report Error "" updateSummary fromSetup (Summary 0 1 1 0) reportOptionError :: (?verbosity::LogLevel, ?threadId::ThreadId) => Location -> String -> Report () reportOptionError loc opt = do report Error (printf "%s: unrecognized option: %s. Try --help to see all options." (show loc) opt) report Error "" updateSummary FromSetup (Summary 0 1 1 0) reportInternalError :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Module a -> SomeException -> Report () reportInternalError fs mod_ err = do report Error (printf "Internal error when executing tests in %s" (moduleName mod_)) report Error (show err) report Error "" updateSummary fs emptySummary{sErrors=1} reportImportError :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> Either String String -> Report () reportImportError modName importResult = do report Error ("Could not import module: " <> modName <> ". This can be caused by a number of issues: ") report Error "" report Error " 1. A module found by GHC contained tests, but was not in 'exposed-modules'. If you want" report Error " to test non-exposed modules follow the instructions here:" report Error " https://github.com/martijnbastiaan/doctest-parallel#test-non-exposed-modules" report Error "" report Error " 2. For Cabal users: Cabal did not generate a GHC environment file. Either:" report Error " * Run with '--write-ghc-environment-files=always'" report Error " * Add 'write-ghc-environment-files: always' to your cabal.project" report Error "" report Error " 3. For Cabal users: Cabal did not generate a GHC environment file in time. This" report Error " can happen if you use 'cabal test' instead of 'cabal run doctests'. See" report Error " https://github.com/martijnbastiaan/doctest-parallel/issues/22." report Error "" report Error " 4. The testsuite executable does not have a dependency on your project library. Please" report Error " add it to the 'build-depends' section of the testsuite executable." report Error "" report Error "See the example project at https://github.com/martijnbastiaan/doctest-parallel/blob/main/example/README.md for more information." report Error "" report Error "The original reason given by GHCi was:" report Error "" case importResult of Left out -> do report Error "Unexpected output:" report Error out Right err -> do report Error "Error:" report Error err updateSummary FromSetup emptySummary{sErrors=1} reportSuccess :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Report () reportSuccess fromSetup = updateSummary fromSetup (Summary 0 1 0 0) updateSummary :: FromSetup -> Summary -> Report () updateSummary FromSetup summary = -- Suppress counts, except for errors and unexpected outputs updateSummary NotFromSetup summary{sExamples=0, sTried=0} updateSummary NotFromSetup summary = do ReportState n f s <- get put (ReportState n f $ s `mappend` summary) reportProgress :: (?verbosity::LogLevel) => Report () reportProgress = gets (show . reportStateSummary) >>= report_ Info -- | Run given test group. -- -- The interpreter state is zeroed with @:reload@ first. This means that you -- can reuse the same 'Interpreter' for several test groups. runTestGroup :: FromSetup -> Bool -> Interpreter -> IO () -> (ReportUpdate -> IO ()) -> [Located DocTest] -> IO Bool runTestGroup fromSetup preserveIt repl setup update tests = do setup successExamples <- runExampleGroup fromSetup preserveIt repl update examples successesProperties <- forM properties $ \(loc, expression) -> do r <- do setup update (UpdateLog Verbose ("Started property at " ++ show loc)) Property.runProperty repl expression case r of Property.Success -> do update (UpdateSuccess fromSetup) pure True Property.Error err -> do update (UpdateError fromSetup loc expression err) pure False Property.Failure msg -> do update (UpdateFailure fromSetup loc expression [msg]) pure False pure (successExamples && and successesProperties) where properties = [(loc, p) | Located loc (Property p) <- tests] examples :: [Located Interaction] examples = [Located loc (e, r) | Located loc (Example e r) <- tests] -- | -- Execute all expressions from given example in given 'Interpreter' and verify -- the output. runExampleGroup :: FromSetup -> Bool -> Interpreter -> (ReportUpdate -> IO ()) -> [Located Interaction] -> IO Bool runExampleGroup fromSetup preserveIt repl update examples = do threadId <- myThreadId go threadId examples where go threadId ((Located loc (expression, expected)) : xs) = do update (UpdateLog Verbose ("Started example at " ++ show loc)) r <- fmap lines <$> safeEvalWith preserveIt repl expression case r of Left err -> do update (UpdateError fromSetup loc expression err) pure False Right actual -> case mkResult expected actual of NotEqual err -> do update (UpdateFailure fromSetup loc expression err) pure False Equal -> do update (UpdateSuccess fromSetup) go threadId xs go _ [] = pure True safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String) safeEvalWith preserveIt | preserveIt = Interpreter.safeEvalIt | otherwise = Interpreter.safeEval doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Runner/0000755000000000000000000000000007346545000021402 5ustar0000000000000000doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Runner/Example.hs0000644000000000000000000001260307346545000023333 0ustar0000000000000000module Test.DocTest.Internal.Runner.Example ( Result (..) , mkResult ) where import Data.Char import Data.List import Test.DocTest.Internal.Util import Test.DocTest.Internal.Parse maxBy :: (Ord a) => (b -> a) -> b -> b -> b maxBy f x y = case compare (f x) (f y) of LT -> y EQ -> x GT -> x data Result = Equal | NotEqual [String] deriving (Eq, Show) mkResult :: ExpectedResult -> [String] -> Result mkResult expected_ actual_ = case expected `matches` actual of Full -> Equal Partial partial -> NotEqual (formatNotEqual expected actual partial) where -- use show to escape special characters in output lines if any output line -- contains any unsafe character escapeOutput | any (not . isSafe) $ concat (expectedAsString ++ actual_) = init . drop 1 . show . stripEnd | otherwise = id actual :: [String] actual = fmap escapeOutput actual_ expected :: ExpectedResult expected = fmap (transformExcpectedLine escapeOutput) expected_ expectedAsString :: [String] expectedAsString = map (\x -> case x of ExpectedLine str -> concatMap lineChunkToString str WildCardLine -> "..." ) expected_ isSafe :: Char -> Bool isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) chunksMatch :: [LineChunk] -> String -> Match ChunksDivergence chunksMatch [] "" = Full chunksMatch [LineChunk xs] ys = if stripEnd xs == stripEnd ys then Full else Partial $ matchingPrefix xs ys chunksMatch (LineChunk x : xs) ys = if x `isPrefixOf` ys then fmap (prependText x) $ (xs `chunksMatch` drop (length x) ys) else Partial $ matchingPrefix x ys chunksMatch zs@(WildCardChunk : xs) (_:ys) = -- Prefer longer matches. fmap prependWildcard $ maxBy (fmap $ length . matchText) (chunksMatch xs ys) (chunksMatch zs ys) chunksMatch [WildCardChunk] [] = Full chunksMatch (WildCardChunk:_) [] = Partial (ChunksDivergence "" "") chunksMatch [] (_:_) = Partial (ChunksDivergence "" "") matchingPrefix xs ys = let common = fmap fst (takeWhile (\(x, y) -> x == y) (xs `zip` ys)) in ChunksDivergence common common matches :: ExpectedResult -> [String] -> Match LinesDivergence matches (ExpectedLine x : xs) (y : ys) = case x `chunksMatch` y of Full -> fmap incLineNo $ xs `matches` ys Partial partial -> Partial (LinesDivergence 1 (expandedWildcards partial)) matches zs@(WildCardLine : xs) us@(_ : ys) = -- Prefer longer matches, and later ones of equal length. let matchWithoutWC = xs `matches` us in let matchWithWC = fmap incLineNo (zs `matches` ys) in let key (LinesDivergence lineNo line) = (length line, lineNo) in maxBy (fmap key) matchWithoutWC matchWithWC matches [WildCardLine] [] = Full matches [] [] = Full matches [] _ = Partial (LinesDivergence 1 "") matches _ [] = Partial (LinesDivergence 1 "") -- Note: order of constructors matters, so that full matches sort as -- greater than partial. data Match a = Partial a | Full deriving (Eq, Ord, Show) instance Functor Match where fmap f (Partial a) = Partial (f a) fmap _ Full = Full data ChunksDivergence = ChunksDivergence { matchText :: String, expandedWildcards :: String } deriving (Show) prependText :: String -> ChunksDivergence -> ChunksDivergence prependText s (ChunksDivergence mt wct) = ChunksDivergence (s++mt) (s++wct) prependWildcard :: ChunksDivergence -> ChunksDivergence prependWildcard (ChunksDivergence mt wct) = ChunksDivergence mt ('.':wct) data LinesDivergence = LinesDivergence { _mismatchLineNo :: Int, _partialLine :: String } deriving (Show) incLineNo :: LinesDivergence -> LinesDivergence incLineNo (LinesDivergence lineNo partialLineMatch) = LinesDivergence (lineNo + 1) partialLineMatch formatNotEqual :: ExpectedResult -> [String] -> LinesDivergence -> [String] formatNotEqual expected_ actual partial = formatLines "expected: " expected ++ formatLines " but got: " (lineMarker wildcard partial actual) where expected :: [String] expected = map (\x -> case x of ExpectedLine str -> concatMap lineChunkToString str WildCardLine -> "..." ) expected_ formatLines :: String -> [String] -> [String] formatLines message xs = case xs of y:ys -> (message ++ y) : map (padding ++) ys [] -> [message] where padding = replicate (length message) ' ' wildcard :: Bool wildcard = any (\x -> case x of ExpectedLine xs -> any (\y -> case y of { WildCardChunk -> True; _ -> False }) xs WildCardLine -> True ) expected_ lineChunkToString :: LineChunk -> String lineChunkToString WildCardChunk = "..." lineChunkToString (LineChunk str) = str transformExcpectedLine :: (String -> String) -> ExpectedLine -> ExpectedLine transformExcpectedLine f (ExpectedLine xs) = ExpectedLine $ fmap (\el -> case el of LineChunk s -> LineChunk $ f s WildCardChunk -> WildCardChunk ) xs transformExcpectedLine _ WildCardLine = WildCardLine lineMarker :: Bool -> LinesDivergence -> [String] -> [String] lineMarker wildcard (LinesDivergence row expanded) actual = let (pre, post) = splitAt row actual in pre ++ [(if wildcard && length expanded > 30 -- show expanded pattern if match is long, to help understanding what matched what then expanded else replicate (length expanded) ' ') ++ "^"] ++ post doctest-parallel-0.3.1.1/src/Test/DocTest/Internal/Util.hs0000644000000000000000000000134207346545000021402 0ustar0000000000000000module Test.DocTest.Internal.Util where import Data.Char convertDosLineEndings :: String -> String convertDosLineEndings = go where go input = case input of '\r':'\n':xs -> '\n' : go xs -- Haddock comments from source files with dos line endings end with a -- CR, so we strip that, too. "\r" -> "" x:xs -> x : go xs "" -> "" -- | Return the longest suffix of elements that satisfy a given predicate. takeWhileEnd :: (a -> Bool) -> [a] -> [a] takeWhileEnd p = reverse . takeWhile p . reverse -- | Remove trailing white space from a string. -- -- >>> stripEnd "foo " -- "foo" stripEnd :: String -> String stripEnd = reverse . dropWhile isSpace . reverse doctest-parallel-0.3.1.1/test/0000755000000000000000000000000007346545000014261 5ustar0000000000000000doctest-parallel-0.3.1.1/test/ExtractSpec.hs0000644000000000000000000001141607346545000017045 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} module ExtractSpec (main, spec) where import Test.Hspec import Test.HUnit #if __GLASGOW_HASKELL__ < 900 import Panic (GhcException (..)) #else import GHC.Utils.Panic (GhcException (..)) #endif import Test.DocTest.Internal.Extract import Test.DocTest.Internal.Location import System.FilePath shouldGive :: HasCallStack => (String, String) -> [Module String] -> Assertion (d, m) `shouldGive` expected = do r <- map (fmap unLoc) `fmap` extract ["-i" ++ dir, dir m] map eraseConfigLocation r `shouldBe` map eraseConfigLocation expected where dir = "test/extract" d main :: IO () main = hspec spec spec :: Spec spec = do let mod_ nm content = Module nm Nothing content [] describe "extract" $ do it "extracts documentation for a top-level declaration" $ do ("declaration", "Foo.hs") `shouldGive` [mod_ "Foo" [" Some documentation"]] it "extracts documentation from argument list" $ do ("argument-list", "Foo.hs") `shouldGive` [mod_ "Foo" [" doc for arg1", " doc for arg2"]] it "extracts documentation for a type class function" $ do ("type-class", "Foo.hs") `shouldGive` [mod_ "Foo" [" 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` [mod_ "Foo" [" foo", " bar"]] it "extracts documentation from the module header" $ do ("module-header", "Foo.hs") `shouldGive` [mod_ "Foo" [" Some documentation"]] it "extracts documentation from imported modules" $ do ("imported-module", "Bar.hs") `shouldGive` [mod_ "Bar" [" documentation for bar"], mod_ "Baz" [" documentation for baz"]] it "extracts documentation from export list" $ do ("export-list", "Foo.hs") `shouldGive` [mod_ "Foo" [" documentation from export list"]] it "extracts documentation from named chunks" $ do ("named-chunks", "Foo.hs") `shouldGive` [mod_ "Foo" [" 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` [mod_ "Foo" [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]] it "extracts $setup code" $ do ("setup", "Foo.hs") `shouldGive` [(mod_ "Foo" [" foo", " bar", " baz"]){moduleSetup=Just "\n some setup code"}] 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` [mod_ "Fixity" []] it "works with parallel list comprehensions" $ do ("regression", "ParallelListComp.hs") `shouldGive` [mod_ "ParallelListComp" []] it "works with list comprehensions in instance definitions" $ do ("regression", "ParallelListCompClass.hs") `shouldGive` [mod_ "ParallelListCompClass" []] it "works with foreign imports" $ do ("regression", "ForeignImport.hs") `shouldGive` [mod_ "ForeignImport" []] it "works for rewrite rules" $ do ("regression", "RewriteRules.hs") `shouldGive` [mod_ "RewriteRules" [" doc for foo"]] it "works for rewrite rules with type signatures" $ do ("regression", "RewriteRulesWithSigs.hs") `shouldGive` [mod_ "RewriteRulesWithSigs" [" doc for foo"]] it "strips CR from dos line endings" $ do ("dos-line-endings", "Foo.hs") `shouldGive` [mod_ "Foo" ["\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` [mod_ "Foo" [" some documentation"], mod_ "Bar" []] it "works for type families and GHC 7.6.1" $ do ("type-families", "Foo.hs") `shouldGive` [mod_ "Foo" []] it "ignores binder annotations" $ do ("module-options", "Binders.hs") `shouldGive` [mod_ "Binders" []] it "ignores module annotations that don't start with 'doctest-parallel:'" $ do ("module-options", "NoOptions.hs") `shouldGive` [mod_ "NoOptions" []] it "detects monomorphic module settings" $ do ("module-options", "Mono.hs") `shouldGive` [(mod_ "Mono" []){moduleConfig= [ noLocation "--no-randomize-error1" , noLocation "--no-randomize-error2" , noLocation "--no-randomize-error3" , noLocation "--no-randomize-error4" , noLocation "--no-randomize-error5" , noLocation "--no-randomize-error6" ]}] it "detects polypormphic module settings" $ do ("module-options", "Poly.hs") `shouldGive` [(mod_ "Poly" []){moduleConfig= [ noLocation "--no-randomize-error" ]}] doctest-parallel-0.3.1.1/test/GhciWrapperSpec.hs0000644000000000000000000001066207346545000017650 0ustar0000000000000000{-# LANGUAGE CPP #-} module GhciWrapperSpec (main, spec) where import Test.Hspec import System.IO.Silently import Control.Exception import Data.List (isInfixOf) import Test.DocTest.Internal.GhciWrapper (Interpreter, Config(..), defaultConfig) import qualified Test.DocTest.Internal.GhciWrapper as Interpreter import Test.DocTest.Internal.Logging (noLogger) main :: IO () main = hspec spec withInterpreterConfig :: Config -> (Interpreter -> IO a) -> IO a withInterpreterConfig config = bracket (Interpreter.new noLogger config []) Interpreter.close withInterpreter :: ((String -> IO String) -> IO a) -> IO a withInterpreter action = withInterpreterConfig defaultConfig $ action . Interpreter.eval 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 "evalIt" $ do it "preserves it" $ do withInterpreterConfig defaultConfig $ \ghci -> do Interpreter.evalIt 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` "" ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n" 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 #if __GLASGOW_HASKELL__ >= 800 ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo") #else ghci "foo" >>= (`shouldSatisfy` isSuffixOf "Not in scope: \8216foo\8217\n") #endif 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 ":set -XOverloadedStrings -Wall -Werror" `shouldReturn` "" ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" context "with NoImplicitPrelude" $ do it "works" $ withInterpreter $ \ghci -> do ghci ":set -XNoImplicitPrelude" `shouldReturn` "" ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" context "with a strange String type" $ do it "works" $ withInterpreter $ \ghci -> do ghci "type String = Int" `shouldReturn` "" ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" doctest-parallel-0.3.1.1/test/InterpreterSpec.hs0000644000000000000000000000223107346545000017731 0ustar0000000000000000module InterpreterSpec (main, spec) where import Prelude () import Prelude.Compat import Test.Hspec import qualified Test.DocTest.Internal.Interpreter as Interpreter import Test.DocTest.Internal.Interpreter (haveInterpreterKey, ghcInfo, withInterpreter) import Test.DocTest.Internal.Logging (noLogger) main :: IO () main = hspec spec spec :: Spec spec = do describe "interpreterSupported" $ do it "indicates whether GHCi is supported on current platform" $ do (Interpreter.interpreterSupported >> return ()) `shouldReturn` () describe "ghcInfo" $ do it ("includes " ++ show haveInterpreterKey) $ do info <- ghcInfo lookup haveInterpreterKey info `shouldSatisfy` (||) <$> (== Just "YES") <*> (== Just "NO") describe "safeEval" $ do it "evaluates an expression" $ withInterpreter noLogger [] $ \ghci -> do Interpreter.safeEval ghci "23 + 42" `shouldReturn` Right "65\n" it "returns Left on unterminated multiline command" $ withInterpreter noLogger [] $ \ghci -> do Interpreter.safeEval ghci ":{\n23 + 42" `shouldReturn` Left "unterminated multiline command" doctest-parallel-0.3.1.1/test/LocationSpec.hs0000644000000000000000000000303707346545000017203 0ustar0000000000000000{-# LANGUAGE CPP #-} module LocationSpec (main, spec) where import Test.Hspec import Test.DocTest.Internal.Location #if __GLASGOW_HASKELL__ < 900 import SrcLoc import FastString (fsLit) #else import GHC.Types.SrcLoc import GHC.Data.FastString (fsLit) #endif main :: IO () main = hspec spec spec :: Spec spec = do describe "toLocation" $ do it "works for a regular SrcSpan" $ do toLocation (mkSrcSpan (mkSrcLoc (fsLit "Foo.hs") 2 5) (mkSrcLoc (fsLit "Foo.hs") 10 20)) `shouldBe` Location "Foo.hs" 2 it "works for a single-line SrcSpan" $ do toLocation (mkSrcSpan (mkSrcLoc (fsLit "Foo.hs") 2 5) (mkSrcLoc (fsLit "Foo.hs") 2 10)) `shouldBe` Location "Foo.hs" 2 it "works for a SrcSpan that corresponds to single point" $ do (toLocation . srcLocSpan) (mkSrcLoc (fsLit "Foo.hs") 10 20) `shouldBe` Location "Foo.hs" 10 it "works for a bad SrcSpan" $ do toLocation noSrcSpan `shouldBe` UnhelpfulLocation "" it "works for a SrcLoc with bad locations" $ do toLocation (mkSrcSpan noSrcLoc noSrcLoc) `shouldBe` UnhelpfulLocation "" describe "enumerate" $ do it "replicates UnhelpfulLocation" $ do let loc = UnhelpfulLocation "foo" (take 10 $ enumerate loc) `shouldBe` replicate 10 loc it "enumerates Location" $ do let loc = Location "Foo.hs" 23 (take 3 $ enumerate loc) `shouldBe` [Location "Foo.hs" 23, Location "Foo.hs" 24, Location "Foo.hs" 25] doctest-parallel-0.3.1.1/test/MainSpec.hs0000644000000000000000000001363707346545000016326 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} module MainSpec (main, spec) where import Test.Hspec import Test.HUnit (assertEqual, Assertion) import qualified Data.Map as Map import qualified Test.DocTest as DocTest import Test.DocTest.Helpers (extractSpecificCabalLibrary, findCabalPackage) import Test.DocTest.Internal.Options import Test.DocTest.Internal.Runner import System.Environment (getEnvironment) import System.IO.Silently import System.IO -- | Construct a doctest specific 'Assertion'. doctest :: HasCallStack => [ModuleName] -> Summary -> Assertion doctest = doctestWithOpts defaultConfig doctestWithOpts :: HasCallStack => Config -> [ModuleName] -> Summary -> Assertion doctestWithOpts config modNames expected = do pkg <- findCabalPackage "doctest-parallel" lib <- extractSpecificCabalLibrary (Just "spectests-modules") pkg actual <- hSilence [stderr] $ DocTest.run lib config{cfgModules=modNames} assertEqual (show modNames) expected actual cases :: Int -> Summary cases n = Summary n n 0 0 main :: IO () main = hspec spec spec :: Spec spec = do env <- Map.fromList <$> runIO getEnvironment let cDescribe = if -- Don't run doctests as part of the Stack testsuite yet, pending -- https://github.com/commercialhaskell/stack/issues/5662 | "STACK_EXE" `Map.member` env -> xdescribe -- Don't run doctests as part of a Nix build. Similar to Stack, Nix -- doesn't seem to deal with private libraries yet. | "NIX_BUILD_TOP" `Map.member` env -> xdescribe | otherwise -> describe cDescribe "doctest" $ do it "testSimple" $ doctest ["TestSimple.Fib"] (cases 1) it "it-variable" $ do doctestWithOpts (defaultConfig{cfgModuleConfig=defaultModuleConfig{cfgPreserveIt=True}}) ["It.Foo"] (cases 5) it "it-variable in $setup" $ do doctestWithOpts (defaultConfig{cfgModuleConfig=defaultModuleConfig{cfgPreserveIt=True}}) ["It.Setup"] (cases 2) it "failing" $ do doctest ["Failing.Foo"] (cases 1) {sFailures = 1} it "skips subsequent examples from the same group if an example fails" $ doctest ["FailingMultiple.Foo"] (cases 4) {sTried = 2, sFailures = 1} it "use -DFIB=fib to set CPP flag" $ doctestWithOpts defaultConfig{cfgGhcArgs=["-DFIB=fib"]} ["GhcArg.Fib"] (cases 1) it "testImport" $ do doctest ["TestImport.ModuleA"] (cases 2) it "testCommentLocation" $ do doctest ["TestCommentLocation.Foo"] (cases 11) it "testPutStr" $ do doctest ["TestPutStr.Fib"] (cases 3) it "fails on multi-line expressions, introduced with :{" $ do doctest ["TestFailOnMultiline.Fib"] (cases 2) {sErrors = 2} it "testBlankline" $ do doctest ["TestBlankline.Fib"] (cases 1) it "examples from the same Haddock comment share the same scope" $ do doctest ["TestCombinedExample.Fib"] (cases 4) it "testDocumentationForArguments" $ do doctest ["TestDocumentationForArguments.Fib"] (cases 1) it "template-haskell" $ do doctest ["TemplateHaskell.Foo"] (cases 2) it "handles source files with CRLF line endings" $ do doctest ["DosLineEndings.Fib"] (cases 1) it "runs $setup before each test group" $ do doctest ["Setup.Foo"] (cases 1) it "skips subsequent tests from a module, if $setup fails" $ do doctest ["SetupSkipOnFailure.Foo"] -- TODO: Introduce "skipped" (cases 2) {sTried = 0, sFailures = 1} it "works with additional object files" $ do doctest ["WithCbits.Bar"] (cases 1) it "ignores trailing whitespace when matching test output" $ do doctest ["TrailingWhitespace.Foo"] (cases 1) cDescribe "doctest as a runner for QuickCheck properties" $ do it "runs a boolean property" $ do doctest ["PropertyBool.Foo"] (cases 1) it "runs an explicitly quantified property" $ do doctest ["PropertyQuantified.Foo"] (cases 1) it "runs an implicitly quantified property" $ do doctest ["PropertyImplicitlyQuantified.Foo"] (cases 1) it "reports a failing property" $ do doctest ["PropertyFailing.Foo"] (cases 1) {sFailures = 1} it "runs a boolean property with an explicit type signature" $ do doctest ["PropertyBoolWithTypeSignature.Foo"] (cases 1) it "runs $setup before each property" $ do doctest ["PropertySetup.Foo"] (cases 1) cDescribe "doctest (module isolation)" $ do it "should fail due to module isolation" $ do doctestWithOpts defaultConfig ["ModuleIsolation.TestA", "ModuleIsolation.TestB"] (cases 2) {sFailures = 1} cDescribe "doctest (regression tests)" $ do it "bugfixOutputToStdErr" $ do doctest ["BugfixOutputToStdErr.Fib"] (cases 2) it "bugfixImportHierarchical" $ do doctest ["BugfixImportHierarchical.ModuleA", "BugfixImportHierarchical.ModuleB"] (cases 4) it "bugfixMultipleModules" $ do doctest ["BugfixMultipleModules.ModuleA", "BugfixMultipleModules.ModuleB"] -- TODO: Introduce "skipped" (cases 6) {sTried = 5, sFailures = 1} it "doesn't clash with user bindings of stdout/stderr" $ do doctest ["LocalStderrBinding.A"] (cases 1) it "doesn't get confused by doctests using System.IO imports" $ do doctest ["SystemIoImported.A"] (cases 2) it "correctly handles C import directories" $ do doctest ["WithCInclude.Bar"] (cases 1) it "sets module level options" $ do doctest ["ModuleOptions.Foo"] (cases 5) it "succeeds for non-exposed modules if --no-implicit-module-import is set" $ do doctest ["NonExposedModule.NoImplicitImport"] (cases 2) doctest-parallel-0.3.1.1/test/OptionsSpec.hs0000644000000000000000000000444207346545000017067 0ustar0000000000000000module OptionsSpec (spec) where import Prelude () import Prelude.Compat import Test.Hspec import Test.DocTest.Internal.Options import Test.DocTest.Internal.Logging (LogLevel(..)) spec :: Spec spec = do describe "parseOptions" $ do describe "--preserve-it" $ do context "without --preserve-it" $ do it "does not preserve the `it` variable" $ do cfgPreserveIt . cfgModuleConfig <$> parseOptions [] `shouldBe` Result False context "with --preserve-it" $ do it "preserves the `it` variable" $ do cfgPreserveIt . cfgModuleConfig <$> parseOptions ["--preserve-it"] `shouldBe` Result True context "with --no-preserve-it" $ do it "preserves the `it` variable" $ do cfgPreserveIt . cfgModuleConfig <$> parseOptions ["--no-preserve-it"] `shouldBe` Result False describe "--randomize-order" $ do context "without --randomize-order" $ do it "does not set randomize order" $ do cfgRandomizeOrder . cfgModuleConfig <$> parseOptions [] `shouldBe` Result False context "with --randomize-order" $ do it "sets randomize order" $ do cfgRandomizeOrder . cfgModuleConfig <$> parseOptions ["--randomize-order"] `shouldBe` Result True context "with --no-randomize-order" $ do it "unsets randomize order" $ do cfgRandomizeOrder . cfgModuleConfig <$> parseOptions ["--no-randomize-order"] `shouldBe` Result False context "with --help" $ do it "outputs usage information" $ do parseOptions ["--help"] `shouldBe` ResultStdout usage context "with --version" $ do it "outputs version information" $ do parseOptions ["--version"] `shouldBe` ResultStdout versionInfo context "with --info" $ do it "outputs machine readable version information" $ do parseOptions ["--info"] `shouldBe` ResultStdout info describe "--verbose" $ do context "without --verbose" $ do it "is not verbose by default" $ do cfgLogLevel <$> parseOptions [] `shouldBe` Result Info context "with --verbose" $ do it "parses verbose option" $ do cfgLogLevel <$> parseOptions ["--verbose"] `shouldBe` Result Verbose doctest-parallel-0.3.1.1/test/ParseSpec.hs0000644000000000000000000001345007346545000016505 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ParseSpec (main, spec) where import Test.Hspec import Data.String import Data.String.Builder (Builder, build) import Control.Monad.Trans.Writer import Test.DocTest.Internal.Parse import Test.DocTest.Internal.Location main :: IO () main = hspec spec group :: Writer [DocTest] () -> Writer [[DocTest]] () group g = tell [execWriter g] ghci :: Expression -> Builder -> Writer [DocTest] () ghci expressions expected = tell [Example expressions $ (map fromString . lines . build) expected] prop_ :: Expression -> Writer [DocTest] () prop_ e = tell [Property e] module_ :: String -> Writer [[DocTest]] () -> Writer [Module [DocTest]] () module_ name gs = tell [Module name Nothing (execWriter gs) []] shouldGive :: IO [Module [Located DocTest]] -> Writer [Module [DocTest]] () -> Expectation shouldGive action expected = map (fmap $ map unLoc) `fmap` action `shouldReturn` execWriter expected spec :: Spec spec = do describe "getDocTests" $ do it "extracts properties from a module" $ do getDocTests ["test/parse/property/Fib.hs"] `shouldGive` do module_ "Fib" $ do group $ do prop_ "foo" prop_ "bar" prop_ "baz" it "extracts examples from a module" $ do getDocTests ["test/parse/simple/Fib.hs"] `shouldGive` do module_ "Fib" $ do group $ do ghci "putStrLn \"foo\"" "foo" ghci "putStr \"bar\"" "bar" ghci "putStrLn \"baz\"" "baz" it "extracts examples from documentation for non-exported names" $ do getDocTests ["test/parse/non-exported/Fib.hs"] `shouldGive` do module_ "Fib" $ do group $ do ghci "putStrLn \"foo\"" "foo" ghci "putStr \"bar\"" "bar" ghci "putStrLn \"baz\"" "baz" it "extracts multiple examples from a module" $ do getDocTests ["test/parse/multiple-examples/Foo.hs"] `shouldGive` do module_ "Foo" $ do group $ do ghci "foo" "23" group $ do ghci "bar" "42" it "returns an empty list, if documentation contains no examples" $ do getDocTests ["test/parse/no-examples/Fib.hs"] >>= (`shouldBe` []) it "sets setup code to Nothing, if it does not contain any tests" $ do getDocTests ["test/parse/setup-empty/Foo.hs"] `shouldGive` do module_ "Foo" $ do group $ do ghci "foo" "23" it "keeps modules that only contain setup code" $ do getDocTests ["test/parse/setup-only/Foo.hs"] `shouldGive` do tell [Module "Foo" (Just [Example "foo" ["23"]]) [] []] describe "parseInteractions (an internal function)" $ do let parse_ = map unLoc . parseInteractions . noLocation . build it "parses an interaction" $ do parse_ $ do ">>> foo" "23" `shouldBe` [("foo", ["23"])] it "drops whitespace as appropriate" $ do parse_ $ do " >>> foo " " 23" `shouldBe` [("foo", ["23"])] it "parses an interaction without a result" $ do parse_ $ do ">>> foo" `shouldBe` [("foo", [])] it "works with a complex example" $ do parse_ $ do "test" "foobar" "" ">>> foo" "23" "" ">>> baz" "" ">>> bar" "23" "" "baz" `shouldBe` [("foo", ["23"]), ("baz", []), ("bar", ["23"])] it "attaches location information to parsed interactions" $ do let loc = Located . Location "Foo.hs" r <- return . parseInteractions . loc 23 . build $ do "1" "2" "" ">>> 4" "5" "" ">>> 7" "" ">>> 9" "10" "" "11" r `shouldBe` [loc 26 $ ("4", ["5"]), loc 29 $ ("7", []), loc 31 $ ("9", ["10"])] it "basic multiline" $ do parse_ $ do ">>> :{ first" " next" "some" ":}" "output" `shouldBe` [(":{ first\n next\nsome\n:}", ["output"])] it "multiline align output" $ do parse_ $ do ">>> :{ first" " :}" " output" `shouldBe` [(":{ first\n:}", ["output"])] it "multiline align output with >>>" $ do parse_ $ do " >>> :{ first" " >>> :}" " output" `shouldBe` [(":{ first\n:}", ["output"])] it "parses wild cards lines" $ do parse_ $ do " >>> action" " foo" " ..." " bar" `shouldBe` [("action", ["foo", WildCardLine, "bar"])] it "parses wild card chunks" $ do parse_ $ do " >>> action" " foo ... bar" `shouldBe` [("action", [ExpectedLine ["foo ", WildCardChunk, " bar"]])] describe " parseProperties (an internal function)" $ do let parse_ = map unLoc . parseProperties . noLocation . build it "parses a property" $ do parse_ $ do "prop> foo" `shouldBe` ["foo"] describe "mkLineChunks (an internal function)" $ do it "replaces ellipsis with WildCardChunks" $ do mkLineChunks "foo ... bar ... baz" `shouldBe` ["foo ", WildCardChunk, " bar ", WildCardChunk, " baz"] it "doesn't replace fewer than 3 consecutive dots" $ do mkLineChunks "foo .. bar .. baz" `shouldBe` ["foo .. bar .. baz"] it "handles leading and trailing dots" $ do mkLineChunks ".. foo bar .." `shouldBe` [".. foo bar .."] it "handles leading and trailing ellipsis" $ do mkLineChunks "... foo bar ..." `shouldBe` [ WildCardChunk , " foo bar " , WildCardChunk ] doctest-parallel-0.3.1.1/test/PropertySpec.hs0000644000000000000000000001246007346545000017257 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings #-} module PropertySpec (main, spec) where import Test.Hspec import Data.String.Builder import Test.DocTest.Internal.Property import Test.DocTest.Internal.Interpreter (withInterpreter) import Test.DocTest.Internal.Logging (noLogger) main :: IO () main = hspec spec isFailure :: PropertyResult -> Bool isFailure (Failure _) = True isFailure _ = False spec :: Spec spec = do describe "runProperty" $ do it "reports a failing property" $ withInterpreter noLogger [] $ \repl -> do runProperty repl "False" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):" it "runs a Bool property" $ withInterpreter noLogger [] $ \repl -> do runProperty repl "True" `shouldReturn` Success it "runs a Bool property with an explicit type signature" $ withInterpreter noLogger [] $ \repl -> do runProperty repl "True :: Bool" `shouldReturn` Success it "runs an implicitly quantified property" $ withInterpreter noLogger [] $ \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 noLogger [] $ \repl -> do runProperty repl "foldr (+) 0 is == sum (is :: [Int])" `shouldReturn` Success it "runs an explicitly quantified property" $ withInterpreter noLogger [] $ \repl -> do runProperty repl "\\xs -> (reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success it "allows to mix implicit and explicit quantification" $ withInterpreter noLogger [] $ \repl -> do runProperty repl "\\x -> x + y == y + x" `shouldReturn` Success it "reports the value for which a property fails" $ withInterpreter noLogger [] $ \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 noLogger [] $ \repl -> do let vals x = case x of (Failure r) -> drop 1 (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 noLogger [] $ \repl -> do runProperty repl "reverse xs == xs" >>= (`shouldSatisfy` isFailure) describe "freeVariables" $ do it "finds a free variables in a term" $ withInterpreter noLogger [] $ \repl -> do freeVariables repl "x" `shouldReturn` ["x"] it "ignores duplicates" $ withInterpreter noLogger [] $ \repl -> do freeVariables repl "x == x" `shouldReturn` ["x"] it "works for terms with multiple names" $ withInterpreter noLogger [] $ \repl -> do freeVariables repl "\\z -> x + y + z == foo 23" `shouldReturn` ["x", "y", "foo"] it "works for names that contain a prime" $ withInterpreter noLogger [] $ \repl -> do freeVariables repl "x' == y''" `shouldReturn` ["x'", "y''"] it "works for names that are similar to other names that are in scope" $ withInterpreter noLogger [] $ \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_"] doctest-parallel-0.3.1.1/test/RunSpec.hs0000644000000000000000000000644007346545000016200 0ustar0000000000000000{-# LANGUAGE CPP #-} module RunSpec (main, spec) where import Prelude () import Prelude.Compat import Test.Hspec import System.Exit import qualified Control.Exception as E import Data.List.Compat import System.IO.Silently import System.IO (stderr) import qualified Test.DocTest as DocTest import Test.DocTest.Helpers (findCabalPackage, extractSpecificCabalLibrary) import qualified Test.DocTest.Internal.Options as Options doctest :: HasCallStack => [String] -> IO () doctest args = do pkg <- findCabalPackage "doctest-parallel" lib <- extractSpecificCabalLibrary (Just "spectests-modules") pkg DocTest.mainFromLibrary lib args main :: IO () main = hspec spec spec :: Spec spec = do describe "doctest" $ do it "exits with ExitFailure if at least one test case fails" $ do hSilence [stderr] (doctest ["Failing.Foo"]) `shouldThrow` (== ExitFailure 1) it "prints help on --help" $ do (r, ()) <- capture (doctest ["--help"]) r `shouldBe` Options.usage it "prints version on --version" $ do (r, ()) <- capture (doctest ["--version"]) lines r `shouldSatisfy` any (isPrefixOf "doctest version ") it "prints error message on invalid option" $ do (r, e) <- hCapture [stderr] . E.try $ doctest ["--foo", "test/integration/test-options/Foo.hs"] e `shouldBe` Left (ExitFailure 1) r `shouldBe` unlines [ "doctest: Unknown command line argument: --foo" , "Try `doctest --help' for more information." ] -- The commented tests fail, but only because `doctest-parallel` prints -- absolute paths. -- -- TODO: Fix -- it "prints verbose description of a specification" $ do -- (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "TestSimple.Fib"] -- r `shouldBe` unlines [ -- "### Started execution at test/integration/TestSimple/Fib.hs:5." -- , "### example:" -- , "fib 10" -- , "### Successful `test/integration/TestSimple/Fib.hs:5'!" -- , "" -- , "# Final summary:" -- , "Examples: 1 Tried: 1 Errors: 0 Unexpected output: 0" -- ] -- it "prints verbose description of a property" $ do -- (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "PropertyBool.Foo"] -- r `shouldBe` unlines [ -- "### Started execution at test/integration/PropertyBool/Foo.hs:4." -- , "### property:" -- , "True" -- , "### Successful `test/integration/PropertyBool/Foo.hs:4'!" -- , "" -- , "# Final summary:" -- , "Examples: 1 Tried: 1 Errors: 0 Unexpected output: 0" -- ] -- it "prints verbose error" $ do -- (r, e) <- hCapture [stderr] . E.try $ doctest ["--verbose", "Failing.Foo"] -- e `shouldBe` Left (ExitFailure 1) -- r `shouldBe` unlines [ -- "### Started execution at test/integration/Failing/Foo.hs:5." -- , "### example:" -- , "23" -- , "test/integration/Failing/Foo.hs:5: failure in expression `23'" -- , "expected: 42" -- , " but got: 23" -- , " ^" -- , "" -- , "# Final summary:" -- , "Examples: 1 Tried: 1 Errors: 0 Unexpected output: 1" -- ] doctest-parallel-0.3.1.1/test/Runner/0000755000000000000000000000000007346545000015532 5ustar0000000000000000doctest-parallel-0.3.1.1/test/Runner/ExampleSpec.hs0000644000000000000000000001315307346545000020277 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Runner.ExampleSpec (main, spec) where import Prelude () import Prelude.Compat import Data.String import Test.Hspec import Test.Hspec.Core.QuickCheck (modifyMaxSize) import Test.QuickCheck import Test.DocTest.Internal.Parse import Test.DocTest.Internal.Runner.Example main :: IO () main = hspec spec data Line = PlainLine String | WildCardLines [String] deriving (Show, Eq) instance Arbitrary Line where arbitrary = frequency [ (2, PlainLine <$> arbitrary) , (1, WildCardLines . getNonEmpty <$> arbitrary) ] lineToExpected :: [Line] -> ExpectedResult lineToExpected = map $ \x -> case x of PlainLine str -> fromString str WildCardLines _ -> WildCardLine lineToActual :: [Line] -> [String] lineToActual = concatMap $ \x -> case x of PlainLine str -> [str] WildCardLines xs -> xs spec :: Spec spec = do describe "mkResult" $ do it "returns Equal when output matches" $ do property $ \xs -> do mkResult (map fromString xs) xs `shouldBe` Equal it "ignores trailing whitespace" $ do mkResult ["foo\t"] ["foo "] `shouldBe` Equal context "with WildCardLine" $ do it "matches zero lines" $ do mkResult ["foo", WildCardLine, "bar"] ["foo", "bar"] `shouldBe` Equal it "matches first zero line" $ do mkResult [WildCardLine, "foo", "bar"] ["foo", "bar"] `shouldBe` Equal it "matches final zero line" $ do mkResult ["foo", "bar", WildCardLine] ["foo", "bar"] `shouldBe` Equal it "matches an arbitrary number of lines" $ do mkResult ["foo", WildCardLine, "bar"] ["foo", "baz", "bazoom", "bar"] `shouldBe` Equal -- See https://github.com/sol/doctest/issues/259 modifyMaxSize (const 8) $ it "matches an arbitrary number of lines (quickcheck)" $ do property $ \xs -> mkResult (lineToExpected xs) (lineToActual xs) `shouldBe` Equal context "with WildCardChunk" $ do it "matches an arbitrary line chunk" $ do mkResult [ExpectedLine ["foo", WildCardChunk, "bar"]] ["foo baz bar"] `shouldBe` Equal it "matches an arbitrary line chunk at end" $ do mkResult [ExpectedLine ["foo", WildCardChunk]] ["foo baz bar"] `shouldBe` Equal it "does not match at end" $ do mkResult [ExpectedLine [WildCardChunk, "baz"]] ["foo baz bar"] `shouldBe` NotEqual [ "expected: ...baz" , " but got: foo baz bar" , " ^" ] it "does not match at start" $ do mkResult [ExpectedLine ["fuu", WildCardChunk]] ["foo baz bar"] `shouldBe` NotEqual [ "expected: fuu..." , " but got: foo baz bar" , " ^" ] context "when output does not match" $ do it "constructs failure message" $ do mkResult ["foo"] ["bar"] `shouldBe` NotEqual [ "expected: foo" , " but got: bar" , " ^" ] it "constructs failure message for multi-line output" $ do mkResult ["foo", "bar"] ["foo", "baz"] `shouldBe` NotEqual [ "expected: foo" , " bar" , " but got: foo" , " baz" , " ^" ] context "when any output line contains \"unsafe\" characters" $ do it "uses show to format output lines" $ do mkResult ["foo\160bar"] ["foo bar"] `shouldBe` NotEqual [ "expected: foo\\160bar" , " but got: foo bar" , " ^" ] it "insert caret after last matching character on different lengths" $ do mkResult ["foo"] ["fo"] `shouldBe` NotEqual [ "expected: foo" , " but got: fo" , " ^" ] it "insert caret after mismatching line for multi-line output" $ do mkResult ["foo", "bar", "bat"] ["foo", "baz", "bax"] `shouldBe` NotEqual [ "expected: foo" , " bar" , " bat" , " but got: foo" , " baz" , " ^" , " bax" ] it "insert caret after mismatching line with the longest match for multi-line wildcard pattern" $ do mkResult ["foo", WildCardLine, "bar", "bat"] ["foo", "xxx", "yyy", "baz", "bxx"] `shouldBe` NotEqual [ "expected: foo" , " ..." , " bar" , " bat" , " but got: foo" , " xxx" , " yyy" , " baz" , " ^" , " bxx" ] it "insert caret after longest match for wildcard" $ do mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo xxx yyy baz bxx"] `shouldBe` NotEqual [ "expected: foo ... bar bat" , " but got: foo xxx yyy baz bxx" , " ^" ] it "show expanded pattern for long matches" $ do mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo 123456789 123456789 xxx yyy baz bxx"] `shouldBe` NotEqual [ "expected: foo ... bar bat" , " but got: foo 123456789 123456789 xxx yyy baz bxx" , " foo ........................... ba^" ] doctest-parallel-0.3.1.1/test/RunnerSpec.hs0000644000000000000000000000546507346545000016713 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams #-} module RunnerSpec (main, spec) where import Test.Hspec import Control.Concurrent import Control.Monad.Trans.State import System.IO import System.IO.Silently (hCapture) import Test.DocTest.Internal.Logging import Test.DocTest.Internal.Runner import Text.Printf (printf) main :: IO () main = hspec spec capture :: Report a -> IO String capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 True mempty) -- like capture, but with interactivity set to False capture_ :: Report a -> IO String capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 False mempty) spec :: Spec spec = do threadId <- runIO myThreadId let ?threadId = threadId let ?verbosity = Info describe "report" $ do context "when mode is interactive" $ do it "writes to stderr" $ do capture $ do report Info "foobar" `shouldReturn` printf "[INFO ] [%s] foobar\n" (show threadId) it "overwrites any intermediate output" $ do capture $ do report_ Info "foo" report Info "bar" `shouldReturn` printf "foo\r[INFO ] [%s] bar\n" (show threadId) it "blank out intermediate output if necessary" $ do capture $ do report_ Info "foobarrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr" report Info "baz" `shouldReturn` printf "foobarrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr\r[INFO ] [%s] baz \n" (show threadId) context "when mode is non-interactive" $ do it "writes to stderr" $ do capture_ $ do report Info "foobar" `shouldReturn` printf "[INFO ] [%s] foobar\n" (show threadId) describe "report_ Info" $ do context "when mode is interactive" $ do it "writes intermediate output to stderr" $ do capture $ do report_ Info "foobar" `shouldReturn` "foobar" it "overwrites any intermediate output" $ do capture $ do report_ Info "foo" report_ Info "bar" `shouldReturn` "foo\rbar" it "blank out intermediate output if necessary" $ do capture $ do report_ Info "foobar" report_ Info "baz" `shouldReturn` "foobar\rbaz " context "when mode is non-interactive" $ do it "is ignored" $ do capture_ $ do report_ Info "foobar" `shouldReturn` "" it "does not influence a subsequent call to `report Info`" $ do capture_ $ do report_ Info "foo" report Info "bar" `shouldReturn` printf "[INFO ] [%s] bar\n" (show threadId) it "does not require `report Info` to blank out any intermediate output" $ do capture_ $ do report_ Info "foobar" report Info "baz" `shouldReturn` printf "[INFO ] [%s] baz\n" (show threadId) doctest-parallel-0.3.1.1/test/Spec.hs0000644000000000000000000000162207346545000015510 0ustar0000000000000000module Main where import Test.Hspec import qualified ExtractSpec import qualified GhciWrapperSpec import qualified InterpreterSpec import qualified LocationSpec import qualified MainSpec import qualified OptionsSpec import qualified ParseSpec import qualified PropertySpec import qualified RunnerSpec import qualified RunSpec import qualified UtilSpec main :: IO () main = hspec spec spec :: Spec spec = do describe "ExtractSpec" ExtractSpec.spec describe "GhciWrapperSpec" GhciWrapperSpec.spec describe "InterpreterSpec" InterpreterSpec.spec describe "LocationSpec" LocationSpec.spec describe "MainSpec" MainSpec.spec describe "OptionsSpec" OptionsSpec.spec describe "ParseSpec" ParseSpec.spec describe "PropertySpec" PropertySpec.spec describe "RunnerSpec" RunnerSpec.spec describe "RunSpec" RunSpec.spec describe "UtilSpec" UtilSpec.spec doctest-parallel-0.3.1.1/test/UtilSpec.hs0000644000000000000000000000107707346545000016352 0ustar0000000000000000module UtilSpec (main, spec) where import Test.Hspec import Test.DocTest.Internal.Util main :: IO () main = hspec spec spec :: Spec spec = do describe "convertDosLineEndings" $ do it "converts CRLF to LF" $ do convertDosLineEndings "foo\r\nbar\r\nbaz" `shouldBe` "foo\nbar\nbaz" it "strips a trailing CR" $ do convertDosLineEndings "foo\r" `shouldBe` "foo" describe "takeWhileEnd" $ do it "returns the longest suffix of elements that satisfy a given predicate" $ do takeWhileEnd (/= ' ') "foo bar" `shouldBe` "bar" doctest-parallel-0.3.1.1/test/doctests.hs0000644000000000000000000000030407346545000016442 0ustar0000000000000000module Main where import Test.DocTest (mainFromCabal) import System.Environment (getArgs) main :: IO () main = do args <- getArgs mainFromCabal "doctest-parallel" ("--randomize-order":args) doctest-parallel-0.3.1.1/test/extract/argument-list/0000755000000000000000000000000007346545000020526 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/argument-list/Foo.hs0000644000000000000000000000014707346545000021607 0ustar0000000000000000module Foo where foo :: Int -- ^ doc for arg1 -> Int -- ^ doc for arg2 -> Int foo = undefined doctest-parallel-0.3.1.1/test/extract/comment-order/0000755000000000000000000000000007346545000020506 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/comment-order/Foo.hs0000644000000000000000000000042107346545000021562 0ustar0000000000000000-- | 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 doctest-parallel-0.3.1.1/test/extract/declaration/0000755000000000000000000000000007346545000020220 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/declaration/Foo.hs0000644000000000000000000000007607346545000021302 0ustar0000000000000000module Foo where -- | Some documentation foo :: Int foo = 23 doctest-parallel-0.3.1.1/test/extract/dos-line-endings/0000755000000000000000000000000007346545000021072 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/dos-line-endings/Foo.hs0000644000000000000000000000011007346545000022141 0ustar0000000000000000module Foo where -- | -- foo -- bar -- baz foo :: Int foo = 23 doctest-parallel-0.3.1.1/test/extract/export-list/0000755000000000000000000000000007346545000020225 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/export-list/Foo.hs0000644000000000000000000000020107346545000021275 0ustar0000000000000000module Foo ( -- * some heading -- | documentation from export list foo , bar ) where foo :: Int foo = 23 bar :: Int bar = 23 doctest-parallel-0.3.1.1/test/extract/imported-module/0000755000000000000000000000000007346545000021041 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/imported-module/Bar.hs0000644000000000000000000000011507346545000022076 0ustar0000000000000000module Bar where import Baz -- | documentation for bar bar :: Int bar = 23 doctest-parallel-0.3.1.1/test/extract/imported-module/Baz.hs0000644000000000000000000000010107346545000022101 0ustar0000000000000000module Baz where -- | documentation for baz baz :: Int baz = 23 doctest-parallel-0.3.1.1/test/extract/module-header/0000755000000000000000000000000007346545000020446 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/module-header/Foo.hs0000644000000000000000000000007607346545000021530 0ustar0000000000000000-- | Some documentation module Foo where foo :: Int foo = 23 doctest-parallel-0.3.1.1/test/extract/module-options/0000755000000000000000000000000007346545000020711 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/module-options/Binders.hs0000644000000000000000000000014007346545000022626 0ustar0000000000000000module Binders where {-# ANN f "doctest-parallel: --no-randomize-error" #-} f :: a -> a f = id doctest-parallel-0.3.1.1/test/extract/module-options/Mono.hs0000644000000000000000000000064207346545000022157 0ustar0000000000000000module Mono where {-# ANN module "doctest-parallel: --no-randomize-error1" #-} {-# ANN module ("doctest-parallel: --no-randomize-error2") #-} {-# ANN module ("doctest-parallel: --no-randomize-error3" ) #-} {-# ANN module ("doctest-parallel: --no-randomize-error4" ) #-} {-# ANN module ("doctest-parallel: --no-randomize-error5 " ) #-} {-# ANN module ("doctest-parallel: --no-randomize-error6" :: String) #-} doctest-parallel-0.3.1.1/test/extract/module-options/NoOptions.hs0000644000000000000000000000015507346545000023176 0ustar0000000000000000module NoOptions where {-# ANN module "doctest-parallel" #-} {-# ANN module "abc" #-} {-# ANN module "" #-} doctest-parallel-0.3.1.1/test/extract/module-options/Poly.hs0000644000000000000000000000017707346545000022175 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Poly where {-# ANN module ("doctest-parallel: --no-randomize-error" :: String) #-} doctest-parallel-0.3.1.1/test/extract/named-chunks/0000755000000000000000000000000007346545000020310 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/named-chunks/Foo.hs0000644000000000000000000000020007346545000021357 0ustar0000000000000000module Foo ( foo , bar ) where -- $foo named chunk foo -- $bar -- named chunk bar foo :: Int foo = 23 bar :: Int bar = 23 doctest-parallel-0.3.1.1/test/extract/regression/0000755000000000000000000000000007346545000020113 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/regression/Fixity.hs0000644000000000000000000000005607346545000021724 0ustar0000000000000000module Fixity where foo :: Int foo = 23 + 42 doctest-parallel-0.3.1.1/test/extract/regression/ForeignImport.hs0000644000000000000000000000037707346545000023242 0ustar0000000000000000{-# 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)) doctest-parallel-0.3.1.1/test/extract/regression/ParallelListComp.hs0000644000000000000000000000017007346545000023654 0ustar0000000000000000{-# LANGUAGE ParallelListComp #-} module ParallelListComp where foo :: [Int] foo = [x+y | x <- [1,2,3] | y <- [4,5,6]] doctest-parallel-0.3.1.1/test/extract/regression/ParallelListCompClass.hs0000644000000000000000000000026207346545000024644 0ustar0000000000000000{-# 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]] doctest-parallel-0.3.1.1/test/extract/regression/RewriteRules.hs0000644000000000000000000000023207346545000023100 0ustar0000000000000000module 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 doctest-parallel-0.3.1.1/test/extract/regression/RewriteRulesWithSigs.hs0000644000000000000000000000025607346545000024570 0ustar0000000000000000module 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 doctest-parallel-0.3.1.1/test/extract/setup/0000755000000000000000000000000007346545000017073 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/setup/Foo.hs0000644000000000000000000000021107346545000020144 0ustar0000000000000000module Foo where -- $setup -- some setup code -- | foo foo :: Int foo = 42 -- | bar bar :: Int bar = 42 -- | baz baz :: Int baz = 42 doctest-parallel-0.3.1.1/test/extract/th/0000755000000000000000000000000007346545000016346 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/th/Bar.hs0000644000000000000000000000016607346545000017411 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Bar where import Language.Haskell.TH.Lib (ExpQ) bar :: ExpQ bar = [| 23 |] doctest-parallel-0.3.1.1/test/extract/th/Foo.hs0000644000000000000000000000015707346545000017430 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Foo where import Bar -- | some documentation foo :: Int foo = $(bar) doctest-parallel-0.3.1.1/test/extract/type-class-args/0000755000000000000000000000000007346545000020751 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/type-class-args/Foo.hs0000644000000000000000000000014407346545000022027 0ustar0000000000000000module Foo where class Foo a where bar :: a -- ^ foo -> Int -- ^ bar -> String doctest-parallel-0.3.1.1/test/extract/type-class/0000755000000000000000000000000007346545000020017 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/type-class/Foo.hs0000644000000000000000000000015507346545000021077 0ustar0000000000000000module Foo where class ToString a where -- | Convert given value to a string. toString :: a -> String doctest-parallel-0.3.1.1/test/extract/type-families/0000755000000000000000000000000007346545000020503 5ustar0000000000000000doctest-parallel-0.3.1.1/test/extract/type-families/Foo.hs0000644000000000000000000000013707346545000021563 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Foo where type family Foo a type instance Foo Int = Int doctest-parallel-0.3.1.1/test/integration/BugfixImportHierarchical/0000755000000000000000000000000007346545000023522 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/BugfixImportHierarchical/ModuleA.hs0000644000000000000000000000024207346545000025402 0ustar0000000000000000-- | -- >>> import BugfixImportHierarchical.ModuleB -- >>> fib 10 -- 55 module BugfixImportHierarchical.ModuleA where import BugfixImportHierarchical.ModuleB () doctest-parallel-0.3.1.1/test/integration/BugfixImportHierarchical/ModuleB.hs0000644000000000000000000000026107346545000025404 0ustar0000000000000000module BugfixImportHierarchical.ModuleB (fib) where -- | -- >>> fib 10 -- 55 -- >>> fib 5 -- 5 fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) doctest-parallel-0.3.1.1/test/integration/BugfixMultipleModules/0000755000000000000000000000000007346545000023075 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/BugfixMultipleModules/ModuleA.hs0000644000000000000000000000032707346545000024761 0ustar0000000000000000{-# OPTIONS_GHC -Wno-unused-imports #-} -- | The test below should fail, as ModuleB does not export it: -- -- >>> import BugfixMultipleModules.ModuleB -- >>> fib 10 -- 55 module BugfixMultipleModules.ModuleA where doctest-parallel-0.3.1.1/test/integration/BugfixMultipleModules/ModuleB.hs0000644000000000000000000000046107346545000024761 0ustar0000000000000000module BugfixMultipleModules.ModuleB (fib) where -- | -- >>> fib 10 -- 55 -- >>> fib 5 -- 5 fib :: Integer -> Integer fib = foo -- This test should fail, as foo is not exported: -- | -- >>> foo 10 -- 55 -- >>> foo 5 -- 5 foo :: Integer -> Integer foo 0 = 0 foo 1 = 1 foo n = foo (n - 1) + foo (n - 2) doctest-parallel-0.3.1.1/test/integration/BugfixOutputToStdErr/0000755000000000000000000000000007346545000022700 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/BugfixOutputToStdErr/Fib.hs0000644000000000000000000000032107346545000023730 0ustar0000000000000000module BugfixOutputToStdErr.Fib where -- | Calculate Fibonacci number of given 'Num'. -- -- >>> import System.IO -- >>> hPutStrLn stderr "foobar" -- foobar fib :: (Num t, Num t1) => t -> t1 fib _ = undefined doctest-parallel-0.3.1.1/test/integration/Color/0000755000000000000000000000000007346545000017662 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/Color/Foo.hs0000644000000000000000000000037707346545000020750 0ustar0000000000000000module Color.Foo where import Data.Maybe -- | Convert a map into list array. -- prop> tabulate m !! fromEnum d == fromMaybe 0 (lookup d m) tabulate :: [(Bool, Double)] -> [Double] tabulate m = [fromMaybe 0 $ lookup False m, fromMaybe 0 $ lookup True m] doctest-parallel-0.3.1.1/test/integration/DosLineEndings/0000755000000000000000000000000007346545000021451 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/DosLineEndings/Fib.hs0000644000000000000000000000026407346545000022507 0ustar0000000000000000module DosLineEndings.Fib where -- | Calculate Fibonacci numbers. -- -- >>> fib 10 -- 55 fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) doctest-parallel-0.3.1.1/test/integration/Failing/0000755000000000000000000000000007346545000020155 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/Failing/Foo.hs0000644000000000000000000000013707346545000021235 0ustar0000000000000000module Failing.Foo where -- | A failing example -- -- >>> 23 -- 42 test :: a test = undefined doctest-parallel-0.3.1.1/test/integration/FailingMultiple/0000755000000000000000000000000007346545000021671 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/FailingMultiple/Foo.hs0000644000000000000000000000023507346545000022750 0ustar0000000000000000module FailingMultiple.Foo where -- | A failing example -- -- >>> 23 -- 23 -- -- >>> 23 -- 42 -- -- >>> 23 -- 23 -- >>> 23 -- 23 test :: a test = undefined doctest-parallel-0.3.1.1/test/integration/GhcArg/0000755000000000000000000000000007346545000017737 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/GhcArg/Fib.hs0000644000000000000000000000027007346545000020772 0ustar0000000000000000{-# LANGUAGE CPP #-} module GhcArg.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) doctest-parallel-0.3.1.1/test/integration/It/0000755000000000000000000000000007346545000017160 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/It/Foo.hs0000644000000000000000000000026307346545000020240 0ustar0000000000000000module It.Foo where -- | -- -- >>> :t 'a' -- 'a' :: Char -- -- >>> "foo" -- "foo" -- -- >>> length it -- 3 -- -- >>> it * it -- 9 -- -- >>> :t it -- it :: Int -- foo = undefined doctest-parallel-0.3.1.1/test/integration/It/Setup.hs0000644000000000000000000000031307346545000020611 0ustar0000000000000000module It.Setup where -- $setup -- >>> :t 'a' -- 'a' :: Char -- -- >>> 42 :: Int -- 42 -- -- >>> it -- 42 -- | -- -- >>> it * it -- 1764 foo = undefined -- | -- -- >>> it * it -- 1764 bar = undefined doctest-parallel-0.3.1.1/test/integration/LocalStderrBinding/0000755000000000000000000000000007346545000022315 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/LocalStderrBinding/A.hs0000644000000000000000000000017307346545000023032 0ustar0000000000000000module LocalStderrBinding.A where stderr :: Bool stderr = True stdout :: String stdout = "hello" -- | -- >>> 3 + 3 -- 6 doctest-parallel-0.3.1.1/test/integration/ModuleIsolation/0000755000000000000000000000000007346545000021713 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/ModuleIsolation/TestA.hs0000644000000000000000000000026607346545000023273 0ustar0000000000000000module ModuleIsolation.TestA (foo) where import ModuleIsolation.TestB () {- $setup >>> :set -XLambdaCase -} -- | -- >>> (\case { 3 -> 5; 7 -> 9}) 3 -- 5 foo :: Num a => a foo = 3 doctest-parallel-0.3.1.1/test/integration/ModuleIsolation/TestB.hs0000644000000000000000000000020307346545000023263 0ustar0000000000000000module ModuleIsolation.TestB (bar) where -- | Example usage: -- -- >>> (\case { 3 -> 5; 7 -> 9}) 3 -- 5 bar :: Num a => a bar = 3 doctest-parallel-0.3.1.1/test/integration/ModuleOptions/0000755000000000000000000000000007346545000021405 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/ModuleOptions/Foo.hs0000644000000000000000000000036407346545000022467 0ustar0000000000000000module ModuleOptions.Foo where {-# ANN module "doctest-parallel: --preserve-it" #-} -- | -- -- >>> :t 'a' -- 'a' :: Char -- -- >>> "foo" -- "foo" -- -- >>> length it -- 3 -- -- >>> it * it -- 9 -- -- >>> :t it -- it :: Int -- foo = undefined doctest-parallel-0.3.1.1/test/integration/Multiline/0000755000000000000000000000000007346545000020546 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/Multiline/Multiline.hs0000644000000000000000000000115307346545000023044 0ustar0000000000000000module Multiline.Multiline where {- | >>> :{ let x = 1 y = z in x + y :} 3 -} z = 2 {- | Aligns with the closing >>> :{ let x = 1 y = z in x + y :} 3 -} z2 = 2 {- | Also works let that's for do: >>> :{ let x = 1 y = z :} >>> y 2 -} z3 = 2 {- | Handles repeated @>>>@ too, which is bad since haddock-2.13.2 currently will strip the leading whitespace leading to something that will not copy-paste (unless it uses explicit { ; } and the users manually strip the @>>>@) >>> :{ >>> let >>> x = 1 >>> y = z >>> in x + y >>> :} 3 -} z4 = 4 doctest-parallel-0.3.1.1/test/integration/NonExposedModule/0000755000000000000000000000000007346545000022034 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/NonExposedModule/Exposed.hs0000644000000000000000000000013407346545000023775 0ustar0000000000000000module NonExposedModule.Exposed (foo) where import NonExposedModule.NoImplicitImport (foo) doctest-parallel-0.3.1.1/test/integration/NonExposedModule/NoImplicitImport.hs0000644000000000000000000000033107346545000025627 0ustar0000000000000000module NonExposedModule.NoImplicitImport where {-# ANN module "doctest-parallel: --no-implicit-module-import" #-} -- | -- >>> import NonExposedModule.Exposed (foo) -- >>> foo 7 -- 14 foo :: Int -> Int foo a = a + a doctest-parallel-0.3.1.1/test/integration/PropertyBool/0000755000000000000000000000000007346545000021244 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/PropertyBool/Foo.hs0000644000000000000000000000010207346545000022314 0ustar0000000000000000module PropertyBool.Foo where -- | -- prop> True foo = undefined doctest-parallel-0.3.1.1/test/integration/PropertyBoolWithTypeSignature/0000755000000000000000000000000007346545000024624 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/PropertyBoolWithTypeSignature/Foo.hs0000644000000000000000000000013307346545000025700 0ustar0000000000000000module PropertyBoolWithTypeSignature.Foo where -- | -- prop> True :: Bool foo = undefined doctest-parallel-0.3.1.1/test/integration/PropertyFailing/0000755000000000000000000000000007346545000021722 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/PropertyFailing/Foo.hs0000644000000000000000000000011307346545000022774 0ustar0000000000000000module PropertyFailing.Foo where -- | -- prop> abs x == x foo = undefined doctest-parallel-0.3.1.1/test/integration/PropertyImplicitlyQuantified/0000755000000000000000000000000007346545000024502 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/PropertyImplicitlyQuantified/Foo.hs0000644000000000000000000000014207346545000025556 0ustar0000000000000000module PropertyImplicitlyQuantified.Foo where -- | -- prop> abs x == abs (abs x) foo = undefined doctest-parallel-0.3.1.1/test/integration/PropertyQuantified/0000755000000000000000000000000007346545000022442 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/PropertyQuantified/Foo.hs0000644000000000000000000000013607346545000023521 0ustar0000000000000000module PropertyQuantified.Foo where -- | -- prop> \x -> abs x == abs (abs x) foo = undefined doctest-parallel-0.3.1.1/test/integration/PropertySetup/0000755000000000000000000000000007346545000021451 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/PropertySetup/Foo.hs0000644000000000000000000000026307346545000022531 0ustar0000000000000000module PropertySetup.Foo where -- $setup -- >>> import Test.QuickCheck -- >>> let arbitraryEven = (* 2) `fmap` arbitrary -- | -- prop> forAll arbitraryEven even foo = undefined doctest-parallel-0.3.1.1/test/integration/Setup/0000755000000000000000000000000007346545000017704 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/Setup/Foo.hs0000644000000000000000000000015207346545000020761 0ustar0000000000000000module Setup.Foo where -- $setup -- >>> let x = 23 :: Int -- | -- >>> x + foo -- 65 foo :: Int foo = 42 doctest-parallel-0.3.1.1/test/integration/SetupSkipOnFailure/0000755000000000000000000000000007346545000022340 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/SetupSkipOnFailure/Foo.hs0000644000000000000000000000022207346545000023413 0ustar0000000000000000module SetupSkipOnFailure.Foo where -- $setup -- >>> x -- 23 -- | -- >>> foo -- 42 foo :: Int foo = 42 -- | -- >>> y -- 42 bar :: Int bar = 42 doctest-parallel-0.3.1.1/test/integration/SystemIoImported/0000755000000000000000000000000007346545000022064 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/SystemIoImported/A.hs0000644000000000000000000000043307346545000022600 0ustar0000000000000000module SystemIoImported.A where import System.IO -- ghci-wrapper needs to poke around with System.IO itself, and unloads the module once it's done. Test to make sure legitimate uses of System.IO don't get lost in the wash. -- | -- >>> import System.IO -- >>> ReadMode -- ReadMode doctest-parallel-0.3.1.1/test/integration/TemplateHaskell/0000755000000000000000000000000007346545000021663 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TemplateHaskell/Foo.hs0000644000000000000000000000063407346545000022745 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TemplateHaskell.Foo where import Language.Haskell.TH import Text.Printf -- | Report an error. -- -- >>> :set -XTemplateHaskell -- >>> $(logError "Something bad happened!") -- ERROR : Something bad happened! logError :: String -> Q Exp logError msg = do loc <- location let s = (printf "ERROR %s: %s" (loc_filename loc) msg) :: String [| putStrLn s |] doctest-parallel-0.3.1.1/test/integration/TestBlankline/0000755000000000000000000000000007346545000021343 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TestBlankline/Fib.hs0000644000000000000000000000030107346545000022371 0ustar0000000000000000module TestBlankline.Fib where -- | Calculate Fibonacci number of given 'Num'. -- -- >>> putStrLn "foo\n\nbar" -- foo -- -- bar fib :: (Num t, Num t1) => t -> t1 fib _ = undefined doctest-parallel-0.3.1.1/test/integration/TestCombinedExample/0000755000000000000000000000000007346545000022500 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TestCombinedExample/Fib.hs0000644000000000000000000000051207346545000023532 0ustar0000000000000000module TestCombinedExample.Fib where -- | Calculate Fibonacci number of given 'Num'. -- -- First let's set `n` to ten: -- -- >>> let n = 10 -- -- And now calculate the 10th Fibonacci number: -- -- >>> fib n -- 55 -- -- >>> let x = 10 -- >>> x -- 10 fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) doctest-parallel-0.3.1.1/test/integration/TestCommentLocation/0000755000000000000000000000000007346545000022537 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TestCommentLocation/Foo.hs0000644000000000000000000000264407346545000023624 0ustar0000000000000000-- | -- Examples in various locations... -- -- Some random text. Some random text. Some random text. Some random text. -- Some random text. Some random text. Some random text. Some random text. -- Some random text. -- -- >>> let x = 10 -- -- Some random text. Some random text. Some random text. Some random text. -- Some random text. Some random text. Some random text. Some random text. -- Some random text. -- -- -- >>> baz -- "foobar" module TestCommentLocation.Foo ( -- | Some documentation not attached to a particular Haskell entity -- -- >>> test 10 -- *** Exception: Prelude.undefined -- ... test, -- | -- >>> fib 10 -- 55 fib, -- | -- >>> bar -- "bar" bar, foo, baz ) where -- | My test -- -- >>> test 20 -- *** Exception: Prelude.undefined -- ... test :: Integer -> Integer test = undefined -- | Note that examples for 'fib' include the two examples below -- and the one example with ^ syntax after 'fix' -- -- >>> foo -- "foo" {- | Example: >>> fib 10 55 -} -- | Calculate Fibonacci number of given `n`. fib :: Integer -- ^ given `n` -- -- >>> fib 10 -- 55 -> Integer -- ^ Fibonacci of given `n` -- -- >>> baz -- "foobar" fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) -- ^ Example: -- -- >>> fib 5 -- 5 foo = "foo" bar = "bar" baz = foo ++ bar doctest-parallel-0.3.1.1/test/integration/TestDocumentationForArguments/0000755000000000000000000000000007346545000024612 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TestDocumentationForArguments/Fib.hs0000644000000000000000000000020307346545000025641 0ustar0000000000000000module TestDocumentationForArguments.Fib where fib :: Int -- ^ -- >>> 23 -- 23 -> Int fib _ = undefined doctest-parallel-0.3.1.1/test/integration/TestFailOnMultiline/0000755000000000000000000000000007346545000022477 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TestFailOnMultiline/Fib.hs0000644000000000000000000000037307346545000023536 0ustar0000000000000000module TestFailOnMultiline.Fib where -- | The following interaction cause `doctest' to fail with an error: -- -- >>> :{ foo :: Int foo = 23 -- | The following interaction cause `doctest' to fail with an error: -- -- >>> :{ bar :: Int bar = 23 doctest-parallel-0.3.1.1/test/integration/TestImport/0000755000000000000000000000000007346545000020716 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TestImport/ModuleA.hs0000644000000000000000000000013307346545000022575 0ustar0000000000000000-- | -- >>> import TestImport.ModuleB -- >>> fib 10 -- 55 module TestImport.ModuleA where doctest-parallel-0.3.1.1/test/integration/TestImport/ModuleB.hs0000644000000000000000000000024307346545000022600 0ustar0000000000000000module TestImport.ModuleB (fib) where -- | -- >>> fib 10 -- 55 -- >>> fib 5 -- 5 fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) doctest-parallel-0.3.1.1/test/integration/TestPutStr/0000755000000000000000000000000007346545000020705 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TestPutStr/Fib.hs0000644000000000000000000000033407346545000021741 0ustar0000000000000000module TestPutStr.Fib where -- | Calculate Fibonacci number of given 'Num'. -- -- >>> putStrLn "foo" -- foo -- >>> putStr "bar" -- bar -- -- >>> putStrLn "baz" -- baz fib :: (Num t, Num t1) => t -> t1 fib _ = undefined doctest-parallel-0.3.1.1/test/integration/TestSimple/0000755000000000000000000000000007346545000020675 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TestSimple/Fib.hs0000644000000000000000000000024607346545000021733 0ustar0000000000000000module TestSimple.Fib where -- | Calculate Fibonacci numbers. -- -- >>> fib 10 -- 55 fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) doctest-parallel-0.3.1.1/test/integration/TrailingWhitespace/0000755000000000000000000000000007346545000022372 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/TrailingWhitespace/Foo.hs0000644000000000000000000000017207346545000023451 0ustar0000000000000000module TrailingWhitespace.Foo where -- | A failing example -- -- >>> putStrLn "foo " -- foo test :: a test = undefined doctest-parallel-0.3.1.1/test/integration/WithCInclude/0000755000000000000000000000000007346545000021126 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/WithCInclude/Bar.hs0000644000000000000000000000017507346545000022171 0ustar0000000000000000{-# LANGUAGE CPP #-} module WithCInclude.Bar where #include "WithCInclude.h" -- | -- >>> x -- 42 x :: Int x = THE_DEFINE doctest-parallel-0.3.1.1/test/integration/WithCInclude/include/0000755000000000000000000000000007346545000022551 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/WithCInclude/include/WithCInclude.h0000644000000000000000000000002607346545000025242 0ustar0000000000000000#define THE_DEFINE 42 doctest-parallel-0.3.1.1/test/integration/WithCbits/0000755000000000000000000000000007346545000020504 5ustar0000000000000000doctest-parallel-0.3.1.1/test/integration/WithCbits/Bar.hs0000644000000000000000000000021707346545000021544 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module WithCbits.Bar where import Foreign.C -- | -- >>> foo -- 23 foreign import ccall foo :: CInt doctest-parallel-0.3.1.1/test/integration/WithCbits/foo.c0000644000000000000000000000003307346545000021427 0ustar0000000000000000int foo() { return 23; } doctest-parallel-0.3.1.1/test/parse/multiple-examples/0000755000000000000000000000000007346545000021042 5ustar0000000000000000doctest-parallel-0.3.1.1/test/parse/multiple-examples/Foo.hs0000644000000000000000000000012107346545000022113 0ustar0000000000000000module Foo where -- | -- >>> foo -- 23 foo = 23 -- | -- >>> bar -- 42 bar = 42 doctest-parallel-0.3.1.1/test/parse/no-examples/0000755000000000000000000000000007346545000017623 5ustar0000000000000000doctest-parallel-0.3.1.1/test/parse/no-examples/Fib.hs0000644000000000000000000000020607346545000020655 0ustar0000000000000000module Fib where -- | Calculate Fibonacci numbers. -- @ -- some code -- @ -- -- foobar 23 fib :: Int -> Int -> Int fib _ = undefined doctest-parallel-0.3.1.1/test/parse/non-exported/0000755000000000000000000000000007346545000020015 5ustar0000000000000000doctest-parallel-0.3.1.1/test/parse/non-exported/Fib.hs0000644000000000000000000000035407346545000021053 0ustar0000000000000000module 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 doctest-parallel-0.3.1.1/test/parse/property/0000755000000000000000000000000007346545000017257 5ustar0000000000000000doctest-parallel-0.3.1.1/test/parse/property/Fib.hs0000644000000000000000000000026407346545000020315 0ustar0000000000000000module Fib where -- | Calculate Fibonacci numbers. -- -- prop> foo -- -- some text -- -- prop> bar -- -- some more text -- -- prop> baz fib :: Int -> Int -> Int fib _ = undefined doctest-parallel-0.3.1.1/test/parse/setup-empty/0000755000000000000000000000000007346545000017667 5ustar0000000000000000doctest-parallel-0.3.1.1/test/parse/setup-empty/Foo.hs0000644000000000000000000000013207346545000020742 0ustar0000000000000000module Foo where -- $setup -- some setup code -- | -- >>> foo -- 23 foo :: Int foo = 23 doctest-parallel-0.3.1.1/test/parse/setup-only/0000755000000000000000000000000007346545000017512 5ustar0000000000000000doctest-parallel-0.3.1.1/test/parse/setup-only/Foo.hs0000644000000000000000000000013207346545000020565 0ustar0000000000000000module Foo where -- $setup -- >>> foo -- 23 -- | some documentation foo :: Int foo = 23 doctest-parallel-0.3.1.1/test/parse/simple/0000755000000000000000000000000007346545000016664 5ustar0000000000000000doctest-parallel-0.3.1.1/test/parse/simple/Fib.hs0000644000000000000000000000027207346545000017721 0ustar0000000000000000module Fib where -- | Calculate Fibonacci numbers. -- -- >>> putStrLn "foo" -- foo -- >>> putStr "bar" -- bar -- -- >>> putStrLn "baz" -- baz fib :: Int -> Int -> Int fib _ = undefined