doctest-0.16.0.1/0000755000000000000000000000000013351740625011576 5ustar0000000000000000doctest-0.16.0.1/doctest.cabal0000644000000000000000000001542213351740625014233 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.31.0. -- -- see: https://github.com/sol/hpack -- -- hash: d830267b38357e2e5f17c55764df93c08d2c7b450b12cba13fc0795f21a39202 name: doctest version: 0.16.0.1 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python (). . Documentation is at . category: Testing bug-reports: https://github.com/sol/doctest/issues homepage: https://github.com/sol/doctest#readme license: MIT license-file: LICENSE copyright: (c) 2009-2018 Simon Hengel author: Simon Hengel maintainer: Simon Hengel build-type: Simple extra-source-files: example/example.cabal example/src/Example.hs example/test/doctests.hs test/parse/multiple-examples/Foo.hs test/parse/no-examples/Fib.hs test/parse/non-exported/Fib.hs test/parse/property/Fib.hs test/parse/setup-empty/Foo.hs test/parse/setup-only/Foo.hs test/parse/simple/Fib.hs test/extract/argument-list/Foo.hs test/extract/comment-order/Foo.hs test/extract/declaration/Foo.hs test/extract/dos-line-endings/Foo.hs test/extract/export-list/Foo.hs test/extract/imported-module/Bar.hs test/extract/imported-module/Baz.hs test/extract/module-header/Foo.hs test/extract/named-chunks/Foo.hs test/extract/regression/Fixity.hs test/extract/regression/ForeignImport.hs test/extract/regression/ParallelListComp.hs test/extract/regression/ParallelListCompClass.hs test/extract/regression/RewriteRules.hs test/extract/regression/RewriteRulesWithSigs.hs test/extract/setup/Foo.hs test/extract/th/Bar.hs test/extract/th/Foo.hs test/extract/type-class-args/Foo.hs test/extract/type-class/Foo.hs test/extract/type-families/Foo.hs test/integration/bugfixImportHierarchical/ModuleA.hs test/integration/bugfixImportHierarchical/ModuleB.hs test/integration/bugfixMultipleModules/ModuleA.hs test/integration/bugfixMultipleModules/ModuleB.hs test/integration/bugfixOutputToStdErr/Fib.hs test/integration/bugfixWorkingDirectory/description test/integration/bugfixWorkingDirectory/examples/Fib.hs test/integration/bugfixWorkingDirectory/Fib.hs test/integration/custom-package-conf/Bar.hs test/integration/custom-package-conf/foo/doctest-foo.cabal test/integration/custom-package-conf/foo/Foo.hs test/integration/dos-line-endings/Fib.hs test/integration/failing-multiple/Foo.hs test/integration/failing/Foo.hs test/integration/it/Foo.hs test/integration/it/Setup.hs test/integration/multiline/Multiline.hs test/integration/parse-error/Foo.hs test/integration/property-bool-with-type-signature/Foo.hs test/integration/property-bool/Foo.hs test/integration/property-failing/Foo.hs test/integration/property-implicitly-quantified/Foo.hs test/integration/property-quantified/Foo.hs test/integration/property-setup/Foo.hs test/integration/setup-skip-on-failure/Foo.hs test/integration/setup/Foo.hs test/integration/template-haskell-bugfix/Main.hs test/integration/template-haskell-bugfix/Printf.hs test/integration/template-haskell/Foo.hs test/integration/test-options/Foo.hs test/integration/testBlankline/Fib.hs test/integration/testCombinedExample/Fib.hs test/integration/testCommentLocation/Foo.hs test/integration/testCPP/Foo.hs test/integration/testDocumentationForArguments/Fib.hs test/integration/testFailOnMultiline/Fib.hs test/integration/testImport/ModuleA.hs test/integration/testImport/ModuleB.hs test/integration/testPutStr/Fib.hs test/integration/testSimple/Fib.hs test/integration/trailing-whitespace/Foo.hs test/integration/with-cbits/Bar.hs test/integration/with-cbits/foo.c test/sandbox/bad.config test/sandbox/cabal.sandbox.config CHANGES README.markdown source-repository head type: git location: https://github.com/sol/doctest library ghc-options: -Wall hs-source-dirs: src ghci-wrapper/src exposed-modules: Test.DocTest other-modules: Extract GhcUtil Interpreter Location Options PackageDBs Parse Property Run Runner Runner.Example Sandbox Util Language.Haskell.GhciWrapper Paths_doctest build-depends: base >=4.5 && <5 , base-compat >=0.7.0 , code-page >=0.1 , deepseq , directory , filepath , ghc >=7.0 && <8.7 , ghc-paths >=0.1.0.9 , process , syb >=0.3 , transformers default-language: Haskell2010 executable doctest main-is: Main.hs other-modules: Paths_doctest ghc-options: -Wall -threaded hs-source-dirs: driver build-depends: base >=4.5 && <5 , base-compat >=0.7.0 , code-page >=0.1 , deepseq , directory , doctest , filepath , ghc >=7.0 && <8.7 , ghc-paths >=0.1.0.9 , process , syb >=0.3 , transformers default-language: Haskell2010 test-suite doctests main-is: doctests.hs type: exitcode-stdio-1.0 ghc-options: -Wall -threaded hs-source-dirs: test build-depends: base >=4.5 && <5 , base-compat >=0.7.0 , code-page >=0.1 , deepseq , directory , doctest , filepath , ghc >=7.0 && <8.7 , ghc-paths >=0.1.0.9 , process , syb >=0.3 , transformers default-language: Haskell2010 test-suite spec main-is: Spec.hs other-modules: ExtractSpec InterpreterSpec LocationSpec MainSpec OptionsSpec Orphans PackageDBsSpec ParseSpec PropertySpec Runner.ExampleSpec RunnerSpec RunSpec SandboxSpec UtilSpec Extract GhcUtil Interpreter Location Options PackageDBs Parse Property Run Runner Runner.Example Sandbox Test.DocTest Util Language.Haskell.GhciWrapper Paths_doctest type: exitcode-stdio-1.0 ghc-options: -Wall -threaded cpp-options: -DTEST hs-source-dirs: test src ghci-wrapper/src c-sources: test/integration/with-cbits/foo.c build-depends: HUnit , QuickCheck >=2.11.3 , base >=4.5 && <5 , base-compat >=0.7.0 , code-page >=0.1 , deepseq , directory , filepath , ghc >=7.0 && <8.7 , ghc-paths >=0.1.0.9 , hspec >=1.5.1 , mockery , process , setenv , silently >=1.2.4 , stringbuilder >=0.4 , syb >=0.3 , transformers , with-location default-language: Haskell2010 doctest-0.16.0.1/Setup.lhs0000644000000000000000000000011413351740625013402 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain doctest-0.16.0.1/README.markdown0000644000000000000000000002516513351740625014310 0ustar0000000000000000# Doctest: Test interactive Haskell examples `doctest` is a small program, 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` is available from [Hackage](http://hackage.haskell.org/cgi-bin/hackage-scripts/package/doctest). Install it, by typing: cabal install doctest Make sure that Cabal's `bindir` is on your `PATH`. On Linux: export PATH="$HOME/.cabal/bin:$PATH" On Mac OS X: export PATH="$HOME/Library/Haskell/bin:$PATH" On Windows: set PATH="%AppData%\cabal\bin\;%PATH%" For more information, see the [section on paths in the Cabal User Guide](http://www.haskell.org/cabal/users-guide/installing-packages.html#paths-in-the-simple-build-system). ## 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 an [REPL](http://en.wikipedia.org/wiki/Read-eval-print_loop) (e.g. ghci) prints to `stdout` and `stderr` when evaluating that expression.) With `doctest` you may check whether the implementation satisfies the given examples, by typing: doctest Fib.hs You may produce Haddock documentation for that module with: haddock -h Fib.hs -o doc/ ### 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!). #### A note on performance By default, `doctest` calls `:reload` between each group to clear GHCi's scope of any local definitions. This ensures that previous examples cannot influence later ones. However, it can lead to performance penalties if you are using `doctest` in a project with many modules. One possible remedy is to pass the `--fast` flag to `doctest`, which disables calling `:reload` between groups. If `doctest`s are running too slowly, you might consider using `--fast`. (With the caveat that the order in which groups appear now matters!) However, note that due to a [bug on GHC 8.2.1 or later](https://ghc.haskell.org/trac/ghc/ticket/14052), the performance of `--fast` suffers significantly when combined with the `--preserve-it` flag (which keeps the value of GHCi's `it` value between examples). ### Setup code You can put setup code in a [named chunk][named-chunks] with the name `$setup`. The setup code is run before each example group. If the setup code produces any errors/failures, all tests from that module are skipped. Here is an example: ```haskell module Foo where import Bar.Baz -- $setup -- >>> let x = 23 :: Int -- | -- >>> foo + x -- 65 foo :: Int foo = 42 ``` Note that you should not place setup code inbetween the module header (`module ... where`) and import declarations. GHC will not be able to parse it ([issue #167](https://github.com/sol/doctest/issues/167)). It is best to place setup code right after import declarations, but due to its declarative nature you can place it anywhere inbetween top level declarations as well. ### Multi-line input GHCi supports commands which span multiple lines, and the same syntax works for doctest: ```haskell -- | -- >>> :{ -- let -- x = 1 -- y = 2 -- in x + y + multiline -- :} -- 6 multiline = 3 ``` Note that `>>>` can be left off for the lines following the first: this is so that haddock does not strip leading whitespace. The expected output has whitespace stripped relative to the :}. Some peculiarities on the ghci side mean that whitespace at the very start is lost. This breaks the example `broken`, since the the x and y are aligned from ghci's perspective. A workaround is to avoid leading space, or add a newline such that the indentation does not matter: ```haskell {- | >>> :{ let x = 1 y = 2 in x + y + works :} 6 -} works = 3 {- | >>> :{ let x = 1 y = 2 in x + y + broken :} 3 -} broken = 3 ``` ### Multi-line output If there are no blank lines in the output, multiple lines are handled automatically. ```haskell -- | >>> putStr "Hello\nWorld!" -- Hello -- World! ``` If however the output contains blank lines, they must be noted explicitly with ``. For example, ```haskell import Data.List ( intercalate ) -- | Double-space a paragraph. -- -- Examples: -- -- >>> let s1 = "\"Every one of whom?\"" -- >>> let s2 = "\"Every one of whom do you think?\"" -- >>> let s3 = "\"I haven't any idea.\"" -- >>> let paragraph = unlines [s1,s2,s3] -- >>> putStrLn $ doubleSpace paragraph -- "Every one of whom?" -- -- "Every one of whom do you think?" -- -- "I haven't any idea." -- doubleSpace :: String -> String doubleSpace = (intercalate "\n\n") . lines ``` ### Matching arbitrary output Any lines containing only three dots (`...`) will match one or more lines with arbitrary content. For instance, ```haskell -- | -- >>> putStrLn "foo\nbar\nbaz" -- foo -- ... -- baz ``` If a line contains three dots and additional content, the three dots will match anything *within that line*: ```haskell -- | -- >>> putStrLn "foo bar baz" -- foo ... baz ``` ### QuickCheck properties Haddock (since version 2.13.0) has markup support for properties. Doctest can verify properties with QuickCheck. A simple property looks like this: ```haskell -- | -- prop> \xs -> sort xs == (sort . sort) (xs :: [Int]) ``` The lambda abstraction is optional and can be omitted: ```haskell -- | -- prop> sort xs == (sort . sort) (xs :: [Int]) ``` A complete example that uses setup code is below: ```haskell module Fib where -- $setup -- >>> import Control.Applicative -- >>> import Test.QuickCheck -- >>> newtype Small = Small Int deriving Show -- >>> instance Arbitrary Small where arbitrary = Small . (`mod` 10) <$> arbitrary -- | Compute Fibonacci numbers -- -- The following property holds: -- -- prop> \(Small n) -> fib n == fib (n + 2) - fib (n + 1) fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) ``` If you see an error like the following, ensure that [QuickCheck](http://hackage.haskell.org/package/QuickCheck) is a dependency of the test-suite or executable running `doctest`. ```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 There's two sets of GHC extensions involved when running Doctest: 1. The set of GHC extensions that are active when compiling the module code (excluding the doctest examples). The easiest way to specify these extensions is through [LANGUAGE pragmas] [language-pragma] in your source files. (Doctest will not look at your cabal file.) 2. The set of GHC extensions that are active when executing the Doctest examples. (These are not influenced by the LANGUAGE pragmas in the file.) The recommended way to enable extensions for Doctest examples is to switch them on like this: ```haskell -- | -- >>> :set -XTupleSections -- >>> fst' $ (1,) 2 -- 1 fst' :: (a, b) -> a fst' = fst ``` Alternatively you can pass any GHC options to Doctest, e.g.: doctest -XCPP Foo.hs These options will affect both the loading of the module and the execution of the Doctest examples. If you want to omit the information which language extensions are enabled from the Doctest examples you can use the method described in [Hiding examples from Haddock] (#hiding-examples-from-haddock), e.g.: ```haskell -- $ -- >>> :set -XTupleSections ``` [language-pragma]: http://www.haskell.org/ghc/docs/latest/html/users_guide/pragmas.html#language-pragma ### Cabal integration Doctest provides both, an executable and a library. The library exposes a function `doctest` of type: ```haskell doctest :: [String] -> IO () ``` Doctest's own `main` is simply: ```haskell main = getArgs >>= doctest ``` Consequently, it is possible to create a custom executable for a project, by passing all command-line arguments that are required for that project to `doctest`. A simple example looks like this: ```haskell -- file doctests.hs import Test.DocTest main = doctest ["-isrc", "src/Main.hs"] ``` And a corresponding Cabal test suite section like this: test-suite doctests type: exitcode-stdio-1.0 ghc-options: -threaded main-is: doctests.hs build-depends: base, doctest >= 0.8 ## Doctest in the wild You can find real world examples of `Doctest` being used below: * [base Data/Maybe.hs](https://github.com/ghc/ghc/blob/669cbef03c220de43b0f88f2b2238bf3c02ed64c/libraries/base/Data/Maybe.hs#L36-L79) * [base Data/Functor.hs](https://github.com/ghc/ghc/blob/669cbef03c220de43b0f88f2b2238bf3c02ed64c/libraries/base/Data/Functor.hs#L34-L64) ## Doctest extensions * [doctest-discover](https://github.com/karun012/doctest-discover) ## Development [![Build Status](https://secure.travis-ci.org/sol/doctest.png)](http://travis-ci.org/sol/doctest) Join in at `#hspec` on freenode. Discuss your ideas first, ideally by opening an issue on GitHub. Add tests for new features, and make sure that the test suite passes with your changes. cabal configure --enable-tests && cabal build && cabal exec cabal test ## Contributors * Adam Vogt * Anders Persson * Ankit Ahuja * Edward Kmett * Hiroki Hattori * Joachim Breitner * João Cristóvão * Julian Arni * Kazu Yamamoto * Levent Erkok * Luke Murphy * Matvey Aksenov * Michael Orlitzky * Michael Snoyman * Nick Smallbone * Sakari Jokinen * Simon Hengel * Sönke Hahn doctest-0.16.0.1/LICENSE0000644000000000000000000000206713351740625012610 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-0.16.0.1/CHANGES0000644000000000000000000000572113351740625012576 0ustar0000000000000000Changes in 0.16.0.1 - Bump bounds to allow GHC 8.6. (#210) Changes in 0.16.0 - Output format has changed to (hopefully) be more machine consumable. (#200) Changes in 0.15.0 - Add `--verbose` for printing each test as it is run Changes in 0.14.1 - Add test assets to source tarball (see #189) Changes in 0.14.0 - GHC 8.4 compatibility. Changes in 0.13.0 - Add `--preserve-it` for allowing the `it` variable to be preserved between examples Changes in 0.12.0 - Preserve the 'it' variable between examples Changes in 0.11.4 - Add `--fast`, which disables running `:reload` between example groups Changes in 0.11.3 - Add `--info` - Add `--no-magic` Changes in 0.11.2 - Make `...` match zero lines Changes in 0.11.1 - Fix an issue with Unicode output on Windows (see #149) Changes in 0.11.0 - Support for GHC 8.0.1-rc2 Changes in 0.10.1 - Automatically expand directories into contained Haskell source files (thanks @snoyberg) - Add cabal_macros.h and autogen dir by default (thanks @snoyberg) Changes in 0.10.0 - Support HASKELL_PACKAGE_SANDBOXES (thanks @snoyberg) Changes in 0.9.13 - Add ellipsis as wildcard Changes in 0.9.12 - Add support for GHC 7.10 Changes in 0.9.11 - Defaults ambiguous type variables to Integer (#74) Changes in 0.9.10 - Add support for the upcoming GHC 7.8 release Changes in 0.9.9 - Add support for multi-line statements Changes in 0.9.8 - Support for GHC HEAD (7.7) Changes in 0.9.7 - Ignore trailing whitespace when matching example output Changes in 0.9.6 - Fail gracefully if GHCi is not supported (#46) Changes in 0.9.5 - Fix a GHC panic with GHC 7.6.1 (#41) Changes in 0.9.4 - Respect HASKELL_PACKAGE_SANDBOX (#39) - Print path to ghc on --version Changes in 0.9.3 - Properly handle additional object files (#38) Changes in 0.9.2 - Add support for QuickCheck properties Changes in 0.9.1 - Fix an issue with GHC 7.6.1 and type families Changes in 0.9.0 - Add support for setup code (see README). - There is no distinction between example/interaction anymore. Each expression is counted as an example in the summary. Changes in 0.8.0 - Doctest now directly accepts arbitrary GHC options, prefixing GHC options with --optghc is no longer necessary Changes in 0.7.0 - Print source location for failing tests - Output less clutter on failing examples - Expose Doctest's functionality through a very simplistic API, which can be used for cabal integration Changes in 0.6.1 - Fix a parser bug with CR+LF line endings Changes in 0.6.0 - Support for ghc-7.4 - Doctest now comes with it's own parser and does not depend on Haddock anymore Changes in 0.5.2 - Proper handling of singular/plural when printing stats - Improve handling of invalid command line options Changes in 0.5.1 - Adapted for ghc-7.2 Changes in 0.5.0 - Print number of interactions to stderr before running tests - Exit with exitFailure on failed tests - Improve documentation - Give a useful error message if ghc is not executable doctest-0.16.0.1/test/0000755000000000000000000000000013351740625012555 5ustar0000000000000000doctest-0.16.0.1/test/ExtractSpec.hs0000644000000000000000000000756113351740625015347 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module ExtractSpec (main, spec) where import Test.Hspec import Test.HUnit import Data.WithLocation import Panic (GhcException (..)) import Extract import Location import System.FilePath import Orphans () shouldGive :: WithLocation ((String, String) -> [Module String] -> Assertion) (d, m) `shouldGive` expected = do r <- map (fmap unLoc) `fmap` extract ["-i" ++ dir, dir m] r `shouldBe` expected where dir = "test/extract" d main :: IO () main = hspec spec spec :: Spec spec = do describe "extract" $ do it "extracts documentation for a top-level declaration" $ do ("declaration", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Some documentation"]] it "extracts documentation from argument list" $ do ("argument-list", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" doc for arg1", " doc for arg2"]] it "extracts documentation for a type class function" $ do ("type-class", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Convert given value to a string."]] it "extracts documentation from the argument list of a type class function" $ do ("type-class-args", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" foo", " bar"]] it "extracts documentation from the module header" $ do ("module-header", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Some documentation"]] it "extracts documentation from imported modules" $ do ("imported-module", "Bar.hs") `shouldGive` [Module "Bar" Nothing [" documentation for bar"], Module "Baz" Nothing [" documentation for baz"]] it "extracts documentation from export list" $ do ("export-list", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" documentation from export list"]] it "extracts documentation from named chunks" $ do ("named-chunks", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" named chunk foo", "\n named chunk bar"]] it "returns docstrings in the same order they appear in the source" $ do ("comment-order", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]] it "extracts $setup code" $ do ("setup", "Foo.hs") `shouldGive` [Module "Foo" (Just "\n some setup code") [" foo", " bar", " baz"]] it "fails on invalid flags" $ do extract ["--foobar", "test/Foo.hs"] `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False) describe "extract (regression tests)" $ do it "works with infix operators" $ do ("regression", "Fixity.hs") `shouldGive` [Module "Fixity" Nothing []] it "works with parallel list comprehensions" $ do ("regression", "ParallelListComp.hs") `shouldGive` [Module "ParallelListComp" Nothing []] it "works with list comprehensions in instance definitions" $ do ("regression", "ParallelListCompClass.hs") `shouldGive` [Module "ParallelListCompClass" Nothing []] it "works with foreign imports" $ do ("regression", "ForeignImport.hs") `shouldGive` [Module "ForeignImport" Nothing []] it "works for rewrite rules" $ do ("regression", "RewriteRules.hs") `shouldGive` [Module "RewriteRules" Nothing [" doc for foo"]] it "works for rewrite rules with type signatures" $ do ("regression", "RewriteRulesWithSigs.hs") `shouldGive` [Module "RewriteRulesWithSigs" Nothing [" doc for foo"]] it "strips CR from dos line endings" $ do ("dos-line-endings", "Foo.hs") `shouldGive` [Module "Foo" Nothing ["\n foo\n bar\n baz"]] it "works with a module that splices in an expression from an other module" $ do ("th", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" some documentation"], Module "Bar" Nothing []] it "works for type families and GHC 7.6.1" $ do ("type-families", "Foo.hs") `shouldGive` [Module "Foo" Nothing []] doctest-0.16.0.1/test/RunnerSpec.hs0000644000000000000000000000452413351740625015202 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings #-} module RunnerSpec (main, spec) where import Test.Hspec #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import System.IO import System.IO.Silently (hCapture) import Control.Monad.Trans.State import Runner main :: IO () main = hspec spec capture :: Report a -> IO String capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 True False mempty) -- like capture, but with interactivity set to False capture_ :: Report a -> IO String capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 False False mempty) spec :: Spec spec = do describe "report" $ do context "when mode is interactive" $ do it "writes to stderr" $ do capture $ do report "foobar" `shouldReturn` "foobar\n" it "overwrites any intermediate output" $ do capture $ do report_ "foo" report "bar" `shouldReturn` "foo\rbar\n" it "blank out intermediate output if necessary" $ do capture $ do report_ "foobar" report "baz" `shouldReturn` "foobar\rbaz \n" context "when mode is non-interactive" $ do it "writes to stderr" $ do capture_ $ do report "foobar" `shouldReturn` "foobar\n" describe "report_" $ do context "when mode is interactive" $ do it "writes intermediate output to stderr" $ do capture $ do report_ "foobar" `shouldReturn` "foobar" it "overwrites any intermediate output" $ do capture $ do report_ "foo" report_ "bar" `shouldReturn` "foo\rbar" it "blank out intermediate output if necessary" $ do capture $ do report_ "foobar" report_ "baz" `shouldReturn` "foobar\rbaz " context "when mode is non-interactive" $ do it "is ignored" $ do capture_ $ do report_ "foobar" `shouldReturn` "" it "does not influence a subsequent call to `report`" $ do capture_ $ do report_ "foo" report "bar" `shouldReturn` "bar\n" it "does not require `report` to blank out any intermediate output" $ do capture_ $ do report_ "foobar" report "baz" `shouldReturn` "baz\n" doctest-0.16.0.1/test/PropertySpec.hs0000644000000000000000000001241613351740625015554 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings #-} module PropertySpec (main, spec) where import Test.Hspec import Data.String.Builder import Property import Interpreter (withInterpreter) main :: IO () main = hspec spec isFailure :: PropertyResult -> Bool isFailure (Failure _) = True isFailure _ = False spec :: Spec spec = do describe "runProperty" $ do it "reports a failing property" $ withInterpreter [] $ \repl -> do runProperty repl "False" `shouldReturn` Failure "*** Failed! Falsifiable (after 1 test):" it "runs a Bool property" $ withInterpreter [] $ \repl -> do runProperty repl "True" `shouldReturn` Success it "runs a Bool property with an explicit type signature" $ withInterpreter [] $ \repl -> do runProperty repl "True :: Bool" `shouldReturn` Success it "runs an implicitly quantified property" $ withInterpreter [] $ \repl -> do runProperty repl "(reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success it "runs an implicitly quantified property even with GHC 7.4" $ #if __GLASGOW_HASKELL__ == 702 pendingWith "This triggers a bug in GHC 7.2.*." -- try e.g. -- >>> 23 -- >>> :t is #else -- ghc will include a suggestion (did you mean `id` instead of `is`) in -- the error message withInterpreter [] $ \repl -> do runProperty repl "foldr (+) 0 is == sum (is :: [Int])" `shouldReturn` Success #endif it "runs an explicitly quantified property" $ withInterpreter [] $ \repl -> do runProperty repl "\\xs -> (reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success it "allows to mix implicit and explicit quantification" $ withInterpreter [] $ \repl -> do runProperty repl "\\x -> x + y == y + x" `shouldReturn` Success it "reports the value for which a property fails" $ withInterpreter [] $ \repl -> do runProperty repl "x == 23" `shouldReturn` Failure "*** Failed! Falsifiable (after 1 test):\n0" it "reports the values for which a property that takes multiple arguments fails" $ withInterpreter [] $ \repl -> do let vals x = case x of (Failure r) -> tail (lines r); _ -> error "Property did not fail!" vals `fmap` runProperty repl "x == True && y == 10 && z == \"foo\"" `shouldReturn` ["False", "0", show ("" :: String)] it "defaults ambiguous type variables to Integer" $ withInterpreter [] $ \repl -> do runProperty repl "reverse xs == xs" >>= (`shouldSatisfy` isFailure) describe "freeVariables" $ do it "finds a free variables in a term" $ withInterpreter [] $ \repl -> do freeVariables repl "x" `shouldReturn` ["x"] it "ignores duplicates" $ withInterpreter [] $ \repl -> do freeVariables repl "x == x" `shouldReturn` ["x"] it "works for terms with multiple names" $ withInterpreter [] $ \repl -> do freeVariables repl "\\z -> x + y + z == foo 23" `shouldReturn` ["x", "y", "foo"] it "works for names that contain a prime" $ withInterpreter [] $ \repl -> do freeVariables repl "x' == y''" `shouldReturn` ["x'", "y''"] it "works for names that are similar to other names that are in scope" $ withInterpreter [] $ \repl -> do freeVariables repl "length_" `shouldReturn` ["length_"] describe "parseNotInScope" $ do context "when error message was produced by GHC 7.4.1" $ do it "extracts a variable name of variable that is not in scope from an error message" $ do parseNotInScope . build $ do ":4:1: Not in scope: `x'" `shouldBe` ["x"] it "ignores duplicates" $ do parseNotInScope . build $ do ":4:1: Not in scope: `x'" "" ":4:6: Not in scope: `x'" `shouldBe` ["x"] it "works for variable names that contain a prime" $ do parseNotInScope . build $ do ":2:1: Not in scope: x'" "" ":2:7: Not in scope: y'" `shouldBe` ["x'", "y'"] it "works for error messages with suggestions" $ do parseNotInScope . build $ do ":1:1:" " Not in scope: `is'" " Perhaps you meant `id' (imported from Prelude)" `shouldBe` ["is"] context "when error message was produced by GHC 8.0.1" $ do it "extracts a variable name of variable that is not in scope from an error message" $ do parseNotInScope . build $ do ":1:1: error: Variable not in scope: x" `shouldBe` ["x"] it "ignores duplicates" $ do parseNotInScope . build $ do ":1:1: error: Variable not in scope: x :: ()" "" ":1:6: error: Variable not in scope: x :: ()" `shouldBe` ["x"] it "works for variable names that contain a prime" $ do parseNotInScope . build $ do ":1:1: error: Variable not in scope: x' :: ()" "" ":1:7: error: Variable not in scope: y'' :: ()" `shouldBe` ["x'", "y''"] it "works for error messages with suggestions" $ do parseNotInScope . build $ do ":1:1: error:" " • Variable not in scope: length_" " • Perhaps you meant ‘length’ (imported from Prelude)" `shouldBe` ["length_"] doctest-0.16.0.1/test/MainSpec.hs0000644000000000000000000001217513351740625014616 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module MainSpec (main, spec) where import Test.Hspec import Test.HUnit (assertEqual, Assertion) import Data.WithLocation import Control.Exception import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.FilePath import Options import Runner (Summary(..)) import Run hiding (doctest) import System.IO.Silently import System.IO withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory workingDir action = do bracket getCurrentDirectory setCurrentDirectory $ \_ -> do setCurrentDirectory workingDir action -- | Construct a doctest specific 'Assertion'. doctest :: WithLocation (FilePath -> [String] -> Summary -> Assertion) doctest = doctestWithPreserveIt defaultPreserveIt doctestWithPreserveIt :: WithLocation (Bool -> FilePath -> [String] -> Summary -> Assertion) doctestWithPreserveIt preserveIt workingDir args expected = do actual <- withCurrentDirectory ("test/integration" workingDir) (hSilence [stderr] $ doctestWithOptions defaultFastMode preserveIt defaultVerbose args) assertEqual label expected actual where label = workingDir ++ " " ++ show args cases :: Int -> Summary cases n = Summary n n 0 0 main :: IO () main = hspec spec spec :: Spec spec = do describe "doctest" $ do it "testSimple" $ do doctest "." ["testSimple/Fib.hs"] (cases 1) it "it-variable" $ do doctestWithPreserveIt True "." ["it/Foo.hs"] (cases 5) it "it-variable in $setup" $ do doctestWithPreserveIt True "." ["it/Setup.hs"] (cases 5) it "failing" $ do doctest "." ["failing/Foo.hs"] (cases 1) {sFailures = 1} it "skips subsequent examples from the same group if an example fails" $ doctest "." ["failing-multiple/Foo.hs"] (cases 4) {sTried = 2, sFailures = 1} it "testImport" $ do doctest "testImport" ["ModuleA.hs"] (cases 3) doctest ".." ["-iintegration/testImport", "integration/testImport/ModuleA.hs"] (cases 3) it "testCommentLocation" $ do doctest "." ["testCommentLocation/Foo.hs"] (cases 11) it "testPutStr" $ do doctest "testPutStr" ["Fib.hs"] (cases 3) it "fails on multi-line expressions, introduced with :{" $ do doctest "testFailOnMultiline" ["Fib.hs"] (cases 2) {sErrors = 2} it "testBlankline" $ do doctest "testBlankline" ["Fib.hs"] (cases 1) it "examples from the same Haddock comment share the same scope" $ do doctest "testCombinedExample" ["Fib.hs"] (cases 4) it "testDocumentationForArguments" $ do doctest "testDocumentationForArguments" ["Fib.hs"] (cases 1) it "template-haskell" $ do doctest "template-haskell" ["Foo.hs"] (cases 2) it "handles source files with CRLF line endings" $ do doctest "dos-line-endings" ["Fib.hs"] (cases 1) it "runs $setup before each test group" $ do doctest "setup" ["Foo.hs"] (cases 2) it "skips subsequent tests from a module, if $setup fails" $ do doctest "setup-skip-on-failure" ["Foo.hs"] (cases 3) {sTried = 1, sFailures = 1} it "works with additional object files" $ do doctest "with-cbits" ["Bar.hs", "../../../dist/build/spec/spec-tmp/test/integration/with-cbits/foo.o"] (cases 1) it "ignores trailing whitespace when matching test output" $ do doctest "trailing-whitespace" ["Foo.hs"] (cases 1) describe "doctest as a runner for QuickCheck properties" $ do it "runs a boolean property" $ do doctest "property-bool" ["Foo.hs"] (cases 1) it "runs an explicitly quantified property" $ do doctest "property-quantified" ["Foo.hs"] (cases 1) it "runs an implicitly quantified property" $ do doctest "property-implicitly-quantified" ["Foo.hs"] (cases 1) it "reports a failing property" $ do doctest "property-failing" ["Foo.hs"] (cases 1) {sFailures = 1} it "runs a boolean property with an explicit type signature" $ do doctest "property-bool-with-type-signature" ["Foo.hs"] (cases 1) it "runs $setup before each property" $ do doctest "property-setup" ["Foo.hs"] (cases 3) describe "doctest (regression tests)" $ do it "bugfixWorkingDirectory" $ do doctest "bugfixWorkingDirectory" ["Fib.hs"] (cases 1) doctest "bugfixWorkingDirectory" ["examples/Fib.hs"] (cases 2) it "bugfixOutputToStdErr" $ do doctest "bugfixOutputToStdErr" ["Fib.hs"] (cases 2) it "bugfixImportHierarchical" $ do doctest "bugfixImportHierarchical" ["ModuleA.hs", "ModuleB.hs"] (cases 3) it "bugfixMultipleModules" $ do doctest "bugfixMultipleModules" ["ModuleA.hs"] (cases 5) it "testCPP" $ do doctest "testCPP" ["-cpp", "Foo.hs"] (cases 1) {sFailures = 1} doctest "testCPP" ["-cpp", "-DFOO", "Foo.hs"] (cases 1) it "template-haskell-bugfix" $ do doctest "template-haskell-bugfix" ["Main.hs"] (cases 2) doctest-0.16.0.1/test/PackageDBsSpec.hs0000644000000000000000000000543513351740625015657 0ustar0000000000000000module PackageDBsSpec (main, spec) where import Prelude () import Prelude.Compat import qualified Control.Exception as E import Data.List (intercalate) import PackageDBs import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Environment.Compat import System.FilePath (searchPathSeparator) import Test.Hspec import Test.Mockery.Directory main :: IO () main = hspec spec withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory workingDir action = do E.bracket getCurrentDirectory setCurrentDirectory $ \_ -> do setCurrentDirectory workingDir action withEnv :: String -> String -> IO a -> IO a withEnv k v action = E.bracket save restore $ \_ -> do setEnv k v >> action where save = lookup k <$> getEnvironment restore = maybe (unsetEnv k) (setEnv k) clearEnv :: IO a -> IO a clearEnv = withEnv "GHC_PACKAGE_PATH" "" . withEnv "HASKELL_PACKAGE_SANDBOX" "" . withEnv "HASKELL_PACKAGE_SANDBOXES" "" combineDirs :: [FilePath] -> String combineDirs = intercalate [searchPathSeparator] spec :: Spec spec = around_ clearEnv $ do describe "getPackageDBsFromEnv" $ do context "without a cabal sandbox present" $ do around_ (inTempDirectory) $ do it "uses global and user when no env or sandboxing used" $ do getPackageDBsFromEnv `shouldReturn` PackageDBs True True [] it "respects GHC_PACKAGE_PATH" $ withEnv "GHC_PACKAGE_PATH" (combineDirs ["foo", "bar", ""]) $ do getPackageDBsFromEnv `shouldReturn` PackageDBs False True ["foo", "bar"] it "HASKELL_PACKAGE_SANDBOXES trumps GHC_PACKAGE_PATH" $ withEnv "GHC_PACKAGE_PATH" (combineDirs ["foo1", "bar1", ""]) $ do withEnv "HASKELL_PACKAGE_SANDBOXES" (combineDirs ["foo2", "bar2", ""]) $ do getPackageDBsFromEnv `shouldReturn` PackageDBs False True ["foo2", "bar2"] it "HASKELL_PACKAGE_SANDBOX trumps GHC_PACKAGE_PATH" $ withEnv "GHC_PACKAGE_PATH" (combineDirs ["foo1", "bar1", ""]) $ do withEnv "HASKELL_PACKAGE_SANDBOX" (combineDirs ["foo2"]) $ do getPackageDBsFromEnv `shouldReturn` PackageDBs True True ["foo2"] context "with a cabal sandbox present" $ do around_ (withCurrentDirectory "test/sandbox") $ do it "respects cabal sandboxes" $ do getPackageDBsFromEnv `shouldReturn` PackageDBs False True ["/home/me/doctest-haskell/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] it "GHC_PACKAGE_PATH takes precedence" $ withEnv "GHC_PACKAGE_PATH" (combineDirs ["foo", "bar"]) $ do getPackageDBsFromEnv `shouldReturn` PackageDBs False False ["foo", "bar"] doctest-0.16.0.1/test/doctests.hs0000644000000000000000000000042213351740625014737 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest [ "-packageghc" , "-isrc" , "-ighci-wrapper/src" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h" , "src/Run.hs" , "src/PackageDBs.hs" ] doctest-0.16.0.1/test/InterpreterSpec.hs0000644000000000000000000000202313351740625016224 0ustar0000000000000000module InterpreterSpec (main, spec) where import Prelude () import Prelude.Compat import Test.Hspec import Interpreter (interpreterSupported, haveInterpreterKey, ghcInfo, withInterpreter, safeEval) main :: IO () main = hspec spec spec :: Spec spec = do describe "interpreterSupported" $ do it "indicates whether GHCi is supported on current platform" $ do (Interpreter.interpreterSupported >> return ()) `shouldReturn` () describe "ghcInfo" $ do it ("includes " ++ show haveInterpreterKey) $ do info <- ghcInfo lookup haveInterpreterKey info `shouldSatisfy` (||) <$> (== Just "YES") <*> (== Just "NO") describe "safeEval" $ do it "evaluates an expression" $ withInterpreter [] $ \ghci -> do Interpreter.safeEval ghci "23 + 42" `shouldReturn` Right "65\n" it "returns Left on unterminated multiline command" $ withInterpreter [] $ \ghci -> do Interpreter.safeEval ghci ":{\n23 + 42" `shouldReturn` Left "unterminated multiline command" doctest-0.16.0.1/test/RunSpec.hs0000644000000000000000000001445213351740625014476 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 #if __GLASGOW_HASKELL__ < 707 import System.Cmd #else import System.Process #endif import System.Directory (getCurrentDirectory, setCurrentDirectory, removeDirectoryRecursive) import Data.List.Compat import System.Environment.Compat import System.IO.Silently import System.IO (stderr) import qualified Options import Run doctestWithDefaultOptions :: [String] -> IO Summary doctestWithDefaultOptions = doctestWithOptions Options.defaultFastMode Options.defaultPreserveIt Options.defaultVerbose withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory workingDir action = do E.bracket getCurrentDirectory setCurrentDirectory $ \_ -> do setCurrentDirectory workingDir action rmDir :: FilePath -> IO () rmDir dir = removeDirectoryRecursive dir `E.catch` (const $ return () :: E.IOException -> IO ()) withEnv :: String -> String -> IO a -> IO a withEnv k v action = E.bracket save restore $ \_ -> do setEnv k v >> action where save = lookup k <$> getEnvironment restore = maybe (unsetEnv k) (setEnv k) 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 ["test/integration/failing/Foo.hs"]) `shouldThrow` (== ExitFailure 1) it "prints help on --help" $ do (r, ()) <- capture (doctest ["--help"]) r `shouldBe` Options.usage it "prints version on --version" $ do (r, ()) <- capture (doctest ["--version"]) lines r `shouldSatisfy` any (isPrefixOf "doctest version ") it "accepts arbitrary GHC options" $ do hSilence [stderr] $ doctest ["-cpp", "-DFOO", "test/integration/test-options/Foo.hs"] it "accepts GHC options with --optghc" $ do hSilence [stderr] $ doctest ["--optghc=-cpp", "--optghc=-DFOO", "test/integration/test-options/Foo.hs"] it "prints a deprecation message for --optghc" $ do (r, _) <- hCapture [stderr] $ doctest ["--optghc=-cpp", "--optghc=-DFOO", "test/integration/test-options/Foo.hs"] lines r `shouldSatisfy` isPrefixOf [ "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options" , "directly." ] it "prints error message on invalid option" $ do (r, e) <- hCapture [stderr] . E.try $ doctest ["--foo", "test/integration/test-options/Foo.hs"] e `shouldBe` Left (ExitFailure 1) r `shouldBe` unlines [ "doctest: unrecognized option `--foo'" , "Try `doctest --help' for more information." ] it "respects HASKELL_PACKAGE_SANDBOX" $ do withCurrentDirectory "test/integration/custom-package-conf/foo" $ do ExitSuccess <- rawSystem "ghc-pkg" ["init", "../packages"] ExitSuccess <- rawSystem "cabal" ["configure", "--disable-optimization", "--disable-library-profiling", "--package-db=../packages"] ExitSuccess <- rawSystem "cabal" ["build"] ExitSuccess <- rawSystem "cabal" ["register", "--inplace"] return () withEnv "HASKELL_PACKAGE_SANDBOX" "test/integration/custom-package-conf/packages" $ do hCapture_ [stderr] (doctest ["test/integration/custom-package-conf/Bar.hs"]) `shouldReturn` "Examples: 2 Tried: 2 Errors: 0 Failures: 0\n" `E.finally` do rmDir "test/integration/custom-package-conf/packages/" rmDir "test/integration/custom-package-conf/foo/dist/" it "prints verbose description of a specification" $ do (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "test/integration/testSimple/Fib.hs"] r `shouldBe` unlines [ "### Started execution at test/integration/testSimple/Fib.hs:5." , "### example:" , "fib 10" , "### Successful!" , "" , "# Final summary:" , "Examples: 1 Tried: 1 Errors: 0 Failures: 0" ] it "prints verbose description of a property" $ do (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "test/integration/property-bool/Foo.hs"] r `shouldBe` unlines [ "### Started execution at test/integration/property-bool/Foo.hs:4." , "### property:" , "True" , "### Successful!" , "" , "# Final summary:" , "Examples: 1 Tried: 1 Errors: 0 Failures: 0" ] it "prints verbose error" $ do (r, e) <- hCapture [stderr] . E.try $ doctest ["--verbose", "test/integration/failing/Foo.hs"] e `shouldBe` Left (ExitFailure 1) r `shouldBe` unlines [ "### Started execution at test/integration/failing/Foo.hs:5." , "### example:" , "23" , "test/integration/failing/Foo.hs:5: failure in expression `23'" , "expected: 42" , " but got: 23" , "" , "# Final summary:" , "Examples: 1 Tried: 1 Errors: 0 Failures: 1" ] describe "doctestWithOptions" $ do context "on parse error" $ do let action = withCurrentDirectory "test/integration/parse-error" (doctestWithDefaultOptions ["Foo.hs"]) it "aborts with (ExitFailure 1)" $ do hSilence [stderr] action `shouldThrow` (== ExitFailure 1) it "prints a useful error message" $ do (r, _) <- hCapture [stderr] (E.try action :: IO (Either ExitCode Summary)) #if __GLASGOW_HASKELL__ < 706 r `shouldBe` "\nFoo.hs:6:1: parse error (possibly incorrect indentation)\n" #else #if __GLASGOW_HASKELL__ < 800 r `shouldBe` "\nFoo.hs:6:1:\n parse error (possibly incorrect indentation or mismatched brackets)\n" #else r `shouldBe` "\nFoo.hs:6:1: error:\n parse error (possibly incorrect indentation or mismatched brackets)\n" #endif #endif describe "expandDirs" $ do it "expands a directory" $ do res <- expandDirs "example" sort res `shouldBe` [ "example/src/Example.hs" , "example/test/doctests.hs" ] it "ignores files" $ do res <- expandDirs "doctest.cabal" res `shouldBe` ["doctest.cabal"] it "ignores random things" $ do let x = "foo bar baz bin" res <- expandDirs x res `shouldBe` [x] doctest-0.16.0.1/test/LocationSpec.hs0000644000000000000000000000257013351740625015500 0ustar0000000000000000module LocationSpec (main, spec) where import Test.Hspec import Location import SrcLoc import FastString (fsLit) 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-0.16.0.1/test/ParseSpec.hs0000644000000000000000000001342313351740625015001 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 Parse import Location import Orphans () 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-0.16.0.1/test/Orphans.hs0000644000000000000000000000077513351740625014534 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Orphans where import Parse import Location -- The generic form -- -- > deriving instance Show a => Show (Module a) -- -- fails with GHC 7.0.1 due to an overlapping instance (leaked by the GHC API), -- this is why we derive the things we need individually. deriving instance Show (Module String) deriving instance Show (Module [DocTest]) deriving instance Show (Module [Located DocTest]) doctest-0.16.0.1/test/Spec.hs0000644000000000000000000000005413351740625014002 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} doctest-0.16.0.1/test/UtilSpec.hs0000644000000000000000000000105113351740625014636 0ustar0000000000000000module UtilSpec (main, spec) where import Test.Hspec import Util main :: IO () main = hspec spec spec :: Spec spec = do describe "convertDosLineEndings" $ do it "converts CRLF to LF" $ do convertDosLineEndings "foo\r\nbar\r\nbaz" `shouldBe` "foo\nbar\nbaz" it "strips a trailing CR" $ do convertDosLineEndings "foo\r" `shouldBe` "foo" describe "takeWhileEnd" $ do it "returns the longest suffix of elements that satisfy a given predicate" $ do takeWhileEnd (/= ' ') "foo bar" `shouldBe` "bar" doctest-0.16.0.1/test/OptionsSpec.hs0000644000000000000000000000500713351740625015361 0ustar0000000000000000module OptionsSpec (spec) where import Prelude () import Prelude.Compat import Test.Hspec import Test.QuickCheck import Options spec :: Spec spec = do describe "parseOptions" $ do let warning = ["WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."] it "strips --optghc" $ property $ \xs ys -> parseOptions (xs ++ ["--optghc", "foobar"] ++ ys) `shouldBe` Result (Run warning (xs ++ ["foobar"] ++ ys) defaultMagic defaultFastMode defaultPreserveIt defaultVerbose) it "strips --optghc=" $ property $ \xs ys -> parseOptions (xs ++ ["--optghc=foobar"] ++ ys) `shouldBe` Result (Run warning (xs ++ ["foobar"] ++ ys) defaultMagic defaultFastMode defaultPreserveIt defaultVerbose) describe "--no-magic" $ do context "without --no-magic" $ do it "enables magic mode" $ do runMagicMode <$> parseOptions [] `shouldBe` Result True context "with --no-magic" $ do it "disables magic mode" $ do runMagicMode <$> parseOptions ["--no-magic"] `shouldBe` Result False describe "--fast" $ do context "without --fast" $ do it "disables fast mode" $ do runFastMode <$> parseOptions [] `shouldBe` Result False context "with --fast" $ do it "enabled fast mode" $ do runFastMode <$> parseOptions ["--fast"] `shouldBe` Result True describe "--preserve-it" $ do context "without --preserve-it" $ do it "does not preserve the `it` variable" $ do runPreserveIt <$> parseOptions [] `shouldBe` Result False context "with --preserve-it" $ do it "preserves the `it` variable" $ do runPreserveIt <$> parseOptions ["--preserve-it"] `shouldBe` Result True context "with --help" $ do it "outputs usage information" $ do parseOptions ["--help"] `shouldBe` Output usage context "with --version" $ do it "outputs version information" $ do parseOptions ["--version"] `shouldBe` Output versionInfo context "with --info" $ do it "outputs machine readable version information" $ do parseOptions ["--info"] `shouldBe` Output info describe "--verbose" $ do context "without --verbose" $ do it "is not verbose by default" $ do runVerbose <$> parseOptions [] `shouldBe` Result False context "with --verbose" $ do it "parses verbose option" $ do runVerbose <$> parseOptions ["--verbose"] `shouldBe` Result True doctest-0.16.0.1/test/SandboxSpec.hs0000644000000000000000000000077613351740625015334 0ustar0000000000000000module SandboxSpec where import Test.Hspec import Sandbox main :: IO () main = hspec spec spec :: Spec spec = do describe "getPackageDbDir" $ do it "parses a config file and extracts package db" $ do pkgDb <- getPackageDbDir "test/sandbox/cabal.sandbox.config" pkgDb `shouldBe` "/home/me/doctest-haskell/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" it "throws an error if a config file is broken" $ do getPackageDbDir "test/sandbox/bad.config" `shouldThrow` anyException doctest-0.16.0.1/test/Runner/0000755000000000000000000000000013351740625014026 5ustar0000000000000000doctest-0.16.0.1/test/Runner/ExampleSpec.hs0000644000000000000000000000523113351740625016571 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Runner.ExampleSpec (main, spec) where import Prelude () import Prelude.Compat import Data.String import Test.Hspec import Test.QuickCheck import Parse import Runner.Example main :: IO () main = hspec spec data Line = PlainLine String | WildCardLines [String] deriving (Show, Eq) instance Arbitrary Line where arbitrary = frequency [ (2, PlainLine <$> arbitrary) , (1, WildCardLines . getNonEmpty <$> arbitrary) ] lineToExpected :: [Line] -> ExpectedResult lineToExpected = map $ \x -> case x of PlainLine str -> fromString str WildCardLines _ -> WildCardLine lineToActual :: [Line] -> [String] lineToActual = concatMap $ \x -> case x of PlainLine str -> [str] WildCardLines xs -> xs spec :: Spec spec = do describe "mkResult" $ do it "returns Equal when output matches" $ do property $ \xs -> do mkResult (map fromString xs) xs `shouldBe` Equal it "ignores trailing whitespace" $ do mkResult ["foo\t"] ["foo "] `shouldBe` Equal context "with WildCardLine" $ do it "matches zero lines" $ do mkResult ["foo", WildCardLine, "bar"] ["foo", "bar"] `shouldBe` Equal it "matches an arbitrary number of lines" $ do mkResult ["foo", WildCardLine, "bar"] ["foo", "baz", "bazoom", "bar"] `shouldBe` Equal 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 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\"" ] doctest-0.16.0.1/test/sandbox/0000755000000000000000000000000013351740625014213 5ustar0000000000000000doctest-0.16.0.1/test/sandbox/bad.config0000644000000000000000000000000613351740625016124 0ustar0000000000000000brokendoctest-0.16.0.1/test/sandbox/cabal.sandbox.config0000644000000000000000000000166113351740625020105 0ustar0000000000000000-- This is a Cabal package environment file. -- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. -- Please create a 'cabal.config' file in the same directory -- if you want to change the default settings for this sandbox. local-repo: /home/me/doctest-haskell/.cabal-sandbox/packages logs-dir: /home/me/doctest-haskell/.cabal-sandbox/logs world-file: /home/me/doctest-haskell/.cabal-sandbox/world user-install: False package-db: /home/me/doctest-haskell/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d build-summary: /home/me/doctest-haskell/.cabal-sandbox/logs/build.log install-dirs prefix: /home/me/doctest-haskell/.cabal-sandbox bindir: $prefix/bin libdir: $prefix/lib libsubdir: $arch-$os-$compiler/$pkgid libexecdir: $prefix/libexec datadir: $prefix/share datasubdir: $arch-$os-$compiler/$pkgid docdir: $datadir/doc/$arch-$os-$compiler/$pkgid htmldir: $docdir/html haddockdir: $htmldir sysconfdir: $prefix/etc doctest-0.16.0.1/test/integration/0000755000000000000000000000000013351740625015100 5ustar0000000000000000doctest-0.16.0.1/test/integration/template-haskell/0000755000000000000000000000000013351740625020334 5ustar0000000000000000doctest-0.16.0.1/test/integration/template-haskell/Foo.hs0000644000000000000000000000061413351740625021414 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Foo where import Language.Haskell.TH import Text.Printf -- | Report an error. -- -- >>> :set -XTemplateHaskell -- >>> $(logError "Something bad happened!") -- ERROR : Something bad happened! logError :: String -> Q Exp logError msg = do loc <- location let s = (printf "ERROR %s: %s" (loc_filename loc) msg) :: String [| putStrLn s |] doctest-0.16.0.1/test/integration/property-failing/0000755000000000000000000000000013351740625020373 5ustar0000000000000000doctest-0.16.0.1/test/integration/property-failing/Foo.hs0000644000000000000000000000007313351740625021452 0ustar0000000000000000module Foo where -- | -- prop> abs x == x foo = undefined doctest-0.16.0.1/test/integration/testPutStr/0000755000000000000000000000000013351740625017241 5ustar0000000000000000doctest-0.16.0.1/test/integration/testPutStr/Fib.hs0000644000000000000000000000032113351740625020271 0ustar0000000000000000module 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-0.16.0.1/test/integration/it/0000755000000000000000000000000013351740625015514 5ustar0000000000000000doctest-0.16.0.1/test/integration/it/Setup.hs0000644000000000000000000000031013351740625017142 0ustar0000000000000000module Setup where -- $setup -- >>> :t 'a' -- 'a' :: Char -- -- >>> 42 :: Int -- 42 -- -- >>> it -- 42 -- | -- -- >>> it * it -- 1764 foo = undefined -- | -- -- >>> it * it -- 1764 bar = undefined doctest-0.16.0.1/test/integration/it/Foo.hs0000644000000000000000000000026013351740625016571 0ustar0000000000000000module Foo where -- | -- -- >>> :t 'a' -- 'a' :: Char -- -- >>> "foo" -- "foo" -- -- >>> length it -- 3 -- -- >>> it * it -- 9 -- -- >>> :t it -- it :: Int -- foo = undefined doctest-0.16.0.1/test/integration/testBlankline/0000755000000000000000000000000013351740625017677 5ustar0000000000000000doctest-0.16.0.1/test/integration/testBlankline/Fib.hs0000644000000000000000000000026313351740625020734 0ustar0000000000000000module Fib where -- | Calculate Fibonacci number of given 'Num'. -- -- >>> putStrLn "foo\n\nbar" -- foo -- -- bar fib :: (Num t, Num t1) => t -> t1 fib _ = undefined doctest-0.16.0.1/test/integration/failing/0000755000000000000000000000000013351740625016511 5ustar0000000000000000doctest-0.16.0.1/test/integration/failing/Foo.hs0000644000000000000000000000012713351740625017570 0ustar0000000000000000module Foo where -- | A failing example -- -- >>> 23 -- 42 test :: a test = undefined doctest-0.16.0.1/test/integration/property-implicitly-quantified/0000755000000000000000000000000013351740625023270 5ustar0000000000000000doctest-0.16.0.1/test/integration/property-implicitly-quantified/Foo.hs0000644000000000000000000000010513351740625024343 0ustar0000000000000000module Foo where -- | -- prop> abs x == abs (abs x) foo = undefined doctest-0.16.0.1/test/integration/testImport/0000755000000000000000000000000013351740625017252 5ustar0000000000000000doctest-0.16.0.1/test/integration/testImport/ModuleB.hs0000644000000000000000000000023013351740625021130 0ustar0000000000000000module 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-0.16.0.1/test/integration/testImport/ModuleA.hs0000644000000000000000000000007613351740625021137 0ustar0000000000000000-- | -- >>> fib 10 -- 55 module ModuleA where import ModuleB doctest-0.16.0.1/test/integration/parse-error/0000755000000000000000000000000013351740625017341 5ustar0000000000000000doctest-0.16.0.1/test/integration/parse-error/Foo.hs0000644000000000000000000000007313351740625020420 0ustar0000000000000000module Foo where -- | Some documentation foo :: Int foo = doctest-0.16.0.1/test/integration/property-quantified/0000755000000000000000000000000013351740625021113 5ustar0000000000000000doctest-0.16.0.1/test/integration/property-quantified/Foo.hs0000644000000000000000000000011313351740625022165 0ustar0000000000000000module Foo where -- | -- prop> \x -> abs x == abs (abs x) foo = undefined doctest-0.16.0.1/test/integration/testDocumentationForArguments/0000755000000000000000000000000013351740625023146 5ustar0000000000000000doctest-0.16.0.1/test/integration/testDocumentationForArguments/Fib.hs0000644000000000000000000000014613351740625024203 0ustar0000000000000000module Fib where fib :: Int -- ^ -- >>> 23 -- 23 -> Int fib _ = undefined doctest-0.16.0.1/test/integration/property-setup/0000755000000000000000000000000013351740625020122 5ustar0000000000000000doctest-0.16.0.1/test/integration/property-setup/Foo.hs0000644000000000000000000000024513351740625021202 0ustar0000000000000000module Foo where -- $setup -- >>> import Test.QuickCheck -- >>> let arbitraryEven = (* 2) `fmap` arbitrary -- | -- prop> forAll arbitraryEven even foo = undefined doctest-0.16.0.1/test/integration/testCommentLocation/0000755000000000000000000000000013351740625021073 5ustar0000000000000000doctest-0.16.0.1/test/integration/testCommentLocation/Foo.hs0000644000000000000000000000260313351740625022153 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 Foo ( -- | Some documentation not attached to a particular Haskell entity -- -- >>> test 10 -- *** Exception: Prelude.undefined -- ... test, -- | -- >>> fib 10 -- 55 fib, -- | -- >>> bar -- "bar" bar ) where -- | My test -- -- >>> test 20 -- *** Exception: Prelude.undefined -- ... test :: Integer -> Integer test = undefined -- | Note that examples for 'fib' include the two examples below -- and the one example with ^ syntax after 'fix' -- -- >>> foo -- "foo" {- | Example: >>> fib 10 55 -} -- | Calculate Fibonacci number of given `n`. fib :: Integer -- ^ given `n` -- -- >>> fib 10 -- 55 -> Integer -- ^ Fibonacci of given `n` -- -- >>> baz -- "foobar" fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) -- ^ Example: -- -- >>> fib 5 -- 5 foo = "foo" bar = "bar" baz = foo ++ bar doctest-0.16.0.1/test/integration/with-cbits/0000755000000000000000000000000013351740625017155 5ustar0000000000000000doctest-0.16.0.1/test/integration/with-cbits/foo.c0000644000000000000000000000003313351740625020100 0ustar0000000000000000int foo() { return 23; } doctest-0.16.0.1/test/integration/with-cbits/Bar.hs0000644000000000000000000000020513351740625020212 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module Bar where import Foreign.C -- | -- >>> foo -- 23 foreign import ccall foo :: CInt doctest-0.16.0.1/test/integration/multiline/0000755000000000000000000000000013351740625017102 5ustar0000000000000000doctest-0.16.0.1/test/integration/multiline/Multiline.hs0000644000000000000000000000114213351740625021376 0ustar0000000000000000module 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-0.16.0.1/test/integration/trailing-whitespace/0000755000000000000000000000000013351740625021043 5ustar0000000000000000doctest-0.16.0.1/test/integration/trailing-whitespace/Foo.hs0000644000000000000000000000014713351740625022124 0ustar0000000000000000module Foo where -- | A failing example -- -- >>> putStrLn "foo " -- foo test :: a test = undefined doctest-0.16.0.1/test/integration/property-bool-with-type-signature/0000755000000000000000000000000013351740625023644 5ustar0000000000000000doctest-0.16.0.1/test/integration/property-bool-with-type-signature/Foo.hs0000644000000000000000000000007513351740625024725 0ustar0000000000000000module Foo where -- | -- prop> True :: Bool foo = undefined doctest-0.16.0.1/test/integration/testSimple/0000755000000000000000000000000013351740625017231 5ustar0000000000000000doctest-0.16.0.1/test/integration/testSimple/Fib.hs0000644000000000000000000000023313351740625020263 0ustar0000000000000000module 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-0.16.0.1/test/integration/dos-line-endings/0000755000000000000000000000000013351740625020237 5ustar0000000000000000doctest-0.16.0.1/test/integration/dos-line-endings/Fib.hs0000644000000000000000000000024513351740625021274 0ustar0000000000000000module 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-0.16.0.1/test/integration/testCPP/0000755000000000000000000000000013351740625016422 5ustar0000000000000000doctest-0.16.0.1/test/integration/testCPP/Foo.hs0000644000000000000000000000015613351740625017503 0ustar0000000000000000module Foo where -- | -- Examples: -- -- >>> foo -- 23 foo :: Int #ifdef FOO foo = 23 #else foo = 42 #endif doctest-0.16.0.1/test/integration/testFailOnMultiline/0000755000000000000000000000000013351740625021033 5ustar0000000000000000doctest-0.16.0.1/test/integration/testFailOnMultiline/Fib.hs0000644000000000000000000000034713351740625022073 0ustar0000000000000000module 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-0.16.0.1/test/integration/setup/0000755000000000000000000000000013351740625016240 5ustar0000000000000000doctest-0.16.0.1/test/integration/setup/Foo.hs0000644000000000000000000000014413351740625017316 0ustar0000000000000000module Foo where -- $setup -- >>> let x = 23 :: Int -- | -- >>> x + foo -- 65 foo :: Int foo = 42 doctest-0.16.0.1/test/integration/bugfixImportHierarchical/0000755000000000000000000000000013351740625022056 5ustar0000000000000000doctest-0.16.0.1/test/integration/bugfixImportHierarchical/ModuleB.hs0000644000000000000000000000023413351740625023740 0ustar0000000000000000module Foo.ModuleB (fib) where -- | -- >>> fib 10 -- 55 -- >>> fib 5 -- 5 fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) doctest-0.16.0.1/test/integration/bugfixImportHierarchical/ModuleA.hs0000644000000000000000000000010213351740625023731 0ustar0000000000000000-- | -- >>> fib 10 -- 55 module ModuleA where import Foo.ModuleB doctest-0.16.0.1/test/integration/custom-package-conf/0000755000000000000000000000000013351740625020726 5ustar0000000000000000doctest-0.16.0.1/test/integration/custom-package-conf/Bar.hs0000644000000000000000000000013213351740625021762 0ustar0000000000000000module Bar where import Foo -- | -- >>> import Foo -- >>> foo -- 23 bar :: Int bar = 42 doctest-0.16.0.1/test/integration/custom-package-conf/foo/0000755000000000000000000000000013351740625021511 5ustar0000000000000000doctest-0.16.0.1/test/integration/custom-package-conf/foo/doctest-foo.cabal0000644000000000000000000000023213351740625024720 0ustar0000000000000000name: doctest-foo version: 0.0.0 build-type: Simple cabal-version: >= 1.8 library exposed-modules: Foo build-depends: base doctest-0.16.0.1/test/integration/custom-package-conf/foo/Foo.hs0000644000000000000000000000004513351740625022567 0ustar0000000000000000module Foo where foo :: Int foo = 23 doctest-0.16.0.1/test/integration/template-haskell-bugfix/0000755000000000000000000000000013351740625021616 5ustar0000000000000000doctest-0.16.0.1/test/integration/template-haskell-bugfix/Main.hs0000644000000000000000000000042713351740625023041 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where -- Import our template "pr" import Printf ( pr ) -- The splice operator $ takes the Haskell source code -- generated at compile time by "pr" and splices it into -- the argument of "putStrLn". main = putStrLn ( $(pr "Hello") ) doctest-0.16.0.1/test/integration/template-haskell-bugfix/Printf.hs0000644000000000000000000000077513351740625023425 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- -- derived from: http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html#th-example -- module Printf (pr) where import Language.Haskell.TH data Format = D | S | L String parse :: String -> [Format] parse s = [ L s ] gen :: [Format] -> Q Exp gen [D] = [| \n -> show n |] gen [S] = [| \s -> s |] gen [L s] = stringE s -- | -- -- >>> :set -XTemplateHaskell -- >>> putStrLn ( $(pr "Hello") ) -- Hello pr :: String -> Q Exp pr s = gen (parse s) doctest-0.16.0.1/test/integration/testCombinedExample/0000755000000000000000000000000013351740625021034 5ustar0000000000000000doctest-0.16.0.1/test/integration/testCombinedExample/Fib.hs0000644000000000000000000000046613351740625022076 0ustar0000000000000000module 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-0.16.0.1/test/integration/bugfixMultipleModules/0000755000000000000000000000000013351740625021431 5ustar0000000000000000doctest-0.16.0.1/test/integration/bugfixMultipleModules/ModuleB.hs0000644000000000000000000000035013351740625023312 0ustar0000000000000000module ModuleB (fib) where -- | -- >>> fib 10 -- 55 -- >>> fib 5 -- 5 fib :: Integer -> Integer fib = foo -- | -- >>> foo 10 -- 55 -- >>> foo 5 -- 5 foo :: Integer -> Integer foo 0 = 0 foo 1 = 1 foo n = foo (n - 1) + foo (n - 2) doctest-0.16.0.1/test/integration/bugfixMultipleModules/ModuleA.hs0000644000000000000000000000007613351740625023316 0ustar0000000000000000-- | -- >>> fib 10 -- 55 module ModuleA where import ModuleB doctest-0.16.0.1/test/integration/bugfixWorkingDirectory/0000755000000000000000000000000013351740625021612 5ustar0000000000000000doctest-0.16.0.1/test/integration/bugfixWorkingDirectory/description0000644000000000000000000000031213351740625024054 0ustar0000000000000000Put the following files in the current working directory: ./Fib.hs ./examples/Fib.hs Now run: doctest examples/Fib.hs Erroneously `./Fib.hs` will be tested instead of `examples/Fib.hs`. doctest-0.16.0.1/test/integration/bugfixWorkingDirectory/Fib.hs0000644000000000000000000000022413351740625022644 0ustar0000000000000000module Fib where -- | Calculate Fibonacci number of given 'Num'. -- -- >>> bar -- 10 fib :: (Num t, Num t1) => t -> t1 fib _ = undefined bar = 10 doctest-0.16.0.1/test/integration/bugfixWorkingDirectory/examples/0000755000000000000000000000000013351740625023430 5ustar0000000000000000doctest-0.16.0.1/test/integration/bugfixWorkingDirectory/examples/Fib.hs0000644000000000000000000000042513351740625024465 0ustar0000000000000000module Fib where -- | Calculate Fibonacci number of given 'Num'. -- -- Examples: -- -- >>> fib 10 -- 55 fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) -- | -- -- Examples: -- -- >>> fib 10 -- 55 foo :: Int -> Int foo = undefined doctest-0.16.0.1/test/integration/setup-skip-on-failure/0000755000000000000000000000000013351740625021243 5ustar0000000000000000doctest-0.16.0.1/test/integration/setup-skip-on-failure/Foo.hs0000644000000000000000000000017713351740625022327 0ustar0000000000000000module Foo where -- $setup -- >>> x -- 23 -- | -- >>> foo -- 42 foo :: Int foo = 42 -- | -- >>> y -- 42 bar :: Int bar = 42 doctest-0.16.0.1/test/integration/failing-multiple/0000755000000000000000000000000013351740625020342 5ustar0000000000000000doctest-0.16.0.1/test/integration/failing-multiple/Foo.hs0000644000000000000000000000021513351740625021417 0ustar0000000000000000module Foo where -- | A failing example -- -- >>> 23 -- 23 -- -- >>> 23 -- 42 -- -- >>> 23 -- 23 -- >>> 23 -- 23 test :: a test = undefined doctest-0.16.0.1/test/integration/bugfixOutputToStdErr/0000755000000000000000000000000013351740625021234 5ustar0000000000000000doctest-0.16.0.1/test/integration/bugfixOutputToStdErr/Fib.hs0000644000000000000000000000027413351740625022273 0ustar0000000000000000module 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-0.16.0.1/test/integration/test-options/0000755000000000000000000000000013351740625017550 5ustar0000000000000000doctest-0.16.0.1/test/integration/test-options/Foo.hs0000644000000000000000000000015613351740625020631 0ustar0000000000000000module Foo where -- | -- Examples: -- -- >>> foo -- 23 foo :: Int #ifdef FOO foo = 23 #else foo = 42 #endif doctest-0.16.0.1/test/integration/property-bool/0000755000000000000000000000000013351740625017715 5ustar0000000000000000doctest-0.16.0.1/test/integration/property-bool/Foo.hs0000644000000000000000000000006513351740625020775 0ustar0000000000000000module Foo where -- | -- prop> True foo = undefined doctest-0.16.0.1/test/extract/0000755000000000000000000000000013351740625014227 5ustar0000000000000000doctest-0.16.0.1/test/extract/export-list/0000755000000000000000000000000013351740625016521 5ustar0000000000000000doctest-0.16.0.1/test/extract/export-list/Foo.hs0000644000000000000000000000020113351740625017571 0ustar0000000000000000module Foo ( -- * some heading -- | documentation from export list foo , bar ) where foo :: Int foo = 23 bar :: Int bar = 23 doctest-0.16.0.1/test/extract/comment-order/0000755000000000000000000000000013351740625017002 5ustar0000000000000000doctest-0.16.0.1/test/extract/comment-order/Foo.hs0000644000000000000000000000042113351740625020056 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-0.16.0.1/test/extract/type-class/0000755000000000000000000000000013351740625016313 5ustar0000000000000000doctest-0.16.0.1/test/extract/type-class/Foo.hs0000644000000000000000000000015513351740625017373 0ustar0000000000000000module Foo where class ToString a where -- | Convert given value to a string. toString :: a -> String doctest-0.16.0.1/test/extract/regression/0000755000000000000000000000000013351740625016407 5ustar0000000000000000doctest-0.16.0.1/test/extract/regression/RewriteRulesWithSigs.hs0000644000000000000000000000025613351740625023064 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-0.16.0.1/test/extract/regression/ForeignImport.hs0000644000000000000000000000037713351740625021536 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-0.16.0.1/test/extract/regression/Fixity.hs0000644000000000000000000000005613351740625020220 0ustar0000000000000000module Fixity where foo :: Int foo = 23 + 42 doctest-0.16.0.1/test/extract/regression/ParallelListCompClass.hs0000644000000000000000000000026213351740625023140 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-0.16.0.1/test/extract/regression/ParallelListComp.hs0000644000000000000000000000017013351740625022150 0ustar0000000000000000{-# LANGUAGE ParallelListComp #-} module ParallelListComp where foo :: [Int] foo = [x+y | x <- [1,2,3] | y <- [4,5,6]] doctest-0.16.0.1/test/extract/regression/RewriteRules.hs0000644000000000000000000000023213351740625021374 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-0.16.0.1/test/extract/module-header/0000755000000000000000000000000013351740625016742 5ustar0000000000000000doctest-0.16.0.1/test/extract/module-header/Foo.hs0000644000000000000000000000007613351740625020024 0ustar0000000000000000-- | Some documentation module Foo where foo :: Int foo = 23 doctest-0.16.0.1/test/extract/type-families/0000755000000000000000000000000013351740625016777 5ustar0000000000000000doctest-0.16.0.1/test/extract/type-families/Foo.hs0000644000000000000000000000013713351740625020057 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Foo where type family Foo a type instance Foo Int = Int doctest-0.16.0.1/test/extract/dos-line-endings/0000755000000000000000000000000013351740625017366 5ustar0000000000000000doctest-0.16.0.1/test/extract/dos-line-endings/Foo.hs0000644000000000000000000000011013351740625020435 0ustar0000000000000000module Foo where -- | -- foo -- bar -- baz foo :: Int foo = 23 doctest-0.16.0.1/test/extract/named-chunks/0000755000000000000000000000000013351740625016604 5ustar0000000000000000doctest-0.16.0.1/test/extract/named-chunks/Foo.hs0000644000000000000000000000020013351740625017653 0ustar0000000000000000module Foo ( foo , bar ) where -- $foo named chunk foo -- $bar -- named chunk bar foo :: Int foo = 23 bar :: Int bar = 23 doctest-0.16.0.1/test/extract/th/0000755000000000000000000000000013351740625014642 5ustar0000000000000000doctest-0.16.0.1/test/extract/th/Bar.hs0000644000000000000000000000010013351740625015671 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Bar where bar = [|23|] doctest-0.16.0.1/test/extract/th/Foo.hs0000644000000000000000000000015713351740625015724 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Foo where import Bar -- | some documentation foo :: Int foo = $(bar) doctest-0.16.0.1/test/extract/setup/0000755000000000000000000000000013351740625015367 5ustar0000000000000000doctest-0.16.0.1/test/extract/setup/Foo.hs0000644000000000000000000000021113351740625016440 0ustar0000000000000000module Foo where -- $setup -- some setup code -- | foo foo :: Int foo = 42 -- | bar bar :: Int bar = 42 -- | baz baz :: Int baz = 42 doctest-0.16.0.1/test/extract/type-class-args/0000755000000000000000000000000013351740625017245 5ustar0000000000000000doctest-0.16.0.1/test/extract/type-class-args/Foo.hs0000644000000000000000000000014413351740625020323 0ustar0000000000000000module Foo where class Foo a where bar :: a -- ^ foo -> Int -- ^ bar -> String doctest-0.16.0.1/test/extract/declaration/0000755000000000000000000000000013351740625016514 5ustar0000000000000000doctest-0.16.0.1/test/extract/declaration/Foo.hs0000644000000000000000000000007613351740625017576 0ustar0000000000000000module Foo where -- | Some documentation foo :: Int foo = 23 doctest-0.16.0.1/test/extract/argument-list/0000755000000000000000000000000013351740625017022 5ustar0000000000000000doctest-0.16.0.1/test/extract/argument-list/Foo.hs0000644000000000000000000000014713351740625020103 0ustar0000000000000000module Foo where foo :: Int -- ^ doc for arg1 -> Int -- ^ doc for arg2 -> Int foo = undefined doctest-0.16.0.1/test/extract/imported-module/0000755000000000000000000000000013351740625017335 5ustar0000000000000000doctest-0.16.0.1/test/extract/imported-module/Bar.hs0000644000000000000000000000011513351740625020372 0ustar0000000000000000module Bar where import Baz -- | documentation for bar bar :: Int bar = 23 doctest-0.16.0.1/test/extract/imported-module/Baz.hs0000644000000000000000000000010113351740625020375 0ustar0000000000000000module Baz where -- | documentation for baz baz :: Int baz = 23 doctest-0.16.0.1/test/parse/0000755000000000000000000000000013351740625013667 5ustar0000000000000000doctest-0.16.0.1/test/parse/setup-only/0000755000000000000000000000000013351740625016006 5ustar0000000000000000doctest-0.16.0.1/test/parse/setup-only/Foo.hs0000644000000000000000000000013213351740625017061 0ustar0000000000000000module Foo where -- $setup -- >>> foo -- 23 -- | some documentation foo :: Int foo = 23 doctest-0.16.0.1/test/parse/non-exported/0000755000000000000000000000000013351740625016311 5ustar0000000000000000doctest-0.16.0.1/test/parse/non-exported/Fib.hs0000644000000000000000000000035413351740625017347 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-0.16.0.1/test/parse/simple/0000755000000000000000000000000013351740625015160 5ustar0000000000000000doctest-0.16.0.1/test/parse/simple/Fib.hs0000644000000000000000000000027213351740625016215 0ustar0000000000000000module Fib where -- | Calculate Fibonacci numbers. -- -- >>> putStrLn "foo" -- foo -- >>> putStr "bar" -- bar -- -- >>> putStrLn "baz" -- baz fib :: Int -> Int -> Int fib _ = undefined doctest-0.16.0.1/test/parse/property/0000755000000000000000000000000013351740625015553 5ustar0000000000000000doctest-0.16.0.1/test/parse/property/Fib.hs0000644000000000000000000000026413351740625016611 0ustar0000000000000000module Fib where -- | Calculate Fibonacci numbers. -- -- prop> foo -- -- some text -- -- prop> bar -- -- some more text -- -- prop> baz fib :: Int -> Int -> Int fib _ = undefined doctest-0.16.0.1/test/parse/multiple-examples/0000755000000000000000000000000013351740625017336 5ustar0000000000000000doctest-0.16.0.1/test/parse/multiple-examples/Foo.hs0000644000000000000000000000012113351740625020407 0ustar0000000000000000module Foo where -- | -- >>> foo -- 23 foo = 23 -- | -- >>> bar -- 42 bar = 42 doctest-0.16.0.1/test/parse/setup-empty/0000755000000000000000000000000013351740625016163 5ustar0000000000000000doctest-0.16.0.1/test/parse/setup-empty/Foo.hs0000644000000000000000000000013213351740625017236 0ustar0000000000000000module Foo where -- $setup -- some setup code -- | -- >>> foo -- 23 foo :: Int foo = 23 doctest-0.16.0.1/test/parse/no-examples/0000755000000000000000000000000013351740625016117 5ustar0000000000000000doctest-0.16.0.1/test/parse/no-examples/Fib.hs0000644000000000000000000000020613351740625017151 0ustar0000000000000000module Fib where -- | Calculate Fibonacci numbers. -- @ -- some code -- @ -- -- foobar 23 fib :: Int -> Int -> Int fib _ = undefined doctest-0.16.0.1/example/0000755000000000000000000000000013351740625013231 5ustar0000000000000000doctest-0.16.0.1/example/example.cabal0000644000000000000000000000056613351740625015657 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, doctest >= 0.8 doctest-0.16.0.1/example/test/0000755000000000000000000000000013351740625014210 5ustar0000000000000000doctest-0.16.0.1/example/test/doctests.hs0000644000000000000000000000015313351740625016373 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest ["-isrc", "src/Example.hs"] doctest-0.16.0.1/example/src/0000755000000000000000000000000013351740625014020 5ustar0000000000000000doctest-0.16.0.1/example/src/Example.hs0000644000000000000000000000012513351740625015745 0ustar0000000000000000module Example where -- | -- >>> foo -- 23 foo = 23 -- | -- >>> bar -- 42 bar = 42 doctest-0.16.0.1/driver/0000755000000000000000000000000013351740625013071 5ustar0000000000000000doctest-0.16.0.1/driver/Main.hs0000644000000000000000000000021713351740625014311 0ustar0000000000000000module Main (main) where import Test.DocTest import System.Environment (getArgs) main :: IO () main = getArgs >>= doctest doctest-0.16.0.1/src/0000755000000000000000000000000013351740625012365 5ustar0000000000000000doctest-0.16.0.1/src/Parse.hs0000644000000000000000000001336113351740625013777 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module 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 #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Extract import Location data DocTest = Example Expression ExpectedResult | Property Expression deriving (Eq, Show) data LineChunk = LineChunk String | WildCardChunk deriving (Show, Eq) instance IsString LineChunk where fromString = LineChunk data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine deriving (Show, Eq) instance IsString ExpectedLine where fromString = ExpectedLine . return . LineChunk type Expression = String type ExpectedResult = [ExpectedLine] type Interaction = (Expression, ExpectedResult) -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules. getDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's getDocTests args = parseModules <$> extract args parseModules :: [Module (Located String)] -> [Module [Located DocTest]] parseModules = filter (not . isEmpty) . map parseModule where isEmpty (Module _ setup tests) = null tests && isNothing setup -- | Convert documentation to `Example`s. parseModule :: Module (Located String) -> Module [Located DocTest] parseModule m = case parseComment <$> m of Module name setup tests -> Module name setup_ (filter (not . null) tests) where setup_ = case setup of Just [] -> Nothing _ -> setup parseComment :: Located String -> [Located DocTest] parseComment c = properties ++ examples where examples = map (fmap $ uncurry Example) (parseInteractions c) properties = map (fmap Property) (parseProperties c) -- | Extract all properties from given Haddock comment. parseProperties :: Located String -> [Located Expression] parseProperties (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) where isPrompt :: Located String -> Bool isPrompt = isPrefixOf "prop>" . dropWhile isSpace . unLoc go xs = case dropWhile (not . isPrompt) xs of prop:rest -> stripPrompt `fmap` prop : go rest [] -> [] stripPrompt = strip . drop 5 . dropWhile isSpace -- | Extract all interactions from given Haddock comment. parseInteractions :: Located String -> [Located Interaction] parseInteractions (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) where isPrompt :: Located String -> Bool isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc isBlankLine :: Located String -> Bool isBlankLine = null . dropWhile isSpace . unLoc isEndOfInteraction :: Located String -> Bool isEndOfInteraction x = isPrompt x || isBlankLine x go :: [Located String] -> [Located Interaction] go xs = case dropWhile (not . isPrompt) xs of prompt:rest | ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))), (ys,zs) <- break isBlankLine rest -> toInteraction prompt ys : go zs | otherwise -> let (ys,zs) = break isEndOfInteraction rest in toInteraction prompt ys : go zs [] -> [] -- | Create an `Interaction`, strip superfluous whitespace as appropriate. -- -- also merge lines between :{ and :}, preserving whitespace inside -- the block (since this is useful for avoiding {;}). toInteraction :: Located String -> [Located String] -> Located Interaction toInteraction (Located loc x) xs = Located loc $ ( (strip cleanedE) -- we do not care about leading and trailing -- whitespace in expressions, so drop them , map mkExpectedLine result_ ) where -- 1. drop trailing whitespace from the prompt, remember the prefix (prefix, e) = span isSpace x (ePrompt, eRest) = splitAt 3 e -- 2. drop, if possible, the exact same sequence of whitespace -- characters from each result line unindent pre = map (tryStripPrefix pre . unLoc) cleanBody line = fromMaybe (unLoc line) (stripPrefix ePrompt (dropWhile isSpace (unLoc line))) (cleanedE, result_) | (body , endLine : rest) <- break ( (==) [":}"] . take 1 . words . cleanBody) xs = (unlines (eRest : map cleanBody body ++ [dropWhile isSpace (cleanBody endLine)]), unindent (takeWhile isSpace (unLoc endLine)) rest) | otherwise = (eRest, unindent prefix xs) tryStripPrefix :: String -> String -> String tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys mkExpectedLine :: String -> ExpectedLine mkExpectedLine x = case x of "" -> "" "..." -> WildCardLine _ -> ExpectedLine $ mkLineChunks x mkLineChunks :: String -> [LineChunk] mkLineChunks = finish . foldr go (0, [], []) where mkChunk :: String -> [LineChunk] mkChunk "" = [] mkChunk x = [LineChunk x] go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk]) go '.' (count, acc, res) = if count == 2 then (0, "", WildCardChunk : mkChunk acc ++ res) else (count + 1, acc, res) go c (count, acc, res) = if count > 0 then (0, c : replicate count '.' ++ acc, res) else (0, c : acc, res) finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res -- | Remove leading and trailing whitespace. strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse doctest-0.16.0.1/src/Location.hs0000644000000000000000000000376113351740625014500 0ustar0000000000000000{-# LANGUAGE CPP, DeriveFunctor #-} module Location where import Control.DeepSeq (deepseq, NFData(rnf)) import SrcLoc hiding (Located) import qualified SrcLoc as GHC import FastString (unpackFS) #if __GLASGOW_HASKELL__ < 702 import Outputable (showPpr) #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__ < 702 toLocation loc | isGoodSrcLoc start = Location (unpackFS $ srcLocFile start) (srcLocLine start) | otherwise = (UnhelpfulLocation . showPpr) start where start = srcSpanStart loc #else toLocation loc = case loc of UnhelpfulSpan str -> UnhelpfulLocation (unpackFS str) RealSrcSpan sp -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) #endif doctest-0.16.0.1/src/Extract.hs0000644000000000000000000002301313351740625014332 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} module Extract (Module(..), extract) where import Prelude hiding (mod, concat) import Control.Monad #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Exception import Data.List (partition, isSuffixOf) import Data.Maybe #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (concat) #endif import Control.DeepSeq (deepseq, NFData(rnf)) import Data.Generics #if __GLASGOW_HASKELL__ < 707 import GHC hiding (flags, Module, Located) import MonadUtils (liftIO, MonadIO) #else import GHC hiding (Module, Located) import DynFlags import MonadUtils (liftIO) #endif import Exception (ExceptionMonad) import System.Directory import System.FilePath #if __GLASGOW_HASKELL__ < 710 import NameSet (NameSet) import Coercion (Coercion) #endif #if __GLASGOW_HASKELL__ < 805 import FastString (unpackFS) #endif import Digraph (flattenSCCs) import System.Posix.Internals (c_getpid) import GhcUtil (withGhc) import Location hiding (unLoc) import Util (convertDosLineEndings) import PackageDBs (getPackageDBArgs) -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException deriving Typeable instance Show ExtractError where show (ExtractError e) = unlines [ "Ouch! Hit an error thunk in GHC's AST while extracting documentation." , "" , " " ++ msg , "" , "This is most likely a bug in doctest." , "" , "Please report it here: https://github.com/sol/doctest/issues/new" ] where msg = case fromException e of Just (Panic s) -> "GHC panic: " ++ s _ -> show e instance Exception ExtractError -- | Documentation for a module grouped together with the modules name. data Module a = Module { moduleName :: String , moduleSetup :: Maybe a , moduleContent :: [a] } deriving (Eq, Functor) instance NFData a => NFData (Module a) where rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` () #if __GLASGOW_HASKELL__ < 803 type GhcPs = RdrName needsTemplateHaskellOrQQ :: ModuleGraph -> Bool needsTemplateHaskellOrQQ = needsTemplateHaskell mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG = map #endif #if __GLASGOW_HASKELL__ < 805 addQuoteInclude :: [String] -> [String] -> [String] addQuoteInclude includes new = new ++ includes #endif -- | Parse a list of modules. parse :: [String] -> IO [TypecheckedModule] parse args = withGhc args $ \modules_ -> withTempOutputDir $ do -- ignore additional object files let modules = filter (not . isSuffixOf ".o") modules_ mapM (`guessTarget` Nothing) modules >>= setTargets mods <- depanal [] False mods' <- if needsTemplateHaskellOrQQ mods then enableCompilation mods else return mods let sortedMods = flattenSCCs (topSortModuleGraph False mods' Nothing) reverse <$> mapM (parseModule >=> typecheckModule >=> loadModule) sortedMods where -- copied from Haddock/Interface.hs enableCompilation :: ModuleGraph -> Ghc ModuleGraph enableCompilation modGraph = do #if __GLASGOW_HASKELL__ < 707 let enableComp d = d { hscTarget = defaultObjectTarget } #else let enableComp d = let platform = targetPlatform d in d { hscTarget = defaultObjectTarget platform } #endif modifySessionDynFlags enableComp -- We need to update the DynFlags of the ModSummaries as well. let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } let modGraph' = mapMG upd modGraph return modGraph' -- copied from Haddock/GhcUtils.hs modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () modifySessionDynFlags f = do dflags <- getSessionDynFlags #if __GLASGOW_HASKELL__ < 707 _ <- setSessionDynFlags (f dflags) #else -- GHCi 7.7 now uses dynamic linking. let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of Just "YES" -> gopt_set dflags Opt_BuildDynamicToo _ -> dflags _ <- setSessionDynFlags (f dflags') #endif return () withTempOutputDir :: Ghc a -> Ghc a 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 gbracket_ before_ after thing = gbracket before_ (const after) (const thing) setOutputDir f d = d { objectDir = Just f , hiDir = Just f , stubDir = Just f , includePaths = addQuoteInclude (includePaths d) [f] } -- | 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 packageDBArgs <- getPackageDBArgs let args' = args ++ packageDBArgs mods <- parse args' let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule . tm_parsed_module) mods (docs `deepseq` return docs) `catches` [ -- Re-throw AsyncException, otherwise execution will not terminate on -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just -- UserInterrupt) because all of them indicate severe conditions and -- should not occur during normal operation. Handler (\e -> throw (e :: AsyncException)) , Handler (throwIO . ExtractError) ] -- | Extract all docstrings from given module and attach the modules name. extractFromModule :: ParsedModule -> Module (Located String) extractFromModule m = Module name (listToMaybe $ map snd setup) (map snd docs) where isSetup = (== Just "setup") . fst (setup, docs) = partition isSetup (docStringsFromModule m) name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m -- | Extract all docstrings from given module. docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)] docStringsFromModule mod = map (fmap (toLocated . fmap unpackHDS)) docs where source = (unLoc . pm_parsed_source) mod -- we use dlist-style concatenation here docs = header ++ exports ++ decls -- We process header, exports and declarations separately instead of -- traversing the whole source in a generic way, to ensure that we get -- everything in source order. header = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]] #if __GLASGOW_HASKELL__ < 710 exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- concat (hsmodExports source)] #elif __GLASGOW_HASKELL__ < 805 exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)] #else exports = [(Nothing, L loc doc) | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source)] #endif decls = extractDocStrings (hsmodDecls source) type Selector a = a -> ([(Maybe String, LHsDocString)], Bool) #if __GLASGOW_HASKELL__ < 710 -- | Ignore a subtree. ignore :: Selector a ignore = const ([], True) #endif -- | Collect given value and descend into subtree. select :: a -> ([a], Bool) select x = ([x], False) -- | Extract all docstrings from given value. extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)] extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl `extQ` fromLDocDecl `extQ` fromLHsDocString #if __GLASGOW_HASKELL__ < 710 `extQ` (ignore :: Selector NameSet) `extQ` (ignore :: Selector PostTcKind) -- HsExpr never contains any documentation, but it may contain error thunks. -- -- Problematic are (non comprehensive): -- -- * parallel list comprehensions -- * infix operators -- `extQ` (ignore :: Selector (HsExpr RdrName)) -- undefined before type checking `extQ` (ignore :: Selector Coercion) #if __GLASGOW_HASKELL__ >= 706 -- hswb_kvs and hswb_tvs may be error thunks `extQ` (ignore :: Selector (HsWithBndrs [LHsType RdrName])) `extQ` (ignore :: Selector (HsWithBndrs [LHsType Name])) `extQ` (ignore :: Selector (HsWithBndrs (LHsType RdrName))) `extQ` (ignore :: Selector (HsWithBndrs (LHsType Name))) #endif #endif ) where fromLHsDecl :: Selector (LHsDecl GhcPs) fromLHsDecl (L loc decl) = case decl of -- Top-level documentation has to be treated separately, because it has -- no location information attached. The location information is -- attached to HsDecl instead. #if __GLASGOW_HASKELL__ < 805 DocD x -> select (fromDocDecl loc x) #else DocD _ x -> select (fromDocDecl loc x) #endif _ -> (extractDocStrings decl, True) fromLDocDecl :: Selector LDocDecl fromLDocDecl (L loc x) = select (fromDocDecl loc x) fromLHsDocString :: Selector LHsDocString fromLHsDocString x = select (Nothing, x) fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString) fromDocDecl loc x = case x of DocCommentNamed name doc -> (Just name, L loc doc) _ -> (Nothing, L loc $ docDeclDoc x) #if __GLASGOW_HASKELL__ < 805 -- | Convert a docstring to a plain string. unpackHDS :: HsDocString -> String unpackHDS (HsDocString s) = unpackFS s #endif doctest-0.16.0.1/src/Interpreter.hs0000644000000000000000000000464613351740625015236 0ustar0000000000000000{-# LANGUAGE CPP #-} module Interpreter ( Interpreter , safeEval , safeEvalIt , withInterpreter , ghc , interpreterSupported -- exported for testing , ghcInfo , haveInterpreterKey ) where import System.Process import System.Directory (getPermissions, executable) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad import Control.Exception hiding (handle) import Data.Char import GHC.Paths (ghc) import Language.Haskell.GhciWrapper haveInterpreterKey :: String haveInterpreterKey = "Have interpreter" ghcInfo :: IO [(String, String)] ghcInfo = read <$> readProcess ghc ["--info"] [] interpreterSupported :: IO Bool interpreterSupported = do -- in a perfect world this permission check should never fail, but I know of -- at least one case where it did.. x <- getPermissions ghc unless (executable x) $ do fail $ ghc ++ " is not executable!" maybe False (== "YES") . lookup haveInterpreterKey <$> ghcInfo -- | Run an interpreter session. -- -- Example: -- -- >>> withInterpreter [] $ \i -> eval i "23 + 42" -- "65\n" withInterpreter :: [String] -- ^ List of flags, passed to GHC -> (Interpreter -> IO a) -- ^ Action to run -> IO a -- ^ Result of action withInterpreter flags action = do let args = [ "--interactive" #if __GLASGOW_HASKELL__ >= 802 , "-fdiagnostics-color=never" , "-fno-diagnostics-show-caret" #endif ] ++ flags bracket (new defaultConfig{configGhci = ghc} args) close action -- | Evaluate an expression; return a Left value on exceptions. -- -- An exception may e.g. be caused on unterminated multiline expressions. safeEval :: Interpreter -> String -> IO (Either String String) safeEval repl = either (return . Left) (fmap Right . eval repl) . filterExpression safeEvalIt :: Interpreter -> String -> IO (Either String String) safeEvalIt repl = either (return . Left) (fmap Right . evalIt repl) . filterExpression filterExpression :: String -> Either String String filterExpression e = case lines e of [] -> Right e l -> if firstLine == ":{" && lastLine /= ":}" then fail_ else Right e where firstLine = strip $ head l lastLine = strip $ last l fail_ = Left "unterminated multiline command" where strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse doctest-0.16.0.1/src/Property.hs0000644000000000000000000000452213351740625014550 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Property ( runProperty , PropertyResult (..) #ifdef TEST , freeVariables , parseNotInScope #endif ) where import Data.List import Data.Maybe import Data.Foldable import Util import Interpreter (Interpreter) import qualified Interpreter import 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 #if __GLASGOW_HASKELL__ >= 707 unquote ('\8216':xs) = init xs #endif unquote xs = xs doctest-0.16.0.1/src/Run.hs0000644000000000000000000001014213351740625013463 0ustar0000000000000000{-# LANGUAGE CPP #-} module Run ( doctest #ifdef TEST , doctestWithOptions , Summary , expandDirs #endif ) where import Prelude () import Prelude.Compat import Control.Monad (when, unless) import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) import System.Environment (getEnvironment) import System.Exit (exitFailure, exitSuccess) import System.FilePath ((), takeExtension) import System.IO import System.IO.CodePage (withCP65001) import qualified Control.Exception as E import Panic import PackageDBs import Parse import Options import Runner import qualified Interpreter -- | Run doctest with given list of arguments. -- -- Example: -- -- >>> doctest ["-iexample/src", "example/src/Example.hs"] -- Examples: 2 Tried: 2 Errors: 0 Failures: 0 -- -- This can be used to create a Cabal test suite that runs doctest for your -- project. -- -- If a directory is given, it is traversed to find all .hs and .lhs files -- inside of it, ignoring hidden entries. doctest :: [String] -> IO () doctest args0 = case parseOptions args0 of Output s -> putStr s Result (Run warnings args_ magicMode fastMode preserveIt verbose) -> do mapM_ (hPutStrLn stderr) warnings hFlush stderr i <- Interpreter.interpreterSupported unless i $ do hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests" exitSuccess args <- case magicMode of False -> return args_ True -> do expandedArgs <- concat <$> mapM expandDirs args_ packageDBArgs <- getPackageDBArgs addDistArgs <- getAddDistArgs return (addDistArgs $ packageDBArgs ++ expandedArgs) r <- doctestWithOptions fastMode preserveIt verbose args `E.catch` \e -> do case fromException e of Just (UsageError err) -> do hPutStrLn stderr ("doctest: " ++ err) hPutStrLn stderr "Try `doctest --help' for more information." exitFailure _ -> E.throwIO e when (not $ isSuccess r) exitFailure -- | Expand a reference to a directory to all .hs and .lhs files within it. expandDirs :: String -> IO [String] expandDirs fp0 = do isDir <- doesDirectoryExist fp0 if isDir then findHaskellFiles fp0 else return [fp0] where findHaskellFiles dir = do contents <- getDirectoryContents dir concat <$> mapM go (filter (not . hidden) contents) where go name = do isDir <- doesDirectoryExist fp if isDir then findHaskellFiles fp else if isHaskellFile fp then return [fp] else return [] where fp = dir name hidden ('.':_) = True hidden _ = False isHaskellFile fp = takeExtension fp `elem` [".hs", ".lhs"] -- | Get the necessary arguments to add the @cabal_macros.h@ file and autogen -- directory, if present. getAddDistArgs :: IO ([String] -> [String]) getAddDistArgs = do env <- getEnvironment let dist = case lookup "HASKELL_DIST_DIR" env of Nothing -> "dist" Just x -> x autogen = dist ++ "/build/autogen/" cabalMacros = autogen ++ "cabal_macros.h" dirExists <- doesDirectoryExist autogen if dirExists then do fileExists <- doesFileExist cabalMacros return $ \rest -> concat ["-i", dist, "/build/autogen/"] : "-optP-include" : (if fileExists then (concat ["-optP", dist, "/build/autogen/cabal_macros.h"]:) else id) rest else return id isSuccess :: Summary -> Bool isSuccess s = sErrors s == 0 && sFailures s == 0 doctestWithOptions :: Bool -> Bool -> Bool -> [String] -> IO Summary doctestWithOptions fastMode preserveIt verbose args = do -- get examples from Haddock comments modules <- getDocTests args Interpreter.withInterpreter args $ \repl -> withCP65001 $ do runModules fastMode preserveIt verbose repl modules doctest-0.16.0.1/src/Runner.hs0000644000000000000000000001673713351740625014210 0ustar0000000000000000{-# LANGUAGE CPP #-} module Runner ( runModules , Summary(..) #ifdef TEST , Report , ReportState (..) , report , report_ #endif ) where import Prelude hiding (putStr, putStrLn, error) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid hiding ((<>)) import Control.Applicative #endif import Control.Monad hiding (forM_) import Text.Printf (printf) import System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice) import Data.Foldable (forM_) import Control.Monad.Trans.State import Control.Monad.IO.Class import Interpreter (Interpreter) import qualified Interpreter import Parse import Location import Property import Runner.Example -- | Summary of a test run. data Summary = Summary { sExamples :: Int , sTried :: Int , sErrors :: Int , sFailures :: Int } deriving Eq -- | Format a summary. instance Show Summary where show (Summary examples tried errors failures) = printf "Examples: %d Tried: %d Errors: %d Failures: %d" examples tried errors failures -- | Sum up summaries. instance Monoid Summary where mempty = Summary 0 0 0 0 #if MIN_VERSION_base(4,11,0) instance Semigroup Summary where (<>) #else mappend #endif (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 :: Bool -> Bool -> Bool -> Interpreter -> [Module [Located DocTest]] -> IO Summary runModules fastMode preserveIt verbose repl modules = do isInteractive <- hIsTerminalDevice stderr ReportState _ _ _ s <- (`execStateT` ReportState 0 isInteractive verbose mempty {sExamples = c}) $ do forM_ modules $ runModule fastMode preserveIt repl verboseReport "# Final summary:" gets (show . reportStateSummary) >>= report return s where c = (sum . map count) modules -- | Count number of expressions in given module. count :: Module [Located DocTest] -> Int count (Module _ setup tests) = sum (map length tests) + maybe 0 length setup -- | A monad for generating test reports. type Report = StateT ReportState IO data ReportState = ReportState { reportStateCount :: Int -- ^ characters on the current line , reportStateInteractive :: Bool -- ^ should intermediate results be printed? , reportStateVerbose :: Bool , reportStateSummary :: Summary -- ^ test summary } -- | Add output to the report. report :: String -> Report () report msg = do overwrite msg -- add a newline, this makes the output permanent liftIO $ hPutStrLn stderr "" modify (\st -> st {reportStateCount = 0}) -- | Add intermediate output to the report. -- -- This will be overwritten by subsequent calls to `report`/`report_`. -- Intermediate out may not contain any newlines. report_ :: String -> Report () report_ msg = do f <- gets reportStateInteractive when f $ do overwrite msg modify (\st -> st {reportStateCount = length msg}) -- | Add output to the report, overwrite any intermediate out. overwrite :: String -> Report () overwrite msg = do n <- gets reportStateCount let str | 0 < n = "\r" ++ msg ++ replicate (n - length msg) ' ' | otherwise = msg liftIO (hPutStr stderr str) -- | Run all examples from given module. runModule :: Bool -> Bool -> Interpreter -> Module [Located DocTest] -> Report () runModule fastMode preserveIt repl (Module module_ setup examples) = do Summary _ _ e0 f0 <- gets reportStateSummary forM_ setup $ runTestGroup preserveIt repl reload Summary _ _ e1 f1 <- gets reportStateSummary -- only run tests, if setup does not produce any errors/failures when (e0 == e1 && f0 == f1) $ forM_ examples $ runTestGroup preserveIt repl setup_ where reload :: IO () reload = do unless fastMode $ -- NOTE: It is important to do the :reload first! See -- https://ghc.haskell.org/trac/ghc/ticket/5904, which results in a -- panic on GHC 7.4.1 if you do the :reload second. void $ Interpreter.safeEval repl ":reload" void $ Interpreter.safeEval repl $ ":m *" ++ module_ when preserveIt $ -- Evaluate a dumb expression to populate the 'it' variable NOTE: This is -- one reason why we cannot have safeEval = safeEvalIt: 'it' isn't set in -- a fresh GHCi session. void $ Interpreter.safeEval repl $ "()" setup_ :: IO () setup_ = do reload forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of Property _ -> return () Example e _ -> void $ safeEvalWith preserveIt repl e reportStart :: Location -> Expression -> String -> Report () reportStart loc expression testType = do verboseReport (printf "### Started execution at %s.\n### %s:\n%s" (show loc) testType expression) reportFailure :: Location -> Expression -> [String] -> Report () reportFailure loc expression err = do report (printf "%s: failure in expression `%s'" (show loc) expression) mapM_ report err report "" updateSummary (Summary 0 1 0 1) reportError :: Location -> Expression -> String -> Report () reportError loc expression err = do report (printf "%s: error in expression `%s'" (show loc) expression) report err report "" updateSummary (Summary 0 1 1 0) reportSuccess :: Report () reportSuccess = do verboseReport "### Successful!\n" updateSummary (Summary 0 1 0 0) verboseReport :: String -> Report () verboseReport xs = do verbose <- gets reportStateVerbose when verbose $ report xs updateSummary :: Summary -> Report () updateSummary summary = do ReportState n f v s <- get put (ReportState n f v $ s `mappend` summary) reportProgress :: Report () reportProgress = do verbose <- gets reportStateVerbose when (not verbose) $ gets (show . reportStateSummary) >>= report_ -- | Run given test group. -- -- The interpreter state is zeroed with @:reload@ first. This means that you -- can reuse the same 'Interpreter' for several test groups. runTestGroup :: Bool -> Interpreter -> IO () -> [Located DocTest] -> Report () runTestGroup preserveIt repl setup tests = do reportProgress liftIO setup runExampleGroup preserveIt repl examples forM_ properties $ \(loc, expression) -> do r <- do liftIO setup reportStart loc expression "property" liftIO $ runProperty repl expression case r of Success -> reportSuccess Error err -> do reportError loc expression err Failure msg -> do reportFailure loc expression [msg] 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 :: Bool -> Interpreter -> [Located Interaction] -> Report () runExampleGroup preserveIt repl = go where go ((Located loc (expression, expected)) : xs) = do reportStart loc expression "example" r <- fmap lines <$> liftIO (safeEvalWith preserveIt repl expression) case r of Left err -> do reportError loc expression err Right actual -> case mkResult expected actual of NotEqual err -> do reportFailure loc expression err Equal -> do reportSuccess go xs go [] = return () safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String) safeEvalWith preserveIt | preserveIt = Interpreter.safeEvalIt | otherwise = Interpreter.safeEval doctest-0.16.0.1/src/PackageDBs.hs0000644000000000000000000000644513351740625014656 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} -- | Manage GHC package databases module PackageDBs ( PackageDBs (..) , ArgStyle (..) , dbArgs , buildArgStyle , getPackageDBsFromEnv , getPackageDBArgs ) where import System.Environment (getEnvironment) import System.FilePath (splitSearchPath, searchPathSeparator) import qualified Sandbox import Control.Exception (try, SomeException) import System.Directory (getCurrentDirectory) -- | Full stack of GHC package databases data PackageDBs = PackageDBs { includeUser :: Bool -- | Unsupported on GHC < 7.6 , includeGlobal :: Bool , extraDBs :: [FilePath] } deriving (Show, Eq) -- | Package database handling switched between GHC 7.4 and 7.6 data ArgStyle = Pre76 | Post76 deriving (Show, Eq) -- | Determine command line arguments to be passed to GHC to set databases correctly -- -- >>> dbArgs Post76 (PackageDBs False True []) -- ["-no-user-package-db"] -- -- >>> dbArgs Pre76 (PackageDBs True True ["somedb"]) -- ["-package-conf","somedb"] dbArgs :: ArgStyle -> PackageDBs -> [String] dbArgs Post76 (PackageDBs user global extras) = (if user then id else ("-no-user-package-db":)) $ (if global then id else ("-no-global-package-db":)) $ concatMap (\extra -> ["-package-db", extra]) extras dbArgs Pre76 (PackageDBs _ False _) = error "Global package database must be included with GHC < 7.6" dbArgs Pre76 (PackageDBs user True extras) = (if user then id else ("-no-user-package-conf":)) $ concatMap (\extra -> ["-package-conf", extra]) extras -- | The argument style to be used with the current GHC version buildArgStyle :: ArgStyle #if __GLASGOW_HASKELL__ >= 706 buildArgStyle = Post76 #else buildArgStyle = Pre76 #endif -- | Determine the PackageDBs based on the environment and cabal sandbox -- information getPackageDBsFromEnv :: IO PackageDBs getPackageDBsFromEnv = do env <- getEnvironment case () of () | Just sandboxes <- lookup "HASKELL_PACKAGE_SANDBOXES" env -> return $ fromEnvMulti sandboxes | Just extra <- lookup "HASKELL_PACKAGE_SANDBOX" env -> return PackageDBs { includeUser = True , includeGlobal = True , extraDBs = [extra] } | Just sandboxes <- lookup "GHC_PACKAGE_PATH" env -> return $ fromEnvMulti sandboxes | otherwise -> do eres <- try $ getCurrentDirectory >>= Sandbox.getSandboxConfigFile >>= Sandbox.getPackageDbDir return $ case eres :: Either SomeException FilePath of Left _ -> PackageDBs True True [] Right db -> PackageDBs False True [db] where fromEnvMulti s = PackageDBs { includeUser = False , includeGlobal = global , extraDBs = splitSearchPath s' } where (s', global) = case reverse s of c:rest | c == searchPathSeparator -> (reverse rest, True) _ -> (s, False) -- | Get the package DB flags for the current GHC version and from the -- environment. getPackageDBArgs :: IO [String] getPackageDBArgs = do dbs <- getPackageDBsFromEnv return $ dbArgs buildArgStyle dbs doctest-0.16.0.1/src/Util.hs0000644000000000000000000000131313351740625013634 0ustar0000000000000000module 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-0.16.0.1/src/Sandbox.hs0000644000000000000000000000575313351740625014331 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns #-} module Sandbox ( getSandboxArguments , getPackageDbDir , getSandboxConfigFile ) where #if __GLASGOW_HASKELL__ < 710 import Data.Functor ((<$>)) #endif import Control.Exception as E (catch, SomeException, throwIO) import Data.Char (isSpace) import Data.List (isPrefixOf, tails) import System.Directory (getCurrentDirectory, doesFileExist) import System.FilePath ((), takeDirectory, takeFileName) configFile :: String configFile = "cabal.sandbox.config" pkgDbKey :: String pkgDbKey = "package-db:" pkgDbKeyLen :: Int pkgDbKeyLen = length pkgDbKey getSandboxArguments :: IO [String] getSandboxArguments = (sandboxArguments <$> getPkgDb) `E.catch` handler where getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir handler :: SomeException -> IO [String] handler _ = return [] -- | Find a sandbox config file by tracing ancestor directories. -- Exception is thrown if not found getSandboxConfigFile :: FilePath -> IO FilePath getSandboxConfigFile dir = do let cfile = dir configFile exist <- doesFileExist cfile if exist then return cfile else do let dir' = takeDirectory dir if dir == dir' then throwIO $ userError "sandbox config file not found" else getSandboxConfigFile dir' -- | Extract a package db directory from the sandbox config file. -- Exception is thrown if the sandbox config file is broken. getPackageDbDir :: FilePath -> IO FilePath getPackageDbDir sconf = do -- Be strict to ensure that an error can be caught. !path <- extractValue . parse <$> readFile sconf return path where parse = head . filter ("package-db:" `isPrefixOf`) . lines extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen -- | Adding necessary GHC options to the package db. -- Exception is thrown if the string argument is incorrect. -- -- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" -- ["-no-user-package-db","-package-db","/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"] -- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d" -- ["-no-user-package-conf","-package-conf","/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"] sandboxArguments :: FilePath -> [String] sandboxArguments pkgDb = [noUserPkgDbOpt, pkgDbOpt, pkgDb] where ver = extractGhcVer pkgDb (pkgDbOpt,noUserPkgDbOpt) | ver < 706 = ("-package-conf","-no-user-package-conf") | otherwise = ("-package-db", "-no-user-package-db") -- | Extracting GHC version from the path of package db. -- Exception is thrown if the string argument is incorrect. -- -- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" -- 706 extractGhcVer :: String -> Int extractGhcVer dir = ver where file = takeFileName dir findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails (verStr1,_:left) = break (== '.') $ findVer file (verStr2,_) = break (== '.') left ver = read verStr1 * 100 + read verStr2 doctest-0.16.0.1/src/Options.hs0000644000000000000000000000675113351740625014365 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} module Options ( Result(..) , Run(..) , defaultMagic , defaultFastMode , defaultPreserveIt , defaultVerbose , parseOptions #ifdef TEST , usage , info , versionInfo #endif ) where import Prelude () import Prelude.Compat import Data.List.Compat import Data.Maybe import qualified Paths_doctest import Data.Version (showVersion) import Config as GHC import Interpreter (ghc) usage :: String usage = unlines [ "Usage:" , " doctest [ --fast | --preserve-it | --no-magic | --verbose | GHC OPTION | MODULE ]..." , " doctest --help" , " doctest --version" , " doctest --info" , "" , "Options:" , " --fast disable :reload between example groups" , " --preserve-it preserve the `it` variable between examples" , " --verbose print each test as it is run" , " --help display this help and exit" , " --version output version information and exit" , " --info output machine-readable version information and exit" ] version :: String version = showVersion Paths_doctest.version ghcVersion :: String ghcVersion = GHC.cProjectVersion versionInfo :: String versionInfo = unlines [ "doctest version " ++ version , "using version " ++ ghcVersion ++ " of the GHC API" , "using " ++ ghc ] info :: String info = "[ " ++ (intercalate "\n, " . map show $ [ ("version", version) , ("ghc_version", ghcVersion) , ("ghc", ghc) ]) ++ "\n]\n" data Result a = Output String | Result a deriving (Eq, Show, Functor) type Warning = String data Run = Run { runWarnings :: [Warning] , runOptions :: [String] , runMagicMode :: Bool , runFastMode :: Bool , runPreserveIt :: Bool , runVerbose :: Bool } deriving (Eq, Show) defaultMagic :: Bool defaultMagic = True defaultFastMode :: Bool defaultFastMode = False defaultPreserveIt :: Bool defaultPreserveIt = False defaultVerbose :: Bool defaultVerbose = False parseOptions :: [String] -> Result Run parseOptions args | "--help" `elem` args = Output usage | "--info" `elem` args = Output info | "--version" `elem` args = Output versionInfo | otherwise = case fmap (fmap (fmap stripOptGhc)) . fmap (fmap stripVerbose) . fmap stripPreserveIt . stripFast <$> stripNoMagic args of (magicMode, (fastMode, (preserveIt, (verbose, (warning, xs))))) -> Result (Run (maybeToList warning) xs magicMode fastMode preserveIt verbose) stripNoMagic :: [String] -> (Bool, [String]) stripNoMagic = stripFlag (not defaultMagic) "--no-magic" stripFast :: [String] -> (Bool, [String]) stripFast = stripFlag (not defaultFastMode) "--fast" stripPreserveIt :: [String] -> (Bool, [String]) stripPreserveIt = stripFlag (not defaultPreserveIt) "--preserve-it" stripVerbose :: [String] -> (Bool, [String]) stripVerbose = stripFlag (not defaultVerbose) "--verbose" stripFlag :: Bool -> String -> [String] -> (Bool, [String]) stripFlag enableIt flag args = ((flag `elem` args) == enableIt, filter (/= flag) args) stripOptGhc :: [String] -> (Maybe Warning, [String]) stripOptGhc = go where go args = case args of [] -> (Nothing, []) "--optghc" : opt : rest -> (Just warning, opt : snd (go rest)) opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (Just warning, x : xs)) (stripPrefix "--optghc=" opt) (go rest) warning = "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly." doctest-0.16.0.1/src/GhcUtil.hs0000644000000000000000000000562413351740625014267 0ustar0000000000000000{-# LANGUAGE CPP #-} module GhcUtil (withGhc) where import GHC.Paths (libdir) #if __GLASGOW_HASKELL__ < 707 import Control.Exception import GHC hiding (flags) import DynFlags (dopt_set) #else import GHC import DynFlags (gopt_set) #endif import Panic (throwGhcException) import MonadUtils (liftIO) import System.Exit (exitFailure) #if __GLASGOW_HASKELL__ < 702 import StaticFlags (v_opt_C_ready) import Data.IORef (writeIORef) #elif __GLASGOW_HASKELL__ < 707 import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) #elif __GLASGOW_HASKELL__ < 801 import StaticFlags (discardStaticFlags) #endif -- | Save static flag globals, run action, and restore them. bracketStaticFlags :: IO a -> IO a #if __GLASGOW_HASKELL__ < 702 -- GHC < 7.2 does not provide saveStaticFlagGlobals/restoreStaticFlagGlobals, -- so we need to modifying v_opt_C_ready directly bracketStaticFlags action = action `finally` writeIORef v_opt_C_ready False #elif __GLASGOW_HASKELL__ < 707 bracketStaticFlags action = bracket saveStaticFlagGlobals restoreStaticFlagGlobals (const action) #else bracketStaticFlags action = action #endif -- Catch GHC source errors, print them and exit. handleSrcErrors :: Ghc a -> Ghc a handleSrcErrors action' = flip handleSourceError action' $ \err -> do #if __GLASGOW_HASKELL__ < 702 printExceptionAndWarnings err #else printException err #endif liftIO exitFailure -- | Run a GHC action in Haddock mode withGhc :: [String] -> ([String] -> Ghc a) -> IO a withGhc flags action = bracketStaticFlags $ do flags_ <- handleStaticFlags flags runGhc (Just libdir) $ do handleDynamicFlags flags_ >>= handleSrcErrors . action handleStaticFlags :: [String] -> IO [Located String] #if __GLASGOW_HASKELL__ < 707 handleStaticFlags flags = fst `fmap` parseStaticFlags (map noLoc flags) #elif __GLASGOW_HASKELL__ < 801 handleStaticFlags flags = return $ map noLoc $ discardStaticFlags flags #else handleStaticFlags flags = return $ map noLoc $ flags #endif handleDynamicFlags :: GhcMonad m => [Located String] -> m [String] handleDynamicFlags flags = do (dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags _ <- setSessionDynFlags dynflags -- We basically do the same thing as `ghc/Main.hs` to distinguish -- "unrecognised flags" from source files. let srcs = map unLoc locSrcs unknown_opts = [ f | f@('-':_) <- srcs ] case unknown_opts of opt : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'")) _ -> return srcs setHaddockMode :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ < 707 setHaddockMode dynflags = (dopt_set dynflags Opt_Haddock) { #else setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) { #endif hscTarget = HscNothing , ghcMode = CompManager , ghcLink = NoLink } doctest-0.16.0.1/src/Runner/0000755000000000000000000000000013351740625013636 5ustar0000000000000000doctest-0.16.0.1/src/Runner/Example.hs0000644000000000000000000000410213351740625015562 0ustar0000000000000000module Runner.Example ( Result (..) , mkResult ) where import Data.Char import Data.List import Util import Parse data Result = Equal | NotEqual [String] deriving (Eq, Show) mkResult :: ExpectedResult -> [String] -> Result mkResult expected actual | expected `matches` actual = Equal | otherwise = NotEqual (formatNotEqual expected actual) where chunksMatch :: [LineChunk] -> String -> Bool chunksMatch [] "" = True chunksMatch [LineChunk xs] ys = stripEnd xs == stripEnd ys chunksMatch (LineChunk x : xs) ys = x `isPrefixOf` ys && xs `chunksMatch` drop (length x) ys chunksMatch zs@(WildCardChunk : xs) (_:ys) = xs `chunksMatch` ys || zs `chunksMatch` ys chunksMatch _ _ = False matches :: ExpectedResult -> [String] -> Bool matches (ExpectedLine x : xs) (y : ys) = x `chunksMatch` y && xs `matches` ys matches (WildCardLine : xs) ys | xs `matches` ys = True matches zs@(WildCardLine : _) (_ : ys) = zs `matches` ys matches [] [] = True matches [] _ = False matches _ [] = False formatNotEqual :: ExpectedResult -> [String] -> [String] formatNotEqual expected_ actual = formatLines "expected: " expected ++ formatLines " but got: " actual where expected :: [String] expected = map (\x -> case x of ExpectedLine str -> concatMap lineChunkToString str WildCardLine -> "..." ) expected_ -- use show to escape special characters in output lines if any output line -- contains any unsafe character escapeOutput | any (not . isSafe) (concat $ expected ++ actual) = map show | otherwise = id isSafe :: Char -> Bool isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) formatLines :: String -> [String] -> [String] formatLines message xs = case escapeOutput xs of y:ys -> (message ++ y) : map (padding ++) ys [] -> [message] where padding = replicate (length message) ' ' lineChunkToString :: LineChunk -> String lineChunkToString WildCardChunk = "..." lineChunkToString (LineChunk str) = str doctest-0.16.0.1/src/Test/0000755000000000000000000000000013351740625013304 5ustar0000000000000000doctest-0.16.0.1/src/Test/DocTest.hs0000644000000000000000000000007613351740625015210 0ustar0000000000000000module Test.DocTest ( doctest ) where import Run doctest-0.16.0.1/ghci-wrapper/0000755000000000000000000000000013351740625014166 5ustar0000000000000000doctest-0.16.0.1/ghci-wrapper/src/0000755000000000000000000000000013351740625014755 5ustar0000000000000000doctest-0.16.0.1/ghci-wrapper/src/Language/0000755000000000000000000000000013351740625016500 5ustar0000000000000000doctest-0.16.0.1/ghci-wrapper/src/Language/Haskell/0000755000000000000000000000000013351740625020063 5ustar0000000000000000doctest-0.16.0.1/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs0000644000000000000000000001072713351740625022641 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Language.Haskell.GhciWrapper ( Interpreter , Config(..) , defaultConfig , new , close , eval , evalIt , evalEcho ) where import System.IO hiding (stdin, stdout, stderr) import System.Process import System.Exit import Control.Monad import Control.Exception import Data.List import Data.Maybe data Config = Config { configGhci :: String , configVerbose :: Bool , configIgnoreDotGhci :: Bool } deriving (Eq, Show) defaultConfig :: Config defaultConfig = Config { configGhci = "ghci" , configVerbose = False , configIgnoreDotGhci = True } -- | Truly random marker, used to separate expressions. -- -- IMPORTANT: This module relies upon the fact that this marker is unique. It -- has been obtained from random.org. Do not expect this module to work -- properly, if you reuse it for any purpose! marker :: String marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1" itMarker :: String itMarker = "d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a" data Interpreter = Interpreter { hIn :: Handle , hOut :: Handle , process :: ProcessHandle } new :: Config -> [String] -> IO Interpreter new Config{..} args_ = do (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit} setMode stdin_ setMode stdout_ let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle} _ <- eval interpreter "import System.IO" _ <- eval interpreter "import GHC.IO.Handle" -- The buffering of stdout and stderr is NoBuffering _ <- eval interpreter "hDuplicateTo stdout stderr" -- Now the buffering of stderr is BlockBuffering Nothing -- In this situation, GHC 7.7 does not flush the buffer even when -- error happens. _ <- eval interpreter "hSetBuffering stdout LineBuffering" _ <- eval interpreter "hSetBuffering stderr LineBuffering" -- this is required on systems that don't use utf8 as default encoding (e.g. -- Windows) _ <- eval interpreter "hSetEncoding stdout utf8" _ <- eval interpreter "hSetEncoding stderr utf8" _ <- eval interpreter ":m - System.IO" _ <- eval interpreter ":m - GHC.IO.Handle" return interpreter where args = args_ ++ catMaybes [ if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing , if configVerbose then Nothing else Just "-v0" ] setMode h = do hSetBinaryMode h False hSetBuffering h LineBuffering hSetEncoding h utf8 close :: Interpreter -> IO () close repl = do hClose $ hIn repl -- It is crucial not to close `hOut` before calling `waitForProcess`, -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang -- around consuming 100% CPU. This happens when ghci tries to print -- something to stdout in its signal handler (e.g. when it is blocked in -- threadDelay it writes "Interrupted." on SIGINT). e <- waitForProcess $ process repl hClose $ hOut repl when (e /= ExitSuccess) $ do throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")") putExpression :: Interpreter -> Bool -> String -> IO () putExpression Interpreter{hIn = stdin} preserveIt e = do hPutStrLn stdin e when preserveIt $ hPutStrLn stdin $ "let " ++ itMarker ++ " = it" hPutStrLn stdin marker when preserveIt $ hPutStrLn stdin $ "let it = " ++ itMarker hFlush stdin getResult :: Bool -> Interpreter -> IO String getResult echoMode Interpreter{hOut = stdout} = go where go = do line <- hGetLine stdout if marker `isSuffixOf` line then do let xs = stripMarker line echo xs return xs else do echo (line ++ "\n") result <- go return (line ++ "\n" ++ result) stripMarker l = take (length l - length marker) l echo :: String -> IO () echo | echoMode = putStr | otherwise = (const $ return ()) -- | Evaluate an expression eval :: Interpreter -> String -> IO String eval repl expr = do putExpression repl False expr getResult False repl -- | Like 'eval', but try to preserve the @it@ variable evalIt :: Interpreter -> String -> IO String evalIt repl expr = do putExpression repl True expr getResult False repl -- | Evaluate an expression evalEcho :: Interpreter -> String -> IO String evalEcho repl expr = do putExpression repl True expr getResult True repl