├── .ghci ├── .gitattributes ├── .github └── workflows │ ├── build.yml │ ├── cabal-doctest.yml │ └── publish.yml ├── .gitignore ├── .mailmap ├── CHANGES.markdown ├── KNOWN_ISSUES ├── LICENSE ├── README.md ├── README.template.md ├── Setup.lhs ├── api ├── Test.DocTest ├── Test.DocTest.Internal.Extract ├── Test.DocTest.Internal.Location ├── Test.DocTest.Internal.Parse └── Test.DocTest.Internal.Run ├── bash_completion.d └── doctest-haskell ├── cabal.project ├── doc ├── Makefile ├── README.template.md └── example │ ├── cabal.project │ ├── fib.cabal │ └── src │ └── Fib.hs ├── doctest.cabal ├── driver ├── cabal-doctest.hs └── doctest.hs ├── example ├── example.cabal ├── src │ └── Example.hs └── test │ └── doctests.hs ├── hie.yaml ├── package.yaml ├── src ├── Cabal.hs ├── Cabal │ ├── Options.hs │ ├── Paths.hs │ └── ReplOptions.hs ├── Extract.hs ├── GhcUtil.hs ├── Imports.hs ├── Info.hs ├── Interpreter.hs ├── Language │ └── Haskell │ │ └── GhciWrapper.hs ├── Location.hs ├── Options.hs ├── PackageDBs.hs ├── Parse.hs ├── Property.hs ├── Run.hs ├── Runner.hs ├── Runner │ └── Example.hs ├── Test │ ├── DocTest.hs │ └── DocTest │ │ └── Internal │ │ ├── Cabal.hs │ │ ├── Extract.hs │ │ ├── Location.hs │ │ ├── Parse.hs │ │ └── Run.hs └── Util.hs └── test ├── Cabal ├── OptionsSpec.hs ├── PathsSpec.hs └── ReplOptionsSpec.hs ├── ExtractSpec.hs ├── InfoSpec.hs ├── InterpreterSpec.hs ├── Language └── Haskell │ └── GhciWrapperSpec.hs ├── LocationSpec.hs ├── MainSpec.hs ├── OptionsSpec.hs ├── PackageDBsSpec.hs ├── ParseSpec.hs ├── PropertySpec.hs ├── RunSpec.hs ├── Runner └── ExampleSpec.hs ├── RunnerSpec.hs ├── Spec.hs ├── UtilSpec.hs ├── extract ├── argument-list │ └── Foo.hs ├── comment-order │ └── Foo.hs ├── declaration │ └── Foo.hs ├── dos-line-endings │ └── Foo.hs ├── export-list │ └── Foo.hs ├── imported-module │ ├── Bar.hs │ └── Baz.hs ├── module-header │ └── Foo.hs ├── named-chunks │ └── Foo.hs ├── regression │ ├── Fixity.hs │ ├── ForeignImport.hs │ ├── ParallelListComp.hs │ ├── ParallelListCompClass.hs │ ├── RewriteRules.hs │ └── RewriteRulesWithSigs.hs ├── setup │ └── Foo.hs ├── th │ ├── Bar.hs │ └── Foo.hs ├── type-class-args │ └── Foo.hs ├── type-class │ └── Foo.hs └── type-families │ └── Foo.hs ├── integration ├── bugfixImportHierarchical │ ├── ModuleA.hs │ └── ModuleB.hs ├── bugfixMultipleModules │ ├── ModuleA.hs │ └── ModuleB.hs ├── bugfixOutputToStdErr │ └── Fib.hs ├── bugfixWorkingDirectory │ ├── Fib.hs │ ├── description │ └── examples │ │ └── Fib.hs ├── color │ └── Foo.hs ├── custom-package-conf │ ├── Bar.hs │ └── foo │ │ ├── Foo.hs │ │ └── doctest-foo.cabal ├── dos-line-endings │ └── Fib.hs ├── fail-fast │ ├── Bar.hs │ ├── Foo.hs │ ├── SetupBar.hs │ └── SetupFoo.hs ├── failing-multiple │ └── Foo.hs ├── failing │ └── Foo.hs ├── it │ ├── Foo.hs │ └── Setup.hs ├── local-stderr-binding │ └── A.hs ├── multiline │ └── Multiline.hs ├── parse-error │ └── Foo.hs ├── property-bool-with-type-signature │ └── Foo.hs ├── property-bool │ └── Foo.hs ├── property-failing │ └── Foo.hs ├── property-implicitly-quantified │ └── Foo.hs ├── property-quantified │ └── Foo.hs ├── property-setup │ └── Foo.hs ├── setup-skip-on-failure │ └── Foo.hs ├── setup │ └── Foo.hs ├── system-io-imported │ └── A.hs ├── template-haskell-bugfix │ ├── Main.hs │ └── Printf.hs ├── template-haskell │ └── Foo.hs ├── test-options │ └── Foo.hs ├── testBlankline │ └── Fib.hs ├── testCPP │ └── Foo.hs ├── testCombinedExample │ └── Fib.hs ├── testCommentLocation │ └── Foo.hs ├── testDocumentationForArguments │ └── Fib.hs ├── testFailOnMultiline │ └── Fib.hs ├── testImport │ ├── ModuleA.hs │ └── ModuleB.hs ├── testPutStr │ └── Fib.hs ├── testSimple │ └── Fib.hs ├── trailing-whitespace │ └── Foo.hs └── with-cbits │ ├── Bar.hs │ └── foo.c └── parse ├── multiple-examples └── Foo.hs ├── no-examples └── Fib.hs ├── non-exported └── Fib.hs ├── property └── Fib.hs ├── setup-empty └── Foo.hs ├── setup-only └── Foo.hs └── simple └── Fib.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -DTEST -isrc -itest -packageghc -XHaskell2010 2 | :set -XNamedFieldPuns 3 | :set -XRecordWildCards 4 | :set -XDeriveFunctor 5 | :set -XNoImplicitPrelude 6 | :set -fno-warn-x-partial 7 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | /doctest.cabal linguist-generated=true 2 | /ghci-wrapper/ghci-wrapper.cabal linguist-generated=true 3 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | concurrency: 4 | group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} 5 | cancel-in-progress: true 6 | 7 | on: 8 | push: 9 | branches: 10 | - main 11 | pull_request: 12 | branches: 13 | - main 14 | schedule: 15 | - cron: 0 0 * * * 16 | 17 | jobs: 18 | build: 19 | name: ${{ matrix.os }} / GHC ${{ matrix.ghc }} 20 | runs-on: ${{ matrix.os }} 21 | 22 | strategy: 23 | fail-fast: true 24 | matrix: 25 | os: 26 | - ubuntu-22.04 27 | ghc: 28 | - 8.2.2 29 | - 8.4.1 30 | - 8.4.2 31 | - 8.4.3 32 | - 8.4.4 33 | - 8.6.1 34 | - 8.6.2 35 | - 8.6.3 36 | - 8.6.4 37 | - 8.6.5 38 | - 8.8.1 39 | - 8.8.2 40 | - 8.8.3 41 | - 8.8.4 42 | - 8.10.1 43 | - 8.10.2 44 | - 8.10.3 45 | - 8.10.4 46 | - 8.10.5 47 | - 8.10.6 48 | - 8.10.7 49 | # - 9.0.1 50 | # - 9.0.2 51 | # - 9.2.1 52 | - 9.2.2 53 | - 9.2.3 54 | - 9.2.4 55 | - 9.2.5 56 | - 9.2.6 57 | - 9.2.7 58 | - 9.2.8 59 | - 9.4.1 60 | - 9.4.2 61 | - 9.4.3 62 | - 9.4.4 63 | - 9.4.5 64 | - 9.4.6 65 | - 9.4.7 66 | - 9.4.8 67 | # - 9.6.1 68 | - 9.6.2 69 | - 9.6.3 70 | - 9.6.4 71 | - 9.6.5 72 | - 9.6.6 73 | - 9.8.1 74 | - 9.8.2 75 | - 9.8.4 76 | - 9.10.1 77 | - 9.12.1 78 | include: 79 | - os: macos-latest 80 | ghc: 9.10.1 81 | - os: windows-latest 82 | # ghc: system 83 | ghc: 9.6.2 84 | steps: 85 | - uses: actions/checkout@v4 86 | - uses: hspec/setup-haskell@v1 87 | with: 88 | ghc-version: ${{ matrix.ghc }} 89 | 90 | - run: cabal update 91 | - run: cabal build 92 | - run: cabal exec "$(cabal list-bin spec)" 93 | - run: cabal install 94 | - run: cabal repl --with-compiler=doctest 95 | 96 | success: 97 | needs: build 98 | runs-on: ubuntu-latest 99 | if: always() # this is required as GitHub considers "skipped" jobs as "passed" when checking branch protection rules 100 | 101 | steps: 102 | - run: false 103 | if: needs.build.result != 'success' 104 | 105 | - uses: actions/checkout@v4 106 | - run: curl -sSL https://raw.githubusercontent.com/sol/hpack/main/get-hpack.sh | bash 107 | - run: hpack && git diff --color --exit-code 108 | -------------------------------------------------------------------------------- /.github/workflows/cabal-doctest.yml: -------------------------------------------------------------------------------- 1 | name: cabal-doctest 2 | 3 | concurrency: 4 | group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} 5 | cancel-in-progress: true 6 | 7 | on: 8 | push: 9 | branches: 10 | - main 11 | pull_request: 12 | branches: 13 | - main 14 | schedule: 15 | - cron: 0 0 * * * 16 | 17 | jobs: 18 | build: 19 | runs-on: ${{ matrix.os }} 20 | 21 | strategy: 22 | fail-fast: false 23 | matrix: 24 | os: 25 | - ubuntu-latest 26 | - macos-13 27 | - windows-latest 28 | 29 | steps: 30 | - uses: actions/checkout@v4 31 | 32 | - uses: hspec/setup-haskell@v1 33 | with: 34 | ghc-version: 9.10.1 35 | if: matrix.os == 'macos-13' 36 | 37 | - run: ghcup install ghc 9.6 --no-set 38 | - run: ghcup install ghc 8.6.5 --no-set 39 | 40 | - run: cabal --version 41 | - run: cabal path 42 | - run: cabal update 43 | - run: cabal install -f cabal-doctest 44 | - run: cabal doctest --allow-newer=False 45 | 46 | - run: cabal doctest -w ghc-9.6 47 | - run: cabal doctest -w ghc-8.6.5 48 | 49 | cabal-doctest-success: 50 | needs: build 51 | runs-on: ubuntu-latest 52 | if: always() # this is required as GitHub considers "skipped" jobs as "passed" when checking branch protection rules 53 | 54 | steps: 55 | - run: false 56 | if: needs.build.result != 'success' 57 | -------------------------------------------------------------------------------- /.github/workflows/publish.yml: -------------------------------------------------------------------------------- 1 | name: publish 2 | 3 | permissions: 4 | contents: write 5 | 6 | on: 7 | push: 8 | branches: 9 | - main 10 | 11 | jobs: 12 | publish: 13 | runs-on: ubuntu-latest 14 | steps: 15 | - uses: actions/checkout@v4 16 | 17 | - run: cabal check 18 | 19 | - uses: sol/haskell-autotag@v1 20 | id: autotag 21 | with: 22 | prefix: null 23 | 24 | - run: cabal sdist 25 | 26 | - uses: haskell-actions/hackage-publish@v1.1 27 | with: 28 | hackageToken: ${{ secrets.HACKAGE_AUTH_TOKEN }} 29 | publish: true 30 | if: steps.autotag.outputs.created 31 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | /.stack-work/ 3 | /ghci-wrapper/.stack-work/ 4 | /doc/gh-md-toc 5 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | Adam Vogt 2 | Veronika Romashkina 3 | -------------------------------------------------------------------------------- /CHANGES.markdown: -------------------------------------------------------------------------------- 1 | Changes in 0.24.0 2 | - cabal-doctest: Add support for cabal-install 3.14.* 3 | 4 | Changes in 0.23.0 5 | - Add `--fail-fast` 6 | 7 | Changes in 0.22.10 8 | - Make progress reporting more robust 9 | 10 | Changes in 0.22.9 11 | - Use `-fprint-error-index-links=never` for GHC `>=9.10` 12 | 13 | Changes in 0.22.8 14 | - cabal-doctest: Fix handling of options with optional arguments 15 | 16 | Changes in 0.22.7 17 | - cabal-doctest: Accept component 18 | - cabal-doctest: Get rid of separate `cabal build` step 19 | - cabal-doctest: Add support for `--list-options` 20 | 21 | Changes in 0.22.6 22 | - cabal-doctest: Take `with-compiler:` from `cabal-project` into account 23 | - cabal-doctest: Add support for `--with-compiler` 24 | - cabal-doctest: Fix `ghc-pkg` discovery logic 25 | - cabal-doctest: Cache `doctest` executables 26 | 27 | Changes in 0.22.5 28 | - Add (experimental) `cabal-doctest` executable. This is guarded behind a 29 | flag for now, use `cabal install doctest -f cabal-doctest` to install it. 30 | 31 | Changes in 0.22.4 32 | - Use `-Wno-unused-packages` for GHC `8.10` / `9.0` / `9.2` 33 | 34 | Changes in 0.22.3 35 | - Use `-Wno-unused-packages` when extracting comments 36 | 37 | Changes in 0.22.2 38 | - GHC 9.8 compatibility 39 | 40 | Changes in 0.22.1 41 | - Add `Test.DocTest.Internal.Run.doctestWithRepl` 42 | 43 | Changes in 0.22.0 44 | - Export more internals 45 | 46 | Changes in 0.21.1 47 | - GHC 9.6 compatibility. 48 | 49 | Changes in 0.21.0 50 | - Accept `--fast`, `--preserve-it` and `--verbose` via `--repl-options` 51 | 52 | Changes in 0.20.1 53 | - GHC 9.4 compatibility. (#382) 54 | 55 | Changes in 0.20.0 56 | - Allow doctest to be invoked via `cabal repl --with-compiler=doctest` 57 | - Include `ghc --info` output in `--info` 58 | - Make `--info` output formatting consistent with GHC 59 | 60 | Changes in 0.19.0 61 | - Better support for `cabal v2-*` 62 | 63 | Changes in 0.18.2 64 | - GHC 9.2 compatibility. (#305, thanks to Ryan Scott and Matthew Pickering) 65 | 66 | Changes in 0.18.1 67 | - GHC 9.0 compatibility. (#275) 68 | 69 | Changes in 0.18 70 | - Don't use unqualified references to `stderr` or `stdout` which may collide with definitions in user code. (#201) 71 | - Remove support for cabal-install sandboxes. They have been obsoleted in practice by Nix-style builds in cabal-install (i.e., the `v2-*` commands) and stack. 72 | 73 | Changes in 0.17 74 | - #266: 75 | - doctest now annotates its internal marker string as a `String`, to prevent misbehaviour in `OverloadedStrings` environments. This has a theoretical chance of breakage; if you're affected, please open an issue. 76 | - `evalEcho` no longer preserves `it`. 77 | 78 | Changes in 0.16.3 79 | - Add a cursor to highlight the differing portion between the 80 | expected and actual output. (#249) 81 | - GHC 8.10 compatibility. (#247, #257) 82 | 83 | Changes in 0.16.2 84 | - Add doctest's necessary-for-operation options to GHC's command 85 | line at the end, so that they over-ride anything provided by the 86 | user. (#233) 87 | - Allow GHC 8.8. 88 | 89 | Changes in 0.16.1 90 | - Fix loading plugins in doctests. (#224) 91 | - Require QuickCheck 2.13.1 or newer. 92 | - Remove dependency on `with-location` 93 | 94 | Changes in 0.16.0.1 95 | - Bump bounds to allow GHC 8.6. (#210) 96 | 97 | Changes in 0.16.0 98 | - Output format has changed to (hopefully) be more machine consumable. (#200) 99 | 100 | Changes in 0.15.0 101 | - Add `--verbose` for printing each test as it is run 102 | 103 | Changes in 0.14.1 104 | - Add test assets to source tarball (see #189) 105 | 106 | Changes in 0.14.0 107 | - GHC 8.4 compatibility. 108 | 109 | Changes in 0.13.0 110 | - Add `--preserve-it` for allowing the `it` variable to be preserved between examples 111 | 112 | Changes in 0.12.0 113 | - Preserve the 'it' variable between examples 114 | 115 | Changes in 0.11.4 116 | - Add `--fast`, which disables running `:reload` between example groups 117 | 118 | Changes in 0.11.3 119 | - Add `--info` 120 | - Add `--no-magic` 121 | 122 | Changes in 0.11.2 123 | - Make `...` match zero lines 124 | 125 | Changes in 0.11.1 126 | - Fix an issue with Unicode output on Windows (see #149) 127 | 128 | Changes in 0.11.0 129 | - Support for GHC 8.0.1-rc2 130 | 131 | Changes in 0.10.1 132 | - Automatically expand directories into contained Haskell source files (thanks @snoyberg) 133 | - Add cabal_macros.h and autogen dir by default (thanks @snoyberg) 134 | 135 | Changes in 0.10.0 136 | - Support HASKELL_PACKAGE_SANDBOXES (thanks @snoyberg) 137 | 138 | Changes in 0.9.13 139 | - Add ellipsis as wildcard 140 | 141 | Changes in 0.9.12 142 | - Add support for GHC 7.10 143 | 144 | Changes in 0.9.11 145 | - Defaults ambiguous type variables to Integer (#74) 146 | 147 | Changes in 0.9.10 148 | - Add support for the upcoming GHC 7.8 release 149 | 150 | Changes in 0.9.9 151 | - Add support for multi-line statements 152 | 153 | Changes in 0.9.8 154 | - Support for GHC HEAD (7.7) 155 | 156 | Changes in 0.9.7 157 | - Ignore trailing whitespace when matching example output 158 | 159 | Changes in 0.9.6 160 | - Fail gracefully if GHCi is not supported (#46) 161 | 162 | Changes in 0.9.5 163 | - Fix a GHC panic with GHC 7.6.1 (#41) 164 | 165 | Changes in 0.9.4 166 | - Respect HASKELL_PACKAGE_SANDBOX (#39) 167 | - Print path to ghc on --version 168 | 169 | Changes in 0.9.3 170 | - Properly handle additional object files (#38) 171 | 172 | Changes in 0.9.2 173 | - Add support for QuickCheck properties 174 | 175 | Changes in 0.9.1 176 | - Fix an issue with GHC 7.6.1 and type families 177 | 178 | Changes in 0.9.0 179 | - Add support for setup code (see README). 180 | - There is no distinction between example/interaction anymore. Each 181 | expression is counted as an example in the summary. 182 | 183 | Changes in 0.8.0 184 | - Doctest now directly accepts arbitrary GHC options, prefixing GHC options 185 | with --optghc is no longer necessary 186 | 187 | Changes in 0.7.0 188 | - Print source location for failing tests 189 | - Output less clutter on failing examples 190 | - Expose Doctest's functionality through a very simplistic API, which can be 191 | used for cabal integration 192 | 193 | Changes in 0.6.1 194 | - Fix a parser bug with CR+LF line endings 195 | 196 | Changes in 0.6.0 197 | - Support for ghc-7.4 198 | - Doctest now comes with it's own parser and does not depend on Haddock 199 | anymore 200 | 201 | Changes in 0.5.2 202 | - Proper handling of singular/plural when printing stats 203 | - Improve handling of invalid command line options 204 | 205 | Changes in 0.5.1 206 | - Adapted for ghc-7.2 207 | 208 | Changes in 0.5.0 209 | - Print number of interactions to stderr before running tests 210 | - Exit with exitFailure on failed tests 211 | - Improve documentation 212 | - Give a useful error message if ghc is not executable 213 | -------------------------------------------------------------------------------- /KNOWN_ISSUES: -------------------------------------------------------------------------------- 1 | (1) Result lines that only contain the string "" are interpreted as 2 | empty lines. Consequently we can not test expressions that evaluates to 3 | "". Let me know if you really need this feature, and we will 4 | work something out. 5 | 6 | (2) Lines that start with ">>>" introduce a new expression. Consequently we 7 | can not test expressions that evaluate to something that starts with ">>>". 8 | Again, let me know if you really need this, and we will probably work 9 | something out. 10 | 11 | (3) Currently we do not care whether the output produced by an expression is 12 | terminated with a newline or not. So both of the following examples will 13 | pass: 14 | 15 | >>> putStr "foo" 16 | foo 17 | 18 | >>> putStrLn "foo" 19 | foo 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009-2024 Simon Hengel 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.template.md: -------------------------------------------------------------------------------- 1 | doc/README.template.md -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /api/Test.DocTest: -------------------------------------------------------------------------------- 1 | doctest :: [String] -> IO () 2 | -------------------------------------------------------------------------------- /api/Test.DocTest.Internal.Extract: -------------------------------------------------------------------------------- 1 | type Module :: * -> * 2 | data Module a = Module 3 | moduleName :: String 4 | moduleSetup :: Maybe a 5 | moduleContent :: [a] 6 | extract :: [String] -> IO [Module (doctest:Location.Located String)] 7 | -------------------------------------------------------------------------------- /api/Test.DocTest.Internal.Location: -------------------------------------------------------------------------------- 1 | type Line :: * 2 | type Line = Int 3 | type Located :: * -> * 4 | data Located a = Located Location a 5 | type Location :: * 6 | data Location 7 | | UnhelpfulLocation String 8 | | Location FilePath Line 9 | enumerate :: Location -> [Location] 10 | noLocation :: a -> Located a 11 | toLocated :: GHC.Types.SrcLoc.Located a -> Located a 12 | toLocation :: GHC.Types.SrcLoc.SrcSpan -> Location 13 | unLoc :: Located a -> a 14 | -------------------------------------------------------------------------------- /api/Test.DocTest.Internal.Parse: -------------------------------------------------------------------------------- 1 | type DocTest :: * 2 | data DocTest 3 | | Example Expression ExpectedResult 4 | | Property Expression 5 | type ExpectedLine :: * 6 | data ExpectedLine 7 | | ExpectedLine [LineChunk] 8 | | WildCardLine 9 | type ExpectedResult :: * 10 | type ExpectedResult = [ExpectedLine] 11 | type Expression :: * 12 | type Expression = String 13 | type LineChunk :: * 14 | data LineChunk 15 | | LineChunk String 16 | | WildCardChunk 17 | type Module :: * -> * 18 | data Module a = Module 19 | moduleName :: String 20 | moduleSetup :: Maybe a 21 | moduleContent :: [a] 22 | extractDocTests :: [String] -> IO [Module [doctest:Location.Located DocTest]] 23 | parseModules :: [Module (doctest:Location.Located String)] -> [Module [doctest:Location.Located DocTest]] 24 | -------------------------------------------------------------------------------- /api/Test.DocTest.Internal.Run: -------------------------------------------------------------------------------- 1 | type Config :: * 2 | data Config = Config 3 | ghcOptions :: [String] 4 | fastMode :: Bool 5 | preserveIt :: Bool 6 | verbose :: Bool 7 | repl :: (String, [String]) 8 | type Result :: * 9 | type Result = Summary 10 | type Summary :: * 11 | data Summary = Summary 12 | sExamples :: Int 13 | sTried :: Int 14 | sErrors :: Int 15 | sFailures :: Int 16 | defaultConfig :: Config 17 | doctest :: [String] -> IO () 18 | doctestWith :: Config -> IO () 19 | doctestWithRepl :: (String, [String]) -> [String] -> IO () 20 | doctestWithResult :: Config -> IO Result 21 | evaluateResult :: Result -> IO () 22 | isSuccess :: Result -> Bool 23 | runDocTests :: Config -> [doctest:Extract.Module [doctest:Location.Located doctest:Parse.DocTest]] -> IO Result 24 | -------------------------------------------------------------------------------- /bash_completion.d/doctest-haskell: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # put into /etc/bash_completion.d/ 4 | # 5 | _doctest() 6 | { 7 | local cur prev opts 8 | COMPREPLY=() 9 | cur="${COMP_WORDS[COMP_CWORD]}" 10 | prev="${COMP_WORDS[COMP_CWORD-1]}" 11 | 12 | opts='--help --version' 13 | 14 | case "${prev}" in 15 | *) 16 | ;; 17 | esac 18 | 19 | if [[ ${cur} == -* ]]; then 20 | COMPREPLY=( $(compgen -W "${opts}" -- ${cur}) ) 21 | return 0 22 | else 23 | _filedir 24 | fi 25 | } 26 | complete -F _doctest doctest 27 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | . 3 | 4 | package doctest 5 | ghc-options: -Werror 6 | 7 | tests: True 8 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | all: gh-md-toc 2 | inject < README.template.md > ../README.md 3 | 4 | gh-md-toc: 5 | wget https://raw.githubusercontent.com/ekalinin/github-markdown-toc/0ccf70d0f49b61895f64bca86793ff8cdb88ad51/gh-md-toc 6 | chmod +x $@ 7 | -------------------------------------------------------------------------------- /doc/README.template.md: -------------------------------------------------------------------------------- 1 | # Doctest: Test interactive Haskell examples 2 | 3 | `doctest` is a tool that checks 4 | [examples](https://haskell-haddock.readthedocs.io/latest/markup.html#examples) 5 | and 6 | [properties](https://haskell-haddock.readthedocs.io/latest/markup.html#properties) 7 | in Haddock comments. 8 | It is similar in spirit to the [popular Python module with the same name](https://docs.python.org/3/library/doctest.html). 9 | 10 | {{ bash gh-md-toc - < README.template.md | tail -n +2 }} 11 | 12 | # Getting started 13 | 14 | ## Installation 15 | 16 | `doctest` is available from 17 | [Hackage](https://hackage.haskell.org/package/doctest). 18 | Install it with: 19 | 20 | cabal update && cabal install --ignore-project doctest 21 | 22 | Make sure that Cabal's `bindir` is on your `PATH`. 23 | 24 | On Linux: 25 | 26 | export PATH="$(cabal -v0 path --installdir):$PATH" 27 | 28 | On Mac OS X: 29 | 30 | export PATH="$(cabal -v0 path --installdir):$PATH" 31 | 32 | On Windows: 33 | 34 | set PATH="%AppData%\cabal\bin\;%PATH%" 35 | 36 | ## A basic example 37 | 38 | Below is a small Haskell module. 39 | The module contains a Haddock comment with some examples of interaction. 40 | The examples demonstrate how the module is supposed to be used. 41 | 42 | ```haskell 43 | -- src/Fib.hs 44 | {{ cat example/src/Fib.hs }} 45 | ``` 46 | 47 | (A comment line starting with `>>>` denotes an _expression_. 48 | All comment lines following an expression denote the _result_ of that expression. 49 | Result is defined by what a 50 | [REPL](https://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop) (e.g. ghci) 51 | prints to `stdout` and `stderr` when evaluating that expression.) 52 | 53 | With `doctest` you can check whether the implementation satisfies the given 54 | examples: 55 | 56 | ``` 57 | doctest src/Fib.hs 58 | ``` 59 | 60 | 61 | # Running `doctest` for a Cabal package 62 | 63 | The easiest way to run `doctest` for a Cabal package is via `cabal repl --with-compiler=doctest`. 64 | 65 | This doesn't make a big difference for a simple package, but in more involved 66 | situations `cabal` will make sure that all dependencies are available and it 67 | will pass any required GHC options to `doctest`. 68 | 69 | A simple `.cabal` file for `Fib` looks like this: 70 | 71 | ```cabal 72 | -- fib.cabal 73 | {{ cat example/fib.cabal }} 74 | ``` 75 | 76 | With a `.cabal` file in place, it is possible to run `doctest` via `cabal repl`: 77 | 78 | ```bash 79 | $ cabal repl --with-compiler=doctest 80 | ... 81 | Examples: 2 Tried: 2 Errors: 0 Failures: 0 82 | ``` 83 | 84 | 85 | Notes: 86 | 87 | - If you use properties you need to pass `--build-depends=QuickCheck` and 88 | `--build-depends=template-haskell` to `cabal repl`. 89 | 90 | - You likely want to reset the warning strategy for `cabal repl` with 91 | `--repl-options='-w -Wdefault'`. 92 | 93 | - `doctest` always uses the version of GHC it was compiled with. Reinstalling 94 | `doctest` with `cabal install doctest --overwrite-policy=always` before each 95 | invocation ensures that it uses the same version of GHC as is on the `PATH`. 96 | 97 | - Technically, `cabal build` is not necessary. `cabal repl --with-compiler=doctest` 98 | will build any dependencies as needed. However, it's more robust to run 99 | `cabal build` first (specifically it is not a good idea to build 100 | `ghc-paths` with `--with-compiler=doctest`). 101 | 102 | So a more robust way to call `doctest` is as follows: 103 | 104 | ``` 105 | cabal install doctest --ignore-project --overwrite-policy=always && cabal build && cabal repl --build-depends=QuickCheck --build-depends=template-haskell --with-compiler=doctest --repl-options='-w -Wdefault' 106 | ``` 107 | 108 | (This is what you want to use on CI.) 109 | 110 | ## Passing `doctest` options to `cabal repl` 111 | 112 | You can pass `doctest` options like `--fast`, `--preserve-it` and `--verbose` to 113 | `cabal repl` via `--repl-options`. 114 | 115 | Example: 116 | 117 | ```bash 118 | $ cabal repl --with-compiler=doctest --repl-options=--verbose 119 | ### Started execution at src/Fib.hs:7. 120 | ### example: 121 | fib 10 122 | ### Successful! 123 | 124 | ### Started execution at src/Fib.hs:10. 125 | ### example: 126 | fib 5 127 | ### Successful! 128 | 129 | # Final summary: 130 | Examples: 2 Tried: 2 Errors: 0 Failures: 0 131 | ``` 132 | 133 | ## Cabal integration 134 | 135 | ***NOTE:*** This feature is experimental. 136 | 137 | ***NOTE:*** This feature requires `cabal-install` version 3.12 or later. 138 | 139 | 140 | ```bash 141 | $ cabal install --ignore-project doctest --flag cabal-doctest 142 | ``` 143 | 144 | ```bash 145 | $ cabal doctest 146 | Examples: 2 Tried: 2 Errors: 0 Failures: 0 147 | ``` 148 | 149 | # Writing examples and properties 150 | 151 | ## Example groups 152 | 153 | Examples from a single Haddock comment are grouped together and share the same 154 | scope. E.g. the following works: 155 | 156 | ```haskell 157 | -- | 158 | -- >>> let x = 23 159 | -- >>> x + 42 160 | -- 65 161 | ``` 162 | 163 | If an example fails, subsequent examples from the same group are skipped. E.g. 164 | for 165 | 166 | ```haskell 167 | -- | 168 | -- >>> let x = 23 169 | -- >>> let n = x + y 170 | -- >>> print n 171 | ``` 172 | 173 | `print n` is skipped, because `let n = x + y` fails (as `y` is not in scope). 174 | 175 | ### A note on performance 176 | 177 | By default, `doctest` calls `:reload` between each group to clear GHCi's scope 178 | of any local definitions. This ensures that previous examples cannot influence 179 | later ones. However, it can lead to performance penalties if you are using 180 | `doctest` in a project with many modules. One possible remedy is to pass the 181 | `--fast` flag to `doctest`, which disables calling `:reload` between groups. 182 | If `doctest`s are running too slowly, you might consider using `--fast`. 183 | (With the caveat that the order in which groups appear now matters!) 184 | 185 | However, note that due to a 186 | [bug on GHC 8.2.1 or later](https://gitlab.haskell.org/ghc/ghc/-/issues/14052), 187 | the performance of `--fast` suffers significantly when combined with the 188 | `--preserve-it` flag (which keeps the value of GHCi's `it` value between 189 | examples). 190 | 191 | ## Setup code 192 | 193 | You can put setup code in a [named chunk][named-chunks] with the name `$setup`. 194 | The setup code is run before each example group. If the setup code produces 195 | any errors/failures, all tests from that module are skipped. 196 | 197 | Here is an example: 198 | 199 | ```haskell 200 | module Foo where 201 | 202 | import Bar.Baz 203 | 204 | -- $setup 205 | -- >>> let x = 23 :: Int 206 | 207 | -- | 208 | -- >>> foo + x 209 | -- 65 210 | foo :: Int 211 | foo = 42 212 | ``` 213 | 214 | Note that you should not place setup code inbetween the module header (`module 215 | ... where`) and import declarations. GHC will not be able to parse it ([issue 216 | #167](https://github.com/sol/doctest/issues/167)). It is best to place setup 217 | code right after import declarations, but due to its declarative nature you can 218 | place it anywhere inbetween top level declarations as well. 219 | 220 | 221 | ## Multi-line input 222 | GHCi supports commands which span multiple lines, and the same syntax works for doctest: 223 | 224 | ```haskell 225 | -- | 226 | -- >>> :{ 227 | -- let 228 | -- x = 1 229 | -- y = 2 230 | -- in x + y + multiline 231 | -- :} 232 | -- 6 233 | multiline = 3 234 | ``` 235 | 236 | Note that `>>>` can be left off for the lines following the first: this is so that 237 | haddock does not strip leading whitespace. The expected output has whitespace 238 | stripped relative to the :}. 239 | 240 | Some peculiarities on the ghci side mean that whitespace at the very start is lost. 241 | This breaks the example `broken`, since the x and y aren't aligned from ghci's 242 | perspective. A workaround is to avoid leading space, or add a newline such 243 | that the indentation does not matter: 244 | 245 | ```haskell 246 | {- | >>> :{ 247 | let x = 1 248 | y = 2 249 | in x + y + works 250 | :} 251 | 6 252 | -} 253 | works = 3 254 | 255 | {- | >>> :{ 256 | let x = 1 257 | y = 2 258 | in x + y + broken 259 | :} 260 | 3 261 | -} 262 | broken = 3 263 | ``` 264 | 265 | ## Multi-line output 266 | If there are no blank lines in the output, multiple lines are handled 267 | automatically. 268 | 269 | ```haskell 270 | -- | >>> putStr "Hello\nWorld!" 271 | -- Hello 272 | -- World! 273 | ``` 274 | 275 | If however the output contains blank lines, they must be noted 276 | explicitly with ``. For example, 277 | 278 | ```haskell 279 | import Data.List ( intercalate ) 280 | 281 | -- | Double-space a paragraph. 282 | -- 283 | -- Examples: 284 | -- 285 | -- >>> let s1 = "\"Every one of whom?\"" 286 | -- >>> let s2 = "\"Every one of whom do you think?\"" 287 | -- >>> let s3 = "\"I haven't any idea.\"" 288 | -- >>> let paragraph = unlines [s1,s2,s3] 289 | -- >>> putStrLn $ doubleSpace paragraph 290 | -- "Every one of whom?" 291 | -- 292 | -- "Every one of whom do you think?" 293 | -- 294 | -- "I haven't any idea." 295 | -- 296 | doubleSpace :: String -> String 297 | doubleSpace = (intercalate "\n\n") . lines 298 | ``` 299 | 300 | ## Matching arbitrary output 301 | Any lines containing only three dots (`...`) will match one or more lines with 302 | arbitrary content. For instance, 303 | 304 | ```haskell 305 | -- | 306 | -- >>> putStrLn "foo\nbar\nbaz" 307 | -- foo 308 | -- ... 309 | -- baz 310 | ``` 311 | 312 | If a line contains three dots and additional content, the three dots will match 313 | anything *within that line*: 314 | 315 | ```haskell 316 | -- | 317 | -- >>> putStrLn "foo bar baz" 318 | -- foo ... baz 319 | ``` 320 | 321 | ## QuickCheck properties 322 | 323 | Haddock has markup support for properties. Doctest can verify properties with 324 | QuickCheck. A simple property looks like this: 325 | 326 | ```haskell 327 | -- | 328 | -- prop> \xs -> sort xs == (sort . sort) (xs :: [Int]) 329 | ``` 330 | 331 | The lambda abstraction is optional and can be omitted: 332 | 333 | ```haskell 334 | -- | 335 | -- prop> sort xs == (sort . sort) (xs :: [Int]) 336 | ``` 337 | 338 | A complete example that uses setup code is below: 339 | 340 | ```haskell 341 | module Fib where 342 | 343 | -- $setup 344 | -- >>> import Control.Applicative 345 | -- >>> import Test.QuickCheck 346 | -- >>> newtype Small = Small Int deriving Show 347 | -- >>> instance Arbitrary Small where arbitrary = Small . (`mod` 10) <$> arbitrary 348 | 349 | -- | Compute Fibonacci numbers 350 | -- 351 | -- The following property holds: 352 | -- 353 | -- prop> \(Small n) -> fib n == fib (n + 2) - fib (n + 1) 354 | fib :: Int -> Int 355 | fib 0 = 0 356 | fib 1 = 1 357 | fib n = fib (n - 1) + fib (n - 2) 358 | ``` 359 | 360 | If you see an error like the following, ensure that 361 | [QuickCheck](https://hackage.haskell.org/package/QuickCheck) is visible to 362 | `doctest` (e.g. by passing `--build-depends=QuickCheck` to `cabal repl`). 363 | 364 | ```haskell 365 | :39:3: 366 | Not in scope: ‘polyQuickCheck’ 367 | In the splice: $(polyQuickCheck (mkName "doctest_prop")) 368 | 369 | :39:3: 370 | GHC stage restriction: 371 | ‘polyQuickCheck’ is used in a top-level splice or annotation, 372 | and must be imported, not defined locally 373 | In the expression: polyQuickCheck (mkName "doctest_prop") 374 | In the splice: $(polyQuickCheck (mkName "doctest_prop")) 375 | ``` 376 | 377 | ## Hiding examples from Haddock 378 | 379 | You can put examples into [named chunks][named-chunks], and not refer to them 380 | in the export list. That way they will not be part of the generated Haddock 381 | documentation, but Doctest will still find them. 382 | 383 | ```haskell 384 | -- $ 385 | -- >>> 1 + 1 386 | -- 2 387 | ``` 388 | 389 | [named-chunks]: https://haskell-haddock.readthedocs.io/latest/markup.html#named-chunks 390 | 391 | ## Using GHC extensions 392 | 393 | There's two sets of GHC extensions involved when running Doctest: 394 | 395 | 1. The set of GHC extensions that are active when compiling the module code 396 | (excluding the doctest examples). The easiest way to specify these 397 | extensions is through [LANGUAGE pragmas][language-pragma] in your source 398 | files. 399 | 400 | 1. The set of GHC extensions that are active when executing the Doctest 401 | examples. (These are not influenced by the LANGUAGE pragmas in the file.) 402 | The recommended way to enable extensions for Doctest examples is to switch 403 | them on like this: 404 | 405 | ```haskell 406 | -- | 407 | -- >>> :seti -XTupleSections 408 | -- >>> fst' $ (1,) 2 409 | -- 1 410 | fst' :: (a, b) -> a 411 | fst' = fst 412 | ``` 413 | 414 | Alternatively you can pass any GHC options to Doctest, e.g.: 415 | 416 | doctest -XCPP Foo.hs 417 | 418 | These options will affect both the loading of the module and the execution of 419 | the Doctest examples. 420 | 421 | If you want to omit the information which language extensions are enabled from 422 | the Doctest examples you can use the method described in [Hiding examples from 423 | Haddock](#hiding-examples-from-haddock), e.g.: 424 | 425 | ```haskell 426 | -- $ 427 | -- >>> :seti -XTupleSections 428 | ``` 429 | 430 | [language-pragma]: https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/pragmas.html#language-pragma 431 | 432 | # Limitations 433 | 434 | 435 | - Doctests only works on platforms that have support for GHC's `--interactive` mode (`ghci`). 436 | 437 | 438 | - Due to [a GHC bug](https://gitlab.haskell.org/ghc/ghc/-/issues/20670), running 439 | `:set -XTemplateHaskell` within `ghci` may unload any modules that were 440 | specified on the command-line. 441 | 442 | To address this `doctest >= 0.19.0` does two things: 443 | 444 | 1. Doctest always enables `-XTemplateHaskell`. So it is safe to use Template 445 | Haskell in examples without enabling the extension explicitly. 446 | 1. Doctest filters out `-XTemplateHaskell` from single-line `:set`-statements. 447 | So it is still safe to include `:set -XTemplateHaskell` in examples for 448 | documentation purposes. It may just not work as intended in `ghci` due to 449 | that GHC bug. 450 | 451 | Doctest does not filter out `-XTemplateHaskell` from multi-line 452 | `:set`-statements. So if you e.g. use 453 | 454 | ``` 455 | >>> :{ 456 | :set -XTemplateHaskell 457 | :} 458 | ``` 459 | then you are on your own. 460 | 461 | Note that all platforms that support `--interactive` also support 462 | `-XTemplateHaskell`. So this approach does not reduce Doctest's platform 463 | support. 464 | 465 | - Modules that are rejected by `haddock` will not work with `doctest`. This 466 | can mean that `doctest` fails on input that is accepted by GHC (e.g. 467 | [#251](https://github.com/sol/doctest/issues/251)). 468 | 469 | - Doctest works best with UTF-8. If your locale is e.g. `LC_ALL=C`, you may 470 | want to invoke `doctest` with `LC_ALL=C.UTF-8`. 471 | 472 | # Doctest in the wild 473 | 474 | You can find real world examples of `Doctest` being used below: 475 | 476 | * [base Data/Maybe.hs](https://github.com/ghc/ghc/blob/669cbef03c220de43b0f88f2b2238bf3c02ed64c/libraries/base/Data/Maybe.hs#L36-L79) 477 | * [base Data/Functor.hs](https://github.com/ghc/ghc/blob/669cbef03c220de43b0f88f2b2238bf3c02ed64c/libraries/base/Data/Functor.hs#L34-L64) 478 | 479 | 480 | # Development 481 | 482 | Discuss your ideas first, ideally by opening an issue on GitHub. 483 | 484 | Add tests for new features, and make sure that the test suite passes with your 485 | changes. 486 | 487 | cabal build && cabal exec $(cabal list-bin spec) 488 | 489 | 490 | # Contributors 491 | 492 | {{ git shortlog HEAD --summary --numbered | awk -F'\t' '{print " * " $2}' | grep -v g357r6kc }} 493 | For up-to-date list, query 494 | 495 | git shortlog -s 496 | -------------------------------------------------------------------------------- /doc/example/cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | . 3 | -------------------------------------------------------------------------------- /doc/example/fib.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | name: fib 4 | version: 0.0.0 5 | build-type: Simple 6 | 7 | library 8 | build-depends: base == 4.* 9 | hs-source-dirs: src 10 | exposed-modules: Fib 11 | default-language: Haskell2010 12 | -------------------------------------------------------------------------------- /doc/example/src/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Compute Fibonacci numbers 4 | -- 5 | -- Examples: 6 | -- 7 | -- >>> fib 10 8 | -- 55 9 | -- 10 | -- >>> fib 5 11 | -- 5 12 | fib :: Int -> Int 13 | fib 0 = 0 14 | fib 1 = 1 15 | fib n = fib (n - 1) + fib (n - 2) 16 | -------------------------------------------------------------------------------- /doctest.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.38.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: doctest 8 | version: 0.24.0 9 | synopsis: Test interactive Haskell examples 10 | description: `doctest` is a tool that checks [examples](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744) 11 | and [properties](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810771856) 12 | in Haddock comments. 13 | It is similar in spirit to the [popular Python module with the same name](https://docs.python.org/3/library/doctest.html). 14 | . 15 | Documentation is at . 16 | category: Testing 17 | bug-reports: https://github.com/sol/doctest/issues 18 | homepage: https://github.com/sol/doctest#readme 19 | license: MIT 20 | license-file: LICENSE 21 | copyright: (c) 2009-2024 Simon Hengel 22 | author: Simon Hengel 23 | maintainer: Simon Hengel 24 | build-type: Simple 25 | extra-source-files: 26 | example/example.cabal 27 | example/src/Example.hs 28 | example/test/doctests.hs 29 | test/parse/multiple-examples/Foo.hs 30 | test/parse/no-examples/Fib.hs 31 | test/parse/non-exported/Fib.hs 32 | test/parse/property/Fib.hs 33 | test/parse/setup-empty/Foo.hs 34 | test/parse/setup-only/Foo.hs 35 | test/parse/simple/Fib.hs 36 | test/extract/argument-list/Foo.hs 37 | test/extract/comment-order/Foo.hs 38 | test/extract/declaration/Foo.hs 39 | test/extract/dos-line-endings/Foo.hs 40 | test/extract/export-list/Foo.hs 41 | test/extract/imported-module/Bar.hs 42 | test/extract/imported-module/Baz.hs 43 | test/extract/module-header/Foo.hs 44 | test/extract/named-chunks/Foo.hs 45 | test/extract/regression/Fixity.hs 46 | test/extract/regression/ForeignImport.hs 47 | test/extract/regression/ParallelListComp.hs 48 | test/extract/regression/ParallelListCompClass.hs 49 | test/extract/regression/RewriteRules.hs 50 | test/extract/regression/RewriteRulesWithSigs.hs 51 | test/extract/setup/Foo.hs 52 | test/extract/th/Bar.hs 53 | test/extract/th/Foo.hs 54 | test/extract/type-class-args/Foo.hs 55 | test/extract/type-class/Foo.hs 56 | test/extract/type-families/Foo.hs 57 | test/integration/bugfixImportHierarchical/ModuleA.hs 58 | test/integration/bugfixImportHierarchical/ModuleB.hs 59 | test/integration/bugfixMultipleModules/ModuleA.hs 60 | test/integration/bugfixMultipleModules/ModuleB.hs 61 | test/integration/bugfixOutputToStdErr/Fib.hs 62 | test/integration/bugfixWorkingDirectory/description 63 | test/integration/bugfixWorkingDirectory/examples/Fib.hs 64 | test/integration/bugfixWorkingDirectory/Fib.hs 65 | test/integration/color/Foo.hs 66 | test/integration/custom-package-conf/Bar.hs 67 | test/integration/custom-package-conf/foo/doctest-foo.cabal 68 | test/integration/custom-package-conf/foo/Foo.hs 69 | test/integration/dos-line-endings/Fib.hs 70 | test/integration/fail-fast/Bar.hs 71 | test/integration/fail-fast/Foo.hs 72 | test/integration/fail-fast/SetupBar.hs 73 | test/integration/fail-fast/SetupFoo.hs 74 | test/integration/failing-multiple/Foo.hs 75 | test/integration/failing/Foo.hs 76 | test/integration/it/Foo.hs 77 | test/integration/it/Setup.hs 78 | test/integration/local-stderr-binding/A.hs 79 | test/integration/multiline/Multiline.hs 80 | test/integration/parse-error/Foo.hs 81 | test/integration/property-bool-with-type-signature/Foo.hs 82 | test/integration/property-bool/Foo.hs 83 | test/integration/property-failing/Foo.hs 84 | test/integration/property-implicitly-quantified/Foo.hs 85 | test/integration/property-quantified/Foo.hs 86 | test/integration/property-setup/Foo.hs 87 | test/integration/setup-skip-on-failure/Foo.hs 88 | test/integration/setup/Foo.hs 89 | test/integration/system-io-imported/A.hs 90 | test/integration/template-haskell-bugfix/Main.hs 91 | test/integration/template-haskell-bugfix/Printf.hs 92 | test/integration/template-haskell/Foo.hs 93 | test/integration/test-options/Foo.hs 94 | test/integration/testBlankline/Fib.hs 95 | test/integration/testCombinedExample/Fib.hs 96 | test/integration/testCommentLocation/Foo.hs 97 | test/integration/testCPP/Foo.hs 98 | test/integration/testDocumentationForArguments/Fib.hs 99 | test/integration/testFailOnMultiline/Fib.hs 100 | test/integration/testImport/ModuleA.hs 101 | test/integration/testImport/ModuleB.hs 102 | test/integration/testPutStr/Fib.hs 103 | test/integration/testSimple/Fib.hs 104 | test/integration/trailing-whitespace/Foo.hs 105 | test/integration/with-cbits/Bar.hs 106 | test/integration/with-cbits/foo.c 107 | CHANGES.markdown 108 | README.md 109 | 110 | source-repository head 111 | type: git 112 | location: https://github.com/sol/doctest 113 | 114 | flag cabal-doctest 115 | description: Install (experimental) cabal-doctest executable 116 | manual: True 117 | default: False 118 | 119 | library 120 | ghc-options: -Wall 121 | hs-source-dirs: 122 | src 123 | default-extensions: 124 | NamedFieldPuns 125 | RecordWildCards 126 | DeriveFunctor 127 | NoImplicitPrelude 128 | exposed-modules: 129 | Test.DocTest 130 | Test.DocTest.Internal.Extract 131 | Test.DocTest.Internal.Location 132 | Test.DocTest.Internal.Parse 133 | Test.DocTest.Internal.Run 134 | Test.DocTest.Internal.Cabal 135 | other-modules: 136 | Cabal 137 | Cabal.Options 138 | Cabal.Paths 139 | Cabal.ReplOptions 140 | Extract 141 | GhcUtil 142 | Imports 143 | Info 144 | Interpreter 145 | Language.Haskell.GhciWrapper 146 | Location 147 | Options 148 | PackageDBs 149 | Parse 150 | Property 151 | Run 152 | Runner 153 | Runner.Example 154 | Util 155 | Paths_doctest 156 | build-depends: 157 | base >=4.7 && <5 158 | , code-page >=0.1 159 | , containers 160 | , deepseq 161 | , directory 162 | , exceptions 163 | , filepath 164 | , ghc >=8.0 && <9.14 165 | , ghc-paths >=0.1.0.9 166 | , process 167 | , syb >=0.3 168 | , temporary 169 | , transformers 170 | default-language: Haskell2010 171 | if impl(ghc >= 9.0) 172 | ghc-options: -fwarn-unused-packages 173 | if impl(ghc >= 9.8) 174 | ghc-options: -fno-warn-x-partial 175 | 176 | executable cabal-doctest 177 | main-is: driver/cabal-doctest.hs 178 | other-modules: 179 | Paths_doctest 180 | default-extensions: 181 | NamedFieldPuns 182 | RecordWildCards 183 | DeriveFunctor 184 | NoImplicitPrelude 185 | ghc-options: -Wall -threaded 186 | build-depends: 187 | base >=4.7 && <5 188 | , doctest 189 | default-language: Haskell2010 190 | if impl(ghc >= 9.0) 191 | ghc-options: -fwarn-unused-packages 192 | if impl(ghc >= 9.8) 193 | ghc-options: -fno-warn-x-partial 194 | if flag(cabal-doctest) 195 | buildable: True 196 | else 197 | buildable: False 198 | 199 | executable doctest 200 | main-is: driver/doctest.hs 201 | other-modules: 202 | Paths_doctest 203 | ghc-options: -Wall -threaded 204 | default-extensions: 205 | NamedFieldPuns 206 | RecordWildCards 207 | DeriveFunctor 208 | NoImplicitPrelude 209 | build-depends: 210 | base >=4.7 && <5 211 | , doctest 212 | default-language: Haskell2010 213 | if impl(ghc >= 9.0) 214 | ghc-options: -fwarn-unused-packages 215 | if impl(ghc >= 9.8) 216 | ghc-options: -fno-warn-x-partial 217 | 218 | test-suite spec 219 | main-is: Spec.hs 220 | other-modules: 221 | Cabal.OptionsSpec 222 | Cabal.PathsSpec 223 | Cabal.ReplOptionsSpec 224 | ExtractSpec 225 | InfoSpec 226 | InterpreterSpec 227 | Language.Haskell.GhciWrapperSpec 228 | LocationSpec 229 | MainSpec 230 | OptionsSpec 231 | PackageDBsSpec 232 | ParseSpec 233 | PropertySpec 234 | Runner.ExampleSpec 235 | RunnerSpec 236 | RunSpec 237 | UtilSpec 238 | Cabal 239 | Cabal.Options 240 | Cabal.Paths 241 | Cabal.ReplOptions 242 | Extract 243 | GhcUtil 244 | Imports 245 | Info 246 | Interpreter 247 | Language.Haskell.GhciWrapper 248 | Location 249 | Options 250 | PackageDBs 251 | Parse 252 | Property 253 | Run 254 | Runner 255 | Runner.Example 256 | Test.DocTest 257 | Test.DocTest.Internal.Cabal 258 | Test.DocTest.Internal.Extract 259 | Test.DocTest.Internal.Location 260 | Test.DocTest.Internal.Parse 261 | Test.DocTest.Internal.Run 262 | Util 263 | Paths_doctest 264 | type: exitcode-stdio-1.0 265 | ghc-options: -Wall -threaded 266 | cpp-options: -DTEST 267 | hs-source-dirs: 268 | test 269 | src 270 | default-extensions: 271 | NamedFieldPuns 272 | RecordWildCards 273 | DeriveFunctor 274 | NoImplicitPrelude 275 | c-sources: 276 | test/integration/with-cbits/foo.c 277 | build-tool-depends: 278 | hspec-discover:hspec-discover 279 | build-depends: 280 | HUnit 281 | , QuickCheck >=2.13.1 282 | , base >=4.7 && <5 283 | , code-page >=0.1 284 | , containers 285 | , deepseq 286 | , directory 287 | , exceptions 288 | , filepath 289 | , ghc >=8.0 && <9.14 290 | , ghc-paths >=0.1.0.9 291 | , hspec >=2.3.0 292 | , hspec-core >=2.3.0 293 | , mockery 294 | , process 295 | , silently >=1.2.4 296 | , stringbuilder >=0.4 297 | , syb >=0.3 298 | , temporary 299 | , transformers 300 | default-language: Haskell2010 301 | if impl(ghc >= 9.0) 302 | ghc-options: -fwarn-unused-packages 303 | if impl(ghc >= 9.8) 304 | ghc-options: -fno-warn-x-partial 305 | -------------------------------------------------------------------------------- /driver/cabal-doctest.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Prelude 4 | import qualified Test.DocTest.Internal.Cabal as Cabal 5 | import System.Environment (getArgs) 6 | 7 | main :: IO () 8 | main = getArgs >>= Cabal.doctest 9 | -------------------------------------------------------------------------------- /driver/doctest.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Prelude 4 | import Test.DocTest 5 | import System.Environment (getArgs) 6 | 7 | main :: IO () 8 | main = getArgs >>= doctest 9 | -------------------------------------------------------------------------------- /example/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >= 1.8 5 | 6 | library 7 | hs-source-dirs: src 8 | exposed-modules: Example 9 | build-depends: base 10 | 11 | test-suite doctests 12 | type: exitcode-stdio-1.0 13 | hs-source-dirs: test 14 | main-is: doctests.hs 15 | ghc-options: -threaded 16 | build-depends: base, doctest >= 0.8 17 | -------------------------------------------------------------------------------- /example/src/Example.hs: -------------------------------------------------------------------------------- 1 | module Example where 2 | 3 | -- | 4 | -- >>> foo 5 | -- 23 6 | foo = 23 7 | 8 | -- | 9 | -- >>> bar 10 | -- 42 11 | bar = 42 12 | -------------------------------------------------------------------------------- /example/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = doctest ["-isrc", "src/Example.hs"] 7 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | component: doctest:test:spec 4 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: doctest 2 | version: 0.24.0 3 | synopsis: Test interactive Haskell examples 4 | description: | 5 | `doctest` is a tool that checks [examples](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744) 6 | and [properties](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810771856) 7 | in Haddock comments. 8 | It is similar in spirit to the [popular Python module with the same name](https://docs.python.org/3/library/doctest.html). 9 | 10 | Documentation is at . 11 | category: Testing 12 | copyright: (c) 2009-2024 Simon Hengel 13 | author: Simon Hengel 14 | maintainer: Simon Hengel 15 | 16 | 17 | github: sol/doctest 18 | 19 | default-extensions: 20 | - NamedFieldPuns 21 | - RecordWildCards 22 | - DeriveFunctor 23 | - NoImplicitPrelude 24 | 25 | extra-source-files: 26 | - example/**/* 27 | - test/parse/**/* 28 | - test/extract/**/* 29 | - test/integration/**/* 30 | - CHANGES.markdown 31 | - README.md 32 | 33 | ghc-options: -Wall 34 | 35 | when: 36 | - condition: impl(ghc >= 9.0) 37 | ghc-options: -fwarn-unused-packages 38 | 39 | - condition: impl(ghc >= 9.8) 40 | ghc-options: -fno-warn-x-partial 41 | 42 | dependencies: 43 | - base >= 4.7 && < 5 44 | 45 | library: 46 | source-dirs: 47 | - src 48 | exposed-modules: 49 | - Test.DocTest 50 | - Test.DocTest.Internal.Extract 51 | - Test.DocTest.Internal.Location 52 | - Test.DocTest.Internal.Parse 53 | - Test.DocTest.Internal.Run 54 | - Test.DocTest.Internal.Cabal 55 | 56 | dependencies: &dependencies 57 | ghc: ">= 8.0 && < 9.14" 58 | syb: ">= 0.3" 59 | code-page: ">= 0.1" 60 | deepseq: 61 | directory: 62 | exceptions: 63 | filepath: 64 | process: 65 | ghc-paths: ">= 0.1.0.9" 66 | transformers: 67 | containers: 68 | temporary: 69 | 70 | flags: 71 | cabal-doctest: 72 | description: Install (experimental) cabal-doctest executable 73 | manual: true 74 | default: false 75 | 76 | executables: 77 | doctest: &doctest 78 | main: driver/doctest.hs 79 | ghc-options: -threaded 80 | dependencies: 81 | - doctest 82 | 83 | cabal-doctest: 84 | <<: *doctest 85 | main: driver/cabal-doctest.hs 86 | when: 87 | condition: flag(cabal-doctest) 88 | then: 89 | buildable: true 90 | else: 91 | buildable: false 92 | 93 | tests: 94 | spec: 95 | build-tools: hspec-discover 96 | main: Spec.hs 97 | ghc-options: -threaded 98 | cpp-options: -DTEST 99 | source-dirs: 100 | - test 101 | - src 102 | c-sources: test/integration/with-cbits/foo.c 103 | dependencies: 104 | <<: *dependencies 105 | HUnit: 106 | hspec: ">= 2.3.0" 107 | hspec-core: ">= 2.3.0" 108 | QuickCheck: ">= 2.13.1" 109 | stringbuilder: ">= 0.4" 110 | silently: ">= 1.2.4" 111 | mockery: 112 | -------------------------------------------------------------------------------- /src/Cabal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Cabal (externalCommand) where 3 | 4 | import Imports 5 | 6 | import Data.List 7 | import Data.Version (makeVersion) 8 | import System.IO 9 | import System.IO.Temp 10 | import System.Environment 11 | import System.Directory 12 | import System.FilePath 13 | import System.Process 14 | 15 | import qualified Info 16 | import Cabal.Paths 17 | import Cabal.Options 18 | 19 | externalCommand :: [String] -> IO () 20 | externalCommand args = do 21 | lookupEnv "CABAL" >>= \ case 22 | Nothing -> run "cabal" args 23 | Just cabal -> run cabal (drop 1 args) 24 | 25 | run :: String -> [String] -> IO () 26 | run cabal args = do 27 | rejectUnsupportedOptions args 28 | 29 | Paths{..} <- paths cabal (discardReplOptions args) 30 | 31 | let 32 | doctest = cache "doctest" <> "-" <> Info.version 33 | script = cache "init-ghci-" <> Info.version 34 | 35 | doesFileExist doctest >>= \ case 36 | True -> pass 37 | False -> callProcess cabal [ 38 | "install" , "doctest-" <> Info.version 39 | , "--flag", "-cabal-doctest" 40 | , "--ignore-project" 41 | , "--installdir", cache 42 | , "--program-suffix", "-" <> Info.version 43 | , "--install-method=copy" 44 | , "--with-compiler", ghc 45 | ] 46 | 47 | doesFileExist script >>= \ case 48 | True -> pass 49 | False -> writeFileAtomically script ":seti -w -Wdefault" 50 | 51 | callProcess doctest ["--version"] 52 | 53 | let 54 | repl extraArgs = call cabal ("repl" 55 | : "--build-depends=QuickCheck" 56 | : "--build-depends=template-haskell" 57 | : ("--repl-options=-ghci-script=" <> script) 58 | : args ++ extraArgs) 59 | 60 | case ghcVersion < makeVersion [9,4] of 61 | True -> do 62 | callProcess cabal ("build" : "--only-dependencies" : discardReplOptions args) 63 | repl ["--with-compiler", doctest, "--with-hc-pkg", ghcPkg] 64 | 65 | False -> do 66 | withSystemTempDirectory "cabal-doctest" $ \ dir -> do 67 | repl ["--keep-temp-files", "--repl-multi-file", dir] 68 | files <- filter (isSuffixOf "-inplace") <$> listDirectory dir 69 | options <- concat <$> mapM (fmap lines . readFile . combine dir) files 70 | call doctest ("--no-magic" : options) 71 | 72 | writeFileAtomically :: FilePath -> String -> IO () 73 | writeFileAtomically name contents = do 74 | (tmp, h) <- openTempFile (takeDirectory name) (takeFileName name) 75 | hPutStr h contents 76 | hClose h 77 | renameFile tmp name 78 | -------------------------------------------------------------------------------- /src/Cabal/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Cabal.Options ( 4 | rejectUnsupportedOptions 5 | , discardReplOptions 6 | 7 | #ifdef TEST 8 | , replOnlyOptions 9 | #endif 10 | ) where 11 | 12 | import Imports 13 | 14 | import System.Exit 15 | import System.Console.GetOpt 16 | 17 | import Data.Set (Set) 18 | import qualified Data.Set as Set 19 | 20 | import qualified Cabal.ReplOptions as Repl 21 | 22 | replOnlyOptions :: Set String 23 | replOnlyOptions = Set.fromList [ 24 | "-z" 25 | , "--ignore-project" 26 | , "--repl-no-load" 27 | , "--repl-options" 28 | , "--repl-multi-file" 29 | , "-b" 30 | , "--build-depends" 31 | , "--no-transitive-deps" 32 | , "--enable-multi-repl" 33 | , "--disable-multi-repl" 34 | , "--keep-temp-files" 35 | ] 36 | 37 | rejectUnsupportedOptions :: [String] -> IO () 38 | rejectUnsupportedOptions args = case getOpt' Permute options args of 39 | (xs, _, _, _) | ListOptions `elem` xs -> do 40 | let 41 | names :: [String] 42 | names = concat [map (\ c -> ['-', c]) short ++ map ("--" <> ) long | Option short long _ _ <- documentedOptions] 43 | putStr (unlines names) 44 | exitSuccess 45 | (_, _, unsupported : _, _) -> do 46 | die $ "Error: cabal: unrecognized 'doctest' option `" <> unsupported <> "'" 47 | _ -> pass 48 | 49 | data Argument = Argument String (Maybe String) | ListOptions 50 | deriving (Eq, Show) 51 | 52 | options :: [OptDescr Argument] 53 | options = 54 | Option [] ["list-options"] (NoArg ListOptions) "" 55 | : documentedOptions 56 | 57 | documentedOptions :: [OptDescr Argument] 58 | documentedOptions = map toOptDescr Repl.options 59 | where 60 | toOptDescr :: Repl.Option -> OptDescr Argument 61 | toOptDescr (Repl.Option long short arg help) = Option (maybeToList short) [long] (toArgDescr long arg) help 62 | 63 | toArgDescr :: String -> Repl.Argument -> ArgDescr Argument 64 | toArgDescr long = \ case 65 | Repl.Argument name -> ReqArg (argument . Just) name 66 | Repl.NoArgument -> NoArg (argument Nothing) 67 | Repl.OptionalArgument name -> OptArg argument name 68 | where 69 | argument :: Maybe String -> Argument 70 | argument value = Argument ("--" <> long) value 71 | 72 | discardReplOptions :: [String] -> [String] 73 | discardReplOptions args = case getOpt Permute options args of 74 | (xs, _, _) -> [renderArgument name value | Argument name value <- xs, Set.notMember name replOnlyOptions] 75 | where 76 | renderArgument name = \ case 77 | Nothing -> name 78 | Just value -> name <> "=" <> value 79 | -------------------------------------------------------------------------------- /src/Cabal/Paths.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE StrictData #-} 4 | module Cabal.Paths ( 5 | Paths(..) 6 | , paths 7 | ) where 8 | 9 | import Imports 10 | 11 | import Data.Char 12 | import Data.Tuple 13 | import Data.Version hiding (parseVersion) 14 | import qualified Data.Version as Version 15 | import System.Exit hiding (die) 16 | import System.Directory 17 | import System.FilePath 18 | import System.IO 19 | import System.Process 20 | import Text.ParserCombinators.ReadP 21 | 22 | data Paths = Paths { 23 | ghcVersion :: Version 24 | , ghc :: FilePath 25 | , ghcPkg :: FilePath 26 | , cache :: FilePath 27 | } deriving (Eq, Show) 28 | 29 | paths :: FilePath -> [String] -> IO Paths 30 | paths cabal args = do 31 | cabalVersion <- strip <$> readProcess cabal ["--numeric-version"] "" 32 | 33 | let 34 | required :: Version 35 | required = makeVersion [3, 12] 36 | 37 | when (parseVersion cabalVersion < Just required) $ do 38 | die $ "'cabal-install' version " <> showVersion required <> " or later is required, but 'cabal --numeric-version' returned " <> cabalVersion <> "." 39 | 40 | values <- parseFields <$> readProcess cabal ("path" : args ++ ["-v0"]) "" 41 | 42 | let 43 | getPath :: String -> String -> IO FilePath 44 | getPath subject key = case lookup key values of 45 | Nothing -> die $ "Cannot determine the path to " <> subject <> ". Running 'cabal path' did not return a value for '" <> key <> "'." 46 | Just path -> canonicalizePath path 47 | 48 | ghc <- getPath "'ghc'" "compiler-path" 49 | 50 | ghcVersionString <- strip <$> readProcess ghc ["--numeric-version"] "" 51 | 52 | ghcVersion <- case parseVersion ghcVersionString of 53 | Nothing -> die $ "Cannot determine GHC version from '" <> ghcVersionString <> "'." 54 | Just version -> return version 55 | 56 | let 57 | ghcPkg :: FilePath 58 | ghcPkg = takeDirectory ghc "ghc-pkg-" <> ghcVersionString 59 | #ifdef mingw32_HOST_OS 60 | <.> "exe" 61 | #endif 62 | 63 | doesFileExist ghcPkg >>= \ case 64 | True -> pass 65 | False -> die $ "Cannot determine the path to 'ghc-pkg' from '" <> ghc <> "'. File '" <> ghcPkg <> "' does not exist." 66 | 67 | abi <- strip <$> readProcess ghcPkg ["--no-user-package-db", "field", "base", "abi", "--simple-output"] "" 68 | 69 | cache_home <- getPath "Cabal's cache directory" "cache-home" 70 | let cache = cache_home "doctest" "ghc-" <> ghcVersionString <> "-" <> abi 71 | 72 | createDirectoryIfMissing True cache 73 | 74 | return Paths { 75 | ghcVersion 76 | , ghc 77 | , ghcPkg 78 | , cache 79 | } 80 | where 81 | parseFields :: String -> [(String, FilePath)] 82 | parseFields = map parseField . lines 83 | 84 | parseField :: String -> (String, FilePath) 85 | parseField input = case break (== ':') input of 86 | (key, ':' : value) -> (key, dropWhile isSpace value) 87 | (key, _) -> (key, "") 88 | 89 | die :: String -> IO a 90 | die message = do 91 | hPutStrLn stderr "Error: [cabal-doctest]" 92 | hPutStrLn stderr message 93 | exitFailure 94 | 95 | parseVersion :: String -> Maybe Version 96 | parseVersion = lookup "" . map swap . readP_to_S Version.parseVersion 97 | -------------------------------------------------------------------------------- /src/Extract.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Extract (Module(..), extract) where 3 | 4 | import Imports hiding (mod, concat) 5 | import Data.List (partition, isSuffixOf) 6 | 7 | import Control.DeepSeq (deepseq, NFData(rnf)) 8 | import Data.Generics 9 | 10 | #if __GLASGOW_HASKELL__ < 900 11 | import GHC hiding (Module, Located) 12 | import DynFlags 13 | import MonadUtils (liftIO) 14 | #else 15 | import GHC hiding (Module, Located) 16 | import GHC.Driver.Session 17 | import GHC.Utils.Monad (liftIO) 18 | #endif 19 | 20 | #if __GLASGOW_HASKELL__ < 900 21 | import Digraph (flattenSCCs) 22 | import Exception (ExceptionMonad) 23 | #else 24 | import GHC.Data.Graph.Directed (flattenSCCs) 25 | import GHC.Utils.Exception (ExceptionMonad) 26 | import Control.Monad.Catch (generalBracket) 27 | #endif 28 | 29 | import System.Directory 30 | import System.FilePath 31 | 32 | #if __GLASGOW_HASKELL__ < 805 33 | import FastString (unpackFS) 34 | #endif 35 | 36 | import System.Posix.Internals (c_getpid) 37 | 38 | import GhcUtil (withGhc) 39 | import Location hiding (unLoc) 40 | 41 | import Util (convertDosLineEndings) 42 | import PackageDBs (getPackageDBArgs) 43 | 44 | #if __GLASGOW_HASKELL__ >= 806 45 | #if __GLASGOW_HASKELL__ < 900 46 | import DynamicLoading (initializePlugins) 47 | #else 48 | import GHC.Runtime.Loader (initializePlugins) 49 | #endif 50 | #endif 51 | 52 | #if __GLASGOW_HASKELL__ >= 901 53 | import GHC.Unit.Module.Graph 54 | #endif 55 | 56 | -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. 57 | newtype ExtractError = ExtractError SomeException 58 | #if __GLASGOW_HASKELL__ < 912 59 | deriving Typeable 60 | #endif 61 | 62 | instance Show ExtractError where 63 | show (ExtractError e) = 64 | unlines [ 65 | "Ouch! Hit an error thunk in GHC's AST while extracting documentation." 66 | , "" 67 | , " " ++ msg 68 | , "" 69 | , "This is most likely a bug in doctest." 70 | , "" 71 | , "Please report it here: https://github.com/sol/doctest/issues/new" 72 | ] 73 | where 74 | msg = case fromException e of 75 | Just (Panic s) -> "GHC panic: " ++ s 76 | _ -> show e 77 | 78 | instance Exception ExtractError 79 | 80 | -- | Documentation for a module grouped together with the modules name. 81 | data Module a = Module { 82 | moduleName :: String 83 | , moduleSetup :: Maybe a 84 | , moduleContent :: [a] 85 | } deriving (Eq, Show, Functor) 86 | 87 | instance NFData a => NFData (Module a) where 88 | rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` () 89 | 90 | #if __GLASGOW_HASKELL__ < 803 91 | type GhcPs = RdrName 92 | #endif 93 | 94 | #if __GLASGOW_HASKELL__ < 805 95 | addQuoteInclude :: [String] -> [String] -> [String] 96 | addQuoteInclude includes new = new ++ includes 97 | #endif 98 | 99 | -- | Parse a list of modules. 100 | parse :: [String] -> IO [ParsedModule] 101 | parse args = withGhc args $ \modules_ -> withTempOutputDir $ do 102 | 103 | -- ignore additional object files 104 | let modules = filter (not . isSuffixOf ".o") modules_ 105 | 106 | setTargets =<< forM modules (\ m -> guessTarget m 107 | #if __GLASGOW_HASKELL__ >= 903 108 | Nothing 109 | #endif 110 | Nothing) 111 | mods <- depanal [] False 112 | 113 | let sortedMods = flattenSCCs 114 | #if __GLASGOW_HASKELL__ >= 901 115 | $ filterToposortToModules 116 | #endif 117 | $ topSortModuleGraph False mods Nothing 118 | reverse <$> mapM (loadModPlugins >=> parseModule) sortedMods 119 | where 120 | 121 | -- copied from Haddock/GhcUtils.hs 122 | modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () 123 | modifySessionDynFlags f = do 124 | dflags <- getSessionDynFlags 125 | -- GHCi 7.7 now uses dynamic linking. 126 | let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of 127 | Just "YES" -> gopt_set dflags Opt_BuildDynamicToo 128 | _ -> dflags 129 | _ <- setSessionDynFlags (f dflags') 130 | return () 131 | 132 | withTempOutputDir :: Ghc a -> Ghc a 133 | withTempOutputDir action = do 134 | tmp <- liftIO getTemporaryDirectory 135 | x <- liftIO c_getpid 136 | let dir = tmp ".doctest-" ++ show x 137 | modifySessionDynFlags (setOutputDir dir) 138 | gbracket_ 139 | (liftIO $ createDirectory dir) 140 | (liftIO $ removeDirectoryRecursive dir) 141 | action 142 | 143 | -- | A variant of 'gbracket' where the return value from the first computation 144 | -- is not required. 145 | gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c 146 | #if __GLASGOW_HASKELL__ < 900 147 | gbracket_ before_ after thing = gbracket before_ (const after) (const thing) 148 | #else 149 | gbracket_ before_ after thing = fst <$> generalBracket before_ (\ _ _ -> after) (const thing) 150 | #endif 151 | 152 | setOutputDir f d = d { 153 | objectDir = Just f 154 | , hiDir = Just f 155 | , stubDir = Just f 156 | , includePaths = addQuoteInclude (includePaths d) [f] 157 | } 158 | 159 | #if __GLASGOW_HASKELL__ >= 806 160 | -- Since GHC 8.6, plugins are initialized on a per module basis 161 | loadModPlugins modsum = do 162 | _ <- setSessionDynFlags (GHC.ms_hspp_opts modsum) 163 | hsc_env <- getSession 164 | 165 | # if __GLASGOW_HASKELL__ >= 902 166 | hsc_env' <- liftIO (initializePlugins hsc_env) 167 | setSession hsc_env' 168 | return modsum 169 | # else 170 | dynflags' <- liftIO (initializePlugins hsc_env (GHC.ms_hspp_opts modsum)) 171 | return $ modsum { ms_hspp_opts = dynflags' } 172 | # endif 173 | #else 174 | loadModPlugins = return 175 | #endif 176 | 177 | -- | Extract all docstrings from given list of files/modules. 178 | -- 179 | -- This includes the docstrings of all local modules that are imported from 180 | -- those modules (possibly indirect). 181 | extract :: [String] -> IO [Module (Located String)] 182 | extract args = do 183 | packageDBArgs <- getPackageDBArgs 184 | let 185 | args' = args ++ 186 | #if __GLASGOW_HASKELL__ >= 810 187 | -- `ghci` ignores unused packages in certain situation. This ensures 188 | -- that we don't fail in situations where `ghci` would not. 189 | "-Wno-unused-packages" : 190 | #endif 191 | packageDBArgs 192 | 193 | mods <- parse args' 194 | let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule) mods 195 | 196 | (docs `deepseq` return docs) `catches` [ 197 | -- Re-throw AsyncException, otherwise execution will not terminate on 198 | -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just 199 | -- UserInterrupt) because all of them indicate severe conditions and 200 | -- should not occur during normal operation. 201 | Handler (\e -> throw (e :: AsyncException)) 202 | , Handler (throwIO . ExtractError) 203 | ] 204 | 205 | -- | Extract all docstrings from given module and attach the modules name. 206 | extractFromModule :: ParsedModule -> Module (Located String) 207 | extractFromModule m = Module name (listToMaybe $ map snd setup) (map snd docs) 208 | where 209 | isSetup = (== Just "setup") . fst 210 | (setup, docs) = partition isSetup (docStringsFromModule m) 211 | name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m 212 | 213 | #if __GLASGOW_HASKELL__ >= 904 214 | unpackHDS :: HsDocString -> String 215 | unpackHDS = renderHsDocString 216 | #endif 217 | 218 | -- | Extract all docstrings from given module. 219 | docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)] 220 | docStringsFromModule mod = map (fmap (toLocated . fmap unpackHDS)) docs 221 | where 222 | source = (unLoc . pm_parsed_source) mod 223 | 224 | -- we use dlist-style concatenation here 225 | docs :: [(Maybe String, LHsDocString)] 226 | docs = header ++ exports ++ decls 227 | 228 | -- We process header, exports and declarations separately instead of 229 | -- traversing the whole source in a generic way, to ensure that we get 230 | -- everything in source order. 231 | #if __GLASGOW_HASKELL__ >= 906 232 | header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader (hsmodExt source)]] 233 | #elif __GLASGOW_HASKELL__ >= 904 234 | header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader (source)]] 235 | #else 236 | header = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]] 237 | #endif 238 | exports :: [(Maybe String, LHsDocString)] 239 | #if __GLASGOW_HASKELL__ >= 904 240 | exports = [ (Nothing, L (locA loc) (hsDocString (unLoc doc))) 241 | #else 242 | exports = [ (Nothing, L (locA loc) doc) 243 | #endif 244 | #if __GLASGOW_HASKELL__ < 805 245 | | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source) 246 | #else 247 | | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source) 248 | #endif 249 | ] 250 | decls :: [(Maybe String, LHsDocString)] 251 | decls = extractDocStrings (hsmodDecls source) 252 | 253 | -- | Extract all docstrings from given value. 254 | extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)] 255 | extractDocStrings d = 256 | #if __GLASGOW_HASKELL__ >= 904 257 | let 258 | docStrs = extractAll extractDocDocString d 259 | docStrNames = catMaybes $ extractAll extractDocName d 260 | in 261 | flip fmap docStrs $ \docStr -> (lookup (getLoc docStr) docStrNames, docStr) 262 | where 263 | extractAll z = everything (++) (mkQ [] ((:[]) . z)) 264 | 265 | extractDocDocString :: LHsDoc GhcPs -> LHsDocString 266 | extractDocDocString = fmap hsDocString 267 | 268 | extractDocName :: DocDecl GhcPs -> Maybe (SrcSpan, String) 269 | extractDocName docDecl = case docDecl of 270 | DocCommentNamed name y -> 271 | Just (getLoc y, name) 272 | _ -> 273 | Nothing 274 | #else 275 | everythingBut (++) (([], False) `mkQ` fromLHsDecl 276 | `extQ` fromLDocDecl 277 | `extQ` fromLHsDocString 278 | ) d 279 | where 280 | fromLHsDecl :: Selector (LHsDecl GhcPs) 281 | fromLHsDecl (L loc decl) = case decl of 282 | 283 | -- Top-level documentation has to be treated separately, because it has 284 | -- no location information attached. The location information is 285 | -- attached to HsDecl instead. 286 | #if __GLASGOW_HASKELL__ < 805 287 | DocD x 288 | #else 289 | DocD _ x 290 | #endif 291 | -> select (fromDocDecl (locA loc) x) 292 | 293 | _ -> (extractDocStrings decl, True) 294 | 295 | fromLDocDecl :: Selector 296 | #if __GLASGOW_HASKELL__ >= 901 297 | (LDocDecl GhcPs) 298 | #else 299 | LDocDecl 300 | #endif 301 | fromLDocDecl (L loc x) = select (fromDocDecl (locA loc) x) 302 | 303 | fromLHsDocString :: Selector LHsDocString 304 | fromLHsDocString x = select (Nothing, x) 305 | 306 | fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString) 307 | fromDocDecl loc x = case x of 308 | DocCommentNamed name doc -> (Just name, L loc doc) 309 | _ -> (Nothing, L loc $ docDeclDoc x) 310 | 311 | type Selector a = a -> ([(Maybe String, LHsDocString)], Bool) 312 | 313 | -- | Collect given value and descend into subtree. 314 | select :: a -> ([a], Bool) 315 | select x = ([x], False) 316 | #endif 317 | 318 | #if __GLASGOW_HASKELL__ < 805 319 | -- | Convert a docstring to a plain string. 320 | unpackHDS :: HsDocString -> String 321 | unpackHDS (HsDocString s) = unpackFS s 322 | #endif 323 | 324 | #if __GLASGOW_HASKELL__ < 901 325 | locA :: SrcSpan -> SrcSpan 326 | locA = id 327 | #endif 328 | -------------------------------------------------------------------------------- /src/GhcUtil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GhcUtil (withGhc) where 3 | 4 | import Imports 5 | 6 | import GHC.Paths (libdir) 7 | import GHC 8 | #if __GLASGOW_HASKELL__ < 900 9 | import DynFlags (gopt_set) 10 | #else 11 | import GHC.Driver.Session (gopt_set) 12 | #endif 13 | 14 | #if __GLASGOW_HASKELL__ < 900 15 | import Panic (throwGhcException) 16 | #else 17 | import GHC.Utils.Panic (throwGhcException) 18 | #endif 19 | 20 | #if __GLASGOW_HASKELL__ < 900 21 | import MonadUtils (liftIO) 22 | #else 23 | import GHC.Utils.Monad (liftIO) 24 | #endif 25 | 26 | import System.Exit (exitFailure) 27 | 28 | #if __GLASGOW_HASKELL__ < 801 29 | import StaticFlags (discardStaticFlags) 30 | #endif 31 | 32 | -- Catch GHC source errors, print them and exit. 33 | handleSrcErrors :: Ghc a -> Ghc a 34 | handleSrcErrors action' = flip handleSourceError action' $ \err -> do 35 | printException err 36 | liftIO exitFailure 37 | 38 | -- | Run a GHC action in Haddock mode 39 | withGhc :: [String] -> ([String] -> Ghc a) -> IO a 40 | withGhc flags action = do 41 | flags_ <- handleStaticFlags flags 42 | 43 | runGhc (Just libdir) $ do 44 | handleDynamicFlags flags_ >>= handleSrcErrors . action 45 | 46 | handleStaticFlags :: [String] -> IO [Located String] 47 | #if __GLASGOW_HASKELL__ < 801 48 | handleStaticFlags flags = return $ map noLoc $ discardStaticFlags flags 49 | #else 50 | handleStaticFlags flags = return $ map noLoc $ flags 51 | #endif 52 | 53 | handleDynamicFlags :: GhcMonad m => [Located String] -> m [String] 54 | handleDynamicFlags flags = do 55 | #if __GLASGOW_HASKELL__ >= 901 56 | logger <- getLogger 57 | let parseDynamicFlags' = parseDynamicFlags logger 58 | #else 59 | let parseDynamicFlags' = parseDynamicFlags 60 | #endif 61 | (dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= (`parseDynamicFlags'` flags) 62 | _ <- setSessionDynFlags dynflags 63 | 64 | -- We basically do the same thing as `ghc/Main.hs` to distinguish 65 | -- "unrecognised flags" from source files. 66 | let srcs = map unLoc locSrcs 67 | unknown_opts = [ f | f@('-':_) <- srcs ] 68 | case unknown_opts of 69 | opt : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'")) 70 | _ -> return srcs 71 | 72 | setHaddockMode :: DynFlags -> DynFlags 73 | setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) { 74 | #if __GLASGOW_HASKELL__ >= 906 75 | backend = noBackend 76 | #elif __GLASGOW_HASKELL__ >= 901 77 | backend = NoBackend 78 | #else 79 | hscTarget = HscNothing 80 | #endif 81 | , ghcMode = CompManager 82 | , ghcLink = NoLink 83 | } 84 | -------------------------------------------------------------------------------- /src/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Imports (module Imports) where 4 | 5 | import Prelude as Imports 6 | import Data.Monoid as Imports 7 | import Data.Maybe as Imports 8 | import Control.Monad as Imports hiding (forM_) 9 | import Control.Exception as Imports 10 | import Data.Foldable as Imports (forM_) 11 | import Control.Arrow as Imports 12 | 13 | import Data.Char 14 | import System.Exit 15 | import System.Process 16 | 17 | #if __GLASGOW_HASKELL__ >= 804 18 | import Data.Functor as Imports ((<&>)) 19 | #else 20 | infixl 1 <&> 21 | (<&>) :: Functor f => f a -> (a -> b) -> f b 22 | (<&>) = flip fmap 23 | #endif 24 | 25 | pass :: Monad m => m () 26 | pass = return () 27 | 28 | equals :: Eq a => a -> a -> Bool 29 | equals = (==) 30 | 31 | strip :: String -> String 32 | strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace 33 | 34 | call :: FilePath -> [FilePath] -> IO () 35 | call name args = rawSystem name args >>= \ case 36 | ExitSuccess -> pass 37 | err -> exitWith err 38 | 39 | exec :: FilePath -> [FilePath] -> IO () 40 | exec name args = rawSystem name args >>= exitWith 41 | -------------------------------------------------------------------------------- /src/Info.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Info ( 3 | versionInfo 4 | , info 5 | , version 6 | #ifdef TEST 7 | , formatInfo 8 | #endif 9 | ) where 10 | 11 | import Imports 12 | 13 | import Data.List 14 | import System.Process 15 | import System.IO.Unsafe 16 | 17 | #if __GLASGOW_HASKELL__ < 900 18 | import Config as GHC 19 | #else 20 | import GHC.Settings.Config as GHC 21 | #endif 22 | 23 | import Interpreter (ghc) 24 | 25 | #ifdef TEST 26 | 27 | version :: String 28 | version = "0.0.0" 29 | 30 | #else 31 | 32 | import Data.Version (showVersion) 33 | import qualified Paths_doctest 34 | 35 | version :: String 36 | version = showVersion Paths_doctest.version 37 | 38 | #endif 39 | 40 | ghcVersion :: String 41 | ghcVersion = GHC.cProjectVersion 42 | 43 | versionInfo :: String 44 | versionInfo = unlines [ 45 | "doctest version " ++ version 46 | , "using version " ++ ghcVersion ++ " of the GHC API" 47 | , "using " ++ ghc 48 | ] 49 | 50 | info :: String 51 | info = formatInfo $ 52 | ("version", version) 53 | : ("ghc_version", ghcVersion) 54 | : ("ghc", ghc) 55 | : ghcInfo 56 | 57 | type Info = [(String, String)] 58 | 59 | ghcInfo :: Info 60 | ghcInfo = read $ unsafePerformIO (readProcess ghc ["--info"] "") 61 | 62 | formatInfo :: Info -> String 63 | formatInfo xs = " [" ++ (intercalate "\n ," $ map show xs) ++ "\n ]\n" 64 | -------------------------------------------------------------------------------- /src/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Interpreter ( 3 | Interpreter 4 | , PreserveIt(..) 5 | , safeEval 6 | , safeEvalWith 7 | , withInterpreter 8 | , ghc 9 | , interpreterSupported 10 | 11 | -- exported for testing 12 | , ghcInfo 13 | , haveInterpreterKey 14 | , filterExpression 15 | ) where 16 | 17 | import Imports 18 | 19 | import System.Process 20 | import System.Directory (getPermissions, executable) 21 | import GHC.Paths (ghc) 22 | 23 | import Language.Haskell.GhciWrapper 24 | 25 | haveInterpreterKey :: String 26 | haveInterpreterKey = "Have interpreter" 27 | 28 | ghcInfo :: IO [(String, String)] 29 | ghcInfo = read <$> readProcess ghc ["--info"] [] 30 | 31 | interpreterSupported :: IO Bool 32 | interpreterSupported = do 33 | -- in a perfect world this permission check should never fail, but I know of 34 | -- at least one case where it did.. 35 | x <- getPermissions ghc 36 | unless (executable x) $ do 37 | fail $ ghc ++ " is not executable!" 38 | 39 | (== Just "YES") . lookup haveInterpreterKey <$> ghcInfo 40 | 41 | withInterpreter 42 | :: (String, [String]) 43 | -> (Interpreter -> IO a) -- ^ Action to run 44 | -> IO a -- ^ Result of action 45 | withInterpreter (command, flags) action = do 46 | let 47 | args = flags ++ [ 48 | xTemplateHaskell 49 | #if __GLASGOW_HASKELL__ >= 802 50 | , "-fdiagnostics-color=never" 51 | , "-fno-diagnostics-show-caret" 52 | #endif 53 | #if __GLASGOW_HASKELL__ >= 810 && __GLASGOW_HASKELL__ < 904 54 | , "-Wno-unused-packages" 55 | #endif 56 | #if __GLASGOW_HASKELL__ >= 910 57 | , "-fprint-error-index-links=never" 58 | #endif 59 | ] 60 | bracket (new defaultConfig{configGhci = command} args) close action 61 | 62 | xTemplateHaskell :: String 63 | xTemplateHaskell = "-XTemplateHaskell" 64 | 65 | -- | Evaluate an expression; return a Left value on exceptions. 66 | -- 67 | -- An exception may e.g. be caused on unterminated multiline expressions. 68 | safeEval :: Interpreter -> String -> IO (Either String String) 69 | safeEval = safeEvalWith NoPreserveIt 70 | 71 | safeEvalWith :: PreserveIt -> Interpreter -> String -> IO (Either String String) 72 | safeEvalWith preserveIt repl = either (return . Left) (fmap Right . evalWith preserveIt repl) . filterExpression 73 | 74 | filterExpression :: String -> Either String String 75 | filterExpression e = 76 | case lines e of 77 | [] -> Right e 78 | l -> if firstLine == ":{" && lastLine /= ":}" then err else Right (filterXTemplateHaskell e) 79 | where 80 | firstLine = strip $ head l 81 | lastLine = strip $ last l 82 | err = Left "unterminated multi-line command" 83 | 84 | filterXTemplateHaskell :: String -> String 85 | filterXTemplateHaskell input = case words input of 86 | [":set", setting] | setting == xTemplateHaskell -> "" 87 | ":set" : xs | xTemplateHaskell `elem` xs -> unwords $ ":set" : filter (/= xTemplateHaskell) xs 88 | _ -> input 89 | -------------------------------------------------------------------------------- /src/Language/Haskell/GhciWrapper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Language.Haskell.GhciWrapper ( 3 | Interpreter 4 | , Config(..) 5 | , defaultConfig 6 | , PreserveIt(..) 7 | , new 8 | , close 9 | , eval 10 | , evalWith 11 | , evalEcho 12 | ) where 13 | 14 | import Imports 15 | 16 | import System.IO hiding (stdin, stdout, stderr) 17 | import System.Process 18 | import System.Exit 19 | import Data.List (isSuffixOf) 20 | 21 | data Config = Config { 22 | configGhci :: String 23 | , configVerbose :: Bool 24 | , configIgnoreDotGhci :: Bool 25 | } deriving (Eq, Show) 26 | 27 | defaultConfig :: Config 28 | defaultConfig = Config { 29 | configGhci = "ghci" 30 | , configVerbose = False 31 | , configIgnoreDotGhci = True 32 | } 33 | 34 | data PreserveIt = NoPreserveIt | PreserveIt 35 | deriving Eq 36 | 37 | -- | Truly random marker, used to separate expressions. 38 | -- 39 | -- IMPORTANT: This module relies upon the fact that this marker is unique. It 40 | -- has been obtained from random.org. Do not expect this module to work 41 | -- properly, if you reuse it for any purpose! 42 | marker :: String 43 | marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1" 44 | 45 | itMarker :: String 46 | itMarker = "d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a" 47 | 48 | data Interpreter = Interpreter { 49 | hIn :: Handle 50 | , hOut :: Handle 51 | , process :: ProcessHandle 52 | } 53 | 54 | new :: Config -> [String] -> IO Interpreter 55 | new Config{..} args_ = do 56 | (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess (proc configGhci args) { 57 | std_in = CreatePipe 58 | , std_out = CreatePipe 59 | , std_err = Inherit 60 | } 61 | setMode stdin_ 62 | setMode stdout_ 63 | let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle} 64 | evalThrow interpreter "import qualified System.IO" 65 | evalThrow interpreter "import qualified GHC.IO.Encoding" 66 | evalThrow interpreter "import qualified GHC.IO.Handle" 67 | -- The buffering of stdout and stderr is NoBuffering 68 | evalThrow interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr" 69 | -- Now the buffering of stderr is BlockBuffering Nothing 70 | -- In this situation, GHC 7.7 does not flush the buffer even when 71 | -- error happens. 72 | evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering" 73 | evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering" 74 | 75 | -- this is required on systems that don't use utf8 as default encoding (e.g. 76 | -- Windows) 77 | evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8" 78 | evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8" 79 | 80 | evalThrow interpreter ":m - System.IO" 81 | evalThrow interpreter ":m - GHC.IO.Encoding" 82 | evalThrow interpreter ":m - GHC.IO.Handle" 83 | 84 | return interpreter 85 | where 86 | args = args_ ++ catMaybes [ 87 | if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing 88 | , if configVerbose then Nothing else Just "-v0" 89 | ] 90 | setMode h = do 91 | hSetBinaryMode h False 92 | hSetBuffering h LineBuffering 93 | hSetEncoding h utf8 94 | 95 | evalThrow :: Interpreter -> String -> IO () 96 | evalThrow interpreter expr = do 97 | output <- eval interpreter expr 98 | unless (null output || configVerbose) $ do 99 | close interpreter 100 | throwIO (ErrorCall output) 101 | 102 | close :: Interpreter -> IO () 103 | close repl = do 104 | hClose $ hIn repl 105 | 106 | -- It is crucial not to close `hOut` before calling `waitForProcess`, 107 | -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang 108 | -- around consuming 100% CPU. This happens when ghci tries to print 109 | -- something to stdout in its signal handler (e.g. when it is blocked in 110 | -- threadDelay it writes "Interrupted." on SIGINT). 111 | e <- waitForProcess $ process repl 112 | hClose $ hOut repl 113 | 114 | when (e /= ExitSuccess) $ do 115 | throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")") 116 | 117 | putExpression :: Interpreter -> PreserveIt -> String -> IO () 118 | putExpression Interpreter{hIn = stdin} (equals PreserveIt -> preserveIt) e = do 119 | hPutStrLn stdin e 120 | when preserveIt $ hPutStrLn stdin $ "let " ++ itMarker ++ " = it" 121 | hPutStrLn stdin (marker ++ " :: Data.String.String") 122 | when preserveIt $ hPutStrLn stdin $ "let it = " ++ itMarker 123 | hFlush stdin 124 | 125 | getResult :: Bool -> Interpreter -> IO String 126 | getResult echoMode Interpreter{hOut = stdout} = go 127 | where 128 | go = do 129 | line <- hGetLine stdout 130 | if marker `isSuffixOf` line 131 | then do 132 | let xs = stripMarker line 133 | echo xs 134 | return xs 135 | else do 136 | echo (line ++ "\n") 137 | result <- go 138 | return (line ++ "\n" ++ result) 139 | stripMarker l = take (length l - length marker) l 140 | 141 | echo :: String -> IO () 142 | echo 143 | | echoMode = putStr 144 | | otherwise = \ _ -> return () 145 | 146 | -- | Evaluate an expression 147 | eval :: Interpreter -> String -> IO String 148 | eval = evalWith NoPreserveIt 149 | 150 | -- | Like 'eval', but try to preserve the @it@ variable 151 | evalWith :: PreserveIt -> Interpreter -> String -> IO String 152 | evalWith preserveIt repl expr = do 153 | putExpression repl preserveIt expr 154 | getResult False repl 155 | 156 | -- | Evaluate an expression 157 | evalEcho :: Interpreter -> String -> IO String 158 | evalEcho repl expr = do 159 | putExpression repl NoPreserveIt expr 160 | getResult True repl 161 | -------------------------------------------------------------------------------- /src/Location.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Location where 3 | 4 | import Imports 5 | 6 | import Control.DeepSeq (deepseq, NFData(rnf)) 7 | 8 | #if __GLASGOW_HASKELL__ < 900 9 | import SrcLoc hiding (Located) 10 | import qualified SrcLoc as GHC 11 | import FastString (unpackFS) 12 | #else 13 | import GHC.Types.SrcLoc hiding (Located) 14 | import qualified GHC.Types.SrcLoc as GHC 15 | import GHC.Data.FastString (unpackFS) 16 | #endif 17 | 18 | -- | A thing with a location attached. 19 | data Located a = Located Location a 20 | deriving (Eq, Show, Functor) 21 | 22 | instance NFData a => NFData (Located a) where 23 | rnf (Located loc a) = loc `deepseq` a `deepseq` () 24 | 25 | -- | Convert a GHC located thing to a located thing. 26 | toLocated :: GHC.Located a -> Located a 27 | toLocated (L loc a) = Located (toLocation loc) a 28 | 29 | -- | Discard location information. 30 | unLoc :: Located a -> a 31 | unLoc (Located _ a) = a 32 | 33 | -- | Add dummy location information. 34 | noLocation :: a -> Located a 35 | noLocation = Located (UnhelpfulLocation "") 36 | 37 | -- | A line number. 38 | type Line = Int 39 | 40 | -- | A combination of file name and line number. 41 | data Location = UnhelpfulLocation String | Location FilePath Line 42 | deriving Eq 43 | 44 | instance Show Location where 45 | show (UnhelpfulLocation s) = s 46 | show (Location file line) = file ++ ":" ++ show line 47 | 48 | instance NFData Location where 49 | rnf (UnhelpfulLocation str) = str `deepseq` () 50 | rnf (Location file line) = file `deepseq` line `deepseq` () 51 | 52 | -- | 53 | -- Create a list from a location, by repeatedly increasing the line number by 54 | -- one. 55 | enumerate :: Location -> [Location] 56 | enumerate loc = case loc of 57 | UnhelpfulLocation _ -> repeat loc 58 | Location file line -> map (Location file) [line ..] 59 | 60 | -- | Convert a GHC source span to a location. 61 | toLocation :: SrcSpan -> Location 62 | #if __GLASGOW_HASKELL__ < 900 63 | toLocation loc = case loc of 64 | UnhelpfulSpan str -> UnhelpfulLocation (unpackFS str) 65 | RealSrcSpan sp -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) 66 | #else 67 | toLocation loc = case loc of 68 | UnhelpfulSpan str -> UnhelpfulLocation (unpackFS $ unhelpfulSpanFS str) 69 | RealSrcSpan sp _ -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) 70 | #endif 71 | -------------------------------------------------------------------------------- /src/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Options ( 3 | Result(..) 4 | , Run(..) 5 | , Config(..) 6 | , defaultConfig 7 | , parseOptions 8 | #ifdef TEST 9 | , defaultRun 10 | , usage 11 | , info 12 | , versionInfo 13 | , nonInteractiveGhcOptions 14 | #endif 15 | ) where 16 | 17 | import Imports 18 | 19 | import Control.Monad.Trans.RWS (RWS, execRWS) 20 | import qualified Control.Monad.Trans.RWS as RWS 21 | 22 | import Data.List (stripPrefix) 23 | 24 | import GHC.Paths (ghc) 25 | 26 | import Info 27 | 28 | usage :: String 29 | usage = unlines [ 30 | "Usage:" 31 | , " doctest [ --fast | --preserve-it | --fail-fast | --no-magic | --verbose | GHC OPTION | MODULE ]..." 32 | , " doctest --help" 33 | , " doctest --version" 34 | , " doctest --info" 35 | , "" 36 | , "Options:" 37 | , " --fast disable :reload between example groups" 38 | , " --preserve-it preserve the `it` variable between examples" 39 | , " --fail-fast abort on first failure" 40 | , " --no-magic disable magic mode" 41 | , " --verbose print each test as it is run" 42 | , " --help display this help and exit" 43 | , " --version output version information and exit" 44 | , " --info output machine-readable version information and exit" 45 | ] 46 | 47 | data Result a = ProxyToGhc [String] | Output String | Result a 48 | deriving (Eq, Show, Functor) 49 | 50 | type Warning = String 51 | 52 | data Run = Run { 53 | runWarnings :: [Warning] 54 | , runMagicMode :: Bool 55 | , runConfig :: Config 56 | } deriving (Eq, Show) 57 | 58 | data Config = Config { 59 | ghcOptions :: [String] 60 | , fastMode :: Bool 61 | , preserveIt :: Bool 62 | , failFast :: Bool 63 | , verbose :: Bool 64 | , repl :: (String, [String]) 65 | } deriving (Eq, Show) 66 | 67 | defaultConfig :: Config 68 | defaultConfig = Config { 69 | ghcOptions = [] 70 | , fastMode = False 71 | , preserveIt = False 72 | , failFast = False 73 | , verbose = False 74 | , repl = (ghc, ["--interactive"]) 75 | } 76 | 77 | nonInteractiveGhcOptions :: [String] 78 | nonInteractiveGhcOptions = [ 79 | "--numeric-version" 80 | , "--supported-languages" 81 | , "--info" 82 | , "--print-global-package-db" 83 | , "--print-libdir" 84 | , "-c" 85 | , "-o" 86 | , "--make" 87 | , "--abi-hash" 88 | ] 89 | 90 | defaultRun :: Run 91 | defaultRun = Run { 92 | runWarnings = [] 93 | , runMagicMode = False 94 | , runConfig = defaultConfig 95 | } 96 | 97 | modifyWarnings :: ([String] -> [String]) -> Run -> Run 98 | modifyWarnings f run = run { runWarnings = f (runWarnings run) } 99 | 100 | setOptions :: [String] -> Run -> Run 101 | setOptions ghcOptions run@Run{..} = run { runConfig = runConfig { ghcOptions } } 102 | 103 | setMagicMode :: Bool -> Run -> Run 104 | setMagicMode magic run = run { runMagicMode = magic } 105 | 106 | setFastMode :: Bool -> Run -> Run 107 | setFastMode fastMode run@Run{..} = run { runConfig = runConfig { fastMode } } 108 | 109 | setPreserveIt :: Bool -> Run -> Run 110 | setPreserveIt preserveIt run@Run{..} = run { runConfig = runConfig { preserveIt } } 111 | 112 | setFailFastMode :: Bool -> Run -> Run 113 | setFailFastMode failFast run@Run{..} = run { runConfig = runConfig { failFast } } 114 | 115 | setVerbose :: Bool -> Run -> Run 116 | setVerbose verbose run@Run{..} = run { runConfig = runConfig { verbose } } 117 | 118 | parseOptions :: [String] -> Result Run 119 | parseOptions args 120 | | on "--info" = Output info 121 | | on "--interactive" = runRunOptionsParser (discard "--interactive" args) defaultRun $ do 122 | commonRunOptions 123 | | on `any` nonInteractiveGhcOptions = ProxyToGhc args 124 | | on "--help" = Output usage 125 | | on "--version" = Output versionInfo 126 | | otherwise = runRunOptionsParser args defaultRun {runMagicMode = True} $ do 127 | commonRunOptions 128 | parseFlag "--no-magic" (setMagicMode False) 129 | parseOptGhc 130 | where 131 | on option = option `elem` args 132 | 133 | type RunOptionsParser = RWS () (Endo Run) [String] () 134 | 135 | runRunOptionsParser :: [String] -> Run -> RunOptionsParser -> Result Run 136 | runRunOptionsParser args def parse = case execRWS parse () args of 137 | (xs, Endo setter) -> 138 | Result (setOptions xs $ setter def) 139 | 140 | commonRunOptions :: RunOptionsParser 141 | commonRunOptions = do 142 | parseFlag "--fast" (setFastMode True) 143 | parseFlag "--preserve-it" (setPreserveIt True) 144 | parseFlag "--fail-fast" (setFailFastMode True) 145 | parseFlag "--verbose" (setVerbose True) 146 | 147 | parseFlag :: String -> (Run -> Run) -> RunOptionsParser 148 | parseFlag flag setter = do 149 | args <- RWS.get 150 | when (flag `elem` args) $ 151 | RWS.tell (Endo setter) 152 | RWS.put (discard flag args) 153 | 154 | parseOptGhc :: RunOptionsParser 155 | parseOptGhc = do 156 | issueWarning <- RWS.state go 157 | when issueWarning $ 158 | RWS.tell $ Endo $ modifyWarnings (++ [warning]) 159 | where 160 | go args = case args of 161 | [] -> (False, []) 162 | "--optghc" : opt : rest -> (True, opt : snd (go rest)) 163 | opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (True, x : xs)) (stripPrefix "--optghc=" opt) (go rest) 164 | 165 | warning = "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly." 166 | 167 | discard :: String -> [String] -> [String] 168 | discard flag = filter (/= flag) 169 | -------------------------------------------------------------------------------- /src/PackageDBs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Manage GHC package databases 3 | module PackageDBs ( 4 | getPackageDBArgs 5 | #ifdef TEST 6 | , PackageDBs (..) 7 | , getPackageDBsFromEnv 8 | #endif 9 | ) where 10 | 11 | import Imports 12 | 13 | import System.Environment (getEnvironment) 14 | import System.FilePath (splitSearchPath, searchPathSeparator) 15 | 16 | -- | Full stack of GHC package databases 17 | data PackageDBs = PackageDBs 18 | { includeUser :: Bool 19 | , includeGlobal :: Bool 20 | , extraDBs :: [FilePath] 21 | } 22 | deriving (Show, Eq) 23 | 24 | -- | Determine command line arguments to be passed to GHC to set databases correctly 25 | -- 26 | -- >>> dbArgs (PackageDBs False True []) 27 | -- ["-no-user-package-db"] 28 | -- 29 | -- >>> dbArgs (PackageDBs True True ["somedb"]) 30 | -- ["-package-db","somedb"] 31 | dbArgs :: PackageDBs -> [String] 32 | dbArgs (PackageDBs user global extras) = 33 | (if user then id else ("-no-user-package-db":)) $ 34 | (if global then id else ("-no-global-package-db":)) $ 35 | concatMap (\extra -> ["-package-db", extra]) extras 36 | 37 | -- | Determine the PackageDBs based on the environment. 38 | getPackageDBsFromEnv :: IO PackageDBs 39 | getPackageDBsFromEnv = do 40 | env <- getEnvironment 41 | return $ case () of 42 | () 43 | | Just packageDBs <- lookup "GHC_PACKAGE_PATH" env 44 | -> fromEnvMulti packageDBs 45 | | otherwise 46 | -> PackageDBs True True [] 47 | where 48 | fromEnvMulti s = PackageDBs 49 | { includeUser = False 50 | , includeGlobal = global 51 | , extraDBs = splitSearchPath s' 52 | } 53 | where 54 | (s', global) = 55 | case reverse s of 56 | c:rest | c == searchPathSeparator -> (reverse rest, True) 57 | _ -> (s, False) 58 | 59 | -- | Get the package DB flags for the current GHC version and from the 60 | -- environment. 61 | getPackageDBArgs :: IO [String] 62 | getPackageDBArgs = do 63 | dbs <- getPackageDBsFromEnv 64 | return $ dbArgs dbs 65 | -------------------------------------------------------------------------------- /src/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Parse ( 4 | Module (..) 5 | , DocTest (..) 6 | , Expression 7 | , ExpectedResult 8 | , ExpectedLine (..) 9 | , LineChunk (..) 10 | , extractDocTests 11 | , parseModules 12 | 13 | #ifdef TEST 14 | , parseInteractions 15 | , parseProperties 16 | , mkLineChunks 17 | #endif 18 | ) where 19 | 20 | import Imports 21 | 22 | import Data.Char (isSpace) 23 | import Data.List (isPrefixOf, stripPrefix) 24 | import Data.String 25 | import Extract 26 | import Location 27 | 28 | 29 | data DocTest = Example Expression ExpectedResult | Property Expression 30 | deriving (Eq, Show) 31 | 32 | data LineChunk = LineChunk String | WildCardChunk 33 | deriving (Show, Eq) 34 | 35 | instance IsString LineChunk where 36 | fromString = LineChunk 37 | 38 | data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine 39 | deriving (Show, Eq) 40 | 41 | instance IsString ExpectedLine where 42 | fromString = ExpectedLine . return . LineChunk 43 | 44 | type Expression = String 45 | type ExpectedResult = [ExpectedLine] 46 | 47 | type Interaction = (Expression, ExpectedResult) 48 | 49 | -- | 50 | -- Extract 'DocTest's from all given modules and all modules included by the 51 | -- given modules. 52 | -- 53 | -- @ 54 | -- extractDocTests = fmap `parseModules` . `extract` 55 | -- @ 56 | extractDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's 57 | extractDocTests = fmap parseModules . extract 58 | 59 | parseModules :: [Module (Located String)] -> [Module [Located DocTest]] 60 | parseModules = filter (not . isEmpty) . map parseModule 61 | where 62 | isEmpty (Module _ setup tests) = null tests && isNothing setup 63 | 64 | -- | Convert documentation to `Example`s. 65 | parseModule :: Module (Located String) -> Module [Located DocTest] 66 | parseModule m = case parseComment <$> m of 67 | Module name setup tests -> Module name setup_ (filter (not . null) tests) 68 | where 69 | setup_ = case setup of 70 | Just [] -> Nothing 71 | _ -> setup 72 | 73 | parseComment :: Located String -> [Located DocTest] 74 | parseComment c = properties ++ examples 75 | where 76 | examples = map (fmap $ uncurry Example) (parseInteractions c) 77 | properties = map (fmap Property) (parseProperties c) 78 | 79 | -- | Extract all properties from given Haddock comment. 80 | parseProperties :: Located String -> [Located Expression] 81 | parseProperties (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) 82 | where 83 | isPrompt :: Located String -> Bool 84 | isPrompt = isPrefixOf "prop>" . dropWhile isSpace . unLoc 85 | 86 | go xs = case dropWhile (not . isPrompt) xs of 87 | prop:rest -> stripPrompt `fmap` prop : go rest 88 | [] -> [] 89 | 90 | stripPrompt = strip . drop 5 . dropWhile isSpace 91 | 92 | -- | Extract all interactions from given Haddock comment. 93 | parseInteractions :: Located String -> [Located Interaction] 94 | parseInteractions (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) 95 | where 96 | isPrompt :: Located String -> Bool 97 | isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc 98 | 99 | isBlankLine :: Located String -> Bool 100 | isBlankLine = null . dropWhile isSpace . unLoc 101 | 102 | isEndOfInteraction :: Located String -> Bool 103 | isEndOfInteraction x = isPrompt x || isBlankLine x 104 | 105 | 106 | go :: [Located String] -> [Located Interaction] 107 | go xs = case dropWhile (not . isPrompt) xs of 108 | prompt:rest 109 | | ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))), 110 | (ys,zs) <- break isBlankLine rest -> 111 | toInteraction prompt ys : go zs 112 | 113 | | otherwise -> 114 | let 115 | (ys,zs) = break isEndOfInteraction rest 116 | in 117 | toInteraction prompt ys : go zs 118 | [] -> [] 119 | 120 | -- | Create an `Interaction`, strip superfluous whitespace as appropriate. 121 | -- 122 | -- also merge lines between :{ and :}, preserving whitespace inside 123 | -- the block (since this is useful for avoiding {;}). 124 | toInteraction :: Located String -> [Located String] -> Located Interaction 125 | toInteraction (Located loc x) xs = Located loc $ 126 | ( 127 | (strip cleanedE) -- we do not care about leading and trailing 128 | -- whitespace in expressions, so drop them 129 | , map mkExpectedLine result_ 130 | ) 131 | where 132 | -- 1. drop trailing whitespace from the prompt, remember the prefix 133 | (prefix, e) = span isSpace x 134 | (ePrompt, eRest) = splitAt 3 e 135 | 136 | -- 2. drop, if possible, the exact same sequence of whitespace 137 | -- characters from each result line 138 | unindent pre = map (tryStripPrefix pre . unLoc) 139 | 140 | cleanBody line = fromMaybe (unLoc line) 141 | (stripPrefix ePrompt (dropWhile isSpace (unLoc line))) 142 | 143 | (cleanedE, result_) 144 | | (body , endLine : rest) <- break 145 | ( (==) [":}"] . take 1 . words . cleanBody) 146 | xs 147 | = (unlines (eRest : map cleanBody body ++ 148 | [dropWhile isSpace (cleanBody endLine)]), 149 | unindent (takeWhile isSpace (unLoc endLine)) rest) 150 | | otherwise = (eRest, unindent prefix xs) 151 | 152 | 153 | tryStripPrefix :: String -> String -> String 154 | tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys 155 | 156 | mkExpectedLine :: String -> ExpectedLine 157 | mkExpectedLine x = case x of 158 | "" -> "" 159 | "..." -> WildCardLine 160 | _ -> ExpectedLine $ mkLineChunks x 161 | 162 | mkLineChunks :: String -> [LineChunk] 163 | mkLineChunks = finish . foldr go (0, [], []) 164 | where 165 | mkChunk :: String -> [LineChunk] 166 | mkChunk "" = [] 167 | mkChunk x = [LineChunk x] 168 | 169 | go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk]) 170 | go '.' (count, acc, res) = if count == 2 171 | then (0, "", WildCardChunk : mkChunk acc ++ res) 172 | else (count + 1, acc, res) 173 | go c (count, acc, res) = if count > 0 174 | then (0, c : replicate count '.' ++ acc, res) 175 | else (0, c : acc, res) 176 | finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res 177 | -------------------------------------------------------------------------------- /src/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Property ( 3 | runProperty 4 | , PropertyResult (..) 5 | #ifdef TEST 6 | , freeVariables 7 | , parseNotInScope 8 | #endif 9 | ) where 10 | 11 | import Imports 12 | 13 | import Data.List 14 | import Data.Foldable 15 | 16 | import Util 17 | import Interpreter (Interpreter) 18 | import qualified Interpreter 19 | import Parse 20 | 21 | -- | The result of evaluating an interaction. 22 | data PropertyResult = 23 | Success 24 | | Failure String 25 | | Error String 26 | deriving (Eq, Show) 27 | 28 | runProperty :: Interpreter -> Expression -> IO PropertyResult 29 | runProperty repl expression = do 30 | _ <- Interpreter.safeEval repl "import Test.QuickCheck ((==>))" 31 | _ <- Interpreter.safeEval repl "import Test.QuickCheck.All (polyQuickCheck)" 32 | _ <- Interpreter.safeEval repl "import Language.Haskell.TH (mkName)" 33 | r <- freeVariables repl expression >>= 34 | (Interpreter.safeEval repl . quickCheck expression) 35 | case r of 36 | Left err -> do 37 | return (Error err) 38 | Right res 39 | | "OK, passed" `isInfixOf` res -> return Success 40 | | otherwise -> do 41 | let msg = stripEnd (takeWhileEnd (/= '\b') res) 42 | return (Failure msg) 43 | where 44 | quickCheck term vars = 45 | "let doctest_prop " ++ unwords vars ++ " = " ++ term ++ "\n" ++ 46 | "$(polyQuickCheck (mkName \"doctest_prop\"))" 47 | 48 | -- | Find all free variables in given term. 49 | -- 50 | -- GHCi is used to detect free variables. 51 | freeVariables :: Interpreter -> String -> IO [String] 52 | freeVariables repl term = do 53 | r <- Interpreter.safeEval repl (":type " ++ term) 54 | return (either (const []) (nub . parseNotInScope) r) 55 | 56 | -- | Parse and return all variables that are not in scope from a ghc error 57 | -- message. 58 | parseNotInScope :: String -> [String] 59 | parseNotInScope = nub . mapMaybe extractVariable . lines 60 | where 61 | -- | Extract variable name from a "Not in scope"-error. 62 | extractVariable :: String -> Maybe String 63 | extractVariable x 64 | | "Not in scope: " `isInfixOf` x = Just . unquote . takeWhileEnd (/= ' ') $ x 65 | | Just y <- (asum $ map (stripPrefix "Variable not in scope: ") (tails x)) = Just (takeWhile (/= ' ') y) 66 | | otherwise = Nothing 67 | 68 | -- | Remove quotes from given name, if any. 69 | unquote ('`':xs) = init xs 70 | unquote ('\8216':xs) = init xs 71 | unquote xs = xs 72 | -------------------------------------------------------------------------------- /src/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Run ( 3 | doctest 4 | , doctestWithRepl 5 | 6 | , Config(..) 7 | , defaultConfig 8 | , doctestWith 9 | 10 | , Result 11 | , Summary(..) 12 | , formatSummary 13 | , isSuccess 14 | , evaluateResult 15 | , doctestWithResult 16 | 17 | , runDocTests 18 | #ifdef TEST 19 | , expandDirs 20 | #endif 21 | ) where 22 | 23 | import Imports 24 | 25 | import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) 26 | import System.Environment (getEnvironment) 27 | import System.Exit (exitFailure, exitSuccess) 28 | import System.FilePath ((), takeExtension) 29 | import System.IO 30 | import System.IO.CodePage (withCP65001) 31 | 32 | import qualified Control.Exception as E 33 | 34 | #if __GLASGOW_HASKELL__ < 900 35 | import Panic 36 | #else 37 | import GHC.Utils.Panic 38 | #endif 39 | 40 | import PackageDBs 41 | import Parse 42 | import Options hiding (Result(..)) 43 | import qualified Options 44 | import Runner 45 | import Location 46 | import qualified Interpreter 47 | 48 | -- | Run doctest with given list of arguments. 49 | -- 50 | -- Example: 51 | -- 52 | -- >>> doctest ["-iexample/src", "example/src/Example.hs"] 53 | -- ... 54 | -- Examples: 2 Tried: 2 Errors: 0 Failures: 0 55 | -- 56 | -- This can be used to create a Cabal test suite that runs doctest for your 57 | -- project. 58 | -- 59 | -- If a directory is given, it is traversed to find all .hs and .lhs files 60 | -- inside of it, ignoring hidden entries. 61 | doctest :: [String] -> IO () 62 | doctest = doctestWithRepl (repl defaultConfig) 63 | 64 | doctestWithRepl :: (String, [String]) -> [String] -> IO () 65 | doctestWithRepl repl args0 = case parseOptions args0 of 66 | Options.ProxyToGhc args -> exec Interpreter.ghc args 67 | Options.Output s -> putStr s 68 | Options.Result (Run warnings magicMode config) -> do 69 | mapM_ (hPutStrLn stderr) warnings 70 | hFlush stderr 71 | 72 | i <- Interpreter.interpreterSupported 73 | unless i $ do 74 | hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests" 75 | exitSuccess 76 | 77 | opts <- case magicMode of 78 | False -> return (ghcOptions config) 79 | True -> do 80 | expandedArgs <- concat <$> mapM expandDirs (ghcOptions config) 81 | packageDBArgs <- getPackageDBArgs 82 | addDistArgs <- getAddDistArgs 83 | return (addDistArgs $ packageDBArgs ++ expandedArgs) 84 | doctestWith config{repl, ghcOptions = opts} 85 | 86 | -- | Expand a reference to a directory to all .hs and .lhs files within it. 87 | expandDirs :: String -> IO [String] 88 | expandDirs fp0 = do 89 | isDir <- doesDirectoryExist fp0 90 | if isDir 91 | then findHaskellFiles fp0 92 | else return [fp0] 93 | where 94 | findHaskellFiles dir = do 95 | contents <- getDirectoryContents dir 96 | concat <$> mapM go (filter (not . hidden) contents) 97 | where 98 | go name = do 99 | isDir <- doesDirectoryExist fp 100 | if isDir 101 | then findHaskellFiles fp 102 | else if isHaskellFile fp 103 | then return [fp] 104 | else return [] 105 | where 106 | fp = dir name 107 | 108 | hidden ('.':_) = True 109 | hidden _ = False 110 | 111 | isHaskellFile fp = takeExtension fp `elem` [".hs", ".lhs"] 112 | 113 | -- | Get the necessary arguments to add the @cabal_macros.h@ file and autogen 114 | -- directory, if present. 115 | getAddDistArgs :: IO ([String] -> [String]) 116 | getAddDistArgs = do 117 | env <- getEnvironment 118 | let dist = fromMaybe "dist" $ lookup "HASKELL_DIST_DIR" env 119 | autogen = dist ++ "/build/autogen/" 120 | cabalMacros = autogen ++ "cabal_macros.h" 121 | 122 | dirExists <- doesDirectoryExist autogen 123 | if dirExists 124 | then do 125 | fileExists <- doesFileExist cabalMacros 126 | return $ \rest -> 127 | concat ["-i", dist, "/build/autogen/"] 128 | : "-optP-include" 129 | : (if fileExists 130 | then (concat ["-optP", dist, "/build/autogen/cabal_macros.h"]:) 131 | else id) rest 132 | else return id 133 | 134 | doctestWith :: Config -> IO () 135 | doctestWith = doctestWithResult >=> evaluateResult 136 | 137 | type Result = Summary 138 | 139 | evaluateResult :: Result -> IO () 140 | evaluateResult r = unless (isSuccess r) exitFailure 141 | 142 | doctestWithResult :: Config -> IO Result 143 | doctestWithResult config = do 144 | (extractDocTests (ghcOptions config) >>= runDocTests config) `E.catch` \e -> do 145 | case fromException e of 146 | Just (UsageError err) -> do 147 | hPutStrLn stderr ("doctest: " ++ err) 148 | hPutStrLn stderr "Try `doctest --help' for more information." 149 | exitFailure 150 | _ -> E.throwIO e 151 | 152 | runDocTests :: Config -> [Module [Located DocTest]] -> IO Result 153 | runDocTests Config{..} modules = do 154 | Interpreter.withInterpreter ((<> ghcOptions) <$> repl) $ \ interpreter -> withCP65001 $ do 155 | runModules 156 | (if fastMode then FastMode else NoFastMode) 157 | (if preserveIt then PreserveIt else NoPreserveIt) 158 | (if failFast then FailFast else NoFailFast) 159 | (if verbose then Verbose else NonVerbose) 160 | interpreter modules 161 | -------------------------------------------------------------------------------- /src/Runner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Runner ( 4 | runModules 5 | , FastMode(..) 6 | , PreserveIt(..) 7 | , FailFast(..) 8 | , Verbose(..) 9 | , Summary(..) 10 | , isSuccess 11 | , formatSummary 12 | 13 | #ifdef TEST 14 | , Report 15 | , ReportState(..) 16 | , runReport 17 | , Interactive(..) 18 | , report 19 | , reportTransient 20 | #endif 21 | ) where 22 | 23 | import Prelude () 24 | import Imports hiding (putStr, putStrLn, error) 25 | 26 | import Text.Printf (printf) 27 | import System.IO hiding (putStr, putStrLn) 28 | 29 | import Control.Monad.Trans.Class 30 | import Control.Monad.Trans.Maybe 31 | import Control.Monad.Trans.State (StateT, evalStateT) 32 | import qualified Control.Monad.Trans.State as State 33 | import Control.Monad.IO.Class 34 | import Data.IORef 35 | 36 | import Interpreter (Interpreter, PreserveIt(..), safeEvalWith) 37 | import qualified Interpreter 38 | import Parse 39 | import Location 40 | import Property 41 | import Runner.Example 42 | 43 | -- | Summary of a test run. 44 | data Summary = Summary { 45 | sExamples :: !Int 46 | , sTried :: !Int 47 | , sErrors :: !Int 48 | , sFailures :: !Int 49 | } deriving Eq 50 | 51 | instance Show Summary where 52 | show = formatSummary 53 | 54 | isSuccess :: Summary -> Bool 55 | isSuccess s = sErrors s == 0 && sFailures s == 0 56 | 57 | formatSummary :: Summary -> String 58 | formatSummary (Summary examples tried errors failures) = 59 | printf "Examples: %d Tried: %d Errors: %d Failures: %d" examples tried errors failures 60 | 61 | -- | Sum up summaries. 62 | instance Monoid Summary where 63 | mempty = Summary 0 0 0 0 64 | #if __GLASGOW_HASKELL__ < 804 65 | mappend 66 | #else 67 | instance Semigroup Summary where 68 | (<>) 69 | #endif 70 | (Summary x1 x2 x3 x4) (Summary y1 y2 y3 y4) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) 71 | 72 | withLineBuffering :: Handle -> IO c -> IO c 73 | withLineBuffering h action = bracket (hGetBuffering h) (hSetBuffering h) $ \ _ -> do 74 | hSetBuffering h LineBuffering 75 | action 76 | 77 | -- | Run all examples from a list of modules. 78 | runModules :: FastMode -> PreserveIt -> FailFast -> Verbose -> Interpreter -> [Module [Located DocTest]] -> IO Summary 79 | runModules fastMode preserveIt failFast verbose repl modules = withLineBuffering stderr $ do 80 | 81 | interactive <- hIsTerminalDevice stderr <&> \ case 82 | False -> NonInteractive 83 | True -> Interactive 84 | 85 | summary <- newIORef mempty {sExamples = n} 86 | 87 | let 88 | reportFinalResult :: IO () 89 | reportFinalResult = do 90 | final <- readIORef summary 91 | hPutStrLn stderr (formatSummary final) 92 | 93 | run :: IO () 94 | run = runReport (ReportState interactive failFast verbose summary) $ do 95 | reportProgress 96 | forM_ modules $ runModule fastMode preserveIt repl 97 | verboseReport "# Final summary:" 98 | 99 | run `finally` reportFinalResult 100 | 101 | readIORef summary 102 | where 103 | n :: Int 104 | n = sum (map countExpressions modules) 105 | 106 | countExpressions :: Module [Located DocTest] -> Int 107 | countExpressions (Module _ setup tests) = sum (map length tests) + maybe 0 length setup 108 | 109 | type Report = MaybeT (StateT ReportState IO) 110 | 111 | data Interactive = NonInteractive | Interactive 112 | 113 | data FastMode = NoFastMode | FastMode 114 | 115 | data FailFast = NoFailFast | FailFast 116 | 117 | data Verbose = NonVerbose | Verbose 118 | 119 | data ReportState = ReportState { 120 | reportStateInteractive :: Interactive 121 | , reportStateFailFast :: FailFast 122 | , reportStateVerbose :: Verbose 123 | , reportStateSummary :: IORef Summary 124 | } 125 | 126 | runReport :: ReportState -> Report () -> IO () 127 | runReport st = void . flip evalStateT st . runMaybeT 128 | 129 | getSummary :: Report Summary 130 | getSummary = gets reportStateSummary >>= liftIO . readIORef 131 | 132 | gets :: (ReportState -> a) -> Report a 133 | gets = lift . State.gets 134 | 135 | -- | Add output to the report. 136 | report :: String -> Report () 137 | report = liftIO . hPutStrLn stderr 138 | 139 | -- | Add intermediate output to the report. 140 | -- 141 | -- This will be overwritten by subsequent calls to `report`/`report_`. 142 | -- Intermediate out may not contain any newlines. 143 | reportTransient :: String -> Report () 144 | reportTransient msg = gets reportStateInteractive >>= \ case 145 | NonInteractive -> pass 146 | Interactive -> liftIO $ do 147 | hPutStr stderr msg 148 | hFlush stderr 149 | hPutStr stderr $ '\r' : (replicate (length msg) ' ') ++ "\r" 150 | 151 | -- | Run all examples from given module. 152 | runModule :: FastMode -> PreserveIt -> Interpreter -> Module [Located DocTest] -> Report () 153 | runModule fastMode preserveIt repl (Module module_ setup examples) = do 154 | 155 | Summary _ _ e0 f0 <- getSummary 156 | 157 | forM_ setup $ 158 | runTestGroup preserveIt repl reload 159 | 160 | Summary _ _ e1 f1 <- getSummary 161 | 162 | -- only run tests, if setup does not produce any errors/failures 163 | when (e0 == e1 && f0 == f1) $ 164 | forM_ examples $ runTestGroup preserveIt repl setup_ 165 | where 166 | reload :: IO () 167 | reload = do 168 | case fastMode of 169 | NoFastMode -> void $ Interpreter.safeEval repl ":reload" 170 | FastMode -> pass 171 | void $ Interpreter.safeEval repl $ ":m *" ++ module_ 172 | 173 | case preserveIt of 174 | NoPreserveIt -> pass 175 | PreserveIt -> do 176 | -- Evaluate a dumb expression to populate the 'it' variable. 177 | -- 178 | -- NOTE: This is one reason why we cannot just always use PreserveIt: 179 | -- 'it' isn't set in a fresh GHCi session. 180 | void $ Interpreter.safeEval repl $ "()" 181 | 182 | setup_ :: IO () 183 | setup_ = do 184 | reload 185 | forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of 186 | Property _ -> return () 187 | Example e _ -> void $ safeEvalWith preserveIt repl e 188 | 189 | reportStart :: Location -> Expression -> String -> Report () 190 | reportStart loc expression testType = do 191 | verboseReport (printf "### Started execution at %s.\n### %s:\n%s" (show loc) testType expression) 192 | 193 | reportFailure :: Location -> Expression -> [String] -> Report () 194 | reportFailure loc expression err = do 195 | report (printf "%s: failure in expression `%s'" (show loc) expression) 196 | mapM_ report err 197 | report "" 198 | updateSummary (Summary 0 1 0 1) 199 | 200 | reportError :: Location -> Expression -> String -> Report () 201 | reportError loc expression err = do 202 | report (printf "%s: error in expression `%s'" (show loc) expression) 203 | report err 204 | report "" 205 | updateSummary (Summary 0 1 1 0) 206 | 207 | reportSuccess :: Report () 208 | reportSuccess = do 209 | verboseReport "### Successful!\n" 210 | updateSummary (Summary 0 1 0 0) 211 | 212 | verboseReport :: String -> Report () 213 | verboseReport msg = gets reportStateVerbose >>= \ case 214 | NonVerbose -> pass 215 | Verbose -> report msg 216 | 217 | updateSummary :: Summary -> Report () 218 | updateSummary summary = do 219 | ref <- gets reportStateSummary 220 | liftIO $ modifyIORef' ref $ mappend summary 221 | reportProgress 222 | gets reportStateFailFast >>= \ case 223 | NoFailFast -> pass 224 | FailFast -> unless (isSuccess summary) abort 225 | 226 | abort :: Report () 227 | abort = MaybeT $ return Nothing 228 | 229 | reportProgress :: Report () 230 | reportProgress = gets reportStateVerbose >>= \ case 231 | NonVerbose -> do 232 | summary <- getSummary 233 | reportTransient (formatSummary summary) 234 | Verbose -> pass 235 | 236 | -- | Run given test group. 237 | -- 238 | -- The interpreter state is zeroed with @:reload@ first. This means that you 239 | -- can reuse the same 'Interpreter' for several test groups. 240 | runTestGroup :: PreserveIt -> Interpreter -> IO () -> [Located DocTest] -> Report () 241 | runTestGroup preserveIt repl setup tests = do 242 | liftIO setup 243 | runExampleGroup preserveIt repl examples 244 | 245 | forM_ properties $ \(loc, expression) -> do 246 | r <- do 247 | liftIO setup 248 | reportStart loc expression "property" 249 | liftIO $ runProperty repl expression 250 | case r of 251 | Success -> 252 | reportSuccess 253 | Error err -> do 254 | reportError loc expression err 255 | Failure msg -> do 256 | reportFailure loc expression [msg] 257 | where 258 | properties = [(loc, p) | Located loc (Property p) <- tests] 259 | 260 | examples :: [Located Interaction] 261 | examples = [Located loc (e, r) | Located loc (Example e r) <- tests] 262 | 263 | type Interaction = (Expression, ExpectedResult) 264 | 265 | -- | 266 | -- Execute all expressions from given example in given 'Interpreter' and verify 267 | -- the output. 268 | runExampleGroup :: PreserveIt -> Interpreter -> [Located Interaction] -> Report () 269 | runExampleGroup preserveIt repl = go 270 | where 271 | go ((Located loc (expression, expected)) : xs) = do 272 | reportStart loc expression "example" 273 | r <- fmap lines <$> liftIO (safeEvalWith preserveIt repl expression) 274 | case r of 275 | Left err -> do 276 | reportError loc expression err 277 | Right actual -> case mkResult expected actual of 278 | NotEqual err -> do 279 | reportFailure loc expression err 280 | Equal -> do 281 | reportSuccess 282 | go xs 283 | go [] = return () 284 | -------------------------------------------------------------------------------- /src/Runner/Example.hs: -------------------------------------------------------------------------------- 1 | module Runner.Example ( 2 | Result (..) 3 | , mkResult 4 | ) where 5 | 6 | import Imports 7 | 8 | import Data.Char 9 | import Data.List (isPrefixOf) 10 | import Util 11 | 12 | import Parse 13 | 14 | maxBy :: (Ord a) => (b -> a) -> b -> b -> b 15 | maxBy f x y = case compare (f x) (f y) of 16 | LT -> y 17 | EQ -> x 18 | GT -> x 19 | 20 | data Result = Equal | NotEqual [String] 21 | deriving (Eq, Show) 22 | 23 | mkResult :: ExpectedResult -> [String] -> Result 24 | mkResult expected_ actual_ = 25 | case expected `matches` actual of 26 | Full -> Equal 27 | Partial partial -> NotEqual (formatNotEqual expected actual partial) 28 | where 29 | -- use show to escape special characters in output lines if any output line 30 | -- contains any unsafe character 31 | escapeOutput 32 | | any (not . isSafe) $ concat (expectedAsString ++ actual_) = init . tail . show . stripEnd 33 | | otherwise = id 34 | 35 | actual :: [String] 36 | actual = fmap escapeOutput actual_ 37 | 38 | expected :: ExpectedResult 39 | expected = fmap (transformExcpectedLine escapeOutput) expected_ 40 | 41 | expectedAsString :: [String] 42 | expectedAsString = map (\x -> case x of 43 | ExpectedLine str -> concatMap lineChunkToString str 44 | WildCardLine -> "..." ) expected_ 45 | 46 | isSafe :: Char -> Bool 47 | isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) 48 | 49 | chunksMatch :: [LineChunk] -> String -> Match ChunksDivergence 50 | chunksMatch [] "" = Full 51 | chunksMatch [LineChunk xs] ys = 52 | if stripEnd xs == stripEnd ys 53 | then Full 54 | else Partial $ matchingPrefix xs ys 55 | chunksMatch (LineChunk x : xs) ys = 56 | if x `isPrefixOf` ys 57 | then fmap (prependText x) $ (xs `chunksMatch` drop (length x) ys) 58 | else Partial $ matchingPrefix x ys 59 | chunksMatch zs@(WildCardChunk : xs) (_:ys) = 60 | -- Prefer longer matches. 61 | fmap prependWildcard $ maxBy 62 | (fmap $ length . matchText) 63 | (chunksMatch xs ys) 64 | (chunksMatch zs ys) 65 | chunksMatch [WildCardChunk] [] = Full 66 | chunksMatch (WildCardChunk:_) [] = Partial (ChunksDivergence "" "") 67 | chunksMatch [] (_:_) = Partial (ChunksDivergence "" "") 68 | 69 | matchingPrefix xs ys = 70 | let common = fmap fst (takeWhile (\(x, y) -> x == y) (xs `zip` ys)) in 71 | ChunksDivergence common common 72 | 73 | matches :: ExpectedResult -> [String] -> Match LinesDivergence 74 | matches (ExpectedLine x : xs) (y : ys) = 75 | case x `chunksMatch` y of 76 | Full -> fmap incLineNo $ xs `matches` ys 77 | Partial partial -> Partial (LinesDivergence 1 (expandedWildcards partial)) 78 | matches zs@(WildCardLine : xs) us@(_ : ys) = 79 | -- Prefer longer matches, and later ones of equal length. 80 | let matchWithoutWC = xs `matches` us in 81 | let matchWithWC = fmap incLineNo (zs `matches` ys) in 82 | let key (LinesDivergence lineNo line) = (length line, lineNo) in 83 | maxBy (fmap key) matchWithoutWC matchWithWC 84 | matches [WildCardLine] [] = Full 85 | matches [] [] = Full 86 | matches [] _ = Partial (LinesDivergence 1 "") 87 | matches _ [] = Partial (LinesDivergence 1 "") 88 | 89 | -- Note: order of constructors matters, so that full matches sort as 90 | -- greater than partial. 91 | data Match a = Partial a | Full 92 | deriving (Eq, Ord, Show) 93 | 94 | instance Functor Match where 95 | fmap f (Partial a) = Partial (f a) 96 | fmap _ Full = Full 97 | 98 | data ChunksDivergence = ChunksDivergence { matchText :: String, expandedWildcards :: String } 99 | deriving (Show) 100 | 101 | prependText :: String -> ChunksDivergence -> ChunksDivergence 102 | prependText s (ChunksDivergence mt wct) = ChunksDivergence (s++mt) (s++wct) 103 | 104 | prependWildcard :: ChunksDivergence -> ChunksDivergence 105 | prependWildcard (ChunksDivergence mt wct) = ChunksDivergence mt ('.':wct) 106 | 107 | data LinesDivergence = LinesDivergence { _mismatchLineNo :: Int, _partialLine :: String } 108 | deriving (Show) 109 | 110 | incLineNo :: LinesDivergence -> LinesDivergence 111 | incLineNo (LinesDivergence lineNo partialLineMatch) = LinesDivergence (lineNo + 1) partialLineMatch 112 | 113 | formatNotEqual :: ExpectedResult -> [String] -> LinesDivergence -> [String] 114 | formatNotEqual expected_ actual partial = formatLines "expected: " expected ++ formatLines " but got: " (lineMarker wildcard partial actual) 115 | where 116 | expected :: [String] 117 | expected = map (\x -> case x of 118 | ExpectedLine str -> concatMap lineChunkToString str 119 | WildCardLine -> "..." ) expected_ 120 | 121 | formatLines :: String -> [String] -> [String] 122 | formatLines message xs = case xs of 123 | y:ys -> (message ++ y) : map (padding ++) ys 124 | [] -> [message] 125 | where 126 | padding = replicate (length message) ' ' 127 | 128 | wildcard :: Bool 129 | wildcard = any (\x -> case x of 130 | ExpectedLine xs -> any (\y -> case y of { WildCardChunk -> True; _ -> False }) xs 131 | WildCardLine -> True ) expected_ 132 | 133 | lineChunkToString :: LineChunk -> String 134 | lineChunkToString WildCardChunk = "..." 135 | lineChunkToString (LineChunk str) = str 136 | 137 | transformExcpectedLine :: (String -> String) -> ExpectedLine -> ExpectedLine 138 | transformExcpectedLine f (ExpectedLine xs) = 139 | ExpectedLine $ fmap (\el -> case el of 140 | LineChunk s -> LineChunk $ f s 141 | WildCardChunk -> WildCardChunk 142 | ) xs 143 | transformExcpectedLine _ WildCardLine = WildCardLine 144 | 145 | lineMarker :: Bool -> LinesDivergence -> [String] -> [String] 146 | lineMarker wildcard (LinesDivergence row expanded) actual = 147 | let (pre, post) = splitAt row actual in 148 | pre ++ 149 | [(if wildcard && length expanded > 30 150 | -- show expanded pattern if match is long, to help understanding what matched what 151 | then expanded 152 | else replicate (length expanded) ' ') ++ "^"] ++ 153 | post 154 | -------------------------------------------------------------------------------- /src/Test/DocTest.hs: -------------------------------------------------------------------------------- 1 | module Test.DocTest ( 2 | doctest 3 | ) where 4 | import Test.DocTest.Internal.Run 5 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Cabal.hs: -------------------------------------------------------------------------------- 1 | module Test.DocTest.Internal.Cabal ( 2 | doctest 3 | ) where 4 | 5 | import Imports 6 | 7 | import qualified Cabal 8 | 9 | doctest :: [String] -> IO () 10 | doctest = Cabal.externalCommand 11 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Extract.hs: -------------------------------------------------------------------------------- 1 | module Test.DocTest.Internal.Extract ( 2 | module Extract 3 | ) where 4 | import Extract 5 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Location.hs: -------------------------------------------------------------------------------- 1 | module Test.DocTest.Internal.Location ( 2 | module Location 3 | ) where 4 | import Location 5 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Parse.hs: -------------------------------------------------------------------------------- 1 | module Test.DocTest.Internal.Parse ( 2 | module Parse 3 | ) where 4 | import Parse 5 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Run.hs: -------------------------------------------------------------------------------- 1 | module Test.DocTest.Internal.Run ( 2 | module Run 3 | ) where 4 | import Run 5 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util where 2 | 3 | import Imports 4 | 5 | import Data.Char 6 | 7 | convertDosLineEndings :: String -> String 8 | convertDosLineEndings = go 9 | where 10 | go input = case input of 11 | '\r':'\n':xs -> '\n' : go xs 12 | 13 | -- Haddock comments from source files with dos line endings end with a 14 | -- CR, so we strip that, too. 15 | "\r" -> "" 16 | 17 | x:xs -> x : go xs 18 | "" -> "" 19 | 20 | -- | Return the longest suffix of elements that satisfy a given predicate. 21 | takeWhileEnd :: (a -> Bool) -> [a] -> [a] 22 | takeWhileEnd p = reverse . takeWhile p . reverse 23 | 24 | -- | Remove trailing white space from a string. 25 | -- 26 | -- >>> stripEnd "foo " 27 | -- "foo" 28 | stripEnd :: String -> String 29 | stripEnd = reverse . dropWhile isSpace . reverse 30 | -------------------------------------------------------------------------------- /test/Cabal/OptionsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Cabal.OptionsSpec (spec) where 3 | 4 | import Imports 5 | 6 | import Test.Hspec 7 | 8 | import System.IO 9 | import System.IO.Silently 10 | import System.Exit 11 | import System.Process 12 | import Data.Set ((\\)) 13 | import qualified Data.Set as Set 14 | 15 | import qualified Cabal.ReplOptionsSpec as Repl 16 | 17 | import Cabal.Options 18 | 19 | spec :: Spec 20 | spec = do 21 | describe "replOnlyOptions" $ do 22 | it "is the set of options that are unique to 'cabal repl'" $ do 23 | build <- Set.fromList . lines <$> readProcess "cabal" ["build", "--list-options"] "" 24 | repl <- Set.fromList . lines <$> readProcess "cabal" ["repl", "--list-options"] "" 25 | Set.toList replOnlyOptions `shouldMatchList` Set.toList (repl \\ build) 26 | 27 | describe "rejectUnsupportedOptions" $ do 28 | it "produces error messages that are consistent with 'cabal repl'" $ do 29 | let 30 | shouldFail :: HasCallStack => String -> IO a -> Expectation 31 | shouldFail command action = do 32 | hCapture_ [stderr] (action `shouldThrow` (== ExitFailure 1)) 33 | `shouldReturn` "Error: cabal: unrecognized '" <> command <> "' option `--installdir'\n" 34 | 35 | #ifndef mingw32_HOST_OS 36 | shouldFail "repl" $ call "cabal" ["repl", "--installdir"] 37 | #endif 38 | shouldFail "doctest" $ rejectUnsupportedOptions ["--installdir"] 39 | 40 | context "with --list-options" $ do 41 | it "lists supported command-line options" $ do 42 | repl <- Set.fromList . lines <$> readProcess "cabal" ["repl", "--list-options"] "" 43 | doctest <- Set.fromList . lines <$> capture_ (rejectUnsupportedOptions ["--list-options"] `shouldThrow` (== ExitSuccess)) 44 | Set.toList (doctest \\ repl) `shouldMatchList` [] 45 | Set.toList (repl \\ doctest) `shouldMatchList` Set.toList Repl.unsupported 46 | 47 | describe "discardReplOptions" $ do 48 | it "discards 'cabal repl'-only options" $ do 49 | discardReplOptions [ 50 | "-w", "ghc-9.10" 51 | , "--build-depends=foo" 52 | , "--build-depends", "foo" 53 | , "-bfoo" 54 | , "-b", "foo" 55 | , "--disable-optimization" 56 | , "--enable-multi-repl" 57 | , "--repl-options", "foo" 58 | , "--repl-options=foo" 59 | , "--allow-newer" 60 | ] `shouldBe` ["--with-compiler=ghc-9.10", "--disable-optimization", "--allow-newer"] 61 | -------------------------------------------------------------------------------- /test/Cabal/PathsSpec.hs: -------------------------------------------------------------------------------- 1 | module Cabal.PathsSpec (spec) where 2 | 3 | import Imports 4 | 5 | import Test.Hspec 6 | 7 | import System.Directory 8 | 9 | import Cabal () 10 | import Cabal.Paths 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "paths" $ do 15 | it "returns the path to 'ghc'" $ do 16 | (paths "cabal" [] >>= doesFileExist . ghc) `shouldReturn` True 17 | 18 | it "returns the path to 'ghc-pkg'" $ do 19 | (paths "cabal" [] >>= doesFileExist . ghcPkg) `shouldReturn` True 20 | 21 | it "returns the path to Cabal's cache directory" $ do 22 | (paths "cabal" [] >>= doesDirectoryExist . cache) `shouldReturn` True 23 | -------------------------------------------------------------------------------- /test/Cabal/ReplOptionsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | module Cabal.ReplOptionsSpec (spec, unsupported) where 4 | 5 | import Imports 6 | 7 | import Test.Hspec 8 | 9 | import Data.List 10 | import System.Process 11 | import Data.Set (Set) 12 | import qualified Data.Set as Set 13 | 14 | import Cabal.ReplOptions 15 | 16 | phony :: [String] 17 | phony = [ 18 | "with-PROG" 19 | , "PROG-option" 20 | , "PROG-options" 21 | ] 22 | 23 | undocumented :: Set String 24 | undocumented = Set.fromList [ 25 | "--enable-optimisation" 26 | , "--disable-optimisation" 27 | , "--haddock-hyperlink-sources" 28 | , "--haddock-hyperlinked-source" 29 | ] 30 | 31 | unsupported :: Set String 32 | unsupported = undocumented <> Set.fromList (map ("--" <>) phony) 33 | 34 | spec :: Spec 35 | spec = do 36 | describe "options" $ do 37 | it "is the list of documented 'repl' options" $ do 38 | documentedOptions <- parseOptions <$> readProcess "cabal" ["help", "repl"] "" 39 | options `shouldBe` filter (optionName >>> (`notElem` phony)) documentedOptions 40 | 41 | it "is consistent with 'cabal repl --list-options'" $ do 42 | let 43 | optionNames :: Option -> [String] 44 | optionNames option = reverse $ "--" <> optionName option : case optionShortName option of 45 | Nothing -> [] 46 | Just c -> [['-', c]] 47 | 48 | repl <- filter (`Set.notMember` unsupported) . lines <$> readProcess "cabal" ["repl", "--list-options"] "" 49 | concatMap optionNames options `shouldBe` repl 50 | 51 | parseOptions :: String -> [Option] 52 | parseOptions = map parseOption . takeOptions 53 | where 54 | parseOption :: String -> Option 55 | parseOption input = case input of 56 | longAndHelp@('-':'-':_) -> parseLongOption Nothing longAndHelp 57 | '-':short:',':' ':longAndHelp -> parseLongOption (Just short) longAndHelp 58 | '-':short:'[':(breakOn ']' -> 59 | (_arg, ']':',':' ':longAndHelp)) -> parseLongOption (Just short) longAndHelp 60 | '-':short:' ':(breakOn ' ' -> 61 | (arg, ' ':'o':'r':' ':(stripPrefix ('-':short:arg) -> 62 | Just (',':' ':longAndHelp)))) -> parseLongOption (Just short) longAndHelp 63 | _ -> err 64 | where 65 | parseLongOption :: Maybe Char -> String -> Option 66 | parseLongOption short longAndHelp = case breakOnAny " [=" longAndHelp of 67 | ('-':'-':long, ' ':help) -> accept long NoArgument help 68 | ('-':'-':long, '[':'=': (breakOn ']' -> 69 | (arg, ']':help))) -> accept long (OptionalArgument arg) help 70 | ('-':'-':long, '=':(breakOn ' ' -> 71 | (arg, ' ':help))) -> accept long (Argument arg) help 72 | _ -> err 73 | where 74 | accept :: String -> Argument -> String -> Option 75 | accept long arg help = Option long short arg (strip help) 76 | 77 | err :: HasCallStack => Option 78 | err = error input 79 | 80 | breakOn c = break (== c) 81 | breakOnAny xs = break (`elem` xs) 82 | 83 | takeOptions :: String -> [String] 84 | takeOptions input = map strip . joinLines $ case break (== "Flags for repl:") (lines input) of 85 | (_, "Flags for repl:" : xs) -> case break (== "") xs of 86 | (ys, "" : _) -> ys 87 | _ -> undefined 88 | _ -> undefined 89 | 90 | joinLines :: [String] -> [String] 91 | joinLines = go 92 | where 93 | go = \ case 94 | x : y : ys | isOption y -> x : go (y : ys) 95 | x : y : ys -> go $ (x ++ ' ' : strip y) : ys 96 | x : xs -> x : xs 97 | [] -> [] 98 | 99 | isOption = isPrefixOf " -" 100 | -------------------------------------------------------------------------------- /test/ExtractSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | 5 | module ExtractSpec (main, spec) where 6 | 7 | import Imports 8 | 9 | import Test.Hspec 10 | import Test.HUnit 11 | 12 | 13 | #if __GLASGOW_HASKELL__ < 900 14 | import Panic (GhcException (..)) 15 | #else 16 | import GHC.Utils.Panic (GhcException (..)) 17 | #endif 18 | 19 | import Extract 20 | import Location 21 | import System.FilePath 22 | 23 | shouldGive :: HasCallStack => (String, String) -> [Module String] -> Assertion 24 | (d, m) `shouldGive` expected = do 25 | r <- map (fmap unLoc) `fmap` extract ["-i" ++ dir, dir m] 26 | r `shouldBe` expected 27 | where dir = "test/extract" d 28 | 29 | main :: IO () 30 | main = hspec spec 31 | 32 | spec :: Spec 33 | spec = do 34 | 35 | describe "extract" $ do 36 | it "extracts documentation for a top-level declaration" $ do 37 | ("declaration", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Some documentation"]] 38 | 39 | it "extracts documentation from argument list" $ do 40 | ("argument-list", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" doc for arg1", " doc for arg2"]] 41 | 42 | it "extracts documentation for a type class function" $ do 43 | ("type-class", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Convert given value to a string."]] 44 | 45 | it "extracts documentation from the argument list of a type class function" $ do 46 | ("type-class-args", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" foo", " bar"]] 47 | 48 | it "extracts documentation from the module header" $ do 49 | ("module-header", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Some documentation"]] 50 | 51 | it "extracts documentation from imported modules" $ do 52 | ("imported-module", "Bar.hs") `shouldGive` [Module "Bar" Nothing [" documentation for bar"], Module "Baz" Nothing [" documentation for baz"]] 53 | 54 | it "extracts documentation from export list" $ do 55 | ("export-list", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" documentation from export list"]] 56 | 57 | it "extracts documentation from named chunks" $ do 58 | ("named-chunks", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" named chunk foo", "\n named chunk bar"]] 59 | 60 | it "returns docstrings in the same order they appear in the source" $ do 61 | ("comment-order", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]] 62 | 63 | it "extracts $setup code" $ do 64 | ("setup", "Foo.hs") `shouldGive` [Module "Foo" (Just "\n some setup code") [" foo", " bar", " baz"]] 65 | 66 | it "fails on invalid flags" $ do 67 | extract ["--foobar", "test/Foo.hs"] `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False) 68 | 69 | describe "extract (regression tests)" $ do 70 | it "works with infix operators" $ do 71 | ("regression", "Fixity.hs") `shouldGive` [Module "Fixity" Nothing []] 72 | 73 | it "works with parallel list comprehensions" $ do 74 | ("regression", "ParallelListComp.hs") `shouldGive` [Module "ParallelListComp" Nothing []] 75 | 76 | it "works with list comprehensions in instance definitions" $ do 77 | ("regression", "ParallelListCompClass.hs") `shouldGive` [Module "ParallelListCompClass" Nothing []] 78 | 79 | it "works with foreign imports" $ do 80 | ("regression", "ForeignImport.hs") `shouldGive` [Module "ForeignImport" Nothing []] 81 | 82 | it "works for rewrite rules" $ do 83 | ("regression", "RewriteRules.hs") `shouldGive` [Module "RewriteRules" Nothing [" doc for foo"]] 84 | 85 | it "works for rewrite rules with type signatures" $ do 86 | ("regression", "RewriteRulesWithSigs.hs") `shouldGive` [Module "RewriteRulesWithSigs" Nothing [" doc for foo"]] 87 | 88 | it "strips CR from dos line endings" $ do 89 | ("dos-line-endings", "Foo.hs") `shouldGive` [Module "Foo" Nothing ["\n foo\n bar\n baz"]] 90 | 91 | it "works with a module that splices in an expression from an other module" $ do 92 | ("th", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" some documentation"], Module "Bar" Nothing []] 93 | 94 | it "works for type families and GHC 7.6.1" $ do 95 | ("type-families", "Foo.hs") `shouldGive` [Module "Foo" Nothing []] 96 | -------------------------------------------------------------------------------- /test/InfoSpec.hs: -------------------------------------------------------------------------------- 1 | module InfoSpec (spec) where 2 | 3 | import Imports 4 | 5 | import Test.Hspec 6 | 7 | import System.Process 8 | 9 | import Info (formatInfo) 10 | import Interpreter (ghc) 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "formatInfo" $ do 15 | it "formats --info output" $ do 16 | info <- readProcess ghc ["--info"] "" 17 | formatInfo (read info) `shouldBe` info 18 | -------------------------------------------------------------------------------- /test/InterpreterSpec.hs: -------------------------------------------------------------------------------- 1 | module InterpreterSpec (spec) where 2 | 3 | import Imports 4 | 5 | import Test.Hspec 6 | 7 | import Interpreter (Interpreter, interpreterSupported, haveInterpreterKey, ghcInfo, ghc, safeEval, filterExpression) 8 | import qualified Interpreter 9 | 10 | withInterpreter :: (Interpreter -> IO a) -> IO a 11 | withInterpreter = Interpreter.withInterpreter (Interpreter.ghc, ["--interactive"]) 12 | 13 | spec :: Spec 14 | spec = do 15 | describe "interpreterSupported" $ do 16 | it "indicates whether GHCi is supported on current platform" $ do 17 | (Interpreter.interpreterSupported >> return ()) `shouldReturn` () 18 | 19 | describe "ghcInfo" $ do 20 | it ("includes " ++ show haveInterpreterKey) $ do 21 | info <- ghcInfo 22 | lookup haveInterpreterKey info `shouldSatisfy` 23 | (||) <$> (== Just "YES") <*> (== Just "NO") 24 | 25 | describe "safeEval" $ do 26 | it "evaluates an expression" $ withInterpreter $ \ ghci -> do 27 | Interpreter.safeEval ghci "23 + 42" `shouldReturn` Right "65\n" 28 | 29 | it "returns Left on unterminated multiline command" $ withInterpreter $ \ ghci -> do 30 | Interpreter.safeEval ghci ":{\n23 + 42" `shouldReturn` Left "unterminated multi-line command" 31 | 32 | describe "filterExpression" $ do 33 | it "removes :set -XTemplateHaskell" $ do 34 | filterExpression ":set -XTemplateHaskell" `shouldBe` Right "" 35 | 36 | it "filters -XTemplateHaskell" $ do 37 | filterExpression ":set -XTemplateHaskell -XCPP" `shouldBe` Right ":set -XCPP" 38 | 39 | it "leaves :set-statement that do not set -XTemplateHaskell alone " $ do 40 | filterExpression ":set -XFoo -XBar" `shouldBe` Right ":set -XFoo -XBar" 41 | -------------------------------------------------------------------------------- /test/Language/Haskell/GhciWrapperSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.Haskell.GhciWrapperSpec (main, spec) where 3 | 4 | import Imports 5 | 6 | import Test.Hspec 7 | import System.IO.Silently 8 | 9 | import Data.List 10 | 11 | import Language.Haskell.GhciWrapper (Interpreter, Config(..), defaultConfig, PreserveIt(..)) 12 | import qualified Language.Haskell.GhciWrapper as Interpreter 13 | 14 | main :: IO () 15 | main = hspec spec 16 | 17 | withInterpreterConfig :: Config -> [String] -> (Interpreter -> IO a) -> IO a 18 | withInterpreterConfig config args = bracket (Interpreter.new config args) Interpreter.close 19 | 20 | withInterpreterArgs :: [String] -> ((String -> IO String) -> IO a) -> IO a 21 | withInterpreterArgs args action = withInterpreterConfig defaultConfig args $ action . Interpreter.eval 22 | 23 | withInterpreter :: ((String -> IO String) -> IO a) -> IO a 24 | withInterpreter = withInterpreterArgs [] 25 | 26 | spec :: Spec 27 | spec = do 28 | describe "evalEcho" $ do 29 | it "prints result to stdout" $ do 30 | withInterpreterConfig defaultConfig [] $ \ghci -> do 31 | (capture $ Interpreter.evalEcho ghci ("putStr" ++ show "foo\nbar")) `shouldReturn` ("foo\nbar", "foo\nbar") 32 | 33 | describe "evalWith" $ do 34 | context "with PreserveIt" $ do 35 | it "preserves it" $ do 36 | withInterpreterConfig defaultConfig [] $ \ghci -> do 37 | Interpreter.evalWith PreserveIt ghci "23" `shouldReturn` "23\n" 38 | Interpreter.eval ghci "it" `shouldReturn` "23\n" 39 | 40 | describe "eval" $ do 41 | it "shows literals" $ withInterpreter $ \ghci -> do 42 | ghci "23" `shouldReturn` "23\n" 43 | 44 | it "shows string literals containing Unicode" $ withInterpreter $ \ghci -> do 45 | ghci "\"λ\"" `shouldReturn` "\"\\955\"\n" 46 | 47 | it "evaluates simple expressions" $ withInterpreter $ \ghci -> do 48 | ghci "23 + 42" `shouldReturn` "65\n" 49 | 50 | it "supports let bindings" $ withInterpreter $ \ghci -> do 51 | ghci "let x = 10" `shouldReturn` "" 52 | ghci "x" `shouldReturn` "10\n" 53 | 54 | it "allows import statements" $ withInterpreter $ \ghci -> do 55 | ghci "import Data.Maybe" `shouldReturn` "" 56 | ghci "fromJust (Just 20)" `shouldReturn` "20\n" 57 | 58 | it "captures stdout" $ withInterpreter $ \ghci -> do 59 | ghci "putStr \"foo\"" `shouldReturn` "foo" 60 | 61 | it "captures stdout (Unicode)" $ withInterpreter $ \ghci -> do 62 | ghci "putStrLn \"λ\"" `shouldReturn` "λ\n" 63 | 64 | it "captures stdout (empty line)" $ withInterpreter $ \ghci -> do 65 | ghci "putStrLn \"\"" `shouldReturn` "\n" 66 | 67 | it "captures stdout (multiple lines)" $ withInterpreter $ \ghci -> do 68 | ghci "putStrLn \"foo\" >> putStrLn \"bar\" >> putStrLn \"baz\"" 69 | `shouldReturn` "foo\nbar\nbaz\n" 70 | 71 | it "captures stderr" $ withInterpreter $ \ghci -> do 72 | ghci "import System.IO" `shouldReturn` "" 73 | ghci "hPutStrLn stderr \"foo\"" `shouldReturn` "foo\n" 74 | 75 | it "captures stderr (Unicode)" $ withInterpreter $ \ghci -> do 76 | ghci "import System.IO" `shouldReturn` "" 77 | ghci "hPutStrLn stderr \"λ\"" `shouldReturn` "λ\n" 78 | 79 | it "shows exceptions" $ withInterpreter $ \ghci -> do 80 | ghci "import Control.Exception" `shouldReturn` "" 81 | #if __GLASGOW_HASKELL__ >= 912 82 | ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n\nHasCallStack backtrace:\n throwIO, called at :25:1 in interactive:Ghci22\n\n" 83 | #else 84 | ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n" 85 | #endif 86 | 87 | it "shows exceptions (ExitCode)" $ withInterpreter $ \ghci -> do 88 | ghci "import System.Exit" `shouldReturn` "" 89 | ghci "exitWith $ ExitFailure 10" `shouldReturn` "*** Exception: ExitFailure 10\n" 90 | 91 | it "gives an error message for identifiers that are not in scope" $ withInterpreter $ \ghci -> do 92 | #if __GLASGOW_HASKELL__ >= 800 93 | ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo") 94 | #elif __GLASGOW_HASKELL__ >= 707 95 | ghci "foo" >>= (`shouldSatisfy` isSuffixOf "Not in scope: \8216foo\8217\n") 96 | #else 97 | ghci "foo" >>= (`shouldSatisfy` isSuffixOf "Not in scope: `foo'\n") 98 | #endif 99 | context "when configVerbose is True" $ do 100 | it "prints prompt" $ do 101 | withInterpreterConfig defaultConfig{configVerbose = True} [] $ \ghci -> do 102 | Interpreter.eval ghci "print 23" >>= (`shouldSatisfy` 103 | (`elem` [ "Prelude> 23\nPrelude> " 104 | , "ghci> 23\nghci> " 105 | ])) 106 | 107 | context "with -XOverloadedStrings, -Wall and -Werror" $ do 108 | it "does not fail on marker expression (bug fix)" $ withInterpreter $ \ghci -> do 109 | ghci ":seti -XOverloadedStrings -Wall -Werror" `shouldReturn` "" 110 | ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" 111 | 112 | context "with NoImplicitPrelude" $ do 113 | it "works" $ withInterpreterArgs ["-XNoImplicitPrelude"] $ \ghci -> do 114 | ghci "putStrLn \"foo\"" >>= (`shouldContain` "Variable not in scope: putStrLn") 115 | ghci "23" `shouldReturn` "23\n" 116 | 117 | context "with a strange String type" $ do 118 | it "works" $ withInterpreter $ \ghci -> do 119 | ghci "type String = Int" `shouldReturn` "" 120 | ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" 121 | -------------------------------------------------------------------------------- /test/LocationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module LocationSpec (main, spec) where 4 | 5 | import Imports 6 | 7 | import Test.Hspec 8 | 9 | import Location 10 | 11 | #if __GLASGOW_HASKELL__ < 900 12 | import SrcLoc 13 | import FastString (fsLit) 14 | #else 15 | import GHC.Types.SrcLoc 16 | import GHC.Data.FastString (fsLit) 17 | #endif 18 | 19 | main :: IO () 20 | main = hspec spec 21 | 22 | spec :: Spec 23 | spec = do 24 | 25 | describe "toLocation" $ do 26 | 27 | it "works for a regular SrcSpan" $ do 28 | toLocation (mkSrcSpan (mkSrcLoc (fsLit "Foo.hs") 2 5) (mkSrcLoc (fsLit "Foo.hs") 10 20)) 29 | `shouldBe` Location "Foo.hs" 2 30 | 31 | it "works for a single-line SrcSpan" $ do 32 | toLocation (mkSrcSpan (mkSrcLoc (fsLit "Foo.hs") 2 5) (mkSrcLoc (fsLit "Foo.hs") 2 10)) 33 | `shouldBe` Location "Foo.hs" 2 34 | 35 | it "works for a SrcSpan that corresponds to single point" $ do 36 | (toLocation . srcLocSpan) (mkSrcLoc (fsLit "Foo.hs") 10 20) 37 | `shouldBe` Location "Foo.hs" 10 38 | 39 | it "works for a bad SrcSpan" $ do 40 | toLocation noSrcSpan `shouldBe` UnhelpfulLocation "" 41 | 42 | it "works for a SrcLoc with bad locations" $ do 43 | toLocation (mkSrcSpan noSrcLoc noSrcLoc) 44 | `shouldBe` UnhelpfulLocation "" 45 | 46 | describe "enumerate" $ do 47 | it "replicates UnhelpfulLocation" $ do 48 | let loc = UnhelpfulLocation "foo" 49 | (take 10 $ enumerate loc) `shouldBe` replicate 10 loc 50 | 51 | it "enumerates Location" $ do 52 | let loc = Location "Foo.hs" 23 53 | (take 3 $ enumerate loc) `shouldBe` [Location "Foo.hs" 23, Location "Foo.hs" 24, Location "Foo.hs" 25] 54 | -------------------------------------------------------------------------------- /test/MainSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | module MainSpec (main, spec) where 4 | 5 | import Imports 6 | 7 | import Test.Hspec 8 | import Test.HUnit (assertEqual, Assertion) 9 | 10 | import System.Directory (getCurrentDirectory, setCurrentDirectory) 11 | import System.FilePath 12 | import Run hiding (doctest, doctestWith) 13 | import System.IO.Silently 14 | import System.IO 15 | 16 | withCurrentDirectory :: FilePath -> IO a -> IO a 17 | withCurrentDirectory workingDir action = do 18 | bracket getCurrentDirectory setCurrentDirectory $ \_ -> do 19 | setCurrentDirectory workingDir 20 | action 21 | 22 | doctest :: HasCallStack => FilePath -> [String] -> Summary -> Assertion 23 | doctest = doctestWith False False 24 | 25 | doctestWithPreserveIt :: HasCallStack => FilePath -> [String] -> Summary -> Assertion 26 | doctestWithPreserveIt = doctestWith True False 27 | 28 | doctestWithFailFast :: HasCallStack => FilePath -> [String] -> Summary -> Assertion 29 | doctestWithFailFast = doctestWith False True 30 | 31 | doctestWith :: HasCallStack => Bool -> Bool -> FilePath -> [String] -> Summary -> Assertion 32 | doctestWith preserveIt failFast workingDir ghcOptions expected = do 33 | actual <- withCurrentDirectory ("test/integration" workingDir) (hSilence [stderr] $ doctestWithResult defaultConfig {ghcOptions, preserveIt, failFast}) 34 | assertEqual label (formatSummary expected) (formatSummary actual) 35 | where 36 | label = workingDir ++ " " ++ show ghcOptions 37 | 38 | cases :: Int -> Summary 39 | cases n = Summary n n 0 0 40 | 41 | main :: IO () 42 | main = hspec spec 43 | 44 | spec :: Spec 45 | spec = do 46 | describe "doctest" $ do 47 | it "testSimple" $ do 48 | doctest "." ["testSimple/Fib.hs"] 49 | (cases 1) 50 | 51 | it "it-variable" $ do 52 | doctestWithPreserveIt "." ["it/Foo.hs"] 53 | (cases 5) 54 | 55 | it "it-variable in $setup" $ do 56 | doctestWithPreserveIt "." ["it/Setup.hs"] 57 | (cases 5) 58 | 59 | it "failing" $ do 60 | doctest "." ["failing/Foo.hs"] 61 | (cases 1) {sFailures = 1} 62 | 63 | it "skips subsequent examples from the same group if an example fails" $ do 64 | doctest "." ["failing-multiple/Foo.hs"] 65 | (cases 4) {sTried = 2, sFailures = 1} 66 | 67 | context "without --fail-fast" $ do 68 | it "continuous even if some tests fail" $ do 69 | doctest "fail-fast" ["Foo.hs"] 70 | (cases 4) {sTried = 4, sFailures = 1} 71 | 72 | context "with --fail-fast" $ do 73 | it "stops after the first failure" $ do 74 | doctestWithFailFast "fail-fast" ["Foo.hs"] 75 | (cases 4) {sTried = 2, sFailures = 1} 76 | 77 | it "stops after failures in $setup" $ do 78 | doctestWithFailFast "fail-fast" ["SetupFoo.hs"] 79 | (cases 6) {sTried = 1, sFailures = 1} 80 | 81 | it "testImport" $ do 82 | doctest "testImport" ["ModuleA.hs"] 83 | (cases 3) 84 | doctest ".." ["-iintegration/testImport", "integration/testImport/ModuleA.hs"] 85 | (cases 3) 86 | 87 | it "testCommentLocation" $ do 88 | doctest "." ["testCommentLocation/Foo.hs"] 89 | (cases 11) 90 | 91 | it "testPutStr" $ do 92 | doctest "testPutStr" ["Fib.hs"] 93 | (cases 3) 94 | 95 | it "fails on multi-line expressions, introduced with :{" $ do 96 | doctest "testFailOnMultiline" ["Fib.hs"] 97 | (cases 2) {sErrors = 2} 98 | 99 | it "testBlankline" $ do 100 | doctest "testBlankline" ["Fib.hs"] 101 | (cases 1) 102 | 103 | it "examples from the same Haddock comment share the same scope" $ do 104 | doctest "testCombinedExample" ["Fib.hs"] 105 | (cases 4) 106 | 107 | it "testDocumentationForArguments" $ do 108 | doctest "testDocumentationForArguments" ["Fib.hs"] 109 | (cases 1) 110 | 111 | it "template-haskell" $ do 112 | doctest "template-haskell" ["Foo.hs"] 113 | (cases 2) 114 | 115 | it "handles source files with CRLF line endings" $ do 116 | doctest "dos-line-endings" ["Fib.hs"] 117 | (cases 1) 118 | 119 | it "runs $setup before each test group" $ do 120 | doctest "setup" ["Foo.hs"] 121 | (cases 2) 122 | 123 | it "skips subsequent tests from a module, if $setup fails" $ do 124 | doctest "setup-skip-on-failure" ["Foo.hs"] 125 | (cases 3) {sTried = 1, sFailures = 1} 126 | 127 | -- Andreas, 2021-02-27, see issue #294. 128 | -- This test case contains a hard-wired path that does not work 129 | -- with v2-cabal. 130 | -- I tested it under v2-cabal with a very non-portable path. 131 | -- Deactivating the test case until a systematic solution is found... 132 | -- 133 | -- it "works with additional object files" $ do 134 | -- -- -- Path for v1-cabal: 135 | -- -- doctest "with-cbits" ["Bar.hs", "../../../dist/build/spec/spec-tmp/test/integration/with-cbits/foo.o"] 136 | -- -- -- Path for v2-cabal with ghc-9.0.1 137 | -- -- doctest "with-cbits" ["Bar.hs", "../../../dist-newstyle/build/x86_64-osx/ghc-9.0.1/doctest-0.19/t/spec/build/spec/spec-tmp/Test/integration/with-cbits/foo.o"] 138 | -- (cases 1) 139 | 140 | it "ignores trailing whitespace when matching test output" $ do 141 | doctest "trailing-whitespace" ["Foo.hs"] 142 | (cases 1) 143 | 144 | describe "doctest as a runner for QuickCheck properties" $ do 145 | it "runs a boolean property" $ do 146 | doctest "property-bool" ["Foo.hs"] 147 | (cases 1) 148 | 149 | it "runs an explicitly quantified property" $ do 150 | doctest "property-quantified" ["Foo.hs"] 151 | (cases 1) 152 | 153 | it "runs an implicitly quantified property" $ do 154 | doctest "property-implicitly-quantified" ["Foo.hs"] 155 | (cases 1) 156 | 157 | it "reports a failing property" $ do 158 | doctest "property-failing" ["Foo.hs"] 159 | (cases 1) {sFailures = 1} 160 | 161 | it "runs a boolean property with an explicit type signature" $ do 162 | doctest "property-bool-with-type-signature" ["Foo.hs"] 163 | (cases 1) 164 | 165 | it "runs $setup before each property" $ do 166 | doctest "property-setup" ["Foo.hs"] 167 | (cases 3) 168 | 169 | describe "doctest (regression tests)" $ do 170 | it "bugfixWorkingDirectory" $ do 171 | doctest "bugfixWorkingDirectory" ["Fib.hs"] 172 | (cases 1) 173 | doctest "bugfixWorkingDirectory" ["examples/Fib.hs"] 174 | (cases 2) 175 | 176 | it "bugfixOutputToStdErr" $ do 177 | doctest "bugfixOutputToStdErr" ["Fib.hs"] 178 | (cases 2) 179 | 180 | it "bugfixImportHierarchical" $ do 181 | doctest "bugfixImportHierarchical" ["ModuleA.hs", "ModuleB.hs"] 182 | (cases 3) 183 | 184 | it "bugfixMultipleModules" $ do 185 | doctest "bugfixMultipleModules" ["ModuleA.hs"] 186 | (cases 5) 187 | 188 | it "testCPP" $ do 189 | doctest "testCPP" ["-cpp", "Foo.hs"] 190 | (cases 1) {sFailures = 1} 191 | doctest "testCPP" ["-cpp", "-DFOO", "Foo.hs"] 192 | (cases 1) 193 | 194 | it "template-haskell-bugfix" $ do 195 | doctest "template-haskell-bugfix" ["Main.hs"] 196 | (cases 2) 197 | 198 | it "doesn't clash with user bindings of stdout/stderr" $ do 199 | doctest "local-stderr-binding" ["A.hs"] 200 | (cases 1) 201 | 202 | it "doesn't get confused by doctests using System.IO imports" $ do 203 | doctest "system-io-imported" ["A.hs"] 204 | (cases 1) 205 | -------------------------------------------------------------------------------- /test/OptionsSpec.hs: -------------------------------------------------------------------------------- 1 | module OptionsSpec (spec) where 2 | 3 | import Imports 4 | 5 | import Data.List 6 | 7 | import Test.Hspec 8 | import Test.QuickCheck hiding (verbose) 9 | 10 | import Options 11 | 12 | newtype NonInteractive = NonInteractive String 13 | deriving (Eq, Show) 14 | 15 | instance Arbitrary NonInteractive where 16 | arbitrary = NonInteractive <$> elements (nonInteractiveGhcOptions \\ ["--info"]) 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "parseOptions" $ do 21 | let 22 | run :: [String] -> Run 23 | run ghcOptions = defaultRun { 24 | runWarnings = ["WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."] 25 | , runMagicMode = True 26 | , runConfig = defaultConfig { ghcOptions } 27 | } 28 | 29 | it "strips --optghc" $ 30 | parseOptions ["--optghc", "foobar"] `shouldBe` Result (run ["foobar"]) 31 | 32 | it "strips --optghc=" $ 33 | parseOptions ["--optghc=foobar"] `shouldBe` Result (run ["foobar"]) 34 | 35 | context "with ghc options that are not valid with --interactive" $ do 36 | it "returns ProxyToGhc" $ do 37 | property $ \ (NonInteractive x) xs -> do 38 | let options = x : xs 39 | parseOptions options `shouldBe` ProxyToGhc options 40 | 41 | context "with --interactive" $ do 42 | let options = ["--interactive", "--foo", "--bar"] 43 | 44 | it "disables magic mode" $ do 45 | runMagicMode <$> parseOptions options `shouldBe` Result False 46 | 47 | it "filters out --interactive" $ do 48 | ghcOptions . runConfig <$> parseOptions options `shouldBe` Result ["--foo", "--bar"] 49 | 50 | it "accepts --fast" $ do 51 | fastMode . runConfig <$> parseOptions ("--fast" : options) `shouldBe` Result True 52 | 53 | describe "--no-magic" $ do 54 | context "without --no-magic" $ do 55 | it "enables magic mode" $ do 56 | runMagicMode <$> parseOptions [] `shouldBe` Result True 57 | 58 | context "with --no-magic" $ do 59 | it "disables magic mode" $ do 60 | runMagicMode <$> parseOptions ["--no-magic"] `shouldBe` Result False 61 | 62 | describe "--fast" $ do 63 | context "without --fast" $ do 64 | it "disables fast mode" $ do 65 | fastMode . runConfig <$> parseOptions [] `shouldBe` Result False 66 | 67 | context "with --fast" $ do 68 | it "enables fast mode" $ do 69 | fastMode . runConfig <$> parseOptions ["--fast"] `shouldBe` Result True 70 | 71 | describe "--preserve-it" $ do 72 | context "without --preserve-it" $ do 73 | it "does not preserve the `it` variable" $ do 74 | preserveIt . runConfig <$> parseOptions [] `shouldBe` Result False 75 | 76 | context "with --preserve-it" $ do 77 | it "preserves the `it` variable" $ do 78 | preserveIt . runConfig <$> parseOptions ["--preserve-it"] `shouldBe` Result True 79 | 80 | describe "--fail-fast" $ do 81 | context "without --fail-fast" $ do 82 | it "disables fail-fast mode" $ do 83 | failFast . runConfig <$> parseOptions [] `shouldBe` Result False 84 | 85 | context "with --fail-fast" $ do 86 | it "enables fail-fast mode" $ do 87 | failFast . runConfig <$> parseOptions ["--fail-fast"] `shouldBe` Result True 88 | 89 | context "with --help" $ do 90 | it "outputs usage information" $ do 91 | parseOptions ["--help"] `shouldBe` Output usage 92 | 93 | context "with --version" $ do 94 | it "outputs version information" $ do 95 | parseOptions ["--version"] `shouldBe` Output versionInfo 96 | 97 | context "with --info" $ do 98 | it "outputs machine readable version information" $ do 99 | parseOptions ["--info"] `shouldBe` Output info 100 | 101 | describe "--verbose" $ do 102 | context "without --verbose" $ do 103 | it "is not verbose by default" $ do 104 | verbose . runConfig <$> parseOptions [] `shouldBe` Result False 105 | 106 | context "with --verbose" $ do 107 | it "parses verbose option" $ do 108 | verbose . runConfig <$> parseOptions ["--verbose"] `shouldBe` Result True 109 | -------------------------------------------------------------------------------- /test/PackageDBsSpec.hs: -------------------------------------------------------------------------------- 1 | module PackageDBsSpec (main, spec) where 2 | 3 | import Imports 4 | 5 | import qualified Control.Exception as E 6 | import Data.List (intercalate) 7 | import PackageDBs 8 | import System.Environment 9 | import System.FilePath (searchPathSeparator) 10 | import Test.Hspec 11 | 12 | import Test.Mockery.Directory 13 | 14 | main :: IO () 15 | main = hspec spec 16 | 17 | withEnv :: String -> String -> IO a -> IO a 18 | withEnv k v action = E.bracket save restore $ \_ -> do 19 | setEnv k v >> action 20 | where 21 | save = lookup k <$> getEnvironment 22 | restore = maybe (unsetEnv k) (setEnv k) 23 | 24 | clearEnv :: IO a -> IO a 25 | clearEnv = 26 | withEnv "GHC_PACKAGE_PATH" "" 27 | 28 | combineDirs :: [FilePath] -> String 29 | combineDirs = intercalate [searchPathSeparator] 30 | 31 | spec :: Spec 32 | spec = around_ clearEnv $ do 33 | describe "getPackageDBsFromEnv" $ do 34 | around_ (inTempDirectory) $ do 35 | it "uses global and user when no env used" $ do 36 | getPackageDBsFromEnv `shouldReturn` PackageDBs True True [] 37 | 38 | it "respects GHC_PACKAGE_PATH" $ 39 | withEnv "GHC_PACKAGE_PATH" (combineDirs ["foo", "bar", ""]) $ do 40 | getPackageDBsFromEnv `shouldReturn` PackageDBs False True ["foo", "bar"] 41 | -------------------------------------------------------------------------------- /test/ParseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module ParseSpec (main, spec) where 3 | 4 | import Imports 5 | 6 | import Test.Hspec 7 | import Data.String 8 | import Data.String.Builder (Builder, build) 9 | import Control.Monad.Trans.Writer 10 | 11 | import Parse 12 | import Location 13 | 14 | main :: IO () 15 | main = hspec spec 16 | 17 | group :: Writer [DocTest] () -> Writer [[DocTest]] () 18 | group g = tell [execWriter g] 19 | 20 | ghci :: Expression -> Builder -> Writer [DocTest] () 21 | ghci expressions expected = tell [Example expressions $ (map fromString . lines . build) expected] 22 | 23 | prop_ :: Expression -> Writer [DocTest] () 24 | prop_ e = tell [Property e] 25 | 26 | module_ :: String -> Writer [[DocTest]] () -> Writer [Module [DocTest]] () 27 | module_ name gs = tell [Module name Nothing $ execWriter gs] 28 | 29 | shouldGive :: IO [Module [Located DocTest]] -> Writer [Module [DocTest]] () -> Expectation 30 | shouldGive action expected = map (fmap $ map unLoc) `fmap` action `shouldReturn` execWriter expected 31 | 32 | spec :: Spec 33 | spec = do 34 | describe "extractDocTests" $ do 35 | it "extracts properties from a module" $ do 36 | extractDocTests ["test/parse/property/Fib.hs"] `shouldGive` do 37 | module_ "Fib" $ do 38 | group $ do 39 | prop_ "foo" 40 | prop_ "bar" 41 | prop_ "baz" 42 | 43 | it "extracts examples from a module" $ do 44 | extractDocTests ["test/parse/simple/Fib.hs"] `shouldGive` do 45 | module_ "Fib" $ do 46 | group $ do 47 | ghci "putStrLn \"foo\"" 48 | "foo" 49 | ghci "putStr \"bar\"" 50 | "bar" 51 | ghci "putStrLn \"baz\"" 52 | "baz" 53 | 54 | it "extracts examples from documentation for non-exported names" $ do 55 | extractDocTests ["test/parse/non-exported/Fib.hs"] `shouldGive` do 56 | module_ "Fib" $ do 57 | group $ do 58 | ghci "putStrLn \"foo\"" 59 | "foo" 60 | ghci "putStr \"bar\"" 61 | "bar" 62 | ghci "putStrLn \"baz\"" 63 | "baz" 64 | 65 | it "extracts multiple examples from a module" $ do 66 | extractDocTests ["test/parse/multiple-examples/Foo.hs"] `shouldGive` do 67 | module_ "Foo" $ do 68 | group $ do 69 | ghci "foo" 70 | "23" 71 | group $ do 72 | ghci "bar" 73 | "42" 74 | 75 | it "returns an empty list, if documentation contains no examples" $ do 76 | extractDocTests ["test/parse/no-examples/Fib.hs"] >>= (`shouldBe` []) 77 | 78 | it "sets setup code to Nothing, if it does not contain any tests" $ do 79 | extractDocTests ["test/parse/setup-empty/Foo.hs"] `shouldGive` do 80 | module_ "Foo" $ do 81 | group $ do 82 | ghci "foo" 83 | "23" 84 | 85 | it "keeps modules that only contain setup code" $ do 86 | extractDocTests ["test/parse/setup-only/Foo.hs"] `shouldGive` do 87 | tell [Module "Foo" (Just [Example "foo" ["23"]]) []] 88 | 89 | describe "parseInteractions (an internal function)" $ do 90 | 91 | let parse_ = map unLoc . parseInteractions . noLocation . build 92 | 93 | it "parses an interaction" $ do 94 | parse_ $ do 95 | ">>> foo" 96 | "23" 97 | `shouldBe` [("foo", ["23"])] 98 | 99 | it "drops whitespace as appropriate" $ do 100 | parse_ $ do 101 | " >>> foo " 102 | " 23" 103 | `shouldBe` [("foo", ["23"])] 104 | 105 | it "parses an interaction without a result" $ do 106 | parse_ $ do 107 | ">>> foo" 108 | `shouldBe` [("foo", [])] 109 | 110 | it "works with a complex example" $ do 111 | parse_ $ do 112 | "test" 113 | "foobar" 114 | "" 115 | ">>> foo" 116 | "23" 117 | "" 118 | ">>> baz" 119 | "" 120 | ">>> bar" 121 | "23" 122 | "" 123 | "baz" 124 | `shouldBe` [("foo", ["23"]), ("baz", []), ("bar", ["23"])] 125 | 126 | it "attaches location information to parsed interactions" $ do 127 | let loc = Located . Location "Foo.hs" 128 | r <- return . parseInteractions . loc 23 . build $ do 129 | "1" 130 | "2" 131 | "" 132 | ">>> 4" 133 | "5" 134 | "" 135 | ">>> 7" 136 | "" 137 | ">>> 9" 138 | "10" 139 | "" 140 | "11" 141 | r `shouldBe` [loc 26 $ ("4", ["5"]), loc 29 $ ("7", []), loc 31 $ ("9", ["10"])] 142 | 143 | it "basic multiline" $ do 144 | parse_ $ do 145 | ">>> :{ first" 146 | " next" 147 | "some" 148 | ":}" 149 | "output" 150 | `shouldBe` [(":{ first\n next\nsome\n:}", ["output"])] 151 | 152 | it "multiline align output" $ do 153 | parse_ $ do 154 | ">>> :{ first" 155 | " :}" 156 | " output" 157 | `shouldBe` [(":{ first\n:}", ["output"])] 158 | 159 | it "multiline align output with >>>" $ do 160 | parse_ $ do 161 | " >>> :{ first" 162 | " >>> :}" 163 | " output" 164 | `shouldBe` [(":{ first\n:}", ["output"])] 165 | 166 | it "parses wild cards lines" $ do 167 | parse_ $ do 168 | " >>> action" 169 | " foo" 170 | " ..." 171 | " bar" 172 | `shouldBe` [("action", ["foo", WildCardLine, "bar"])] 173 | 174 | it "parses wild card chunks" $ do 175 | parse_ $ do 176 | " >>> action" 177 | " foo ... bar" 178 | `shouldBe` [("action", [ExpectedLine ["foo ", WildCardChunk, " bar"]])] 179 | 180 | describe " parseProperties (an internal function)" $ do 181 | let parse_ = map unLoc . parseProperties . noLocation . build 182 | 183 | it "parses a property" $ do 184 | parse_ $ do 185 | "prop> foo" 186 | `shouldBe` ["foo"] 187 | 188 | describe "mkLineChunks (an internal function)" $ do 189 | 190 | it "replaces ellipsis with WildCardChunks" $ do 191 | mkLineChunks "foo ... bar ... baz" `shouldBe` 192 | ["foo ", WildCardChunk, " bar ", WildCardChunk, " baz"] 193 | 194 | it "doesn't replace fewer than 3 consecutive dots" $ do 195 | mkLineChunks "foo .. bar .. baz" `shouldBe` 196 | ["foo .. bar .. baz"] 197 | 198 | it "handles leading and trailing dots" $ do 199 | mkLineChunks ".. foo bar .." `shouldBe` [".. foo bar .."] 200 | 201 | it "handles leading and trailing ellipsis" $ do 202 | mkLineChunks "... foo bar ..." `shouldBe` [ WildCardChunk 203 | , " foo bar " 204 | , WildCardChunk 205 | ] 206 | -------------------------------------------------------------------------------- /test/PropertySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module PropertySpec (spec) where 3 | 4 | import Imports 5 | 6 | import Test.Hspec 7 | import Data.String.Builder 8 | 9 | import Property 10 | import Interpreter (Interpreter) 11 | import qualified Interpreter 12 | 13 | withInterpreter :: (Interpreter -> IO a) -> IO a 14 | withInterpreter = Interpreter.withInterpreter (Interpreter.ghc, ["--interactive"]) 15 | 16 | isFailure :: PropertyResult -> Bool 17 | isFailure (Failure _) = True 18 | isFailure _ = False 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "runProperty" $ do 23 | it "reports a failing property" $ withInterpreter $ \repl -> do 24 | runProperty repl "False" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):" 25 | 26 | it "runs a Bool property" $ withInterpreter $ \repl -> do 27 | runProperty repl "True" `shouldReturn` Success 28 | 29 | it "runs a Bool property with an explicit type signature" $ withInterpreter $ \repl -> do 30 | runProperty repl "True :: Bool" `shouldReturn` Success 31 | 32 | it "runs an implicitly quantified property" $ withInterpreter $ \repl -> do 33 | runProperty repl "(reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success 34 | 35 | it "runs an implicitly quantified property even with GHC 7.4" $ 36 | -- ghc will include a suggestion (did you mean `id` instead of `is`) in 37 | -- the error message 38 | withInterpreter $ \repl -> do 39 | runProperty repl "foldr (+) 0 is == sum (is :: [Int])" `shouldReturn` Success 40 | 41 | it "runs an explicitly quantified property" $ withInterpreter $ \repl -> do 42 | runProperty repl "\\xs -> (reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success 43 | 44 | it "allows to mix implicit and explicit quantification" $ withInterpreter $ \repl -> do 45 | runProperty repl "\\x -> x + y == y + x" `shouldReturn` Success 46 | 47 | it "reports the value for which a property fails" $ withInterpreter $ \repl -> do 48 | runProperty repl "x == 23" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):\n0" 49 | 50 | it "reports the values for which a property that takes multiple arguments fails" $ withInterpreter $ \repl -> do 51 | let vals x = case x of (Failure r) -> tail (lines r); _ -> error "Property did not fail!" 52 | vals `fmap` runProperty repl "x == True && y == 10 && z == \"foo\"" `shouldReturn` ["False", "0", show ("" :: String)] 53 | 54 | it "defaults ambiguous type variables to Integer" $ withInterpreter $ \repl -> do 55 | runProperty repl "reverse xs == xs" >>= (`shouldSatisfy` isFailure) 56 | 57 | describe "freeVariables" $ do 58 | it "finds a free variables in a term" $ withInterpreter $ \repl -> do 59 | freeVariables repl "x" `shouldReturn` ["x"] 60 | 61 | it "ignores duplicates" $ withInterpreter $ \repl -> do 62 | freeVariables repl "x == x" `shouldReturn` ["x"] 63 | 64 | it "works for terms with multiple names" $ withInterpreter $ \repl -> do 65 | freeVariables repl "\\z -> x + y + z == foo 23" `shouldReturn` ["x", "y", "foo"] 66 | 67 | it "works for names that contain a prime" $ withInterpreter $ \repl -> do 68 | freeVariables repl "x' == y''" `shouldReturn` ["x'", "y''"] 69 | 70 | it "works for names that are similar to other names that are in scope" $ withInterpreter $ \repl -> do 71 | freeVariables repl "length_" `shouldReturn` ["length_"] 72 | 73 | describe "parseNotInScope" $ do 74 | context "when error message was produced by GHC 7.4.1" $ do 75 | it "extracts a variable name of variable that is not in scope from an error message" $ do 76 | parseNotInScope . build $ do 77 | ":4:1: Not in scope: `x'" 78 | `shouldBe` ["x"] 79 | 80 | it "ignores duplicates" $ do 81 | parseNotInScope . build $ do 82 | ":4:1: Not in scope: `x'" 83 | "" 84 | ":4:6: Not in scope: `x'" 85 | `shouldBe` ["x"] 86 | 87 | it "works for variable names that contain a prime" $ do 88 | parseNotInScope . build $ do 89 | ":2:1: Not in scope: x'" 90 | "" 91 | ":2:7: Not in scope: y'" 92 | `shouldBe` ["x'", "y'"] 93 | 94 | it "works for error messages with suggestions" $ do 95 | parseNotInScope . build $ do 96 | ":1:1:" 97 | " Not in scope: `is'" 98 | " Perhaps you meant `id' (imported from Prelude)" 99 | `shouldBe` ["is"] 100 | 101 | context "when error message was produced by GHC 8.0.1" $ do 102 | it "extracts a variable name of variable that is not in scope from an error message" $ do 103 | parseNotInScope . build $ do 104 | ":1:1: error: Variable not in scope: x" 105 | `shouldBe` ["x"] 106 | 107 | it "ignores duplicates" $ do 108 | parseNotInScope . build $ do 109 | ":1:1: error: Variable not in scope: x :: ()" 110 | "" 111 | ":1:6: error: Variable not in scope: x :: ()" 112 | `shouldBe` ["x"] 113 | 114 | it "works for variable names that contain a prime" $ do 115 | parseNotInScope . build $ do 116 | ":1:1: error: Variable not in scope: x' :: ()" 117 | "" 118 | ":1:7: error: Variable not in scope: y'' :: ()" 119 | `shouldBe` ["x'", "y''"] 120 | 121 | it "works for error messages with suggestions" $ do 122 | parseNotInScope . build $ do 123 | ":1:1: error:" 124 | " • Variable not in scope: length_" 125 | " • Perhaps you meant ‘length’ (imported from Prelude)" 126 | `shouldBe` ["length_"] 127 | -------------------------------------------------------------------------------- /test/RunSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module RunSpec (main, spec) where 3 | 4 | import Imports 5 | 6 | import Test.Hspec 7 | import System.Exit 8 | 9 | import qualified Control.Exception as E 10 | import System.FilePath 11 | import System.Directory (getCurrentDirectory, setCurrentDirectory) 12 | import Data.List (isPrefixOf, sort) 13 | import Data.Char 14 | 15 | import System.IO.Silently 16 | import System.IO (stderr) 17 | import qualified Options 18 | 19 | import Run 20 | 21 | withCurrentDirectory :: FilePath -> IO a -> IO a 22 | withCurrentDirectory workingDir action = do 23 | E.bracket getCurrentDirectory setCurrentDirectory $ \_ -> do 24 | setCurrentDirectory workingDir 25 | action 26 | 27 | main :: IO () 28 | main = hspec spec 29 | 30 | 31 | removeLoadedPackageEnvironment :: String -> String 32 | #if __GLASGOW_HASKELL__ < 810 33 | removeLoadedPackageEnvironment = unlines . filter (not . isPrefixOf "Loaded package environment from ") . lines 34 | #else 35 | removeLoadedPackageEnvironment = id 36 | #endif 37 | 38 | spec :: Spec 39 | spec = do 40 | describe "doctest" $ do 41 | it "exits with ExitFailure if at least one test case fails" $ do 42 | hSilence [stderr] (doctest ["test/integration/failing/Foo.hs"]) `shouldThrow` (== ExitFailure 1) 43 | 44 | it "prints help on --help" $ do 45 | (r, ()) <- capture (doctest ["--help"]) 46 | r `shouldBe` Options.usage 47 | 48 | it "prints version on --version" $ do 49 | (r, ()) <- capture (doctest ["--version"]) 50 | lines r `shouldSatisfy` any (isPrefixOf "doctest version ") 51 | 52 | it "accepts arbitrary GHC options" $ do 53 | hSilence [stderr] $ doctest ["-cpp", "-DFOO", "test/integration/test-options/Foo.hs"] 54 | 55 | it "accepts GHC options with --optghc" $ do 56 | hSilence [stderr] $ doctest ["--optghc=-cpp", "--optghc=-DFOO", "test/integration/test-options/Foo.hs"] 57 | 58 | it "prints a deprecation message for --optghc" $ do 59 | (r, _) <- hCapture [stderr] $ doctest ["--optghc=-cpp", "--optghc=-DFOO", "test/integration/test-options/Foo.hs"] 60 | lines r `shouldSatisfy` isPrefixOf [ 61 | "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options" 62 | , "directly." 63 | ] 64 | 65 | it "prints error message on invalid option" $ do 66 | (r, e) <- hCapture [stderr] . E.try $ doctest ["--foo", "test/integration/test-options/Foo.hs"] 67 | e `shouldBe` Left (ExitFailure 1) 68 | removeLoadedPackageEnvironment r `shouldBe` unlines [ 69 | "doctest: unrecognized option `--foo'" 70 | , "Try `doctest --help' for more information." 71 | ] 72 | 73 | it "prints verbose description of a specification" $ do 74 | (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "test/integration/testSimple/Fib.hs"] 75 | removeLoadedPackageEnvironment r `shouldBe` unlines [ 76 | "### Started execution at test/integration/testSimple/Fib.hs:5." 77 | , "### example:" 78 | , "fib 10" 79 | , "### Successful!" 80 | , "" 81 | , "# Final summary:" 82 | , "Examples: 1 Tried: 1 Errors: 0 Failures: 0" 83 | ] 84 | 85 | it "prints verbose description of a property" $ do 86 | (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "test/integration/property-bool/Foo.hs"] 87 | removeLoadedPackageEnvironment r `shouldBe` unlines [ 88 | "### Started execution at test/integration/property-bool/Foo.hs:4." 89 | , "### property:" 90 | , "True" 91 | , "### Successful!" 92 | , "" 93 | , "# Final summary:" 94 | , "Examples: 1 Tried: 1 Errors: 0 Failures: 0" 95 | ] 96 | 97 | it "prints verbose error" $ do 98 | (r, e) <- hCapture [stderr] . E.try $ doctest ["--verbose", "test/integration/failing/Foo.hs"] 99 | e `shouldBe` Left (ExitFailure 1) 100 | removeLoadedPackageEnvironment r `shouldBe` unlines [ 101 | "### Started execution at test/integration/failing/Foo.hs:5." 102 | , "### example:" 103 | , "23" 104 | , "test/integration/failing/Foo.hs:5: failure in expression `23'" 105 | , "expected: 42" 106 | , " but got: 23" 107 | , " ^" 108 | , "" 109 | , "# Final summary:" 110 | , "Examples: 1 Tried: 1 Errors: 0 Failures: 1" 111 | ] 112 | 113 | #if __GLASGOW_HASKELL__ >= 802 114 | it "can deal with potentially problematic GHC options" $ do 115 | hSilence [stderr] $ doctest ["-fdiagnostics-color=always", "test/integration/color/Foo.hs"] 116 | #endif 117 | 118 | describe "doctestWithResult" $ do 119 | context "on parse error" $ do 120 | let 121 | action = withCurrentDirectory "test/integration/parse-error" $ do 122 | doctestWithResult defaultConfig { ghcOptions = ["Foo.hs"] } 123 | 124 | it "aborts with (ExitFailure 1)" $ do 125 | hSilence [stderr] action `shouldThrow` (== ExitFailure 1) 126 | 127 | it "prints a useful error message" $ do 128 | (r, _) <- hCapture [stderr] (E.try action :: IO (Either ExitCode Summary)) 129 | stripAnsiColors (removeLoadedPackageEnvironment r) `shouldBe` unlines ( 130 | #if __GLASGOW_HASKELL__ < 910 131 | "" : 132 | #endif 133 | #if __GLASGOW_HASKELL__ >= 906 134 | [ "Foo.hs:6:1: error: [GHC-58481]" 135 | #else 136 | [ "Foo.hs:6:1: error:" 137 | #endif 138 | , " parse error (possibly incorrect indentation or mismatched brackets)" 139 | #if __GLASGOW_HASKELL__ >= 910 140 | , "" 141 | #endif 142 | ]) 143 | 144 | describe "expandDirs" $ do 145 | it "expands a directory" $ do 146 | res <- expandDirs "example" 147 | sort res `shouldBe` 148 | [ "example" "src" "Example.hs" 149 | , "example" "test" "doctests.hs" 150 | ] 151 | it "ignores files" $ do 152 | res <- expandDirs "doctest.cabal" 153 | res `shouldBe` ["doctest.cabal"] 154 | it "ignores random things" $ do 155 | let x = "foo bar baz bin" 156 | res <- expandDirs x 157 | res `shouldBe` [x] 158 | 159 | stripAnsiColors :: String -> String 160 | stripAnsiColors xs = case xs of 161 | '\ESC' : '[' : ';' : ys | 'm' : zs <- dropWhile isNumber ys -> stripAnsiColors zs 162 | '\ESC' : '[' : ys | 'm' : zs <- dropWhile isNumber ys -> stripAnsiColors zs 163 | y : ys -> y : stripAnsiColors ys 164 | [] -> [] 165 | -------------------------------------------------------------------------------- /test/Runner/ExampleSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Runner.ExampleSpec (main, spec) where 3 | 4 | import Imports 5 | 6 | import Data.String 7 | import Test.Hspec 8 | import Test.Hspec.Core.QuickCheck (modifyMaxSize) 9 | import Test.QuickCheck 10 | 11 | import Parse 12 | import Runner.Example 13 | 14 | main :: IO () 15 | main = hspec spec 16 | 17 | data Line = PlainLine String | WildCardLines [String] 18 | deriving (Show, Eq) 19 | 20 | instance Arbitrary Line where 21 | arbitrary = frequency [ (2, PlainLine <$> arbitrary) 22 | , (1, WildCardLines . getNonEmpty <$> arbitrary) 23 | ] 24 | 25 | lineToExpected :: [Line] -> ExpectedResult 26 | lineToExpected = map $ \x -> case x of 27 | PlainLine str -> fromString str 28 | WildCardLines _ -> WildCardLine 29 | 30 | lineToActual :: [Line] -> [String] 31 | lineToActual = concatMap $ \x -> case x of 32 | PlainLine str -> [str] 33 | WildCardLines xs -> xs 34 | 35 | spec :: Spec 36 | spec = do 37 | describe "mkResult" $ do 38 | it "returns Equal when output matches" $ do 39 | property $ \xs -> do 40 | mkResult (map fromString xs) xs `shouldBe` Equal 41 | 42 | it "ignores trailing whitespace" $ do 43 | mkResult ["foo\t"] ["foo "] `shouldBe` Equal 44 | 45 | context "with WildCardLine" $ do 46 | it "matches zero lines" $ do 47 | mkResult ["foo", WildCardLine, "bar"] ["foo", "bar"] 48 | `shouldBe` Equal 49 | 50 | it "matches first zero line" $ do 51 | mkResult [WildCardLine, "foo", "bar"] ["foo", "bar"] 52 | `shouldBe` Equal 53 | 54 | it "matches final zero line" $ do 55 | mkResult ["foo", "bar", WildCardLine] ["foo", "bar"] 56 | `shouldBe` Equal 57 | 58 | it "matches an arbitrary number of lines" $ do 59 | mkResult ["foo", WildCardLine, "bar"] ["foo", "baz", "bazoom", "bar"] 60 | `shouldBe` Equal 61 | 62 | -- See https://github.com/sol/doctest/issues/259 63 | modifyMaxSize (const 8) $ 64 | it "matches an arbitrary number of lines (quickcheck)" $ do 65 | property $ \xs -> mkResult (lineToExpected xs) (lineToActual xs) 66 | `shouldBe` Equal 67 | 68 | context "with WildCardChunk" $ do 69 | it "matches an arbitrary line chunk" $ do 70 | mkResult [ExpectedLine ["foo", WildCardChunk, "bar"]] ["foo baz bar"] 71 | `shouldBe` Equal 72 | 73 | it "matches an arbitrary line chunk at end" $ do 74 | mkResult [ExpectedLine ["foo", WildCardChunk]] ["foo baz bar"] 75 | `shouldBe` Equal 76 | 77 | it "does not match at end" $ do 78 | mkResult [ExpectedLine [WildCardChunk, "baz"]] ["foo baz bar"] 79 | `shouldBe` NotEqual [ 80 | "expected: ...baz" 81 | , " but got: foo baz bar" 82 | , " ^" 83 | ] 84 | 85 | it "does not match at start" $ do 86 | mkResult [ExpectedLine ["fuu", WildCardChunk]] ["foo baz bar"] 87 | `shouldBe` NotEqual [ 88 | "expected: fuu..." 89 | , " but got: foo baz bar" 90 | , " ^" 91 | ] 92 | 93 | context "when output does not match" $ do 94 | it "constructs failure message" $ do 95 | mkResult ["foo"] ["bar"] `shouldBe` NotEqual [ 96 | "expected: foo" 97 | , " but got: bar" 98 | , " ^" 99 | ] 100 | 101 | it "constructs failure message for multi-line output" $ do 102 | mkResult ["foo", "bar"] ["foo", "baz"] `shouldBe` NotEqual [ 103 | "expected: foo" 104 | , " bar" 105 | , " but got: foo" 106 | , " baz" 107 | , " ^" 108 | ] 109 | 110 | context "when any output line contains \"unsafe\" characters" $ do 111 | it "uses show to format output lines" $ do 112 | mkResult ["foo\160bar"] ["foo bar"] `shouldBe` NotEqual [ 113 | "expected: foo\\160bar" 114 | , " but got: foo bar" 115 | , " ^" 116 | ] 117 | 118 | it "insert caret after last matching character on different lengths" $ do 119 | mkResult ["foo"] ["fo"] `shouldBe` NotEqual [ 120 | "expected: foo" 121 | , " but got: fo" 122 | , " ^" 123 | ] 124 | 125 | it "insert caret after mismatching line for multi-line output" $ do 126 | mkResult ["foo", "bar", "bat"] ["foo", "baz", "bax"] `shouldBe` NotEqual [ 127 | "expected: foo" 128 | , " bar" 129 | , " bat" 130 | , " but got: foo" 131 | , " baz" 132 | , " ^" 133 | , " bax" 134 | ] 135 | 136 | it "insert caret after mismatching line with the longest match for multi-line wildcard pattern" $ do 137 | mkResult ["foo", WildCardLine, "bar", "bat"] ["foo", "xxx", "yyy", "baz", "bxx"] `shouldBe` NotEqual [ 138 | "expected: foo" 139 | , " ..." 140 | , " bar" 141 | , " bat" 142 | , " but got: foo" 143 | , " xxx" 144 | , " yyy" 145 | , " baz" 146 | , " ^" 147 | , " bxx" 148 | ] 149 | 150 | it "insert caret after longest match for wildcard" $ do 151 | mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo xxx yyy baz bxx"] `shouldBe` NotEqual [ 152 | "expected: foo ... bar bat" 153 | , " but got: foo xxx yyy baz bxx" 154 | , " ^" 155 | ] 156 | 157 | it "show expanded pattern for long matches" $ do 158 | mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo 123456789 123456789 xxx yyy baz bxx"] `shouldBe` NotEqual [ 159 | "expected: foo ... bar bat" 160 | , " but got: foo 123456789 123456789 xxx yyy baz bxx" 161 | , " foo ........................... ba^" 162 | ] 163 | -------------------------------------------------------------------------------- /test/RunnerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings #-} 2 | module RunnerSpec (spec) where 3 | 4 | import Imports 5 | 6 | import Test.Hspec 7 | 8 | import Data.IORef 9 | import System.IO 10 | import System.IO.Silently (hCapture_) 11 | import Runner 12 | 13 | capture :: Interactive -> Report () -> IO String 14 | capture interactive action = do 15 | ref <- newIORef mempty 16 | hCapture_ [stderr] (runReport (ReportState interactive NoFailFast NonVerbose ref) action) 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "report" $ do 21 | context "when mode is interactive" $ do 22 | it "writes to stderr" $ do 23 | capture Interactive $ do 24 | report "foobar" 25 | `shouldReturn` "foobar\n" 26 | 27 | context "when mode is non-interactive" $ do 28 | it "writes to stderr" $ do 29 | capture NonInteractive $ do 30 | report "foobar" 31 | `shouldReturn` "foobar\n" 32 | 33 | describe "report_" $ do 34 | context "when mode is interactive" $ do 35 | it "writes transient output to stderr" $ do 36 | capture Interactive $ do 37 | reportTransient "foobar" 38 | `shouldReturn` "foobar\r \r" 39 | 40 | context "when mode is non-interactive" $ do 41 | it "is ignored" $ do 42 | capture NonInteractive $ do 43 | reportTransient "foobar" 44 | `shouldReturn` "" 45 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/UtilSpec.hs: -------------------------------------------------------------------------------- 1 | module UtilSpec (main, spec) where 2 | 3 | import Imports 4 | 5 | import Test.Hspec 6 | 7 | import Util 8 | 9 | main :: IO () 10 | main = hspec spec 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "convertDosLineEndings" $ do 15 | it "converts CRLF to LF" $ do 16 | convertDosLineEndings "foo\r\nbar\r\nbaz" `shouldBe` "foo\nbar\nbaz" 17 | 18 | it "strips a trailing CR" $ do 19 | convertDosLineEndings "foo\r" `shouldBe` "foo" 20 | 21 | describe "takeWhileEnd" $ do 22 | it "returns the longest suffix of elements that satisfy a given predicate" $ do 23 | takeWhileEnd (/= ' ') "foo bar" `shouldBe` "bar" 24 | -------------------------------------------------------------------------------- /test/extract/argument-list/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | foo :: Int -- ^ doc for arg1 4 | -> Int -- ^ doc for arg2 5 | -> Int 6 | foo = undefined 7 | -------------------------------------------------------------------------------- /test/extract/comment-order/Foo.hs: -------------------------------------------------------------------------------- 1 | -- | module header 2 | module Foo ( 3 | 4 | -- * some heading 5 | -- | export list 1 6 | foo 7 | 8 | -- * some other heading 9 | -- | export list 2 10 | , bar 11 | 12 | -- * one more heading 13 | -- $foo 14 | , baz 15 | ) where 16 | 17 | -- | foo 18 | foo :: Int 19 | foo = 23 20 | 21 | -- $foo named chunk 22 | 23 | -- | bar 24 | bar :: Int 25 | bar = 23 26 | 27 | baz :: Int 28 | baz = 23 29 | -------------------------------------------------------------------------------- /test/extract/declaration/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | Some documentation 4 | foo :: Int 5 | foo = 23 6 | -------------------------------------------------------------------------------- /test/extract/dos-line-endings/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | 4 | -- foo 5 | -- bar 6 | -- baz 7 | foo :: Int 8 | foo = 23 9 | -------------------------------------------------------------------------------- /test/extract/export-list/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo ( 2 | -- * some heading 3 | -- | documentation from export list 4 | foo 5 | , bar 6 | ) where 7 | 8 | foo :: Int 9 | foo = 23 10 | 11 | bar :: Int 12 | bar = 23 13 | -------------------------------------------------------------------------------- /test/extract/imported-module/Bar.hs: -------------------------------------------------------------------------------- 1 | module Bar where 2 | 3 | import Baz 4 | 5 | -- | documentation for bar 6 | bar :: Int 7 | bar = 23 8 | -------------------------------------------------------------------------------- /test/extract/imported-module/Baz.hs: -------------------------------------------------------------------------------- 1 | module Baz where 2 | 3 | -- | documentation for baz 4 | baz :: Int 5 | baz = 23 6 | -------------------------------------------------------------------------------- /test/extract/module-header/Foo.hs: -------------------------------------------------------------------------------- 1 | -- | Some documentation 2 | module Foo where 3 | 4 | foo :: Int 5 | foo = 23 6 | -------------------------------------------------------------------------------- /test/extract/named-chunks/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo ( 2 | foo 3 | , bar 4 | ) where 5 | 6 | -- $foo named chunk foo 7 | 8 | -- $bar 9 | -- named chunk bar 10 | 11 | foo :: Int 12 | foo = 23 13 | 14 | bar :: Int 15 | bar = 23 16 | -------------------------------------------------------------------------------- /test/extract/regression/Fixity.hs: -------------------------------------------------------------------------------- 1 | module Fixity where 2 | 3 | foo :: Int 4 | foo = 23 + 42 5 | -------------------------------------------------------------------------------- /test/extract/regression/ForeignImport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module ForeignImport where 3 | import Foreign.C 4 | 5 | import Prelude hiding (sin) 6 | 7 | -- pure function 8 | foreign import ccall "sin" c_sin :: CDouble -> CDouble 9 | sin :: Double -> Double 10 | sin d = realToFrac (c_sin (realToFrac d)) 11 | -------------------------------------------------------------------------------- /test/extract/regression/ParallelListComp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ParallelListComp #-} 2 | module ParallelListComp where 3 | 4 | foo :: [Int] 5 | foo = [x+y | x <- [1,2,3] | y <- [4,5,6]] 6 | -------------------------------------------------------------------------------- /test/extract/regression/ParallelListCompClass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ParallelListComp #-} 2 | module ParallelListCompClass where 3 | 4 | class Foo a where 5 | foo :: a -> [Int] 6 | 7 | instance Foo Int where 8 | foo _ = [x+y | x <- [1,2,3] | y <- [4,5,6]] 9 | -------------------------------------------------------------------------------- /test/extract/regression/RewriteRules.hs: -------------------------------------------------------------------------------- 1 | module RewriteRules (foo) where 2 | 3 | {-# RULES "map/append" forall f xs ys. map f (xs ++ ys) = map f xs ++ map f ys #-} 4 | 5 | -- | doc for foo 6 | foo :: Int 7 | foo = 23 8 | -------------------------------------------------------------------------------- /test/extract/regression/RewriteRulesWithSigs.hs: -------------------------------------------------------------------------------- 1 | module RewriteRulesWithSigs (foo) where 2 | 3 | {-# RULES "map/append" forall f (xs :: [Int]) ys. map f (xs ++ ys) = map f xs ++ map f ys #-} 4 | 5 | -- | doc for foo 6 | foo :: Int 7 | foo = 23 8 | -------------------------------------------------------------------------------- /test/extract/setup/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- $setup 4 | -- some setup code 5 | 6 | -- | foo 7 | foo :: Int 8 | foo = 42 9 | 10 | -- | bar 11 | bar :: Int 12 | bar = 42 13 | 14 | -- | baz 15 | baz :: Int 16 | baz = 42 17 | -------------------------------------------------------------------------------- /test/extract/th/Bar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Bar where 4 | 5 | import Language.Haskell.TH.Lib (ExpQ) 6 | 7 | bar :: ExpQ 8 | bar = [| 23 |] 9 | -------------------------------------------------------------------------------- /test/extract/th/Foo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Foo where 3 | 4 | import Bar 5 | 6 | -- | some documentation 7 | foo :: Int 8 | foo = $(bar) 9 | -------------------------------------------------------------------------------- /test/extract/type-class-args/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | 4 | class Foo a where 5 | 6 | bar :: a -- ^ foo 7 | -> Int -- ^ bar 8 | -> String 9 | -------------------------------------------------------------------------------- /test/extract/type-class/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | 4 | class ToString a where 5 | 6 | -- | Convert given value to a string. 7 | toString :: a -> String 8 | -------------------------------------------------------------------------------- /test/extract/type-families/Foo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Foo where 3 | 4 | type family Foo a 5 | 6 | type instance Foo Int = Int 7 | -------------------------------------------------------------------------------- /test/integration/bugfixImportHierarchical/ModuleA.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- >>> fib 10 3 | -- 55 4 | module ModuleA where 5 | 6 | import Foo.ModuleB 7 | -------------------------------------------------------------------------------- /test/integration/bugfixImportHierarchical/ModuleB.hs: -------------------------------------------------------------------------------- 1 | module Foo.ModuleB (fib) where 2 | 3 | 4 | -- | 5 | -- >>> fib 10 6 | -- 55 7 | -- >>> fib 5 8 | -- 5 9 | fib :: Integer -> Integer 10 | fib 0 = 0 11 | fib 1 = 1 12 | fib n = fib (n - 1) + fib (n - 2) 13 | -------------------------------------------------------------------------------- /test/integration/bugfixMultipleModules/ModuleA.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- >>> fib 10 3 | -- 55 4 | module ModuleA where 5 | 6 | import ModuleB 7 | -------------------------------------------------------------------------------- /test/integration/bugfixMultipleModules/ModuleB.hs: -------------------------------------------------------------------------------- 1 | module ModuleB (fib) where 2 | 3 | 4 | -- | 5 | -- >>> fib 10 6 | -- 55 7 | -- >>> fib 5 8 | -- 5 9 | fib :: Integer -> Integer 10 | fib = foo 11 | 12 | -- | 13 | -- >>> foo 10 14 | -- 55 15 | -- >>> foo 5 16 | -- 5 17 | foo :: Integer -> Integer 18 | foo 0 = 0 19 | foo 1 = 1 20 | foo n = foo (n - 1) + foo (n - 2) 21 | -------------------------------------------------------------------------------- /test/integration/bugfixOutputToStdErr/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci number of given 'Num'. 4 | -- 5 | -- >>> import System.IO 6 | -- >>> hPutStrLn stderr "foobar" 7 | -- foobar 8 | fib :: (Num t, Num t1) => t -> t1 9 | fib _ = undefined 10 | -------------------------------------------------------------------------------- /test/integration/bugfixWorkingDirectory/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci number of given 'Num'. 4 | -- 5 | -- >>> bar 6 | -- 10 7 | fib :: (Num t, Num t1) => t -> t1 8 | fib _ = undefined 9 | 10 | bar = 10 11 | -------------------------------------------------------------------------------- /test/integration/bugfixWorkingDirectory/description: -------------------------------------------------------------------------------- 1 | Put the following files in the current working directory: 2 | 3 | ./Fib.hs 4 | ./examples/Fib.hs 5 | 6 | Now run: 7 | 8 | doctest examples/Fib.hs 9 | 10 | Erroneously `./Fib.hs` will be tested instead of `examples/Fib.hs`. 11 | -------------------------------------------------------------------------------- /test/integration/bugfixWorkingDirectory/examples/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | 4 | -- | Calculate Fibonacci number of given 'Num'. 5 | -- 6 | -- Examples: 7 | -- 8 | -- >>> fib 10 9 | -- 55 10 | fib :: Integer -> Integer 11 | fib 0 = 0 12 | fib 1 = 1 13 | fib n = fib (n - 1) + fib (n - 2) 14 | 15 | -- | 16 | -- 17 | -- Examples: 18 | -- 19 | -- >>> fib 10 20 | -- 55 21 | foo :: Int -> Int 22 | foo = undefined 23 | -------------------------------------------------------------------------------- /test/integration/color/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | import Data.Maybe 4 | 5 | -- | Convert a map into list array. 6 | -- prop> tabulate m !! fromEnum d == fromMaybe 0 (lookup d m) 7 | tabulate :: [(Bool, Double)] -> [Double] 8 | tabulate m = [fromMaybe 0 $ lookup False m, fromMaybe 0 $ lookup True m] 9 | -------------------------------------------------------------------------------- /test/integration/custom-package-conf/Bar.hs: -------------------------------------------------------------------------------- 1 | module Bar where 2 | 3 | import Foo 4 | 5 | -- | 6 | -- >>> import Foo 7 | -- >>> foo 8 | -- 23 9 | bar :: Int 10 | bar = 42 11 | -------------------------------------------------------------------------------- /test/integration/custom-package-conf/foo/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | foo :: Int 3 | foo = 23 4 | -------------------------------------------------------------------------------- /test/integration/custom-package-conf/foo/doctest-foo.cabal: -------------------------------------------------------------------------------- 1 | name: doctest-foo 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >= 1.8 5 | 6 | library 7 | exposed-modules: Foo 8 | build-depends: base 9 | -------------------------------------------------------------------------------- /test/integration/dos-line-endings/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci numbers. 4 | -- 5 | -- >>> fib 10 6 | -- 55 7 | fib :: Integer -> Integer 8 | fib 0 = 0 9 | fib 1 = 1 10 | fib n = fib (n - 1) + fib (n - 2) 11 | -------------------------------------------------------------------------------- /test/integration/fail-fast/Bar.hs: -------------------------------------------------------------------------------- 1 | module Bar where 2 | 3 | -- | bar 4 | -- a passing test 5 | -- >>> bar 6 | -- 42 7 | bar :: Int 8 | bar = 42 9 | -------------------------------------------------------------------------------- /test/integration/fail-fast/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | import Bar 4 | 5 | -- | A passing example 6 | -- 7 | -- >>> 23 8 | -- 23 9 | test1 :: a 10 | test1 = undefined 11 | 12 | -- | A failing example 13 | -- 14 | -- >>> 23 15 | -- 42 16 | test2 :: a 17 | test2 = undefined 18 | 19 | -- | Another passing example 20 | -- 21 | -- >>> 23 22 | -- 23 23 | test3 :: a 24 | test3 = undefined 25 | -------------------------------------------------------------------------------- /test/integration/fail-fast/SetupBar.hs: -------------------------------------------------------------------------------- 1 | module SetupBar where 2 | 3 | -- $setup 4 | -- >>> 23 5 | -- 23 6 | 7 | -- | bar 8 | -- a passing test 9 | -- >>> bar 10 | -- 42 11 | bar :: Int 12 | bar = 42 13 | -------------------------------------------------------------------------------- /test/integration/fail-fast/SetupFoo.hs: -------------------------------------------------------------------------------- 1 | module SetupFoo where 2 | 3 | import SetupBar 4 | 5 | 6 | -- $setup 7 | -- >>> 24 8 | -- 23 9 | 10 | -- | A passing example 11 | -- 12 | -- >>> 23 13 | -- 23 14 | test1 :: a 15 | test1 = undefined 16 | 17 | -- | A failing example 18 | -- 19 | -- >>> 23 20 | -- 42 21 | test2 :: a 22 | test2 = undefined 23 | 24 | -- | Another passing example 25 | -- 26 | -- >>> 23 27 | -- 23 28 | test3 :: a 29 | test3 = undefined 30 | -------------------------------------------------------------------------------- /test/integration/failing-multiple/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | A failing example 4 | -- 5 | -- >>> 23 6 | -- 23 7 | -- 8 | -- >>> 23 9 | -- 42 10 | -- 11 | -- >>> 23 12 | -- 23 13 | -- >>> 23 14 | -- 23 15 | test :: a 16 | test = undefined 17 | -------------------------------------------------------------------------------- /test/integration/failing/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | A failing example 4 | -- 5 | -- >>> 23 6 | -- 42 7 | test :: a 8 | test = undefined 9 | -------------------------------------------------------------------------------- /test/integration/it/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | 4 | -- 5 | -- >>> :t 'a' 6 | -- 'a' :: Char 7 | -- 8 | -- >>> "foo" 9 | -- "foo" 10 | -- 11 | -- >>> length it 12 | -- 3 13 | -- 14 | -- >>> it * it 15 | -- 9 16 | -- 17 | -- >>> :t it 18 | -- it :: Int 19 | -- 20 | foo = undefined 21 | -------------------------------------------------------------------------------- /test/integration/it/Setup.hs: -------------------------------------------------------------------------------- 1 | module Setup where 2 | 3 | -- $setup 4 | -- >>> :t 'a' 5 | -- 'a' :: Char 6 | -- 7 | -- >>> 42 :: Int 8 | -- 42 9 | -- 10 | -- >>> it 11 | -- 42 12 | 13 | -- | 14 | -- 15 | -- >>> it * it 16 | -- 1764 17 | foo = undefined 18 | 19 | -- | 20 | -- 21 | -- >>> it * it 22 | -- 1764 23 | bar = undefined 24 | -------------------------------------------------------------------------------- /test/integration/local-stderr-binding/A.hs: -------------------------------------------------------------------------------- 1 | module A where 2 | 3 | stderr :: Bool 4 | stderr = True 5 | 6 | stdout :: String 7 | stdout = "hello" 8 | 9 | -- | 10 | -- >>> 3 + 3 11 | -- 6 12 | -------------------------------------------------------------------------------- /test/integration/multiline/Multiline.hs: -------------------------------------------------------------------------------- 1 | module Multiline where 2 | 3 | 4 | {- | 5 | 6 | >>> :{ 7 | let 8 | x = 1 9 | y = z 10 | in x + y 11 | :} 12 | 3 13 | 14 | -} 15 | z = 2 16 | 17 | {- | 18 | 19 | Aligns with the closing 20 | 21 | >>> :{ 22 | let 23 | x = 1 24 | y = z 25 | in x + y 26 | :} 27 | 3 28 | -} 29 | z2 = 2 30 | 31 | 32 | {- | Also works let that's for do: 33 | 34 | >>> :{ 35 | let 36 | x = 1 37 | y = z 38 | :} 39 | 40 | >>> y 41 | 2 42 | 43 | -} 44 | z3 = 2 45 | 46 | 47 | 48 | {- | Handles repeated @>>>@ too, which is bad since haddock-2.13.2 currently 49 | will strip the leading whitespace leading to something that will not copy-paste 50 | (unless it uses explicit { ; } and the users manually strip the @>>>@) 51 | 52 | >>> :{ 53 | >>> let 54 | >>> x = 1 55 | >>> y = z 56 | >>> in x + y 57 | >>> :} 58 | 3 59 | 60 | -} 61 | z4 = 4 62 | -------------------------------------------------------------------------------- /test/integration/parse-error/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | Some documentation 4 | foo :: Int 5 | foo = 6 | -------------------------------------------------------------------------------- /test/integration/property-bool-with-type-signature/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | 4 | -- prop> True :: Bool 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/property-bool/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | 4 | -- prop> True 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/property-failing/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | 4 | -- prop> abs x == x 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/property-implicitly-quantified/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | 4 | -- prop> abs x == abs (abs x) 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/property-quantified/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | 4 | -- prop> \x -> abs x == abs (abs x) 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/property-setup/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- $setup 4 | -- >>> import Test.QuickCheck 5 | -- >>> let arbitraryEven = (* 2) `fmap` arbitrary 6 | 7 | -- | 8 | -- prop> forAll arbitraryEven even 9 | foo = undefined 10 | -------------------------------------------------------------------------------- /test/integration/setup-skip-on-failure/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- $setup 4 | -- >>> x 5 | -- 23 6 | 7 | -- | 8 | -- >>> foo 9 | -- 42 10 | foo :: Int 11 | foo = 42 12 | 13 | -- | 14 | -- >>> y 15 | -- 42 16 | bar :: Int 17 | bar = 42 18 | -------------------------------------------------------------------------------- /test/integration/setup/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- $setup 4 | -- >>> let x = 23 :: Int 5 | 6 | -- | 7 | -- >>> x + foo 8 | -- 65 9 | foo :: Int 10 | foo = 42 11 | -------------------------------------------------------------------------------- /test/integration/system-io-imported/A.hs: -------------------------------------------------------------------------------- 1 | module A where 2 | 3 | import System.IO 4 | 5 | -- ghci-wrapper needs to poke around with System.IO itself, and unloads the module once it's done. Test to make sure legitimate uses of System.IO don't get lost in the wash. 6 | 7 | -- | 8 | -- >>> ReadMode 9 | -- ReadMode 10 | 11 | -------------------------------------------------------------------------------- /test/integration/template-haskell-bugfix/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Main where 3 | 4 | -- Import our template "pr" 5 | import Printf ( pr ) 6 | 7 | -- The splice operator $ takes the Haskell source code 8 | -- generated at compile time by "pr" and splices it into 9 | -- the argument of "putStrLn". 10 | main = putStrLn ( $(pr "Hello") ) 11 | -------------------------------------------------------------------------------- /test/integration/template-haskell-bugfix/Printf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -- 3 | -- derived from: http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html#th-example 4 | -- 5 | module Printf (pr) where 6 | 7 | import Language.Haskell.TH 8 | 9 | data Format = D | S | L String 10 | 11 | parse :: String -> [Format] 12 | parse s = [ L s ] 13 | 14 | gen :: [Format] -> Q Exp 15 | gen [D] = [| \n -> show n |] 16 | gen [S] = [| \s -> s |] 17 | gen [L s] = stringE s 18 | 19 | -- | 20 | -- 21 | -- >>> :set -XTemplateHaskell 22 | -- >>> putStrLn ( $(pr "Hello") ) 23 | -- Hello 24 | pr :: String -> Q Exp 25 | pr s = gen (parse s) 26 | -------------------------------------------------------------------------------- /test/integration/template-haskell/Foo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Foo where 3 | 4 | import Language.Haskell.TH 5 | import Text.Printf 6 | 7 | -- | Report an error. 8 | -- 9 | -- >>> :set -XTemplateHaskell 10 | -- >>> $(logError "Something bad happened!") 11 | -- ERROR : Something bad happened! 12 | logError :: String -> Q Exp 13 | logError msg = do 14 | loc <- location 15 | let s = (printf "ERROR %s: %s" (loc_filename loc) msg) :: String 16 | [| putStrLn s |] 17 | -------------------------------------------------------------------------------- /test/integration/test-options/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | 4 | -- | 5 | -- Examples: 6 | -- 7 | -- >>> foo 8 | -- 23 9 | foo :: Int 10 | #ifdef FOO 11 | foo = 23 12 | #else 13 | foo = 42 14 | #endif 15 | -------------------------------------------------------------------------------- /test/integration/testBlankline/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci number of given 'Num'. 4 | -- 5 | -- >>> putStrLn "foo\n\nbar" 6 | -- foo 7 | -- 8 | -- bar 9 | fib :: (Num t, Num t1) => t -> t1 10 | fib _ = undefined 11 | -------------------------------------------------------------------------------- /test/integration/testCPP/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | 4 | -- | 5 | -- Examples: 6 | -- 7 | -- >>> foo 8 | -- 23 9 | foo :: Int 10 | #ifdef FOO 11 | foo = 23 12 | #else 13 | foo = 42 14 | #endif 15 | -------------------------------------------------------------------------------- /test/integration/testCombinedExample/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci number of given 'Num'. 4 | -- 5 | -- First let's set `n` to ten: 6 | -- 7 | -- >>> let n = 10 8 | -- 9 | -- And now calculate the 10th Fibonacci number: 10 | -- 11 | -- >>> fib n 12 | -- 55 13 | -- 14 | -- >>> let x = 10 15 | -- >>> x 16 | -- 10 17 | fib :: Integer -> Integer 18 | fib 0 = 0 19 | fib 1 = 1 20 | fib n = fib (n - 1) + fib (n - 2) 21 | -------------------------------------------------------------------------------- /test/integration/testCommentLocation/Foo.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Examples in various locations... 3 | -- 4 | -- Some random text. Some random text. Some random text. Some random text. 5 | -- Some random text. Some random text. Some random text. Some random text. 6 | -- Some random text. 7 | -- 8 | -- >>> let x = 10 9 | -- 10 | -- Some random text. Some random text. Some random text. Some random text. 11 | -- Some random text. Some random text. Some random text. Some random text. 12 | -- Some random text. 13 | -- 14 | -- 15 | -- >>> baz 16 | -- "foobar" 17 | 18 | module Foo ( 19 | -- | Some documentation not attached to a particular Haskell entity 20 | -- 21 | -- >>> test 10 22 | -- *** Exception: Prelude.undefined 23 | -- ... 24 | test, 25 | 26 | -- | 27 | -- >>> fib 10 28 | -- 55 29 | fib, 30 | 31 | -- | 32 | -- >>> bar 33 | -- "bar" 34 | bar 35 | ) where 36 | 37 | 38 | -- | My test 39 | -- 40 | -- >>> test 20 41 | -- *** Exception: Prelude.undefined 42 | -- ... 43 | test :: Integer -> Integer 44 | test = undefined 45 | 46 | -- | Note that examples for 'fib' include the two examples below 47 | -- and the one example with ^ syntax after 'fix' 48 | -- 49 | -- >>> foo 50 | -- "foo" 51 | 52 | {- | 53 | Example: 54 | 55 | >>> fib 10 56 | 55 57 | -} 58 | 59 | -- | Calculate Fibonacci number of given `n`. 60 | fib :: Integer -- ^ given `n` 61 | -- 62 | -- >>> fib 10 63 | -- 55 64 | 65 | -> Integer -- ^ Fibonacci of given `n` 66 | -- 67 | -- >>> baz 68 | -- "foobar" 69 | fib 0 = 0 70 | fib 1 = 1 71 | fib n = fib (n - 1) + fib (n - 2) 72 | -- ^ Example: 73 | -- 74 | -- >>> fib 5 75 | -- 5 76 | 77 | foo = "foo" 78 | bar = "bar" 79 | baz = foo ++ bar 80 | -------------------------------------------------------------------------------- /test/integration/testDocumentationForArguments/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | fib :: Int -- ^ 4 | -- >>> 23 5 | -- 23 6 | -> Int 7 | fib _ = undefined 8 | -------------------------------------------------------------------------------- /test/integration/testFailOnMultiline/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | The following interaction cause `doctest' to fail with an error: 4 | -- 5 | -- >>> :{ 6 | foo :: Int 7 | foo = 23 8 | 9 | -- | The following interaction cause `doctest' to fail with an error: 10 | -- 11 | -- >>> :{ 12 | bar :: Int 13 | bar = 23 14 | -------------------------------------------------------------------------------- /test/integration/testImport/ModuleA.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- >>> fib 10 3 | -- 55 4 | module ModuleA where 5 | 6 | import ModuleB 7 | -------------------------------------------------------------------------------- /test/integration/testImport/ModuleB.hs: -------------------------------------------------------------------------------- 1 | module ModuleB (fib) where 2 | 3 | 4 | -- | 5 | -- >>> fib 10 6 | -- 55 7 | -- >>> fib 5 8 | -- 5 9 | fib :: Integer -> Integer 10 | fib 0 = 0 11 | fib 1 = 1 12 | fib n = fib (n - 1) + fib (n - 2) 13 | -------------------------------------------------------------------------------- /test/integration/testPutStr/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci number of given 'Num'. 4 | -- 5 | -- >>> putStrLn "foo" 6 | -- foo 7 | -- >>> putStr "bar" 8 | -- bar 9 | -- 10 | -- >>> putStrLn "baz" 11 | -- baz 12 | fib :: (Num t, Num t1) => t -> t1 13 | fib _ = undefined 14 | -------------------------------------------------------------------------------- /test/integration/testSimple/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci numbers. 4 | -- 5 | -- >>> fib 10 6 | -- 55 7 | fib :: Integer -> Integer 8 | fib 0 = 0 9 | fib 1 = 1 10 | fib n = fib (n - 1) + fib (n - 2) 11 | -------------------------------------------------------------------------------- /test/integration/trailing-whitespace/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | A failing example 4 | -- 5 | -- >>> putStrLn "foo " 6 | -- foo 7 | test :: a 8 | test = undefined 9 | -------------------------------------------------------------------------------- /test/integration/with-cbits/Bar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module Bar where 3 | 4 | import Foreign.C 5 | 6 | -- | 7 | -- >>> foo 8 | -- 23 9 | foreign import ccall foo :: CInt 10 | -------------------------------------------------------------------------------- /test/integration/with-cbits/foo.c: -------------------------------------------------------------------------------- 1 | int foo() { 2 | return 23; 3 | } 4 | -------------------------------------------------------------------------------- /test/parse/multiple-examples/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- | 4 | -- >>> foo 5 | -- 23 6 | foo = 23 7 | 8 | -- | 9 | -- >>> bar 10 | -- 42 11 | bar = 42 12 | -------------------------------------------------------------------------------- /test/parse/no-examples/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci numbers. 4 | -- @ 5 | -- some code 6 | -- @ 7 | -- 8 | -- foobar 23 9 | fib :: Int -> Int -> Int 10 | fib _ = undefined 11 | -------------------------------------------------------------------------------- /test/parse/non-exported/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib (foo) where 2 | 3 | foo :: Int 4 | foo = 23 5 | 6 | -- | Calculate Fibonacci number of given 'Num'. 7 | -- 8 | -- >>> putStrLn "foo" 9 | -- foo 10 | -- >>> putStr "bar" 11 | -- bar 12 | -- 13 | -- >>> putStrLn "baz" 14 | -- baz 15 | fib :: (Num t, Num t1) => t -> t1 16 | fib _ = undefined 17 | -------------------------------------------------------------------------------- /test/parse/property/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci numbers. 4 | -- 5 | -- prop> foo 6 | -- 7 | -- some text 8 | -- 9 | -- prop> bar 10 | -- 11 | -- some more text 12 | -- 13 | -- prop> baz 14 | fib :: Int -> Int -> Int 15 | fib _ = undefined 16 | -------------------------------------------------------------------------------- /test/parse/setup-empty/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- $setup 4 | -- some setup code 5 | 6 | -- | 7 | -- >>> foo 8 | -- 23 9 | foo :: Int 10 | foo = 23 11 | -------------------------------------------------------------------------------- /test/parse/setup-only/Foo.hs: -------------------------------------------------------------------------------- 1 | module Foo where 2 | 3 | -- $setup 4 | -- >>> foo 5 | -- 23 6 | 7 | -- | some documentation 8 | foo :: Int 9 | foo = 23 10 | -------------------------------------------------------------------------------- /test/parse/simple/Fib.hs: -------------------------------------------------------------------------------- 1 | module Fib where 2 | 3 | -- | Calculate Fibonacci numbers. 4 | -- 5 | -- >>> putStrLn "foo" 6 | -- foo 7 | -- >>> putStr "bar" 8 | -- bar 9 | -- 10 | -- >>> putStrLn "baz" 11 | -- baz 12 | fib :: Int -> Int -> Int 13 | fib _ = undefined 14 | --------------------------------------------------------------------------------