├── .github ├── scripts │ ├── all_check.py │ └── parse_hls_log.py └── workflows │ └── ci.yml ├── .gitignore ├── .vscode ├── README.md ├── extensions.json └── settings.json ├── CHANGES.markdown ├── KNOWN_ISSUES ├── LICENSE ├── README.markdown ├── cabal.project ├── default.nix ├── doctest-parallel.cabal ├── example ├── README.md ├── cabal.project ├── example.cabal ├── src │ └── Example.hs ├── stack.yaml └── test │ └── doctests.hs ├── hie.yaml ├── nix ├── nixpkgs.nix ├── sources.json └── sources.nix ├── release.sh ├── scripts └── build_all.sh ├── shell.nix ├── src ├── Control │ └── Monad │ │ └── Extra.hs ├── Data │ └── List │ │ └── Extra.hs └── Test │ ├── DocTest.hs │ └── DocTest │ ├── Helpers.hs │ └── Internal │ ├── Extract.hs │ ├── GhcUtil.hs │ ├── GhciWrapper.hs │ ├── Interpreter.hs │ ├── Location.hs │ ├── Logging.hs │ ├── Nix.hs │ ├── Options.hs │ ├── Parse.hs │ ├── Property.hs │ ├── Runner.hs │ ├── Runner │ └── Example.hs │ └── Util.hs ├── stack.yaml └── test ├── ExtractSpec.hs ├── GhciWrapperSpec.hs ├── InterpreterSpec.hs ├── LocationSpec.hs ├── MainSpec.hs ├── OptionsSpec.hs ├── ParseSpec.hs ├── ProjectsSpec.hs ├── PropertySpec.hs ├── RunSpec.hs ├── Runner └── ExampleSpec.hs ├── RunnerSpec.hs ├── Spec.hs ├── UtilSpec.hs ├── doctests.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 ├── module-options │ ├── Binders.hs │ ├── Mono.hs │ ├── NoOptions.hs │ └── Poly.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 ├── Color │ └── Foo.hs ├── DosLineEndings │ └── Fib.hs ├── Failing │ └── Foo.hs ├── FailingMultiple │ └── Foo.hs ├── GhcArg │ └── Fib.hs ├── It │ ├── Foo.hs │ └── Setup.hs ├── LocalStderrBinding │ └── A.hs ├── ModuleIsolation │ ├── TestA.hs │ └── TestB.hs ├── ModuleOptions │ ├── Foo.hs │ └── Setup.hs ├── Multiline │ └── Multiline.hs ├── NonExposedModule │ ├── Exposed.hs │ └── NoImplicitImport.hs ├── PropertyBool │ └── Foo.hs ├── PropertyBoolWithTypeSignature │ └── Foo.hs ├── PropertyFailing │ └── Foo.hs ├── PropertyImplicitlyQuantified │ └── Foo.hs ├── PropertyQuantified │ └── Foo.hs ├── PropertySetup │ └── Foo.hs ├── Setup │ └── Foo.hs ├── SetupSkipOnFailure │ └── Foo.hs ├── SystemIoImported │ └── A.hs ├── TemplateHaskell │ └── Foo.hs ├── TestBlankline │ └── Fib.hs ├── TestCombinedExample │ └── Fib.hs ├── TestCommentLocation │ └── Foo.hs ├── TestDocumentationForArguments │ └── Fib.hs ├── TestFailOnMultiline │ └── Fib.hs ├── TestImport │ ├── ModuleA.hs │ └── ModuleB.hs ├── TestPutStr │ └── Fib.hs ├── TestSimple │ └── Fib.hs ├── TrailingWhitespace │ └── Foo.hs ├── WithCInclude │ ├── Bar.hs │ └── include │ │ └── WithCInclude.h └── WithCbits │ ├── Bar.hs │ └── foo.c ├── nix ├── a.cabal ├── cabal.project ├── default.nix ├── nix │ └── nixpkgs.nix ├── release.nix ├── shell.nix ├── src │ └── A.hs └── test │ └── doctests.hs ├── 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 └── projects └── T85-default-language ├── T85-default-language.cabal ├── cabal.project ├── src └── MyLib.hs └── test └── doctests.hs /.github/scripts/all_check.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | """ 3 | Makes sure: 4 | 5 | * All jobs are listed in the 'all' job 6 | * Only existing tests are listed 7 | 8 | """ 9 | 10 | # SPDX-FileCopyrightText: 2022 Google LLC 11 | # 12 | # SPDX-License-Identifier: Apache-2.0 13 | 14 | import sys 15 | import yaml 16 | 17 | CI_PATH = ".github/workflows/ci.yml" 18 | ALL_TEST = "all" 19 | 20 | def main(): 21 | ci_yml_fp = open(CI_PATH, "r") 22 | ci_yml_parsed = yaml.load(ci_yml_fp, Loader=yaml.FullLoader) 23 | 24 | all_jobs = set(ci_yml_parsed['jobs'].keys()) - {ALL_TEST} 25 | all_needs = set(ci_yml_parsed["jobs"][ALL_TEST]["needs"]) 26 | 27 | if all_jobs - all_needs: 28 | sys.exit(f"Not all jobs mentioned in {ALL_TEST}.needs: {all_jobs - all_needs}") 29 | 30 | if all_needs - all_jobs: 31 | sys.exit(f"Non-existing jobs found in {ALL_TEST}.needs: {all_needs - all_jobs}") 32 | 33 | 34 | if __name__ == '__main__': 35 | main() 36 | -------------------------------------------------------------------------------- /.github/scripts/parse_hls_log.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | """ 3 | HLS fails if it encounters an ignored file: 4 | 5 | https://github.com/haskell/haskell-language-server/issues/2692 6 | 7 | This Python script parses the log generated by HLS, and ignores all failures 8 | if they're explicitly ignored in `hie.yaml`. 9 | 10 | Usage: 11 | 12 | parse_hls_log 13 | 14 | """ 15 | import re 16 | import sys 17 | 18 | NONE_CRADLE_RE = re.compile("None cradle found for (.*), ignoring the file") 19 | FILES_FAILED_MSG = "Files that failed:" 20 | 21 | def get_ignored_files(lines): 22 | for line in lines: 23 | cradle_match = NONE_CRADLE_RE.search(line) 24 | if cradle_match is not None: 25 | yield cradle_match.groups()[0].strip() 26 | 27 | def get_failed_files(lines): 28 | lines = iter(lines) 29 | for line in lines: 30 | if line.startswith(FILES_FAILED_MSG): 31 | for line in lines: 32 | if line.startswith(" * "): 33 | yield line[3:].strip() 34 | 35 | def has_error(lines): 36 | for line in lines: 37 | if "| Error |" in line: 38 | return True 39 | if "[ Error ]" in line: 40 | return True 41 | return False 42 | 43 | if __name__ == "__main__": 44 | with open(sys.argv[1]) as log: 45 | lines = log.readlines() 46 | 47 | ignored = set(get_ignored_files(lines)) 48 | failed = set(get_failed_files(lines)) 49 | real_failed = failed - ignored 50 | 51 | if real_failed: 52 | print("HLS failed on:", file=sys.stderr) 53 | for fail in real_failed: 54 | print(f" * {fail}", file=sys.stderr) 55 | sys.exit(1) 56 | 57 | if has_error(lines): 58 | print("Error in log", file=sys.stderr) 59 | sys.exit(1) 60 | 61 | if ignored: 62 | print("All failing files were ignored by user") 63 | else: 64 | print("No files ignored, no files failed.") 65 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: doctest-parallel-ci 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | 8 | concurrency: 9 | group: ${{ github.head_ref || github.run_id }} 10 | cancel-in-progress: true 11 | 12 | jobs: 13 | # Stack 14 | stack: 15 | name: ${{ matrix.os }} / Stack / ${{ matrix.resolver }} 16 | runs-on: ${{ matrix.os }} 17 | strategy: 18 | matrix: 19 | os: ["macOS-latest", "windows-latest", "ubuntu-24.04"] 20 | resolver: ["lts-22.44"] 21 | fail-fast: false 22 | steps: 23 | - name: Checkout 24 | uses: actions/checkout@v4 25 | 26 | - name: Setup Haskell 27 | uses: haskell-actions/setup@v2.8.0 28 | id: setup-haskell 29 | with: 30 | enable-stack: true 31 | 32 | - name: Cache dependencies 33 | uses: actions/cache@v4 34 | with: 35 | path: ${{ steps.setup-haskell.outputs.stack-root }}/snapshots 36 | key: ${{ runner.os }}-ghc-${{ matrix.resolver }}-${{ hashFiles('doctest-parallel.cabal') }} 37 | restore-keys: | 38 | ${{ runner.os }}-stack-${{ matrix.resolver }}-${{ hashFiles('doctest-parallel.cabal') }} 39 | ${{ runner.os }}-stack-${{ matrix.resolver }}- 40 | 41 | - name: Build 42 | run : | 43 | stack build --resolver ${{ matrix.resolver }} 44 | 45 | - name: Test - doctests 46 | run : | 47 | stack test doctest-parallel:doctests --resolver ${{ matrix.resolver }} 48 | 49 | - name: Test - spectests 50 | run : | 51 | stack test doctest-parallel:spectests --resolver ${{ matrix.resolver }} 52 | 53 | - name: Test - example project 54 | run: | 55 | cd example 56 | stack test --resolver ${{ matrix.resolver }} 57 | 58 | # Cabal 59 | cabal: 60 | name: ${{ matrix.os }} / ${{ matrix.ghc }} 61 | runs-on: ${{ matrix.os }} 62 | strategy: 63 | matrix: 64 | os: ["macOS-latest", "windows-latest", "ubuntu-24.04"] 65 | ghc: 66 | - "9.12.2" 67 | - "9.10.2" 68 | - "9.8.4" 69 | - "9.6.7" 70 | - "9.4.8" 71 | - "9.2.8" 72 | - "9.0.2" 73 | exclude: 74 | # Newer macOSs don't have the right LLVM to compile our dependencies 75 | - os: macOS-latest 76 | ghc: "9.0.2" 77 | 78 | # Uncomment if testing with an unreleased GHC. Make sure to edit the 79 | # "Setup Haskell (head)" step too. 80 | # include: 81 | # - os: ubuntu-24.04 82 | # ghc: head 83 | fail-fast: false 84 | steps: 85 | - name: Checkout 86 | uses: actions/checkout@v4 87 | 88 | - name: Setup Haskell 89 | if: matrix.ghc != 'head' 90 | uses: haskell-actions/setup@v2.8.0 91 | id: setup-haskell 92 | with: 93 | ghc-version: ${{ matrix.ghc }} 94 | cabal-version: 3.14.1.0 95 | 96 | - name: Setup Haskell (head) 97 | if: matrix.ghc == 'head' 98 | id: setup-haskell-head 99 | run: | 100 | sudo apt-get update 101 | sudo apt-get install -y build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 102 | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh 103 | ghcup config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml 104 | ghcup install ghc 9.10.0.20240328 105 | ghcup set ghc 9.10.0.20240328 106 | echo "cabal-store=$HOME/.cabal/store" >> $GITHUB_OUTPUT 107 | 108 | - name: Enable -Werror 109 | run: | 110 | echo "package doctest-parallel" >> cabal.project.local 111 | echo " ghc-options: -Werror" >> cabal.project.local 112 | 113 | - name: Setup CI 114 | run: | 115 | cabal v2-freeze 116 | mv cabal.project.freeze frozen 117 | 118 | - name: Cache dependencies 119 | uses: actions/cache@v4 120 | with: 121 | path: ${{ steps.setup-haskell.outputs.cabal-store || steps.setup-haskell-head.outputs.cabal-store }} 122 | key: ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ hashFiles('frozen') }} 123 | restore-keys: | 124 | ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ hashFiles('frozen') }} 125 | ${{ runner.os }}-ghc-${{ matrix.ghc }}- 126 | 127 | - name: Build 128 | run: | 129 | cabal v2-update 130 | cabal v2-build all --enable-tests 131 | 132 | - name: Test - doctests 133 | run: | 134 | cabal v2-run doctests 135 | 136 | - name: Test - spectests 137 | run: | 138 | cabal v2-run spectests 139 | 140 | - name: Test - example project 141 | run: | 142 | cd example 143 | # See: https://github.com/martijnbastiaan/doctest-parallel/issues/22 144 | # cabal v2-test 145 | cabal v2-run doctests 146 | 147 | nix: 148 | runs-on: ubuntu-24.04 149 | steps: 150 | - uses: actions/checkout@v4 151 | - uses: cachix/install-nix-action@v31 152 | with: 153 | nix_path: nixpkgs=channel:nixos-unstable 154 | - run: | 155 | nix-build 156 | 157 | cd test/nix 158 | nix-build 159 | nix-shell --pure --run "cabal run doctests" 160 | nix-shell --pure --run "cabal test" 161 | nix-shell --pure --run "cabal run doctests --write-ghc-environment-files=always" 162 | nix-shell --pure --run "cabal test --write-ghc-environment-files=always" 163 | 164 | hls: 165 | name: HLS 166 | runs-on: ubuntu-24.04 167 | strategy: 168 | matrix: 169 | tools: 170 | - {ghc: "9.10.2", cabal: "3.12.1.0", hls: "2.9.0.1", ghcup: "0.1.50.2"} 171 | steps: 172 | - name: Checkout 173 | uses: actions/checkout@v4 174 | 175 | - name: Setup Haskell 176 | run: | 177 | sudo apt-get update 178 | sudo apt-get install curl -y 179 | sudo apt-get install \ 180 | build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev \ 181 | libgmp10 libncurses-dev libncurses6 libtinfo6 -y 182 | 183 | sudo curl "https://downloads.haskell.org/~ghcup/${{ matrix.tools.ghcup }}/x86_64-linux-ghcup-${{ matrix.tools.ghcup }}" --output /usr/bin/ghcup 184 | sudo chmod +x /usr/bin/ghcup 185 | 186 | ghcup install ghc ${{ matrix.tools.ghc }} --set --force 187 | ghcup install cabal ${{ matrix.tools.cabal }} --set --force 188 | ghcup install hls ${{ matrix.tools.hls }} --set --force 189 | 190 | cabal update 191 | 192 | echo "${HOME}/.ghcup/bin/" >> $GITHUB_PATH 193 | ls "${HOME}/.ghcup/bin/" 194 | 195 | - name: Setup CI 196 | run: | 197 | cabal v2-freeze 198 | mv cabal.project.freeze frozen 199 | 200 | - name: Cache dependencies 201 | uses: actions/cache@v4 202 | with: 203 | path: $HOME/.cabal/store 204 | key: ${{ runner.os }}-cachebust1-hls-${{ matrix.tools.ghc }}-${{ matrix.tools.cabal }}-${{ matrix.tools.hls }}-${{ matrix.tools.ghcup }}-${{ hashFiles('frozen') }} 205 | restore-keys: | 206 | ${{ runner.os }}-cachebust1-hls-${{ matrix.tools.ghc }}-${{ matrix.tools.cabal }}-${{ matrix.tools.hls }}-${{ matrix.tools.ghcup }}-${{ hashFiles('frozen') }} 207 | ${{ runner.os }}-cachebust1-hls-${{ matrix.tools.ghc }}-${{ matrix.tools.cabal }}-${{ matrix.tools.hls }}-${{ matrix.tools.ghcup }}- 208 | 209 | - name: Build 210 | run: | 211 | cabal v2-update 212 | cabal v2-build all --enable-tests --only-dependencies 213 | 214 | - name: Run haskell-language-server-wrapper 215 | run: | 216 | (haskell-language-server-wrapper || true) |& tee hls-log 217 | .github/scripts/parse_hls_log.py hls-log 218 | 219 | # Mandatory check on GitHub 220 | all: 221 | name: All jobs finished 222 | if: always() 223 | needs: [ 224 | cabal, 225 | stack, 226 | nix, 227 | hls, 228 | ] 229 | runs-on: ubuntu-24.04 230 | steps: 231 | - name: Checkout 232 | uses: actions/checkout@v4 233 | 234 | - name: Check dependencies for failures 235 | run: | 236 | # Test all dependencies for success/failure 237 | set -x 238 | success="${{ contains(needs.*.result, 'success') }}" 239 | fail="${{ contains(needs.*.result, 'failure') }}" 240 | set +x 241 | 242 | # Test whether success/fail variables contain sane values 243 | if [[ "${success}" != "true" && "${success}" != "false" ]]; then exit 1; fi 244 | if [[ "${fail}" != "true" && "${fail}" != "false" ]]; then exit 1; fi 245 | 246 | # We want to fail if one or more dependencies fail. For safety, we introduce 247 | # a second check: if no dependencies succeeded something weird is going on. 248 | if [[ "${fail}" == "true" || "${success}" == "false" ]]; then 249 | echo "One or more dependency failed, or no dependency succeeded." 250 | exit 1 251 | fi 252 | 253 | - name: Install dependencies 254 | run: | 255 | sudo apt-get update 256 | sudo apt-get -y install python3-yaml 257 | 258 | - name: Check that the 'all' job depends on all other jobs 259 | run: | 260 | .github/scripts/all_check.py 261 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | /.stack-work/ 4 | /ghci-wrapper/.stack-work/ 5 | .ghc.environment.* 6 | .stack-work 7 | stack.yaml.lock 8 | result 9 | -------------------------------------------------------------------------------- /.vscode/README.md: -------------------------------------------------------------------------------- 1 | Please do not add opiniated settings, unless they're recommended by the 2 | style guide. 3 | -------------------------------------------------------------------------------- /.vscode/extensions.json: -------------------------------------------------------------------------------- 1 | { 2 | "recommendations": ["haskell.haskell"] 3 | } 4 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "cSpell.words": [ 3 | "NOINLINE", 4 | "WHNF", 5 | "fmap" 6 | ], 7 | "files.exclude": { 8 | "**/*.dyn_hi": true, 9 | "**/*.dyn_o": true, 10 | "**/*.hi": true, 11 | "**/*.o": true, 12 | "**/*.o-boot": true, 13 | "**/*.hi-boot": true, 14 | "**/dist-newstyle": true, 15 | "**/.stack-work": true, 16 | "**/.ghc.environment.*": true 17 | }, 18 | "files.insertFinalNewline": true, 19 | "files.trimFinalNewlines": true, 20 | "files.trimTrailingWhitespace": true, 21 | "editor.rulers": [ 22 | 80, 23 | 90 24 | ], 25 | "editor.tabSize": 2 26 | } 27 | -------------------------------------------------------------------------------- /CHANGES.markdown: -------------------------------------------------------------------------------- 1 | # 0.4 2 | * Account for `default-language` sections in Cabal files ([#85](https://github.com/martijnbastiaan/doctest-parallel/issues/85)) 3 | * Add support for Cabal 3.14 ([#88](https://github.com/martijnbastiaan/doctest-parallel/pull/88)) 4 | * Add parallel parsing on Linux/macOS. The GHC API is now used to call the parser directly, which allows parallel parsing. On Windows, files will be parsed sequentially still due to the GHC API locking files. ([#85](https://github.com/martijnbastiaan/doctest-parallel/issues/89)) 5 | * Drop support for GHC < 9 6 | 7 | # 0.3.1.1 8 | * Add support for GHC 9.12 (loosened bounds in Hackage revision) 9 | * Add support for GHC 9.10 10 | 11 | # 0.3.1 12 | * Add support for GHC 9.8 13 | * Drop support for GHC 8.2 14 | * Add `--ghc-arg` as a command line argument, allowing users to pass additional arguments to GHC used to parse Haddock. 15 | 16 | # 0.3.0.1 17 | * Add support for GHC 9.6 18 | 19 | # 0.3.0 20 | * Add support for Nix shell environments ([#58](https://github.com/martijnbastiaan/doctest-parallel/pull/58)) 21 | * `Language.Haskell.GhciWrapper` has been moved to `Test.DocTest.Internal.GhciWrapper`. This module was never intended to be part of the public API. ([#61](https://github.com/martijnbastiaan/doctest-parallel/pull/61)) 22 | * Add more elaborate debug options. You can now pass `--log-level=LEVEL` where `level` is one of `debug`, `verbose`, `info`, `warning`, or `error`. ([#14](https://github.com/martijnbastiaan/doctest-parallel/issues/14)) 23 | 24 | # 0.2.6 25 | * `getNumProcessors` is now used to detect the (default) number of GHCi subprocesses to spawn. This should more reliably use all of a system's resources. Fixes [#53](https://github.com/martijnbastiaan/doctest-parallel/issues/53). 26 | * Add Nix support. If the environment variable `NIX_BUILD_TOP` is present an extra package database is added to `GHC_PACKAGE_PATH`. This isn't expected to break existing builds, but if it does consider passing `--no-nix`. ([#34](https://github.com/martijnbastiaan/doctest-parallel/issues/34)) 27 | * The QuickCheck example mentioned in the README now uses `abs` instead of `sort`. This prevents confusing errors when `sort` is not imported. Fixes [#50](https://github.com/martijnbastiaan/doctest-parallel/issues/50). 28 | 29 | # 0.2.5 30 | * Loosen Cabal bounds to >= 2.4 && < 3.9 31 | 32 | # 0.2.4 33 | * Add support for GHC 9.4 ([#43](https://github.com/martijnbastiaan/doctest-parallel/pull/43)) 34 | 35 | # 0.2.3 36 | * Conditionals in Cabal files are now solved ([#35](https://github.com/martijnbastiaan/doctest-parallel/pull/37)). Thanks to @philderbeast for the report and contributions. 37 | * Unexpected outputs in `$setup` blocks are no longer ignored ([#39](https://github.com/martijnbastiaan/doctest-parallel/pull/39)) 38 | 39 | # 0.2.2 40 | * Command line arguments (such as `--randomize-order`) can now be overridden on a per-module basis ([#25](https://github.com/martijnbastiaan/doctest-parallel/pull/25)) 41 | * Implicit pre-test module imports can now be disabled using `--no-implicit-module-import`. This can help to test functions from non-exposed modules ([#26](https://github.com/martijnbastiaan/doctest-parallel/pull/26)) 42 | * `runModule` does not swallow import errors anymore ([#28](https://github.com/martijnbastiaan/doctest-parallel/issues/28)) 43 | * `autogen-modules` are not searched for tests anymore ([#30](https://github.com/martijnbastiaan/doctest-parallel/issues/30)) 44 | 45 | # 0.2.1 46 | * C include directories (Cabal field: `include-dirs`) are now passed to GHC when parsing source files ([#7](https://github.com/martijnbastiaan/doctest-parallel/issues/7)) 47 | * A migration guide has been added ([#11](https://github.com/martijnbastiaan/doctest-parallel/issues/11)) 48 | * Test order can be randomized using `--randomize-order`. Test order can be made deterministic by adding an optional `--seed=N` argument ([#12](https://github.com/martijnbastiaan/doctest-parallel/pull/12)) 49 | * Any non-error output can now be surpressed by `--quiet` ([#20](https://github.com/martijnbastiaan/doctest-parallel/pull/20)) 50 | * Doctest can now be called using a record for option passing in addition to command line arguments. See `mainFromCabalWithConfig` and `mainFromLibraryWithConfig`. 51 | 52 | # 0.2 53 | Changes: 54 | * Support for GHC 9.2 has been added ([#4](https://github.com/martijnbastiaan/doctest-parallel/pull/4)) 55 | * Support for GHC 8.2 has been dropped ([#3](https://github.com/martijnbastiaan/doctest-parallel/pull/3)) 56 | * The dependency `cabal-install-parsers` has been dropped. This trims the dependency tree quite a bit ([#3](https://github.com/martijnbastiaan/doctest-parallel/pull/3)) 57 | * The Hackage distribution now ships all files necessary to run `doctest-parallel`'s tests (Fixes [#1](https://github.com/martijnbastiaan/doctest-parallel/issues/1), PR [#2](https://github.com/martijnbastiaan/doctest-parallel/pull/2)) 58 | 59 | # 0.1 60 | Fresh fork from `sol/doctest`. See the README for an overview of all the changes. 61 | -------------------------------------------------------------------------------- /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-2018 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 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./ 3 | 4 | write-ghc-environment-files: always 5 | 6 | tests: true 7 | 8 | package doctest-parallel 9 | ghc-options: +RTS -qn4 -A128M -RTS -j4 10 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import nix/nixpkgs.nix {} }: 2 | 3 | with nixpkgs.pkgs; 4 | with gitignore; 5 | 6 | haskellPackages.callCabal2nix "doctest-parallel" (gitignoreSource ./.) {} 7 | -------------------------------------------------------------------------------- /doctest-parallel.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | 3 | name: doctest-parallel 4 | version: 0.3.1.1 5 | synopsis: Test interactive Haskell examples 6 | description: The doctest program checks examples in source code comments. It is modeled 7 | after doctest for Python (). 8 | . 9 | Documentation is at . 10 | category: Testing 11 | bug-reports: https://github.com/martijnbastiaan/doctest-parallel/issues 12 | homepage: https://github.com/martijnbastiaan/doctest-parallel#readme 13 | license: MIT 14 | license-file: LICENSE 15 | copyright: (c) 2009-2018 Simon Hengel, 2021-2022 Martijn Bastiaan 16 | author: Martijn Bastiaan 17 | maintainer: Martijn Bastiaan 18 | build-type: Simple 19 | tested-with: 20 | GHC == 9.0.2 21 | , GHC == 9.2.8 22 | , GHC == 9.4.8 23 | , GHC == 9.6.7 24 | , GHC == 9.8.4 25 | , GHC == 9.10.2 26 | , GHC == 9.12.2 27 | 28 | extra-source-files: 29 | example/example.cabal 30 | example/src/Example.hs 31 | example/test/doctests.hs 32 | cabal.project 33 | CHANGES.markdown 34 | README.markdown 35 | 36 | -- Rather annoyingly, Cabal implements arbitrary limitations in their file 37 | -- globbing, one of them being that a wildcard can't be used to match 38 | -- directories. Hence, we list them here individually. 39 | test/extract/argument-list/*.hs 40 | test/extract/comment-order/*.hs 41 | test/extract/declaration/*.hs 42 | test/extract/dos-line-endings/*.hs 43 | test/extract/export-list/*.hs 44 | test/extract/imported-module/*.hs 45 | test/extract/module-header/*.hs 46 | test/extract/module-options/*.hs 47 | test/extract/named-chunks/*.hs 48 | test/extract/regression/*.hs 49 | test/extract/setup/*.hs 50 | test/extract/th/*.hs 51 | test/extract/type-class/*.hs 52 | test/extract/type-class-args/*.hs 53 | test/extract/type-families/*.hs 54 | test/parse/multiple-examples/*.hs 55 | test/parse/no-examples/*.hs 56 | test/parse/non-exported/*.hs 57 | test/parse/property/*.hs 58 | test/parse/setup-empty/*.hs 59 | test/parse/setup-only/*.hs 60 | test/parse/simple/*.hs 61 | test/integration/WithCInclude/include/WithCInclude.h 62 | 63 | source-repository head 64 | type: git 65 | location: https://github.com/martijnbastiaan/doctest-parallel 66 | 67 | library 68 | ghc-options: -Wall 69 | hs-source-dirs: src 70 | exposed-modules: 71 | Test.DocTest 72 | Test.DocTest.Helpers 73 | Test.DocTest.Internal.Extract 74 | Test.DocTest.Internal.GhciWrapper 75 | Test.DocTest.Internal.GhcUtil 76 | Test.DocTest.Internal.Interpreter 77 | Test.DocTest.Internal.Location 78 | Test.DocTest.Internal.Logging 79 | Test.DocTest.Internal.Nix 80 | Test.DocTest.Internal.Options 81 | Test.DocTest.Internal.Parse 82 | Test.DocTest.Internal.Property 83 | Test.DocTest.Internal.Runner 84 | Test.DocTest.Internal.Runner.Example 85 | Test.DocTest.Internal.Util 86 | autogen-modules: 87 | Paths_doctest_parallel 88 | other-modules: 89 | Control.Monad.Extra 90 | Data.List.Extra 91 | Paths_doctest_parallel 92 | build-depends: 93 | Cabal >= 2.4 && < 3.15 94 | , Glob 95 | , base >=4.10 && <5 96 | , base-compat >=0.7.0 97 | , code-page >=0.1 98 | , containers 99 | , deepseq 100 | , directory 101 | , exceptions 102 | , filepath 103 | , ghc >=9.0 && <9.13 104 | , ghc-exactprint 105 | , ghc-paths >=0.1.0.9 106 | , process 107 | , random >= 1.2 108 | , syb >=0.3 109 | , transformers 110 | , unordered-containers 111 | default-language: Haskell2010 112 | 113 | test-suite doctests 114 | type: exitcode-stdio-1.0 115 | hs-source-dirs: test 116 | main-is: doctests.hs 117 | ghc-options: -threaded 118 | build-depends: base, doctest-parallel 119 | default-language: Haskell2010 120 | 121 | 122 | library spectests-modules 123 | default-language: Haskell2010 124 | build-depends: base, doctest-parallel, template-haskell 125 | -- Too many warnings. TODO: fix. 126 | -- ghc-options: -Wall 127 | hs-source-dirs: 128 | test/integration 129 | include-dirs: 130 | test/integration/WithCInclude/include 131 | c-sources: 132 | test/integration/WithCbits/foo.c 133 | exposed-modules: 134 | BugfixImportHierarchical.ModuleA 135 | BugfixImportHierarchical.ModuleB 136 | BugfixMultipleModules.ModuleA 137 | BugfixMultipleModules.ModuleB 138 | BugfixOutputToStdErr.Fib 139 | Color.Foo 140 | DosLineEndings.Fib 141 | Failing.Foo 142 | FailingMultiple.Foo 143 | GhcArg.Fib 144 | It.Foo 145 | It.Setup 146 | LocalStderrBinding.A 147 | ModuleIsolation.TestA 148 | ModuleIsolation.TestB 149 | ModuleOptions.Foo 150 | NonExposedModule.Exposed 151 | Multiline.Multiline 152 | PropertyBool.Foo 153 | PropertyBoolWithTypeSignature.Foo 154 | PropertyFailing.Foo 155 | PropertyImplicitlyQuantified.Foo 156 | PropertyQuantified.Foo 157 | PropertySetup.Foo 158 | Setup.Foo 159 | SetupSkipOnFailure.Foo 160 | SystemIoImported.A 161 | TemplateHaskell.Foo 162 | TestBlankline.Fib 163 | TestCombinedExample.Fib 164 | TestCommentLocation.Foo 165 | TestDocumentationForArguments.Fib 166 | TestFailOnMultiline.Fib 167 | TestImport.ModuleA 168 | TestImport.ModuleB 169 | TestPutStr.Fib 170 | TestSimple.Fib 171 | TrailingWhitespace.Foo 172 | WithCbits.Bar 173 | WithCInclude.Bar 174 | other-modules: 175 | NonExposedModule.NoImplicitImport 176 | 177 | test-suite spectests 178 | main-is: Spec.hs 179 | other-modules: 180 | ExtractSpec 181 | GhciWrapperSpec 182 | InterpreterSpec 183 | LocationSpec 184 | MainSpec 185 | OptionsSpec 186 | ParseSpec 187 | ProjectsSpec 188 | PropertySpec 189 | Runner.ExampleSpec 190 | RunnerSpec 191 | RunSpec 192 | UtilSpec 193 | type: exitcode-stdio-1.0 194 | ghc-options: -Wall -threaded 195 | cpp-options: -DTEST 196 | hs-source-dirs: 197 | test 198 | build-depends: 199 | HUnit 200 | , QuickCheck >=2.13.1 201 | , base 202 | , base-compat 203 | , code-page 204 | , containers 205 | , doctest-parallel 206 | , deepseq 207 | , directory 208 | , exceptions 209 | , filepath 210 | , ghc 211 | , ghc-paths 212 | , hspec >=2.3.0 213 | , hspec-core >=2.3.0 214 | , mockery 215 | , process 216 | , setenv 217 | , silently >=1.2.4 218 | , stringbuilder >=0.4 219 | , spectests-modules 220 | , syb 221 | , transformers 222 | default-language: Haskell2010 223 | -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | # Integrating `doctest-parallel` into your project 2 | `doctest-parallel` currently assumes you have a `.cabal` file in your project. If this is the case, it can be setup by adding the following: 3 | 4 | ## `your-project.cabal` 5 | ``` 6 | test-suite doctests 7 | type: exitcode-stdio-1.0 8 | hs-source-dirs: test 9 | main-is: doctests.hs 10 | ghc-options: -threaded 11 | build-depends: base, your-project, doctest-parallel >= 0.1 12 | default-language: Haskell2010 13 | ``` 14 | 15 | ## `cabal.project` 16 | You can omit this file if your project is a Stack-only project. Otherwise, add the following: 17 | 18 | ``` 19 | write-ghc-environment-files: always 20 | ``` 21 | 22 | If this file does not yet exist, also add: 23 | 24 | ``` 25 | packages: 26 | . 27 | ``` 28 | 29 | ## `test/doctests.hs` 30 | ```haskell 31 | module Main where 32 | 33 | import Test.DocTest (mainFromCabal) 34 | import System.Environment (getArgs) 35 | 36 | main :: IO () 37 | main = mainFromCabal "your-project" =<< getArgs 38 | ``` 39 | 40 | # Running the testsuite 41 | 42 | ## Cabal 43 | Execute: 44 | 45 | ``` 46 | cabal run doctests 47 | ``` 48 | 49 | **At the moment, using `cabal test` is not reliable. See [#22](https://github.com/martijnbastiaan/doctest-parallel/issues/22).** 50 | 51 | ## Stack 52 | Stack users can use: 53 | 54 | ``` 55 | stack test example:doctestsstack test 56 | ``` 57 | 58 | It will also run as part of `stack test`. 59 | 60 | # Help 61 | Run: 62 | 63 | ``` 64 | cabal run doctests -- --help 65 | ``` 66 | 67 | Or: 68 | 69 | ``` 70 | stack test example:doctests --test-arguments --help 71 | ``` 72 | 73 | Example output: 74 | 75 | ``` 76 | Usage: 77 | doctest [ options ]... []... 78 | doctest --help 79 | doctest --version 80 | doctest --info 81 | 82 | Options: 83 | -jN number of threads to use 84 | † --implicit-module-import import module before testing it (default) 85 | † --randomize-order randomize order in which tests are run 86 | † --seed=N use a specific seed to randomize test order 87 | † --preserve-it preserve the `it` variable between examples 88 | --verbose print each test as it is run 89 | --quiet only print errors 90 | --help display this help and exit 91 | --version output version information and exit 92 | --info output machine-readable version information and exit 93 | 94 | Supported inverted options: 95 | † --no-implicit-module-import 96 | † --no-randomize-order (default) 97 | † --no-preserve-it (default) 98 | 99 | Options marked with a dagger (†) can also be used to set module level options, using 100 | an ANN pragma like this: 101 | 102 | {-# ANN module "doctest-parallel: --no-randomize-order" #-} 103 | 104 | ``` 105 | -------------------------------------------------------------------------------- /example/cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ../ 3 | ./ 4 | 5 | write-ghc-environment-files: always 6 | 7 | allow-newer: 8 | *:base 9 | , *:ghc-bignum 10 | 11 | source-repository-package 12 | type: git 13 | location: https://github.com/haskell-unordered-containers/unordered-containers.git 14 | tag: d52a0fd10bfa701cbbc9d7ac06bd7eb7664b3972 15 | 16 | allow-newer: 17 | unordered-containers:template-haskell 18 | -------------------------------------------------------------------------------- /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, example, doctest-parallel >= 0.1 17 | default-language: Haskell2010 18 | -------------------------------------------------------------------------------- /example/src/Example.hs: -------------------------------------------------------------------------------- 1 | module Example (foo, bar) where 2 | 3 | -- | 4 | -- >>> foo 5 | -- 23 6 | foo = 23 7 | 8 | -- | 9 | -- >>> bar 10 | -- 42 11 | bar = 42 12 | -------------------------------------------------------------------------------- /example/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: 2 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/04.yaml 3 | 4 | extra-deps: 5 | - .. 6 | -------------------------------------------------------------------------------- /example/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest (mainFromCabal) 4 | import System.Environment (getArgs) 5 | 6 | main :: IO () 7 | main = mainFromCabal "example" =<< getArgs 8 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | multi: 3 | - path: "./test" 4 | config: 5 | cradle: 6 | none: 7 | - path: "./example" 8 | config: 9 | cradle: 10 | none: 11 | - path: "./" 12 | config: 13 | cradle: 14 | cabal: 15 | - path: "./src" 16 | component: "lib:doctest-parallel" 17 | - path: "./test/integration" 18 | component: "lib:spectests-modules" 19 | - path: "./test/doctests.hs" 20 | component: "doctest-parallel:doctests" 21 | -------------------------------------------------------------------------------- /nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | { sources ? import ./sources.nix }: 2 | 3 | let 4 | overlay = _: nixpkgs: { 5 | 6 | # Nix tooling 7 | niv = (import sources.niv {}).niv; 8 | gitignore = import sources.gitignore { inherit (nixpkgs) lib; }; 9 | 10 | # Haskell overrides 11 | haskellPackages = nixpkgs.haskellPackages.override { 12 | overrides = self: super: { 13 | # External overrides 14 | # ..no overrides yet 15 | 16 | # Internal overrides 17 | # ..no overrides yet 18 | }; 19 | }; 20 | }; 21 | 22 | in import sources.nixpkgs { overlays = [ overlay ]; } 23 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "gitignore": { 3 | "branch": "master", 4 | "description": "Nix functions for filtering local git sources", 5 | "homepage": "", 6 | "owner": "hercules-ci", 7 | "repo": "gitignore.nix", 8 | "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73", 9 | "sha256": "07vg2i9va38zbld9abs9lzqblz193vc5wvqd6h7amkmwf66ljcgh", 10 | "type": "tarball", 11 | "url": "https://github.com/hercules-ci/gitignore.nix/archive/a20de23b925fd8264fd7fad6454652e142fd7f73.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "nixpkgs": { 15 | "branch": "release-22.11", 16 | "description": "Nix Packages collection", 17 | "homepage": "", 18 | "owner": "NixOS", 19 | "repo": "nixpkgs", 20 | "rev": "4098cb41387cae6d3e0078fa6d84b258967ac7fa", 21 | "sha256": "0blwc8zrwwaidg51cnfbhicy5s9a9ikrmrw4fi21agaz24x5snzp", 22 | "type": "tarball", 23 | "url": "https://github.com/NixOS/nixpkgs/archive/4098cb41387cae6d3e0078fa6d84b258967ac7fa.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: name: spec: 10 | let 11 | name' = sanitizeName name + "-src"; 12 | in 13 | if spec.builtin or true then 14 | builtins_fetchurl { inherit (spec) url sha256; name = name'; } 15 | else 16 | pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; 17 | 18 | fetch_tarball = pkgs: name: spec: 19 | let 20 | name' = sanitizeName name + "-src"; 21 | in 22 | if spec.builtin or true then 23 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 24 | else 25 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 26 | 27 | fetch_git = name: spec: 28 | let 29 | ref = 30 | if spec ? ref then spec.ref else 31 | if spec ? branch then "refs/heads/${spec.branch}" else 32 | if spec ? tag then "refs/tags/${spec.tag}" else 33 | abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; 34 | submodules = if spec ? submodules then spec.submodules else false; 35 | submoduleArg = 36 | let 37 | nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0; 38 | emptyArgWithWarning = 39 | if submodules == true 40 | then 41 | builtins.trace 42 | ( 43 | "The niv input \"${name}\" uses submodules " 44 | + "but your nix's (${builtins.nixVersion}) builtins.fetchGit " 45 | + "does not support them" 46 | ) 47 | {} 48 | else {}; 49 | in 50 | if nixSupportsSubmodules 51 | then { inherit submodules; } 52 | else emptyArgWithWarning; 53 | in 54 | builtins.fetchGit 55 | ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); 56 | 57 | fetch_local = spec: spec.path; 58 | 59 | fetch_builtin-tarball = name: throw 60 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 61 | $ niv modify ${name} -a type=tarball -a builtin=true''; 62 | 63 | fetch_builtin-url = name: throw 64 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 65 | $ niv modify ${name} -a type=file -a builtin=true''; 66 | 67 | # 68 | # Various helpers 69 | # 70 | 71 | # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 72 | sanitizeName = name: 73 | ( 74 | concatMapStrings (s: if builtins.isList s then "-" else s) 75 | ( 76 | builtins.split "[^[:alnum:]+._?=-]+" 77 | ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) 78 | ) 79 | ); 80 | 81 | # The set of packages used when specs are fetched using non-builtins. 82 | mkPkgs = sources: system: 83 | let 84 | sourcesNixpkgs = 85 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; 86 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 87 | hasThisAsNixpkgsPath = == ./.; 88 | in 89 | if builtins.hasAttr "nixpkgs" sources 90 | then sourcesNixpkgs 91 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 92 | import {} 93 | else 94 | abort 95 | '' 96 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 97 | add a package called "nixpkgs" to your sources.json. 98 | ''; 99 | 100 | # The actual fetching function. 101 | fetch = pkgs: name: spec: 102 | 103 | if ! builtins.hasAttr "type" spec then 104 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 105 | else if spec.type == "file" then fetch_file pkgs name spec 106 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 107 | else if spec.type == "git" then fetch_git name spec 108 | else if spec.type == "local" then fetch_local spec 109 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 110 | else if spec.type == "builtin-url" then fetch_builtin-url name 111 | else 112 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 113 | 114 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 115 | # the path directly as opposed to the fetched source. 116 | replace = name: drv: 117 | let 118 | saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; 119 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 120 | in 121 | if ersatz == "" then drv else 122 | # this turns the string into an actual Nix path (for both absolute and 123 | # relative paths) 124 | if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; 125 | 126 | # Ports of functions for older nix versions 127 | 128 | # a Nix version of mapAttrs if the built-in doesn't exist 129 | mapAttrs = builtins.mapAttrs or ( 130 | f: set: with builtins; 131 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 132 | ); 133 | 134 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 135 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 136 | 137 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 138 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 139 | 140 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 141 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 142 | concatMapStrings = f: list: concatStrings (map f list); 143 | concatStrings = builtins.concatStringsSep ""; 144 | 145 | # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 146 | optionalAttrs = cond: as: if cond then as else {}; 147 | 148 | # fetchTarball version that is compatible between all the versions of Nix 149 | builtins_fetchTarball = { url, name ? null, sha256 }@attrs: 150 | let 151 | inherit (builtins) lessThan nixVersion fetchTarball; 152 | in 153 | if lessThan nixVersion "1.12" then 154 | fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 155 | else 156 | fetchTarball attrs; 157 | 158 | # fetchurl version that is compatible between all the versions of Nix 159 | builtins_fetchurl = { url, name ? null, sha256 }@attrs: 160 | let 161 | inherit (builtins) lessThan nixVersion fetchurl; 162 | in 163 | if lessThan nixVersion "1.12" then 164 | fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 165 | else 166 | fetchurl attrs; 167 | 168 | # Create the final "sources" from the config 169 | mkSources = config: 170 | mapAttrs ( 171 | name: spec: 172 | if builtins.hasAttr "outPath" spec 173 | then abort 174 | "The values in sources.json should not have an 'outPath' attribute" 175 | else 176 | spec // { outPath = replace name (fetch config.pkgs name spec); } 177 | ) config.sources; 178 | 179 | # The "config" used by the fetchers 180 | mkConfig = 181 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 182 | , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) 183 | , system ? builtins.currentSystem 184 | , pkgs ? mkPkgs sources system 185 | }: rec { 186 | # The sources, i.e. the attribute set of spec name to spec 187 | inherit sources; 188 | 189 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 190 | inherit pkgs; 191 | }; 192 | 193 | in 194 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 195 | -------------------------------------------------------------------------------- /release.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -euo pipefail 3 | IFS=$'\n\t' 4 | 5 | rm -rf dist-newstyle 6 | rm -rf .ghc.env* 7 | 8 | cabal update 9 | cabal sdist 10 | cabal v2-haddock doctest-parallel \ 11 | --with-compiler ghc-9.6.2 \ 12 | --haddock-for-hackage \ 13 | --haddock-hyperlinked-source \ 14 | --enable-documentation 15 | 16 | PASSWORD=${PASSWORD:-password-here} 17 | SDIST=$(find . -name 'doctest-parallel-*.tar.gz' | grep -v docs) 18 | DDIST=$(find . -name 'doctest-parallel-*.tar.gz' | grep docs) 19 | 20 | echo "To publish a release candidate, run:" 21 | echo " cabal upload --username=martijnbastiaan --password=${PASSWORD} ${SDIST}" 22 | echo " cabal upload --documentation --username=martijnbastiaan --password=${PASSWORD} ${DDIST}" 23 | echo "" 24 | echo "To make a release, run:" 25 | echo " cabal upload --publish --username=martijnbastiaan --password=${PASSWORD} ${SDIST}" 26 | echo " cabal upload --publish --documentation --username=martijnbastiaan --password=${PASSWORD} ${DDIST}" 27 | -------------------------------------------------------------------------------- /scripts/build_all.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | GHCS=( "9.0.2" "9.2.8" "9.4.8" "9.6.6" "9.8.1" "9.10.1" ) 5 | 6 | cabal update 7 | 8 | for GHC in "${GHCS[@]}" 9 | do 10 | echo "> cabal build all --with-compiler=ghc-$GHC --only-dependencies" 11 | cabal build all --with-compiler=ghc-$GHC --only-dependencies 12 | done 13 | 14 | for GHC in "${GHCS[@]}" 15 | do 16 | echo "> cabal build all --with-compiler=ghc-$GHC" 17 | cabal build all --with-compiler=ghc-$GHC 18 | done 19 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix {} }: 2 | let 3 | inherit (nixpkgs) pkgs; 4 | inherit (pkgs) haskellPackages; 5 | 6 | project = (import ./. {}); 7 | in 8 | pkgs.stdenv.mkDerivation { 9 | name = "shell"; 10 | buildInputs = project.env.propagatedBuildInputs ++ project.env.nativeBuildInputs ++ [ 11 | haskellPackages.cabal-install 12 | ]; 13 | LC_ALL = "C.UTF-8"; 14 | } 15 | -------------------------------------------------------------------------------- /src/Control/Monad/Extra.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Extra where 2 | 3 | -- | Like @if@, but where the test can be monadic. 4 | ifM :: Monad m => m Bool -> m a -> m a -> m a 5 | ifM predicate t f = do b <- predicate; if b then t else f 6 | 7 | -- | Like 'when', but where the test can be monadic. 8 | whenM :: Monad m => m Bool -> m () -> m () 9 | whenM b t = ifM b t (pure ()) 10 | -------------------------------------------------------------------------------- /src/Data/List/Extra.hs: -------------------------------------------------------------------------------- 1 | module Data.List.Extra (trim, splitOn) where 2 | 3 | import Data.Char (isSpace) 4 | import Data.List (dropWhileEnd) 5 | 6 | -- | Remove spaces from either side of a string. A combination of 'trimEnd' and 'trimStart'. 7 | -- 8 | -- > trim " hello " == "hello" 9 | -- > trimStart " hello " == "hello " 10 | -- > trimEnd " hello " == " hello" 11 | -- > \s -> trim s == trimEnd (trimStart s) 12 | trim :: String -> String 13 | trim = trimEnd . trimStart 14 | 15 | -- | Remove spaces from the start of a string, see 'trim'. 16 | trimStart :: String -> String 17 | trimStart = dropWhile isSpace 18 | 19 | -- | Remove spaces from the end of a string, see 'trim'. 20 | trimEnd :: String -> String 21 | trimEnd = dropWhileEnd isSpace 22 | 23 | -- TODO: Use doctests after fixing: https://github.com/martijnbastiaan/doctest-parallel/issues/87 24 | 25 | -- | Break a list into pieces separated by the first argument, consuming the delimiter. 26 | -- 27 | -- > splitOn '.' "A.B" 28 | -- ["A","B"] 29 | -- > splitOn '.' "A.B.C" 30 | -- ["A","B","C"] 31 | -- > splitOn '.' "." 32 | -- ["",""] 33 | -- > splitOn '.' "" 34 | -- [""] 35 | splitOn :: Eq a => a -> [a] -> [[a]] 36 | splitOn needle haystack = 37 | case break (== needle) haystack of 38 | (chunk, []) -> [chunk] 39 | (chunk, _ : rest) -> chunk : splitOn needle rest 40 | -------------------------------------------------------------------------------- /src/Test/DocTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImplicitParams #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | module Test.DocTest 7 | ( mainFromCabal 8 | , mainFromLibrary 9 | , mainFromCabalWithConfig 10 | , mainFromLibraryWithConfig 11 | 12 | -- * Internal 13 | , filterModules 14 | , isSuccess 15 | , setSeed 16 | , run 17 | ) where 18 | 19 | import Prelude () 20 | import Prelude.Compat 21 | 22 | import qualified Data.Set as Set 23 | import Data.List (intercalate) 24 | 25 | import Control.Monad (unless) 26 | import Control.Monad.Extra (ifM) 27 | import System.Exit (exitFailure) 28 | import System.IO 29 | import System.Random (randomIO) 30 | 31 | import qualified Control.Exception as E 32 | 33 | import GHC.Utils.Panic 34 | 35 | import Test.DocTest.Internal.Options 36 | import Test.DocTest.Internal.Runner 37 | import Test.DocTest.Internal.Nix (getNixGhciArgs) 38 | 39 | -- Cabal 40 | import Distribution.Simple 41 | ( KnownExtension(ImplicitPrelude), Extension (DisableExtension) ) 42 | 43 | -- me 44 | import Test.DocTest.Helpers 45 | ( Library (libDefaultExtensions), extractCabalLibrary, findCabalPackage 46 | , libraryToGhciArgs ) 47 | import Test.DocTest.Internal.Logging (LogLevel(..)) 48 | 49 | import qualified Test.DocTest.Internal.Logging as Logging 50 | 51 | -- | Run doctest with given list of arguments. 52 | -- 53 | -- Example: 54 | -- 55 | -- @ 56 | -- mainFromCabal "my-project" =<< getArgs 57 | -- @ 58 | -- 59 | mainFromCabal :: String -> [String] -> IO () 60 | mainFromCabal libName cmdArgs = do 61 | lib <- extractCabalLibrary =<< findCabalPackage libName 62 | mainFromLibrary lib cmdArgs 63 | 64 | -- | Run doctest given config. 65 | -- 66 | -- Example: 67 | -- 68 | -- @ 69 | -- mainFromCabal "my-project" defaultConfig 70 | -- @ 71 | -- 72 | mainFromCabalWithConfig :: String -> Config -> IO () 73 | mainFromCabalWithConfig libName config = do 74 | lib <- extractCabalLibrary =<< findCabalPackage libName 75 | mainFromLibraryWithConfig lib config 76 | 77 | -- | Like 'mainFromCabal', but with a given library. 78 | mainFromLibrary :: Library -> [String] -> IO () 79 | mainFromLibrary lib (parseOptions -> opts) = 80 | case opts of 81 | ResultStdout s -> putStr s 82 | ResultStderr s -> do 83 | hPutStrLn stderr ("doctest: " ++ s) 84 | hPutStrLn stderr "Try `doctest --help' for more information." 85 | exitFailure 86 | Result config -> do 87 | mainFromLibraryWithConfig lib config 88 | 89 | -- | Run doctests with given library and config. 90 | mainFromLibraryWithConfig :: Library -> Config -> IO () 91 | mainFromLibraryWithConfig lib config = do 92 | r <- run lib config `E.catch` \e -> do 93 | case fromException e of 94 | Just (UsageError err) -> do 95 | hPutStrLn stderr ("doctest: " ++ err) 96 | hPutStrLn stderr "Try `doctest --help' for more information." 97 | exitFailure 98 | _ -> E.throwIO e 99 | unless (isSuccess r) exitFailure 100 | 101 | isSuccess :: Summary -> Bool 102 | isSuccess s = sErrors s == 0 && sFailures s == 0 103 | 104 | -- | Filter modules to be tested against a list of modules to be tested (specified 105 | -- by the user on the command line). If list is empty, test all modules. Throws 106 | -- and error if a non-existing module was specified. 107 | filterModules :: [ModuleName] -> [ModuleName] -> [ModuleName] 108 | filterModules [] mods = mods 109 | filterModules wantedMods0 allMods0 110 | | (_:_) <- nonExistingMods = error ("Unknown modules specified: " <> show nonExistingMods) 111 | | otherwise = filter isSpecifiedMod allMods0 112 | where 113 | wantedMods1 = Set.fromList wantedMods0 114 | allMods1 = Set.fromList allMods0 115 | 116 | nonExistingMods = Set.toList (wantedMods1 `Set.difference` allMods1) 117 | isSpecifiedMod nm = nm `Set.member` wantedMods1 118 | 119 | setSeed :: (?verbosity :: LogLevel) => ModuleConfig -> IO ModuleConfig 120 | setSeed cfg@ModuleConfig{cfgRandomizeOrder=True, cfgSeed=Nothing} = do 121 | -- Using an absolute number to prevent copy+paste errors 122 | seed <- abs <$> randomIO 123 | Logging.log Info ("Using freshly generated seed to randomize test order: " <> show seed) 124 | pure cfg{cfgSeed=Just seed} 125 | setSeed cfg = pure cfg 126 | 127 | -- | Run doctest for given library and config. Produce a summary of all tests. 128 | run :: Library -> Config -> IO Summary 129 | run lib Config{..} = do 130 | nixGhciArgs <- ifM (pure cfgNix) getNixGhciArgs (pure []) 131 | 132 | let 133 | implicitPrelude = DisableExtension ImplicitPrelude `notElem` libDefaultExtensions lib 134 | (includeArgs, allModules, otherGhciArgs) = libraryToGhciArgs lib 135 | evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"] ++ nixGhciArgs 136 | parseGhcArgs = includeArgs ++ otherGhciArgs ++ nixGhciArgs ++ cfgGhcArgs 137 | 138 | let 139 | ?verbosity = cfgLogLevel 140 | 141 | modConfig <- setSeed cfgModuleConfig 142 | 143 | -- Run tests 144 | Logging.log Verbose "Running examples.." 145 | let 146 | filteredModules = filterModules cfgModules allModules 147 | filteredModulesMsg = intercalate ", " filteredModules 148 | Logging.log Debug ("Running examples in modules: " <> filteredModulesMsg) 149 | runModules modConfig cfgThreads implicitPrelude parseGhcArgs evalGhciArgs filteredModules 150 | -------------------------------------------------------------------------------- /src/Test/DocTest/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | module Test.DocTest.Helpers where 9 | 10 | import GHC.Stack (HasCallStack) 11 | 12 | import Data.Maybe (maybeToList) 13 | import System.Directory 14 | ( canonicalizePath, doesFileExist ) 15 | import System.FilePath ((), isDrive, takeDirectory) 16 | import System.FilePath.Glob (glob) 17 | import System.Info (compilerVersion) 18 | 19 | import qualified Data.Set as Set 20 | 21 | -- Cabal 22 | import Distribution.ModuleName (ModuleName) 23 | import Distribution.Simple 24 | ( Extension (DisableExtension, EnableExtension, UnknownExtension), Language (..) ) 25 | import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) 26 | import Distribution.PackageDescription 27 | ( GenericPackageDescription (condLibrary) 28 | , exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package 29 | , packageDescription, condSubLibraries, includeDirs, autogenModules, ConfVar(..) 30 | , defaultLanguage, BuildInfo (otherModules) ) 31 | 32 | import Distribution.Compiler (CompilerFlavor(GHC)) 33 | import Distribution.Pretty (prettyShow) 34 | import Distribution.System (buildArch, buildOS) 35 | import Distribution.Types.Condition (Condition(..)) 36 | import Distribution.Types.CondTree 37 | import Distribution.Types.Version (Version, mkVersion') 38 | import Distribution.Types.VersionRange (withinRange) 39 | import Distribution.Verbosity (silent) 40 | 41 | #if MIN_VERSION_Cabal(3,8,0) 42 | import Distribution.Simple.PackageDescription (readGenericPackageDescription) 43 | #else 44 | import Distribution.PackageDescription.Parsec (readGenericPackageDescription) 45 | #endif 46 | 47 | #if MIN_VERSION_Cabal(3,14,0) 48 | import Distribution.Utils.Path (SymbolicPath, makeSymbolicPath) 49 | #elif MIN_VERSION_Cabal(3,6,0) 50 | import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath) 51 | #endif 52 | 53 | 54 | -- | Efficient implementation of set like deletion on lists 55 | -- 56 | -- >>> "abcd" `rmList` "ad" 57 | -- "bc" 58 | -- >>> "aaabcccd" `rmList` "ad" 59 | -- "bccc" 60 | rmList :: Ord a => [a] -> [a] -> [a] 61 | rmList xs (Set.fromList -> ys) = filter (not . (`Set.member` ys)) xs 62 | 63 | data Library = Library 64 | { libSourceDirectories :: [FilePath] 65 | -- ^ Haskell source directories 66 | , libCSourceDirectories :: [FilePath] 67 | -- ^ C source directories 68 | , libModules :: [ModuleName] 69 | -- ^ Exposed modules 70 | , libDefaultExtensions :: [Extension] 71 | -- ^ Extensions enabled by default 72 | , libDefaultLanguages :: [Language] 73 | -- ^ Language version(s) to enable 74 | } 75 | deriving (Show) 76 | 77 | -- | Merge multiple libraries into one, by concatenating all their fields. 78 | mergeLibraries :: [Library] -> Library 79 | mergeLibraries libs = Library 80 | -- XXX: Why do we merge libraries? Shouldn't we always aim to parse ONE library? 81 | { libSourceDirectories = concatMap libSourceDirectories libs 82 | , libCSourceDirectories = concatMap libCSourceDirectories libs 83 | , libModules = concatMap libModules libs 84 | , libDefaultExtensions = concatMap libDefaultExtensions libs 85 | , libDefaultLanguages = concatMap libDefaultLanguages libs 86 | } 87 | 88 | -- | Convert a "Library" to arguments suitable to be passed to GHCi. 89 | libraryToGhciArgs :: Library -> ([String], [String], [String]) 90 | libraryToGhciArgs Library{..} = (hsSrcArgs <> cSrcArgs, modArgs, extArgs <> langArgs) 91 | where 92 | hsSrcArgs = map ("-i" <>) libSourceDirectories 93 | cSrcArgs = map ("-I" <>) libCSourceDirectories 94 | modArgs = map prettyShow libModules 95 | extArgs = map showExt libDefaultExtensions 96 | langArgs = map showLanguage libDefaultLanguages 97 | 98 | showLanguage = \case 99 | UnknownLanguage ul -> "-X" <> ul 100 | l -> "-X" <> show l 101 | 102 | showExt = \case 103 | EnableExtension ext -> "-X" <> show ext 104 | DisableExtension ext -> "-XNo" <> show ext 105 | UnknownExtension ext -> "-X" <> ext 106 | 107 | -- | Drop a number of elements from the end of the list. 108 | -- 109 | -- > dropEnd 3 "hello" == "he" 110 | -- > dropEnd 5 "bye" == "" 111 | -- > dropEnd (-1) "bye" == "bye" 112 | -- > \i xs -> dropEnd i xs `isPrefixOf` xs 113 | -- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i) 114 | -- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..] 115 | dropEnd :: Int -> [a] -> [a] 116 | dropEnd i xs 117 | | i <= 0 = xs 118 | | otherwise = f xs (drop i xs) 119 | where 120 | f (a:as) (_:bs) = a : f as bs 121 | f _ _ = [] 122 | 123 | -- | Searches for a file called @package.cabal@, where @package@ is given as an 124 | -- argument. It will look for it in the current directory. If it can't find it 125 | -- there, it will traverse up until it finds the file or a file called 126 | -- @cabal.project@. In case of the latter, it will traverse down recursively 127 | -- until it encounters a @package.cabal@. 128 | -- 129 | -- The returned path points to the @package.cabal@. Errors if it could not 130 | -- find @package.cabal@ anywhere, or when it found multiple. 131 | -- 132 | findCabalPackage :: HasCallStack => String -> IO FilePath 133 | findCabalPackage packageName = goUp =<< canonicalizePath packageName 134 | where 135 | goUp :: FilePath -> IO FilePath 136 | goUp path 137 | | isDrive path = error ("Could not find '" <> packageFilename <> "'") 138 | | otherwise = do 139 | packageExists <- doesFileExist (path packageFilename) 140 | projectExists <- doesFileExist (path projectFilename) 141 | 142 | if | packageExists -> pure (path packageFilename) 143 | | projectExists -> goDown path 144 | | otherwise -> goUp (takeDirectory path) 145 | 146 | goDown :: FilePath -> IO FilePath 147 | goDown path = do 148 | candidates <- glob (path "**" packageFilename) 149 | case candidates of 150 | [] -> error ("Could not find " <> packageFilename <> " in project " <> path) 151 | (_:_:_) -> error ("Ambiguous packages in project " <> path <> ": " <> show candidates) 152 | [c] -> pure c 153 | 154 | packageFilename = packageName <> ".cabal" 155 | projectFilename = "cabal.project" 156 | 157 | #if MIN_VERSION_Cabal(3,14,0) 158 | compatPrettyShow :: SymbolicPath a b -> FilePath 159 | compatPrettyShow = prettyShow 160 | #elif MIN_VERSION_Cabal(3,6,0) 161 | compatPrettyShow :: SymbolicPath PackageDir SourceDir -> FilePath 162 | compatPrettyShow = prettyShow 163 | #else 164 | compatPrettyShow :: FilePath -> FilePath 165 | compatPrettyShow = id 166 | #endif 167 | 168 | -- | Traverse the given tree, solve predicates in branches, and return its 169 | -- contents. 170 | -- 171 | -- XXX: Branches guarded by Cabal flags are ignored. I'm not sure where we should 172 | -- get this info from. 173 | -- 174 | solveCondTree :: CondTree ConfVar c a -> [(c, a)] 175 | solveCondTree CondNode{condTreeData, condTreeConstraints, condTreeComponents} = 176 | (condTreeConstraints, condTreeData) : concatMap goBranch condTreeComponents 177 | where 178 | goBranch :: CondBranch ConfVar c a -> [(c, a)] 179 | goBranch (CondBranch condBranchCondition condBranchIfTrue condBranchIfFalse) = 180 | if goCondition condBranchCondition 181 | then solveCondTree condBranchIfTrue 182 | else maybe mempty solveCondTree condBranchIfFalse 183 | 184 | goCondition :: Condition ConfVar -> Bool 185 | goCondition = \case 186 | Var cv -> 187 | case cv of 188 | OS os -> os == buildOS 189 | Arch ar -> ar == buildArch 190 | Impl cf versionRange -> 191 | case cf of 192 | GHC -> withinRange buildGhc versionRange 193 | _ -> error ("Unrecognized compiler: " <> show cf) 194 | -- XXX: We currently ignore any flags passed to Cabal 195 | #if MIN_VERSION_Cabal(3,4,0) 196 | PackageFlag _fn -> False 197 | #else 198 | Flag _fn -> False 199 | #endif 200 | Lit b -> b 201 | CNot con -> not (goCondition con) 202 | COr con0 con1 -> goCondition con0 || goCondition con1 203 | CAnd con0 con1 -> goCondition con0 && goCondition con1 204 | 205 | -- | GHC version as Cabal's 'Version' data structure 206 | buildGhc :: Version 207 | buildGhc = mkVersion' compilerVersion 208 | 209 | -- | Given a filepath to a @package.cabal@, parse it, and yield a "Library". Yields 210 | -- the default Library if first argument is Nothing, otherwise it will look for 211 | -- a specific sublibrary. 212 | extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library 213 | extractSpecificCabalLibrary maybeLibName pkgPath = do 214 | pkg <- 215 | readGenericPackageDescription 216 | silent 217 | #if MIN_VERSION_Cabal(3,14,0) 218 | Nothing 219 | (makeSymbolicPath pkgPath) 220 | #else 221 | pkgPath 222 | #endif 223 | case maybeLibName of 224 | Nothing -> 225 | case condLibrary pkg of 226 | Nothing -> 227 | let pkgDescription = package (packageDescription pkg) in 228 | error ("Could not find main library in: " <> show pkgDescription) 229 | Just lib -> 230 | pure (go lib) 231 | 232 | Just libName -> 233 | pure (go (findSubLib pkg libName (condSubLibraries pkg))) 234 | 235 | where 236 | findSubLib pkg targetLibName [] = 237 | let pkgDescription = package (packageDescription pkg) in 238 | error ("Could not find library " <> targetLibName <> " in " <> show pkgDescription) 239 | findSubLib pkg targetLibName ((libName, lib):libs) 240 | | unUnqualComponentName libName == targetLibName = lib 241 | | otherwise = findSubLib pkg targetLibName libs 242 | 243 | go condNode = mergeLibraries libs1 244 | where 245 | libs0 = map snd (solveCondTree condNode) 246 | libs1 = map goLib libs0 247 | 248 | goLib lib = Library 249 | { libSourceDirectories = map ((root ) . compatPrettyShow) sourceDirs 250 | , libCSourceDirectories = map ((root )) 251 | #if MIN_VERSION_Cabal(3,14,0) 252 | $ map compatPrettyShow 253 | #endif 254 | cSourceDirs 255 | , libModules = modules `rmList` autogenModules buildInfo 256 | , libDefaultExtensions = defaultExtensions buildInfo 257 | , libDefaultLanguages = maybeToList (defaultLanguage buildInfo) 258 | } 259 | where 260 | modules = otherModules buildInfo <> exposedModules lib 261 | buildInfo = libBuildInfo lib 262 | sourceDirs = hsSourceDirs buildInfo 263 | cSourceDirs = includeDirs buildInfo 264 | root = takeDirectory pkgPath 265 | 266 | 267 | -- | Given a filepath to a @package.cabal@, parse it, and yield a "Library". Returns 268 | -- and error if no library was specified in the cabal package file. 269 | extractCabalLibrary :: FilePath -> IO Library 270 | extractCabalLibrary = extractSpecificCabalLibrary Nothing 271 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Extract.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE ViewPatterns #-} 10 | 11 | module Test.DocTest.Internal.Extract 12 | ( Module(..) 13 | , isEmptyModule 14 | , extract 15 | , extractIO 16 | , eraseConfigLocation 17 | ) where 18 | import Prelude hiding (mod, concat) 19 | import Control.DeepSeq (NFData, deepseq) 20 | import Control.Exception (AsyncException, throw, throwIO, fromException) 21 | import Control.Monad 22 | import Control.Monad.Catch (catches, SomeException, Exception, Handler (Handler)) 23 | import Data.Generics (Data, extQ, mkQ, everythingBut) 24 | import Data.List (partition, isPrefixOf) 25 | import Data.List.Extra (trim, splitOn) 26 | import Data.Maybe 27 | import GHC.Generics (Generic) 28 | 29 | #if __GLASGOW_HASKELL__ < 912 30 | import Data.Generics (Typeable) 31 | #endif 32 | 33 | import GHC hiding (Module, Located, moduleName, parsedSource) 34 | import GHC.Driver.Session 35 | import GHC.Utils.Monad (liftIO) 36 | 37 | import System.Directory 38 | import System.FilePath 39 | 40 | #if __GLASGOW_HASKELL__ < 902 41 | import GHC.Data.FastString (unpackFS) 42 | import GHC.Types.Basic (SourceText(SourceText)) 43 | #elif __GLASGOW_HASKELL__ < 906 44 | import GHC.Types.SourceText (SourceText(SourceText)) 45 | import GHC.Data.FastString (unpackFS) 46 | #else 47 | import GHC.Data.FastString (unpackFS) 48 | #endif 49 | 50 | import Test.DocTest.Internal.GhcUtil (withGhc) 51 | import Test.DocTest.Internal.Location hiding (unLoc) 52 | import Test.DocTest.Internal.Util (convertDosLineEndings) 53 | 54 | #if MIN_VERSION_ghc_exactprint(1,3,0) 55 | import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleEpAnnsWithCppInternal, defaultCppOptions) 56 | #else 57 | import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCppInternal, defaultCppOptions) 58 | #endif 59 | 60 | #if __GLASGOW_HASKELL__ < 902 61 | import GHC.Driver.Types (throwErrors) 62 | import GHC.Parser.Header (getOptionsFromFile) 63 | #elif __GLASGOW_HASKELL__ < 904 64 | import GHC.Types.SourceError (throwErrors) 65 | import GHC.Parser.Header (getOptionsFromFile) 66 | #else 67 | import GHC.Types.SourceError (throwErrors) 68 | import GHC.Parser.Header (getOptionsFromFile) 69 | import GHC.Driver.Config.Parser (initParserOpts) 70 | #endif 71 | 72 | #if __GLASGOW_HASKELL__ < 904 73 | initParserOpts :: DynFlags -> DynFlags 74 | initParserOpts = id 75 | #endif 76 | 77 | 78 | -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. 79 | newtype ExtractError = ExtractError SomeException 80 | #if __GLASGOW_HASKELL__ < 912 81 | deriving Typeable 82 | #endif 83 | 84 | instance Show ExtractError where 85 | show (ExtractError e) = 86 | unlines [ 87 | "Ouch! Hit an error thunk in GHC's AST while extracting documentation." 88 | , "" 89 | , " " ++ msg 90 | , "" 91 | , "This is most likely a bug in doctest-parallel." 92 | , "" 93 | , "Please report it here: https://github.com/martijnbastiaan/doctest-parallel/issues/new" 94 | ] 95 | where 96 | msg = case fromException e of 97 | Just (Panic s) -> "GHC panic: " ++ s 98 | _ -> show e 99 | 100 | instance Exception ExtractError 101 | 102 | data ModuleNotFoundError = ModuleNotFoundError String [FilePath] 103 | deriving ( 104 | #if __GLASGOW_HASKELL__ < 912 105 | Typeable, 106 | #endif 107 | Exception 108 | ) 109 | 110 | instance Show ModuleNotFoundError where 111 | show (ModuleNotFoundError modName incdirs) = 112 | unlines [ 113 | "Module not found: " ++ modName 114 | , "" 115 | , "Tried the following include directories:" 116 | , "" 117 | , unlines incdirs 118 | ] 119 | 120 | -- | Documentation for a module grouped together with the modules name. 121 | data Module a = Module { 122 | moduleName :: String 123 | , moduleSetup :: Maybe a 124 | , moduleContent :: [a] 125 | , moduleConfig :: [Located String] 126 | } deriving (Eq, Functor, Show, Generic, NFData) 127 | 128 | isEmptyModule :: Module a -> Bool 129 | isEmptyModule (Module _ setup tests _) = null tests && isNothing setup 130 | 131 | eraseConfigLocation :: Module a -> Module a 132 | eraseConfigLocation m@Module{moduleConfig} = 133 | m{moduleConfig=map go moduleConfig} 134 | where 135 | go (Located _ a) = noLocation a 136 | 137 | moduleParts :: String -> [String] 138 | moduleParts = splitOn '.' 139 | 140 | findModulePath :: [FilePath] -> String -> IO FilePath 141 | findModulePath importPaths modName = do 142 | let 143 | modPath = foldl1 () (moduleParts modName) <.> "hs" 144 | 145 | found <- fmap catMaybes $ forM importPaths $ \importPath -> do 146 | let fullPath = importPath modPath 147 | exists <- doesFileExist fullPath 148 | return $ if exists then Just fullPath else Nothing 149 | 150 | case found of 151 | [] -> throwIO (ModuleNotFoundError modName importPaths) 152 | (p:_) -> pure p 153 | 154 | -- | Parse a list of modules. Can throw an `ModuleNotFoundError` if a module's 155 | -- source file cannot be found. Can throw a `SourceError` if an error occurs 156 | -- while parsing. 157 | parse :: String -> Ghc ParsedSource 158 | parse modName = do 159 | -- Find all specified modules on disk 160 | importPaths0 <- importPaths <$> getDynFlags 161 | path <- liftIO $ findModulePath importPaths0 modName 162 | 163 | -- LANGUAGE pragmas can influence how a file is parsed. For example, CPP 164 | -- means we need to preprocess the file before parsing it. We use GHC's 165 | -- `getOptionsFromFile` to parse these pragmas and then feed them as options 166 | -- to the "real" parser. 167 | dynFlags0 <- getDynFlags 168 | #if __GLASGOW_HASKELL__ < 904 169 | flagsFromFile <- 170 | #else 171 | (_, flagsFromFile) <- 172 | #endif 173 | liftIO $ getOptionsFromFile (initParserOpts dynFlags0) path 174 | (dynFlags1, _, _) <- parseDynamicFilePragma dynFlags0 flagsFromFile 175 | 176 | #if MIN_VERSION_ghc_exactprint(1,3,0) 177 | result <- parseModuleEpAnnsWithCppInternal defaultCppOptions dynFlags1 path 178 | #else 179 | result <- parseModuleApiAnnsWithCppInternal defaultCppOptions dynFlags1 path 180 | #endif 181 | 182 | case result of 183 | Left errs -> throwErrors errs 184 | #if MIN_VERSION_ghc_exactprint(1,3,0) 185 | Right (_cppComments, _dynFlags, parsedSource) -> pure parsedSource 186 | #else 187 | Right (_apiAnns, _cppComments, _dynFlags, parsedSource) -> pure parsedSource 188 | #endif 189 | 190 | -- | Like `extract`, but runs in the `IO` monad given GHC parse arguments. 191 | extractIO :: [String] -> String -> IO (Module (Located String)) 192 | extractIO parseArgs modName = withGhc parseArgs $ extract modName 193 | 194 | -- | Extract all docstrings from given list of files/modules. 195 | -- 196 | -- This includes the docstrings of all local modules that are imported from 197 | -- those modules (possibly indirect). 198 | -- 199 | -- Can throw `ExtractError` if an error occurs while extracting the docstrings, 200 | -- or a `SourceError` if an error occurs while parsing the module. Can throw a 201 | -- `ModuleNotFoundError` if a module's source file cannot be found. 202 | extract :: String -> Ghc (Module (Located String)) 203 | extract modName = do 204 | mod <- parse modName 205 | let 206 | docs0 = extractFromModule modName mod 207 | docs1 = fmap convertDosLineEndings <$> docs0 208 | 209 | (docs1 `deepseq` return docs1) `catches` [ 210 | -- Re-throw AsyncException, otherwise execution will not terminate on 211 | -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just 212 | -- UserInterrupt) because all of them indicate severe conditions and 213 | -- should not occur during normal operation. 214 | Handler (\e -> throw (e :: AsyncException)) 215 | , Handler (liftIO . throwIO . ExtractError) 216 | ] 217 | 218 | -- | Extract all docstrings from given module and attach the modules name. 219 | extractFromModule :: String -> ParsedSource -> Module (Located String) 220 | extractFromModule modName m = Module 221 | { moduleName = modName 222 | , moduleSetup = listToMaybe (map snd setup) 223 | , moduleContent = map snd docs 224 | , moduleConfig = moduleAnnsFromModule m 225 | } 226 | where 227 | isSetup = (== Just "setup") . fst 228 | (setup, docs) = partition isSetup (docStringsFromModule m) 229 | 230 | -- | Extract all module annotations from given module. 231 | moduleAnnsFromModule :: ParsedSource -> [Located String] 232 | moduleAnnsFromModule mod = 233 | [fmap stripOptionString ann | ann <- anns, isOption ann] 234 | where 235 | optionPrefix = "doctest-parallel:" 236 | isOption (Located _ s) = optionPrefix `isPrefixOf` s 237 | stripOptionString s = trim (drop (length optionPrefix) s) 238 | anns = extractModuleAnns source 239 | source = unLoc mod 240 | 241 | -- | Extract all docstrings from given module. 242 | docStringsFromModule :: ParsedSource -> [(Maybe String, Located String)] 243 | docStringsFromModule mod = 244 | #if __GLASGOW_HASKELL__ < 904 245 | map (fmap (toLocated . fmap unpackHDS)) docs 246 | #else 247 | map (fmap (toLocated . fmap renderHsDocString)) docs 248 | #endif 249 | where 250 | source = unLoc mod 251 | 252 | -- we use dlist-style concatenation here 253 | docs :: [(Maybe String, LHsDocString)] 254 | docs = header ++ exports ++ decls 255 | 256 | -- We process header, exports and declarations separately instead of 257 | -- traversing the whole source in a generic way, to ensure that we get 258 | -- everything in source order. 259 | header :: [(Maybe String, LHsDocString)] 260 | #if __GLASGOW_HASKELL__ < 904 261 | header = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]] 262 | #elif __GLASGOW_HASKELL__ < 906 263 | header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader source]] 264 | #else 265 | header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader (hsmodExt source)]] 266 | #endif 267 | 268 | exports :: [(Maybe String, LHsDocString)] 269 | exports = [ (Nothing, L (locA loc) doc) 270 | #if __GLASGOW_HASKELL__ < 904 271 | | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source) 272 | #else 273 | | L loc (IEDoc _ (unLoc . fmap hsDocString -> doc)) <- maybe [] unLoc (hsmodExports source) 274 | #endif 275 | ] 276 | 277 | decls :: [(Maybe String, LHsDocString)] 278 | decls = extractDocStrings (Right (hsmodDecls source)) 279 | 280 | type Selector b a = a -> ([b], Bool) 281 | 282 | type DocSelector a = Selector (Maybe String, LHsDocString) a 283 | type AnnSelector a = Selector (Located String) a 284 | 285 | -- | Collect given value and descend into subtree. 286 | select :: a -> ([a], Bool) 287 | select x = ([x], False) 288 | 289 | #if __GLASGOW_HASKELL__ >= 904 290 | -- | Don't collect any values 291 | noSelect :: ([a], Bool) 292 | noSelect = ([], False) 293 | #endif 294 | 295 | -- | Extract module annotations from given value. 296 | extractModuleAnns :: Data a => a -> [Located String] 297 | extractModuleAnns = everythingBut (++) (([], False) `mkQ` fromLHsDecl) 298 | where 299 | fromLHsDecl :: AnnSelector (LHsDecl GhcPs) 300 | fromLHsDecl (L (locA -> loc) decl) = case decl of 301 | #if __GLASGOW_HASKELL__ < 906 302 | AnnD _ (HsAnnotation _ (SourceText _) ModuleAnnProvenance (L _loc expr)) 303 | #else 304 | AnnD _ (HsAnnotation _ ModuleAnnProvenance (L _loc expr)) 305 | #endif 306 | | Just s <- extractLit loc expr 307 | -> select s 308 | _ -> 309 | -- XXX: Shouldn't this be handled by 'everythingBut'? 310 | (extractModuleAnns decl, True) 311 | 312 | -- | Extract string literals. Looks through type annotations and parentheses. 313 | extractLit :: SrcSpan -> HsExpr GhcPs -> Maybe (Located String) 314 | extractLit loc = \case 315 | -- well this is a holy mess innit 316 | #if __GLASGOW_HASKELL__ < 904 317 | HsPar _ (L l e) -> extractLit (locA l) e 318 | #elif __GLASGOW_HASKELL__ < 909 319 | HsPar _ _ (L l e) _ -> extractLit (locA l) e 320 | #else 321 | HsPar _ (L l e) -> extractLit (locA l) e 322 | #endif 323 | ExprWithTySig _ (L l e) _ -> extractLit (locA l) e 324 | HsOverLit _ OverLit{ol_val=HsIsString _ s} -> Just (toLocated (L loc (unpackFS s))) 325 | HsLit _ (HsString _ s) -> Just (toLocated (L loc (unpackFS s))) 326 | _ -> Nothing 327 | 328 | -- | Extract all docstrings from given value. 329 | extractDocStrings :: Either (HsDecl GhcPs) [LHsDecl GhcPs] -> [(Maybe String, LHsDocString)] 330 | extractDocStrings = 331 | everythingBut 332 | (++) 333 | ( ([], False) 334 | `mkQ` fromLHsDecl 335 | `extQ` fromLDocDecl 336 | `extQ` fromLHsDocString 337 | #if __GLASGOW_HASKELL__ >= 904 338 | `extQ` fromHsType 339 | #endif 340 | ) 341 | where 342 | fromLHsDecl :: DocSelector (LHsDecl GhcPs) 343 | fromLHsDecl (L loc decl) = case decl of 344 | 345 | -- Top-level documentation has to be treated separately, because it has 346 | -- no location information attached. The location information is 347 | -- attached to HsDecl instead. 348 | DocD _ x -> select (fromDocDecl (locA loc) x) 349 | 350 | _ -> (extractDocStrings (Left decl), True) 351 | 352 | 353 | fromLDocDecl :: DocSelector 354 | #if __GLASGOW_HASKELL__ >= 901 355 | (LDocDecl GhcPs) 356 | #else 357 | LDocDecl 358 | #endif 359 | fromLDocDecl (L loc x) = select (fromDocDecl (locA loc) x) 360 | 361 | fromLHsDocString :: DocSelector LHsDocString 362 | fromLHsDocString x = select (Nothing, x) 363 | 364 | #if __GLASGOW_HASKELL__ >= 904 365 | fromHsType :: DocSelector (HsType GhcPs) 366 | fromHsType x = case x of 367 | HsDocTy _ _ (L loc hsDoc) -> select (Nothing, L loc (hsDocString hsDoc)) 368 | _ -> noSelect 369 | #endif 370 | 371 | #if __GLASGOW_HASKELL__ < 904 372 | fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString) 373 | #else 374 | fromDocDecl :: SrcSpan -> DocDecl GhcPs -> (Maybe String, LHsDocString) 375 | #endif 376 | fromDocDecl loc x = case x of 377 | #if __GLASGOW_HASKELL__ < 904 378 | DocCommentNamed name doc -> (Just name, L loc doc) 379 | _ -> (Nothing, L loc $ docDeclDoc x) 380 | #else 381 | DocCommentNamed name doc -> (Just name, hsDocString <$> doc) 382 | _ -> (Nothing, L loc $ hsDocString $ unLoc $ docDeclDoc x) 383 | #endif 384 | 385 | #if __GLASGOW_HASKELL__ < 901 386 | locA :: SrcSpan -> SrcSpan 387 | locA = id 388 | #endif 389 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/GhcUtil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Test.DocTest.Internal.GhcUtil (withGhc) where 3 | 4 | import GHC.Paths (libdir) 5 | import GHC 6 | import GHC.Driver.Session (gopt_set) 7 | 8 | import GHC.Utils.Panic (throwGhcException) 9 | 10 | -- | Run a GHC action in Haddock mode 11 | withGhc :: [String] -> Ghc a -> IO a 12 | withGhc flags action = do 13 | flags_ <- handleStaticFlags flags 14 | 15 | runGhc (Just libdir) $ do 16 | handleDynamicFlags flags_ 17 | action 18 | 19 | handleStaticFlags :: [String] -> IO [Located String] 20 | handleStaticFlags flags = return $ map noLoc $ flags 21 | 22 | handleDynamicFlags :: GhcMonad m => [Located String] -> m () 23 | handleDynamicFlags flags = do 24 | #if __GLASGOW_HASKELL__ >= 901 25 | logger <- getLogger 26 | let parseDynamicFlags' = parseDynamicFlags logger 27 | #else 28 | let parseDynamicFlags' = parseDynamicFlags 29 | #endif 30 | dynflags0 <- setHaddockMode <$> getSessionDynFlags 31 | (dynflags1, locSrcs, _) <- parseDynamicFlags' dynflags0 flags 32 | _ <- setSessionDynFlags dynflags1 33 | 34 | -- We basically do the same thing as `ghc/Main.hs` to distinguish 35 | -- "unrecognised flags" from source files. 36 | let srcs = map unLoc locSrcs 37 | unknown_opts = [ f | f@('-':_) <- srcs ] 38 | case unknown_opts of 39 | opt : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'")) 40 | _ -> return () 41 | 42 | setHaddockMode :: DynFlags -> DynFlags 43 | setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) { 44 | #if __GLASGOW_HASKELL__ >= 906 45 | backend = noBackend 46 | #elif __GLASGOW_HASKELL__ >= 901 47 | backend = NoBackend 48 | #else 49 | hscTarget = HscNothing 50 | #endif 51 | , ghcMode = CompManager 52 | , ghcLink = NoLink 53 | } 54 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/GhciWrapper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE MultiWayIf #-} 3 | 4 | module Test.DocTest.Internal.GhciWrapper ( 5 | Interpreter 6 | , Config(..) 7 | , defaultConfig 8 | , new 9 | , close 10 | , eval 11 | , evalIt 12 | , evalEcho 13 | ) where 14 | 15 | import System.IO hiding (stdin, stdout, stderr) 16 | import System.Process 17 | import System.Exit 18 | import Control.Monad 19 | import Control.Exception 20 | import Data.List 21 | import Data.Maybe 22 | 23 | import Test.DocTest.Internal.Logging (DebugLogger) 24 | 25 | data Config = Config { 26 | configGhci :: String 27 | , configVerbose :: Bool 28 | , configIgnoreDotGhci :: Bool 29 | } deriving (Eq, Show) 30 | 31 | defaultConfig :: Config 32 | defaultConfig = Config { 33 | configGhci = "ghci" 34 | , configVerbose = False 35 | , configIgnoreDotGhci = True 36 | } 37 | 38 | -- | Truly random marker, used to separate expressions. 39 | -- 40 | -- IMPORTANT: This module relies upon the fact that this marker is unique. It 41 | -- has been obtained from random.org. Do not expect this module to work 42 | -- properly, if you reuse it for any purpose! 43 | marker :: String 44 | marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1" 45 | 46 | itMarker :: String 47 | itMarker = "d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a" 48 | 49 | data Interpreter = Interpreter { 50 | hIn :: Handle 51 | , hOut :: Handle 52 | , process :: ProcessHandle 53 | , logger :: DebugLogger 54 | } 55 | 56 | new :: DebugLogger -> Config -> [String] -> IO Interpreter 57 | new logger Config{..} args_ = do 58 | logger ("Calling: " ++ unwords (configGhci:args)) 59 | (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit} 60 | setMode stdin_ 61 | setMode stdout_ 62 | let 63 | interpreter = Interpreter 64 | { hIn = stdin_ 65 | , hOut = stdout_ 66 | , process = processHandle 67 | , logger=logger 68 | } 69 | _ <- eval interpreter "import qualified System.IO" 70 | _ <- eval interpreter "import qualified GHC.IO.Handle" 71 | -- The buffering of stdout and stderr is NoBuffering 72 | _ <- eval interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr" 73 | -- Now the buffering of stderr is BlockBuffering Nothing 74 | -- In this situation, GHC 7.7 does not flush the buffer even when 75 | -- error happens. 76 | _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering" 77 | _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering" 78 | 79 | -- this is required on systems that don't use utf8 as default encoding (e.g. 80 | -- Windows) 81 | _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout System.IO.utf8" 82 | _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr System.IO.utf8" 83 | 84 | _ <- eval interpreter ":m - System.IO" 85 | _ <- eval interpreter ":m - GHC.IO.Handle" 86 | 87 | return interpreter 88 | where 89 | args = args_ ++ catMaybes [ 90 | if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing 91 | , if configVerbose then Nothing else Just "-v0" 92 | ] 93 | setMode h = do 94 | hSetBinaryMode h False 95 | hSetBuffering h LineBuffering 96 | hSetEncoding h utf8 97 | 98 | close :: Interpreter -> IO () 99 | close repl = do 100 | hClose $ hIn repl 101 | 102 | -- It is crucial not to close `hOut` before calling `waitForProcess`, 103 | -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang 104 | -- around consuming 100% CPU. This happens when ghci tries to print 105 | -- something to stdout in its signal handler (e.g. when it is blocked in 106 | -- threadDelay it writes "Interrupted." on SIGINT). 107 | e <- waitForProcess $ process repl 108 | hClose $ hOut repl 109 | 110 | when (e /= ExitSuccess) $ do 111 | throwIO (userError $ "Test.DocTest.Internal.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")") 112 | 113 | putExpression :: Interpreter -> Bool -> String -> IO () 114 | putExpression Interpreter{logger = logger, hIn = stdin} preserveIt e = do 115 | logger (">>> " ++ e) 116 | hPutStrLn stdin e 117 | 118 | when preserveIt $ do 119 | let e1 = "let " ++ itMarker ++ " = it" 120 | logger (">>> " ++ e1) 121 | hPutStrLn stdin e1 122 | 123 | hPutStrLn stdin (marker ++ " :: Data.String.String") 124 | 125 | when preserveIt $ do 126 | let e3 = "let it = " ++ itMarker 127 | logger (">>> " ++ e3) 128 | hPutStrLn stdin e3 129 | 130 | hFlush stdin 131 | 132 | getResult :: Bool -> Interpreter -> IO String 133 | getResult echoMode Interpreter{logger = logger, hOut = stdout} = do 134 | result <- go 135 | unless (result == mempty) $ logger result 136 | pure result 137 | where 138 | go = do 139 | line <- hGetLine stdout 140 | 141 | if 142 | | marker `isSuffixOf` line -> do 143 | let xs = stripMarker line 144 | echo xs 145 | return xs 146 | | otherwise -> do 147 | echo (line ++ "\n") 148 | result <- go 149 | return (line ++ "\n" ++ result) 150 | stripMarker l = take (length l - length marker) l 151 | 152 | echo :: String -> IO () 153 | echo 154 | | echoMode = putStr 155 | | otherwise = (const $ return ()) 156 | 157 | -- | Evaluate an expression 158 | eval :: Interpreter -> String -> IO String 159 | eval repl expr = do 160 | putExpression repl False expr 161 | getResult False repl 162 | 163 | -- | Like 'eval', but try to preserve the @it@ variable 164 | evalIt :: Interpreter -> String -> IO String 165 | evalIt repl expr = do 166 | putExpression repl True expr 167 | getResult False repl 168 | 169 | -- | Evaluate an expression 170 | evalEcho :: Interpreter -> String -> IO String 171 | evalEcho repl expr = do 172 | putExpression repl False expr 173 | getResult True repl 174 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #if __GLASGOW_HASKELL__ <= 906 4 | {-# LANGUAGE LambdaCase #-} 5 | #endif 6 | 7 | module Test.DocTest.Internal.Interpreter ( 8 | Interpreter 9 | , safeEval 10 | , safeEvalIt 11 | , withInterpreter 12 | , ghc 13 | , interpreterSupported 14 | 15 | -- * exported for testing 16 | , ghcInfo 17 | , haveInterpreterKey 18 | ) where 19 | 20 | import System.Process 21 | import System.Directory (getPermissions, executable) 22 | import Control.Monad 23 | import Control.Exception hiding (handle) 24 | import Data.Char 25 | #if __GLASGOW_HASKELL__ > 906 26 | import Data.List (unsnoc) 27 | #else 28 | import Data.Bifunctor (first) 29 | #endif 30 | import GHC.Paths (ghc) 31 | 32 | import Test.DocTest.Internal.GhciWrapper 33 | import Test.DocTest.Internal.Logging (DebugLogger) 34 | 35 | -- $setup 36 | -- >>> import Test.DocTest.Internal.GhciWrapper (eval) 37 | -- >>> import Test.DocTest.Internal.Logging (noLogger) 38 | 39 | #if __GLASGOW_HASKELL__ <= 906 40 | -- | If the list is empty returns 'Nothing', otherwise returns the 'init' and the 'last'. 41 | -- 42 | -- > unsnoc "test" == Just ("tes",'t') 43 | -- > unsnoc "" == Nothing 44 | -- > \xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs) 45 | unsnoc :: [a] -> Maybe ([a], a) 46 | unsnoc = \case 47 | [] -> Nothing 48 | x:xs -> Just $ unsnoc1 x xs 49 | where 50 | unsnoc1 :: a -> [a] -> ([a], a) 51 | unsnoc1 x = \case 52 | [] -> ([], x) 53 | y:ys -> first (x:) $ unsnoc1 y ys 54 | #endif 55 | 56 | haveInterpreterKey :: String 57 | haveInterpreterKey = "Have interpreter" 58 | 59 | ghcInfo :: IO [(String, String)] 60 | ghcInfo = read <$> readProcess ghc ["--info"] [] 61 | 62 | interpreterSupported :: IO Bool 63 | interpreterSupported = do 64 | -- in a perfect world this permission check should never fail, but I know of 65 | -- at least one case where it did.. 66 | x <- getPermissions ghc 67 | unless (executable x) $ do 68 | fail $ ghc ++ " is not executable!" 69 | 70 | maybe False (== "YES") . lookup haveInterpreterKey <$> ghcInfo 71 | 72 | -- | Run an interpreter session. 73 | -- 74 | -- Example: 75 | -- 76 | -- >>> withInterpreter noLogger [] $ \i -> eval i "23 + 42" 77 | -- "65\n" 78 | withInterpreter 79 | :: DebugLogger -- ^ Debug logger 80 | -> [String] -- ^ List of flags, passed to GHC 81 | -> (Interpreter -> IO a) -- ^ Action to run 82 | -> IO a -- ^ Result of action 83 | withInterpreter logger flags action = do 84 | let 85 | args = flags ++ [ 86 | "--interactive" 87 | , "-fdiagnostics-color=never" 88 | , "-fno-diagnostics-show-caret" 89 | ] 90 | bracket (new logger defaultConfig{configGhci = ghc} args) close action 91 | 92 | -- | Evaluate an expression; return a Left value on exceptions. 93 | -- 94 | -- An exception may e.g. be caused on unterminated multiline expressions. 95 | safeEval :: Interpreter -> String -> IO (Either String String) 96 | safeEval repl = either (return . Left) (fmap Right . eval repl) . filterExpression 97 | 98 | safeEvalIt :: Interpreter -> String -> IO (Either String String) 99 | safeEvalIt repl = either (return . Left) (fmap Right . evalIt repl) . filterExpression 100 | 101 | filterExpression :: String -> Either String String 102 | filterExpression e = 103 | case map strip (lines e) of 104 | [] -> Right e 105 | (firstLine:ls) -> 106 | let lastLine = maybe firstLine snd (unsnoc ls) in 107 | if firstLine == ":{" && lastLine /= ":}" then fail_ else Right e 108 | where 109 | fail_ = Left "unterminated multiline command" 110 | 111 | strip :: String -> String 112 | strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse 113 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Location.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | module Test.DocTest.Internal.Location where 3 | 4 | import Control.DeepSeq (deepseq, NFData(rnf)) 5 | 6 | import GHC.Types.SrcLoc hiding (Located) 7 | import qualified GHC.Types.SrcLoc as GHC 8 | import GHC.Data.FastString (unpackFS) 9 | 10 | -- | A thing with a location attached. 11 | data Located a = Located Location a 12 | deriving (Eq, Show, Functor) 13 | 14 | instance NFData a => NFData (Located a) where 15 | rnf (Located loc a) = loc `deepseq` a `deepseq` () 16 | 17 | -- | Convert a GHC located thing to a located thing. 18 | toLocated :: GHC.Located a -> Located a 19 | toLocated (L loc a) = Located (toLocation loc) a 20 | 21 | -- | Discard location information. 22 | unLoc :: Located a -> a 23 | unLoc (Located _ a) = a 24 | 25 | -- | Add dummy location information. 26 | noLocation :: a -> Located a 27 | noLocation = Located (UnhelpfulLocation "") 28 | 29 | -- | A line number. 30 | type Line = Int 31 | 32 | -- | A combination of file name and line number. 33 | data Location = UnhelpfulLocation String | Location FilePath Line 34 | deriving Eq 35 | 36 | instance Show Location where 37 | show (UnhelpfulLocation s) = s 38 | show (Location file line) = file ++ ":" ++ show line 39 | 40 | instance NFData Location where 41 | rnf (UnhelpfulLocation str) = str `deepseq` () 42 | rnf (Location file line) = file `deepseq` line `deepseq` () 43 | 44 | -- | 45 | -- Create a list from a location, by repeatedly increasing the line number by 46 | -- one. 47 | enumerate :: Location -> [Location] 48 | enumerate loc = case loc of 49 | UnhelpfulLocation _ -> repeat loc 50 | Location file line -> map (Location file) [line ..] 51 | 52 | -- | Convert a GHC source span to a location. 53 | toLocation :: SrcSpan -> Location 54 | toLocation loc = case loc of 55 | UnhelpfulSpan str -> UnhelpfulLocation (unpackFS $ unhelpfulSpanFS str) 56 | RealSrcSpan sp _ -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) 57 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Logging.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE ImplicitParams #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | module Test.DocTest.Internal.Logging where 8 | 9 | import Control.Applicative (Alternative((<|>))) 10 | import Control.Concurrent (ThreadId, myThreadId) 11 | import Control.DeepSeq (NFData) 12 | import Data.Char (toLower, toUpper) 13 | import Data.List (intercalate) 14 | import Data.Maybe (fromMaybe) 15 | import GHC.Generics (Generic) 16 | import System.IO (hPutStrLn, stderr) 17 | import Text.Printf (printf) 18 | 19 | #if MIN_VERSION_base(4,18,0) 20 | import GHC.Conc.Sync (threadLabel) 21 | #endif 22 | 23 | #if !MIN_VERSION_base(4,18,0) 24 | threadLabel :: ThreadId -> IO (Maybe String) 25 | threadLabel _ = pure Nothing 26 | #endif 27 | 28 | -- | Convenience type alias - not used in this module, but sprinkled across the 29 | -- project. 30 | type DebugLogger = String -> IO () 31 | 32 | -- | Discards any log message 33 | noLogger :: DebugLogger 34 | noLogger = const (pure ()) 35 | 36 | data LogLevel 37 | = Debug 38 | -- ^ Intended for debug runs 39 | | Verbose 40 | -- ^ Intended for debug runs, but without flooding the user with internal messages 41 | | Info 42 | -- ^ Default log level - print messages user is likely wanting to see 43 | | Warning 44 | -- ^ Only print warnings 45 | | Error 46 | -- ^ Only print errors 47 | deriving (Show, Eq, Enum, Generic, NFData, Ord, Bounded) 48 | 49 | -- | Case insensitive 50 | -- 51 | -- >>> parseLogLevel "Info" 52 | -- Just Info 53 | -- >>> parseLogLevel "info" 54 | -- Just Info 55 | -- >>> parseLogLevel "errox" 56 | -- Nothing 57 | -- 58 | parseLogLevel :: String -> Maybe LogLevel 59 | parseLogLevel (map toLower -> level) = 60 | foldl (<|>) Nothing (map go [minBound..]) 61 | where 62 | go :: LogLevel -> Maybe LogLevel 63 | go l 64 | | map toLower (show l) == level = Just l 65 | | otherwise = Nothing 66 | 67 | -- | Pretty print a 'LogLevel' in a justified manner, i.e., all outputs take the 68 | -- same amount of characters to display. 69 | -- 70 | -- >>> showJustifiedLogLevel Debug 71 | -- "Debug " 72 | -- >>> showJustifiedLogLevel Verbose 73 | -- "Verbose" 74 | -- >>> showJustifiedLogLevel Info 75 | -- "Info " 76 | -- >>> showJustifiedLogLevel Warning 77 | -- "Warning" 78 | -- >>> showJustifiedLogLevel Error 79 | -- "Error " 80 | -- 81 | showJustifiedLogLevel :: LogLevel -> String 82 | showJustifiedLogLevel = justifyLeft maxSizeLogLevel ' ' . show 83 | where 84 | maxSizeLogLevel :: Int 85 | maxSizeLogLevel = maximum (map (length . show) [(minBound :: LogLevel)..]) 86 | 87 | -- | Justify a list with a custom fill symbol 88 | -- 89 | -- >>> justifyLeft 10 'x' "foo" 90 | -- "fooxxxxxxx" 91 | -- >>> justifyLeft 3 'x' "foo" 92 | -- "foo" 93 | -- >>> justifyLeft 2 'x' "foo" 94 | -- "foo" 95 | -- 96 | justifyLeft :: Int -> a -> [a] -> [a] 97 | justifyLeft n c s = s ++ replicate (n - length s) c 98 | 99 | -- | Pretty name for a 'ThreadId'. Uses 'threadLabel' if available, otherwise 100 | -- falls back to 'show'. 101 | getThreadName :: ThreadId -> IO String 102 | getThreadName threadId = fromMaybe (show threadId) <$> threadLabel threadId 103 | 104 | -- | /Prettily/ format a log message 105 | -- 106 | -- > threadId <- myThreadId 107 | -- > formatLog Debug (show threadId) "some debug message" 108 | -- "[DEBUG ] [ThreadId 1277462] some debug message" 109 | -- 110 | formatLog :: String -> LogLevel -> String -> String 111 | formatLog nm lvl msg = 112 | intercalate "\n" (map go (lines msg)) 113 | where 114 | go = printf "[%s] [%s] %s" (map toUpper (showJustifiedLogLevel lvl)) nm 115 | 116 | -- | Like 'formatLog', but instantiates the /thread/ argument with the current 'ThreadId' 117 | -- 118 | -- > formatLogHere Debug "some debug message" 119 | -- "[DEBUG ] [ThreadId 1440849] some debug message" 120 | -- 121 | formatLogHere :: LogLevel -> String -> IO String 122 | formatLogHere lvl msg = do 123 | threadName <- getThreadName =<< myThreadId 124 | pure (formatLog threadName lvl msg) 125 | 126 | -- | Should a message be printed? For a given verbosity level and message log level. 127 | shouldLog :: (?verbosity :: LogLevel) => LogLevel -> Bool 128 | shouldLog lvl = ?verbosity <= lvl 129 | 130 | -- | Basic logging function. Uses 'formatLogHere'. Is not thread-safe. 131 | log :: (?verbosity :: LogLevel) => LogLevel -> String -> IO () 132 | log lvl msg 133 | | shouldLog lvl = hPutStrLn stderr =<< formatLogHere lvl msg 134 | | otherwise = pure () 135 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Nix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Test.DocTest.Internal.Nix where 4 | 5 | import Control.Monad (msum) 6 | import Control.Monad.Extra (ifM) 7 | import Control.Monad.Trans.Maybe 8 | import Data.Bool (bool) 9 | import Data.List (intercalate, isSuffixOf) 10 | import Data.Maybe (isJust) 11 | import Data.Version 12 | import GHC.Base (mzero) 13 | import System.Directory 14 | import System.Environment (lookupEnv) 15 | import System.FilePath ((), isDrive, takeDirectory) 16 | import System.Process (readProcess) 17 | 18 | import GHC.Data.Maybe (liftMaybeT) 19 | import System.Info (fullCompilerVersion) 20 | 21 | -- | E.g. @9.0.2@ 22 | compilerVersionStr :: String 23 | compilerVersionStr = intercalate "." (map show (versionBranch fullCompilerVersion)) 24 | 25 | -- | Traverse upwards until one of the following conditions is met: 26 | -- 27 | -- * Current working directory is either root or a home directory 28 | -- * The predicate function returns 'Just' 29 | -- 30 | findDirectoryUp :: (FilePath -> IO (Maybe a)) -> MaybeT IO a 31 | findDirectoryUp f = do 32 | home <- liftMaybeT getHomeDirectory 33 | MaybeT (go home =<< getCurrentDirectory) 34 | where 35 | go home cwd 36 | | isDrive cwd = pure Nothing 37 | | cwd == home = pure Nothing 38 | | otherwise = 39 | f cwd >>= \case 40 | Just a -> pure (Just a) 41 | Nothing -> go home (takeDirectory cwd) 42 | 43 | -- | Like 'findDirectoryUp', but takes a predicate function instead. If the predicate 44 | -- yields 'True', the filepath is returned. 45 | findDirectoryUpPredicate :: (FilePath -> IO Bool) -> MaybeT IO FilePath 46 | findDirectoryUpPredicate f = findDirectoryUp (\fp -> bool Nothing (Just fp) <$> f fp) 47 | 48 | -- | Find the root of the Cabal project relative to the current directory. 49 | findCabalProjectRoot :: MaybeT IO FilePath 50 | findCabalProjectRoot = 51 | msum 52 | [ findDirectoryUpPredicate containsCabalProject 53 | , findDirectoryUpPredicate containsCabalPackage 54 | ] 55 | where 56 | containsCabalPackage :: FilePath -> IO Bool 57 | containsCabalPackage fp = elem "cabal.project" <$> getDirectoryContents fp 58 | 59 | containsCabalProject :: FilePath -> IO Bool 60 | containsCabalProject fp = any (".cabal" `isSuffixOf`) <$> getDirectoryContents fp 61 | 62 | -- | Find the local package database in @dist-newstyle@. 63 | findLocalPackageDb :: MaybeT IO FilePath 64 | findLocalPackageDb = do 65 | projectRoot <- findCabalProjectRoot 66 | let 67 | relDir = "dist-newstyle" "packagedb" ("ghc-" ++ compilerVersionStr) 68 | absDir = projectRoot relDir 69 | ifM 70 | (liftMaybeT (doesDirectoryExist absDir)) 71 | (return absDir) 72 | mzero 73 | 74 | -- | Are we running in a Nix shell? 75 | inNixShell :: IO Bool 76 | inNixShell = isJust <$> lookupEnv "IN_NIX_SHELL" 77 | 78 | -- | Are we running in a Nix build environment? 79 | inNixBuild :: IO Bool 80 | inNixBuild = isJust <$> lookupEnv "NIX_BUILD_TOP" 81 | 82 | getLocalCabalPackageDbArgs :: IO [String] 83 | getLocalCabalPackageDbArgs = do 84 | runMaybeT findLocalPackageDb >>= \case 85 | Nothing -> pure [] 86 | Just s -> pure ["-package-db", s] 87 | 88 | getLocalNixPackageDbArgs :: IO [String] 89 | getLocalNixPackageDbArgs = do 90 | pkgDb <- makeAbsolute ("dist" "package.conf.inplace") 91 | ifM 92 | (doesDirectoryExist pkgDb) 93 | (pure ["-package-db", pkgDb]) 94 | (pure []) 95 | 96 | -- | Get global package db; used in a NIX_SHELL context 97 | getGlobalPackageDb :: IO String 98 | getGlobalPackageDb = init <$> readProcess "ghc" ["--print-global-package-db"] "" 99 | 100 | -- | Get flags to be used when running in a Nix context (either in a build, or a 101 | -- shell). 102 | getNixGhciArgs :: IO [String] 103 | getNixGhciArgs = 104 | ifM inNixShell goShell (ifM inNixBuild goBuild (pure [])) 105 | where 106 | goShell = do 107 | globalPkgDb <- getGlobalPackageDb 108 | localPkgDbFlag <- getLocalCabalPackageDbArgs 109 | let globalDbFlag = ["-package-db", globalPkgDb] 110 | pure (defaultArgs ++ globalDbFlag ++ localPkgDbFlag) 111 | 112 | goBuild = do 113 | localDbFlag <- getLocalNixPackageDbArgs 114 | pure (defaultArgs ++ localDbFlag) 115 | 116 | defaultArgs = 117 | [ "-package-env", "-" 118 | 119 | -- Nix doesn't always expose the GHC library (_specifically_ the GHC lib) even 120 | -- if a package lists it as a dependency. This simply always exposes it as a 121 | -- workaround. 122 | , "-package", "ghc" 123 | ] 124 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | module Test.DocTest.Internal.Options where 7 | 8 | import Prelude () 9 | import Prelude.Compat 10 | 11 | import Control.DeepSeq (NFData) 12 | import Data.List.Compat 13 | import GHC.Generics (Generic) 14 | import Text.Read (readMaybe) 15 | 16 | import qualified Paths_doctest_parallel 17 | import Data.Version (showVersion) 18 | 19 | import GHC.Settings.Config as GHC 20 | 21 | import Test.DocTest.Internal.Location (Located (Located), Location) 22 | import Test.DocTest.Internal.Interpreter (ghc) 23 | import Test.DocTest.Internal.Logging (LogLevel(..)) 24 | import qualified Test.DocTest.Internal.Logging as Logging 25 | 26 | usage :: String 27 | usage = unlines [ 28 | "Usage:" 29 | , " doctest [ options ]... []..." 30 | , " doctest --help" 31 | , " doctest --version" 32 | , " doctest --info" 33 | , "" 34 | , "Options:" 35 | , " -jN number of threads to use" 36 | , " --log-level=LEVEL one of: debug, verbose, info, warning, error. Default: info." 37 | , " --ghc-arg=ARG pass argument to GHC when parsing, pass multiple times for multiple flags" 38 | , "† --implicit-module-import import module before testing it (default)" 39 | , "† --randomize-order randomize order in which tests are run" 40 | , "† --seed=N use a specific seed to randomize test order" 41 | , "† --preserve-it preserve the `it` variable between examples" 42 | , " --nix account for Nix build environments (default)" 43 | , " --quiet set log level to `Error`, shorthand for `--log-level=error`" 44 | , " --verbose set log level to `Verbose`, shorthand for `--log-level=verbose`" 45 | , " --debug set log level to `Debug`, shorthand for `--log-level=debug`" 46 | , " --help display this help and exit" 47 | , " --version output version information and exit" 48 | , " --info output machine-readable version information and exit" 49 | , "" 50 | , "Supported inverted options:" 51 | , " --no-nix" 52 | , "† --no-implicit-module-import" 53 | , "† --no-randomize-order (default)" 54 | , "† --no-preserve-it (default)" 55 | , "" 56 | , "Options marked with a dagger (†) can also be used to set module level options, using" 57 | , "an ANN pragma like this:" 58 | , "" 59 | , " {-# ANN module \"doctest-parallel: --no-randomize-order\" #-} " 60 | , "" 61 | ] 62 | 63 | version :: String 64 | version = showVersion Paths_doctest_parallel.version 65 | 66 | ghcVersion :: String 67 | ghcVersion = GHC.cProjectVersion 68 | 69 | versionInfo :: String 70 | versionInfo = unlines [ 71 | "doctest version " ++ version 72 | , "using version " ++ ghcVersion ++ " of the GHC API" 73 | , "using " ++ ghc 74 | ] 75 | 76 | info :: String 77 | info = "[ " ++ (intercalate "\n, " . map show $ [ 78 | ("version", version) 79 | , ("ghc_version", ghcVersion) 80 | , ("ghc", ghc) 81 | ]) ++ "\n]\n" 82 | 83 | data Result a 84 | = ResultStderr String 85 | | ResultStdout String 86 | | Result a 87 | deriving (Eq, Show, Functor) 88 | 89 | type Warning = String 90 | type ModuleName = String 91 | 92 | data Config = Config 93 | { cfgLogLevel :: LogLevel 94 | -- ^ Verbosity level. 95 | , cfgModules :: [ModuleName] 96 | -- ^ Module names to test. An empty list means "test all modules". 97 | , cfgThreads :: Maybe Int 98 | -- ^ Number of threads to use. Defaults to autodetection based on the number 99 | -- of cores. 100 | , cfgModuleConfig :: ModuleConfig 101 | -- ^ Options specific to modules 102 | , cfgNix :: Bool 103 | -- ^ Detect Nix build environment and try to make GHC aware of the local package 104 | -- being tested. 105 | , cfgGhcArgs :: [String] 106 | -- ^ Extra arguments passed to GHC when parsing 107 | } deriving (Show, Eq, Generic, NFData) 108 | 109 | data ModuleConfig = ModuleConfig 110 | { cfgPreserveIt :: Bool 111 | -- ^ Preserve the @it@ variable between examples (default: @False@) 112 | , cfgRandomizeOrder :: Bool 113 | -- ^ Randomize the order in which test cases in a module are run (default: @False@) 114 | , cfgSeed :: Maybe Int 115 | -- ^ Initialize random number generator used to randomize test cases when 116 | -- 'cfgRandomizeOrder' is set. If set to 'Nothing', a random seed is picked 117 | -- from a system RNG source on startup. 118 | , cfgImplicitModuleImport :: Bool 119 | -- ^ Import a module before testing it. Can be disabled to enabled to test 120 | -- non-exposed modules. 121 | } deriving (Show, Eq, Generic, NFData) 122 | 123 | defaultModuleConfig :: ModuleConfig 124 | defaultModuleConfig = ModuleConfig 125 | { cfgPreserveIt = False 126 | , cfgRandomizeOrder = False 127 | , cfgSeed = Nothing 128 | , cfgImplicitModuleImport = True 129 | } 130 | 131 | defaultConfig :: Config 132 | defaultConfig = Config 133 | { cfgModules = [] 134 | , cfgThreads = Nothing 135 | , cfgLogLevel = Info 136 | , cfgModuleConfig = defaultModuleConfig 137 | , cfgNix = True 138 | , cfgGhcArgs = [] 139 | } 140 | 141 | parseLocatedModuleOptions :: 142 | ModuleName -> 143 | ModuleConfig -> 144 | [Located String] -> 145 | Either (Location, String) ModuleConfig 146 | parseLocatedModuleOptions _modName modConfig [] = Right modConfig 147 | parseLocatedModuleOptions modName modConfig0 (Located loc o:os) = 148 | case parseModuleOption modConfig0 o of 149 | Nothing -> 150 | Left (loc, o) 151 | Just modConfig1 -> 152 | parseLocatedModuleOptions modName modConfig1 os 153 | 154 | parseModuleOption :: ModuleConfig -> String -> Maybe ModuleConfig 155 | parseModuleOption config arg = 156 | case arg of 157 | "--randomize-order" -> Just config{cfgRandomizeOrder=True} 158 | "--no-randomize-order" -> Just config{cfgRandomizeOrder=False} 159 | "--preserve-it" -> Just config{cfgPreserveIt=True} 160 | "--no-preserve-it" -> Just config{cfgPreserveIt=False} 161 | "--implicit-module-import" -> Just config{cfgImplicitModuleImport=True} 162 | "--no-implicit-module-import" -> Just config{cfgImplicitModuleImport=False} 163 | ('-':_) | Just n <- parseSeed arg -> Just config{cfgSeed=Just n} 164 | _ -> Nothing 165 | 166 | parseOptions :: [String] -> Result Config 167 | parseOptions = fmap revGhcArgs . go defaultConfig 168 | where 169 | go config [] = Result config 170 | go config (arg:args) = 171 | case arg of 172 | "--help" -> ResultStdout usage 173 | "--info" -> ResultStdout info 174 | "--version" -> ResultStdout versionInfo 175 | "--quiet" -> go config{cfgLogLevel=Error} args 176 | "--verbose" -> go config{cfgLogLevel=Verbose} args 177 | "--debug" -> go config{cfgLogLevel=Debug} args 178 | "--nix" -> go config{cfgNix=True} args 179 | "--no-nix" -> go config{cfgNix=False} args 180 | ('-':_) | Just n <- parseThreads arg -> go config{cfgThreads=Just n} args 181 | ('-':_) | Just l <- parseLogLevel arg -> go config{cfgLogLevel=l} args 182 | ('-':_) | Just a <- parseGhcArg arg -> go (addGhcArg a config) args 183 | ('-':_) 184 | -- Module specific configuration options 185 | | Just modCfg <- parseModuleOption (cfgModuleConfig config) arg 186 | -> go config{cfgModuleConfig=modCfg} args 187 | ('-':_) -> ResultStderr ("Unknown command line argument: " <> arg) 188 | mod_ -> go config{cfgModules=mod_ : cfgModules config} args 189 | 190 | addGhcArg :: String -> Config -> Config 191 | addGhcArg arg Config{..} = Config{cfgGhcArgs=arg:cfgGhcArgs, ..} 192 | 193 | revGhcArgs :: Config -> Config 194 | revGhcArgs Config{..} = Config{cfgGhcArgs=reverse cfgGhcArgs, ..} 195 | 196 | -- | Parse ghc-arg argument 197 | -- 198 | -- >>> parseGhcArg "--ghc-arg=foobar" 199 | -- Just "foobar" 200 | 201 | -- >>> parseGhcArg "--ghc-arg=-DFOO=3" 202 | -- Just "-DFOO=3" 203 | -- 204 | parseGhcArg :: String -> Maybe String 205 | parseGhcArg arg = parseSpecificFlag arg "ghc-arg" 206 | 207 | -- | Parse seed argument 208 | -- 209 | -- >>> parseSeed "--seed=6" 210 | -- Just 6 211 | -- >>> parseSeed "--seeeed=6" 212 | -- Nothing 213 | -- 214 | parseSeed :: String -> Maybe Int 215 | parseSeed arg = readMaybe =<< parseSpecificFlag arg "seed" 216 | 217 | -- | Parse seed argument 218 | -- 219 | -- >>> parseLogLevel "--log-level=Debug" 220 | -- Just Debug 221 | -- >>> parseLogLevel "--log-level=debug" 222 | -- Just Debug 223 | -- >>> parseSeed "---log-level=debug" 224 | -- Nothing 225 | parseLogLevel :: String -> Maybe LogLevel 226 | parseLogLevel arg = Logging.parseLogLevel =<< parseSpecificFlag arg "log-level" 227 | 228 | -- | Parse number of threads argument 229 | -- 230 | -- >>> parseThreads "-j6" 231 | -- Just 6 232 | -- >>> parseThreads "-j-2" 233 | -- Nothing 234 | -- >>> parseThreads "-jA" 235 | -- Nothing 236 | -- 237 | parseThreads :: String -> Maybe Int 238 | parseThreads ('-':'j':n0) = do 239 | n1 <- readMaybe n0 240 | if n1 > 0 then Just n1 else Nothing 241 | parseThreads _ = Nothing 242 | 243 | -- | Parse a specific flag with a value, or return 'Nothing' 244 | -- 245 | -- >>> parseSpecificFlag "--foo" "foo" 246 | -- Nothing 247 | -- >>> parseSpecificFlag "--foo=" "foo" 248 | -- Nothing 249 | -- >>> parseSpecificFlag "--foo=5" "foo" 250 | -- Just "5" 251 | -- >>> parseSpecificFlag "--foo=5" "bar" 252 | -- Nothing 253 | parseSpecificFlag :: String -> String -> Maybe String 254 | parseSpecificFlag arg flag = do 255 | case parseFlag arg of 256 | ('-':'-':f, value) | f == flag -> value 257 | _ -> Nothing 258 | 259 | -- | Parse a flag into its flag and argument component. 260 | -- 261 | -- Example: 262 | -- 263 | -- >>> parseFlag "--optghc=foo" 264 | -- ("--optghc",Just "foo") 265 | -- >>> parseFlag "--optghc=" 266 | -- ("--optghc",Nothing) 267 | -- >>> parseFlag "--fast" 268 | -- ("--fast",Nothing) 269 | parseFlag :: String -> (String, Maybe String) 270 | parseFlag arg = 271 | case break (== '=') arg of 272 | (flag, ['=']) -> (flag, Nothing) 273 | (flag, '=':opt) -> (flag, Just opt) 274 | (flag, _) -> (flag, Nothing) 275 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Test.DocTest.Internal.Parse ( 5 | Module (..) 6 | , DocTest (..) 7 | , Interaction 8 | , Expression 9 | , ExpectedResult 10 | , ExpectedLine (..) 11 | , LineChunk (..) 12 | , getDocTests 13 | , getDocTestsIO 14 | 15 | -- * exported for testing 16 | , parseInteractions 17 | , parseProperties 18 | , mkLineChunks 19 | ) where 20 | 21 | import Data.Char (isSpace) 22 | import Data.List 23 | import Data.Maybe 24 | import Data.String 25 | 26 | import Test.DocTest.Internal.Extract 27 | import Test.DocTest.Internal.GhcUtil (withGhc) 28 | import Test.DocTest.Internal.Location 29 | import GHC (Ghc) 30 | 31 | 32 | data DocTest = Example Expression ExpectedResult | Property Expression 33 | deriving (Eq, Show) 34 | 35 | data LineChunk = LineChunk String | WildCardChunk 36 | deriving (Show, Eq) 37 | 38 | instance IsString LineChunk where 39 | fromString = LineChunk 40 | 41 | data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine 42 | deriving (Show, Eq) 43 | 44 | instance IsString ExpectedLine where 45 | fromString = ExpectedLine . return . LineChunk 46 | 47 | type Expression = String 48 | type ExpectedResult = [ExpectedLine] 49 | 50 | type Interaction = (Expression, ExpectedResult) 51 | 52 | -- | Extract 'DocTest's from given module 53 | getDocTestsIO :: [String] -> String -> IO (Module [Located DocTest]) 54 | getDocTestsIO parseArgs mod_ = withGhc parseArgs $ parseModule <$> extract mod_ 55 | 56 | -- | Extract 'DocTest's from given module 57 | getDocTests :: String -> Ghc (Module [Located DocTest]) 58 | getDocTests mod_ = parseModule <$> extract mod_ 59 | 60 | -- | Convert documentation to `Example`s. 61 | parseModule :: Module (Located String) -> Module [Located DocTest] 62 | parseModule m = 63 | case parseComment <$> m of 64 | Module name setup tests cfg -> 65 | Module name setup_ (filter (not . null) tests) cfg 66 | where 67 | setup_ = case setup of 68 | Just [] -> Nothing 69 | _ -> setup 70 | 71 | parseComment :: Located String -> [Located DocTest] 72 | parseComment c = properties ++ examples 73 | where 74 | examples = map (fmap $ uncurry Example) (parseInteractions c) 75 | properties = map (fmap Property) (parseProperties c) 76 | 77 | -- | Extract all properties from given Haddock comment. 78 | parseProperties :: Located String -> [Located Expression] 79 | parseProperties (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) 80 | where 81 | isPrompt :: Located String -> Bool 82 | isPrompt = isPrefixOf "prop>" . dropWhile isSpace . unLoc 83 | 84 | go xs = case dropWhile (not . isPrompt) xs of 85 | prop:rest -> stripPrompt `fmap` prop : go rest 86 | [] -> [] 87 | 88 | stripPrompt = strip . drop 5 . dropWhile isSpace 89 | 90 | -- | Extract all interactions from given Haddock comment. 91 | parseInteractions :: Located String -> [Located Interaction] 92 | parseInteractions (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) 93 | where 94 | isPrompt :: Located String -> Bool 95 | isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc 96 | 97 | isBlankLine :: Located String -> Bool 98 | isBlankLine = null . dropWhile isSpace . unLoc 99 | 100 | isEndOfInteraction :: Located String -> Bool 101 | isEndOfInteraction x = isPrompt x || isBlankLine x 102 | 103 | 104 | go :: [Located String] -> [Located Interaction] 105 | go xs = case dropWhile (not . isPrompt) xs of 106 | prompt:rest 107 | | ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))), 108 | (ys,zs) <- break isBlankLine rest -> 109 | toInteraction prompt ys : go zs 110 | 111 | | otherwise -> 112 | let 113 | (ys,zs) = break isEndOfInteraction rest 114 | in 115 | toInteraction prompt ys : go zs 116 | [] -> [] 117 | 118 | -- | Create an `Interaction`, strip superfluous whitespace as appropriate. 119 | -- 120 | -- also merge lines between :{ and :}, preserving whitespace inside 121 | -- the block (since this is useful for avoiding {;}). 122 | toInteraction :: Located String -> [Located String] -> Located Interaction 123 | toInteraction (Located loc x) xs = Located loc $ 124 | ( 125 | (strip cleanedE) -- we do not care about leading and trailing 126 | -- whitespace in expressions, so drop them 127 | , map mkExpectedLine result_ 128 | ) 129 | where 130 | -- 1. drop trailing whitespace from the prompt, remember the prefix 131 | (prefix, e) = span isSpace x 132 | (ePrompt, eRest) = splitAt 3 e 133 | 134 | -- 2. drop, if possible, the exact same sequence of whitespace 135 | -- characters from each result line 136 | unindent pre = map (tryStripPrefix pre . unLoc) 137 | 138 | cleanBody line = fromMaybe (unLoc line) 139 | (stripPrefix ePrompt (dropWhile isSpace (unLoc line))) 140 | 141 | (cleanedE, result_) 142 | | (body , endLine : rest) <- break 143 | ( (==) [":}"] . take 1 . words . cleanBody) 144 | xs 145 | = (unlines (eRest : map cleanBody body ++ 146 | [dropWhile isSpace (cleanBody endLine)]), 147 | unindent (takeWhile isSpace (unLoc endLine)) rest) 148 | | otherwise = (eRest, unindent prefix xs) 149 | 150 | 151 | tryStripPrefix :: String -> String -> String 152 | tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys 153 | 154 | mkExpectedLine :: String -> ExpectedLine 155 | mkExpectedLine x = case x of 156 | "" -> "" 157 | "..." -> WildCardLine 158 | _ -> ExpectedLine $ mkLineChunks x 159 | 160 | mkLineChunks :: String -> [LineChunk] 161 | mkLineChunks = finish . foldr go (0, [], []) 162 | where 163 | mkChunk :: String -> [LineChunk] 164 | mkChunk "" = [] 165 | mkChunk x = [LineChunk x] 166 | 167 | go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk]) 168 | go '.' (count, acc, res) = if count == 2 169 | then (0, "", WildCardChunk : mkChunk acc ++ res) 170 | else (count + 1, acc, res) 171 | go c (count, acc, res) = if count > 0 172 | then (0, c : replicate count '.' ++ acc, res) 173 | else (0, c : acc, res) 174 | finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res 175 | 176 | 177 | -- | Remove leading and trailing whitespace. 178 | strip :: String -> String 179 | strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse 180 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | 3 | module Test.DocTest.Internal.Property where 4 | 5 | import Data.List 6 | import Data.Maybe 7 | import Data.Foldable 8 | 9 | import Test.DocTest.Internal.Util 10 | import Test.DocTest.Internal.Interpreter (Interpreter) 11 | import qualified Test.DocTest.Internal.Interpreter as Interpreter 12 | import Test.DocTest.Internal.Parse 13 | 14 | -- | The result of evaluating an interaction. 15 | data PropertyResult = 16 | Success 17 | | Failure String 18 | | Error String 19 | deriving (Eq, Show) 20 | 21 | runProperty :: Interpreter -> Expression -> IO PropertyResult 22 | runProperty repl expression = do 23 | _ <- Interpreter.safeEval repl "import Test.QuickCheck ((==>))" 24 | _ <- Interpreter.safeEval repl "import Test.QuickCheck.All (polyQuickCheck)" 25 | _ <- Interpreter.safeEval repl "import Language.Haskell.TH (mkName)" 26 | _ <- Interpreter.safeEval repl ":set -XTemplateHaskell" 27 | r <- freeVariables repl expression >>= 28 | (Interpreter.safeEval repl . quickCheck expression) 29 | case r of 30 | Left err -> do 31 | return (Error err) 32 | Right res 33 | | "OK, passed" `isInfixOf` res -> return Success 34 | | otherwise -> do 35 | let msg = stripEnd (takeWhileEnd (/= '\b') res) 36 | return (Failure msg) 37 | where 38 | quickCheck term vars = 39 | "let doctest_prop " ++ unwords vars ++ " = " ++ term ++ "\n" ++ 40 | "$(polyQuickCheck (mkName \"doctest_prop\"))" 41 | 42 | -- | Find all free variables in given term. 43 | -- 44 | -- GHCi is used to detect free variables. 45 | freeVariables :: Interpreter -> String -> IO [String] 46 | freeVariables repl term = do 47 | r <- Interpreter.safeEval repl (":type " ++ term) 48 | return (either (const []) (nub . parseNotInScope) r) 49 | 50 | -- | Parse and return all variables that are not in scope from a ghc error 51 | -- message. 52 | parseNotInScope :: String -> [String] 53 | parseNotInScope = nub . mapMaybe extractVariable . lines 54 | where 55 | -- | Extract variable name from a "Not in scope"-error. 56 | extractVariable :: String -> Maybe String 57 | extractVariable x 58 | | "Not in scope: " `isInfixOf` x = Just . unquote . takeWhileEnd (/= ' ') $ x 59 | | Just y <- (asum $ map (stripPrefix "Variable not in scope: ") (tails x)) = Just (takeWhile (/= ' ') y) 60 | | otherwise = Nothing 61 | 62 | -- | Remove quotes from given name, if any. 63 | unquote ('`':xs) = init xs 64 | unquote ('\8216':xs) = init xs 65 | unquote xs = xs 66 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Runner/Example.hs: -------------------------------------------------------------------------------- 1 | module Test.DocTest.Internal.Runner.Example ( 2 | Result (..) 3 | , mkResult 4 | ) where 5 | 6 | import Data.Char 7 | import Data.List 8 | 9 | import Test.DocTest.Internal.Util 10 | import Test.DocTest.Internal.Parse 11 | 12 | maxBy :: (Ord a) => (b -> a) -> b -> b -> b 13 | maxBy f x y = case compare (f x) (f y) of 14 | LT -> y 15 | EQ -> x 16 | GT -> x 17 | 18 | data Result = Equal | NotEqual [String] 19 | deriving (Eq, Show) 20 | 21 | mkResult :: ExpectedResult -> [String] -> Result 22 | mkResult expected_ actual_ = 23 | case expected `matches` actual of 24 | Full -> Equal 25 | Partial partial -> NotEqual (formatNotEqual expected actual partial) 26 | where 27 | -- use show to escape special characters in output lines if any output line 28 | -- contains any unsafe character 29 | escapeOutput 30 | | any (not . isSafe) $ concat (expectedAsString ++ actual_) = init . drop 1 . show . stripEnd 31 | | otherwise = id 32 | 33 | actual :: [String] 34 | actual = fmap escapeOutput actual_ 35 | 36 | expected :: ExpectedResult 37 | expected = fmap (transformExcpectedLine escapeOutput) expected_ 38 | 39 | expectedAsString :: [String] 40 | expectedAsString = map (\x -> case x of 41 | ExpectedLine str -> concatMap lineChunkToString str 42 | WildCardLine -> "..." ) expected_ 43 | 44 | isSafe :: Char -> Bool 45 | isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) 46 | 47 | chunksMatch :: [LineChunk] -> String -> Match ChunksDivergence 48 | chunksMatch [] "" = Full 49 | chunksMatch [LineChunk xs] ys = 50 | if stripEnd xs == stripEnd ys 51 | then Full 52 | else Partial $ matchingPrefix xs ys 53 | chunksMatch (LineChunk x : xs) ys = 54 | if x `isPrefixOf` ys 55 | then fmap (prependText x) $ (xs `chunksMatch` drop (length x) ys) 56 | else Partial $ matchingPrefix x ys 57 | chunksMatch zs@(WildCardChunk : xs) (_:ys) = 58 | -- Prefer longer matches. 59 | fmap prependWildcard $ maxBy 60 | (fmap $ length . matchText) 61 | (chunksMatch xs ys) 62 | (chunksMatch zs ys) 63 | chunksMatch [WildCardChunk] [] = Full 64 | chunksMatch (WildCardChunk:_) [] = Partial (ChunksDivergence "" "") 65 | chunksMatch [] (_:_) = Partial (ChunksDivergence "" "") 66 | 67 | matchingPrefix xs ys = 68 | let common = fmap fst (takeWhile (\(x, y) -> x == y) (xs `zip` ys)) in 69 | ChunksDivergence common common 70 | 71 | matches :: ExpectedResult -> [String] -> Match LinesDivergence 72 | matches (ExpectedLine x : xs) (y : ys) = 73 | case x `chunksMatch` y of 74 | Full -> fmap incLineNo $ xs `matches` ys 75 | Partial partial -> Partial (LinesDivergence 1 (expandedWildcards partial)) 76 | matches zs@(WildCardLine : xs) us@(_ : ys) = 77 | -- Prefer longer matches, and later ones of equal length. 78 | let matchWithoutWC = xs `matches` us in 79 | let matchWithWC = fmap incLineNo (zs `matches` ys) in 80 | let key (LinesDivergence lineNo line) = (length line, lineNo) in 81 | maxBy (fmap key) matchWithoutWC matchWithWC 82 | matches [WildCardLine] [] = Full 83 | matches [] [] = Full 84 | matches [] _ = Partial (LinesDivergence 1 "") 85 | matches _ [] = Partial (LinesDivergence 1 "") 86 | 87 | -- Note: order of constructors matters, so that full matches sort as 88 | -- greater than partial. 89 | data Match a = Partial a | Full 90 | deriving (Eq, Ord, Show) 91 | 92 | instance Functor Match where 93 | fmap f (Partial a) = Partial (f a) 94 | fmap _ Full = Full 95 | 96 | data ChunksDivergence = ChunksDivergence { matchText :: String, expandedWildcards :: String } 97 | deriving (Show) 98 | 99 | prependText :: String -> ChunksDivergence -> ChunksDivergence 100 | prependText s (ChunksDivergence mt wct) = ChunksDivergence (s++mt) (s++wct) 101 | 102 | prependWildcard :: ChunksDivergence -> ChunksDivergence 103 | prependWildcard (ChunksDivergence mt wct) = ChunksDivergence mt ('.':wct) 104 | 105 | data LinesDivergence = LinesDivergence { _mismatchLineNo :: Int, _partialLine :: String } 106 | deriving (Show) 107 | 108 | incLineNo :: LinesDivergence -> LinesDivergence 109 | incLineNo (LinesDivergence lineNo partialLineMatch) = LinesDivergence (lineNo + 1) partialLineMatch 110 | 111 | formatNotEqual :: ExpectedResult -> [String] -> LinesDivergence -> [String] 112 | formatNotEqual expected_ actual partial = formatLines "expected: " expected ++ formatLines " but got: " (lineMarker wildcard partial actual) 113 | where 114 | expected :: [String] 115 | expected = map (\x -> case x of 116 | ExpectedLine str -> concatMap lineChunkToString str 117 | WildCardLine -> "..." ) expected_ 118 | 119 | formatLines :: String -> [String] -> [String] 120 | formatLines message xs = case xs of 121 | y:ys -> (message ++ y) : map (padding ++) ys 122 | [] -> [message] 123 | where 124 | padding = replicate (length message) ' ' 125 | 126 | wildcard :: Bool 127 | wildcard = any (\x -> case x of 128 | ExpectedLine xs -> any (\y -> case y of { WildCardChunk -> True; _ -> False }) xs 129 | WildCardLine -> True ) expected_ 130 | 131 | lineChunkToString :: LineChunk -> String 132 | lineChunkToString WildCardChunk = "..." 133 | lineChunkToString (LineChunk str) = str 134 | 135 | transformExcpectedLine :: (String -> String) -> ExpectedLine -> ExpectedLine 136 | transformExcpectedLine f (ExpectedLine xs) = 137 | ExpectedLine $ fmap (\el -> case el of 138 | LineChunk s -> LineChunk $ f s 139 | WildCardChunk -> WildCardChunk 140 | ) xs 141 | transformExcpectedLine _ WildCardLine = WildCardLine 142 | 143 | lineMarker :: Bool -> LinesDivergence -> [String] -> [String] 144 | lineMarker wildcard (LinesDivergence row expanded) actual = 145 | let (pre, post) = splitAt row actual in 146 | pre ++ 147 | [(if wildcard && length expanded > 30 148 | -- show expanded pattern if match is long, to help understanding what matched what 149 | then expanded 150 | else replicate (length expanded) ' ') ++ "^"] ++ 151 | post 152 | -------------------------------------------------------------------------------- /src/Test/DocTest/Internal/Util.hs: -------------------------------------------------------------------------------- 1 | module Test.DocTest.Internal.Util where 2 | 3 | import Data.Char 4 | 5 | convertDosLineEndings :: String -> String 6 | convertDosLineEndings = go 7 | where 8 | go input = case input of 9 | '\r':'\n':xs -> '\n' : go xs 10 | 11 | -- Haddock comments from source files with dos line endings end with a 12 | -- CR, so we strip that, too. 13 | "\r" -> "" 14 | 15 | x:xs -> x : go xs 16 | "" -> "" 17 | 18 | -- | Return the longest suffix of elements that satisfy a given predicate. 19 | takeWhileEnd :: (a -> Bool) -> [a] -> [a] 20 | takeWhileEnd p = reverse . takeWhile p . reverse 21 | 22 | -- | Remove trailing white space from a string. 23 | -- 24 | -- >>> stripEnd "foo " 25 | -- "foo" 26 | stripEnd :: String -> String 27 | stripEnd = reverse . dropWhile isSpace . reverse 28 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: 2 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/04.yaml 3 | 4 | packages: 5 | - . 6 | -------------------------------------------------------------------------------- /test/ExtractSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module ExtractSpec (main, spec) where 5 | 6 | import Test.Hspec 7 | import Test.HUnit 8 | 9 | import GHC.Utils.Panic (GhcException (..)) 10 | 11 | import Test.DocTest.Internal.Extract 12 | import Test.DocTest.Internal.Location 13 | import System.FilePath 14 | 15 | 16 | shouldGive :: HasCallStack => (String, String) -> Module String -> Assertion 17 | (d, m) `shouldGive` expected = do 18 | r <- fmap unLoc `fmap` extractIO ["-i" ++ dir] m 19 | eraseConfigLocation r `shouldBe` eraseConfigLocation expected 20 | where 21 | dir = "test/extract" d 22 | 23 | main :: IO () 24 | main = hspec spec 25 | 26 | spec :: Spec 27 | spec = do 28 | let mod_ nm content = Module nm Nothing content [] 29 | 30 | describe "extract" $ do 31 | it "extracts documentation for a top-level declaration" $ do 32 | ("declaration", "Foo") `shouldGive` mod_ "Foo" [" Some documentation"] 33 | 34 | it "extracts documentation from argument list" $ do 35 | ("argument-list", "Foo") `shouldGive` mod_ "Foo" [" doc for arg1", " doc for arg2"] 36 | 37 | it "extracts documentation for a type class function" $ do 38 | ("type-class", "Foo") `shouldGive` mod_ "Foo" [" Convert given value to a string."] 39 | 40 | it "extracts documentation from the argument list of a type class function" $ do 41 | ("type-class-args", "Foo") `shouldGive` mod_ "Foo" [" foo", " bar"] 42 | 43 | it "extracts documentation from the module header" $ do 44 | ("module-header", "Foo") `shouldGive` mod_ "Foo" [" Some documentation"] 45 | 46 | it "does not extract documentation from imported modules" $ do 47 | ("imported-module", "Bar") `shouldGive` mod_ "Bar" [" documentation for bar"] 48 | 49 | it "extracts documentation from export list" $ do 50 | ("export-list", "Foo") `shouldGive` mod_ "Foo" [" documentation from export list"] 51 | 52 | it "extracts documentation from named chunks" $ do 53 | ("named-chunks", "Foo") `shouldGive` mod_ "Foo" [" named chunk foo", "\n named chunk bar"] 54 | 55 | it "returns docstrings in the same order they appear in the source" $ do 56 | ("comment-order", "Foo") `shouldGive` mod_ "Foo" [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"] 57 | 58 | it "extracts $setup code" $ do 59 | ("setup", "Foo") `shouldGive` (mod_ "Foo" [" foo", " bar", " baz"]){moduleSetup=Just "\n some setup code"} 60 | 61 | it "fails on invalid flags" $ do 62 | extractIO ["--foobar"] "test/Foo.hs" `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False) 63 | 64 | describe "extract (regression tests)" $ do 65 | it "works with infix operators" $ do 66 | ("regression", "Fixity") `shouldGive` mod_ "Fixity" [] 67 | 68 | it "works with parallel list comprehensions" $ do 69 | ("regression", "ParallelListComp") `shouldGive` mod_ "ParallelListComp" [] 70 | 71 | it "works with list comprehensions in instance definitions" $ do 72 | ("regression", "ParallelListCompClass") `shouldGive` mod_ "ParallelListCompClass" [] 73 | 74 | it "works with foreign imports" $ do 75 | ("regression", "ForeignImport") `shouldGive` mod_ "ForeignImport" [] 76 | 77 | it "works for rewrite rules" $ do 78 | ("regression", "RewriteRules") `shouldGive` mod_ "RewriteRules" [" doc for foo"] 79 | 80 | it "works for rewrite rules with type signatures" $ do 81 | ("regression", "RewriteRulesWithSigs") `shouldGive` mod_ "RewriteRulesWithSigs" [" doc for foo"] 82 | 83 | it "strips CR from dos line endings" $ do 84 | ("dos-line-endings", "Foo") `shouldGive` mod_ "Foo" ["\n foo\n bar\n baz"] 85 | 86 | it "works with a module that splices in an expression from an other module" $ do 87 | ("th", "Foo") `shouldGive` mod_ "Foo" [" some documentation"] 88 | 89 | it "works for type families and GHC 7.6.1" $ do 90 | ("type-families", "Foo") `shouldGive` mod_ "Foo" [] 91 | 92 | it "ignores binder annotations" $ do 93 | ("module-options", "Binders") `shouldGive` mod_ "Binders" [] 94 | 95 | it "ignores module annotations that don't start with 'doctest-parallel:'" $ do 96 | ("module-options", "NoOptions") `shouldGive` mod_ "NoOptions" [] 97 | 98 | it "detects monomorphic module settings" $ do 99 | ("module-options", "Mono") `shouldGive` (mod_ "Mono" []){moduleConfig= 100 | [ noLocation "--no-randomize-error1" 101 | , noLocation "--no-randomize-error2" 102 | , noLocation "--no-randomize-error3" 103 | , noLocation "--no-randomize-error4" 104 | , noLocation "--no-randomize-error5" 105 | , noLocation "--no-randomize-error6" 106 | ]} 107 | 108 | it "detects polypormphic module settings" $ do 109 | ("module-options", "Poly") `shouldGive` (mod_ "Poly" []){moduleConfig= 110 | [ noLocation "--no-randomize-error" 111 | ]} 112 | -------------------------------------------------------------------------------- /test/GhciWrapperSpec.hs: -------------------------------------------------------------------------------- 1 | module GhciWrapperSpec (main, spec) where 2 | 3 | import Test.Hspec 4 | import System.IO.Silently 5 | 6 | import Control.Exception 7 | import Data.List (isInfixOf, isPrefixOf) 8 | 9 | import Test.DocTest.Internal.GhciWrapper (Interpreter, Config(..), defaultConfig) 10 | import qualified Test.DocTest.Internal.GhciWrapper as Interpreter 11 | import Test.DocTest.Internal.Logging (noLogger) 12 | 13 | main :: IO () 14 | main = hspec spec 15 | 16 | withInterpreterConfig :: Config -> (Interpreter -> IO a) -> IO a 17 | withInterpreterConfig config = bracket (Interpreter.new noLogger config []) Interpreter.close 18 | 19 | withInterpreter :: ((String -> IO String) -> IO a) -> IO a 20 | withInterpreter action = withInterpreterConfig defaultConfig $ action . Interpreter.eval 21 | 22 | spec :: Spec 23 | spec = do 24 | describe "evalEcho" $ do 25 | it "prints result to stdout" $ do 26 | withInterpreterConfig defaultConfig $ \ghci -> do 27 | (capture $ Interpreter.evalEcho ghci ("putStr" ++ show "foo\nbar")) `shouldReturn` ("foo\nbar", "foo\nbar") 28 | 29 | describe "evalIt" $ do 30 | it "preserves it" $ do 31 | withInterpreterConfig defaultConfig $ \ghci -> do 32 | Interpreter.evalIt ghci "23" `shouldReturn` "23\n" 33 | Interpreter.eval ghci "it" `shouldReturn` "23\n" 34 | 35 | describe "eval" $ do 36 | it "shows literals" $ withInterpreter $ \ghci -> do 37 | ghci "23" `shouldReturn` "23\n" 38 | 39 | it "shows string literals containing Unicode" $ withInterpreter $ \ghci -> do 40 | ghci "\"λ\"" `shouldReturn` "\"\\955\"\n" 41 | 42 | it "evaluates simple expressions" $ withInterpreter $ \ghci -> do 43 | ghci "23 + 42" `shouldReturn` "65\n" 44 | 45 | it "supports let bindings" $ withInterpreter $ \ghci -> do 46 | ghci "let x = 10" `shouldReturn` "" 47 | ghci "x" `shouldReturn` "10\n" 48 | 49 | it "allows import statements" $ withInterpreter $ \ghci -> do 50 | ghci "import Data.Maybe" `shouldReturn` "" 51 | ghci "fromJust (Just 20)" `shouldReturn` "20\n" 52 | 53 | it "captures stdout" $ withInterpreter $ \ghci -> do 54 | ghci "putStr \"foo\"" `shouldReturn` "foo" 55 | 56 | it "captures stdout (Unicode)" $ withInterpreter $ \ghci -> do 57 | ghci "putStrLn \"λ\"" `shouldReturn` "λ\n" 58 | 59 | it "captures stdout (empty line)" $ withInterpreter $ \ghci -> do 60 | ghci "putStrLn \"\"" `shouldReturn` "\n" 61 | 62 | it "captures stdout (multiple lines)" $ withInterpreter $ \ghci -> do 63 | ghci "putStrLn \"foo\" >> putStrLn \"bar\" >> putStrLn \"baz\"" 64 | `shouldReturn` "foo\nbar\nbaz\n" 65 | 66 | it "captures stderr" $ withInterpreter $ \ghci -> do 67 | ghci "import System.IO" `shouldReturn` "" 68 | ghci "hPutStrLn stderr \"foo\"" `shouldReturn` "foo\n" 69 | 70 | it "captures stderr (Unicode)" $ withInterpreter $ \ghci -> do 71 | ghci "import System.IO" `shouldReturn` "" 72 | ghci "hPutStrLn stderr \"λ\"" `shouldReturn` "λ\n" 73 | 74 | it "shows exceptions" $ withInterpreter $ \ghci -> do 75 | ghci "import Control.Exception" `shouldReturn` "" 76 | res <- ghci "throwIO DivideByZero" 77 | res `shouldSatisfy` isPrefixOf "*** Exception: divide by zero\n" 78 | 79 | it "shows exceptions (ExitCode)" $ withInterpreter $ \ghci -> do 80 | ghci "import System.Exit" `shouldReturn` "" 81 | ghci "exitWith $ ExitFailure 10" `shouldReturn` "*** Exception: ExitFailure 10\n" 82 | 83 | it "gives an error message for identifiers that are not in scope" $ withInterpreter $ \ghci -> do 84 | ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo") 85 | context "when configVerbose is True" $ do 86 | it "prints prompt" $ do 87 | withInterpreterConfig defaultConfig{configVerbose = True} $ \ghci -> do 88 | Interpreter.eval ghci "print 23" >>= (`shouldSatisfy` 89 | (`elem` [ "Prelude> 23\nPrelude> " 90 | , "ghci> 23\nghci> " 91 | ])) 92 | 93 | context "with -XOverloadedStrings, -Wall and -Werror" $ do 94 | it "does not fail on marker expression (bug fix)" $ withInterpreter $ \ghci -> do 95 | ghci ":set -XOverloadedStrings -Wall -Werror" `shouldReturn` "" 96 | ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" 97 | 98 | context "with NoImplicitPrelude" $ do 99 | it "works" $ withInterpreter $ \ghci -> do 100 | ghci ":set -XNoImplicitPrelude" `shouldReturn` "" 101 | ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" 102 | 103 | context "with a strange String type" $ do 104 | it "works" $ withInterpreter $ \ghci -> do 105 | ghci "type String = Int" `shouldReturn` "" 106 | ghci "putStrLn \"foo\"" `shouldReturn` "foo\n" 107 | -------------------------------------------------------------------------------- /test/InterpreterSpec.hs: -------------------------------------------------------------------------------- 1 | module InterpreterSpec (main, spec) where 2 | 3 | import Prelude () 4 | import Prelude.Compat 5 | 6 | import Test.Hspec 7 | 8 | import qualified Test.DocTest.Internal.Interpreter as Interpreter 9 | import Test.DocTest.Internal.Interpreter 10 | (haveInterpreterKey, ghcInfo, withInterpreter) 11 | import Test.DocTest.Internal.Logging (noLogger) 12 | 13 | main :: IO () 14 | main = hspec spec 15 | 16 | spec :: Spec 17 | spec = do 18 | describe "interpreterSupported" $ do 19 | it "indicates whether GHCi is supported on current platform" $ do 20 | (Interpreter.interpreterSupported >> return ()) `shouldReturn` () 21 | 22 | describe "ghcInfo" $ do 23 | it ("includes " ++ show haveInterpreterKey) $ do 24 | info <- ghcInfo 25 | lookup haveInterpreterKey info `shouldSatisfy` 26 | (||) <$> (== Just "YES") <*> (== Just "NO") 27 | 28 | describe "safeEval" $ do 29 | it "evaluates an expression" $ withInterpreter noLogger [] $ \ghci -> do 30 | Interpreter.safeEval ghci "23 + 42" `shouldReturn` Right "65\n" 31 | 32 | it "returns Left on unterminated multiline command" $ withInterpreter noLogger [] $ \ghci -> do 33 | Interpreter.safeEval ghci ":{\n23 + 42" `shouldReturn` Left "unterminated multiline command" 34 | -------------------------------------------------------------------------------- /test/LocationSpec.hs: -------------------------------------------------------------------------------- 1 | module LocationSpec (main, spec) where 2 | 3 | import Test.Hspec 4 | 5 | import Test.DocTest.Internal.Location 6 | 7 | import GHC.Types.SrcLoc 8 | import GHC.Data.FastString (fsLit) 9 | 10 | main :: IO () 11 | main = hspec spec 12 | 13 | spec :: Spec 14 | spec = do 15 | 16 | describe "toLocation" $ do 17 | 18 | it "works for a regular SrcSpan" $ do 19 | toLocation (mkSrcSpan (mkSrcLoc (fsLit "Foo.hs") 2 5) (mkSrcLoc (fsLit "Foo.hs") 10 20)) 20 | `shouldBe` Location "Foo.hs" 2 21 | 22 | it "works for a single-line SrcSpan" $ do 23 | toLocation (mkSrcSpan (mkSrcLoc (fsLit "Foo.hs") 2 5) (mkSrcLoc (fsLit "Foo.hs") 2 10)) 24 | `shouldBe` Location "Foo.hs" 2 25 | 26 | it "works for a SrcSpan that corresponds to single point" $ do 27 | (toLocation . srcLocSpan) (mkSrcLoc (fsLit "Foo.hs") 10 20) 28 | `shouldBe` Location "Foo.hs" 10 29 | 30 | it "works for a bad SrcSpan" $ do 31 | toLocation noSrcSpan `shouldBe` UnhelpfulLocation "" 32 | 33 | it "works for a SrcLoc with bad locations" $ do 34 | toLocation (mkSrcSpan noSrcLoc noSrcLoc) 35 | `shouldBe` UnhelpfulLocation "" 36 | 37 | describe "enumerate" $ do 38 | it "replicates UnhelpfulLocation" $ do 39 | let loc = UnhelpfulLocation "foo" 40 | (take 10 $ enumerate loc) `shouldBe` replicate 10 loc 41 | 42 | it "enumerates Location" $ do 43 | let loc = Location "Foo.hs" 23 44 | (take 3 $ enumerate loc) `shouldBe` [Location "Foo.hs" 23, Location "Foo.hs" 24, Location "Foo.hs" 25] 45 | -------------------------------------------------------------------------------- /test/MainSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | 5 | module MainSpec where 6 | 7 | import Test.Hspec 8 | import Test.HUnit (assertEqual, Assertion) 9 | 10 | import qualified Data.Map as Map 11 | import qualified Test.DocTest as DocTest 12 | import Test.DocTest.Helpers (extractSpecificCabalLibrary, findCabalPackage) 13 | import Test.DocTest.Internal.Options 14 | import Test.DocTest.Internal.Runner 15 | import System.Environment (getEnvironment) 16 | import System.IO.Silently 17 | import System.IO 18 | 19 | -- | Construct a doctest specific 'Assertion'. 20 | doctest :: HasCallStack => [ModuleName] -> Summary -> Assertion 21 | doctest = doctestWithOpts defaultConfig 22 | 23 | doctestWithOpts :: HasCallStack => Config -> [ModuleName] -> Summary -> Assertion 24 | doctestWithOpts config modNames expected = do 25 | pkg <- findCabalPackage "doctest-parallel" 26 | lib <- extractSpecificCabalLibrary (Just "spectests-modules") pkg 27 | actual <- 28 | hSilence [stderr] $ 29 | DocTest.run lib config{cfgModules=modNames} 30 | assertEqual (show modNames) expected actual 31 | 32 | cases :: Int -> Summary 33 | cases n = Summary n n 0 0 34 | 35 | main :: IO () 36 | main = hspec spec 37 | 38 | spec :: Spec 39 | spec = do 40 | env <- Map.fromList <$> runIO getEnvironment 41 | 42 | let 43 | cDescribe = 44 | if 45 | -- Don't run doctests as part of the Stack testsuite yet, pending 46 | -- https://github.com/commercialhaskell/stack/issues/5662 47 | | "STACK_EXE" `Map.member` env -> xdescribe 48 | 49 | -- Don't run doctests as part of a Nix build. Similar to Stack, Nix 50 | -- doesn't seem to deal with private libraries yet. 51 | | "NIX_BUILD_TOP" `Map.member` env -> xdescribe 52 | 53 | | otherwise -> describe 54 | 55 | cDescribe "doctest" $ do 56 | it "testSimple" $ 57 | doctest ["TestSimple.Fib"] 58 | (cases 1) 59 | 60 | it "it-variable" $ do 61 | doctestWithOpts (defaultConfig{cfgModuleConfig=defaultModuleConfig{cfgPreserveIt=True}}) ["It.Foo"] 62 | (cases 5) 63 | 64 | it "it-variable in $setup" $ do 65 | doctestWithOpts (defaultConfig{cfgModuleConfig=defaultModuleConfig{cfgPreserveIt=True}}) ["It.Setup"] 66 | (cases 2) 67 | 68 | it "failing" $ do 69 | doctest ["Failing.Foo"] 70 | (cases 1) {sFailures = 1} 71 | 72 | it "skips subsequent examples from the same group if an example fails" $ 73 | doctest ["FailingMultiple.Foo"] 74 | (cases 4) {sTried = 2, sFailures = 1} 75 | 76 | it "use -DFIB=fib to set CPP flag" $ 77 | doctestWithOpts defaultConfig{cfgGhcArgs=["-DFIB=fib"]} ["GhcArg.Fib"] 78 | (cases 1) 79 | 80 | it "testImport" $ do 81 | doctest ["TestImport.ModuleA"] 82 | (cases 2) 83 | 84 | it "testCommentLocation" $ do 85 | doctest ["TestCommentLocation.Foo"] 86 | (cases 11) 87 | 88 | it "testPutStr" $ do 89 | doctest ["TestPutStr.Fib"] 90 | (cases 3) 91 | 92 | it "fails on multi-line expressions, introduced with :{" $ do 93 | doctest ["TestFailOnMultiline.Fib"] 94 | (cases 2) {sErrors = 2} 95 | 96 | it "testBlankline" $ do 97 | doctest ["TestBlankline.Fib"] 98 | (cases 1) 99 | 100 | it "examples from the same Haddock comment share the same scope" $ do 101 | doctest ["TestCombinedExample.Fib"] 102 | (cases 4) 103 | 104 | it "testDocumentationForArguments" $ do 105 | doctest ["TestDocumentationForArguments.Fib"] 106 | (cases 1) 107 | 108 | it "template-haskell" $ do 109 | doctest ["TemplateHaskell.Foo"] 110 | (cases 2) 111 | 112 | it "handles source files with CRLF line endings" $ do 113 | doctest ["DosLineEndings.Fib"] 114 | (cases 1) 115 | 116 | it "runs $setup before each test group" $ do 117 | doctest ["Setup.Foo"] 118 | (cases 1) 119 | 120 | it "skips subsequent tests from a module, if $setup fails" $ do 121 | doctest ["SetupSkipOnFailure.Foo"] 122 | -- TODO: Introduce "skipped" 123 | (cases 2) {sTried = 0, sFailures = 1} 124 | 125 | it "works with additional object files" $ do 126 | doctest ["WithCbits.Bar"] 127 | (cases 1) 128 | 129 | it "ignores trailing whitespace when matching test output" $ do 130 | doctest ["TrailingWhitespace.Foo"] 131 | (cases 1) 132 | 133 | cDescribe "doctest as a runner for QuickCheck properties" $ do 134 | it "runs a boolean property" $ do 135 | doctest ["PropertyBool.Foo"] 136 | (cases 1) 137 | 138 | it "runs an explicitly quantified property" $ do 139 | doctest ["PropertyQuantified.Foo"] 140 | (cases 1) 141 | 142 | it "runs an implicitly quantified property" $ do 143 | doctest ["PropertyImplicitlyQuantified.Foo"] 144 | (cases 1) 145 | 146 | it "reports a failing property" $ do 147 | doctest ["PropertyFailing.Foo"] 148 | (cases 1) {sFailures = 1} 149 | 150 | it "runs a boolean property with an explicit type signature" $ do 151 | doctest ["PropertyBoolWithTypeSignature.Foo"] 152 | (cases 1) 153 | 154 | it "runs $setup before each property" $ do 155 | doctest ["PropertySetup.Foo"] 156 | (cases 1) 157 | 158 | cDescribe "doctest (module isolation)" $ do 159 | it "should fail due to module isolation" $ do 160 | doctestWithOpts defaultConfig ["ModuleIsolation.TestA", "ModuleIsolation.TestB"] 161 | (cases 2) {sFailures = 1} 162 | 163 | cDescribe "doctest (regression tests)" $ do 164 | it "bugfixOutputToStdErr" $ do 165 | doctest ["BugfixOutputToStdErr.Fib"] 166 | (cases 2) 167 | 168 | it "bugfixImportHierarchical" $ do 169 | doctest ["BugfixImportHierarchical.ModuleA", "BugfixImportHierarchical.ModuleB"] 170 | (cases 4) 171 | 172 | it "bugfixMultipleModules" $ do 173 | doctest ["BugfixMultipleModules.ModuleA", "BugfixMultipleModules.ModuleB"] 174 | -- TODO: Introduce "skipped" 175 | (cases 6) {sTried = 5, sFailures = 1} 176 | 177 | it "doesn't clash with user bindings of stdout/stderr" $ do 178 | doctest ["LocalStderrBinding.A"] 179 | (cases 1) 180 | 181 | it "doesn't get confused by doctests using System.IO imports" $ do 182 | doctest ["SystemIoImported.A"] 183 | (cases 2) 184 | 185 | it "correctly handles C import directories" $ do 186 | doctest ["WithCInclude.Bar"] 187 | (cases 1) 188 | 189 | it "sets module level options" $ do 190 | doctest ["ModuleOptions.Foo"] 191 | (cases 5) 192 | 193 | it "succeeds for non-exposed modules if --no-implicit-module-import is set" $ do 194 | doctest ["NonExposedModule.NoImplicitImport"] 195 | (cases 2) 196 | -------------------------------------------------------------------------------- /test/OptionsSpec.hs: -------------------------------------------------------------------------------- 1 | module OptionsSpec (spec) where 2 | 3 | import Prelude () 4 | import Prelude.Compat 5 | 6 | import Test.Hspec 7 | 8 | import Test.DocTest.Internal.Options 9 | import Test.DocTest.Internal.Logging (LogLevel(..)) 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "parseOptions" $ do 14 | describe "--preserve-it" $ do 15 | context "without --preserve-it" $ do 16 | it "does not preserve the `it` variable" $ do 17 | cfgPreserveIt . cfgModuleConfig <$> 18 | parseOptions [] `shouldBe` Result False 19 | 20 | context "with --preserve-it" $ do 21 | it "preserves the `it` variable" $ do 22 | cfgPreserveIt . cfgModuleConfig <$> 23 | parseOptions ["--preserve-it"] `shouldBe` Result True 24 | 25 | context "with --no-preserve-it" $ do 26 | it "preserves the `it` variable" $ do 27 | cfgPreserveIt . cfgModuleConfig <$> 28 | parseOptions ["--no-preserve-it"] `shouldBe` Result False 29 | 30 | describe "--randomize-order" $ do 31 | context "without --randomize-order" $ do 32 | it "does not set randomize order" $ do 33 | cfgRandomizeOrder . cfgModuleConfig <$> 34 | parseOptions [] `shouldBe` Result False 35 | 36 | context "with --randomize-order" $ do 37 | it "sets randomize order" $ do 38 | cfgRandomizeOrder . cfgModuleConfig <$> 39 | parseOptions ["--randomize-order"] `shouldBe` Result True 40 | 41 | context "with --no-randomize-order" $ do 42 | it "unsets randomize order" $ do 43 | cfgRandomizeOrder . cfgModuleConfig <$> 44 | parseOptions ["--no-randomize-order"] `shouldBe` Result False 45 | 46 | context "with --help" $ do 47 | it "outputs usage information" $ do 48 | parseOptions ["--help"] `shouldBe` ResultStdout usage 49 | 50 | context "with --version" $ do 51 | it "outputs version information" $ do 52 | parseOptions ["--version"] `shouldBe` ResultStdout versionInfo 53 | 54 | context "with --info" $ do 55 | it "outputs machine readable version information" $ do 56 | parseOptions ["--info"] `shouldBe` ResultStdout info 57 | 58 | describe "--verbose" $ do 59 | context "without --verbose" $ do 60 | it "is not verbose by default" $ do 61 | cfgLogLevel <$> parseOptions [] `shouldBe` Result Info 62 | 63 | context "with --verbose" $ do 64 | it "parses verbose option" $ do 65 | cfgLogLevel <$> parseOptions ["--verbose"] `shouldBe` Result Verbose 66 | -------------------------------------------------------------------------------- /test/ParseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module ParseSpec (main, spec) where 3 | 4 | import Test.Hspec 5 | import Data.String 6 | import Data.String.Builder (Builder, build) 7 | import Control.Monad.Trans.Writer 8 | 9 | import Test.DocTest.Internal.Parse 10 | import Test.DocTest.Internal.Location 11 | import Test.DocTest.Internal.Extract (isEmptyModule) 12 | 13 | main :: IO () 14 | main = hspec spec 15 | 16 | group :: Writer [DocTest] () -> Writer [[DocTest]] () 17 | group g = tell [execWriter g] 18 | 19 | ghci :: Expression -> Builder -> Writer [DocTest] () 20 | ghci expressions expected = tell [Example expressions $ (map fromString . lines . build) expected] 21 | 22 | prop_ :: Expression -> Writer [DocTest] () 23 | prop_ e = tell [Property e] 24 | 25 | module_ :: String -> Writer [[DocTest]] () -> Writer [Module [DocTest]] () 26 | module_ name gs = tell [Module name Nothing (execWriter gs) []] 27 | 28 | shouldGive :: IO (Module [Located DocTest]) -> Writer [Module [DocTest]] () -> Expectation 29 | shouldGive action expected = map (fmap $ map unLoc) `fmap` fmap pure action `shouldReturn` execWriter expected 30 | 31 | spec :: Spec 32 | spec = do 33 | describe "getDocTestsIO" $ do 34 | it "extracts properties from a module" $ do 35 | getDocTestsIO ["-itest/parse/property"] "Fib" `shouldGive` do 36 | module_ "Fib" $ do 37 | group $ do 38 | prop_ "foo" 39 | prop_ "bar" 40 | prop_ "baz" 41 | 42 | it "extracts examples from a module" $ do 43 | getDocTestsIO ["-itest/parse/simple"] "Fib" `shouldGive` do 44 | module_ "Fib" $ do 45 | group $ do 46 | ghci "putStrLn \"foo\"" 47 | "foo" 48 | ghci "putStr \"bar\"" 49 | "bar" 50 | ghci "putStrLn \"baz\"" 51 | "baz" 52 | 53 | it "extracts examples from documentation for non-exported names" $ do 54 | getDocTestsIO ["-itest/parse/non-exported"] "Fib" `shouldGive` do 55 | module_ "Fib" $ do 56 | group $ do 57 | ghci "putStrLn \"foo\"" 58 | "foo" 59 | ghci "putStr \"bar\"" 60 | "bar" 61 | ghci "putStrLn \"baz\"" 62 | "baz" 63 | 64 | it "extracts multiple examples from a module" $ do 65 | getDocTestsIO ["-itest/parse/multiple-examples"] "Foo" `shouldGive` do 66 | module_ "Foo" $ do 67 | group $ do 68 | ghci "foo" 69 | "23" 70 | group $ do 71 | ghci "bar" 72 | "42" 73 | 74 | it "returns an empty list, if documentation contains no examples" $ do 75 | getDocTestsIO ["-itest/parse/no-examples"] "Fib" >>= (`shouldSatisfy` isEmptyModule) 76 | 77 | it "sets setup code to Nothing, if it does not contain any tests" $ do 78 | getDocTestsIO ["-itest/parse/setup-empty"] "Foo" `shouldGive` do 79 | module_ "Foo" $ do 80 | group $ do 81 | ghci "foo" 82 | "23" 83 | 84 | it "keeps modules that only contain setup code" $ do 85 | getDocTestsIO ["-itest/parse/setup-only"] "Foo" `shouldGive` do 86 | tell [Module "Foo" (Just [Example "foo" ["23"]]) [] []] 87 | 88 | describe "parseInteractions (an internal function)" $ do 89 | 90 | let parse_ = map unLoc . parseInteractions . noLocation . build 91 | 92 | it "parses an interaction" $ do 93 | parse_ $ do 94 | ">>> foo" 95 | "23" 96 | `shouldBe` [("foo", ["23"])] 97 | 98 | it "drops whitespace as appropriate" $ do 99 | parse_ $ do 100 | " >>> foo " 101 | " 23" 102 | `shouldBe` [("foo", ["23"])] 103 | 104 | it "parses an interaction without a result" $ do 105 | parse_ $ do 106 | ">>> foo" 107 | `shouldBe` [("foo", [])] 108 | 109 | it "works with a complex example" $ do 110 | parse_ $ do 111 | "test" 112 | "foobar" 113 | "" 114 | ">>> foo" 115 | "23" 116 | "" 117 | ">>> baz" 118 | "" 119 | ">>> bar" 120 | "23" 121 | "" 122 | "baz" 123 | `shouldBe` [("foo", ["23"]), ("baz", []), ("bar", ["23"])] 124 | 125 | it "attaches location information to parsed interactions" $ do 126 | let loc = Located . Location "Foo.hs" 127 | r <- return . parseInteractions . loc 23 . build $ do 128 | "1" 129 | "2" 130 | "" 131 | ">>> 4" 132 | "5" 133 | "" 134 | ">>> 7" 135 | "" 136 | ">>> 9" 137 | "10" 138 | "" 139 | "11" 140 | r `shouldBe` [loc 26 $ ("4", ["5"]), loc 29 $ ("7", []), loc 31 $ ("9", ["10"])] 141 | 142 | it "basic multiline" $ do 143 | parse_ $ do 144 | ">>> :{ first" 145 | " next" 146 | "some" 147 | ":}" 148 | "output" 149 | `shouldBe` [(":{ first\n next\nsome\n:}", ["output"])] 150 | 151 | it "multiline align output" $ do 152 | parse_ $ do 153 | ">>> :{ first" 154 | " :}" 155 | " output" 156 | `shouldBe` [(":{ first\n:}", ["output"])] 157 | 158 | it "multiline align output with >>>" $ do 159 | parse_ $ do 160 | " >>> :{ first" 161 | " >>> :}" 162 | " output" 163 | `shouldBe` [(":{ first\n:}", ["output"])] 164 | 165 | it "parses wild cards lines" $ do 166 | parse_ $ do 167 | " >>> action" 168 | " foo" 169 | " ..." 170 | " bar" 171 | `shouldBe` [("action", ["foo", WildCardLine, "bar"])] 172 | 173 | it "parses wild card chunks" $ do 174 | parse_ $ do 175 | " >>> action" 176 | " foo ... bar" 177 | `shouldBe` [("action", [ExpectedLine ["foo ", WildCardChunk, " bar"]])] 178 | 179 | describe " parseProperties (an internal function)" $ do 180 | let parse_ = map unLoc . parseProperties . noLocation . build 181 | 182 | it "parses a property" $ do 183 | parse_ $ do 184 | "prop> foo" 185 | `shouldBe` ["foo"] 186 | 187 | describe "mkLineChunks (an internal function)" $ do 188 | 189 | it "replaces ellipsis with WildCardChunks" $ do 190 | mkLineChunks "foo ... bar ... baz" `shouldBe` 191 | ["foo ", WildCardChunk, " bar ", WildCardChunk, " baz"] 192 | 193 | it "doesn't replace fewer than 3 consecutive dots" $ do 194 | mkLineChunks "foo .. bar .. baz" `shouldBe` 195 | ["foo .. bar .. baz"] 196 | 197 | it "handles leading and trailing dots" $ do 198 | mkLineChunks ".. foo bar .." `shouldBe` [".. foo bar .."] 199 | 200 | it "handles leading and trailing ellipsis" $ do 201 | mkLineChunks "... foo bar ..." `shouldBe` [ WildCardChunk 202 | , " foo bar " 203 | , WildCardChunk 204 | ] 205 | -------------------------------------------------------------------------------- /test/ProjectsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | module ProjectsSpec (main, spec) where 4 | 5 | import Test.Hspec 6 | import System.Environment (getEnvironment) 7 | import System.Process (readCreateProcess, proc) 8 | 9 | import qualified Data.Map as Map 10 | 11 | main :: IO () 12 | main = hspec spec 13 | 14 | spec :: Spec 15 | spec = do 16 | env <- Map.fromList <$> runIO getEnvironment 17 | 18 | let 19 | -- Only test with cabal 20 | cDescribe = 21 | if 22 | | "STACK_EXE" `Map.member` env -> xdescribe 23 | | "NIX_BUILD_TOP" `Map.member` env -> xdescribe 24 | | otherwise -> describe 25 | 26 | cDescribe "T85-default-language" $ do 27 | it "cabal run doctests" $ do 28 | _ <- readCreateProcess (proc "cabal" ["run", "-v0", "--", "doctests", "--quiet"]) "" 29 | pure () 30 | -------------------------------------------------------------------------------- /test/PropertySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings #-} 2 | module PropertySpec (main, spec) where 3 | 4 | import Test.Hspec 5 | import Data.String.Builder 6 | 7 | import Test.DocTest.Internal.Property 8 | import Test.DocTest.Internal.Interpreter (withInterpreter) 9 | import Test.DocTest.Internal.Logging (noLogger) 10 | 11 | main :: IO () 12 | main = hspec spec 13 | 14 | isFailure :: PropertyResult -> Bool 15 | isFailure (Failure _) = True 16 | isFailure _ = False 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "runProperty" $ do 21 | it "reports a failing property" $ withInterpreter noLogger [] $ \repl -> do 22 | runProperty repl "False" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):" 23 | 24 | it "runs a Bool property" $ withInterpreter noLogger [] $ \repl -> do 25 | runProperty repl "True" `shouldReturn` Success 26 | 27 | it "runs a Bool property with an explicit type signature" $ withInterpreter noLogger [] $ \repl -> do 28 | runProperty repl "True :: Bool" `shouldReturn` Success 29 | 30 | it "runs an implicitly quantified property" $ withInterpreter noLogger [] $ \repl -> do 31 | runProperty repl "(reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success 32 | 33 | it "runs an implicitly quantified property even with GHC 7.4" $ 34 | -- ghc will include a suggestion (did you mean `id` instead of `is`) in 35 | -- the error message 36 | withInterpreter noLogger [] $ \repl -> do 37 | runProperty repl "foldr (+) 0 is == sum (is :: [Int])" `shouldReturn` Success 38 | 39 | it "runs an explicitly quantified property" $ withInterpreter noLogger [] $ \repl -> do 40 | runProperty repl "\\xs -> (reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success 41 | 42 | it "allows to mix implicit and explicit quantification" $ withInterpreter noLogger [] $ \repl -> do 43 | runProperty repl "\\x -> x + y == y + x" `shouldReturn` Success 44 | 45 | it "reports the value for which a property fails" $ withInterpreter noLogger [] $ \repl -> do 46 | runProperty repl "x == 23" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):\n0" 47 | 48 | it "reports the values for which a property that takes multiple arguments fails" $ withInterpreter noLogger [] $ \repl -> do 49 | let vals x = case x of (Failure r) -> drop 1 (lines r); _ -> error "Property did not fail!" 50 | vals `fmap` runProperty repl "x == True && y == 10 && z == \"foo\"" `shouldReturn` ["False", "0", show ("" :: String)] 51 | 52 | it "defaults ambiguous type variables to Integer" $ withInterpreter noLogger [] $ \repl -> do 53 | runProperty repl "reverse xs == xs" >>= (`shouldSatisfy` isFailure) 54 | 55 | describe "freeVariables" $ do 56 | it "finds a free variables in a term" $ withInterpreter noLogger [] $ \repl -> do 57 | freeVariables repl "x" `shouldReturn` ["x"] 58 | 59 | it "ignores duplicates" $ withInterpreter noLogger [] $ \repl -> do 60 | freeVariables repl "x == x" `shouldReturn` ["x"] 61 | 62 | it "works for terms with multiple names" $ withInterpreter noLogger [] $ \repl -> do 63 | freeVariables repl "\\z -> x + y + z == foo 23" `shouldReturn` ["x", "y", "foo"] 64 | 65 | it "works for names that contain a prime" $ withInterpreter noLogger [] $ \repl -> do 66 | freeVariables repl "x' == y''" `shouldReturn` ["x'", "y''"] 67 | 68 | it "works for names that are similar to other names that are in scope" $ withInterpreter noLogger [] $ \repl -> do 69 | freeVariables repl "length_" `shouldReturn` ["length_"] 70 | 71 | describe "parseNotInScope" $ do 72 | context "when error message was produced by GHC 7.4.1" $ do 73 | it "extracts a variable name of variable that is not in scope from an error message" $ do 74 | parseNotInScope . build $ do 75 | ":4:1: Not in scope: `x'" 76 | `shouldBe` ["x"] 77 | 78 | it "ignores duplicates" $ do 79 | parseNotInScope . build $ do 80 | ":4:1: Not in scope: `x'" 81 | "" 82 | ":4:6: Not in scope: `x'" 83 | `shouldBe` ["x"] 84 | 85 | it "works for variable names that contain a prime" $ do 86 | parseNotInScope . build $ do 87 | ":2:1: Not in scope: x'" 88 | "" 89 | ":2:7: Not in scope: y'" 90 | `shouldBe` ["x'", "y'"] 91 | 92 | it "works for error messages with suggestions" $ do 93 | parseNotInScope . build $ do 94 | ":1:1:" 95 | " Not in scope: `is'" 96 | " Perhaps you meant `id' (imported from Prelude)" 97 | `shouldBe` ["is"] 98 | 99 | context "when error message was produced by GHC 8.0.1" $ do 100 | it "extracts a variable name of variable that is not in scope from an error message" $ do 101 | parseNotInScope . build $ do 102 | ":1:1: error: Variable not in scope: x" 103 | `shouldBe` ["x"] 104 | 105 | it "ignores duplicates" $ do 106 | parseNotInScope . build $ do 107 | ":1:1: error: Variable not in scope: x :: ()" 108 | "" 109 | ":1:6: error: Variable not in scope: x :: ()" 110 | `shouldBe` ["x"] 111 | 112 | it "works for variable names that contain a prime" $ do 113 | parseNotInScope . build $ do 114 | ":1:1: error: Variable not in scope: x' :: ()" 115 | "" 116 | ":1:7: error: Variable not in scope: y'' :: ()" 117 | `shouldBe` ["x'", "y''"] 118 | 119 | it "works for error messages with suggestions" $ do 120 | parseNotInScope . build $ do 121 | ":1:1: error:" 122 | " • Variable not in scope: length_" 123 | " • Perhaps you meant ‘length’ (imported from Prelude)" 124 | `shouldBe` ["length_"] 125 | -------------------------------------------------------------------------------- /test/RunSpec.hs: -------------------------------------------------------------------------------- 1 | module RunSpec (main, spec) where 2 | 3 | import Prelude () 4 | import Prelude.Compat 5 | 6 | import Test.Hspec 7 | import System.Exit 8 | 9 | import qualified Control.Exception as E 10 | import Data.List.Compat 11 | 12 | import System.IO.Silently 13 | import System.IO (stderr) 14 | import qualified Test.DocTest as DocTest 15 | import Test.DocTest.Helpers (findCabalPackage, extractSpecificCabalLibrary) 16 | import qualified Test.DocTest.Internal.Options as Options 17 | 18 | doctest :: HasCallStack => [String] -> IO () 19 | doctest args = do 20 | pkg <- findCabalPackage "doctest-parallel" 21 | lib <- extractSpecificCabalLibrary (Just "spectests-modules") pkg 22 | DocTest.mainFromLibrary lib args 23 | 24 | main :: IO () 25 | main = hspec spec 26 | 27 | spec :: Spec 28 | spec = do 29 | describe "doctest" $ do 30 | it "exits with ExitFailure if at least one test case fails" $ do 31 | hSilence [stderr] (doctest ["Failing.Foo"]) `shouldThrow` (== ExitFailure 1) 32 | 33 | it "prints help on --help" $ do 34 | (r, ()) <- capture (doctest ["--help"]) 35 | r `shouldBe` Options.usage 36 | 37 | it "prints version on --version" $ do 38 | (r, ()) <- capture (doctest ["--version"]) 39 | lines r `shouldSatisfy` any (isPrefixOf "doctest version ") 40 | 41 | it "prints error message on invalid option" $ do 42 | (r, e) <- hCapture [stderr] . E.try $ doctest ["--foo", "test/integration/test-options/Foo.hs"] 43 | e `shouldBe` Left (ExitFailure 1) 44 | r `shouldBe` unlines [ 45 | "doctest: Unknown command line argument: --foo" 46 | , "Try `doctest --help' for more information." 47 | ] 48 | 49 | -- The commented tests fail, but only because `doctest-parallel` prints 50 | -- absolute paths. 51 | -- 52 | -- TODO: Fix 53 | 54 | -- it "prints verbose description of a specification" $ do 55 | -- (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "TestSimple.Fib"] 56 | -- r `shouldBe` unlines [ 57 | -- "### Started execution at test/integration/TestSimple/Fib.hs:5." 58 | -- , "### example:" 59 | -- , "fib 10" 60 | -- , "### Successful `test/integration/TestSimple/Fib.hs:5'!" 61 | -- , "" 62 | -- , "# Final summary:" 63 | -- , "Examples: 1 Tried: 1 Errors: 0 Unexpected output: 0" 64 | -- ] 65 | 66 | -- it "prints verbose description of a property" $ do 67 | -- (r, ()) <- hCapture [stderr] $ doctest ["--verbose", "PropertyBool.Foo"] 68 | -- r `shouldBe` unlines [ 69 | -- "### Started execution at test/integration/PropertyBool/Foo.hs:4." 70 | -- , "### property:" 71 | -- , "True" 72 | -- , "### Successful `test/integration/PropertyBool/Foo.hs:4'!" 73 | -- , "" 74 | -- , "# Final summary:" 75 | -- , "Examples: 1 Tried: 1 Errors: 0 Unexpected output: 0" 76 | -- ] 77 | 78 | -- it "prints verbose error" $ do 79 | -- (r, e) <- hCapture [stderr] . E.try $ doctest ["--verbose", "Failing.Foo"] 80 | -- e `shouldBe` Left (ExitFailure 1) 81 | -- r `shouldBe` unlines [ 82 | -- "### Started execution at test/integration/Failing/Foo.hs:5." 83 | -- , "### example:" 84 | -- , "23" 85 | -- , "test/integration/Failing/Foo.hs:5: failure in expression `23'" 86 | -- , "expected: 42" 87 | -- , " but got: 23" 88 | -- , " ^" 89 | -- , "" 90 | -- , "# Final summary:" 91 | -- , "Examples: 1 Tried: 1 Errors: 0 Unexpected output: 1" 92 | -- ] 93 | -------------------------------------------------------------------------------- /test/Runner/ExampleSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Runner.ExampleSpec (main, spec) where 3 | 4 | import Prelude () 5 | import Prelude.Compat 6 | 7 | import Data.String 8 | import Test.Hspec 9 | import Test.Hspec.Core.QuickCheck (modifyMaxSize) 10 | import Test.QuickCheck 11 | 12 | import Test.DocTest.Internal.Parse 13 | import Test.DocTest.Internal.Runner.Example 14 | 15 | main :: IO () 16 | main = hspec spec 17 | 18 | data Line = PlainLine String | WildCardLines [String] 19 | deriving (Show, Eq) 20 | 21 | instance Arbitrary Line where 22 | arbitrary = frequency [ (2, PlainLine <$> arbitrary) 23 | , (1, WildCardLines . getNonEmpty <$> arbitrary) 24 | ] 25 | 26 | lineToExpected :: [Line] -> ExpectedResult 27 | lineToExpected = map $ \x -> case x of 28 | PlainLine str -> fromString str 29 | WildCardLines _ -> WildCardLine 30 | 31 | lineToActual :: [Line] -> [String] 32 | lineToActual = concatMap $ \x -> case x of 33 | PlainLine str -> [str] 34 | WildCardLines xs -> xs 35 | 36 | spec :: Spec 37 | spec = do 38 | describe "mkResult" $ do 39 | it "returns Equal when output matches" $ do 40 | property $ \xs -> do 41 | mkResult (map fromString xs) xs `shouldBe` Equal 42 | 43 | it "ignores trailing whitespace" $ do 44 | mkResult ["foo\t"] ["foo "] `shouldBe` Equal 45 | 46 | context "with WildCardLine" $ do 47 | it "matches zero lines" $ do 48 | mkResult ["foo", WildCardLine, "bar"] ["foo", "bar"] 49 | `shouldBe` Equal 50 | 51 | it "matches first zero line" $ do 52 | mkResult [WildCardLine, "foo", "bar"] ["foo", "bar"] 53 | `shouldBe` Equal 54 | 55 | it "matches final zero line" $ do 56 | mkResult ["foo", "bar", WildCardLine] ["foo", "bar"] 57 | `shouldBe` Equal 58 | 59 | it "matches an arbitrary number of lines" $ do 60 | mkResult ["foo", WildCardLine, "bar"] ["foo", "baz", "bazoom", "bar"] 61 | `shouldBe` Equal 62 | 63 | -- See https://github.com/sol/doctest/issues/259 64 | modifyMaxSize (const 8) $ 65 | it "matches an arbitrary number of lines (quickcheck)" $ do 66 | property $ \xs -> mkResult (lineToExpected xs) (lineToActual xs) 67 | `shouldBe` Equal 68 | 69 | context "with WildCardChunk" $ do 70 | it "matches an arbitrary line chunk" $ do 71 | mkResult [ExpectedLine ["foo", WildCardChunk, "bar"]] ["foo baz bar"] 72 | `shouldBe` Equal 73 | 74 | it "matches an arbitrary line chunk at end" $ do 75 | mkResult [ExpectedLine ["foo", WildCardChunk]] ["foo baz bar"] 76 | `shouldBe` Equal 77 | 78 | it "does not match at end" $ do 79 | mkResult [ExpectedLine [WildCardChunk, "baz"]] ["foo baz bar"] 80 | `shouldBe` NotEqual [ 81 | "expected: ...baz" 82 | , " but got: foo baz bar" 83 | , " ^" 84 | ] 85 | 86 | it "does not match at start" $ do 87 | mkResult [ExpectedLine ["fuu", WildCardChunk]] ["foo baz bar"] 88 | `shouldBe` NotEqual [ 89 | "expected: fuu..." 90 | , " but got: foo baz bar" 91 | , " ^" 92 | ] 93 | 94 | context "when output does not match" $ do 95 | it "constructs failure message" $ do 96 | mkResult ["foo"] ["bar"] `shouldBe` NotEqual [ 97 | "expected: foo" 98 | , " but got: bar" 99 | , " ^" 100 | ] 101 | 102 | it "constructs failure message for multi-line output" $ do 103 | mkResult ["foo", "bar"] ["foo", "baz"] `shouldBe` NotEqual [ 104 | "expected: foo" 105 | , " bar" 106 | , " but got: foo" 107 | , " baz" 108 | , " ^" 109 | ] 110 | 111 | context "when any output line contains \"unsafe\" characters" $ do 112 | it "uses show to format output lines" $ do 113 | mkResult ["foo\160bar"] ["foo bar"] `shouldBe` NotEqual [ 114 | "expected: foo\\160bar" 115 | , " but got: foo bar" 116 | , " ^" 117 | ] 118 | 119 | it "insert caret after last matching character on different lengths" $ do 120 | mkResult ["foo"] ["fo"] `shouldBe` NotEqual [ 121 | "expected: foo" 122 | , " but got: fo" 123 | , " ^" 124 | ] 125 | 126 | it "insert caret after mismatching line for multi-line output" $ do 127 | mkResult ["foo", "bar", "bat"] ["foo", "baz", "bax"] `shouldBe` NotEqual [ 128 | "expected: foo" 129 | , " bar" 130 | , " bat" 131 | , " but got: foo" 132 | , " baz" 133 | , " ^" 134 | , " bax" 135 | ] 136 | 137 | it "insert caret after mismatching line with the longest match for multi-line wildcard pattern" $ do 138 | mkResult ["foo", WildCardLine, "bar", "bat"] ["foo", "xxx", "yyy", "baz", "bxx"] `shouldBe` NotEqual [ 139 | "expected: foo" 140 | , " ..." 141 | , " bar" 142 | , " bat" 143 | , " but got: foo" 144 | , " xxx" 145 | , " yyy" 146 | , " baz" 147 | , " ^" 148 | , " bxx" 149 | ] 150 | 151 | it "insert caret after longest match for wildcard" $ do 152 | mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo xxx yyy baz bxx"] `shouldBe` NotEqual [ 153 | "expected: foo ... bar bat" 154 | , " but got: foo xxx yyy baz bxx" 155 | , " ^" 156 | ] 157 | 158 | it "show expanded pattern for long matches" $ do 159 | mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo 123456789 123456789 xxx yyy baz bxx"] `shouldBe` NotEqual [ 160 | "expected: foo ... bar bat" 161 | , " but got: foo 123456789 123456789 xxx yyy baz bxx" 162 | , " foo ........................... ba^" 163 | ] 164 | -------------------------------------------------------------------------------- /test/RunnerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings, ImplicitParams #-} 2 | module RunnerSpec (main, spec) where 3 | 4 | import Test.Hspec 5 | 6 | import Control.Concurrent 7 | import Control.Monad.Trans.State 8 | import System.IO 9 | import System.IO.Silently (hCapture) 10 | import Test.DocTest.Internal.Logging 11 | import Test.DocTest.Internal.Runner 12 | import Text.Printf (printf) 13 | 14 | main :: IO () 15 | main = hspec spec 16 | 17 | capture :: Report a -> IO String 18 | capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 True mempty) 19 | 20 | -- like capture, but with interactivity set to False 21 | capture_ :: Report a -> IO String 22 | capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 False mempty) 23 | 24 | spec :: Spec 25 | spec = do 26 | threadId <- runIO myThreadId 27 | let ?threadId = threadId 28 | let ?verbosity = Info 29 | 30 | describe "report" $ do 31 | 32 | context "when mode is interactive" $ do 33 | 34 | it "writes to stderr" $ do 35 | capture $ do 36 | report Info "foobar" 37 | `shouldReturn` printf "[INFO ] [%s] foobar\n" (show threadId) 38 | 39 | it "overwrites any intermediate output" $ do 40 | capture $ do 41 | report_ Info "foo" 42 | report Info "bar" 43 | `shouldReturn` printf "foo\r[INFO ] [%s] bar\n" (show threadId) 44 | 45 | it "blank out intermediate output if necessary" $ do 46 | capture $ do 47 | report_ Info "foobarrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr" 48 | report Info "baz" 49 | `shouldReturn` printf "foobarrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr\r[INFO ] [%s] baz \n" (show threadId) 50 | 51 | context "when mode is non-interactive" $ do 52 | it "writes to stderr" $ do 53 | capture_ $ do 54 | report Info "foobar" 55 | `shouldReturn` printf "[INFO ] [%s] foobar\n" (show threadId) 56 | 57 | describe "report_ Info" $ do 58 | 59 | context "when mode is interactive" $ do 60 | it "writes intermediate output to stderr" $ do 61 | capture $ do 62 | report_ Info "foobar" 63 | `shouldReturn` "foobar" 64 | 65 | it "overwrites any intermediate output" $ do 66 | capture $ do 67 | report_ Info "foo" 68 | report_ Info "bar" 69 | `shouldReturn` "foo\rbar" 70 | 71 | it "blank out intermediate output if necessary" $ do 72 | capture $ do 73 | report_ Info "foobar" 74 | report_ Info "baz" 75 | `shouldReturn` "foobar\rbaz " 76 | 77 | context "when mode is non-interactive" $ do 78 | it "is ignored" $ do 79 | capture_ $ do 80 | report_ Info "foobar" 81 | `shouldReturn` "" 82 | 83 | it "does not influence a subsequent call to `report Info`" $ do 84 | capture_ $ do 85 | report_ Info "foo" 86 | report Info "bar" 87 | `shouldReturn` printf "[INFO ] [%s] bar\n" (show threadId) 88 | 89 | it "does not require `report Info` to blank out any intermediate output" $ do 90 | capture_ $ do 91 | report_ Info "foobar" 92 | report Info "baz" 93 | `shouldReturn` printf "[INFO ] [%s] baz\n" (show threadId) 94 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | 5 | import qualified ExtractSpec 6 | import qualified GhciWrapperSpec 7 | import qualified InterpreterSpec 8 | import qualified LocationSpec 9 | import qualified MainSpec 10 | import qualified OptionsSpec 11 | import qualified ParseSpec 12 | import qualified ProjectsSpec 13 | import qualified PropertySpec 14 | import qualified RunnerSpec 15 | import qualified RunSpec 16 | import qualified UtilSpec 17 | 18 | main :: IO () 19 | main = hspec spec 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "ExtractSpec" ExtractSpec.spec 24 | describe "GhciWrapperSpec" GhciWrapperSpec.spec 25 | describe "InterpreterSpec" InterpreterSpec.spec 26 | describe "LocationSpec" LocationSpec.spec 27 | describe "MainSpec" MainSpec.spec 28 | describe "OptionsSpec" OptionsSpec.spec 29 | describe "ParseSpec" ParseSpec.spec 30 | describe "ProjectsSpec" ProjectsSpec.spec 31 | describe "PropertySpec" PropertySpec.spec 32 | describe "RunnerSpec" RunnerSpec.spec 33 | describe "RunSpec" RunSpec.spec 34 | describe "UtilSpec" UtilSpec.spec 35 | -------------------------------------------------------------------------------- /test/UtilSpec.hs: -------------------------------------------------------------------------------- 1 | module UtilSpec (main, spec) where 2 | 3 | import Test.Hspec 4 | 5 | import Test.DocTest.Internal.Util 6 | 7 | main :: IO () 8 | main = hspec spec 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "convertDosLineEndings" $ do 13 | it "converts CRLF to LF" $ do 14 | convertDosLineEndings "foo\r\nbar\r\nbaz" `shouldBe` "foo\nbar\nbaz" 15 | 16 | it "strips a trailing CR" $ do 17 | convertDosLineEndings "foo\r" `shouldBe` "foo" 18 | 19 | describe "takeWhileEnd" $ do 20 | it "returns the longest suffix of elements that satisfy a given predicate" $ do 21 | takeWhileEnd (/= ' ') "foo bar" `shouldBe` "bar" 22 | -------------------------------------------------------------------------------- /test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest (mainFromCabal) 4 | import System.Environment (getArgs) 5 | 6 | main :: IO () 7 | main = do 8 | args <- getArgs 9 | mainFromCabal "doctest-parallel" ("--randomize-order":args) 10 | -------------------------------------------------------------------------------- /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/module-options/Binders.hs: -------------------------------------------------------------------------------- 1 | module Binders where 2 | 3 | {-# ANN f "doctest-parallel: --no-randomize-error" #-} 4 | f :: a -> a 5 | f = id 6 | -------------------------------------------------------------------------------- /test/extract/module-options/Mono.hs: -------------------------------------------------------------------------------- 1 | module Mono where 2 | 3 | {-# ANN module "doctest-parallel: --no-randomize-error1" #-} 4 | {-# ANN module ("doctest-parallel: --no-randomize-error2") #-} 5 | {-# ANN module ("doctest-parallel: --no-randomize-error3" ) #-} 6 | {-# ANN module ("doctest-parallel: --no-randomize-error4" ) #-} 7 | {-# ANN module ("doctest-parallel: --no-randomize-error5 " ) #-} 8 | {-# ANN module ("doctest-parallel: --no-randomize-error6" :: String) #-} 9 | -------------------------------------------------------------------------------- /test/extract/module-options/NoOptions.hs: -------------------------------------------------------------------------------- 1 | module NoOptions where 2 | 3 | {-# ANN module "doctest-parallel" #-} 4 | {-# ANN module "abc" #-} 5 | {-# ANN module "" #-} 6 | -------------------------------------------------------------------------------- /test/extract/module-options/Poly.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Poly where 4 | 5 | {-# ANN module ("doctest-parallel: --no-randomize-error" :: String) #-} 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 | -- >>> import BugfixImportHierarchical.ModuleB 3 | -- >>> fib 10 4 | -- 55 5 | module BugfixImportHierarchical.ModuleA where 6 | 7 | import BugfixImportHierarchical.ModuleB () 8 | -------------------------------------------------------------------------------- /test/integration/BugfixImportHierarchical/ModuleB.hs: -------------------------------------------------------------------------------- 1 | module BugfixImportHierarchical.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 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | 3 | -- | The test below should fail, as ModuleB does not export it: 4 | -- 5 | -- >>> import BugfixMultipleModules.ModuleB 6 | -- >>> fib 10 7 | -- 55 8 | module BugfixMultipleModules.ModuleA where 9 | -------------------------------------------------------------------------------- /test/integration/BugfixMultipleModules/ModuleB.hs: -------------------------------------------------------------------------------- 1 | module BugfixMultipleModules.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 | -- This test should fail, as foo is not exported: 13 | 14 | -- | 15 | -- >>> foo 10 16 | -- 55 17 | -- >>> foo 5 18 | -- 5 19 | foo :: Integer -> Integer 20 | foo 0 = 0 21 | foo 1 = 1 22 | foo n = foo (n - 1) + foo (n - 2) 23 | -------------------------------------------------------------------------------- /test/integration/BugfixOutputToStdErr/Fib.hs: -------------------------------------------------------------------------------- 1 | module BugfixOutputToStdErr.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/Color/Foo.hs: -------------------------------------------------------------------------------- 1 | module Color.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/DosLineEndings/Fib.hs: -------------------------------------------------------------------------------- 1 | module DosLineEndings.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/Failing/Foo.hs: -------------------------------------------------------------------------------- 1 | module Failing.Foo where 2 | 3 | -- | A failing example 4 | -- 5 | -- >>> 23 6 | -- 42 7 | test :: a 8 | test = undefined 9 | -------------------------------------------------------------------------------- /test/integration/FailingMultiple/Foo.hs: -------------------------------------------------------------------------------- 1 | module FailingMultiple.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/GhcArg/Fib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module GhcArg.Fib where 4 | 5 | -- | Calculate Fibonacci numbers. 6 | -- 7 | -- >>> FIB 10 8 | -- 55 9 | fib :: Integer -> Integer 10 | fib 0 = 0 11 | fib 1 = 1 12 | fib n = fib (n - 1) + fib (n - 2) 13 | -------------------------------------------------------------------------------- /test/integration/It/Foo.hs: -------------------------------------------------------------------------------- 1 | module It.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 It.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/LocalStderrBinding/A.hs: -------------------------------------------------------------------------------- 1 | module LocalStderrBinding.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/ModuleIsolation/TestA.hs: -------------------------------------------------------------------------------- 1 | module ModuleIsolation.TestA (foo) where 2 | 3 | import ModuleIsolation.TestB () 4 | 5 | {- $setup 6 | >>> :set -XLambdaCase 7 | -} 8 | 9 | -- | 10 | -- >>> (\case { 3 -> 5; 7 -> 9}) 3 11 | -- 5 12 | foo :: Num a => a 13 | foo = 3 14 | -------------------------------------------------------------------------------- /test/integration/ModuleIsolation/TestB.hs: -------------------------------------------------------------------------------- 1 | module ModuleIsolation.TestB (bar) where 2 | 3 | -- | Example usage: 4 | -- 5 | -- >>> (\case { 3 -> 5; 7 -> 9}) 3 6 | -- 5 7 | bar :: Num a => a 8 | bar = 3 9 | -------------------------------------------------------------------------------- /test/integration/ModuleOptions/Foo.hs: -------------------------------------------------------------------------------- 1 | module ModuleOptions.Foo where 2 | 3 | {-# ANN module "doctest-parallel: --preserve-it" #-} 4 | 5 | -- | 6 | -- 7 | -- >>> :t 'a' 8 | -- 'a' :: Char 9 | -- 10 | -- >>> "foo" 11 | -- "foo" 12 | -- 13 | -- >>> length it 14 | -- 3 15 | -- 16 | -- >>> it * it 17 | -- 9 18 | -- 19 | -- >>> :t it 20 | -- it :: Int 21 | -- 22 | foo = undefined 23 | -------------------------------------------------------------------------------- /test/integration/ModuleOptions/Setup.hs: -------------------------------------------------------------------------------- 1 | module It.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/Multiline/Multiline.hs: -------------------------------------------------------------------------------- 1 | module Multiline.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/NonExposedModule/Exposed.hs: -------------------------------------------------------------------------------- 1 | module NonExposedModule.Exposed (foo) where 2 | 3 | import NonExposedModule.NoImplicitImport (foo) 4 | -------------------------------------------------------------------------------- /test/integration/NonExposedModule/NoImplicitImport.hs: -------------------------------------------------------------------------------- 1 | module NonExposedModule.NoImplicitImport where 2 | 3 | {-# ANN module "doctest-parallel: --no-implicit-module-import" #-} 4 | 5 | -- | 6 | -- >>> import NonExposedModule.Exposed (foo) 7 | -- >>> foo 7 8 | -- 14 9 | foo :: Int -> Int 10 | foo a = a + a 11 | -------------------------------------------------------------------------------- /test/integration/PropertyBool/Foo.hs: -------------------------------------------------------------------------------- 1 | module PropertyBool.Foo where 2 | 3 | -- | 4 | -- prop> True 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/PropertyBoolWithTypeSignature/Foo.hs: -------------------------------------------------------------------------------- 1 | module PropertyBoolWithTypeSignature.Foo where 2 | 3 | -- | 4 | -- prop> True :: Bool 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/PropertyFailing/Foo.hs: -------------------------------------------------------------------------------- 1 | module PropertyFailing.Foo where 2 | 3 | -- | 4 | -- prop> abs x == x 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/PropertyImplicitlyQuantified/Foo.hs: -------------------------------------------------------------------------------- 1 | module PropertyImplicitlyQuantified.Foo where 2 | 3 | -- | 4 | -- prop> abs x == abs (abs x) 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/PropertyQuantified/Foo.hs: -------------------------------------------------------------------------------- 1 | module PropertyQuantified.Foo where 2 | 3 | -- | 4 | -- prop> \x -> abs x == abs (abs x) 5 | foo = undefined 6 | -------------------------------------------------------------------------------- /test/integration/PropertySetup/Foo.hs: -------------------------------------------------------------------------------- 1 | module PropertySetup.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/Foo.hs: -------------------------------------------------------------------------------- 1 | module Setup.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/SetupSkipOnFailure/Foo.hs: -------------------------------------------------------------------------------- 1 | module SetupSkipOnFailure.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/SystemIoImported/A.hs: -------------------------------------------------------------------------------- 1 | module SystemIoImported.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 | -- >>> import System.IO 9 | -- >>> ReadMode 10 | -- ReadMode 11 | -------------------------------------------------------------------------------- /test/integration/TemplateHaskell/Foo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module TemplateHaskell.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/TestBlankline/Fib.hs: -------------------------------------------------------------------------------- 1 | module TestBlankline.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/TestCombinedExample/Fib.hs: -------------------------------------------------------------------------------- 1 | module TestCombinedExample.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 TestCommentLocation.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 | 36 | foo, baz 37 | ) where 38 | 39 | 40 | -- | My test 41 | -- 42 | -- >>> test 20 43 | -- *** Exception: Prelude.undefined 44 | -- ... 45 | test :: Integer -> Integer 46 | test = undefined 47 | 48 | -- | Note that examples for 'fib' include the two examples below 49 | -- and the one example with ^ syntax after 'fix' 50 | -- 51 | -- >>> foo 52 | -- "foo" 53 | 54 | {- | 55 | Example: 56 | 57 | >>> fib 10 58 | 55 59 | -} 60 | 61 | -- | Calculate Fibonacci number of given `n`. 62 | fib :: Integer -- ^ given `n` 63 | -- 64 | -- >>> fib 10 65 | -- 55 66 | 67 | -> Integer -- ^ Fibonacci of given `n` 68 | -- 69 | -- >>> baz 70 | -- "foobar" 71 | fib 0 = 0 72 | fib 1 = 1 73 | fib n = fib (n - 1) + fib (n - 2) 74 | -- ^ Example: 75 | -- 76 | -- >>> fib 5 77 | -- 5 78 | 79 | foo = "foo" 80 | bar = "bar" 81 | baz = foo ++ bar 82 | -------------------------------------------------------------------------------- /test/integration/TestDocumentationForArguments/Fib.hs: -------------------------------------------------------------------------------- 1 | module TestDocumentationForArguments.Fib where 2 | 3 | fib :: Int -- ^ 4 | -- >>> 23 5 | -- 23 6 | -> Int 7 | fib _ = undefined 8 | -------------------------------------------------------------------------------- /test/integration/TestFailOnMultiline/Fib.hs: -------------------------------------------------------------------------------- 1 | module TestFailOnMultiline.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 | -- >>> import TestImport.ModuleB 3 | -- >>> fib 10 4 | -- 55 5 | module TestImport.ModuleA where 6 | 7 | -------------------------------------------------------------------------------- /test/integration/TestImport/ModuleB.hs: -------------------------------------------------------------------------------- 1 | module TestImport.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 TestPutStr.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 TestSimple.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/TrailingWhitespace/Foo.hs: -------------------------------------------------------------------------------- 1 | module TrailingWhitespace.Foo where 2 | 3 | -- | A failing example 4 | -- 5 | -- >>> putStrLn "foo " 6 | -- foo 7 | test :: a 8 | test = undefined 9 | -------------------------------------------------------------------------------- /test/integration/WithCInclude/Bar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module WithCInclude.Bar where 4 | 5 | #include "WithCInclude.h" 6 | 7 | 8 | -- | 9 | -- >>> x 10 | -- 42 11 | x :: Int 12 | x = THE_DEFINE 13 | -------------------------------------------------------------------------------- /test/integration/WithCInclude/include/WithCInclude.h: -------------------------------------------------------------------------------- 1 | #define THE_DEFINE 42 2 | -------------------------------------------------------------------------------- /test/integration/WithCbits/Bar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module WithCbits.Bar where 3 | 4 | import Foreign.C 5 | 6 | -- | 7 | -- >>> foo 8 | -- 23 9 | foreign import ccall foo :: CInt 10 | -------------------------------------------------------------------------------- /test/integration/WithCbits/foo.c: -------------------------------------------------------------------------------- 1 | int foo() { 2 | return 23; 3 | } 4 | -------------------------------------------------------------------------------- /test/nix/a.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: a 3 | version: 0.0.0 4 | build-type: Simple 5 | 6 | library 7 | hs-source-dirs: src 8 | exposed-modules: A 9 | build-depends: base, extra, ghc 10 | default-language: Haskell2010 11 | 12 | test-suite doctests 13 | type: exitcode-stdio-1.0 14 | hs-source-dirs: test 15 | main-is: doctests.hs 16 | ghc-options: -threaded 17 | build-depends: base, a, doctest-parallel >= 0.1, 18 | default-language: Haskell2010 19 | -------------------------------------------------------------------------------- /test/nix/cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | . 3 | 4 | -- Nix projects don't need environment files! 5 | write-ghc-environment-files: never 6 | -------------------------------------------------------------------------------- /test/nix/default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix {} }: 2 | 3 | with nixpkgs.pkgs; 4 | with gitignore; 5 | 6 | haskellPackages.callCabal2nix "a" (gitignoreSource ./.) {} 7 | -------------------------------------------------------------------------------- /test/nix/nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | { sources ? import ./../../../nix/sources.nix }: 2 | 3 | let 4 | overlay = _: nixpkgs: { 5 | 6 | # Nix tooling 7 | niv = (import sources.niv {}).niv; 8 | gitignore = import sources.gitignore { inherit (nixpkgs) lib; }; 9 | 10 | # Haskell overrides 11 | haskellPackages = nixpkgs.haskellPackages.override { 12 | overrides = self: super: { 13 | # External overrides 14 | # ..no overrides yet 15 | 16 | # Internal overrides 17 | doctest-parallel = import ../../.. { inherit nixpkgs; }; 18 | }; 19 | }; 20 | }; 21 | 22 | in import sources.nixpkgs { overlays = [ overlay ]; } 23 | 24 | -------------------------------------------------------------------------------- /test/nix/release.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import ./nix/nixpkgs.nix { }; 3 | in 4 | pkgs.haskellPackages.callPackage ./default.nix { } 5 | -------------------------------------------------------------------------------- /test/nix/shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix {} }: 2 | let 3 | inherit (nixpkgs) pkgs; 4 | inherit (pkgs) haskellPackages; 5 | 6 | project = import ./release.nix; 7 | in 8 | pkgs.stdenv.mkDerivation { 9 | name = "shell"; 10 | buildInputs = project.env.propagatedBuildInputs ++ project.env.nativeBuildInputs ++ [ 11 | haskellPackages.cabal-install 12 | ]; 13 | LC_ALL = "C.UTF-8"; 14 | } 15 | -------------------------------------------------------------------------------- /test/nix/src/A.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module A where 4 | 5 | -- Test CPP on 'ghc', which seems to be handled specially 6 | #if MIN_VERSION_ghc(9,0,0) 7 | -- #if MIN_VERSION_base(4,15,0) 8 | -- | 9 | -- >>> foo 10 | -- 23 11 | foo = 23 12 | #else 13 | -- | 14 | -- >>> bar 15 | -- 42 16 | bar = 42 17 | #endif 18 | 19 | -- Test CPP on 'base', a wired-in package 20 | #if MIN_VERSION_base(4,12,0) 21 | x = 3 22 | #else 23 | x = 5 24 | #endif 25 | 26 | -- Test CPP on 'extra', a "normal" Hackage package 27 | #if MIN_VERSION_extra(1,7,0) 28 | y = 10 29 | #else 30 | y = 20 31 | #endif 32 | -------------------------------------------------------------------------------- /test/nix/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest (mainFromCabal) 4 | import System.Environment (getArgs) 5 | 6 | main :: IO () 7 | main = mainFromCabal "a" =<< getArgs 8 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /test/projects/T85-default-language/T85-default-language.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: T85-default-language 3 | version: 0.1.0.0 4 | license: BSD-3-Clause 5 | author: Martijn Bastiaan 6 | maintainer: martijn@hmbastiaan.nl 7 | build-type: Simple 8 | extra-doc-files: CHANGELOG.md 9 | 10 | common warnings 11 | ghc-options: -Wall 12 | 13 | library 14 | import: warnings 15 | exposed-modules: MyLib 16 | build-depends: base ^>=4.17.2.1 17 | hs-source-dirs: src 18 | default-language: Haskell2010 19 | 20 | test-suite doctests 21 | type: exitcode-stdio-1.0 22 | hs-source-dirs: test 23 | main-is: doctests.hs 24 | ghc-options: -threaded 25 | build-depends: base, T85-default-language, doctest-parallel >= 0.1 26 | default-language: Haskell2010 27 | -------------------------------------------------------------------------------- /test/projects/T85-default-language/cabal.project: -------------------------------------------------------------------------------- 1 | write-ghc-environment-files: always 2 | 3 | packages: 4 | . 5 | ../../.. 6 | 7 | tests: true 8 | 9 | package doctest-parallel 10 | ghc-options: +RTS -qn4 -A128M -RTS -j4 11 | -------------------------------------------------------------------------------- /test/projects/T85-default-language/src/MyLib.hs: -------------------------------------------------------------------------------- 1 | module MyLib (someFunc) where 2 | 3 | data (Show a) => ShowProxy a = Prox a 4 | deriving (Show) 5 | 6 | showViaProxy :: (Show a) => a -> IO () 7 | showViaProxy a = putStrLn $ show $ Prox a 8 | 9 | someFunc :: IO () 10 | someFunc = showViaProxy "hello world!" 11 | -------------------------------------------------------------------------------- /test/projects/T85-default-language/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest (mainFromCabal) 4 | import System.Environment (getArgs) 5 | 6 | main :: IO () 7 | main = mainFromCabal "T85-default-language" =<< getArgs 8 | --------------------------------------------------------------------------------