module Splint ( plugin ) where import qualified Bag as GHC import qualified Data.IORef as IORef import qualified ErrUtils as GHC import qualified GhcPlugins as GHC import qualified Language.Haskell.HLint as HLint import qualified Splint.Parser as Splint import qualified System.IO.Unsafe as Unsafe 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 <- Splint.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 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 {-# NOINLINE settingsRef #-} settingsRef :: IORef.IORef (Maybe Settings) settingsRef = Unsafe.unsafePerformIO $ IORef.newIORef Nothing 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 ]