splint 1.0.1.5 → 1.0.2.0

raw patch · 7 files changed

+288/−155 lines, 7 filesdep ~basedep ~containersdep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, containers, ghc, hlint, stm

API changes (from Hackage documentation)

Files

• splint.cabal +21/−10
• src/ghc-8.10/Splint.hs +65/−0
• src/ghc-9.0/Splint.hs +65/−0
• src/ghc-9.2/Splint.hs +62/−0
• src/lib/Splint.hs +0/−145
• src/lib/Splint/RemoteData.hs +8/−0
• src/lib/Splint/Settings.hs +67/−0

@@ -1,11 +1,11 @@ cabal-version: >= 1.10  name: splint-version: 1.0.1.5+version: 1.0.2.0  synopsis: HLint as a GHC source plugin. description:-  Splint makes HLint 3 available as a GHC source plugin. To use it, pass+  Splint makes HLint available as a GHC source plugin. To use it, pass   @-fplugin=Splint@ to GHC. Any options passed to Splint are passed through to   HLint. For example you can use @-fplugin-opt=Splint:'--ignore=Use concatMap'@   to ignore the "Use @concatMap@" suggestion.@@ -23,13 +23,16 @@  library   build-depends:-    base >= 4.13.0 && < 4.16-    , containers >= 0.6.2 && < 0.7-    , ghc >= 8.10 && < 8.11 || >= 9.0 && < 9.1+    base >= 4.14 && < 4.17+    , containers >= 0.6 && < 0.7+    , ghc >= 8.10 && < 8.11 || >= 9.0 && < 9.3     , hlint-    , stm >= 2.5.0 && < 2.6+    , stm >= 2.5 && < 2.6   default-language: Haskell2010-  exposed-modules: Splint+  exposed-modules:+    Splint+    Splint.RemoteData+    Splint.Settings   ghc-options:     -Weverything     -Wno-implicit-prelude@@ -39,10 +42,18 @@     -Wno-missing-import-lists     -Wno-missing-safe-haskell-mode     -Wno-prepositive-qualified-module+    -Wno-safe     -Wno-unsafe   hs-source-dirs: src/lib -  if impl(ghc >= 9.0)-    build-depends: hlint >= 3.3 && < 3.4+  if impl(ghc >= 9.2)+    build-depends: hlint >= 3.4 && < 3.5+    ghc-options: -Wno-missing-kind-signatures+    hs-source-dirs: src/ghc-9.2   else-    build-depends: hlint >= 3.2 && < 3.3+    if impl(ghc >= 9.0)+      build-depends: hlint >= 3.3 && < 3.4+      hs-source-dirs: src/ghc-9.0+    else+      build-depends: hlint >= 3.2 && < 3.3+      hs-source-dirs: src/ghc-8.10

@@ -0,0 +1,65 @@+module Splint where++import qualified Bag as GHC+import qualified ErrUtils as GHC+import qualified GhcPlugins as GHC+import qualified Language.Haskell.HLint as HLint+import qualified Splint.Settings as Settings++plugin :: GHC.Plugin+plugin = GHC.defaultPlugin+  { GHC.parsedResultAction = action+  , GHC.pluginRecompile = GHC.purePlugin+  }++action+  :: [GHC.CommandLineOption]+  -> GHC.ModSummary+  -> GHC.HsParsedModule+  -> GHC.Hsc GHC.HsParsedModule+action commandLineOptions modSummary hsParsedModule = do+  (parseFlags, classifies, hint) <- GHC.liftIO $ Settings.load commandLineOptions+  moduleEx <- parse parseFlags modSummary hsParsedModule+  dynFlags <- GHC.getDynFlags+  GHC.liftIO+    . GHC.printOrThrowWarnings dynFlags+    . GHC.listToBag+    . fmap (ideaToWarnMsg dynFlags)+    . filter ((/= HLint.Ignore) . HLint.ideaSeverity)+    $ HLint.applyHints classifies hint [moduleEx]+  pure hsParsedModule++ideaToWarnMsg :: GHC.DynFlags -> HLint.Idea -> GHC.WarnMsg+ideaToWarnMsg dynFlags idea =+  let+    mkErrMsg = case HLint.ideaSeverity idea of+      HLint.Error -> GHC.mkPlainErrMsg+      _ -> GHC.mkPlainWarnMsg+    srcSpan = case HLint.unpackSrcSpan $ HLint.ideaSpan idea of+      Nothing -> GHC.noSrcSpan+      Just (file, (startLine, startColumn), (endLine, endColumn)) ->+        GHC.mkSrcSpan+          (GHC.mkSrcLoc (GHC.mkFastString file) startLine startColumn)+          (GHC.mkSrcLoc (GHC.mkFastString file) endLine endColumn)+    msgDoc = ideaToMsgDoc idea+  in mkErrMsg dynFlags srcSpan msgDoc++ideaToMsgDoc :: HLint.Idea -> GHC.MsgDoc+ideaToMsgDoc idea = GHC.vcat+  [ GHC.text $ HLint.ideaHint idea+  , case HLint.ideaTo idea of+    Just to | not $ null to -> GHC.text $ "Perhaps: " <> to+    _ -> GHC.empty+  , GHC.vcat . fmap (GHC.text . mappend "Note: " . show) $ HLint.ideaNote idea+  ]++parse+  :: HLint.ParseFlags+  -> GHC.ModSummary+  -> GHC.HsParsedModule+  -> GHC.Hsc HLint.ModuleEx+parse _ _ hsParsedModule = do+  let+    apiAnns = GHC.hpm_annotations hsParsedModule+    hsModule = GHC.hpm_module hsParsedModule+  pure $ HLint.createModuleEx apiAnns hsModule

@@ -0,0 +1,65 @@+module Splint where++import qualified GHC.Data.Bag as GHC+import qualified GHC.Plugins as GHC+import qualified GHC.Utils.Error as GHC+import qualified Language.Haskell.HLint as HLint+import qualified Splint.Settings as Settings++plugin :: GHC.Plugin+plugin = GHC.defaultPlugin+  { GHC.parsedResultAction = action+  , GHC.pluginRecompile = GHC.purePlugin+  }++action+  :: [GHC.CommandLineOption]+  -> GHC.ModSummary+  -> GHC.HsParsedModule+  -> GHC.Hsc GHC.HsParsedModule+action commandLineOptions modSummary hsParsedModule = do+  (parseFlags, classifies, hint) <- GHC.liftIO $ Settings.load commandLineOptions+  moduleEx <- parse parseFlags modSummary hsParsedModule+  dynFlags <- GHC.getDynFlags+  GHC.liftIO+    . GHC.printOrThrowWarnings dynFlags+    . GHC.listToBag+    . fmap (ideaToWarnMsg dynFlags)+    . filter ((/= HLint.Ignore) . HLint.ideaSeverity)+    $ HLint.applyHints classifies hint [moduleEx]+  pure hsParsedModule++ideaToWarnMsg :: GHC.DynFlags -> HLint.Idea -> GHC.WarnMsg+ideaToWarnMsg dynFlags idea =+  let+    mkErrMsg = case HLint.ideaSeverity idea of+      HLint.Error -> GHC.mkPlainErrMsg+      _ -> GHC.mkPlainWarnMsg+    srcSpan = case HLint.unpackSrcSpan $ HLint.ideaSpan idea of+      Nothing -> GHC.noSrcSpan+      Just (file, (startLine, startColumn), (endLine, endColumn)) ->+        GHC.mkSrcSpan+          (GHC.mkSrcLoc (GHC.mkFastString file) startLine startColumn)+          (GHC.mkSrcLoc (GHC.mkFastString file) endLine endColumn)+    msgDoc = ideaToMsgDoc idea+  in mkErrMsg dynFlags srcSpan msgDoc++ideaToMsgDoc :: HLint.Idea -> GHC.MsgDoc+ideaToMsgDoc idea = GHC.vcat+  [ GHC.text $ HLint.ideaHint idea+  , case HLint.ideaTo idea of+    Just to | not $ null to -> GHC.text $ "Perhaps: " <> to+    _ -> GHC.empty+  , GHC.vcat . fmap (GHC.text . mappend "Note: " . show) $ HLint.ideaNote idea+  ]++parse+  :: HLint.ParseFlags+  -> GHC.ModSummary+  -> GHC.HsParsedModule+  -> GHC.Hsc HLint.ModuleEx+parse _ _ hsParsedModule = do+  let+    apiAnns = GHC.hpm_annotations hsParsedModule+    hsModule = GHC.hpm_module hsParsedModule+  pure $ HLint.createModuleEx apiAnns hsModule

@@ -0,0 +1,62 @@+module Splint where++import qualified GHC.Data.Bag as Bag+import qualified GHC.Driver.Errors as Errors+import qualified GHC.Hs as Hs+import qualified GHC.Plugins as Plugins+import qualified GHC.Types.Error as Error+import qualified GHC.Utils.Logger as Logger+import qualified Language.Haskell.HLint as HLint+import qualified Splint.Settings as Settings++plugin :: Plugins.Plugin+plugin = Plugins.defaultPlugin+  { Plugins.parsedResultAction = parsedResultAction+  , Plugins.pluginRecompile = Plugins.purePlugin+  }++parsedResultAction+  :: [Plugins.CommandLineOption]+  -> Plugins.ModSummary+  -> Hs.HsParsedModule+  -> Plugins.Hsc Hs.HsParsedModule+parsedResultAction commandLineOptions _modSummary hsParsedModule = do+  (_parseFlags, classifies, hint) <- Plugins.liftIO+    $ Settings.load commandLineOptions+  logger <- Logger.getLogger+  dynFlags <- Plugins.getDynFlags+  Plugins.liftIO+    . Errors.printOrThrowWarnings logger dynFlags+    . Bag.listToBag+    . fmap ideaToWarnMsg+    . filter ((/=) HLint.Ignore . HLint.ideaSeverity)+    . HLint.applyHints classifies hint+    . pure+    . HLint.createModuleEx+    $ Hs.hpm_module hsParsedModule+  pure hsParsedModule++ideaToWarnMsg :: HLint.Idea -> Error.WarnMsg+ideaToWarnMsg idea =+  Error.mkPlainWarnMsg (ideaToSrcSpan idea) (ideaToSDoc idea)++ideaToSrcSpan :: HLint.Idea -> Plugins.SrcSpan+ideaToSrcSpan idea = case HLint.unpackSrcSpan $ HLint.ideaSpan idea of+  Nothing -> Plugins.noSrcSpan+  Just (filePath, (startLine, startColumn), (endLine, endColumn)) ->+    let fastString = Plugins.mkFastString filePath+    in+      Plugins.mkSrcSpan+        (Plugins.mkSrcLoc fastString startLine startColumn)+        (Plugins.mkSrcLoc fastString endLine endColumn)++ideaToSDoc :: HLint.Idea -> Error.SDoc+ideaToSDoc idea = Plugins.vcat+  [ Plugins.text $ HLint.ideaHint idea+  , case HLint.ideaTo idea of+    Just to | not $ null to -> Plugins.text $ "Perhaps: " <> to+    _ -> Plugins.empty+  , Plugins.vcat+  . fmap (Plugins.text . mappend "Note: " . show)+  $ HLint.ideaNote idea+  ]

@@ -1,145 +0,0 @@-{-# LANGUAGE CPP #-}--module Splint-  ( plugin-  )-where--import qualified Control.Concurrent as Concurrent-import qualified Control.Concurrent.STM as Stm-import qualified Control.Exception as Exception-import qualified Control.Monad.IO.Class as IO-import qualified Data.Map as Map-import qualified Language.Haskell.HLint as HLint-import qualified System.IO.Unsafe as Unsafe--# if MIN_VERSION_GLASGOW_HASKELL(9, 0, 0, 0)-import qualified GHC.Data.Bag as GHC-import qualified GHC.Utils.Error as GHC-import qualified GHC.Plugins as GHC-# else-import qualified Bag as GHC-import qualified ErrUtils as GHC-import qualified GhcPlugins as GHC-# endif--plugin :: GHC.Plugin-plugin = GHC.defaultPlugin-  { GHC.parsedResultAction = action-  , GHC.pluginRecompile = GHC.purePlugin-  }--action-  :: [GHC.CommandLineOption]-  -> GHC.ModSummary-  -> GHC.HsParsedModule-  -> GHC.Hsc GHC.HsParsedModule-action commandLineOptions modSummary hsParsedModule = do-  (parseFlags, classifies, hint) <- getSettings commandLineOptions-  moduleEx <- parse parseFlags modSummary hsParsedModule-  dynFlags <- GHC.getDynFlags-  io-    . GHC.printOrThrowWarnings dynFlags-    . GHC.listToBag-    . fmap (ideaToWarnMsg dynFlags)-    . filter ((/= HLint.Ignore) . HLint.ideaSeverity)-    $ HLint.applyHints classifies hint [moduleEx]-  pure hsParsedModule--type Settings = (HLint.ParseFlags, [HLint.Classify], HLint.Hint)--getSettings :: [String] -> GHC.Hsc Settings-getSettings options = do-  let insert = Stm.modifyTVar settingsTVar . Map.insert options-  remoteData <- io . stm $ do-    settings <- Stm.readTVar settingsTVar-    let remoteData = Map.findWithDefault NotAsked options settings-    case remoteData of-      NotAsked -> insert Loading-      _ -> pure ()-    pure remoteData-  case remoteData of-    NotAsked -> io . withTMVar settingsTMVar . const $ do-      result <- Exception.try $ HLint.argsSettings options-      case result of-        Left ioException -> do-          stm . insert $ Failure ioException-          Exception.throwIO ioException-        Right settings -> do-          stm . insert $ Success settings-          pure settings-    Loading -> do-      io $ Concurrent.threadDelay 1000-      getSettings options-    Failure ioException -> io $ Exception.throwIO ioException-    Success settings -> pure settings--io :: IO.MonadIO m => IO a -> m a-io = GHC.liftIO--stm :: Stm.STM a -> IO a-stm = Stm.atomically--withTMVar :: Stm.TMVar a -> (a -> IO b) -> IO b-withTMVar var =-  Exception.bracket (stm $ Stm.takeTMVar var) (stm . Stm.putTMVar var)---- | Getting settings is not instantaneous. Since settings are usually reused--- between modules, it makes sense to cache them. However each module can--- potentially customize its settings using the @OPTIONS_GHC@ pragma. This--- variable is used as a cache of settings keyed on the command line options.-settingsTVar-  :: Stm.TVar (Map.Map [String] (RemoteData Exception.IOException Settings))-settingsTVar = Unsafe.unsafePerformIO $ Stm.newTVarIO Map.empty-{-# NOINLINE settingsTVar #-}---- | Even though we cache settings based on command line options, we only want--- to load settings one at a time. Practically this is to work around a bug in--- GHC. But aside from that, loading settings calls @withArgs@ and doing that--- simultaneously in separate threads is dubious.--- <https://gitlab.haskell.org/ghc/ghc/issues/18261>-settingsTMVar :: Stm.TMVar ()-settingsTMVar = Unsafe.unsafePerformIO $ Stm.newTMVarIO ()-{-# NOINLINE settingsTMVar #-}--data RemoteData e a-  = NotAsked-  | Loading-  | Failure e-  | Success a-  deriving (Eq, Show)--ideaToWarnMsg :: GHC.DynFlags -> HLint.Idea -> GHC.WarnMsg-ideaToWarnMsg dynFlags idea =-  let-    mkErrMsg = case HLint.ideaSeverity idea of-      HLint.Error -> GHC.mkPlainErrMsg-      _ -> GHC.mkPlainWarnMsg-    srcSpan = case HLint.unpackSrcSpan $ HLint.ideaSpan idea of-      Nothing -> GHC.noSrcSpan-      Just (file, (startLine, startColumn), (endLine, endColumn)) ->-        GHC.mkSrcSpan-          (GHC.mkSrcLoc (GHC.mkFastString file) startLine startColumn)-          (GHC.mkSrcLoc (GHC.mkFastString file) endLine endColumn)-    msgDoc = ideaToMsgDoc idea-  in mkErrMsg dynFlags srcSpan msgDoc--ideaToMsgDoc :: HLint.Idea -> GHC.MsgDoc-ideaToMsgDoc idea = GHC.vcat-  [ GHC.text $ HLint.ideaHint idea-  , case HLint.ideaTo idea of-    Just to | not $ null to -> GHC.text $ "Perhaps: " <> to-    _ -> GHC.empty-  , GHC.vcat . fmap (GHC.text . mappend "Note: " . show) $ HLint.ideaNote idea-  ]--parse-  :: HLint.ParseFlags-  -> GHC.ModSummary-  -> GHC.HsParsedModule-  -> GHC.Hsc HLint.ModuleEx-parse _ _ hsParsedModule = do-  let-    apiAnns = GHC.hpm_annotations hsParsedModule-    hsModule = GHC.hpm_module hsParsedModule-  pure $ HLint.createModuleEx apiAnns hsModule

@@ -0,0 +1,8 @@+module Splint.RemoteData where++data RemoteData e a+  = NotAsked+  | Loading+  | Failure e+  | Success a+  deriving (Eq, Show)

@@ -0,0 +1,67 @@+module Splint.Settings where++import qualified Control.Concurrent.STM as Stm+import qualified Control.Exception as Exception+import qualified Data.Map as Map+import qualified Language.Haskell.HLint as HLint+import qualified Splint.RemoteData as RemoteData+import qualified System.IO.Unsafe as Unsafe++type Settings = (HLint.ParseFlags, [HLint.Classify], HLint.Hint)++-- | Getting settings is not instantaneous. Since settings are usually reused+-- between modules, it makes sense to cache them. However each module can+-- potentially customize its settings using the @OPTIONS_GHC@ pragma. This+-- variable is used as a cache of settings keyed on the command line options.+cache+  :: Stm.TVar+       (Map.Map [String] (RemoteData.RemoteData Exception.IOException Settings))+cache = Unsafe.unsafePerformIO $ Stm.newTVarIO Map.empty+{-# NOINLINE cache #-}++-- | Even though we cache settings based on command line options, we only want+-- to load settings one at a time. Practically this is to work around a bug in+-- GHC. But aside from that, loading settings calls @withArgs@ and doing that+-- simultaneously in separate threads is dubious.+-- <https://gitlab.haskell.org/ghc/ghc/issues/18261>+semaphore :: Stm.TMVar ()+semaphore = Unsafe.unsafePerformIO $ Stm.newTMVarIO ()+{-# NOINLINE semaphore #-}++withTMVar :: Stm.TMVar a -> (a -> IO b) -> IO b+withTMVar x = Exception.bracket+  (Stm.atomically $ Stm.takeTMVar x)+  (Stm.atomically . Stm.putTMVar x)++load :: [String] -> IO Settings+load commandLineOptions = do+  remoteData <- Stm.atomically $ do+    settings <- Stm.readTVar cache+    let+      remoteData =+        Map.findWithDefault RemoteData.NotAsked commandLineOptions settings+    case remoteData of+      RemoteData.NotAsked ->+        Stm.modifyTVar cache $ Map.insert commandLineOptions RemoteData.Loading+      RemoteData.Loading -> Stm.retry+      _ -> pure ()+    pure remoteData+  case remoteData of+    RemoteData.NotAsked -> withTMVar semaphore . const $ do+      result <- Exception.try $ HLint.argsSettings commandLineOptions+      case result of+        Left ioException -> do+          Stm.atomically+            . Stm.modifyTVar cache+            . Map.insert commandLineOptions+            $ RemoteData.Failure ioException+          Exception.throwIO ioException+        Right settings -> do+          Stm.atomically+            . Stm.modifyTVar cache+            . Map.insert commandLineOptions+            $ RemoteData.Success settings+          pure settings+    RemoteData.Loading -> load commandLineOptions+    RemoteData.Failure ioException -> Exception.throwIO ioException+    RemoteData.Success settings -> pure settings