diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/pinned-warnings.cabal b/pinned-warnings.cabal --- a/pinned-warnings.cabal +++ b/pinned-warnings.cabal @@ -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 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 diff --git a/src/GhcFacade.hs b/src/GhcFacade.hs --- a/src/GhcFacade.hs +++ b/src/GhcFacade.hs @@ -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 diff --git a/src/PinnedWarnings.hs b/src/PinnedWarnings.hs --- a/src/PinnedWarnings.hs +++ b/src/PinnedWarnings.hs @@ -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 diff --git a/src/ShowWarnings.hs b/src/ShowWarnings.hs --- a/src/ShowWarnings.hs +++ b/src/ShowWarnings.hs @@ -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 :: ()