git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
swap
6624a5937 ahead, 0 behind
11 files changed+277−254
since splitsnapshots
unifiedsplit
.github/workflows/cabal.yml+44 .gitignore+2−1 .travis.yml−155 CHANGELOG.md+23−1 LICENSE+1−1 Readme.md+32−23 example/Main.hs+9−3 haskell-stack-trace-plugin.cabal+52−53 src/StackTrace/Plugin.hs+109−14 test/StackTrace/PluginSpec.hs+1−1 test/resource/ghc86.output → test/resource/ghc.output+4−2
.github/workflows/cabal.ymlnew file+44
@@ -0,0 +1,44 @@
1+name: cabal
2+
3+on:
4+ push:
5+ branches: [ master ]
6+ pull_request:
7+ branches: [ '*' ]
8+ schedule:
9+ - cron: "00 15 * * *"
10+
11+jobs:
12+ build:
13+ runs-on: ubuntu-18.04
14+ strategy:
15+ matrix:
16+ ghc: ["8.6", "8.8", "8.10", "9.0"]
17+ cabal: ["3.2"]
18+ cache-version: ["2021-05-21"]
19+
20+ steps:
21+ - uses: actions/checkout@v2
22+ - uses: haskell/actions/setup@v1
23+ with:
24+ ghc-version: ${{ matrix.ghc }}
25+ cabal-version: ${{ matrix.cabal }}
26+
27+ - name: Cache ~/.cabal/store
28+ uses: actions/cache@v2
29+ with:
30+ path: |
31+ ~/.cabal/store
32+ dist-newstyle
33+ key: ${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cache-version }}-cabal
34+
35+ - name: Install dependencies
36+ run: |
37+ cabal update
38+ cabal configure --disable-optimization --enable-tests --write-ghc-environment-files=always -j2
39+ cabal build --only-dependencies
40+
41+ - name: Build & Test
42+ run: |
43+ cabal build --flag dev
44+ cabal test --flag dev
.gitignore+2−1
@@ -3,4 +3,5 @@ dist-*/
33.ghc.environment.*
44cabal.project.local
55
6−*~
6+*~
7+tasks.json
.travis.ymldeleted−155
@@ -1,155 +0,0 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci 'haskell-stack-trace-plugin.cabal' '--output' '.travis.yml'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.8
8−#
9−version: ~> 1.0
10−language: c
11−os: linux
12−dist: xenial
13−git:
14− # whether to recursively clone submodules
15− submodules: false
16−cache:
17− directories:
18− - $HOME/.cabal/packages
19− - $HOME/.cabal/store
20− - $HOME/.hlint
21−before_cache:
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
23− # remove files that are regenerated by 'cabal update'
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
27− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
28− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
29− - rm -rfv $CABALHOME/packages/head.hackage
30−jobs:
31− include:
32− - compiler: ghc-8.6.5
33− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
34− os: linux
35−before_install:
36− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
37− - WITHCOMPILER="-w $HC"
38− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
39− - HCPKG="$HC-pkg"
40− - unset CC
41− - CABAL=/opt/ghc/bin/cabal
42− - CABALHOME=$HOME/.cabal
43− - export PATH="$CABALHOME/bin:$PATH"
44− - TOP=$(pwd)
45− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
46− - echo $HCNUMVER
47− - CABAL="$CABAL -vnormal+nowrap+markoutput"
48− - set -o pipefail
49− - |
50− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
51− echo 'BEGIN { state = "output"; }' >> .colorful.awk
52− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
53− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
54− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
55− echo ' if (state == "cabal") {' >> .colorful.awk
56− echo ' print blue($0)' >> .colorful.awk
57− echo ' } else {' >> .colorful.awk
58− echo ' print $0' >> .colorful.awk
59− echo ' }' >> .colorful.awk
60− echo '}' >> .colorful.awk
61− - cat .colorful.awk
62− - |
63− color_cabal_output () {
64− awk -f $TOP/.colorful.awk
65− }
66− - echo text | color_cabal_output
67−install:
68− - ${CABAL} --version
69− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
70− - TEST=--enable-tests
71− - BENCH=--enable-benchmarks
72− - HEADHACKAGE=false
73− - rm -f $CABALHOME/config
74− - |
75− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
76− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
77− echo "write-ghc-environment-files: always" >> $CABALHOME/config
78− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
79− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
80− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
81− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
82− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
83− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
84− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
85− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
86− echo "install-dirs user" >> $CABALHOME/config
87− echo " prefix: $CABALHOME" >> $CABALHOME/config
88− echo "repository hackage.haskell.org" >> $CABALHOME/config
89− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
90− echo " secure: True" >> $CABALHOME/config
91− echo " key-threshold: 3" >> $CABALHOME/config
92− echo " root-keys:" >> $CABALHOME/config
93− echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config
94− echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config
95− echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config
96− echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config
97− echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config
98− - |
99− echo "program-default-options" >> $CABALHOME/config
100− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
101− - cat $CABALHOME/config
102− - rm -fv cabal.project cabal.project.local cabal.project.freeze
103− - travis_retry ${CABAL} v2-update -v
104− # Generate cabal.project
105− - rm -rf cabal.project cabal.project.local cabal.project.freeze
106− - touch cabal.project
107− - |
108− echo "packages: ." >> cabal.project
109− - |
110− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haskell-stack-trace-plugin)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
111− - cat cabal.project || true
112− - cat cabal.project.local || true
113− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
114− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
115− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
116− - rm cabal.project.freeze
117− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
118− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
119−script:
120− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
121− # Packaging...
122− - ${CABAL} v2-sdist all | color_cabal_output
123− # Unpacking...
124− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
125− - cd ${DISTDIR} || false
126− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
127− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
128− - PKGDIR_haskell_stack_trace_plugin="$(find . -maxdepth 1 -type d -regex '.*/haskell-stack-trace-plugin-[0-9.]*')"
129− # Generate cabal.project
130− - rm -rf cabal.project cabal.project.local cabal.project.freeze
131− - touch cabal.project
132− - |
133− echo "packages: ${PKGDIR_haskell_stack_trace_plugin}" >> cabal.project
134− - |
135− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haskell-stack-trace-plugin)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
136− - cat cabal.project || true
137− - cat cabal.project.local || true
138− # Building...
139− # this builds all libraries and executables (without tests/benchmarks)
140− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
141− # Building with tests and benchmarks...
142− # build & run tests, build benchmarks
143− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
144− # Testing...
145− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
146− # cabal check...
147− - (cd ${PKGDIR_haskell_stack_trace_plugin} && ${CABAL} -vnormal check)
148− # haddock...
149− - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output
150− # Building without installed constraints for packages in global-db...
151− - rm -f cabal.project.local
152− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
153−
154−# REGENDATA ("0.8",["haskell-stack-trace-plugin.cabal","--output",".travis.yml"])
155−# EOF
CHANGELOG.md+23−1
@@ -1,5 +1,27 @@
11# Revision history for haskell-stack-trace-pugin
22
3+## Unreleased changes
4+
5+## 0.1.3.0
6+
7+- Added support `where` clause [#11](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/11) (@waddlaw)
8+- Avoid redundant-constraints warnings [#12](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/12) (@waddlaw)
9+
10+## 0.1.2.0 -- 2021-05-21
11+
12+- Added support for GHC 8.10 [#7](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/7) (@etorreborre)
13+- Added support for GHC 9.0 @waddlaw
14+
15+## 0.1.1.1 -- 2020-01-18
16+
17+- Allow GHC-8.8.1
18+
19+## 0.1.1.0 -- 2020-01-18
20+
21+- Ergonomic improvements [#1](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/1) (@khwarizmii)
22+- Add Integration test
23+- Add GitHub Action
24+
325## 0.1.0.0 -- 2018-12-07
426
5−* First version. Released on an unsuspecting world.
27+- First version. Released on an unsuspecting world.
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2018-2020 Shinya Yamaguchi
1+Copyright (c) 2018-2021 Shinya Yamaguchi
22
33Permission is hereby granted, free of charge, to any person obtaining
44a copy of this software and associated documentation files (the
Readme.md+32−23
@@ -1,11 +1,14 @@
11# haskell-stack-trace-plugin
22
3+![](https://github.com/waddlaw/haskell-stack-trace-plugin/workflows/cabal/badge.svg)
34[![Hackage](https://img.shields.io/hackage/v/haskell-stack-trace-plugin.svg)](https://hackage.haskell.org/package/haskell-stack-trace-plugin)
45
56This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack.
67
7−1. (implicitly) Import [GHC.Stack](https://www.stackage.org/haddock/lts-12.21/base-4.11.1.0/GHC-Stack.html) for all modules.
8−2. Add [HasCallStack](https://www.stackage.org/haddock/lts-12.21/base-4.11.1.0/GHC-Stack.html#t:HasCallStack) constraint for all top-level functions.
8+1. (implicitly) Import [GHC.Stack](https://hackage.haskell.org/package/base/docs/GHC-Stack.html) for all modules.
9+2. Add [HasCallStack](https://hackage.haskell.org/package/base/docs/GHC-Stack.html#t:HasCallStack) constraint for all top-level functions.
10+3. Other supported syntaxes
11+ - [x] `where` clause
912
1013Requirement: (8.6 <= on GHC)
1114
@@ -31,10 +34,10 @@ f3 = f4 0
3134
3235-- HsQualTy
3336f4 :: Show a => a -> Int
34−f4 _ = f5 0 0
37+f4 n = f5 (show n) 0
3538
3639-- HsFunTy
37−f5 :: Int -> Int -> Int
40+f5 :: String -> Int -> Int
3841f5 _ _ = head f6
3942
4043-- HsListTy
@@ -47,7 +50,13 @@ f7 = (fromJust f8, fromJust f8)
4750
4851-- HsAppTy
4952f8 :: Maybe Int
50−f8 = Just fError
53+f8 = Just f9
54+
55+f9 :: Int
56+f9 = f10
57+ where
58+ f10 :: Int
59+ f10 = fError
5160
5261-- HsTyVar
5362fError :: Int
@@ -57,7 +66,7 @@ fError = error "fError"
5766This example get error:
5867
5968```shell
60−$ cabal new-build
69+$ cabal build
6170example/Main.hs:15:7: error:
6271 Not in scope: type constructor or class ‘HasCallStack’
6372 |
@@ -70,10 +79,10 @@ Yes, add `import GHC.Stack` to above example.
7079Fix and rebuild!
7180
7281```shell
73−$ cabal new-run
82+$ cabal run example -v0
7483example: fError
7584CallStack (from HasCallStack):
76− error, called at example/Main.hs:41:10 in main:Main
85+ error, called at example/Main.hs:47:10 in main:Main
7786```
7887
7988Hmm, it is not useful. But, you will to be happy when enable this plugin.
@@ -84,22 +93,22 @@ Hmm, it is not useful. But, you will to be happy when enable this plugin.
8493```
8594
8695```shell
87−$ cabal new-run
88−...
89−
96+$ cabal run example -v0
9097example: fError
9198CallStack (from HasCallStack):
92− error, called at example/Main.hs:40:10 in main:Main
93− fError, called at example/Main.hs:36:11 in main:Main
94− f8, called at example/Main.hs:32:16 in main:Main
95− f7, called at example/Main.hs:28:11 in main:Main
96− f6, called at example/Main.hs:24:15 in main:Main
97− f5, called at example/Main.hs:20:8 in main:Main
98− f4, called at example/Main.hs:16:6 in main:Main
99− f3, called at example/Main.hs:12:6 in main:Main
100− f2, called at example/Main.hs:9:6 in main:Main
101− f1, called at example/Main.hs:6:14 in main:Main
102− main, called at example/Main.hs:6:1 in main:Main
99+ error, called at example/Main.hs:47:10 in main:Main
100+ fError, called at example/Main.hs:43:11 in main:Main
101+ f10, called at example/Main.hs:40:6 in main:Main
102+ f9, called at example/Main.hs:37:11 in main:Main
103+ f8, called at example/Main.hs:33:16 in main:Main
104+ f7, called at example/Main.hs:29:11 in main:Main
105+ f6, called at example/Main.hs:25:15 in main:Main
106+ f5, called at example/Main.hs:21:8 in main:Main
107+ f4, called at example/Main.hs:17:6 in main:Main
108+ f3, called at example/Main.hs:13:6 in main:Main
109+ f2, called at example/Main.hs:10:6 in main:Main
110+ f1, called at example/Main.hs:7:14 in main:Main
111+ main, called at example/Main.hs:7:1 in main:Main
103112```
104113
105−Great!!!
114+Great!!!
example/Main.hs+9−3
@@ -18,10 +18,10 @@ f3 = f4 0
1818
1919-- HsQualTy
2020f4 :: Show a => a -> Int
21−f4 _ = f5 0 0
21+f4 n = f5 (show n) 0
2222
2323-- HsFunTy
24−f5 :: Int -> Int -> Int
24+f5 :: String -> Int -> Int
2525f5 _ _ = head f6
2626
2727-- HsListTy
@@ -34,7 +34,13 @@ f7 = (fromJust f8, fromJust f8)
3434
3535-- HsAppTy
3636f8 :: Maybe Int
37−f8 = Just fError
37+f8 = Just f9
38+
39+f9 :: Int
40+f9 = f10
41+ where
42+ f10 :: Int
43+ f10 = fError
3844
3945-- HsTyVar
4046fError :: Int
haskell-stack-trace-plugin.cabal+52−53
@@ -1,77 +1,76 @@
1−name: haskell-stack-trace-plugin
2−version: 0.1.0.1
3−synopsis: haskell-stack-trace-plugin
4−description: This plugin allow implicitly add HasCallStack class to every top-level function for all module. Hence, we can to get completely continuous call stack.
5−homepage: https://github.com/waddlaw/haskell-stack-trace-plugin
6−bug-reports: https://github.com/waddlaw/haskell-stack-trace-plugin/issues
7−license: MIT
8−license-file: LICENSE
9−author: Shinya Yamaguchi
10−maintainer: ingronze@gmail.com
11−copyright: 2018-2020 Shinya Yamaguchi
12−category: Compiler Plugin, Development, Debug
13−build-type: Simple
14−extra-source-files: CHANGELOG.md, Readme.md
15−cabal-version: >=1.10
16−tested-with: GHC == 8.6.5
1+cabal-version: 2.4
2+name: haskell-stack-trace-plugin
3+version: 0.1.3.0
4+synopsis: haskell-stack-trace-plugin
5+description:
6+ This plugin allow implicitly add HasCallStack class to every top-level function for all module. Hence, we can to get completely continuous call stack.
7+
8+homepage: https://github.com/waddlaw/haskell-stack-trace-plugin
9+bug-reports:
10+ https://github.com/waddlaw/haskell-stack-trace-plugin/issues
11+
12+license: MIT
13+license-file: LICENSE
14+author: Shinya Yamaguchi
15+maintainer: a@wado.dev
16+copyright: 2018-2021 Shinya Yamaguchi
17+category: Compiler Plugin, Development, Debug
18+build-type: Simple
19+extra-source-files:
20+ CHANGELOG.md
21+ Readme.md
22+
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
1724
1825source-repository head
1926 type: git
2027 location: git://github.com/waddlaw/haskell-stack-trace-plugin
2128
2229flag dev
23− description: Turn on development settings.
24− manual: True
25− default: False
30+ description: Turn on development settings.
31+ manual: True
32+ default: False
2633
27−library
28− hs-source-dirs: src
29− build-depends:
30− base >=4.12 && <4.13,
31− ghc>=8.6.2 && <8.6.6
34+common common-opts
35+ build-depends: base >=4.12 && <4.18
36+ default-language: Haskell2010
3237
33− exposed-modules:
34− StackTrace.Plugin
38+library
39+ import: common-opts
40+ hs-source-dirs: src
41+ build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.0 || ^>=9.2 || ^>=9.4
42+ exposed-modules: StackTrace.Plugin
3543
3644 if flag(dev)
37− ghc-options: -Wall -Werror -Wcompat
38− -- -Wincomplete-record-updates
39− -Wincomplete-uni-patterns
40− -Wnoncanonical-monad-instances
41− -Wnoncanonical-monadfail-instances
42− -Wno-missing-home-modules
45+ ghc-options:
46+ -Wall -Werror -Wcompat -Wincomplete-uni-patterns
47+ -Wnoncanonical-monad-instances -Wno-missing-home-modules
48+
4349 else
44− ghc-options: -O2 -Wall
45− default-language: Haskell2010
50+ ghc-options: -Wall
4651
4752test-suite test
53+ import: common-opts
4854 main-is: Spec.hs
4955 hs-source-dirs: test
5056 type: exitcode-stdio-1.0
5157 build-depends:
52− base >=4.12 && <4.13,
53− bytestring >= 0.10.8 && <0.11,
54− hspec >= 2.7 && <2.8,
55− typed-process >= 0.2.6 && <0.2.9
56−
57− build-tool-depends:
58− hspec-discover:hspec-discover >= 2.7 && <2.8
58+ , bytestring >=0.10 && <0.12
59+ , hspec ^>=2.8
60+ , typed-process ^>=0.2
5961
60− other-modules: StackTrace.PluginSpec
62+ build-tool-depends: hspec-discover:hspec-discover ^>=2.8
63+ other-modules: StackTrace.PluginSpec
6164
6265 if flag(dev)
63− ghc-options: -Wall -Werror
64− else
65− ghc-options: -O2 -Wall
66+ ghc-options: -Wall -Werror
6667
67− default-language: Haskell2010
68+ else
69+ ghc-options: -Wall
6870
6971executable example
70− main-is: Main.hs
72+ import: common-opts
73+ main-is: Main.hs
7174 hs-source-dirs: example
72− default-language: Haskell2010
73− ghc-options:
74− -fplugin=StackTrace.Plugin
75− build-depends:
76− base >=4.12 && <4.13,
77− haskell-stack-trace-plugin
75+ ghc-options: -fplugin=StackTrace.Plugin -Wredundant-constraints
76+ build-depends: haskell-stack-trace-plugin
src/StackTrace/Plugin.hs+109−14
@@ -1,11 +1,23 @@
11{-# LANGUAGE RankNTypes #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
34module StackTrace.Plugin (plugin) where
45
56import Control.Arrow (first)
67import Data.Monoid (Any(Any, getAny))
8+import GHC.Types.SrcLoc
9+#if __GLASGOW_HASKELL__ >= 900
10+import GHC.Plugins
11+#else
12+
713import GhcPlugins
14+#endif
15+#if __GLASGOW_HASKELL__ >= 810
16+import GHC.Hs
17+#endif
18+#if __GLASGOW_HASKELL__ < 810
819import HsSyn
20+#endif
921
1022type Traversal s t a b
1123 = forall f. Applicative f =>
@@ -28,13 +40,30 @@ parsedPlugin _ _ pm = do
2840ghcStackModuleName :: ModuleName
2941ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
3042
43+#if __GLASGOW_HASKELL__ < 810
44+importDeclQualified :: Bool
45+importDeclQualified = True
46+#else
47+importDeclQualified :: ImportDeclQualifiedStyle
48+importDeclQualified = QualifiedPre
49+#endif
50+
3151ghcStackImport :: Located (ImportDecl (GhcPass p))
3252ghcStackImport =
33− noLoc $
53+ L srcSpan $
3454 (simpleImportDecl $ mkModuleName "GHC.Stack")
35− {ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName}
36−
55+ { ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName }
56+ where
57+ -- This is for GHC-9 related problems. @noLoc@ causes GHC to throw warnings
58+ -- about unused imports. Even if the import is used
59+ -- See: https://github.com/waddlaw/haskell-stack-trace-plugin/issues/16
60+ srcSpan = RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc "haskell-stack-trace-plugin:very-unique-file-name-to-avoid-collision" 1 1) Nothing
61+
62+#if __GLASGOW_HASKELL__ >= 900
63+updateHsModule :: HsModule -> HsModule
64+#else
3765updateHsModule :: HsModule GhcPs -> HsModule GhcPs
66+#endif
3867updateHsModule hsm =
3968 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
4069 where
@@ -56,7 +85,6 @@ updateHsModule hsm =
5685 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
5786 astTraversal = updateHsmodDecl
5887 . updateHsDecl
59− . updateSig
6088 . updateLHsSigWsType
6189 . updateLHsSigType
6290 . updateLHsType
@@ -65,10 +93,56 @@ updateHsModule hsm =
6593updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
6694updateHsmodDecl = traverse
6795
68−updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)
69−updateHsDecl f (SigD xSig s) = SigD xSig <$> f s
96+updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
97+updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s
98+updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind
7099updateHsDecl _ sig = pure sig
71100
101+updateHsBind :: Traversal' (HsBind GhcPs) (LHsSigWcType GhcPs)
102+updateHsBind f bind@FunBind {} = (\x -> bind {fun_matches = x}) <$> updateMatchGroup f (fun_matches bind)
103+updateHsBind _ bind = pure bind
104+
105+updateMatchGroup :: Traversal' (MatchGroup GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
106+updateMatchGroup f mg@MG {} = (\x -> mg {mg_alts = x}) <$> updateLLMatch f (mg_alts mg)
107+#if __GLASGOW_HASKELL__ < 900
108+updateMatchGroup _ mg = pure mg
109+#endif
110+
111+updateLocated :: Functor f => (a -> b -> f c) -> a -> Located b -> f (Located c)
112+updateLocated f g (L l e) = L l <$> f g e
113+
114+updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs)
115+updateLLMatch = updateLocated updateLMatches
116+
117+updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs)
118+updateLMatches f = traverse (updateLocated updateMatch f)
119+
120+updateMatch :: Traversal' (Match GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
121+updateMatch f m@Match {} = (\x -> m {m_grhss = x}) <$> updateGrhss f (m_grhss m)
122+#if __GLASGOW_HASKELL__ < 900
123+updateMatch _ m = pure m
124+#endif
125+
126+updateGrhss :: Traversal' (GRHSs GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
127+updateGrhss f grhss@GRHSs {} = (\x -> grhss {grhssLocalBinds = x}) <$> updateLHsLocalBinds f (grhssLocalBinds grhss)
128+#if __GLASGOW_HASKELL__ < 900
129+updateGrhss _ grhss = pure grhss
130+#endif
131+
132+updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs)
133+updateLHsLocalBinds = updateLocated updateLocalBinds
134+
135+updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs)
136+updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR
137+updateLocalBinds _ hsValBinds = pure hsValBinds
138+
139+updateHsValBindsLR :: Traversal' (HsValBindsLR GhcPs GhcPs) (LHsSigWcType GhcPs)
140+updateHsValBindsLR f (ValBinds xValBinds lHsBindsLR lSigs) = ValBinds xValBinds lHsBindsLR <$> updateLSigs f lSigs
141+updateHsValBindsLR _ valBinds = pure valBinds
142+
143+updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs)
144+updateLSigs f = traverse (updateLocated updateSig f)
145+
72146updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
73147updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
74148updateSig _ sig = pure sig
@@ -76,41 +150,62 @@ updateSig _ sig = pure sig
76150updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
77151updateLHsSigWsType f lhs@HsWC {} =
78152 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
153+#if __GLASGOW_HASKELL__ < 900
79154updateLHsSigWsType _ lhs = pure lhs
155+#endif
80156
81157updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
82158updateLHsSigType f lhs@HsIB {} =
83159 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160+#if __GLASGOW_HASKELL__ < 900
84161updateLHsSigType _ lhs = pure lhs
162+#endif
85163
86164updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
87165updateLHsType = traverse
88166
89167-- Main process
90168updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
91−updateHsType (HsQualTy xty ctxt body) =
92− flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
169+updateHsType ty@(HsQualTy xty ctxt body) =
170+ if hasHasCallStack (unLoc ctxt)
171+ then pure ty
172+ else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
93173updateHsType ty@HsTyVar {} =
94− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
174+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
95175updateHsType ty@HsAppTy {} =
96− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
176+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
97177updateHsType ty@HsFunTy {} =
98− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
178+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
99179updateHsType ty@HsListTy {} =
100− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
180+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
101181updateHsType ty@HsTupleTy {} =
102− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
182+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
103183updateHsType ty = pure ty
104184
185+#if __GLASGOW_HASKELL__ < 810
186+xQualTy :: NoExt
187+xQualTy = noExt
188+#else
189+xQualTy :: NoExtField
190+xQualTy = NoExtField
191+#endif
192+
105193flagASTModified :: a -> (Any, a)
106194flagASTModified a = (Any True, a)
107195
108196appendHSC :: HsContext GhcPs -> HsContext GhcPs
109197appendHSC cs = mkHSC : cs
110198
199+hasHasCallStack :: HsContext GhcPs -> Bool
200+hasHasCallStack = any (checkHsType . unLoc)
201+ where
202+ checkHsType :: HsType GhcPs -> Bool
203+ checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack")
204+ checkHsType _ = False
205+
111206-- make HasCallStack => constraint
112207mkHSC :: LHsType GhcPs
113−mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
208+mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
114209
115210lId :: Located (IdP GhcPs)
116211lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"
test/StackTrace/PluginSpec.hs+1−1
@@ -9,7 +9,7 @@ import System.Process.Typed
99spec :: Spec
1010spec = do
1111 output <- runIO exe
12− expected <- runIO $ BL.readFile "test/resource/ghc86.output"
12+ expected <- runIO $ BL.readFile "test/resource/ghc.output"
1313 it "integration test" $ output `shouldBe` expected
1414
1515
test/resource/ghc86.output → test/resource/ghc.outputrenamed+4−2
@@ -1,7 +1,9 @@
11example: fError
22CallStack (from HasCallStack):
3− error, called at example/Main.hs:41:10 in main:Main
4− fError, called at example/Main.hs:37:11 in main:Main
3+ error, called at example/Main.hs:47:10 in main:Main
4+ fError, called at example/Main.hs:43:11 in main:Main
5+ f10, called at example/Main.hs:40:6 in main:Main
6+ f9, called at example/Main.hs:37:11 in main:Main
57 f8, called at example/Main.hs:33:16 in main:Main
68 f7, called at example/Main.hs:29:11 in main:Main
79 f6, called at example/Main.hs:25:15 in main:Main