Avoid redundant-constraints warnings (fixes #9)

CHANGELOG.md

@@ -5,6 +5,7 @@
 ## 0.1.3.0
 
 - Added support `where` clause [#11](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/11) (@waddlaw)
+- Avoid redundant-constraints warnings [#12](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/12) (@waddlaw)
 
 ## 0.1.2.0 -- 2021-05-21
 

Readme.md

@@ -32,10 +32,10 @@ f3 = f4 0
 
 -- HsQualTy
 f4 :: Show a => a -> Int
-f4 _ = f5 0 0
+f4 n = f5 (show n) 0
 
 -- HsFunTy
-f5 :: Int -> Int -> Int
+f5 :: String -> Int -> Int
 f5 _ _ = head f6
 
 -- HsListTy

example/Main.hs

@@ -18,10 +18,10 @@ f3 = f4 0
 
 -- HsQualTy
 f4 :: Show a => a -> Int
-f4 _ = f5 0 0
+f4 n = f5 (show n) 0
 
 -- HsFunTy
-f5 :: Int -> Int -> Int
+f5 :: String -> Int -> Int
 f5 _ _ = head f6
 
 -- HsListTy

haskell-stack-trace-plugin.cabal

@@ -72,5 +72,5 @@ executable example
   import:         common-opts
   main-is:        Main.hs
   hs-source-dirs: example
-  ghc-options:    -fplugin=StackTrace.Plugin
+  ghc-options:    -fplugin=StackTrace.Plugin -Wredundant-constraints
   build-depends:  haskell-stack-trace-plugin

src/StackTrace/Plugin.hs

@@ -160,8 +160,10 @@ updateLHsType = traverse
 
 -- Main process
 updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
-updateHsType (HsQualTy xty ctxt body) =
-  flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
+updateHsType ty@(HsQualTy xty ctxt body) =
+  if hasHasCallStack (unLoc ctxt)
+    then pure ty
+    else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
 updateHsType ty@HsTyVar {} =
   flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
 updateHsType ty@HsAppTy {} =
@@ -188,6 +190,13 @@ flagASTModified a = (Any True, a)
 appendHSC :: HsContext GhcPs -> HsContext GhcPs
 appendHSC cs = mkHSC : cs
 
+hasHasCallStack :: HsContext GhcPs -> Bool
+hasHasCallStack = any (checkHsType . unLoc)
+  where
+    checkHsType :: HsType GhcPs -> Bool
+    checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc  "HasCallStack")
+    checkHsType _ = False
+
 -- make HasCallStack => constraint
 mkHSC :: LHsType GhcPs
 mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId