pinned-warnings 0.1.0.1 → 0.1.0.2
raw patch · 5 files changed
+297/−73 lines, 5 filesdep +timedep +transformersdep ~basedep ~bytestring
Dependencies added: time, transformers
Dependency ranges changed: base, bytestring
Files
- README.md +10/−3
- pinned-warnings.cabal +8/−5
- src/GhcFacade.hs +31/−29
- src/PinnedWarnings.hs +241/−35
- src/ShowWarnings.hs +7/−1
README.md view
@@ -34,9 +34,16 @@ ``` With this you can simply use `:sw` to view warnings. +### Fixing warnings+There is limited functionality for automatically fixing warnings. Currently+only warnings due to redundant module import statements are corrected but there+is room for improvement in this regard.++To use this functionality, have the `ShowWarnings` module added to your GHCi+session then evaluate `fixWarnings`.+ ### Known limitations-- Warnings produced outside of module type checking are not captured, for- example those related to `.cabal` file omissions.-- Only the specified versions of GHC are supported+- Warnings that aren't for a specific module are not captured.+- Only the versions of GHC specified in the cabal file are supported (8.10, 9.0) - If you make changes to files and call `showWarnings` without reloading first, the messages may not be referencing the right code anymore.
pinned-warnings.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: pinned-warnings-version: 0.1.0.1+version: 0.1.0.2 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,16 +19,19 @@ extra-source-files: README.md CHANGELOG.md-tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1+tested-with: GHC ==8.10.4 || ==9.0.1 library exposed-modules: PinnedWarnings, ShowWarnings other-modules: GhcFacade- --default-extensions: ImportQualifiedPost build-depends: ghc >= 8.8 && < 9.1,- base >= 4.7 && < 5,- bytestring >= 0.10.10 && < 0.11,+ base >= 4.14.1 && < 5,+ bytestring >= 0.10.12 && < 0.11, containers >= 0.6.2 && < 0.7, directory >= 1.3.6 && < 1.4,+ time >= 1.9.3 && < 1.10,+ transformers >= 0.5.6 && < 0.6 hs-source-dirs: src default-language: Haskell2010+ ghc-options: -Wall+ -Wincomplete-patterns
src/GhcFacade.hs view
@@ -2,30 +2,32 @@ {-# LANGUAGE PatternSynonyms #-} module GhcFacade ( module X- , pattern RealSrcSpan'- , bytesFS'+ , pattern RealSrcLoc'+ , log_action' ) where -import qualified Data.ByteString.Char8 as BS- #if MIN_VERSION_ghc(9,0,0)-import GHC.Data.Bag as X-import GHC.Tc.Types as X-import GHC.Tc.Plugin as X-import GHC.Driver.Plugins as X hiding (TcPlugin)-import GHC.Data.IOEnv as X-import GHC.Core.Make as X-import GHC.Tc.Types.Evidence as X import GHC as X-import GHC.Data.FastString as X-import GHC.Utils.Error as X 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.Session+import GHC.Driver.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 import GHC.Types.Name.Occurrence as X+import GHC.Types.SrcLoc as X+import GHC.Utils.Error as X -#elif MIN_VERSION_ghc(8,8,0)+#elif MIN_VERSION_ghc(8,10,0) import Bag as X import Class as X+import Constraint as X import DynFlags as X import ErrUtils as X import FastString as X@@ -37,27 +39,27 @@ import OccName as X import Outputable as X import Plugins as X hiding (TcPlugin)+import SrcLoc as X import TcEvidence as X import TcPluginM as X import TcRnTypes as X #endif -#if MIN_VERSION_ghc(8,10,0) && __GLASGOW_HASKELL__ < 900-import Constraint as X-#endif--pattern RealSrcSpan' :: RealSrcSpan -> SrcSpan-pattern RealSrcSpan' s <-+pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc+pattern RealSrcLoc' s <- #if MIN_VERSION_ghc(9,0,1)- RealSrcSpan s x-#elif MIN_VERSION_ghc(8,8,0)- RealSrcSpan s+ RealSrcLoc s _+#elif MIN_VERSION_ghc(8,10,0)+ RealSrcLoc s #endif -bytesFS' :: FastString -> BS.ByteString-bytesFS' =-#if MIN_VERSION_ghc(8,10,0)- bytesFS-#elif MIN_VERSION_ghc(8,8,0)- BS.pack . unpackFS+log_action' :: LogAction -> (DynFlags -> Severity -> SrcSpan -> MsgDoc -> IO ()) -> LogAction+#if MIN_VERSION_ghc(9,0,1)+log_action' action withStuff dflags warnReason severity srcSpan msgDoc = do+ withStuff dflags severity srcSpan msgDoc+ action dflags warnReason severity srcSpan msgDoc+#elif MIN_VERSION_ghc(8,10,0)+log_action' action withStuff dflags warnReason severity srcSpan pprStyle msgDoc = do+ withStuff dflags severity srcSpan msgDoc+ action dflags warnReason severity srcSpan pprStyle msgDoc #endif
src/PinnedWarnings.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-} module PinnedWarnings ( plugin ) where@@ -6,45 +8,85 @@ import Control.Concurrent.MVar import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Trans.State import qualified Data.ByteString.Char8 as BS+import Data.Char (isSpace) import Data.IORef import Data.List+import Data.Monoid (Alt(..)) import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S+import Data.String (fromString)+import Data.Time import qualified System.Directory as Dir import System.IO.Unsafe (unsafePerformIO)+import qualified Text.ParserCombinators.ReadP as P import qualified GhcFacade as Ghc -type ModuleFile = BS.ByteString+--------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------- +type ModuleFile = Ghc.FastString++newtype Warning = Warning { unWarning :: Ghc.WarnMsg }++instance Eq Warning where+ Warning a == Warning b = show a == show b++instance Ord Warning where+ compare (Warning a) (Warning b) = compare (show a) (show b)++newtype MonoidMap k a = MonoidMap (M.Map k a)+ deriving Foldable++instance (Ord k, Semigroup a) => Semigroup (MonoidMap k a) where+ MonoidMap a <> MonoidMap b = MonoidMap $ M.unionWith (<>) a b++instance (Ord k, Semigroup a) => Monoid (MonoidMap k a) where+ mempty = MonoidMap M.empty++type SrcSpanKey = (Ghc.RealSrcLoc, Ghc.RealSrcLoc)++type WarningsWithModDate =+ ( Alt Maybe UTCTime -- Last time the module was modified+ , MonoidMap SrcSpanKey (S.Set Warning)+ )+ -- The infamous mutable global trick. -- Needed to track the pinned warnings during and after compilation.-globalState :: MVar (M.Map ModuleFile Ghc.WarningMessages)+globalState :: MVar (M.Map ModuleFile WarningsWithModDate) globalState = unsafePerformIO $ newMVar mempty {-# NOINLINE globalState #-} +--------------------------------------------------------------------------------+-- Plugin+--------------------------------------------------------------------------------+ plugin :: Ghc.Plugin plugin = Ghc.defaultPlugin { Ghc.tcPlugin = const $ Just tcPlugin- , Ghc.typeCheckResultAction = const insertModuleWarnings+ , Ghc.parsedResultAction = const resetPinnedWarnsForMod+ , Ghc.dynflagsPlugin = const addWarningCapture } tcPlugin :: Ghc.TcPlugin tcPlugin = Ghc.TcPlugin { Ghc.tcPluginInit = initTcPlugin- , Ghc.tcPluginSolve = \(sw, counterRef) _ _ wanteds ->- checkWanteds sw counterRef wanteds+ , Ghc.tcPluginSolve = \(sw, fw, counterRef) _ _ wanteds ->+ checkWanteds sw fw counterRef wanteds , Ghc.tcPluginStop = const $ pure () } -initTcPlugin :: Ghc.TcPluginM (Ghc.TyCon, IORef Int)+initTcPlugin :: Ghc.TcPluginM (Ghc.TyCon, Ghc.TyCon, IORef Int) initTcPlugin =- (,) <$> lookupShowWarnings- <*> Ghc.tcPluginIO (newIORef 0)+ (,,) <$> lookupShowWarnings+ <*> lookupFixWarnings+ <*> Ghc.tcPluginIO (newIORef 0) -- | Gets a reference to the 'ShowWarnings' constraint lookupShowWarnings :: Ghc.TcPluginM Ghc.TyCon@@ -54,19 +96,34 @@ (Just "pinned-warnings") case result of- Ghc.Found _ mod -> do- name <- Ghc.lookupOrig mod $ Ghc.mkTcOcc "ShowWarnings"+ Ghc.Found _ mod' -> do+ name <- Ghc.lookupOrig mod' $ Ghc.mkTcOcc "ShowWarnings" Ghc.classTyCon <$> Ghc.tcLookupClass name _ -> error "ShowWarnings module not found" --- | If any wanted constraints are for 'ShowWarnings', then inject any pinned+-- | Gets a reference to the 'FixWarnings' constraint+lookupFixWarnings :: Ghc.TcPluginM Ghc.TyCon+lookupFixWarnings = do+ result <- Ghc.findImportedModule+ (Ghc.mkModuleName "ShowWarnings")+ (Just "pinned-warnings")++ case result of+ Ghc.Found _ mod' -> do+ name <- Ghc.lookupOrig mod' $ Ghc.mkTcOcc "FixWarnings"+ Ghc.classTyCon <$> Ghc.tcLookupClass name++ _ -> error "ShowWarnings module not found"++-- | If any wanted constraints are for 'ShowWarnings', then inject the pinned -- warnings into GHC. checkWanteds :: Ghc.TyCon+ -> Ghc.TyCon -> IORef Int -> [Ghc.Ct] -> Ghc.TcPluginM Ghc.TcPluginResult-checkWanteds sw counterRef+checkWanteds sw fw counterRef = fmap (flip Ghc.TcPluginOk [] . catMaybes) . traverse go where@@ -77,21 +134,31 @@ -- for some reason warnings only appear if they are added on -- particular iterations. when (counter == 2) addWarningsToContext+ incrementCounter - Ghc.tcPluginIO $ modifyIORef' counterRef succ+ pure $ Just (Ghc.EvExpr Ghc.unitExpr, ct) + | Ghc.classTyCon cls == fw = do+ counter <- Ghc.tcPluginIO $ readIORef counterRef++ when (counter == 0) (Ghc.tcPluginIO fixWarnings)+ incrementCounter+ pure $ Just (Ghc.EvExpr Ghc.unitExpr, ct) go _ = pure Nothing + incrementCounter =+ Ghc.tcPluginIO $ modifyIORef' counterRef succ+ -- | Add warnings from the global state back into the GHC context addWarningsToContext :: Ghc.TcPluginM () addWarningsToContext = do errsRef <- Ghc.tcl_errs . snd <$> Ghc.getEnvs - pruneDeleted- pinnedWarns <- Ghc.listToBag- . foldMap Ghc.bagToList+ Ghc.tcPluginIO pruneDeleted+ pinnedWarns <- Ghc.listToBag . map unWarning+ . foldMap (foldMap S.toList . snd) <$> Ghc.tcPluginIO (readMVar globalState) Ghc.tcPluginIO . atomicModifyIORef' errsRef@@ -99,34 +166,173 @@ ((Ghc.unionBags pinnedWarns warnings, errors), ()) -- | Remove warnings for modules that no longer exist-pruneDeleted :: Ghc.TcPluginM ()-pruneDeleted = Ghc.tcPluginIO . modifyMVar_ globalState $ \warns -> do+pruneDeleted :: IO ()+pruneDeleted = modifyMVar_ globalState $ \warns -> do let mods = M.keys warns deletedMods <-- filterM (fmap not . Dir.doesFileExist . BS.unpack)+ filterM (fmap not . Dir.doesFileExist . Ghc.unpackFS) mods pure $ foldl' (flip M.delete) warns deletedMods --- | After type checking a module, pin any warnings pertaining to it.-insertModuleWarnings :: Ghc.ModSummary -> Ghc.TcGblEnv -> Ghc.TcM Ghc.TcGblEnv-insertModuleWarnings modSummary tcGblEnv = do- lclErrsRef <- Ghc.tcl_errs . Ghc.env_lcl <$> Ghc.getEnv- (warns, _) <- liftIO $ readIORef lclErrsRef-- let modFile = BS.pack $ Ghc.ms_hspp_file modSummary- onlyThisMod w =- case Ghc.errMsgSpan w of- Ghc.RealSrcSpan' span ->- Ghc.bytesFS' (Ghc.srcSpanFile span) == modFile- _ -> False-- warnsForMod = Ghc.filterBag onlyThisMod warns+-- | Removes currently pinned warnings for a module and updates the timestamp.+-- This occurs before any new warnings are captured for the module.+resetPinnedWarnsForMod+ :: Ghc.ModSummary+ -> Ghc.HsParsedModule+ -> Ghc.Hsc Ghc.HsParsedModule+resetPinnedWarnsForMod modSummary parsedModule = do+ let modFile = fromString $ Ghc.ms_hspp_file modSummary+ modifiedTime = Alt . Just $ Ghc.ms_hs_date modSummary -- Replace any existing pinned warnings with new ones for this module liftIO . modifyMVar_ globalState- $ pure . M.insert modFile warnsForMod+ $ pure . M.insert modFile (modifiedTime, mempty) - pure tcGblEnv+ pure parsedModule++-- | Taps into the log action to capture the warnings that GHC emits.+addWarningCapture :: Ghc.DynFlags -> IO Ghc.DynFlags+addWarningCapture dynFlags = do+ pure dynFlags+ { Ghc.log_action = Ghc.log_action' (Ghc.log_action dynFlags) $+ \dyn severity srcSpan msgDoc -> do+ case (severity, Ghc.srcSpanFileName_maybe srcSpan) of+ (Ghc.SevWarning, Just modFile)+ | Ghc.RealSrcLoc' start <- Ghc.srcSpanStart srcSpan+ , Ghc.RealSrcLoc' end <- Ghc.srcSpanEnd srcSpan+ -> do+ let warn = M.singleton (start, end)+ . S.singleton+ . Warning+ $ Ghc.mkWarnMsg dyn srcSpan Ghc.alwaysQualify msgDoc++ modifyMVar_ globalState+ $ pure+ . M.insertWith (<>) modFile+ (mempty, MonoidMap warn)++ _ -> pure ()+ }++fixWarnings :: IO ()+fixWarnings = do+ pruneDeleted+ modifyMVar_ globalState $ traverse fixWarning++-- | Fixes applicable warning and returns 'False' if all warnings for the+-- corresponding span should be removed.+fixWarning :: WarningsWithModDate -> IO WarningsWithModDate+fixWarning (Alt (Just modifiedAt), MonoidMap warnMap) = do+ (pairs, files) <- (`runStateT` M.empty)+ . flip filterM (reverse $ M.toList warnMap) $ \case+ ((start, end), warnSet)+ | Alt (Just reWarn)+ <- foldMap (Alt . parseRedundancyWarn) warnSet+ -> do+ let file = Ghc.unpackFS $ Ghc.srcLocFile start++ mCached <- gets (M.lookup file)++ srcLines <-+ maybe (liftIO . fmap BS.lines $ BS.readFile file)+ pure+ mCached++ mNewSrcLines <- liftIO $+ fixRedundancyWarning start end modifiedAt reWarn srcLines++ case mNewSrcLines of+ Nothing -> pure True++ Just newSrcLines -> do+ modify' $ M.insert file newSrcLines++ pure False++ _ -> pure True++ _ <- M.traverseWithKey+ (\file ls -> do+ BS.writeFile file $ BS.unlines ls+ putStrLn $ "'" <> file <> "' has been edited"+ )+ files++ pure (Alt Nothing, MonoidMap $ M.fromList pairs)++fixWarning w = pure w++--------------------------------------------------------------------------------+-- Redundant import warnings+--------------------------------------------------------------------------------++-- | Redundant import warnings+data RedundancyWarn+ = WholeModule+ | IndividualThings [String]+ deriving Show++-- | Attempt to fix redundant import warning.+fixRedundancyWarning :: Ghc.RealSrcLoc+ -> Ghc.RealSrcLoc+ -> UTCTime+ -> RedundancyWarn+ -> [BS.ByteString]+ -> IO (Maybe [BS.ByteString])+fixRedundancyWarning start end lastModified warn srcLines = do+ let file = Ghc.unpackFS $ Ghc.srcLocFile start++ fileModified <- Dir.getModificationTime file++ if fileModified /= lastModified+ then do+ putStrLn $ "'" <> file <> "' has been modified since warnings were last collected."+ pure Nothing++ else+ case warn of+ WholeModule -> do+ let startLine = Ghc.srcLocLine start+ endLine = Ghc.srcLocLine end+ (before, rest) = splitAt (startLine - 1) srcLines+ (_, after) = splitAt (endLine - startLine + 1) rest++ pure . Just $ before <> after++ -- TODO+ IndividualThings _things -> pure Nothing++parseRedundancyWarn :: Warning -> Maybe RedundancyWarn+parseRedundancyWarn (Warning warn) =+ case P.readP_to_S redundancyWarnParser (show warn) of+ [(w, "")] -> Just w+ _ -> Nothing++redundancyWarnParser :: P.ReadP RedundancyWarn+redundancyWarnParser = do+ _ <- P.string "The import of ‘"++ inQuotes <-+ P.sepBy1 (P.munch1 $ \c -> not (isSpace c) && c /= ',' && c /= '’')+ (P.char ',' <* P.skipSpaces)++ _ <- P.char '’'++ let terms+ = IndividualThings inQuotes+ <$ ( P.skipSpaces+ *> P.string "from module ‘"+ *> P.munch1 (/= '’')+ *> P.string "’ is redundant"+ )++ wholeMod = WholeModule <$ (P.skipSpaces *> P.string "is redundant")++ result <- P.choice [terms, wholeMod]++ _ <- P.munch (const True)++ pure result
src/ShowWarnings.hs view
@@ -1,9 +1,15 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} module ShowWarnings ( ShowWarnings , showWarnings+ , FixWarnings+ , fixWarnings ) where class ShowWarnings where+ -- | Display currently pinned warnings showWarnings :: ()++class FixWarnings where+ -- | Auto-fixes certain types of warnings+ fixWarnings :: ()