{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE PackageImports  #-}
{-# LANGUAGE RecordWildCards #-}

-- | This module provides a GHC plugin that you can use to run HLint on a
--   module
--
--  To do so, add this @hlint-plugin@ package as a build dependency of your
--  Haskell package and then add the GHC options @-fplugin HLint.Plugin@
--  To use this plugin, add this package as a build dependency and then enable
--  the following GHC options (typically in the @ghc-options:@ field of your
--  @.cabal@ file):
--
--  > -fplugin HLint.Plugin
--
--  You can pass command-line options to @hlint@ using @-fplugin-opt@, like
--  this:
--
--  > -fplugin HLint.Plugin -fplugin-opt='HLint.Plugin:--ignore=Redundant guard'
module HLint.Plugin
    ( -- * 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

-- | GHC plugin that runs HLint on a Haskell module after parsing the module
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