pinned-warnings 0.1.0.8 → 0.1.0.9
raw patch · 7 files changed
+184/−71 lines, 7 filesdep ~bytestringdep ~containersdep ~directory
Dependency ranges changed: bytestring, containers, directory, ghc, time
Files
- README.md +1/−1
- pinned-warnings.cabal +7/−7
- src/Internal/FixWarnings.hs +52/−40
- src/Internal/GhcFacade.hs +29/−2
- src/Internal/Types.hs +24/−2
- src/PinnedWarnings.hs +63/−19
- test/Spec.hs +8/−0
README.md view
@@ -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.
pinned-warnings.cabal view
@@ -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 <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 || ==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
src/Internal/FixWarnings.hs view
@@ -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 '’'
src/Internal/GhcFacade.hs view
@@ -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
src/Internal/Types.hs view
@@ -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
src/PinnedWarnings.hs view
@@ -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
test/Spec.hs view
@@ -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)" ]