A GHC plugin for disabling some warnings.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
cabal-version: >= 1.10 | |
name: disable-warnings | |
version: 0.2022.5.24 | |
build-type: Simple | |
library | |
build-depends: base, ghc | |
default-language: Haskell2010 | |
exposed-modules: DisableWarnings |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module DisableWarnings where | |
import qualified Data.List as List | |
import qualified GHC.Data.Bag as Bag | |
import qualified GHC.Data.IOEnv as IOEnv | |
import qualified GHC.Plugins as Plugins | |
import qualified GHC.Tc.Types as Tc | |
import qualified GHC.Types.Error as Error | |
plugin :: Plugins.Plugin | |
plugin = Plugins.defaultPlugin | |
{ Plugins.pluginRecompile = Plugins.purePlugin | |
, Plugins.typeCheckResultAction = \_ _ _ -> do | |
env <- IOEnv.getEnv | |
IOEnv.updMutVarM (Tc.tcl_errs $ Tc.env_lcl env) $ \messages -> do | |
let | |
(warnings, errors) = Error.partitionMessages messages | |
newWarnings = Bag.filterBag shouldKeep warnings | |
pure . Error.mkMessages $ Bag.unionBags newWarnings errors | |
pure $ Tc.env_gbl env | |
} | |
shouldKeep :: Error.MsgEnvelope Error.DecoratedSDoc -> Bool | |
shouldKeep msgEnvelope = | |
let shown = show msgEnvelope | |
in | |
case Error.errMsgReason msgEnvelope of | |
Plugins.Reason Plugins.Opt_WarnDuplicateConstraints -> | |
notInfixOf "HasCallStack" shown | |
Plugins.Reason Plugins.Opt_WarnRedundantConstraints -> | |
notInfixOf "HasCallStack" shown | |
Plugins.Reason Plugins.Opt_WarnUnusedImports -> | |
notInfixOf "GHC.Stack" shown | |
_ -> True | |
notInfixOf :: Eq a => [a] -> [a] -> Bool | |
notInfixOf x = not . List.isInfixOf x |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment