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.2 +version: 0.1.0.3 synopsis: Preserve warnings in a GHCi session description: Please see the README on GitHub at 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 diff --git a/src/GhcFacade.hs b/src/GhcFacade.hs deleted file mode 100644 --- a/src/GhcFacade.hs +++ /dev/null @@ -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 diff --git a/src/Internal/FixWarnings.hs b/src/Internal/FixWarnings.hs new file mode 100644 --- /dev/null +++ b/src/Internal/FixWarnings.hs @@ -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 + diff --git a/src/Internal/GhcFacade.hs b/src/Internal/GhcFacade.hs new file mode 100644 --- /dev/null +++ b/src/Internal/GhcFacade.hs @@ -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 diff --git a/src/Internal/Types.hs b/src/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Types.hs @@ -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) + ) + diff --git a/src/PinnedWarnings.hs b/src/PinnedWarnings.hs --- a/src/PinnedWarnings.hs +++ b/src/PinnedWarnings.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = pure ()