{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE OverloadedLabels      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PackageImports        #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE StrictData            #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -Wno-orphans   #-}

-- On 9.4 we get a new redundant constraint warning, but deleting the
-- constraint breaks the build on earlier versions. Rather than apply
-- lots of CPP, we just disable the warning until later.
{-# OPTIONS_GHC -Wno-redundant-constraints   #-}

#ifdef HLINT_ON_GHC_LIB
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z)
#else
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)
#endif

module Ide.Plugin.Hlint
  (
    descriptor
  , Log(..)
  ) where
import           Control.Arrow                                      ((&&&))
import           Control.Concurrent.STM
import           Control.DeepSeq
import           Control.Exception
import           Control.Lens                                       ((?~), (^.))
import           Control.Monad
import           Control.Monad.Error.Class                          (MonadError (throwError))
import           Control.Monad.IO.Class                             (MonadIO (liftIO))
import           Control.Monad.Trans.Class                          (MonadTrans (lift))
import           Control.Monad.Trans.Except                         (ExceptT (..),
                                                                     runExceptT)
import           Data.Aeson.Types                                   (FromJSON (..),
                                                                     ToJSON (..),
                                                                     Value (..))
import qualified Data.ByteString                                    as BS
import           Data.Hashable
import qualified Data.HashMap.Strict                                as Map
import qualified Data.Map                                           as M
import           Data.Maybe
import qualified Data.Text                                          as T
import qualified Data.Text.Encoding                                 as T
import           Data.Typeable
import           Development.IDE                                    hiding
                                                                    (Error,
                                                                     getExtensions)
import           Development.IDE.Core.Compile                       (sourceParser)
import           Development.IDE.Core.Rules                         (defineNoFile,
                                                                     getParsedModuleWithComments)
import           Development.IDE.Core.Shake                         (getDiagnostics)
import qualified Refact.Apply                                       as Refact
import qualified Refact.Types                                       as Refact

#ifdef HLINT_ON_GHC_LIB
import           Development.IDE.GHC.Compat                         (DynFlags,
                                                                     WarningFlag (Opt_WarnUnrecognisedPragmas),
                                                                     extensionFlags,
                                                                     ms_hspp_opts,
                                                                     topDir,
                                                                     wopt)
import qualified Development.IDE.GHC.Compat.Util                    as EnumSet

#if MIN_GHC_API_VERSION(9,4,0)
import qualified "ghc-lib-parser" GHC.Data.Strict                   as Strict
#endif
#if MIN_GHC_API_VERSION(9,0,0)
import           "ghc-lib-parser" GHC.Types.SrcLoc                  hiding
                                                                    (RealSrcSpan)
import qualified "ghc-lib-parser" GHC.Types.SrcLoc                  as GHC
#else
import           "ghc-lib-parser" SrcLoc                            hiding
                                                                    (RealSrcSpan)
import qualified "ghc-lib-parser" SrcLoc                            as GHC
#endif
import           "ghc-lib-parser" GHC.LanguageExtensions            (Extension)
import           Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
import           System.FilePath                                    (takeFileName)
import           System.IO                                          (IOMode (WriteMode),
                                                                     hClose,
                                                                     hPutStr,
                                                                     hSetEncoding,
                                                                     hSetNewlineMode,
                                                                     noNewlineTranslation,
                                                                     utf8,
                                                                     withFile)
import           System.IO.Temp
#else
import           Development.IDE.GHC.Compat                         hiding
                                                                    (setEnv,
                                                                     (<+>))
import           GHC.Generics                                       (Associativity (LeftAssociative, NotAssociative, RightAssociative))
#if MIN_GHC_API_VERSION(9,2,0)
import           Language.Haskell.GHC.ExactPrint.ExactPrint         (deltaOptions)
#else
import           Language.Haskell.GHC.ExactPrint.Delta              (deltaOptions)
#endif
import           Language.Haskell.GHC.ExactPrint.Parsers            (postParseTransform)
import           Language.Haskell.GHC.ExactPrint.Types              (Rigidity (..))
import           Language.Haskell.GhclibParserEx.Fixity             as GhclibParserEx (applyFixities)
import qualified Refact.Fixity                                      as Refact
#endif
import           Ide.Plugin.Config                                  hiding
                                                                    (Config)
import           Ide.Plugin.Error
import           Ide.Plugin.Properties
import           Ide.Plugin.Resolve
import           Ide.PluginUtils
import           Ide.Types                                          hiding
                                                                    (Config)
import           Language.Haskell.HLint                             as Hlint
import qualified Language.LSP.Protocol.Lens                         as LSP
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types                        hiding
                                                                    (Null)
import qualified Language.LSP.Protocol.Types                        as LSP
import           Language.LSP.Server                                (getVersionedTextDoc)

import qualified Development.IDE.Core.Shake                         as Shake
import           Development.IDE.Spans.Pragmas                      (LineSplitTextEdits (LineSplitTextEdits),
                                                                     NextPragmaInfo (NextPragmaInfo),
                                                                     getNextPragmaInfo,
                                                                     lineSplitDeleteTextEdit,
                                                                     lineSplitInsertTextEdit,
                                                                     lineSplitTextEdits,
                                                                     nextPragmaLine)
import           GHC.Generics                                       (Generic)
#if !MIN_VERSION_apply_refact(0,12,0)
import           System.Environment                                 (setEnv,
                                                                     unsetEnv)
#endif
import           Development.IDE.Core.PluginUtils                   as PluginUtils
import           Text.Regex.TDFA.Text                               ()
-- ---------------------------------------------------------------------

data Log
  = LogShake Shake.Log
  | LogApplying NormalizedFilePath (Either String WorkspaceEdit)
  | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]]
  | LogGetIdeas NormalizedFilePath
  | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them
  | forall a. (Pretty a) => LogResolve a

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
log -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
log
    LogApplying NormalizedFilePath
fp Either String WorkspaceEdit
res -> Doc ann
"Applying hint(s) for" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedFilePath -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
fp Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Either String WorkspaceEdit -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Either String WorkspaceEdit
res
    LogGeneratedIdeas NormalizedFilePath
fp [[Refactoring SrcSpan]]
ideas -> Doc ann
"Generated hlint ideas for for" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedFilePath -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
fp Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [[Refactoring SrcSpan]] -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow [[Refactoring SrcSpan]]
ideas
    LogUsingExtensions NormalizedFilePath
fp [String]
exts -> Doc ann
"Using extensions for " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedFilePath -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
fp Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [String] -> Doc ann
forall ann. [String] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [String]
exts
    LogGetIdeas NormalizedFilePath
fp -> Doc ann
"Getting hlint ideas for " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NormalizedFilePath -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
fp
    LogResolve a
msg -> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
msg

#ifdef HLINT_ON_GHC_LIB
-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib
#if !MIN_GHC_API_VERSION(9,0,0)
type BufSpan = ()
#endif
pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan
#if MIN_GHC_API_VERSION(9,4,0)
pattern $mRealSrcSpan :: forall {r}.
SrcSpan -> (RealSrcSpan -> Maybe BufSpan -> r) -> ((# #) -> r) -> r
RealSrcSpan x y <- GHC.RealSrcSpan x (fromStrictMaybe -> y)
#elif MIN_GHC_API_VERSION(9,0,0)
pattern RealSrcSpan x y = GHC.RealSrcSpan x y
#else
pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))
#endif
{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
#endif

#if MIN_GHC_API_VERSION(9,4,0)
fromStrictMaybe :: Strict.Maybe a -> Maybe a
fromStrictMaybe :: forall a. Maybe a -> Maybe a
fromStrictMaybe (Strict.Just a
a ) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
fromStrictMaybe  Maybe a
Strict.Nothing  = Maybe a
forall a. Maybe a
Nothing
#endif

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId =
  let resolveRecorder :: Recorder (WithPriority Log)
resolveRecorder = (Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
forall a. Pretty a => a -> Log
LogResolve Recorder (WithPriority Log)
recorder
      ([PluginCommand IdeState]
pluginCommands, PluginHandlers IdeState
pluginHandlers) = Recorder (WithPriority Log)
-> PluginId
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
-> ResolveFunction
     IdeState HlintResolveCommands 'Method_CodeActionResolve
-> ([PluginCommand IdeState], PluginHandlers IdeState)
forall ideState a.
FromJSON a =>
Recorder (WithPriority Log)
-> PluginId
-> PluginMethodHandler ideState 'Method_TextDocumentCodeAction
-> ResolveFunction ideState a 'Method_CodeActionResolve
-> ([PluginCommand ideState], PluginHandlers ideState)
mkCodeActionWithResolveAndCommand Recorder (WithPriority Log)
resolveRecorder PluginId
plId PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionProvider (Recorder (WithPriority Log)
-> ResolveFunction
     IdeState HlintResolveCommands 'Method_CodeActionResolve
resolveProvider Recorder (WithPriority Log)
recorder)
      desc :: Text
desc = Text
"Provides HLint diagnostics and code actions. Built with hlint-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VERSION_hlint
  in (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
desc)
  { pluginRules = rules recorder plId
  , pluginCommands = pluginCommands
  , pluginHandlers = pluginHandlers
  , pluginConfigDescriptor = defaultConfigDescriptor
      { configHasDiagnostics = True
      , configCustomConfig = mkCustomConfig properties
      }
  }

-- This rule only exists for generating file diagnostics
-- so the RuleResult is empty
data GetHlintDiagnostics = GetHlintDiagnostics
    deriving (GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
(GetHlintDiagnostics -> GetHlintDiagnostics -> Bool)
-> (GetHlintDiagnostics -> GetHlintDiagnostics -> Bool)
-> Eq GetHlintDiagnostics
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
== :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
$c/= :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
/= :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
Eq, Int -> GetHlintDiagnostics -> ShowS
[GetHlintDiagnostics] -> ShowS
GetHlintDiagnostics -> String
(Int -> GetHlintDiagnostics -> ShowS)
-> (GetHlintDiagnostics -> String)
-> ([GetHlintDiagnostics] -> ShowS)
-> Show GetHlintDiagnostics
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetHlintDiagnostics -> ShowS
showsPrec :: Int -> GetHlintDiagnostics -> ShowS
$cshow :: GetHlintDiagnostics -> String
show :: GetHlintDiagnostics -> String
$cshowList :: [GetHlintDiagnostics] -> ShowS
showList :: [GetHlintDiagnostics] -> ShowS
Show, Typeable, (forall x. GetHlintDiagnostics -> Rep GetHlintDiagnostics x)
-> (forall x. Rep GetHlintDiagnostics x -> GetHlintDiagnostics)
-> Generic GetHlintDiagnostics
forall x. Rep GetHlintDiagnostics x -> GetHlintDiagnostics
forall x. GetHlintDiagnostics -> Rep GetHlintDiagnostics x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GetHlintDiagnostics -> Rep GetHlintDiagnostics x
from :: forall x. GetHlintDiagnostics -> Rep GetHlintDiagnostics x
$cto :: forall x. Rep GetHlintDiagnostics x -> GetHlintDiagnostics
to :: forall x. Rep GetHlintDiagnostics x -> GetHlintDiagnostics
Generic)
instance Hashable GetHlintDiagnostics
instance NFData   GetHlintDiagnostics

type instance RuleResult GetHlintDiagnostics = ()

-- | Hlint rules to generate file diagnostics based on hlint hints
-- | This rule is recomputed when:
-- | - A file has been edited via
-- |    - `getIdeas` -> `getParsedModule` in any case
-- |    - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
-- | - The hlint specific settings have changed, via `getHlintSettingsRule`
rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
rules Recorder (WithPriority Log)
recorder PluginId
plugin = do
  Recorder (WithPriority Log)
-> (GetHlintDiagnostics
    -> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((GetHlintDiagnostics
  -> NormalizedFilePath -> Action (IdeResult ()))
 -> Rules ())
-> (GetHlintDiagnostics
    -> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetHlintDiagnostics
GetHlintDiagnostics NormalizedFilePath
file -> do
    PluginConfig
config <- PluginId -> Action PluginConfig
getPluginConfigAction PluginId
plugin
    let hlintOn :: Bool
hlintOn = PluginConfig -> Bool
plcGlobalOn PluginConfig
config Bool -> Bool -> Bool
&& PluginConfig -> Bool
plcDiagnosticsOn PluginConfig
config
    Either ParseError [Idea]
ideas <- if Bool
hlintOn then Recorder (WithPriority Log)
-> NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas Recorder (WithPriority Log)
recorder NormalizedFilePath
file else Either ParseError [Idea] -> Action (Either ParseError [Idea])
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right [])
    IdeResult () -> Action (IdeResult ())
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics NormalizedFilePath
file Either ParseError [Idea]
ideas, () -> Maybe ()
forall a. a -> Maybe a
Just ())

  Recorder (WithPriority Log)
-> (GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
defineNoFile ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
 -> Rules ())
-> (GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetHlintSettings
GetHlintSettings -> do
    (Config [String]
flags) <- PluginId -> Action Config
getHlintConfig PluginId
plugin
    IO (ParseFlags, [Classify], Hint)
-> Action (ParseFlags, [Classify], Hint)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ParseFlags, [Classify], Hint)
 -> Action (ParseFlags, [Classify], Hint))
-> IO (ParseFlags, [Classify], Hint)
-> Action (ParseFlags, [Classify], Hint)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (ParseFlags, [Classify], Hint)
argsSettings [String]
flags

  Action () -> Rules ()
forall a. Action a -> Rules ()
action (Action () -> Rules ()) -> Action () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
    HashMap NormalizedFilePath FileOfInterestStatus
files <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
    Action [Maybe ()] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [Maybe ()] -> Action ()) -> Action [Maybe ()] -> Action ()
forall a b. (a -> b) -> a -> b
$ GetHlintDiagnostics -> [NormalizedFilePath] -> Action [Maybe ()]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetHlintDiagnostics
GetHlintDiagnostics ([NormalizedFilePath] -> Action [Maybe ()])
-> [NormalizedFilePath] -> Action [Maybe ()]
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
Map.keys HashMap NormalizedFilePath FileOfInterestStatus
files

  where

      diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
      diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics NormalizedFilePath
file (Right [Idea]
ideas) =
       (NormalizedFilePath
file, ShowDiagnostic
ShowDiag,) (Diagnostic -> FileDiagnostic) -> [Diagnostic] -> [FileDiagnostic]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Diagnostic] -> [Diagnostic]
forall a. [Maybe a] -> [a]
catMaybes [Idea -> Maybe Diagnostic
ideaToDiagnostic Idea
i | Idea
i <- [Idea]
ideas]
      diagnostics NormalizedFilePath
file (Left ParseError
parseErr) =
        [(NormalizedFilePath
file, ShowDiagnostic
ShowDiag, ParseError -> Diagnostic
parseErrorToDiagnostic ParseError
parseErr)]


      ideaToDiagnostic :: Idea -> Maybe Diagnostic
      ideaToDiagnostic :: Idea -> Maybe Diagnostic
ideaToDiagnostic Idea
idea = do
        DiagnosticSeverity
diagnosticSeverity <- Severity -> Maybe DiagnosticSeverity
ideaSeverityToDiagnosticSeverity (Idea -> Severity
ideaSeverity Idea
idea)
        Diagnostic -> Maybe Diagnostic
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Diagnostic -> Maybe Diagnostic) -> Diagnostic -> Maybe Diagnostic
forall a b. (a -> b) -> a -> b
$
            LSP.Diagnostic {
              $sel:_range:Diagnostic :: Range
_range    = SrcSpan -> Range
srcSpanToRange (SrcSpan -> Range) -> SrcSpan -> Range
forall a b. (a -> b) -> a -> b
$ Idea -> SrcSpan
ideaSpan Idea
idea
            , $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
diagnosticSeverity
            -- we are encoding the fact that idea has refactorings in diagnostic code
            , $sel:_code:Diagnostic :: Maybe (Int32 |? Text)
_code     = (Int32 |? Text) -> Maybe (Int32 |? Text)
forall a. a -> Maybe a
Just (Text -> Int32 |? Text
forall a b. b -> a |? b
InR (Text -> Int32 |? Text) -> Text -> Int32 |? Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
codePre String -> ShowS
forall a. [a] -> [a] -> [a]
++ Idea -> String
ideaHint Idea
idea)
            , $sel:_source:Diagnostic :: Maybe Text
_source   = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"hlint"
            , $sel:_message:Diagnostic :: Text
_message  = Idea -> Text
idea2Message Idea
idea
            , $sel:_relatedInformation:Diagnostic :: Maybe [DiagnosticRelatedInformation]
_relatedInformation = Maybe [DiagnosticRelatedInformation]
forall a. Maybe a
Nothing
            , $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags     = Maybe [DiagnosticTag]
forall a. Maybe a
Nothing
            , $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = Maybe CodeDescription
forall a. Maybe a
Nothing
            , $sel:_data_:Diagnostic :: Maybe Value
_data_ = Maybe Value
forall a. Maybe a
Nothing
            }

        where
          codePre :: String
codePre = if [Refactoring SrcSpan] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Refactoring SrcSpan] -> Bool) -> [Refactoring SrcSpan] -> Bool
forall a b. (a -> b) -> a -> b
$ Idea -> [Refactoring SrcSpan]
ideaRefactoring Idea
idea then String
"" else String
"refact:"

          -- We only propogate error severity of hlint and downgrade other severities to Info.
          -- Currently, there are just 2 error level serverities present in hlint by default: https://github.com/ndmitchell/hlint/issues/1549#issuecomment-1892701824.
          -- And according to ndmitchell: The default error level severities of the two hints are justified and it's fairly uncommon to happen.
          -- GH Issue about discussion on this: https://github.com/ndmitchell/hlint/issues/1549
          ideaSeverityToDiagnosticSeverity :: Hlint.Severity -> Maybe LSP.DiagnosticSeverity
          ideaSeverityToDiagnosticSeverity :: Severity -> Maybe DiagnosticSeverity
ideaSeverityToDiagnosticSeverity Severity
Hlint.Ignore = Maybe DiagnosticSeverity
forall a. Maybe a
Nothing
          ideaSeverityToDiagnosticSeverity Severity
Hlint.Suggestion = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DiagnosticSeverity_Information
          ideaSeverityToDiagnosticSeverity Severity
Hlint.Warning = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DiagnosticSeverity_Information
          ideaSeverityToDiagnosticSeverity Severity
Hlint.Error = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DiagnosticSeverity_Error

      idea2Message :: Idea -> T.Text
      idea2Message :: Idea -> Text
idea2Message Idea
idea = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Idea -> String
ideaHint Idea
idea, Text
"Found:", Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Idea -> String
ideaFrom Idea
idea)]
                                     [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
toIdea [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Note -> Text) -> [Note] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Note -> String) -> Note -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> String
forall a. Show a => a -> String
show) (Idea -> [Note]
ideaNote Idea
idea)
        where
          toIdea :: [T.Text]
          toIdea :: [Text]
toIdea = case Idea -> Maybe String
ideaTo Idea
idea of
            Maybe String
Nothing -> []
            Just String
i  -> [String -> Text
T.pack String
"Why not:", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i]


      parseErrorToDiagnostic :: ParseError -> Diagnostic
      parseErrorToDiagnostic :: ParseError -> Diagnostic
parseErrorToDiagnostic (Hlint.ParseError SrcSpan
l String
msg String
contents) =
        LSP.Diagnostic {
            $sel:_range:Diagnostic :: Range
_range    = SrcSpan -> Range
srcSpanToRange SrcSpan
l
          , $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DiagnosticSeverity_Information
          , $sel:_code:Diagnostic :: Maybe (Int32 |? Text)
_code     = (Int32 |? Text) -> Maybe (Int32 |? Text)
forall a. a -> Maybe a
Just (Text -> Int32 |? Text
forall a b. b -> a |? b
InR Text
sourceParser)
          , $sel:_source:Diagnostic :: Maybe Text
_source   = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"hlint"
          , $sel:_message:Diagnostic :: Text
_message  = [Text] -> Text
T.unlines [String -> Text
T.pack String
msg,String -> Text
T.pack String
contents]
          , $sel:_relatedInformation:Diagnostic :: Maybe [DiagnosticRelatedInformation]
_relatedInformation = Maybe [DiagnosticRelatedInformation]
forall a. Maybe a
Nothing
          , $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags     = Maybe [DiagnosticTag]
forall a. Maybe a
Nothing
          , $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = Maybe CodeDescription
forall a. Maybe a
Nothing
          , $sel:_data_:Diagnostic :: Maybe Value
_data_ = Maybe Value
forall a. Maybe a
Nothing
        }

      -- This one is defined in Development.IDE.GHC.Error but here
      -- the types could come from ghc-lib or ghc
      srcSpanToRange :: SrcSpan -> LSP.Range
      srcSpanToRange :: SrcSpan -> Range
srcSpanToRange (RealSrcSpan RealSrcSpan
span Maybe BufSpan
_) = Range {
          $sel:_start:Range :: Position
_start = LSP.Position {
                $sel:_line:Position :: UInt
_line = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              , $sel:_character:Position :: UInt
_character  = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
        , $sel:_end:Range :: Position
_end   = LSP.Position {
                $sel:_line:Position :: UInt
_line = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
             , $sel:_character:Position :: UInt
_character = Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
        }
      srcSpanToRange (UnhelpfulSpan UnhelpfulSpanReason
_) = Range
noRange

getIdeas :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas :: Recorder (WithPriority Log)
-> NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas Recorder (WithPriority Log)
recorder NormalizedFilePath
nfp = do
  Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> Action ()) -> Log -> Action ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogGetIdeas NormalizedFilePath
nfp
  (ParseFlags
flags, [Classify]
classify, Hint
hint) <- GetHlintSettings -> Action (ParseFlags, [Classify], Hint)
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetHlintSettings
GetHlintSettings

  let applyHints' :: Maybe (Either ParseError ModuleEx) -> Either ParseError [Idea]
applyHints' (Just (Right ModuleEx
modEx)) = [Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right ([Idea] -> Either ParseError [Idea])
-> [Idea] -> Either ParseError [Idea]
forall a b. (a -> b) -> a -> b
$ [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints [Classify]
classify Hint
hint [ModuleEx
modEx]
      applyHints' (Just (Left ParseError
err)) = ParseError -> Either ParseError [Idea]
forall a b. a -> Either a b
Left ParseError
err
      applyHints' Maybe (Either ParseError ModuleEx)
Nothing = [Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right []

  (Maybe (Either ParseError ModuleEx) -> Either ParseError [Idea])
-> Action (Maybe (Either ParseError ModuleEx))
-> Action (Either ParseError [Idea])
forall a b. (a -> b) -> Action a -> Action b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Either ParseError ModuleEx) -> Either ParseError [Idea]
applyHints' (ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
moduleEx ParseFlags
flags)

  where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
#ifndef HLINT_ON_GHC_LIB
        moduleEx _flags = do
          mbpm <- getParsedModuleWithComments nfp
          return $ createModule <$> mbpm
          where
            createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu))
                  where anns = pm_annotations pm
                        modu = pm_parsed_source pm

            applyParseFlagsFixities :: ParsedSource -> ParsedSource
            applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul

            parseFlagsToFixities :: ParseFlags -> [(String, Fixity)]
            parseFlagsToFixities = map toFixity . Hlint.fixities

            toFixity :: FixityInfo -> (String, Fixity)
            toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
                where
                    f LeftAssociative  = InfixL
                    f RightAssociative = InfixR
                    f NotAssociative   = InfixN
#else
        moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
moduleEx ParseFlags
flags = do
          Maybe ParsedModule
mbpm <- NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModuleWithComments NormalizedFilePath
nfp
          -- If ghc was not able to parse the module, we disable hlint diagnostics
          if Maybe ParsedModule -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ParsedModule
mbpm
              then Maybe (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx))
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ParseError ModuleEx)
forall a. Maybe a
Nothing
              else do
                     ParseFlags
flags' <- ParseFlags -> Action ParseFlags
setExtensions ParseFlags
flags
                     (UTCTime
_, Maybe Text
contents) <- NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
                     let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
                     let contents' :: Maybe String
contents' = Text -> String
T.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
contents
                     Either ParseError ModuleEx -> Maybe (Either ParseError ModuleEx)
forall a. a -> Maybe a
Just (Either ParseError ModuleEx -> Maybe (Either ParseError ModuleEx))
-> Action (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either ParseError ModuleEx)
-> Action (Either ParseError ModuleEx)
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ParseFlags
-> String -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
flags' String
fp Maybe String
contents')

        setExtensions :: ParseFlags -> Action ParseFlags
setExtensions ParseFlags
flags = do
          [Extension]
hlintExts <- NormalizedFilePath -> Action [Extension]
getExtensions NormalizedFilePath
nfp
          Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> Action ()) -> Log -> Action ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [String] -> Log
LogUsingExtensions NormalizedFilePath
nfp ((Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> String
forall a. Show a => a -> String
show [Extension]
hlintExts)
          ParseFlags -> Action ParseFlags
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseFlags -> Action ParseFlags)
-> ParseFlags -> Action ParseFlags
forall a b. (a -> b) -> a -> b
$ ParseFlags
flags { enabledExtensions = hlintExts }

-- Gets extensions from ModSummary dynflags for the file.
-- Previously this would union extensions from both hlint's parsedFlags
-- and the ModSummary dynflags. However using the parsedFlags extensions
-- can sometimes interfere with the hlint parsing of the file.
-- See https://github.com/haskell/haskell-language-server/issues/1279
--
-- Note: this is used when HLINT_ON_GHC_LIB is defined. We seem to need
-- these extensions to construct dynflags to parse the file again. Therefore
-- using hlint default extensions doesn't seem to be a problem when
-- HLINT_ON_GHC_LIB is not defined because we don't parse the file again.
getExtensions :: NormalizedFilePath -> Action [Extension]
getExtensions :: NormalizedFilePath -> Action [Extension]
getExtensions NormalizedFilePath
nfp = do
    DynFlags
dflags <- Action DynFlags
getFlags
    let hscExts :: [Extension]
hscExts = EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
EnumSet.toList (DynFlags -> EnumSet Extension
extensionFlags DynFlags
dflags)
    let hscExts' :: [Extension]
hscExts' = (Extension -> Maybe Extension) -> [Extension] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Extension
GhclibParserEx.readExtension (String -> Maybe Extension)
-> (Extension -> String) -> Extension -> Maybe Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> String
forall a. Show a => a -> String
show) [Extension]
hscExts
    [Extension] -> Action [Extension]
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return [Extension]
hscExts'
  where getFlags :: Action DynFlags
        getFlags :: Action DynFlags
getFlags = do
          ModSummaryResult
modsum <- GetModSummary -> NormalizedFilePath -> Action ModSummaryResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
          DynFlags -> Action DynFlags
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Action DynFlags) -> DynFlags -> Action DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags) -> ModSummary -> DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum
#endif

-- ---------------------------------------------------------------------

data GetHlintSettings = GetHlintSettings
    deriving (GetHlintSettings -> GetHlintSettings -> Bool
(GetHlintSettings -> GetHlintSettings -> Bool)
-> (GetHlintSettings -> GetHlintSettings -> Bool)
-> Eq GetHlintSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetHlintSettings -> GetHlintSettings -> Bool
== :: GetHlintSettings -> GetHlintSettings -> Bool
$c/= :: GetHlintSettings -> GetHlintSettings -> Bool
/= :: GetHlintSettings -> GetHlintSettings -> Bool
Eq, Int -> GetHlintSettings -> ShowS
[GetHlintSettings] -> ShowS
GetHlintSettings -> String
(Int -> GetHlintSettings -> ShowS)
-> (GetHlintSettings -> String)
-> ([GetHlintSettings] -> ShowS)
-> Show GetHlintSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetHlintSettings -> ShowS
showsPrec :: Int -> GetHlintSettings -> ShowS
$cshow :: GetHlintSettings -> String
show :: GetHlintSettings -> String
$cshowList :: [GetHlintSettings] -> ShowS
showList :: [GetHlintSettings] -> ShowS
Show, Typeable, (forall x. GetHlintSettings -> Rep GetHlintSettings x)
-> (forall x. Rep GetHlintSettings x -> GetHlintSettings)
-> Generic GetHlintSettings
forall x. Rep GetHlintSettings x -> GetHlintSettings
forall x. GetHlintSettings -> Rep GetHlintSettings x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GetHlintSettings -> Rep GetHlintSettings x
from :: forall x. GetHlintSettings -> Rep GetHlintSettings x
$cto :: forall x. Rep GetHlintSettings x -> GetHlintSettings
to :: forall x. Rep GetHlintSettings x -> GetHlintSettings
Generic)
instance Hashable GetHlintSettings
instance NFData   GetHlintSettings
instance NFData Hint where rnf :: Hint -> ()
rnf = Hint -> ()
forall a. a -> ()
rwhnf
instance NFData Classify where rnf :: Classify -> ()
rnf = Classify -> ()
forall a. a -> ()
rwhnf
instance NFData ParseFlags where rnf :: ParseFlags -> ()
rnf = ParseFlags -> ()
forall a. a -> ()
rwhnf
instance Show Hint where show :: Hint -> String
show = String -> Hint -> String
forall a b. a -> b -> a
const String
"<hint>"
instance Show ParseFlags where show :: ParseFlags -> String
show = String -> ParseFlags -> String
forall a b. a -> b -> a
const String
"<parseFlags>"

type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint)

-- ---------------------------------------------------------------------

newtype Config = Config [String]

properties :: Properties '[ 'PropertyKey "flags" ('TArray String)]
properties :: Properties '[ 'PropertyKey "flags" ('TArray String)]
properties = Properties '[]
emptyProperties
  Properties '[]
-> (Properties '[]
    -> Properties '[ 'PropertyKey "flags" ('TArray String)])
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "flags"
-> Text
-> [String]
-> Properties '[]
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
forall (s :: Symbol) (r :: [PropertyKey]) a.
(KnownSymbol s, NotElem s r, ToJSON a, FromJSON a) =>
KeyNameProxy s
-> Text
-> [a]
-> Properties r
-> Properties ('PropertyKey s ('TArray a) : r)
defineArrayProperty KeyNameProxy "flags"
#flags
    Text
"Flags used by hlint" []

-- | Get the plugin config
getHlintConfig :: PluginId -> Action Config
getHlintConfig :: PluginId -> Action Config
getHlintConfig PluginId
pId =
  [String] -> Config
Config
    ([String] -> Config) -> Action [String] -> Action Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyNameProxy "flags"
-> PluginId
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
-> Action
     (ToHsType
        (FindByKeyName "flags" '[ 'PropertyKey "flags" ('TArray String)]))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction KeyNameProxy "flags"
#flags PluginId
pId Properties '[ 'PropertyKey "flags" ('TArray String)]
properties

-- ---------------------------------------------------------------------
codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionProvider IdeState
ideState PluginId
_pluginId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
documentId Range
_ CodeActionContext
context)
  | let TextDocumentIdentifier Uri
uri = TextDocumentIdentifier
documentId
  , Just NormalizedFilePath
docNormalizedFilePath <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (Uri -> NormalizedUri
toNormalizedUri Uri
uri)
  = do
    VersionedTextDocumentIdentifier
verTxtDocId <- LspM Config VersionedTextDocumentIdentifier
-> ExceptT
     PluginError (LspM Config) VersionedTextDocumentIdentifier
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config VersionedTextDocumentIdentifier
 -> ExceptT
      PluginError (LspM Config) VersionedTextDocumentIdentifier)
-> LspM Config VersionedTextDocumentIdentifier
-> ExceptT
     PluginError (LspM Config) VersionedTextDocumentIdentifier
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier
-> LspM Config VersionedTextDocumentIdentifier
forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc TextDocumentIdentifier
documentId
    IO ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Command |? CodeAction] |? Null)
 -> ExceptT
      PluginError (LspM Config) ([Command |? CodeAction] |? Null))
-> IO ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a b. (a -> b) -> a -> b
$ ([CodeAction] -> [Command |? CodeAction] |? Null)
-> IO [CodeAction] -> IO ([Command |? CodeAction] |? Null)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. a -> a |? b
InL ([Command |? CodeAction] -> [Command |? CodeAction] |? Null)
-> ([CodeAction] -> [Command |? CodeAction])
-> [CodeAction]
-> [Command |? CodeAction] |? Null
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeAction -> Command |? CodeAction)
-> [CodeAction] -> [Command |? CodeAction]
forall a b. (a -> b) -> [a] -> [b]
map CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
LSP.InR) (IO [CodeAction] -> IO ([Command |? CodeAction] |? Null))
-> IO [CodeAction] -> IO ([Command |? CodeAction] |? Null)
forall a b. (a -> b) -> a -> b
$ do
      [FileDiagnostic]
allDiagnostics <- STM [FileDiagnostic] -> IO [FileDiagnostic]
forall a. STM a -> IO a
atomically (STM [FileDiagnostic] -> IO [FileDiagnostic])
-> STM [FileDiagnostic] -> IO [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ IdeState -> STM [FileDiagnostic]
getDiagnostics IdeState
ideState

      let numHintsInDoc :: Int
numHintsInDoc = [Diagnostic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
            [Diagnostic
diagnostic | (NormalizedFilePath
diagnosticNormalizedFilePath, ShowDiagnostic
_, Diagnostic
diagnostic) <- [FileDiagnostic]
allDiagnostics
                        , Diagnostic -> Bool
validCommand Diagnostic
diagnostic
                        , NormalizedFilePath
diagnosticNormalizedFilePath NormalizedFilePath -> NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
docNormalizedFilePath
            ]
      let numHintsInContext :: Int
numHintsInContext = [Diagnostic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
            [Diagnostic
diagnostic | Diagnostic
diagnostic <- [Diagnostic]
diags
                        , Diagnostic -> Bool
validCommand Diagnostic
diagnostic
            ]
      let singleHintCodeActions :: [CodeAction]
singleHintCodeActions = [Diagnostic]
diags [Diagnostic] -> (Diagnostic -> [CodeAction]) -> [CodeAction]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VersionedTextDocumentIdentifier -> Diagnostic -> [CodeAction]
diagnosticToCodeActions VersionedTextDocumentIdentifier
verTxtDocId
      if Int
numHintsInDoc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Int
numHintsInContext Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then do
        [CodeAction] -> IO [CodeAction]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CodeAction] -> IO [CodeAction])
-> [CodeAction] -> IO [CodeAction]
forall a b. (a -> b) -> a -> b
$ [CodeAction]
singleHintCodeActions [CodeAction] -> [CodeAction] -> [CodeAction]
forall a. [a] -> [a] -> [a]
++ [VersionedTextDocumentIdentifier -> CodeAction
applyAllAction VersionedTextDocumentIdentifier
verTxtDocId]
      else
        [CodeAction] -> IO [CodeAction]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeAction]
singleHintCodeActions
  | Bool
otherwise
  = MessageResult 'Method_TextDocumentCodeAction
-> ExceptT
     PluginError
     (LspM Config)
     (MessageResult 'Method_TextDocumentCodeAction)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessageResult 'Method_TextDocumentCodeAction
 -> ExceptT
      PluginError
      (LspM Config)
      (MessageResult 'Method_TextDocumentCodeAction))
-> MessageResult 'Method_TextDocumentCodeAction
-> ExceptT
     PluginError
     (LspM Config)
     (MessageResult 'Method_TextDocumentCodeAction)
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. a -> a |? b
InL []

  where
    applyAllAction :: VersionedTextDocumentIdentifier -> CodeAction
applyAllAction VersionedTextDocumentIdentifier
verTxtDocId =
      let args :: Maybe Value
args = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ HlintResolveCommands -> Value
forall a. ToJSON a => a -> Value
toJSON (VersionedTextDocumentIdentifier
-> Maybe OneHint -> HlintResolveCommands
ApplyHint VersionedTextDocumentIdentifier
verTxtDocId Maybe OneHint
forall a. Maybe a
Nothing)
        in Text
-> Maybe CodeActionKind
-> Maybe [Diagnostic]
-> Maybe Bool
-> Maybe (Rec (("reason" .== Text) .+ Empty))
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction Text
"Apply all hints" (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionKind_QuickFix) Maybe [Diagnostic]
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
forall a. Maybe a
Nothing Maybe WorkspaceEdit
forall a. Maybe a
Nothing Maybe Command
forall a. Maybe a
Nothing Maybe Value
args

    -- |Some hints do not have an associated refactoring
    validCommand :: Diagnostic -> Bool
validCommand (LSP.Diagnostic Range
_ Maybe DiagnosticSeverity
_ (Just (InR Text
code)) Maybe CodeDescription
_ (Just Text
"hlint") Text
_ Maybe [DiagnosticTag]
_ Maybe [DiagnosticRelatedInformation]
_ Maybe Value
_) =
        Text
"refact:" Text -> Text -> Bool
`T.isPrefixOf` Text
code
    validCommand Diagnostic
_ =
        Bool
False

    diags :: [Diagnostic]
diags = CodeActionContext
context CodeActionContext
-> Getting [Diagnostic] CodeActionContext [Diagnostic]
-> [Diagnostic]
forall s a. s -> Getting a s a -> a
^. Getting [Diagnostic] CodeActionContext [Diagnostic]
forall s a. HasDiagnostics s a => Lens' s a
Lens' CodeActionContext [Diagnostic]
LSP.diagnostics

resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve
resolveProvider :: Recorder (WithPriority Log)
-> ResolveFunction
     IdeState HlintResolveCommands 'Method_CodeActionResolve
resolveProvider Recorder (WithPriority Log)
recorder IdeState
ideState PluginId
_plId MessageParams 'Method_CodeActionResolve
ca Uri
uri HlintResolveCommands
resolveValue = do
  NormalizedFilePath
file <-  Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
  case HlintResolveCommands
resolveValue of
    (ApplyHint VersionedTextDocumentIdentifier
verTxtDocId Maybe OneHint
oneHint) -> do
        WorkspaceEdit
edit <- LspM Config (Either PluginError WorkspaceEdit)
-> ExceptT PluginError (LspM Config) WorkspaceEdit
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (LspM Config (Either PluginError WorkspaceEdit)
 -> ExceptT PluginError (LspM Config) WorkspaceEdit)
-> LspM Config (Either PluginError WorkspaceEdit)
-> ExceptT PluginError (LspM Config) WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ IO (Either PluginError WorkspaceEdit)
-> LspM Config (Either PluginError WorkspaceEdit)
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError WorkspaceEdit)
 -> LspM Config (Either PluginError WorkspaceEdit))
-> IO (Either PluginError WorkspaceEdit)
-> LspM Config (Either PluginError WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> VersionedTextDocumentIdentifier
-> IO (Either PluginError WorkspaceEdit)
applyHint Recorder (WithPriority Log)
recorder IdeState
ideState NormalizedFilePath
file Maybe OneHint
oneHint VersionedTextDocumentIdentifier
verTxtDocId
        CodeAction -> ExceptT PluginError (LspM Config) CodeAction
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeAction -> ExceptT PluginError (LspM Config) CodeAction)
-> CodeAction -> ExceptT PluginError (LspM Config) CodeAction
forall a b. (a -> b) -> a -> b
$ MessageParams 'Method_CodeActionResolve
CodeAction
ca CodeAction -> (CodeAction -> CodeAction) -> CodeAction
forall a b. a -> (a -> b) -> b
& (Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
-> CodeAction -> Identity CodeAction
forall s a. HasEdit s a => Lens' s a
Lens' CodeAction (Maybe WorkspaceEdit)
LSP.edit ((Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
 -> CodeAction -> Identity CodeAction)
-> WorkspaceEdit -> CodeAction -> CodeAction
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ WorkspaceEdit
edit
    (IgnoreHint VersionedTextDocumentIdentifier
verTxtDocId Text
hintTitle ) -> do
        WorkspaceEdit
edit <- LspM Config (Either PluginError WorkspaceEdit)
-> ExceptT PluginError (LspM Config) WorkspaceEdit
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (LspM Config (Either PluginError WorkspaceEdit)
 -> ExceptT PluginError (LspM Config) WorkspaceEdit)
-> LspM Config (Either PluginError WorkspaceEdit)
-> ExceptT PluginError (LspM Config) WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ IO (Either PluginError WorkspaceEdit)
-> LspM Config (Either PluginError WorkspaceEdit)
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError WorkspaceEdit)
 -> LspM Config (Either PluginError WorkspaceEdit))
-> IO (Either PluginError WorkspaceEdit)
-> LspM Config (Either PluginError WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> VersionedTextDocumentIdentifier
-> Text
-> IO (Either PluginError WorkspaceEdit)
ignoreHint Recorder (WithPriority Log)
recorder IdeState
ideState NormalizedFilePath
file VersionedTextDocumentIdentifier
verTxtDocId Text
hintTitle
        CodeAction -> ExceptT PluginError (LspM Config) CodeAction
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeAction -> ExceptT PluginError (LspM Config) CodeAction)
-> CodeAction -> ExceptT PluginError (LspM Config) CodeAction
forall a b. (a -> b) -> a -> b
$ MessageParams 'Method_CodeActionResolve
CodeAction
ca CodeAction -> (CodeAction -> CodeAction) -> CodeAction
forall a b. a -> (a -> b) -> b
& (Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
-> CodeAction -> Identity CodeAction
forall s a. HasEdit s a => Lens' s a
Lens' CodeAction (Maybe WorkspaceEdit)
LSP.edit ((Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
 -> CodeAction -> Identity CodeAction)
-> WorkspaceEdit -> CodeAction -> CodeAction
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ WorkspaceEdit
edit

-- | Convert a hlint diagnostic into an apply and an ignore code action
-- if applicable
diagnosticToCodeActions :: VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]
diagnosticToCodeActions :: VersionedTextDocumentIdentifier -> Diagnostic -> [CodeAction]
diagnosticToCodeActions VersionedTextDocumentIdentifier
verTxtDocId Diagnostic
diagnostic
  | LSP.Diagnostic{ $sel:_source:Diagnostic :: Diagnostic -> Maybe Text
_source = Just Text
"hlint", $sel:_code:Diagnostic :: Diagnostic -> Maybe (Int32 |? Text)
_code = Just (InR Text
code), $sel:_range:Diagnostic :: Diagnostic -> Range
_range = LSP.Range Position
start Position
_ } <- Diagnostic
diagnostic
  , let isHintApplicable :: Bool
isHintApplicable = Text
"refact:" Text -> Text -> Bool
`T.isPrefixOf` Text
code
  , let hint :: Text
hint = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"refact:" Text
"" Text
code
  , let suppressHintTitle :: Text
suppressHintTitle = Text
"Ignore hint \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hint Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" in this module"
  , let suppressHintArguments :: HlintResolveCommands
suppressHintArguments = VersionedTextDocumentIdentifier -> Text -> HlintResolveCommands
IgnoreHint VersionedTextDocumentIdentifier
verTxtDocId Text
hint
  = [Maybe CodeAction] -> [CodeAction]
forall a. [Maybe a] -> [a]
catMaybes
      -- Applying the hint is marked preferred because it addresses the underlying error.
      -- Disabling the rule isn't, because less often used and configuration can be adapted.
      [ if | Bool
isHintApplicable
           , let applyHintTitle :: Text
applyHintTitle = Text
"Apply hint \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hint Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
                 applyHintArguments :: HlintResolveCommands
applyHintArguments = VersionedTextDocumentIdentifier
-> Maybe OneHint -> HlintResolveCommands
ApplyHint VersionedTextDocumentIdentifier
verTxtDocId (OneHint -> Maybe OneHint
forall a. a -> Maybe a
Just (OneHint -> Maybe OneHint) -> OneHint -> Maybe OneHint
forall a b. (a -> b) -> a -> b
$ Position -> Text -> OneHint
OneHint Position
start Text
hint) ->
               CodeAction -> Maybe CodeAction
forall a. a -> Maybe a
Just (Text -> Diagnostic -> Maybe Value -> Bool -> CodeAction
mkCodeAction Text
applyHintTitle Diagnostic
diagnostic (Value -> Maybe Value
forall a. a -> Maybe a
Just (HlintResolveCommands -> Value
forall a. ToJSON a => a -> Value
toJSON HlintResolveCommands
applyHintArguments)) Bool
True)
           | Bool
otherwise -> Maybe CodeAction
forall a. Maybe a
Nothing
      , CodeAction -> Maybe CodeAction
forall a. a -> Maybe a
Just (Text -> Diagnostic -> Maybe Value -> Bool -> CodeAction
mkCodeAction Text
suppressHintTitle Diagnostic
diagnostic (Value -> Maybe Value
forall a. a -> Maybe a
Just (HlintResolveCommands -> Value
forall a. ToJSON a => a -> Value
toJSON HlintResolveCommands
suppressHintArguments)) Bool
False)
      ]
  | Bool
otherwise = []

mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe Value -> Bool -> LSP.CodeAction
mkCodeAction :: Text -> Diagnostic -> Maybe Value -> Bool -> CodeAction
mkCodeAction Text
title Diagnostic
diagnostic Maybe Value
data_  Bool
isPreferred =
  LSP.CodeAction
    { $sel:_title:CodeAction :: Text
_title = Text
title
    , $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionKind_QuickFix
    , $sel:_diagnostics:CodeAction :: Maybe [Diagnostic]
_diagnostics = [Diagnostic] -> Maybe [Diagnostic]
forall a. a -> Maybe a
Just [Diagnostic
diagnostic]
    , $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
isPreferred
    , $sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== Text) .+ Empty))
_disabled = Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
forall a. Maybe a
Nothing
    , $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = Maybe WorkspaceEdit
forall a. Maybe a
Nothing
    , $sel:_command:CodeAction :: Maybe Command
_command = Maybe Command
forall a. Maybe a
Nothing
    , $sel:_data_:CodeAction :: Maybe Value
_data_ = Maybe Value
data_
    }

mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit]
mkSuppressHintTextEdits :: DynFlags -> Text -> Text -> [TextEdit]
mkSuppressHintTextEdits DynFlags
dynFlags Text
fileContents Text
hint =
  let
    NextPragmaInfo{ Int
$sel:nextPragmaLine:NextPragmaInfo :: NextPragmaInfo -> Int
nextPragmaLine :: Int
nextPragmaLine, Maybe LineSplitTextEdits
$sel:lineSplitTextEdits:NextPragmaInfo :: NextPragmaInfo -> Maybe LineSplitTextEdits
lineSplitTextEdits :: Maybe LineSplitTextEdits
lineSplitTextEdits } = DynFlags -> Maybe Text -> NextPragmaInfo
getNextPragmaInfo DynFlags
dynFlags (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
fileContents)
    nextPragmaLinePosition :: Position
nextPragmaLinePosition = UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nextPragmaLine) UInt
0
    nextPragmaRange :: Range
nextPragmaRange = Position -> Position -> Range
Range Position
nextPragmaLinePosition Position
nextPragmaLinePosition
    wnoUnrecognisedPragmasText :: Maybe Text
wnoUnrecognisedPragmasText =
      if WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnrecognisedPragmas DynFlags
dynFlags
      then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n"
      else Maybe Text
forall a. Maybe a
Nothing
    hlintIgnoreText :: Maybe Text
hlintIgnoreText = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"{-# HLINT ignore \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hint Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" #-}\n")
    -- we combine the texts into a single text because lsp-test currently
    -- applies text edits backwards and I want the options pragma to
    -- appear above the hlint pragma in the tests
    combinedText :: Text
combinedText = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text
wnoUnrecognisedPragmasText, Maybe Text
hlintIgnoreText]
    combinedTextEdit :: TextEdit
combinedTextEdit = Range -> Text -> TextEdit
LSP.TextEdit Range
nextPragmaRange Text
combinedText
    lineSplitTextEditList :: [TextEdit]
lineSplitTextEditList = [TextEdit]
-> (LineSplitTextEdits -> [TextEdit])
-> Maybe LineSplitTextEdits
-> [TextEdit]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\LineSplitTextEdits{TextEdit
$sel:lineSplitDeleteTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
$sel:lineSplitInsertTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
lineSplitInsertTextEdit :: TextEdit
lineSplitDeleteTextEdit :: TextEdit
..} -> [TextEdit
lineSplitInsertTextEdit, TextEdit
lineSplitDeleteTextEdit]) Maybe LineSplitTextEdits
lineSplitTextEdits
  in
    TextEdit
combinedTextEdit TextEdit -> [TextEdit] -> [TextEdit]
forall a. a -> [a] -> [a]
: [TextEdit]
lineSplitTextEditList
-- ---------------------------------------------------------------------

ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit)
ignoreHint :: Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> VersionedTextDocumentIdentifier
-> Text
-> IO (Either PluginError WorkspaceEdit)
ignoreHint Recorder (WithPriority Log)
_recorder IdeState
ideState NormalizedFilePath
nfp VersionedTextDocumentIdentifier
verTxtDocId Text
ignoreHintTitle = ExceptT PluginError IO WorkspaceEdit
-> IO (Either PluginError WorkspaceEdit)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PluginError IO WorkspaceEdit
 -> IO (Either PluginError WorkspaceEdit))
-> ExceptT PluginError IO WorkspaceEdit
-> IO (Either PluginError WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ do
  (FileVersion
_, Maybe Text
fileContents) <- String
-> IdeState
-> ExceptT PluginError Action (FileVersion, Maybe Text)
-> ExceptT PluginError IO (FileVersion, Maybe Text)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"Hlint.GetFileContents" IdeState
ideState (ExceptT PluginError Action (FileVersion, Maybe Text)
 -> ExceptT PluginError IO (FileVersion, Maybe Text))
-> ExceptT PluginError Action (FileVersion, Maybe Text)
-> ExceptT PluginError IO (FileVersion, Maybe Text)
forall a b. (a -> b) -> a -> b
$ GetFileContents
-> NormalizedFilePath
-> ExceptT PluginError Action (FileVersion, Maybe Text)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetFileContents
GetFileContents NormalizedFilePath
nfp
  (ModSummaryResult
msr, PositionMapping
_) <- String
-> IdeState
-> ExceptT PluginError Action (ModSummaryResult, PositionMapping)
-> ExceptT PluginError IO (ModSummaryResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"Hlint.GetModSummaryWithoutTimestamps" IdeState
ideState (ExceptT PluginError Action (ModSummaryResult, PositionMapping)
 -> ExceptT PluginError IO (ModSummaryResult, PositionMapping))
-> ExceptT PluginError Action (ModSummaryResult, PositionMapping)
-> ExceptT PluginError IO (ModSummaryResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetModSummaryWithoutTimestamps
-> NormalizedFilePath
-> ExceptT PluginError Action (ModSummaryResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
nfp
  case Maybe Text
fileContents of
    Just Text
contents -> do
        let dynFlags :: DynFlags
dynFlags = ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags) -> ModSummary -> DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
msr
            textEdits :: [TextEdit]
textEdits = DynFlags -> Text -> Text -> [TextEdit]
mkSuppressHintTextEdits DynFlags
dynFlags Text
contents Text
ignoreHintTitle
            workspaceEdit :: WorkspaceEdit
workspaceEdit =
                Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
LSP.WorkspaceEdit
                  (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just (Uri -> [TextEdit] -> Map Uri [TextEdit]
forall k a. k -> a -> Map k a
M.singleton (VersionedTextDocumentIdentifier
verTxtDocId VersionedTextDocumentIdentifier
-> Getting Uri VersionedTextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri VersionedTextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' VersionedTextDocumentIdentifier Uri
LSP.uri) [TextEdit]
textEdits))
                  Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing
                  Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing
        WorkspaceEdit -> ExceptT PluginError IO WorkspaceEdit
forall a. a -> ExceptT PluginError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WorkspaceEdit
workspaceEdit
    Maybe Text
Nothing -> PluginError -> ExceptT PluginError IO WorkspaceEdit
forall a. PluginError -> ExceptT PluginError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError -> ExceptT PluginError IO WorkspaceEdit)
-> PluginError -> ExceptT PluginError IO WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
"Unable to get fileContents"

-- ---------------------------------------------------------------------
data HlintResolveCommands =
    ApplyHint
      { HlintResolveCommands -> VersionedTextDocumentIdentifier
verTxtDocId :: VersionedTextDocumentIdentifier
      -- |If Nothing, apply all hints, otherise only apply
      -- the given hint
      , HlintResolveCommands -> Maybe OneHint
oneHint     :: Maybe OneHint
      }
  | IgnoreHint
      { verTxtDocId     :: VersionedTextDocumentIdentifier
      , HlintResolveCommands -> Text
ignoreHintTitle :: HintTitle
      } deriving ((forall x. HlintResolveCommands -> Rep HlintResolveCommands x)
-> (forall x. Rep HlintResolveCommands x -> HlintResolveCommands)
-> Generic HlintResolveCommands
forall x. Rep HlintResolveCommands x -> HlintResolveCommands
forall x. HlintResolveCommands -> Rep HlintResolveCommands x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HlintResolveCommands -> Rep HlintResolveCommands x
from :: forall x. HlintResolveCommands -> Rep HlintResolveCommands x
$cto :: forall x. Rep HlintResolveCommands x -> HlintResolveCommands
to :: forall x. Rep HlintResolveCommands x -> HlintResolveCommands
Generic, [HlintResolveCommands] -> Value
[HlintResolveCommands] -> Encoding
HlintResolveCommands -> Bool
HlintResolveCommands -> Value
HlintResolveCommands -> Encoding
(HlintResolveCommands -> Value)
-> (HlintResolveCommands -> Encoding)
-> ([HlintResolveCommands] -> Value)
-> ([HlintResolveCommands] -> Encoding)
-> (HlintResolveCommands -> Bool)
-> ToJSON HlintResolveCommands
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: HlintResolveCommands -> Value
toJSON :: HlintResolveCommands -> Value
$ctoEncoding :: HlintResolveCommands -> Encoding
toEncoding :: HlintResolveCommands -> Encoding
$ctoJSONList :: [HlintResolveCommands] -> Value
toJSONList :: [HlintResolveCommands] -> Value
$ctoEncodingList :: [HlintResolveCommands] -> Encoding
toEncodingList :: [HlintResolveCommands] -> Encoding
$comitField :: HlintResolveCommands -> Bool
omitField :: HlintResolveCommands -> Bool
ToJSON, Maybe HlintResolveCommands
Value -> Parser [HlintResolveCommands]
Value -> Parser HlintResolveCommands
(Value -> Parser HlintResolveCommands)
-> (Value -> Parser [HlintResolveCommands])
-> Maybe HlintResolveCommands
-> FromJSON HlintResolveCommands
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser HlintResolveCommands
parseJSON :: Value -> Parser HlintResolveCommands
$cparseJSONList :: Value -> Parser [HlintResolveCommands]
parseJSONList :: Value -> Parser [HlintResolveCommands]
$comittedField :: Maybe HlintResolveCommands
omittedField :: Maybe HlintResolveCommands
FromJSON)

type HintTitle = T.Text

data OneHint =
  OneHint
    { OneHint -> Position
oneHintPos   :: Position
    , OneHint -> Text
oneHintTitle :: HintTitle
    } deriving ((forall x. OneHint -> Rep OneHint x)
-> (forall x. Rep OneHint x -> OneHint) -> Generic OneHint
forall x. Rep OneHint x -> OneHint
forall x. OneHint -> Rep OneHint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OneHint -> Rep OneHint x
from :: forall x. OneHint -> Rep OneHint x
$cto :: forall x. Rep OneHint x -> OneHint
to :: forall x. Rep OneHint x -> OneHint
Generic, OneHint -> OneHint -> Bool
(OneHint -> OneHint -> Bool)
-> (OneHint -> OneHint -> Bool) -> Eq OneHint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OneHint -> OneHint -> Bool
== :: OneHint -> OneHint -> Bool
$c/= :: OneHint -> OneHint -> Bool
/= :: OneHint -> OneHint -> Bool
Eq, Int -> OneHint -> ShowS
[OneHint] -> ShowS
OneHint -> String
(Int -> OneHint -> ShowS)
-> (OneHint -> String) -> ([OneHint] -> ShowS) -> Show OneHint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OneHint -> ShowS
showsPrec :: Int -> OneHint -> ShowS
$cshow :: OneHint -> String
show :: OneHint -> String
$cshowList :: [OneHint] -> ShowS
showList :: [OneHint] -> ShowS
Show, [OneHint] -> Value
[OneHint] -> Encoding
OneHint -> Bool
OneHint -> Value
OneHint -> Encoding
(OneHint -> Value)
-> (OneHint -> Encoding)
-> ([OneHint] -> Value)
-> ([OneHint] -> Encoding)
-> (OneHint -> Bool)
-> ToJSON OneHint
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: OneHint -> Value
toJSON :: OneHint -> Value
$ctoEncoding :: OneHint -> Encoding
toEncoding :: OneHint -> Encoding
$ctoJSONList :: [OneHint] -> Value
toJSONList :: [OneHint] -> Value
$ctoEncodingList :: [OneHint] -> Encoding
toEncodingList :: [OneHint] -> Encoding
$comitField :: OneHint -> Bool
omitField :: OneHint -> Bool
ToJSON, Maybe OneHint
Value -> Parser [OneHint]
Value -> Parser OneHint
(Value -> Parser OneHint)
-> (Value -> Parser [OneHint]) -> Maybe OneHint -> FromJSON OneHint
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser OneHint
parseJSON :: Value -> Parser OneHint
$cparseJSONList :: Value -> Parser [OneHint]
parseJSONList :: Value -> Parser [OneHint]
$comittedField :: Maybe OneHint
omittedField :: Maybe OneHint
FromJSON)

applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)
applyHint :: Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> VersionedTextDocumentIdentifier
-> IO (Either PluginError WorkspaceEdit)
applyHint Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
nfp Maybe OneHint
mhint VersionedTextDocumentIdentifier
verTxtDocId =
  ExceptT PluginError IO WorkspaceEdit
-> IO (Either PluginError WorkspaceEdit)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PluginError IO WorkspaceEdit
 -> IO (Either PluginError WorkspaceEdit))
-> ExceptT PluginError IO WorkspaceEdit
-> IO (Either PluginError WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ do
    let runAction' :: Action a -> IO a
        runAction' :: forall a. Action a -> IO a
runAction' = String -> IdeState -> Action a -> IO a
forall a. String -> IdeState -> Action a -> IO a
runAction String
"applyHint" IdeState
ide
    let errorHandlers :: [Handler (Either String b)]
errorHandlers = [ (IOException -> IO (Either String b)) -> Handler (Either String b)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO (Either String b))
 -> Handler (Either String b))
-> (IOException -> IO (Either String b))
-> Handler (Either String b)
forall a b. (a -> b) -> a -> b
$ \IOException
e -> Either String b -> IO (Either String b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String b
forall a b. a -> Either a b
Left (IOException -> String
forall a. Show a => a -> String
show (IOException
e :: IOException)))
                        , (ErrorCall -> IO (Either String b)) -> Handler (Either String b)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ErrorCall -> IO (Either String b)) -> Handler (Either String b))
-> (ErrorCall -> IO (Either String b)) -> Handler (Either String b)
forall a b. (a -> b) -> a -> b
$ \ErrorCall
e -> Either String b -> IO (Either String b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String b
forall a b. a -> Either a b
Left (ErrorCall -> String
forall a. Show a => a -> String
show (ErrorCall
e :: ErrorCall)))
                        ]
    [Idea]
ideas <- (ParseError -> PluginError)
-> ([Idea] -> [Idea])
-> ExceptT ParseError IO [Idea]
-> ExceptT PluginError IO [Idea]
forall (m :: * -> *) e f a b.
Functor m =>
(e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT (Text -> PluginError
PluginInternalError (Text -> PluginError)
-> (ParseError -> Text) -> ParseError -> PluginError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
showParseError) [Idea] -> [Idea]
forall a. a -> a
id (ExceptT ParseError IO [Idea] -> ExceptT PluginError IO [Idea])
-> ExceptT ParseError IO [Idea] -> ExceptT PluginError IO [Idea]
forall a b. (a -> b) -> a -> b
$ IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea]
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea])
-> IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea]
forall a b. (a -> b) -> a -> b
$ Action (Either ParseError [Idea]) -> IO (Either ParseError [Idea])
forall a. Action a -> IO a
runAction' (Action (Either ParseError [Idea])
 -> IO (Either ParseError [Idea]))
-> Action (Either ParseError [Idea])
-> IO (Either ParseError [Idea])
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas Recorder (WithPriority Log)
recorder NormalizedFilePath
nfp
    let ideas' :: [Idea]
ideas' = [Idea] -> (OneHint -> [Idea]) -> Maybe OneHint -> [Idea]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Idea]
ideas (OneHint -> [Idea] -> [Idea]
`filterIdeas` [Idea]
ideas) Maybe OneHint
mhint
    let commands :: [[Refactoring SrcSpan]]
commands = (Idea -> [Refactoring SrcSpan])
-> [Idea] -> [[Refactoring SrcSpan]]
forall a b. (a -> b) -> [a] -> [b]
map Idea -> [Refactoring SrcSpan]
ideaRefactoring [Idea]
ideas'
    Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT PluginError IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> ExceptT PluginError IO ())
-> Log -> ExceptT PluginError IO ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [[Refactoring SrcSpan]] -> Log
LogGeneratedIdeas NormalizedFilePath
nfp [[Refactoring SrcSpan]]
commands
    let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
    (UTCTime
_, Maybe Text
mbOldContent) <- IO (UTCTime, Maybe Text)
-> ExceptT PluginError IO (UTCTime, Maybe Text)
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Maybe Text)
 -> ExceptT PluginError IO (UTCTime, Maybe Text))
-> IO (UTCTime, Maybe Text)
-> ExceptT PluginError IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a. Action a -> IO a
runAction' (Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text))
-> Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
    Text
oldContent <- ExceptT PluginError IO Text
-> (Text -> ExceptT PluginError IO Text)
-> Maybe Text
-> ExceptT PluginError IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO Text -> ExceptT PluginError IO Text
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT PluginError IO Text)
-> IO Text -> ExceptT PluginError IO Text
forall a b. (a -> b) -> a -> b
$ (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 (String -> IO ByteString
BS.readFile String
fp)) Text -> ExceptT PluginError IO Text
forall a. a -> ExceptT PluginError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mbOldContent
    ModSummaryResult
modsum <- IO ModSummaryResult -> ExceptT PluginError IO ModSummaryResult
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummaryResult -> ExceptT PluginError IO ModSummaryResult)
-> IO ModSummaryResult -> ExceptT PluginError IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ Action ModSummaryResult -> IO ModSummaryResult
forall a. Action a -> IO a
runAction' (Action ModSummaryResult -> IO ModSummaryResult)
-> Action ModSummaryResult -> IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ GetModSummary -> NormalizedFilePath -> Action ModSummaryResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
    let dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags) -> ModSummary -> DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum

    -- set Nothing as "position" for "applyRefactorings" because
    -- applyRefactorings expects the provided position to be _within_ the scope
    -- of each refactoring it will apply.
    -- But "Idea"s returned by HLint point to starting position of the expressions
    -- that contain refactorings, so they are often outside the refactorings' boundaries.
    let position :: Maybe a
position = Maybe a
forall a. Maybe a
Nothing
#ifdef HLINT_ON_GHC_LIB
    let writeFileUTF8NoNewLineTranslation :: String -> Text -> IO ()
writeFileUTF8NoNewLineTranslation String
file Text
txt =
            String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
file IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
                Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
                Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
noNewlineTranslation
                Handle -> String -> IO ()
hPutStr Handle
h (Text -> String
T.unpack Text
txt)
    Either String String
res <-
        IO (Either String String)
-> ExceptT PluginError IO (Either String String)
forall a. IO a -> ExceptT PluginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String String)
 -> ExceptT PluginError IO (Either String String))
-> IO (Either String String)
-> ExceptT PluginError IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
-> (String -> Handle -> IO (Either String String))
-> IO (Either String String)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (ShowS
takeFileName String
fp) ((String -> Handle -> IO (Either String String))
 -> IO (Either String String))
-> (String -> Handle -> IO (Either String String))
-> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ \String
temp Handle
h -> do
            Handle -> IO ()
hClose Handle
h
            String -> Text -> IO ()
writeFileUTF8NoNewLineTranslation String
temp Text
oldContent
            [Extension]
exts <- Action [Extension] -> IO [Extension]
forall a. Action a -> IO a
runAction' (Action [Extension] -> IO [Extension])
-> Action [Extension] -> IO [Extension]
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action [Extension]
getExtensions NormalizedFilePath
nfp
            -- We have to reparse extensions to remove the invalid ones
            let ([Extension]
enabled, [Extension]
disabled, [String]
_invalid) = [String] -> ([Extension], [Extension], [String])
Refact.parseExtensions ([String] -> ([Extension], [Extension], [String]))
-> [String] -> ([Extension], [Extension], [String])
forall a b. (a -> b) -> a -> b
$ (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show [Extension]
exts
            let refactExts :: [String]
refactExts = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show ([Extension] -> [String]) -> [Extension] -> [String]
forall a b. (a -> b) -> a -> b
$ [Extension]
enabled [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
disabled
            (String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> IO String -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Maybe (Int, Int)
-> [[Refactoring SrcSpan]]
-> String
-> [String]
-> IO String
applyRefactorings (DynFlags -> String
topDir DynFlags
dflags) Maybe (Int, Int)
forall a. Maybe a
position [[Refactoring SrcSpan]]
commands String
temp [String]
refactExts)
                IO (Either String String)
-> [Handler (Either String String)] -> IO (Either String String)
forall a. IO a -> [Handler a] -> IO a
`catches` [Handler (Either String String)]
forall {b}. [Handler (Either String b)]
errorHandlers
#else
    mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
    res <-
        case mbParsedModule of
            Nothing -> throwError "Apply hint: error parsing the module"
            Just pm -> do
                let anns = pm_annotations pm
                let modu = pm_parsed_source pm
                -- apply-refact uses RigidLayout
                let rigidLayout = deltaOptions RigidLayout
                (anns', modu') <-
                    ExceptT $ mapM (uncurry Refact.applyFixities)
                            $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
                liftIO $ (Right <$> Refact.applyRefactorings' position commands anns' modu')
                            `catches` errorHandlers
#endif
    case Either String String
res of
      Right String
appliedFile -> do
        let wsEdit :: WorkspaceEdit
wsEdit = Bool
-> (VersionedTextDocumentIdentifier, Text)
-> Text
-> WithDeletions
-> WorkspaceEdit
diffText' Bool
True (VersionedTextDocumentIdentifier
verTxtDocId, Text
oldContent) (String -> Text
T.pack String
appliedFile) WithDeletions
IncludeDeletions
        IO (Either PluginError WorkspaceEdit)
-> ExceptT PluginError IO WorkspaceEdit
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either PluginError WorkspaceEdit)
 -> ExceptT PluginError IO WorkspaceEdit)
-> IO (Either PluginError WorkspaceEdit)
-> ExceptT PluginError IO WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ Either PluginError WorkspaceEdit
-> IO (Either PluginError WorkspaceEdit)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceEdit -> Either PluginError WorkspaceEdit
forall a b. b -> Either a b
Right WorkspaceEdit
wsEdit)
      Left String
err ->
        PluginError -> ExceptT PluginError IO WorkspaceEdit
forall a. PluginError -> ExceptT PluginError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError -> ExceptT PluginError IO WorkspaceEdit)
-> PluginError -> ExceptT PluginError IO WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err
    where
          -- | If we are only interested in applying a particular hint then
          -- let's filter out all the irrelevant ideas
          filterIdeas :: OneHint -> [Idea] -> [Idea]
          filterIdeas :: OneHint -> [Idea] -> [Idea]
filterIdeas (OneHint (Position UInt
l UInt
c) Text
title) [Idea]
ideas =
            let title' :: String
title' = Text -> String
T.unpack Text
title
                ideaPos :: Idea -> (Int, Int)
ideaPos = (RealSrcSpan -> Int
srcSpanStartLine (RealSrcSpan -> Int)
-> (RealSrcSpan -> Int) -> RealSrcSpan -> (Int, Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& RealSrcSpan -> Int
srcSpanStartCol) (RealSrcSpan -> (Int, Int))
-> (Idea -> RealSrcSpan) -> Idea -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RealSrcSpan
toRealSrcSpan (SrcSpan -> RealSrcSpan)
-> (Idea -> SrcSpan) -> Idea -> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Idea -> SrcSpan
ideaSpan
            in (Idea -> Bool) -> [Idea] -> [Idea]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Idea
i -> Idea -> String
ideaHint Idea
i String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
title' Bool -> Bool -> Bool
&& Idea -> (Int, Int)
ideaPos Idea
i (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
lUInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+UInt
1, UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
cUInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+UInt
1)) [Idea]
ideas

          toRealSrcSpan :: SrcSpan -> RealSrcSpan
toRealSrcSpan (RealSrcSpan RealSrcSpan
real Maybe BufSpan
_) = RealSrcSpan
real
          toRealSrcSpan (UnhelpfulSpan UnhelpfulSpanReason
x) = String -> RealSrcSpan
forall a. HasCallStack => String -> a
error (String -> RealSrcSpan) -> String -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ String
"No real source span: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnhelpfulSpanReason -> String
forall a. Show a => a -> String
show UnhelpfulSpanReason
x

          showParseError :: Hlint.ParseError -> String
          showParseError :: ParseError -> String
showParseError (Hlint.ParseError SrcSpan
location String
message String
content) =
            [String] -> String
unlines [SrcSpan -> String
forall a. Show a => a -> String
show SrcSpan
location, String
message, String
content]

-- | Map over both failure and success.
bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT :: forall (m :: * -> *) e f a b.
Functor m =>
(e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT e -> f
f a -> b
g (ExceptT m (Either e a)
m) = m (Either f b) -> ExceptT f m b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((Either e a -> Either f b) -> m (Either e a) -> m (Either f b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either e a -> Either f b
h m (Either e a)
m) where
  h :: Either e a -> Either f b
h (Left e
e)  = f -> Either f b
forall a b. a -> Either a b
Left (e -> f
f e
e)
  h (Right a
a) = b -> Either f b
forall a b. b -> Either a b
Right (a -> b
g a
a)
{-# INLINE bimapExceptT #-}

-- ---------------------------------------------------------------------------
-- Apply-refact compatability, documentation copied from upstream apply-refact
-- ---------------------------------------------------------------------------

-- | Apply a set of refactorings as supplied by HLint
--
-- This compatibility function abstracts over https://github.com/mpickering/apply-refact/issues/133
-- for backwards compatability.
applyRefactorings ::
  -- | FilePath to [GHC's libdir](https://downloads.haskell.org/ghc/latest/docs/users_guide/using.html#ghc-flag---print-libdir).
  --
  -- It is possible to use @libdir@ from [ghc-paths package](https://hackage.haskell.org/package/ghc-paths), but note
  -- this will make it difficult to provide a binary distribution of your program.
  FilePath ->
  -- | Apply hints relevant to a specific position
  Maybe (Int, Int) ->
  -- | 'Refactoring's to apply. Each inner list corresponds to an HLint
  -- <https://hackage.haskell.org/package/hlint/docs/Language-Haskell-HLint.html#t:Idea Idea>.
  -- An @Idea@ may have more than one 'Refactoring'.
  --
  -- The @Idea@s are sorted in ascending order of starting location, and are applied
  -- in that order. If two @Idea@s start at the same location, the one with the larger
  -- source span comes first. An @Idea@ is filtered out (ignored) if there is an @Idea@
  -- prior to it which has an overlapping source span and is not filtered out.
  [[Refact.Refactoring Refact.SrcSpan]] ->
  -- | Target file
  FilePath ->
  -- | GHC extensions, e.g., @LambdaCase@, @NoStarIsType@. The list is processed from left
  -- to right. An extension (e.g., @StarIsType@) may be overridden later (e.g., by @NoStarIsType@).
  --
  -- These are in addition to the @LANGUAGE@ pragmas in the target file. When they conflict
  -- with the @LANGUAGE@ pragmas, pragmas win.
  [String] ->
  IO String
applyRefactorings :: String
-> Maybe (Int, Int)
-> [[Refactoring SrcSpan]]
-> String
-> [String]
-> IO String
applyRefactorings =
#if MIN_VERSION_apply_refact(0,12,0)
  String
-> Maybe (Int, Int)
-> [[Refactoring SrcSpan]]
-> String
-> [String]
-> IO String
Refact.applyRefactorings
#else
  \libdir pos refacts fp exts -> withRuntimeLibdir libdir (Refact.applyRefactorings pos refacts fp exts)

  where
    -- Setting a environment variable with the libdir used by ghc-exactprint.
    -- It is a workaround for an error caused by the use of a hardcoded at compile time libdir
    -- in ghc-exactprint that makes dependent executables non portables.
    -- See https://github.com/alanz/ghc-exactprint/issues/96.
    -- WARNING: this code is not thread safe, so if you try to apply several async refactorings
    -- it could fail. That case is not very likely so we assume the risk.
    withRuntimeLibdir :: FilePath -> IO a -> IO a
    withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key)
        where key = "GHC_EXACTPRINT_GHC_LIBDIR"
#endif