diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -44,6 +44,6 @@ ### Known limitations - 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) +- Only the versions of GHC specified in the cabal file are supported (8.10, 9.0, 9.2) - 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.8 +version: 0.1.0.9 synopsis: Preserve warnings in a GHCi session description: Please see the README on GitHub at 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 || ==9.0.1 +tested-with: GHC ==8.10.4 || ==8.10.5 || ==8.10.6 || ==8.10.7 || ==9.0.1 || ==9.2.1 library exposed-modules: PinnedWarnings @@ -28,12 +28,12 @@ Internal.GhcFacade Internal.Types - build-depends: ghc >= 8.8 && < 9.1, + build-depends: ghc >= 8.10 && < 9.3, 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, + bytestring >= 0.10.12, + containers >= 0.6.2, + directory >= 1.3.6, + time >= 1.9.3, transformers >= 0.5.6 && < 0.6 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Internal/FixWarnings.hs b/src/Internal/FixWarnings.hs --- a/src/Internal/FixWarnings.hs +++ b/src/Internal/FixWarnings.hs @@ -31,19 +31,18 @@ , warningsMap = MonoidMap warnMap } = do - let file = Ghc.unpackFS modFile - lastModification <- liftIO $ Dir.getModificationTime file + lastModification <- liftIO $ Dir.getModificationTime modFile -- Do not attempt to edit if file has been touched since last reload if lastModification /= modifiedAt then do putStrLn - $ "'" <> file + $ "'" <> modFile <> "' has been modified since last compiled. Reload and try again." pure warns else do - curSrcLines <- liftIO . fmap BS.lines $ BS.readFile file + curSrcLines <- liftIO . fmap BS.lines $ BS.readFile modFile -- State is used to keep the contents of the source file in memory while -- warnings for the file are fixed. @@ -71,8 +70,8 @@ when (length pairs /= length warnMap) $ do -- write the changes to the file - BS.writeFile file $ BS.unlines newFileContents - putStrLn $ "'" <> file <> "' has been edited" + BS.writeFile modFile $ BS.unlines newFileContents + putStrLn $ "'" <> modFile <> "' has been edited" pure MkWarningsWithModDate { lastUpdated = lastModification @@ -85,26 +84,29 @@ -> RedundancyWarn -> [BS.ByteString] -> Maybe [BS.ByteString] -fixRedundancyWarning startLine warn srcLines = +fixRedundancyWarning startLine warn srcLines = do -- The span for redundant errors is only ever a single line. This means we -- must search for the end of the import statement. If this a warning about a -- single import thing, the span line may not encompass the start of the -- import statement so we must search for that as well. - let (before, stmt : after) = splitAt (startLine - 1) srcLines + (before, stmt : after) <- Just $ splitAt (startLine - 1) srcLines - isStart bs = "import" `BS.isPrefixOf` BS.dropSpace bs + let isStart bs = "import" `BS.isPrefixOf` BS.dropSpace bs - (before', stmt') - | isStart stmt = (before, [stmt]) - | otherwise = - let (inS, st : rs) = break isStart $ stmt : reverse before - in (reverse rs, st : reverse inS) + -- If the first line is not the start of the import declaration, search for + -- it in the preceding lines. + (before', stmt') <- + if isStart stmt + then Just (before, [stmt]) + else do + (inS, st : rs) <- Just . break isStart $ stmt : reverse before + Just (reverse rs, st : reverse inS) - (stmt'', after') = splitAtImportEnd $ stmt' <> after + let (stmt'', after') = splitAtImportEnd $ stmt' <> after hasExplicitList - -- Check the next line to see if contains an explicit import list + -- Check the next line to see if it contains an explicit import list | a : _ <- after , BS.length (BS.takeWhile isSpace a) > BS.length (BS.takeWhile isSpace stmt) @@ -112,17 +114,20 @@ = True | otherwise = isJust (BS.elemIndex '(' stmt) - in case warn of - WholeModule - | hasExplicitList -> Just $ before <> after' - | otherwise -> Just $ before <> after + case warn of + WholeModule + | hasExplicitList -> Just $ before <> after' + | otherwise -> Just $ before <> after - IndividualThings things -> - (<> after') . (before' <>) . BS.lines <$> - foldM fixRedundantThing - (BS.unlines stmt'') - things + IndividualThings things -> + (<> after') . (before' <>) . BS.lines <$> + foldM fixRedundantThing + (BS.unlines stmt'') + things +-- | Splits at the end of an import with an explicit list by counting the +-- number of opening and closing parens. If the main parens is closed, then +-- that marks the end of the import. splitAtImportEnd :: [BS.ByteString] -> ([BS.ByteString], [BS.ByteString]) splitAtImportEnd ls = first reverse $ go 0 0 ([], ls) where go o c acc @@ -143,18 +148,8 @@ -- - Semicolon layout fixRedundantThing :: BS.ByteString -> String -> Maybe BS.ByteString fixRedundantThing stmt thing - | (start, match) <- BS.breakSubstring thingBS stmt - , not (BS.null match) - , isSeparator $ BS.drop thingLen match - , isCellStart $ BS.reverse start - - -- check that there isn't a second valid match - , (start2, match2) <- BS.breakSubstring thingBS (BS.drop thingLen match) - , BS.null match2 - || not - ( isSeparator (BS.drop thingLen match2) - && isCellStart (BS.reverse start2) - ) + -- Bail if there is more than one valid candidate + | [(start, match)] <- filter isValidCandidate $ findCandidates stmt -- preserve the whitespace immediately after the ',' or '(' , let start' = let (s, e) = BS.breakEnd (`elem` [',', '(']) start @@ -177,6 +172,23 @@ where bs = BS.pack thing thingLen = BS.length thingBS + -- A list of substring matches where each element is a pair of the prefix + -- with the match and remaining suffix. + findCandidates "" = [] + findCandidates inp = + let (pre, match) = BS.breakSubstring thingBS inp + in (pre, match) : + ( first ((pre <> thingBS) <>) + <$> findCandidates (BS.drop thingLen match) + ) + + -- Test if a match pair is valid by checking that the match is not a + -- substring of a different identifier + isValidCandidate (start, match) = + not (BS.null match) + && isSeparator (BS.drop thingLen match) + && isCellStart (BS.reverse start) + isSeparator = headPred $ \c -> isSpace c || c `elem` [',', '(', ')'] isCellStart = headPred $ \c -> isSpace c || c `elem` [',', '('] isOperator = headPred (`elem` opChars) @@ -208,8 +220,8 @@ deriving Show parseRedundancyWarn :: Warning -> Maybe RedundancyWarn -parseRedundancyWarn (Warning warn) = - case P.readP_to_S redundancyWarnParser (show warn) of +parseRedundancyWarn warn = + case P.readP_to_S redundancyWarnParser (showWarning warn) of [(w, "")] -> Just w _ -> Nothing @@ -219,7 +231,7 @@ <|> P.string "The qualified import of ‘" inQuotes <- - P.sepBy1 (P.munch1 $ \c -> not (isSpace c) && c /= ',' && c /= '’') + P.sepBy1 (P.munch1 $ \c -> not (isSpace c) && c `notElem` [',', '’']) (P.char ',' <* P.skipSpaces) _ <- P.char '’' diff --git a/src/Internal/GhcFacade.hs b/src/Internal/GhcFacade.hs --- a/src/Internal/GhcFacade.hs +++ b/src/Internal/GhcFacade.hs @@ -3,10 +3,33 @@ module Internal.GhcFacade ( module X , pattern RealSrcLoc' +#if MIN_VERSION_ghc(9,2,0) +#else , log_action' +#endif ) where -#if MIN_VERSION_ghc(9,0,0) +#if 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 +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,0,0) import GHC as X import GHC.Core.Class as X import GHC.Core.Make as X @@ -53,8 +76,12 @@ RealSrcLoc s #endif +#if MIN_VERSION_ghc(9,2,0) +#else log_action' :: LogAction -> (DynFlags -> Severity -> SrcSpan -> MsgDoc -> IO ()) -> LogAction -#if MIN_VERSION_ghc(9,0,1) +#endif +#if MIN_VERSION_ghc(9,2,0) +#elif 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 diff --git a/src/Internal/Types.hs b/src/Internal/Types.hs --- a/src/Internal/Types.hs +++ b/src/Internal/Types.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} module Internal.Types ( ModuleFile , Warning(..) + , showWarning , MonoidMap(..) , SrcSpanKey , WarningsWithModDate(..) @@ -13,9 +15,29 @@ import qualified Internal.GhcFacade as Ghc -type ModuleFile = Ghc.FastString +type ModuleFile = String -newtype Warning = Warning { unWarning :: Ghc.WarnMsg } +newtype Warning = Warning + { unWarning +#if MIN_VERSION_ghc(9,2,0) + :: Ghc.MsgEnvelope Ghc.DecoratedSDoc +#else + :: Ghc.WarnMsg +#endif + } + +showWarning :: Warning -> String +showWarning = +#if 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 +#endif instance Eq Warning where Warning a == Warning b = show a == show b diff --git a/src/PinnedWarnings.hs b/src/PinnedWarnings.hs --- a/src/PinnedWarnings.hs +++ b/src/PinnedWarnings.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module PinnedWarnings ( plugin ) where @@ -29,12 +30,19 @@ -- Plugin -------------------------------------------------------------------------------- +-- dynFlagsPlugin is being removed in future GHC. There is instead a way to +-- modify the HscEnv and there is a Logger type on HscEnv that should allow +-- for hooking into messages. plugin :: Ghc.Plugin plugin = Ghc.defaultPlugin { Ghc.tcPlugin = const $ Just tcPlugin , Ghc.parsedResultAction = const resetPinnedWarnsForMod +#if MIN_VERSION_ghc(9,2,0) + , Ghc.driverPlugin = const (pure . addWarningCapture) +#else , Ghc.dynflagsPlugin = const (pure . addWarningCapture) +#endif , Ghc.pluginRecompile = Ghc.purePlugin } @@ -128,8 +136,13 @@ <$> Ghc.tcPluginIO (readMVar globalState) Ghc.tcPluginIO . atomicModifyIORef' errsRef +#if MIN_VERSION_ghc(9,2,0) + $ \messages -> + (Ghc.mkMessages pinnedWarns `Ghc.unionMessages` messages, ()) +#else $ \(warnings, errors) -> ((Ghc.unionBags pinnedWarns warnings, errors), ()) +#endif -- | Remove warnings for modules that no longer exist pruneDeleted :: IO () @@ -139,7 +152,7 @@ mods = M.keys warns' deletedMods <- - filterM (fmap not . Dir.doesFileExist . Ghc.unpackFS) + filterM (fmap not . Dir.doesFileExist) mods pure $ foldl' (flip M.delete) warns' deletedMods @@ -159,35 +172,66 @@ pure parsedModule -- | Taps into the log action to capture the warnings that GHC emits. +#if MIN_VERSION_ghc(9,2,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 warnReason severity srcSpan sdoc = do + case severity of + Ghc.SevWarning + | Ghc.RealSrcLoc' start <- Ghc.srcSpanStart srcSpan + , Ghc.RealSrcLoc' end <- Ghc.srcSpanEnd srcSpan + , Just modFile <- Ghc.srcSpanFileName_maybe srcSpan + -> do + let warn = Warning $ Ghc.mkPlainWarnMsg srcSpan sdoc + addWarningToGlobalState start end modFile warn + _ -> pure () + + logAction dynFlags warnReason severity srcSpan sdoc +#else addWarningCapture :: Ghc.DynFlags -> Ghc.DynFlags addWarningCapture dynFlags = do 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) + case severity of + Ghc.SevWarning | Ghc.RealSrcLoc' start <- Ghc.srcSpanStart srcSpan , Ghc.RealSrcLoc' end <- Ghc.srcSpanEnd srcSpan + , Just modFile <- Ghc.srcSpanFileName_maybe srcSpan -> do - let warn = M.singleton (start, end) - . S.singleton - . Warning + let warn = Warning $ Ghc.mkWarnMsg dyn srcSpan Ghc.alwaysQualify msgDoc - - let file = Ghc.unpackFS modFile - exists <- Dir.doesFileExist file - when exists $ do - fileModifiedAt <- Dir.getModificationTime file - modifyMVar_ globalState - $ pure - . M.insertWith (<>) modFile - MkWarningsWithModDate - { lastUpdated = fileModifiedAt - , warningsMap = MonoidMap warn - } - + addWarningToGlobalState start end modFile warn _ -> pure () } +#endif + +-- | Adds a warning to the global state variable +addWarningToGlobalState + :: Ghc.RealSrcLoc -- ^ start location + -> Ghc.RealSrcLoc -- ^ end location + -> Ghc.FastString -- ^ module name + -> Warning + -> IO () +addWarningToGlobalState start end modFile warn = do + let wrappedWarn = M.singleton (start, end) + $ S.singleton warn + file = Ghc.unpackFS modFile + exists <- Dir.doesFileExist file + when exists $ do + fileModifiedAt <- Dir.getModificationTime file + modifyMVar_ globalState + $ pure + . M.insertWith (<>) file + MkWarningsWithModDate + { lastUpdated = fileModifiedAt + , warningsMap = MonoidMap wrappedWarn + } fixWarnings :: IO () fixWarnings = do diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -54,6 +54,9 @@ fixRedundancyWarning 1 WholeModule input15 @?= Just output15 + + fixRedundancyWarning 1 (IndividualThings ["zip", "zipWith"]) input16 + @?= Just output16 ] input1, output1 :: BS.ByteString @@ -146,3 +149,8 @@ , "import Bar" ] output15 = [ "import Bar" ] + +-- first match is a subsubstring of another term +input16, output16 :: [BS.ByteString] +input16 = [ "import Data.List (zip4, zip, zipWith3, zipWith, zipWith2, zip3)" ] +output16 = [ "import Data.List (zip4, zipWith3, zipWith2, zip3)" ]