git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
swap
6624a5915 ahead, 0 behind
5 files changed+32−14
since splitsnapshots
unifiedsplit
CHANGELOG.md+1 Readme.md+6−4 example/Main.hs+2−2 haskell-stack-trace-plugin.cabal+3−3 src/StackTrace/Plugin.hs+20−5
CHANGELOG.md+1
@@ -5,6 +5,7 @@
55## 0.1.3.0
66
77- 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)
89
910## 0.1.2.0 -- 2021-05-21
1011
Readme.md+6−4
@@ -5,8 +5,10 @@
55
66This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack.
77
8−1. (implicitly) Import [GHC.Stack](https://hackage.haskell.org/package/base-4.12.0.0/docs/GHC-Stack.html) for all modules.
9−2. Add [HasCallStack](https://hackage.haskell.org/package/base-4.12.0.0/docs/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
1012
1113Requirement: (8.6 <= on GHC)
1214
@@ -32,10 +34,10 @@ f3 = f4 0
3234
3335-- HsQualTy
3436f4 :: Show a => a -> Int
35−f4 _ = f5 0 0
37+f4 n = f5 (show n) 0
3638
3739-- HsFunTy
38−f5 :: Int -> Int -> Int
40+f5 :: String -> Int -> Int
3941f5 _ _ = head f6
4042
4143-- HsListTy
example/Main.hs+2−2
@@ -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
haskell-stack-trace-plugin.cabal+3−3
@@ -32,13 +32,13 @@ flag dev
3232 default: False
3333
3434common common-opts
35− build-depends: base >=4.12 && <4.16
35+ build-depends: base >=4.12 && <4.18
3636 default-language: Haskell2010
3737
3838library
3939 import: common-opts
4040 hs-source-dirs: src
41− build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.0
41+ build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.0 || ^>=9.2 || ^>=9.4
4242 exposed-modules: StackTrace.Plugin
4343
4444 if flag(dev)
@@ -72,5 +72,5 @@ executable example
7272 import: common-opts
7373 main-is: Main.hs
7474 hs-source-dirs: example
75− ghc-options: -fplugin=StackTrace.Plugin
75+ ghc-options: -fplugin=StackTrace.Plugin -Wredundant-constraints
7676 build-depends: haskell-stack-trace-plugin
src/StackTrace/Plugin.hs+20−5
@@ -5,6 +5,7 @@ module StackTrace.Plugin (plugin) where
55
66import Control.Arrow (first)
77import Data.Monoid (Any(Any, getAny))
8+import GHC.Types.SrcLoc
89#if __GLASGOW_HASKELL__ >= 900
910import GHC.Plugins
1011#else
@@ -49,9 +50,14 @@ importDeclQualified = QualifiedPre
4950
5051ghcStackImport :: Located (ImportDecl (GhcPass p))
5152ghcStackImport =
52− noLoc $
53+ L srcSpan $
5354 (simpleImportDecl $ mkModuleName "GHC.Stack")
54− {ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
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
5561
5662#if __GLASGOW_HASKELL__ >= 900
5763updateHsModule :: HsModule -> HsModule
@@ -160,15 +166,17 @@ updateLHsType = traverse
160166
161167-- Main process
162168updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
163−updateHsType (HsQualTy xty ctxt body) =
164− 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
165173updateHsType ty@HsTyVar {} =
166174 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
167175updateHsType ty@HsAppTy {} =
168176 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
169177updateHsType ty@HsFunTy {} =
170178 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
171−updateHsType ty@HsListTy {} =
179+updateHsType ty@HsListTy {} =
172180 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
173181updateHsType ty@HsTupleTy {} =
174182 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
@@ -188,6 +196,13 @@ flagASTModified a = (Any True, a)
188196appendHSC :: HsContext GhcPs -> HsContext GhcPs
189197appendHSC cs = mkHSC : cs
190198
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+
191206-- make HasCallStack => constraint
192207mkHSC :: LHsType GhcPs
193208mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId