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 :: Plugin
plugin = Plugin
GHC.defaultPlugin
  { parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
GHC.parsedResultAction = [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
action
  , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
GHC.pluginRecompile = [CommandLineOption] -> IO PluginRecompile
GHC.purePlugin
  }

action
  :: [GHC.CommandLineOption]
  -> GHC.ModSummary
  -> GHC.HsParsedModule
  -> GHC.Hsc GHC.HsParsedModule
action :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
action [CommandLineOption]
commandLineOptions ModSummary
modSummary HsParsedModule
hsParsedModule = do
  (ParseFlags
parseFlags, [Classify]
classifies, Hint
hint) <- IO (ParseFlags, [Classify], Hint)
-> Hsc (ParseFlags, [Classify], Hint)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO (ParseFlags, [Classify], Hint)
 -> Hsc (ParseFlags, [Classify], Hint))
-> IO (ParseFlags, [Classify], Hint)
-> Hsc (ParseFlags, [Classify], Hint)
forall a b. (a -> b) -> a -> b
$ [CommandLineOption] -> IO (ParseFlags, [Classify], Hint)
Settings.load [CommandLineOption]
commandLineOptions
  ModuleEx
moduleEx <- ParseFlags -> ModSummary -> HsParsedModule -> Hsc ModuleEx
parse ParseFlags
parseFlags ModSummary
modSummary HsParsedModule
hsParsedModule
  DynFlags
dynFlags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO
    (IO () -> Hsc ()) -> ([Idea] -> IO ()) -> [Idea] -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Bag WarnMsg -> IO ()
GHC.printOrThrowWarnings DynFlags
dynFlags
    (Bag WarnMsg -> IO ())
-> ([Idea] -> Bag WarnMsg) -> [Idea] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WarnMsg] -> Bag WarnMsg
forall a. [a] -> Bag a
GHC.listToBag
    ([WarnMsg] -> Bag WarnMsg)
-> ([Idea] -> [WarnMsg]) -> [Idea] -> Bag WarnMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Idea -> WarnMsg) -> [Idea] -> [WarnMsg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags -> Idea -> WarnMsg
ideaToWarnMsg DynFlags
dynFlags)
    ([Idea] -> [WarnMsg]) -> ([Idea] -> [Idea]) -> [Idea] -> [WarnMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Idea -> Bool) -> [Idea] -> [Idea]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
HLint.Ignore) (Severity -> Bool) -> (Idea -> Severity) -> Idea -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Idea -> Severity
HLint.ideaSeverity)
    ([Idea] -> Hsc ()) -> [Idea] -> Hsc ()
forall a b. (a -> b) -> a -> b
$ [Classify] -> Hint -> [ModuleEx] -> [Idea]
HLint.applyHints [Classify]
classifies Hint
hint [ModuleEx
moduleEx]
  HsParsedModule -> Hsc HsParsedModule
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsParsedModule
hsParsedModule

ideaToWarnMsg :: GHC.DynFlags -> HLint.Idea -> GHC.WarnMsg
ideaToWarnMsg :: DynFlags -> Idea -> WarnMsg
ideaToWarnMsg DynFlags
dynFlags Idea
idea =
  let
    mkErrMsg :: DynFlags -> SrcSpan -> MsgDoc -> WarnMsg
mkErrMsg = case Idea -> Severity
HLint.ideaSeverity Idea
idea of
      Severity
HLint.Error -> DynFlags -> SrcSpan -> MsgDoc -> WarnMsg
GHC.mkPlainErrMsg
      Severity
_ -> DynFlags -> SrcSpan -> MsgDoc -> WarnMsg
GHC.mkPlainWarnMsg
    srcSpan :: SrcSpan
srcSpan = case SrcSpan -> Maybe (CommandLineOption, (Int, Int), (Int, Int))
HLint.unpackSrcSpan (SrcSpan -> Maybe (CommandLineOption, (Int, Int), (Int, Int)))
-> SrcSpan -> Maybe (CommandLineOption, (Int, Int), (Int, Int))
forall a b. (a -> b) -> a -> b
$ Idea -> SrcSpan
HLint.ideaSpan Idea
idea of
      Maybe (CommandLineOption, (Int, Int), (Int, Int))
Nothing -> SrcSpan
GHC.noSrcSpan
      Just (CommandLineOption
file, (Int
startLine, Int
startColumn), (Int
endLine, Int
endColumn)) ->
        SrcLoc -> SrcLoc -> SrcSpan
GHC.mkSrcSpan
          (FastString -> Int -> Int -> SrcLoc
GHC.mkSrcLoc (CommandLineOption -> FastString
GHC.mkFastString CommandLineOption
file) Int
startLine Int
startColumn)
          (FastString -> Int -> Int -> SrcLoc
GHC.mkSrcLoc (CommandLineOption -> FastString
GHC.mkFastString CommandLineOption
file) Int
endLine Int
endColumn)
    msgDoc :: MsgDoc
msgDoc = Idea -> MsgDoc
ideaToMsgDoc Idea
idea
  in DynFlags -> SrcSpan -> MsgDoc -> WarnMsg
mkErrMsg DynFlags
dynFlags SrcSpan
srcSpan MsgDoc
msgDoc

ideaToMsgDoc :: HLint.Idea -> GHC.MsgDoc
ideaToMsgDoc :: Idea -> MsgDoc
ideaToMsgDoc Idea
idea = [MsgDoc] -> MsgDoc
GHC.vcat
  [ CommandLineOption -> MsgDoc
GHC.text (CommandLineOption -> MsgDoc) -> CommandLineOption -> MsgDoc
forall a b. (a -> b) -> a -> b
$ Idea -> CommandLineOption
HLint.ideaHint Idea
idea
  , case Idea -> Maybe CommandLineOption
HLint.ideaTo Idea
idea of
    Just CommandLineOption
to | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CommandLineOption
to -> CommandLineOption -> MsgDoc
GHC.text (CommandLineOption -> MsgDoc) -> CommandLineOption -> MsgDoc
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"Perhaps: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. Semigroup a => a -> a -> a
<> CommandLineOption
to
    Maybe CommandLineOption
_ -> MsgDoc
GHC.empty
  , [MsgDoc] -> MsgDoc
GHC.vcat ([MsgDoc] -> MsgDoc) -> ([Note] -> [MsgDoc]) -> [Note] -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note -> MsgDoc) -> [Note] -> [MsgDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CommandLineOption -> MsgDoc
GHC.text (CommandLineOption -> MsgDoc)
-> (Note -> CommandLineOption) -> Note -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. Monoid a => a -> a -> a
mappend CommandLineOption
"Note: " (CommandLineOption -> CommandLineOption)
-> (Note -> CommandLineOption) -> Note -> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show) ([Note] -> MsgDoc) -> [Note] -> MsgDoc
forall a b. (a -> b) -> a -> b
$ Idea -> [Note]
HLint.ideaNote Idea
idea
  ]

parse
  :: HLint.ParseFlags
  -> GHC.ModSummary
  -> GHC.HsParsedModule
  -> GHC.Hsc HLint.ModuleEx
parse :: ParseFlags -> ModSummary -> HsParsedModule -> Hsc ModuleEx
parse ParseFlags
_ ModSummary
_ HsParsedModule
hsParsedModule = do
  let
    apiAnns :: ApiAnns
apiAnns = HsParsedModule -> ApiAnns
GHC.hpm_annotations HsParsedModule
hsParsedModule
    hsModule :: Located (HsModule GhcPs)
hsModule = HsParsedModule -> Located (HsModule GhcPs)
GHC.hpm_module HsParsedModule
hsParsedModule
  ModuleEx -> Hsc ModuleEx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleEx -> Hsc ModuleEx) -> ModuleEx -> Hsc ModuleEx
forall a b. (a -> b) -> a -> b
$ ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
HLint.createModuleEx ApiAnns
apiAnns Located (HsModule GhcPs)
hsModule