splint 1.0.1.0 → 1.0.1.1

raw patch · 2 files changed

+68/−15 lines, 2 filesdep +containersdep +stmPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: containers, stm

API changes (from Hackage documentation)

Files

• splint.cabal +3/−1
• src/lib/Splint.hs +65/−14

@@ -1,7 +1,7 @@ cabal-version: 2.2  name: splint-version: 1.0.1.0+version: 1.0.1.1  synopsis: HLint as a GHC source plugin. description:@@ -46,8 +46,10 @@    build-depends:     base >= 4.12.0 && < 4.15+    , containers >= 0.6.0 && < 0.7     , ghc >= 8.6.1 && < 8.11     , hlint >= 3.0 && < 3.2+    , stm >= 2.5.0 && < 2.6   exposed-modules: Splint   hs-source-dirs: src/lib   other-modules: Splint.Parser

@@ -4,7 +4,11 @@ where  import qualified Bag as GHC-import qualified Data.IORef as IORef+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 ErrUtils as GHC import qualified GhcPlugins as GHC import qualified Language.Haskell.HLint as HLint@@ -26,7 +30,7 @@   (parseFlags, classifies, hint) <- getSettings commandLineOptions   moduleEx <- Splint.parse parseFlags modSummary hsParsedModule   dynFlags <- GHC.getDynFlags-  GHC.liftIO+  io     . GHC.printOrThrowWarnings dynFlags     . GHC.listToBag     . fmap (ideaToWarnMsg dynFlags)@@ -36,19 +40,66 @@  type Settings = (HLint.ParseFlags, [HLint.Classify], HLint.Hint) -getSettings :: [GHC.CommandLineOption] -> GHC.Hsc Settings-getSettings commandLineOptions = GHC.liftIO $ do-  maybeSettings <- IORef.readIORef settingsRef-  case maybeSettings of-    Just settings -> pure settings-    Nothing -> do-      settings <- HLint.argsSettings commandLineOptions-      IORef.writeIORef settingsRef $ Just settings-      pure settings+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 -{-# NOINLINE settingsRef #-}-settingsRef :: IORef.IORef (Maybe Settings)-settingsRef = Unsafe.unsafePerformIO $ IORef.newIORef Nothing+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 =