pinned-warnings 0.1.0.6 → 0.1.0.7
raw patch · 6 files changed
+83/−56 lines, 6 files
Files
- pinned-warnings.cabal +1/−1
- src/Internal/FixWarnings.hs +9/−5
- src/Internal/Types.hs +10/−5
- src/PinnedWarnings.hs +56/−44
- src/ShowWarnings.hs +6/−0
- test/Spec.hs +1/−1
pinned-warnings.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: pinned-warnings-version: 0.1.0.6+version: 0.1.0.7 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
src/Internal/FixWarnings.hs view
@@ -25,7 +25,10 @@ -- | 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+fixWarning MkWarningsWithModDate+ { lastUpdated = Alt (Just modifiedAt)+ , warningsMap = 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)@@ -77,12 +80,13 @@ ) files - pure (Alt Nothing, MonoidMap $ M.fromList pairs)+ pure MkWarningsWithModDate+ { lastUpdated = Alt Nothing+ , warningsMap = MonoidMap $ M.fromList pairs+ } fixWarning w = pure w --- TODO handle operators- -- | Attempt to fix redundant import warning. -- Returns 'Nothing' if incapable of fixing. fixRedundancyWarning :: Int@@ -97,7 +101,7 @@ let (before, stmt : after) = splitAt (startLine - 1) srcLines - isStart bs = (== "import") . BS.take 6 $ BS.dropSpace bs+ isStart bs = "import" `BS.isPrefixOf` BS.dropSpace bs (before', stmt') | isStart stmt = (before, [stmt])
src/Internal/Types.hs view
@@ -4,7 +4,7 @@ , Warning(..) , MonoidMap(..) , SrcSpanKey- , WarningsWithModDate+ , WarningsWithModDate(..) ) where import Data.Monoid (Alt(..))@@ -35,8 +35,13 @@ 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)- )+data WarningsWithModDate =+ MkWarningsWithModDate+ { lastUpdated :: !(Alt Maybe UTCTime) -- Last time the module was modified+ , warningsMap :: !(MonoidMap SrcSpanKey (S.Set Warning))+ } +instance Semigroup WarningsWithModDate where+ a <> b = MkWarningsWithModDate+ (lastUpdated a <> lastUpdated b)+ (warningsMap a <> warningsMap b)
src/PinnedWarnings.hs view
@@ -20,8 +20,8 @@ import qualified Internal.GhcFacade as Ghc import Internal.Types --- The infamous mutable global trick.--- Needed to track the pinned warnings during and after compilation.+-- | A mutable global variable used to track warnings during and after+-- compilations. globalState :: MVar (M.Map ModuleFile WarningsWithModDate) globalState = unsafePerformIO $ newMVar mempty {-# NOINLINE globalState #-}@@ -33,69 +33,62 @@ plugin :: Ghc.Plugin plugin = Ghc.defaultPlugin- { Ghc.tcPlugin = const $ Just tcPlugin+ { Ghc.tcPlugin = const $ Just tcPlugin , Ghc.parsedResultAction = const resetPinnedWarnsForMod- , Ghc.dynflagsPlugin = const addWarningCapture- , Ghc.pluginRecompile = Ghc.purePlugin+ , Ghc.dynflagsPlugin = const (pure . addWarningCapture)+ , Ghc.pluginRecompile = Ghc.purePlugin } tcPlugin :: Ghc.TcPlugin tcPlugin = Ghc.TcPlugin { Ghc.tcPluginInit = initTcPlugin- , Ghc.tcPluginSolve = \(sw, fw, counterRef) _ _ wanteds ->- checkWanteds sw fw counterRef wanteds+ , Ghc.tcPluginSolve = \pluginState _ _ -> checkWanteds pluginState , Ghc.tcPluginStop = const $ pure () } -initTcPlugin :: Ghc.TcPluginM (Ghc.TyCon, Ghc.TyCon, IORef Int)-initTcPlugin =- (,,) <$> lookupShowWarnings- <*> lookupFixWarnings- <*> Ghc.tcPluginIO (newIORef 0)---- | Gets a reference to the 'ShowWarnings' constraint-lookupShowWarnings :: Ghc.TcPluginM Ghc.TyCon-lookupShowWarnings = do- result <- Ghc.findImportedModule- (Ghc.mkModuleName "ShowWarnings")- (Just "pinned-warnings")-- case result of- Ghc.Found _ mod' -> do- name <- Ghc.lookupOrig mod' $ Ghc.mkTcOcc "ShowWarnings"- Ghc.classTyCon <$> Ghc.tcLookupClass name+data PluginState =+ MkPluginState+ { showWarningsClass :: Ghc.TyCon+ , fixWarningsClass :: Ghc.TyCon+ , clearWarningsClass :: Ghc.TyCon+ , counterRef :: IORef Int+ } - _ -> error "ShowWarnings module not found"+initTcPlugin :: Ghc.TcPluginM PluginState+initTcPlugin =+ MkPluginState+ <$> lookupClass "ShowWarnings"+ <*> lookupClass "FixWarnings"+ <*> lookupClass "ClearWarnings"+ <*> Ghc.tcPluginIO (newIORef 0) --- | Gets a reference to the 'FixWarnings' constraint-lookupFixWarnings :: Ghc.TcPluginM Ghc.TyCon-lookupFixWarnings = do+-- | Get a reference to a class from the @ShowWarnings@ module+lookupClass :: String -> Ghc.TcPluginM Ghc.TyCon+lookupClass className = do result <- Ghc.findImportedModule (Ghc.mkModuleName "ShowWarnings")- (Just "pinned-warnings")+ (Just "pinned-warnings") case result of Ghc.Found _ mod' -> do- name <- Ghc.lookupOrig mod' $ Ghc.mkTcOcc "FixWarnings"+ name <- Ghc.lookupOrig mod' $ Ghc.mkTcOcc className 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+checkWanteds :: PluginState -> [Ghc.Ct] -> Ghc.TcPluginM Ghc.TcPluginResult-checkWanteds sw fw counterRef+checkWanteds pluginState = fmap (flip Ghc.TcPluginOk [] . catMaybes) . traverse go where go ct@Ghc.CDictCan { Ghc.cc_class = cls }- | Ghc.classTyCon cls == sw = do- counter <- Ghc.tcPluginIO $ readIORef counterRef+ | Ghc.classTyCon cls == showWarningsClass pluginState = do+ counter <- Ghc.tcPluginIO $ readIORef (counterRef pluginState) -- for some reason warnings only appear if they are added on -- particular iterations.@@ -104,18 +97,26 @@ pure $ Just (Ghc.EvExpr Ghc.unitExpr, ct) - | Ghc.classTyCon cls == fw = do- counter <- Ghc.tcPluginIO $ readIORef counterRef+ | Ghc.classTyCon cls == fixWarningsClass pluginState = do+ counter <- Ghc.tcPluginIO $ readIORef (counterRef pluginState) when (counter == 0) (Ghc.tcPluginIO fixWarnings) incrementCounter pure $ Just (Ghc.EvExpr Ghc.unitExpr, ct) + | Ghc.classTyCon cls == clearWarningsClass pluginState = do+ counter <- Ghc.tcPluginIO $ readIORef (counterRef pluginState)++ when (counter == 0) (Ghc.tcPluginIO clearWarnings)+ incrementCounter++ pure $ Just (Ghc.EvExpr Ghc.unitExpr, ct)+ go _ = pure Nothing incrementCounter =- Ghc.tcPluginIO $ modifyIORef' counterRef succ+ Ghc.tcPluginIO $ modifyIORef' (counterRef pluginState) succ -- | Add warnings from the global state back into the GHC context addWarningsToContext :: Ghc.TcPluginM ()@@ -124,7 +125,7 @@ Ghc.tcPluginIO pruneDeleted pinnedWarns <- Ghc.listToBag . map unWarning- . foldMap (foldMap S.toList . snd)+ . foldMap (foldMap S.toList . warningsMap) <$> Ghc.tcPluginIO (readMVar globalState) Ghc.tcPluginIO . atomicModifyIORef' errsRef@@ -154,14 +155,18 @@ -- Replace any existing pinned warnings with new ones for this module liftIO . modifyMVar_ globalState- $ pure . M.insert modFile (modifiedTime, mempty)+ $ pure . M.insert modFile+ MkWarningsWithModDate+ { lastUpdated = modifiedTime+ , warningsMap = mempty+ } pure parsedModule -- | Taps into the log action to capture the warnings that GHC emits.-addWarningCapture :: Ghc.DynFlags -> IO Ghc.DynFlags+addWarningCapture :: Ghc.DynFlags -> Ghc.DynFlags addWarningCapture dynFlags = do- pure dynFlags+ dynFlags { Ghc.log_action = Ghc.log_action' (Ghc.log_action dynFlags) $ \dyn severity srcSpan msgDoc -> do case (severity, Ghc.srcSpanFileName_maybe srcSpan) of@@ -177,7 +182,10 @@ modifyMVar_ globalState $ pure . M.insertWith (<>) modFile- (mempty, MonoidMap warn)+ MkWarningsWithModDate+ { lastUpdated = mempty+ , warningsMap = MonoidMap warn+ } _ -> pure () }@@ -186,3 +194,7 @@ fixWarnings = do pruneDeleted modifyMVar_ globalState $ traverse FW.fixWarning++clearWarnings :: IO ()+clearWarnings =+ void $ swapMVar globalState M.empty
src/ShowWarnings.hs view
@@ -4,6 +4,8 @@ , showWarnings , FixWarnings , fixWarnings+ , ClearWarnings+ , clearWarnings ) where class ShowWarnings where@@ -13,3 +15,7 @@ class FixWarnings where -- | Auto-fixes certain types of warnings fixWarnings :: ()++class ClearWarnings where+ -- | Removes any currently pinned warnings+ clearWarnings :: ()
test/Spec.hs view
@@ -96,7 +96,7 @@ input7, output7 :: [BS.ByteString] input7 = [ "import Foo.Bar" , " ( foo"- , " , bar"+ , " , pattern bar" , " , baz" , " )" ]