pinned-warnings 0.1.0.12 → 0.1.0.13
raw patch · 5 files changed
+99/−10 lines, 5 filesdep ~ghc
Dependency ranges changed: ghc
Files
- CHANGELOG.md +4/−0
- pinned-warnings.cabal +3/−3
- src/Internal/GhcFacade.hs +29/−1
- src/Internal/Types.hs +14/−3
- src/PinnedWarnings.hs +49/−3
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pinned-warnings +## 0.1.0.13++* Support GHC 9.4.x+ ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world.
pinned-warnings.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: pinned-warnings-version: 0.1.0.12+version: 0.1.0.13 synopsis: Preserve warnings in a GHCi session description: Please see the README on GitHub at <https://github.com/aaronallen8455/pinned-warnings#readme> homepage: https://github.com/aaronallen8455/pinned-warnings#readme@@ -19,7 +19,7 @@ extra-source-files: README.md CHANGELOG.md-tested-with: GHC ==8.10.4 || ==8.10.5 || ==8.10.6 || ==8.10.7 || ==9.0.1 || ==9.2.2+tested-with: GHC ==8.10.4 || ==8.10.5 || ==8.10.6 || ==8.10.7 || ==9.0.1 || ==9.2.2 || ==9.4.2 library exposed-modules: PinnedWarnings@@ -28,7 +28,7 @@ Internal.GhcFacade Internal.Types - build-depends: ghc >= 8.10 && < 9.3,+ build-depends: ghc >= 8.10 && < 9.5, base >= 4.14.1 && < 5, bytestring >= 0.10.12, containers >= 0.6.2,
src/Internal/GhcFacade.hs view
@@ -7,9 +7,10 @@ #else , log_action' #endif+ , TcPluginResult' ) where -#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0) import GHC as X hiding (FunDep) import GHC.Core.Class as X import GHC.Core.Make as X@@ -18,7 +19,28 @@ import GHC.Data.IOEnv as X import GHC.Driver.Plugins as X hiding (TcPlugin) import GHC.Driver.Env.Types as X+import GHC.Tc.Errors.Types as X import GHC.Tc.Plugin as X+import GHC.Tc.Types as X hiding (DefaultingPlugin)+import GHC.Tc.Types.Constraint as X+import GHC.Tc.Types.Evidence as X+import GHC.Types.Error as X+import GHC.Types.Name.Occurrence as X+import GHC.Types.SrcLoc as X+import GHC.Utils.Error as X+import GHC.Utils.Logger as X+import GHC.Utils.Outputable as X++#elif MIN_VERSION_ghc(9,2,0)+import GHC as X hiding (FunDep)+import GHC.Core.Class as X+import GHC.Core.Make as X+import GHC.Data.Bag as X+import GHC.Data.FastString as X+import GHC.Data.IOEnv as X+import GHC.Driver.Plugins as X hiding (TcPlugin)+import GHC.Driver.Env.Types as X+import GHC.Tc.Plugin as X import GHC.Tc.Types as X import GHC.Tc.Types.Constraint as X import GHC.Tc.Types.Evidence as X@@ -89,4 +111,10 @@ log_action' action withStuff dflags warnReason severity srcSpan pprStyle msgDoc = do withStuff dflags severity srcSpan msgDoc action dflags warnReason severity srcSpan pprStyle msgDoc+#endif++#if MIN_VERSION_ghc(9,4,0)+type TcPluginResult' = X.TcPluginSolveResult+#else+type TcPluginResult' = X.TcPluginResult #endif
src/Internal/Types.hs view
@@ -10,6 +10,7 @@ ) where import qualified Data.Map.Strict as M+import Data.Ord (comparing) import qualified Data.Set as S import Data.Time @@ -19,7 +20,9 @@ newtype Warning = Warning { unWarning-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0)+ :: Ghc.MsgEnvelope Ghc.DiagnosticMessage+#elif MIN_VERSION_ghc(9,2,0) :: Ghc.MsgEnvelope Ghc.DecoratedSDoc #else :: Ghc.WarnMsg@@ -28,12 +31,20 @@ showWarning :: Warning -> String showWarning =-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0) let sdocCtx = Ghc.defaultSDocContext { Ghc.sdocPrintUnicodeSyntax = True , Ghc.sdocCanUseUnicode = True } in foldMap (Ghc.showSDocOneLine sdocCtx)+ . Ghc.unDecorated . Ghc.diagnosticMessage+ . Ghc.errMsgDiagnostic . unWarning+#elif MIN_VERSION_ghc(9,2,0)+ let sdocCtx = Ghc.defaultSDocContext+ { Ghc.sdocPrintUnicodeSyntax = True+ , Ghc.sdocCanUseUnicode = True+ }+ in foldMap (Ghc.showSDocOneLine sdocCtx) . Ghc.unDecorated . Ghc.errMsgDiagnostic . unWarning #else show . unWarning@@ -43,7 +54,7 @@ Warning a == Warning b = show a == show b instance Ord Warning where- compare (Warning a) (Warning b) = compare (show a) (show b)+ compare = comparing (show . unWarning) newtype MonoidMap k a = MonoidMap (M.Map k a) deriving Foldable
src/PinnedWarnings.hs view
@@ -52,6 +52,9 @@ { Ghc.tcPluginInit = initTcPlugin , Ghc.tcPluginSolve = \pluginState _ _ -> checkWanteds pluginState , Ghc.tcPluginStop = const $ pure ()+#if MIN_VERSION_ghc(9,4,0)+ , Ghc.tcPluginRewrite = mempty+#endif } data PluginState =@@ -75,7 +78,11 @@ lookupClass className = do result <- Ghc.findImportedModule (Ghc.mkModuleName "ShowWarnings")+#if MIN_VERSION_ghc(9,4,0)+ Ghc.NoPkgQual+#else (Just "pinned-warnings")+#endif case result of Ghc.Found _ mod' -> do@@ -88,7 +95,7 @@ -- warnings into GHC. checkWanteds :: PluginState -> [Ghc.Ct]- -> Ghc.TcPluginM Ghc.TcPluginResult+ -> Ghc.TcPluginM Ghc.TcPluginResult' checkWanteds pluginState = fmap (flip Ghc.TcPluginOk [] . catMaybes) . traverse go@@ -136,8 +143,12 @@ <$> Ghc.tcPluginIO (readMVar globalState) Ghc.tcPluginIO . atomicModifyIORef' errsRef-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0) $ \messages ->+ (Ghc.mkMessages ((fmap . fmap) Ghc.TcRnUnknownMessage pinnedWarns)+ `Ghc.unionMessages` messages, ())+#elif MIN_VERSION_ghc(9,2,0)+ $ \messages -> (Ghc.mkMessages pinnedWarns `Ghc.unionMessages` messages, ()) #else $ \(warnings, errors) ->@@ -161,8 +172,13 @@ -- This occurs before any new warnings are captured for the module. resetPinnedWarnsForMod :: Ghc.ModSummary+#if MIN_VERSION_ghc(9,4,0)+ -> Ghc.ParsedResult+ -> Ghc.Hsc Ghc.ParsedResult+#else -> Ghc.HsParsedModule -> Ghc.Hsc Ghc.HsParsedModule+#endif resetPinnedWarnsForMod modSummary parsedModule = do let modFile = fromString $ Ghc.ms_hspp_file modSummary @@ -172,7 +188,37 @@ pure parsedModule -- | Taps into the log action to capture the warnings that GHC emits.-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0)+addWarningCapture :: Ghc.HscEnv -> Ghc.HscEnv+addWarningCapture hscEnv =+ hscEnv+ { Ghc.hsc_logger = Ghc.pushLogHook warningsHook (Ghc.hsc_logger hscEnv)+ }+ where+ warningsHook :: Ghc.LogAction -> Ghc.LogAction+ warningsHook logAction dynFlags messageClass srcSpan sdoc = do+ case messageClass of+ Ghc.MCDiagnostic Ghc.SevWarning _+ | Ghc.RealSrcLoc' start <- Ghc.srcSpanStart srcSpan+ , Ghc.RealSrcLoc' end <- Ghc.srcSpanEnd srcSpan+ , Just modFile <- Ghc.srcSpanFileName_maybe srcSpan+ -> do+ let diag =+ Ghc.DiagnosticMessage+ { Ghc.diagMessage = Ghc.mkSimpleDecorated sdoc+ , Ghc.diagReason = Ghc.WarningWithoutFlag+ , Ghc.diagHints = []+ }+ warn = Warning Ghc.MsgEnvelope+ { Ghc.errMsgSpan = srcSpan+ , Ghc.errMsgContext = Ghc.neverQualify+ , Ghc.errMsgDiagnostic = diag+ , Ghc.errMsgSeverity = Ghc.SevWarning+ }+ addWarningToGlobalState start end modFile warn+ _ -> pure ()+ logAction dynFlags messageClass srcSpan sdoc+#elif MIN_VERSION_ghc(9,2,0) addWarningCapture :: Ghc.HscEnv -> Ghc.HscEnv addWarningCapture hscEnv = hscEnv