packages feed

pinned-warnings (empty) → 0.1.0.0

raw patch · 8 files changed

+315/−0 lines, 8 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, directory, ghc

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for pinned-warnings++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Aaron Allen (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Aaron Allen nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,40 @@+# Pinned Warnings++### The problem+When working in GHCi, it's easy to lose track of warnings from modules other+than the one you are currently editing. Having to reload the project to catch+any warnings you might have missed is painful.++### The solution+This package has a GHC plugin that allows you to see all the current warnings+from all modules in GHCi by calling a special `showWarnings` function.++### Usage+You can start GHCi in your project with one of the following commands to enable+the necessary plugin. You can add `pinned-warnings` as a package dependency to+avoid having to include the additional argument.+```+cabal update+cabal new-repl -b pinned-warnings --ghc-options="-fplugin PinnedWarnings"++stack update+stack repl --package pinned-warnings --ghci-options "-fplugin PinnedWarnings"+```+Then you must add the `ShowWarnings` module to the GHCi context:+```+:m + ShowWarnings+```+Now all active warnings can be viewed by evaluating `showWarnings`.++### Tip+You can define a custom GHCi command in your `.ghci` file that adds the+`ShowWarnings` module and calls `showWarnings`:+```+:def sw (\_ -> pure ":m + ShowWarnings \n showWarnings")+```+With this you can simply use `:sw` to view warnings.++### Known limitations+- Warnings produced outside of module type checking are not captured,+  for example those related to `.cabal` file omissions.+- Only the specified versions of GHC are supported
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pinned-warnings.cabal view
@@ -0,0 +1,34 @@+cabal-version:       2.4+-- Initial package description 'pinned-warnings.cabal' generated by 'cabal+-- init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++name:                pinned-warnings+version:             0.1.0.0+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+bug-reports:    https://github.com/aaronallen8455/pinned-warnings/issues+license:        BSD-3-Clause+license-file:   LICENSE++author: Aaron Allen+maintainer:          aaronallen8455@gmail.com+copyright: 2021 Aaron Allen+category: Utility+extra-source-files:+  README.md+  CHANGELOG.md+tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1++library+  exposed-modules:     PinnedWarnings, ShowWarnings+  other-modules:       GhcFacade+  --default-extensions:  ImportQualifiedPost+  build-depends:       ghc              >= 8.8 && < 9.1,+                       base             >= 4.7 && < 5,+                       bytestring       >= 0.10.10 && < 0.11,+                       containers       >= 0.6.2 && < 0.7,+                       directory        >= 1.3.6 && < 1.4,+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/GhcFacade.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+module GhcFacade+  ( module X+  , pattern RealSrcSpan'+  , bytesFS'+  ) where++import qualified Data.ByteString.Char8 as BS++#if MIN_VERSION_ghc(9,0,0)+import GHC.Data.Bag as X+import GHC.Tc.Types as X+import GHC.Tc.Plugin as X+import GHC.Driver.Plugins as X hiding (TcPlugin)+import GHC.Data.IOEnv as X+import GHC.Core.Make as X+import GHC.Tc.Types.Evidence as X+import GHC as X+import GHC.Data.FastString as X+import GHC.Utils.Error as X+import GHC.Core.Class as X+import GHC.Tc.Types.Constraint as X+import GHC.Types.Name.Occurrence as X++#elif MIN_VERSION_ghc(8,8,0)+import Bag as X+import Class 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 TcEvidence as X+import TcPluginM as X+import TcRnTypes as X+#endif++#if MIN_VERSION_ghc(8,10,0) && __GLASGOW_HASKELL__ < 900+import Constraint as X+#endif++pattern RealSrcSpan' :: RealSrcSpan -> SrcSpan+pattern RealSrcSpan' s <-+#if MIN_VERSION_ghc(9,0,1)+    RealSrcSpan s x+#elif MIN_VERSION_ghc(8,8,0)+    RealSrcSpan s+#endif++bytesFS' :: FastString -> BS.ByteString+bytesFS' =+#if MIN_VERSION_ghc(8,10,0)+  bytesFS+#elif MIN_VERSION_ghc(8,8,0)+  BS.pack . unpackFS+#endif
+ src/PinnedWarnings.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}+module PinnedWarnings+  ( plugin+  ) where++import           Control.Concurrent.MVar+import           Control.Monad+import           Control.Monad.IO.Class+import qualified Data.ByteString.Char8 as BS+import           Data.IORef+import           Data.List+import qualified Data.Map.Strict as M+import           Data.Maybe+import qualified Data.Set as S+import qualified System.Directory as Dir+import           System.IO.Unsafe (unsafePerformIO)++import qualified GhcFacade as Ghc++type ModuleFile = BS.ByteString++-- The infamous mutable global trick.+-- Needed to track the pinned warnings during and after compilation.+globalState :: MVar (M.Map ModuleFile Ghc.WarningMessages)+globalState = unsafePerformIO $ newMVar mempty+{-# NOINLINE globalState #-}++plugin :: Ghc.Plugin+plugin =+  Ghc.defaultPlugin+    { Ghc.tcPlugin = const $ Just tcPlugin+    , Ghc.typeCheckResultAction = const insertModuleWarnings+    }++tcPlugin :: Ghc.TcPlugin+tcPlugin =+  Ghc.TcPlugin+    { Ghc.tcPluginInit  = initTcPlugin+    , Ghc.tcPluginSolve = \(sw, counterRef) _ _ wanteds ->+        checkWanteds sw counterRef wanteds+    , Ghc.tcPluginStop  = const $ pure ()+    }++initTcPlugin :: Ghc.TcPluginM (Ghc.TyCon, IORef Int)+initTcPlugin =+  (,) <$> lookupShowWarnings+      <*> 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++    _ -> error "ShowWarnings module not found"++-- | If any wanted constraints are for 'ShowWarnings', then inject any pinned+-- warnings into GHC.+checkWanteds :: Ghc.TyCon+             -> IORef Int+             -> [Ghc.Ct]+             -> Ghc.TcPluginM Ghc.TcPluginResult+checkWanteds sw counterRef+    = 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++          -- for some reason warnings only appear if they are added on+          -- particular iterations.+          when (counter == 2) addWarningsToContext++          Ghc.tcPluginIO $ modifyIORef' counterRef succ++          pure $ Just (Ghc.EvExpr Ghc.unitExpr, ct)++    go _ = pure Nothing++-- | Add warnings from the global state back into the GHC context+addWarningsToContext :: Ghc.TcPluginM ()+addWarningsToContext = do+  errsRef <- Ghc.tcl_errs . snd <$> Ghc.getEnvs++  pruneDeleted+  pinnedWarns <- Ghc.listToBag+               . foldMap Ghc.bagToList+             <$> Ghc.tcPluginIO (readMVar globalState)++  Ghc.tcPluginIO . atomicModifyIORef' errsRef+    $ \(warnings, errors) ->+        ((Ghc.unionBags pinnedWarns warnings, errors), ())++-- | Remove warnings for modules that no longer exist+pruneDeleted :: Ghc.TcPluginM ()+pruneDeleted = Ghc.tcPluginIO . modifyMVar_ globalState $ \warns -> do+  let mods = M.keys warns++  deletedMods <-+    filterM (fmap not . Dir.doesFileExist . BS.unpack)+            mods++  pure $ foldl' (flip M.delete) warns deletedMods++-- | After type checking a module, pin any warnings pertaining to it.+insertModuleWarnings :: Ghc.ModSummary -> Ghc.TcGblEnv -> Ghc.TcM Ghc.TcGblEnv+insertModuleWarnings modSummary tcGblEnv = do+  lclErrsRef <- Ghc.tcl_errs . Ghc.env_lcl <$> Ghc.getEnv+  (warns, _) <- liftIO $ readIORef lclErrsRef++  let modFile = BS.pack $ Ghc.ms_hspp_file modSummary+      onlyThisMod w =+        case Ghc.errMsgSpan w of+          Ghc.RealSrcSpan' span ->+            Ghc.bytesFS' (Ghc.srcSpanFile span) == modFile+          _ -> False++      warnsForMod = Ghc.filterBag onlyThisMod warns++  -- Replace any existing pinned warnings with new ones for this module+  liftIO . modifyMVar_ globalState+    $ pure . M.insert modFile warnsForMod++  pure tcGblEnv+
+ src/ShowWarnings.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module ShowWarnings+  ( ShowWarnings+  , showWarnings+  ) where++class ShowWarnings where+  showWarnings :: ()