pinned-warnings 0.1.0.2 → 0.1.0.3
raw patch · 7 files changed
+348/−223 lines, 7 filesdep +pinned-warningsdep +tastydep +tasty-hunitdep ~base
Dependencies added: pinned-warnings, tasty, tasty-hunit
Dependency ranges changed: base
Files
- pinned-warnings.cabal +17/−3
- src/GhcFacade.hs +0/−65
- src/Internal/FixWarnings.hs +217/−0
- src/Internal/GhcFacade.hs +65/−0
- src/Internal/Types.hs +42/−0
- src/PinnedWarnings.hs +5/−155
- test/Spec.hs +2/−0
pinned-warnings.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: pinned-warnings-version: 0.1.0.2+version: 0.1.0.3 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@@ -15,7 +15,7 @@ author: Aaron Allen maintainer: aaronallen8455@gmail.com copyright: 2021 Aaron Allen-category: Utility+category: Utility, Development extra-source-files: README.md CHANGELOG.md@@ -23,7 +23,11 @@ library exposed-modules: PinnedWarnings, ShowWarnings- other-modules: GhcFacade++ other-modules: Internal.GhcFacade+ Internal.FixWarnings+ Internal.Types+ build-depends: ghc >= 8.8 && < 9.1, base >= 4.14.1 && < 5, bytestring >= 0.10.12 && < 0.11,@@ -35,3 +39,13 @@ default-language: Haskell2010 ghc-options: -Wall -Wincomplete-patterns++test-suite pinned-warnings-test+ main-is: Spec.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ build-depends: base,+ pinned-warnings,+ tasty,+ tasty-hunit,+ default-language: Haskell2010
− src/GhcFacade.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternSynonyms #-}-module GhcFacade- ( module X- , pattern RealSrcLoc'- , log_action'- ) where--#if MIN_VERSION_ghc(9,0,0)-import GHC 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,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-import GHC as X-import HscMain as X-import HscTypes as X-import IOEnv as X-import MkCore as X-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--pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc-pattern RealSrcLoc' s <--#if MIN_VERSION_ghc(9,0,1)- RealSrcLoc s _-#elif MIN_VERSION_ghc(8,10,0)- RealSrcLoc s-#endif--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/Internal/FixWarnings.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Internal.FixWarnings+ ( fixWarning+ , fixRedundancyWarning+ ) where++import Control.Applicative ((<|>))+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.State+import Data.Bifunctor (first)+import qualified Data.ByteString.Char8 as BS+import Data.Char (isSpace)+import Data.Monoid (Alt(..))+import qualified Data.Map.Strict as M+import qualified System.Directory as Dir+import qualified Text.ParserCombinators.ReadP as P++import qualified Internal.GhcFacade as Ghc+import Internal.Types++-- | 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+ -- State is used to keep the contents of a source file in memory while all+ -- applicable warnings for that file are fixed.+ (pairs, files) <- (`runStateT` M.empty)+ . flip filterM (reverse $ M.toList warnMap) $ \case+ ((start, _), warnSet)+ | Alt (Just reWarn) -- Take the first redundancy warning parsed+ <- 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++ fileModified <- liftIO $ Dir.getModificationTime file+ if fileModified /= modifiedAt+ then do+ -- Do not attempt to edit if file has been touched since last reload+ liftIO . putStrLn+ $ "'" <> file+ <> "' has been modified since last compiled. Reload and try again."+ pure True++ -- attempt to fix the warning+ else do+ let startLine = Ghc.srcLocLine start+ mNewSrcLines =+ fixRedundancyWarning startLine reWarn srcLines++ case mNewSrcLines of+ Nothing -> pure True++ Just newSrcLines -> do+ modify' $ M.insert file newSrcLines++ pure False++ _ -> pure True++ -- write the changes to the file+ _ <- 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++-- | Attempt to fix redundant import warning.+-- Returns 'Nothing' if incapable of fixing.+fixRedundancyWarning :: Int+ -> RedundancyWarn+ -> [BS.ByteString]+ -> Maybe [BS.ByteString]+fixRedundancyWarning startLine warn srcLines =+ -- 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++ isStart bs = (== "import") . BS.take 6 $ 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)++ (stmt'', after') = splitAtImportEnd $ stmt' <> after++ in case warn of+ WholeModule ->+ Just $ before' <> after'++ IndividualThings things ->+ (<> after') . (before' <>) . BS.lines <$>+ foldM fixRedundantThing+ (BS.unlines stmt'')+ things++splitAtImportEnd :: [BS.ByteString] -> ([BS.ByteString], [BS.ByteString])+splitAtImportEnd ls = first reverse $ go 0 0 ([], ls) where+ go o c acc+ | o /= 0 , o == c+ = acc+ go _ _ acc@(_, []) = acc -- shouldn't happen+ go o c (stmt, r:rest) =+ let addO = length $ BS.elemIndices '(' r+ addC = length $ BS.elemIndices ')' r+ in go (o + addO) (c + addC) (r : stmt, rest)++-- | Removes a particular thing from an import list without disrupting the+-- formatting. Returns 'Nothing' if the thing doesn't exist or appears more+-- than once.+--+-- Edges cases not handled:+-- - Comments interspersed in the statement that mention the thing+-- - Semicolon layout+fixRedundantThing :: BS.ByteString -> String -> Maybe BS.ByteString+fixRedundantThing stmt thing+ | (start, match) <- BS.breakSubstring thingBS stmt+ , not (BS.null match)+ , isSeparator . BS.take 1 $ BS.drop thingLen match+ , isCellStart . BS.take 1 $ BS.reverse start++ -- check that there isn't a second match+ , (start2, match2) <- BS.breakSubstring thingBS (BS.drop thingLen match)+ , BS.null match2+ || not+ ( isSeparator (BS.take 1 $ BS.drop thingLen match2)+ && isCellStart (BS.take 1 $ BS.reverse start2)+ )++ , let start' = BS.dropWhileEnd (\c -> c /= ',' && c /= '(') start+ end = dropRest+ . BS.dropSpace+ $ BS.drop thingLen match++ = case BS.take 1 end of+ "," -> Just $ start' <> BS.drop 1 end+ ")" -> Just $ BS.take (BS.length start' - 1) start' <> end+ _ -> Nothing++ | otherwise = Nothing+ where+ thingBS = BS.pack thing+ thingLen = BS.length thingBS+ isSeparator c = BS.all isSpace c || c `elem` [",", "(", ")"]+ isCellStart c = BS.all isSpace c || c `elem` [",", "("]+ dropRest bs = case BS.uncons bs of+ Nothing -> ""+ -- Constructors of a type or methods of a class+ Just (c, r)+ | c == '(' -> BS.dropWhile (\x -> x /= ',' && x /= ')')+ . BS.drop 1+ $ BS.dropWhile (/= ')') r++ _ -> BS.dropSpace bs++--------------------------------------------------------------------------------+-- Parsing+--------------------------------------------------------------------------------++-- | Redundant import warnings+data RedundancyWarn+ = WholeModule+ | IndividualThings [String]+ deriving Show++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 ‘"+ <|> P.string "The qualified 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/Internal/GhcFacade.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+module Internal.GhcFacade+ ( module X+ , pattern RealSrcLoc'+ , log_action'+ ) where++#if MIN_VERSION_ghc(9,0,0)+import GHC 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,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+import GHC as X+import HscMain as X+import HscTypes as X+import IOEnv as X+import MkCore as X+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++pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc+pattern RealSrcLoc' s <-+#if MIN_VERSION_ghc(9,0,1)+ RealSrcLoc s _+#elif MIN_VERSION_ghc(8,10,0)+ RealSrcLoc s+#endif++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/Internal/Types.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveFoldable #-}+module Internal.Types+ ( ModuleFile+ , Warning(..)+ , MonoidMap(..)+ , SrcSpanKey+ , WarningsWithModDate+ ) where++import Data.Monoid (Alt(..))+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Data.Time++import qualified Internal.GhcFacade as Ghc++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) -- start and end of span++type WarningsWithModDate =+ ( Alt Maybe UTCTime -- Last time the module was modified+ , MonoidMap SrcSpanKey (S.Set Warning)+ )+
src/PinnedWarnings.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-} module PinnedWarnings ( plugin ) where@@ -8,9 +6,6 @@ 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(..))@@ -18,42 +13,12 @@ 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------------------------------------------------------------------------------------- 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)- )+import qualified Internal.FixWarnings as FW+import qualified Internal.GhcFacade as Ghc+import Internal.Types -- The infamous mutable global trick. -- Needed to track the pinned warnings during and after compilation.@@ -71,6 +36,7 @@ { Ghc.tcPlugin = const $ Just tcPlugin , Ghc.parsedResultAction = const resetPinnedWarnsForMod , Ghc.dynflagsPlugin = const addWarningCapture+ , Ghc.pluginRecompile = Ghc.purePlugin } tcPlugin :: Ghc.TcPlugin@@ -219,120 +185,4 @@ 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-+ modifyMVar_ globalState $ traverse FW.fixWarning
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = pure ()