git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
Merge pull request #12 from waddlaw/avoid-redundant-constraints-warnings

Avoid redundant-constraints warnings (fixes #9)

commit2ff39be031fa1670c11c2158d27b3414f630bdc0 authorShinya Yamaguchi <waddlaw@users.noreply.github.com> dateTue 25 May 2021, 12:19 (5 years ago) parentb1f31b34154d9e
5 files changed+17−7
compare with master
unifiedsplit
CHANGELOG.md+1 Readme.md+2−2 example/Main.hs+2−2 haskell-stack-trace-plugin.cabal+1−1 src/StackTrace/Plugin.hs+11−2
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+2−2
@@ -32,10 +32,10 @@ f3 = f4 0
3232
3333-- HsQualTy
3434f4 :: Show a => a -> Int
35−f4 _ = f5 0 0
35+f4 n = f5 (show n) 0
3636
3737-- HsFunTy
38−f5 :: Int -> Int -> Int
38+f5 :: String -> Int -> Int
3939f5 _ _ = head f6
4040
4141-- 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+1−1
@@ -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+11−2
@@ -160,8 +160,10 @@ updateLHsType = traverse
160160
161161-- Main process
162162updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
163−updateHsType (HsQualTy xty ctxt body) =
164− flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
163+updateHsType ty@(HsQualTy xty ctxt body) =
164+ if hasHasCallStack (unLoc ctxt)
165+ then pure ty
166+ else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
165167updateHsType ty@HsTyVar {} =
166168 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
167169updateHsType ty@HsAppTy {} =
@@ -188,6 +190,13 @@ flagASTModified a = (Any True, a)
188190appendHSC :: HsContext GhcPs -> HsContext GhcPs
189191appendHSC cs = mkHSC : cs
190192
193+hasHasCallStack :: HsContext GhcPs -> Bool
194+hasHasCallStack = any (checkHsType . unLoc)
195+ where
196+ checkHsType :: HsType GhcPs -> Bool
197+ checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack")
198+ checkHsType _ = False
199+
191200-- make HasCallStack => constraint
192201mkHSC :: LHsType GhcPs
193202mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId