{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
module HLint.Plugin
(
plugin
) where
import GHC.Driver.Errors.Types (GhcMessage)
import GHC.Hs (HsParsedModule(..))
import GHC.Plugins (Plugin(..))
import Language.Haskell.HLint (Idea(..))
import GHC.Types.Error
( DiagnosticMessage(..)
, DiagnosticReason(..)
, MsgEnvelope(..)
)
import qualified GHC.Data.Bag as Bag
import qualified GHC.Driver.Config.Diagnostic as Diagnostic
import qualified GHC.Driver.Errors as Errors
import qualified GHC.Driver.Errors.Types as Errors.Types
import qualified GHC.Plugins as Plugins
import qualified GHC.Types.Error as Error
import qualified GHC.Utils.Logger as Logger
import qualified GHC.Utils.Outputable as Outputable
import qualified HLint.Plugin.Settings as Settings
import qualified Language.Haskell.HLint as HLint
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
Plugins.defaultPlugin
{ [String] -> ModSummary -> ParsedResult -> Hsc ParsedResult
forall {m :: * -> *} {p}.
(MonadIO m, HasDynFlags m, HasLogger m) =>
[String] -> p -> ParsedResult -> m ParsedResult
parsedResultAction :: forall {m :: * -> *} {p}.
(MonadIO m, HasDynFlags m, HasLogger m) =>
[String] -> p -> ParsedResult -> m ParsedResult
parsedResultAction :: [String] -> ModSummary -> ParsedResult -> Hsc ParsedResult
parsedResultAction
, pluginRecompile :: [String] -> IO PluginRecompile
pluginRecompile = [String] -> IO PluginRecompile
Plugins.purePlugin
}
where
parsedResultAction :: [String] -> p -> ParsedResult -> m ParsedResult
parsedResultAction [String]
arguments p
_ ParsedResult
parsedResult = do
(ParseFlags
_parseFlags, [Classify]
classifies, Hint
hint) <- do
IO (ParseFlags, [Classify], Hint)
-> m (ParseFlags, [Classify], Hint)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Plugins.liftIO ([String] -> IO (ParseFlags, [Classify], Hint)
Settings.argsSettings [String]
arguments)
DynFlags
dynFlags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
Plugins.getDynFlags
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
Logger.getLogger
let HsParsedModule{ Located HsModule
hpm_module :: Located HsModule
hpm_module :: HsParsedModule -> Located HsModule
hpm_module } =
ParsedResult -> HsParsedModule
Plugins.parsedResultModule ParsedResult
parsedResult
let moduleEx :: ModuleEx
moduleEx = Located HsModule -> ModuleEx
HLint.createModuleEx Located HsModule
hpm_module
let ideas :: [Idea]
ideas = [Classify] -> Hint -> [ModuleEx] -> [Idea]
HLint.applyHints [Classify]
classifies Hint
hint [ModuleEx
moduleEx]
let msgEnvelopes :: [MsgEnvelope GhcMessage]
msgEnvelopes = (Idea -> MsgEnvelope GhcMessage)
-> [Idea] -> [MsgEnvelope GhcMessage]
forall a b. (a -> b) -> [a] -> [b]
map Idea -> MsgEnvelope GhcMessage
ideaToMsgEnvelope [Idea]
ideas
let messages :: Messages GhcMessage
messages = Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
Error.mkMessages ([MsgEnvelope GhcMessage] -> Bag (MsgEnvelope GhcMessage)
forall a. [a] -> Bag a
Bag.listToBag [MsgEnvelope GhcMessage]
msgEnvelopes)
let diagOpts :: DiagOpts
diagOpts = DynFlags -> DiagOpts
Diagnostic.initDiagOpts DynFlags
dynFlags
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Plugins.liftIO (Logger -> DiagOpts -> Messages GhcMessage -> IO ()
Errors.printOrThrowDiagnostics Logger
logger DiagOpts
diagOpts Messages GhcMessage
messages)
ParsedResult -> m ParsedResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedResult
parsedResult
ideaToMsgEnvelope :: Idea -> MsgEnvelope GhcMessage
ideaToMsgEnvelope :: Idea -> MsgEnvelope GhcMessage
ideaToMsgEnvelope Idea{String
[String]
[Note]
[Refactoring SrcSpan]
Maybe String
SrcSpan
Severity
ideaModule :: [String]
ideaDecl :: [String]
ideaSeverity :: Severity
ideaHint :: String
ideaSpan :: SrcSpan
ideaFrom :: String
ideaTo :: Maybe String
ideaNote :: [Note]
ideaRefactoring :: [Refactoring SrcSpan]
ideaModule :: Idea -> [String]
ideaDecl :: Idea -> [String]
ideaSeverity :: Idea -> Severity
ideaHint :: Idea -> String
ideaSpan :: Idea -> SrcSpan
ideaFrom :: Idea -> String
ideaTo :: Idea -> Maybe String
ideaNote :: Idea -> [Note]
ideaRefactoring :: Idea -> [Refactoring SrcSpan]
..} = MsgEnvelope{PrintUnqualified
SrcSpan
Severity
GhcMessage
errMsgSpan :: SrcSpan
errMsgContext :: PrintUnqualified
errMsgDiagnostic :: GhcMessage
errMsgSeverity :: Severity
errMsgSpan :: SrcSpan
errMsgContext :: PrintUnqualified
errMsgDiagnostic :: GhcMessage
errMsgSeverity :: Severity
..}
where
sdoc :: SDoc
sdoc = [SDoc] -> SDoc
Plugins.vcat ([SDoc]
sdocs0 [SDoc] -> [SDoc] -> [SDoc]
forall a. Semigroup a => a -> a -> a
<> [SDoc]
sdocs1 [SDoc] -> [SDoc] -> [SDoc]
forall a. Semigroup a => a -> a -> a
<> [SDoc]
sdocs2)
where
sdocs0 :: [SDoc]
sdocs0 = [ String -> SDoc
Plugins.text String
ideaHint ]
sdocs1 :: [SDoc]
sdocs1 =
case Maybe String
ideaTo of
Maybe String
Nothing -> []
Just String
"" -> []
Just String
to -> [ String -> SDoc
Plugins.text (String
"Perhaps: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
to) ]
sdocs2 :: [SDoc]
sdocs2 = do
Note
note <- [Note]
ideaNote
SDoc -> [SDoc]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> SDoc
Plugins.text (String
"Note: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Note -> String
forall a. Show a => a -> String
show Note
note))
errMsgSpan :: SrcSpan
errMsgSpan = SrcSpan
ideaSpan
errMsgContext :: PrintUnqualified
errMsgContext = PrintUnqualified
Outputable.alwaysQualify
diagnosticMessage :: DiagnosticMessage
diagnosticMessage = DiagnosticMessage{[GhcHint]
DiagnosticReason
DecoratedSDoc
forall a. [a]
diagMessage :: DecoratedSDoc
diagReason :: DiagnosticReason
diagHints :: forall a. [a]
diagMessage :: DecoratedSDoc
diagReason :: DiagnosticReason
diagHints :: [GhcHint]
..}
where
diagMessage :: DecoratedSDoc
diagMessage = SDoc -> DecoratedSDoc
Error.mkSimpleDecorated SDoc
sdoc
diagReason :: DiagnosticReason
diagReason =
case Severity
ideaSeverity of
Severity
HLint.Ignore -> DiagnosticReason
WarningWithoutFlag
Severity
HLint.Suggestion -> DiagnosticReason
WarningWithoutFlag
Severity
HLint.Warning -> DiagnosticReason
WarningWithoutFlag
Severity
HLint.Error -> DiagnosticReason
ErrorWithoutFlag
diagHints :: [a]
diagHints = []
errMsgDiagnostic :: GhcMessage
errMsgDiagnostic =
DiagnosticMessage -> GhcMessage
forall a. (Diagnostic a, Typeable a) => a -> GhcMessage
Errors.Types.ghcUnknownMessage DiagnosticMessage
diagnosticMessage
errMsgSeverity :: Severity
errMsgSeverity =
case Severity
ideaSeverity of
Severity
HLint.Ignore -> Severity
Error.SevIgnore
Severity
HLint.Suggestion -> Severity
Error.SevWarning
Severity
HLint.Warning -> Severity
Error.SevWarning
Severity
HLint.Error -> Severity
Error.SevError