{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedLabels      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PackageImports        #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StrictData            #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}

{-# OPTIONS_GHC -Wno-orphans   #-}

#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.IO.Class
import           Control.Monad.Trans.Except
import           Data.Aeson.Types                                   (FromJSON (..),
                                                                     ToJSON (..),
                                                                     Value (..))
import qualified Data.ByteString                                    as BS
import           Data.Hashable
import qualified Data.HashMap.Strict                                as Map
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.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.Properties
import           Ide.PluginUtils
import           Ide.Types                                          hiding
                                                                    (Config)
import           Language.Haskell.HLint                             as Hlint hiding
                                                                             (Error)
import           Language.LSP.Server                                (ProgressCancellable (Cancellable),
                                                                     sendRequest,
                                                                     withIndefiniteProgress)
import           Language.LSP.Types                                 hiding
                                                                    (SemanticTokenAbsolute (length, line),
                                                                     SemanticTokenRelative (length),
                                                                     SemanticTokensEdit (_start))
import qualified Language.LSP.Types                                 as LSP
import qualified Language.LSP.Types.Lens                            as LSP

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)
import           System.Environment                                 (setEnv,
                                                                     unsetEnv)
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
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

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

#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 ) = forall a. a -> Maybe a
Just a
a
fromStrictMaybe  Maybe a
Strict.Nothing  = 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 = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
  { pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> PluginId -> Rules ()
rules Recorder (WithPriority Log)
recorder PluginId
plId
  , pluginCommands :: [PluginCommand IdeState]
pluginCommands =
      [ forall ideState a.
FromJSON a =>
CommandId
-> HintTitle
-> CommandFunction ideState a
-> PluginCommand ideState
PluginCommand CommandId
"applyOne" HintTitle
"Apply a single hint" (Recorder (WithPriority Log)
-> CommandFunction IdeState ApplyOneParams
applyOneCmd Recorder (WithPriority Log)
recorder)
      , forall ideState a.
FromJSON a =>
CommandId
-> HintTitle
-> CommandFunction ideState a
-> PluginCommand ideState
PluginCommand CommandId
"applyAll" HintTitle
"Apply all hints to the file" (Recorder (WithPriority Log) -> CommandFunction IdeState Uri
applyAllCmd Recorder (WithPriority Log)
recorder)
      ]
  , pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider
  , pluginConfigDescriptor :: ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor
defaultConfigDescriptor
      { configHasDiagnostics :: Bool
configHasDiagnostics = Bool
True
      , configCustomConfig :: CustomConfig
configCustomConfig = forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig Properties '[ 'PropertyKey "flags" ('TArray String)]
properties
      }
  }

-- This rule only exists for generating file diagnostics
-- so the RuleResult is empty
data GetHlintDiagnostics = GetHlintDiagnostics
    deriving (GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
$c/= :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
== :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
$c== :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
Eq, Int -> GetHlintDiagnostics -> ShowS
[GetHlintDiagnostics] -> ShowS
GetHlintDiagnostics -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetHlintDiagnostics] -> ShowS
$cshowList :: [GetHlintDiagnostics] -> ShowS
show :: GetHlintDiagnostics -> String
$cshow :: GetHlintDiagnostics -> String
showsPrec :: Int -> GetHlintDiagnostics -> ShowS
$cshowsPrec :: Int -> GetHlintDiagnostics -> ShowS
Show, Typeable, 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
$cto :: forall x. Rep GetHlintDiagnostics x -> GetHlintDiagnostics
$cfrom :: forall x. GetHlintDiagnostics -> Rep GetHlintDiagnostics x
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
  forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) 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) -> PluginConfig -> Bool
pluginEnabledConfig 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 forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right [])
    forall (m :: * -> *) a. Monad m => a -> m a
return (NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics NormalizedFilePath
file Either ParseError [Idea]
ideas, forall a. a -> Maybe a
Just ())

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

  forall a. Action a -> Rules ()
action forall a b. (a -> b) -> a -> b
$ do
    HashMap NormalizedFilePath FileOfInterestStatus
files <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetHlintDiagnostics
GetHlintDiagnostics forall a b. (a -> b) -> a -> b
$ 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, Idea -> Diagnostic
ideaToDiagnostic Idea
i) | Idea
i <- [Idea]
ideas, Idea -> Severity
ideaSeverity Idea
i forall a. Eq a => a -> a -> Bool
/= Severity
Ignore]
      diagnostics NormalizedFilePath
file (Left ParseError
parseErr) =
        [(NormalizedFilePath
file, ShowDiagnostic
ShowDiag, ParseError -> Diagnostic
parseErrorToDiagnostic ParseError
parseErr)]

      ideaToDiagnostic :: Idea -> Diagnostic
      ideaToDiagnostic :: Idea -> Diagnostic
ideaToDiagnostic Idea
idea =
        LSP.Diagnostic {
            $sel:_range:Diagnostic :: Range
_range    = SrcSpan -> Range
srcSpanToRange forall a b. (a -> b) -> a -> b
$ Idea -> SrcSpan
ideaSpan Idea
idea
          , $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DsInfo
          -- we are encoding the fact that idea has refactorings in diagnostic code
          , $sel:_code:Diagnostic :: Maybe (Int32 |? HintTitle)
_code     = forall a. a -> Maybe a
Just (forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ String
codePre forall a. [a] -> [a] -> [a]
++ Idea -> String
ideaHint Idea
idea)
          , $sel:_source:Diagnostic :: Maybe HintTitle
_source   = forall a. a -> Maybe a
Just HintTitle
"hlint"
          , $sel:_message:Diagnostic :: HintTitle
_message  = Idea -> HintTitle
idea2Message Idea
idea
          , $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = forall a. Maybe a
Nothing
          , $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags     = forall a. Maybe a
Nothing
        }
        where codePre :: String
codePre = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Idea -> [Refactoring SrcSpan]
ideaRefactoring Idea
idea then String
"" else String
"refact:"

      idea2Message :: Idea -> T.Text
      idea2Message :: Idea -> HintTitle
idea2Message Idea
idea = [HintTitle] -> HintTitle
T.unlines forall a b. (a -> b) -> a -> b
$ [String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ Idea -> String
ideaHint Idea
idea, HintTitle
"Found:", HintTitle
"  " forall a. Semigroup a => a -> a -> a
<> String -> HintTitle
T.pack (Idea -> String
ideaFrom Idea
idea)]
                                     forall a. Semigroup a => a -> a -> a
<> [HintTitle]
toIdea forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (String -> HintTitle
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (Idea -> [Note]
ideaNote Idea
idea)
        where
          toIdea :: [T.Text]
          toIdea :: [HintTitle]
toIdea = case Idea -> Maybe String
ideaTo Idea
idea of
            Maybe String
Nothing -> []
            Just String
i  -> [String -> HintTitle
T.pack String
"Why not:", String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ String
"  " 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 = forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DsInfo
          , $sel:_code:Diagnostic :: Maybe (Int32 |? HintTitle)
_code     = forall a. a -> Maybe a
Just (forall a b. b -> a |? b
InR HintTitle
"parser")
          , $sel:_source:Diagnostic :: Maybe HintTitle
_source   = forall a. a -> Maybe a
Just HintTitle
"hlint"
          , $sel:_message:Diagnostic :: HintTitle
_message  = [HintTitle] -> HintTitle
T.unlines [String -> HintTitle
T.pack String
msg,String -> HintTitle
T.pack String
contents]
          , $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = forall a. Maybe a
Nothing
          , $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags     = 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 {
          _start :: Position
_start = LSP.Position {
                _line :: UInt
_line = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1
              , _character :: UInt
_character  = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1}
        , _end :: Position
_end   = LSP.Position {
                _line :: UInt
_line = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1
             , _character :: UInt
_character = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span 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
  forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogGetIdeas NormalizedFilePath
nfp
  (ParseFlags
flags, [Classify]
classify, Hint
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)) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints [Classify]
classify Hint
hint [ModuleEx
modEx]
      applyHints' (Just (Left ParseError
err)) = forall a b. a -> Either a b
Left ParseError
err
      applyHints' Maybe (Either ParseError ModuleEx)
Nothing = forall a b. b -> Either a b
Right []

  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 forall a. Maybe a -> Bool
isNothing Maybe ParsedModule
mbpm
              then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
              else do
                     ParseFlags
flags' <- ParseFlags -> Action ParseFlags
setExtensions ParseFlags
flags
                     (UTCTime
_, Maybe HintTitle
contents) <- NormalizedFilePath -> Action (UTCTime, Maybe HintTitle)
getFileContents NormalizedFilePath
nfp
                     let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
                     let contents' :: Maybe String
contents' = HintTitle -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HintTitle
contents
                     forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
          forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [String] -> Log
LogUsingExtensions NormalizedFilePath
nfp (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
show [Extension]
hlintExts)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParseFlags
flags { enabledExtensions :: [Extension]
enabledExtensions = [Extension]
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 = forall a. Enum a => EnumSet a -> [a]
EnumSet.toList (DynFlags -> EnumSet Extension
extensionFlags DynFlags
dflags)
    let hscExts' :: [Extension]
hscExts' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Extension
GhclibParserEx.readExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Extension]
hscExts
    forall (m :: * -> *) a. Monad m => a -> m a
return [Extension]
hscExts'
  where getFlags :: Action DynFlags
        getFlags :: Action DynFlags
getFlags = do
          ModSummaryResult
modsum <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum
#endif

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

data GetHlintSettings = GetHlintSettings
    deriving (GetHlintSettings -> GetHlintSettings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetHlintSettings -> GetHlintSettings -> Bool
$c/= :: GetHlintSettings -> GetHlintSettings -> Bool
== :: GetHlintSettings -> GetHlintSettings -> Bool
$c== :: GetHlintSettings -> GetHlintSettings -> Bool
Eq, Int -> GetHlintSettings -> ShowS
[GetHlintSettings] -> ShowS
GetHlintSettings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetHlintSettings] -> ShowS
$cshowList :: [GetHlintSettings] -> ShowS
show :: GetHlintSettings -> String
$cshow :: GetHlintSettings -> String
showsPrec :: Int -> GetHlintSettings -> ShowS
$cshowsPrec :: Int -> GetHlintSettings -> ShowS
Show, Typeable, 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
$cto :: forall x. Rep GetHlintSettings x -> GetHlintSettings
$cfrom :: forall x. GetHlintSettings -> Rep GetHlintSettings x
Generic)
instance Hashable GetHlintSettings
instance NFData   GetHlintSettings
instance NFData Hint where rnf :: Hint -> ()
rnf = forall a. a -> ()
rwhnf
instance NFData Classify where rnf :: Classify -> ()
rnf = forall a. a -> ()
rwhnf
instance NFData ParseFlags where rnf :: ParseFlags -> ()
rnf = forall a. a -> ()
rwhnf
instance Show Hint where show :: Hint -> String
show = forall a b. a -> b -> a
const String
"<hint>"
instance Show ParseFlags where show :: ParseFlags -> String
show = 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
  forall a b. a -> (a -> b) -> b
& forall (s :: Symbol) (r :: [PropertyKey]) a.
(KnownSymbol s, NotElem s r, ToJSON a, FromJSON a) =>
KeyNameProxy s
-> HintTitle
-> [a]
-> Properties r
-> Properties ('PropertyKey s ('TArray a) : r)
defineArrayProperty forall a. IsLabel "flags" a => a
#flags
    HintTitle
"Flags used by hlint" []

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

runHlintAction
 :: (Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k, Typeable (RuleResult k), NFData k, NFData (RuleResult k))
 => IdeState
 -> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction :: forall k.
(Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k,
 Typeable (RuleResult k), NFData k, NFData (RuleResult k)) =>
IdeState
-> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction IdeState
ideState NormalizedFilePath
normalizedFilePath String
desc k
rule = forall a. String -> IdeState -> Action a -> IO a
runAction String
desc IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
rule NormalizedFilePath
normalizedFilePath

runGetFileContentsAction :: IdeState -> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe T.Text))
runGetFileContentsAction :: IdeState
-> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe HintTitle))
runGetFileContentsAction IdeState
ideState NormalizedFilePath
normalizedFilePath = forall k.
(Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k,
 Typeable (RuleResult k), NFData k, NFData (RuleResult k)) =>
IdeState
-> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction IdeState
ideState NormalizedFilePath
normalizedFilePath String
"Hlint.GetFileContents" GetFileContents
GetFileContents

runGetModSummaryAction :: IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult)
runGetModSummaryAction :: IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult)
runGetModSummaryAction IdeState
ideState NormalizedFilePath
normalizedFilePath = forall k.
(Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k,
 Typeable (RuleResult k), NFData k, NFData (RuleResult k)) =>
IdeState
-> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction IdeState
ideState NormalizedFilePath
normalizedFilePath String
"Hlint.GetModSummary" GetModSummary
GetModSummary

-- ---------------------------------------------------------------------
codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState '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)
  = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> List a
LSP.List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> a |? b
LSP.InR) forall a b. (a -> b) -> a -> b
$ do
      [FileDiagnostic]
allDiagnostics <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ IdeState -> STM [FileDiagnostic]
getDiagnostics IdeState
ideState
      let numHintsInDoc :: Int
numHintsInDoc = 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 forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
docNormalizedFilePath
            ]
      let numHintsInContext :: Int
numHintsInContext = forall (t :: * -> *) a. Foldable t => t a -> Int
length
            [Diagnostic
diagnostic | Diagnostic
diagnostic <- [Diagnostic]
diags
                        , Diagnostic -> Bool
validCommand Diagnostic
diagnostic
            ]
      Maybe (FileVersion, Maybe HintTitle)
file <- IdeState
-> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe HintTitle))
runGetFileContentsAction IdeState
ideState NormalizedFilePath
docNormalizedFilePath
      [CodeAction]
singleHintCodeActions <-
        if | Just (FileVersion
_, Maybe HintTitle
source) <- Maybe (FileVersion, Maybe HintTitle)
file -> do
               Maybe ModSummaryResult
modSummaryResult <- IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult)
runGetModSummaryAction IdeState
ideState NormalizedFilePath
docNormalizedFilePath
               forall (f :: * -> *) a. Applicative f => a -> f a
pure if | Just ModSummaryResult
modSummaryResult <- Maybe ModSummaryResult
modSummaryResult
                       , Just HintTitle
source <- Maybe HintTitle
source
                       , let dynFlags :: DynFlags
dynFlags = ModSummary -> DynFlags
ms_hspp_opts forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modSummaryResult ->
                           [Diagnostic]
diags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynFlags
-> HintTitle
-> PluginId
-> TextDocumentIdentifier
-> Diagnostic
-> [CodeAction]
diagnosticToCodeActions DynFlags
dynFlags HintTitle
source PluginId
pluginId TextDocumentIdentifier
documentId
                       | Bool
otherwise -> []
           | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      if Int
numHintsInDoc forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Int
numHintsInContext forall a. Ord a => a -> a -> Bool
> Int
0 then do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [CodeAction]
singleHintCodeActions forall a. [a] -> [a] -> [a]
++ [CodeAction
applyAllAction]
      else
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeAction]
singleHintCodeActions
  | Bool
otherwise
  = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
LSP.List []

  where
    applyAllAction :: CodeAction
applyAllAction =
      let args :: Maybe [Value]
args = forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON (TextDocumentIdentifier
documentId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
LSP.uri)]
          cmd :: Command
cmd = PluginId -> CommandId -> HintTitle -> Maybe [Value] -> Command
mkLspCommand PluginId
pluginId CommandId
"applyAll" HintTitle
"Apply all hints" Maybe [Value]
args
        in HintTitle
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction HintTitle
"Apply all hints" (forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionQuickFix) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Command
cmd) forall a. Maybe a
Nothing

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

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

-- | Convert a hlint diagnostic into an apply and an ignore code action
-- if applicable
diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> TextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]
diagnosticToCodeActions :: DynFlags
-> HintTitle
-> PluginId
-> TextDocumentIdentifier
-> Diagnostic
-> [CodeAction]
diagnosticToCodeActions DynFlags
dynFlags HintTitle
fileContents PluginId
pluginId TextDocumentIdentifier
documentId Diagnostic
diagnostic
  | LSP.Diagnostic{ $sel:_source:Diagnostic :: Diagnostic -> Maybe HintTitle
_source = Just HintTitle
"hlint", $sel:_code:Diagnostic :: Diagnostic -> Maybe (Int32 |? HintTitle)
_code = Just (InR HintTitle
code), $sel:_range:Diagnostic :: Diagnostic -> Range
_range = LSP.Range Position
start Position
_ } <- Diagnostic
diagnostic
  , let TextDocumentIdentifier Uri
uri = TextDocumentIdentifier
documentId
  , let isHintApplicable :: Bool
isHintApplicable = HintTitle
"refact:" HintTitle -> HintTitle -> Bool
`T.isPrefixOf` HintTitle
code
  , let hint :: HintTitle
hint = HintTitle -> HintTitle -> HintTitle -> HintTitle
T.replace HintTitle
"refact:" HintTitle
"" HintTitle
code
  , let suppressHintTitle :: HintTitle
suppressHintTitle = HintTitle
"Ignore hint \"" forall a. Semigroup a => a -> a -> a
<> HintTitle
hint forall a. Semigroup a => a -> a -> a
<> HintTitle
"\" in this module"
  , let suppressHintTextEdits :: [TextEdit]
suppressHintTextEdits = DynFlags -> HintTitle -> HintTitle -> [TextEdit]
mkSuppressHintTextEdits DynFlags
dynFlags HintTitle
fileContents HintTitle
hint
  , let suppressHintWorkspaceEdit :: WorkspaceEdit
suppressHintWorkspaceEdit =
          Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
LSP.WorkspaceEdit
            (forall a. a -> Maybe a
Just (forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton Uri
uri (forall a. [a] -> List a
List [TextEdit]
suppressHintTextEdits)))
            forall a. Maybe a
Nothing
            forall a. Maybe a
Nothing
  = 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 :: HintTitle
applyHintTitle = HintTitle
"Apply hint \"" forall a. Semigroup a => a -> a -> a
<> HintTitle
hint forall a. Semigroup a => a -> a -> a
<> HintTitle
"\""
                 applyHintArguments :: [Value]
applyHintArguments = [forall a. ToJSON a => a -> Value
toJSON (Uri -> Position -> HintTitle -> ApplyOneParams
AOP (TextDocumentIdentifier
documentId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
LSP.uri) Position
start HintTitle
hint)]
                 applyHintCommand :: Command
applyHintCommand = PluginId -> CommandId -> HintTitle -> Maybe [Value] -> Command
mkLspCommand PluginId
pluginId CommandId
"applyOne" HintTitle
applyHintTitle (forall a. a -> Maybe a
Just [Value]
applyHintArguments) ->
               forall a. a -> Maybe a
Just (HintTitle
-> Diagnostic
-> Maybe WorkspaceEdit
-> Maybe Command
-> Bool
-> CodeAction
mkCodeAction HintTitle
applyHintTitle Diagnostic
diagnostic forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Command
applyHintCommand) Bool
True)
           | Bool
otherwise -> forall a. Maybe a
Nothing
      , forall a. a -> Maybe a
Just (HintTitle
-> Diagnostic
-> Maybe WorkspaceEdit
-> Maybe Command
-> Bool
-> CodeAction
mkCodeAction HintTitle
suppressHintTitle Diagnostic
diagnostic (forall a. a -> Maybe a
Just WorkspaceEdit
suppressHintWorkspaceEdit) forall a. Maybe a
Nothing Bool
False)
      ]
  | Bool
otherwise = []

mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe LSP.WorkspaceEdit -> Maybe LSP.Command -> Bool -> LSP.CodeAction
mkCodeAction :: HintTitle
-> Diagnostic
-> Maybe WorkspaceEdit
-> Maybe Command
-> Bool
-> CodeAction
mkCodeAction HintTitle
title Diagnostic
diagnostic Maybe WorkspaceEdit
workspaceEdit Maybe Command
command Bool
isPreferred =
  LSP.CodeAction
    { $sel:_title:CodeAction :: HintTitle
_title = HintTitle
title
    , $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionQuickFix
    , $sel:_diagnostics:CodeAction :: Maybe (List Diagnostic)
_diagnostics = forall a. a -> Maybe a
Just (forall a. [a] -> List a
LSP.List [Diagnostic
diagnostic])
    , $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = forall a. a -> Maybe a
Just Bool
isPreferred
    , $sel:_disabled:CodeAction :: Maybe Reason
_disabled = forall a. Maybe a
Nothing
    , $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = Maybe WorkspaceEdit
workspaceEdit
    , $sel:_command:CodeAction :: Maybe Command
_command = Maybe Command
command
    , $sel:_xdata:CodeAction :: Maybe Value
_xdata = forall a. Maybe a
Nothing
    }

mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit]
mkSuppressHintTextEdits :: DynFlags -> HintTitle -> HintTitle -> [TextEdit]
mkSuppressHintTextEdits DynFlags
dynFlags HintTitle
fileContents HintTitle
hint =
  let
    NextPragmaInfo{ Int
nextPragmaLine :: Int
$sel:nextPragmaLine:NextPragmaInfo :: NextPragmaInfo -> Int
nextPragmaLine, Maybe LineSplitTextEdits
lineSplitTextEdits :: Maybe LineSplitTextEdits
$sel:lineSplitTextEdits:NextPragmaInfo :: NextPragmaInfo -> Maybe LineSplitTextEdits
lineSplitTextEdits } = DynFlags -> Maybe HintTitle -> NextPragmaInfo
getNextPragmaInfo DynFlags
dynFlags (forall a. a -> Maybe a
Just HintTitle
fileContents)
    nextPragmaLinePosition :: Position
nextPragmaLinePosition = UInt -> UInt -> Position
Position (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 HintTitle
wnoUnrecognisedPragmasText =
      if WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnrecognisedPragmas DynFlags
dynFlags
      then forall a. a -> Maybe a
Just HintTitle
"{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n"
      else forall a. Maybe a
Nothing
    hlintIgnoreText :: Maybe HintTitle
hlintIgnoreText = forall a. a -> Maybe a
Just (HintTitle
"{-# HLINT ignore \"" forall a. Semigroup a => a -> a -> a
<> HintTitle
hint forall a. Semigroup a => a -> a -> a
<> HintTitle
"\" #-}\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 :: HintTitle
combinedText = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe HintTitle
wnoUnrecognisedPragmasText, Maybe HintTitle
hlintIgnoreText]
    combinedTextEdit :: TextEdit
combinedTextEdit = Range -> HintTitle -> TextEdit
LSP.TextEdit Range
nextPragmaRange HintTitle
combinedText
    lineSplitTextEditList :: [TextEdit]
lineSplitTextEditList = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\LineSplitTextEdits{TextEdit
lineSplitDeleteTextEdit :: TextEdit
lineSplitInsertTextEdit :: TextEdit
$sel:lineSplitInsertTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
$sel:lineSplitDeleteTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
..} -> [TextEdit
lineSplitInsertTextEdit, TextEdit
lineSplitDeleteTextEdit]) Maybe LineSplitTextEdits
lineSplitTextEdits
  in
    TextEdit
combinedTextEdit forall a. a -> [a] -> [a]
: [TextEdit]
lineSplitTextEditList
-- ---------------------------------------------------------------------

applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
applyAllCmd Recorder (WithPriority Log)
recorder IdeState
ide Uri
uri = do
  let file :: NormalizedFilePath
file = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Uri
uri forall a. [a] -> [a] -> [a]
++ String
" is not a file.")
                    String -> NormalizedFilePath
toNormalizedFilePath'
                   (Uri -> Maybe String
uriToFilePath' Uri
uri)
  forall c (m :: * -> *) a.
MonadLsp c m =>
HintTitle -> ProgressCancellable -> m a -> m a
withIndefiniteProgress HintTitle
"Applying all hints" ProgressCancellable
Cancellable forall a b. (a -> b) -> a -> b
$ do
    Either String WorkspaceEdit
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file forall a. Maybe a
Nothing
    forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Either String WorkspaceEdit -> Log
LogApplying NormalizedFilePath
file Either String WorkspaceEdit
res
    case Either String WorkspaceEdit
res of
      Left String
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (HintTitle -> ResponseError
responseError (String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ String
"hlint:applyAll: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
err))
      Right WorkspaceEdit
fs -> do
        LspId 'WorkspaceApplyEdit
_ <- forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe HintTitle -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
fs) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
Null

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

data ApplyOneParams = AOP
  { ApplyOneParams -> Uri
file      :: Uri
  , ApplyOneParams -> Position
start_pos :: Position
  -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
  , ApplyOneParams -> HintTitle
hintTitle :: HintTitle
  } deriving (ApplyOneParams -> ApplyOneParams -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplyOneParams -> ApplyOneParams -> Bool
$c/= :: ApplyOneParams -> ApplyOneParams -> Bool
== :: ApplyOneParams -> ApplyOneParams -> Bool
$c== :: ApplyOneParams -> ApplyOneParams -> Bool
Eq,Int -> ApplyOneParams -> ShowS
[ApplyOneParams] -> ShowS
ApplyOneParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApplyOneParams] -> ShowS
$cshowList :: [ApplyOneParams] -> ShowS
show :: ApplyOneParams -> String
$cshow :: ApplyOneParams -> String
showsPrec :: Int -> ApplyOneParams -> ShowS
$cshowsPrec :: Int -> ApplyOneParams -> ShowS
Show,forall x. Rep ApplyOneParams x -> ApplyOneParams
forall x. ApplyOneParams -> Rep ApplyOneParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ApplyOneParams x -> ApplyOneParams
$cfrom :: forall x. ApplyOneParams -> Rep ApplyOneParams x
Generic,Value -> Parser [ApplyOneParams]
Value -> Parser ApplyOneParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ApplyOneParams]
$cparseJSONList :: Value -> Parser [ApplyOneParams]
parseJSON :: Value -> Parser ApplyOneParams
$cparseJSON :: Value -> Parser ApplyOneParams
FromJSON,[ApplyOneParams] -> Encoding
[ApplyOneParams] -> Value
ApplyOneParams -> Encoding
ApplyOneParams -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ApplyOneParams] -> Encoding
$ctoEncodingList :: [ApplyOneParams] -> Encoding
toJSONList :: [ApplyOneParams] -> Value
$ctoJSONList :: [ApplyOneParams] -> Value
toEncoding :: ApplyOneParams -> Encoding
$ctoEncoding :: ApplyOneParams -> Encoding
toJSON :: ApplyOneParams -> Value
$ctoJSON :: ApplyOneParams -> Value
ToJSON)

type HintTitle = T.Text

data OneHint = OneHint
  { OneHint -> Position
oneHintPos   :: Position
  , OneHint -> HintTitle
oneHintTitle :: HintTitle
  } deriving (OneHint -> OneHint -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OneHint -> OneHint -> Bool
$c/= :: OneHint -> OneHint -> Bool
== :: OneHint -> OneHint -> Bool
$c== :: OneHint -> OneHint -> Bool
Eq, Int -> OneHint -> ShowS
[OneHint] -> ShowS
OneHint -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OneHint] -> ShowS
$cshowList :: [OneHint] -> ShowS
show :: OneHint -> String
$cshow :: OneHint -> String
showsPrec :: Int -> OneHint -> ShowS
$cshowsPrec :: Int -> OneHint -> ShowS
Show)

applyOneCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState ApplyOneParams
applyOneCmd :: Recorder (WithPriority Log)
-> CommandFunction IdeState ApplyOneParams
applyOneCmd Recorder (WithPriority Log)
recorder IdeState
ide (AOP Uri
uri Position
pos HintTitle
title) = do
  let oneHint :: OneHint
oneHint = Position -> HintTitle -> OneHint
OneHint Position
pos HintTitle
title
  let file :: NormalizedFilePath
file = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Uri
uri forall a. [a] -> [a] -> [a]
++ String
" is not a file.") String -> NormalizedFilePath
toNormalizedFilePath'
                   (Uri -> Maybe String
uriToFilePath' Uri
uri)
  let progTitle :: HintTitle
progTitle = HintTitle
"Applying hint: " forall a. Semigroup a => a -> a -> a
<> HintTitle
title
  forall c (m :: * -> *) a.
MonadLsp c m =>
HintTitle -> ProgressCancellable -> m a -> m a
withIndefiniteProgress HintTitle
progTitle ProgressCancellable
Cancellable forall a b. (a -> b) -> a -> b
$ do
    Either String WorkspaceEdit
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file (forall a. a -> Maybe a
Just OneHint
oneHint)
    forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Either String WorkspaceEdit -> Log
LogApplying NormalizedFilePath
file Either String WorkspaceEdit
res
    case Either String WorkspaceEdit
res of
      Left String
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (HintTitle -> ResponseError
responseError (String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ String
"hlint:applyOne: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
err))
      Right WorkspaceEdit
fs -> do
        LspId 'WorkspaceApplyEdit
_ <- forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe HintTitle -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
fs) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
Null

applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)
applyHint :: Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
nfp Maybe OneHint
mhint =
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    let runAction' :: Action a -> IO a
        runAction' :: forall a. Action a -> IO a
runAction' = forall a. String -> IdeState -> Action a -> IO a
runAction String
"applyHint" IdeState
ide
    let errorHandlers :: [Handler (Either String b)]
errorHandlers = [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \IOException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (IOException
e :: IOException)))
                        , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \ErrorCall
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (ErrorCall
e :: ErrorCall)))
                        ]
    [Idea]
ideas <- forall (m :: * -> *) e f a b.
Functor m =>
(e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT ParseError -> String
showParseError forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall a. Action a -> IO a
runAction' 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' = 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 = forall a b. (a -> b) -> [a] -> [b]
map Idea -> [Refactoring SrcSpan]
ideaRefactoring [Idea]
ideas'
    forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug 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 HintTitle
mbOldContent) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Action a -> IO a
runAction' forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe HintTitle)
getFileContents NormalizedFilePath
nfp
    HintTitle
oldContent <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> HintTitle
T.decodeUtf8 (String -> IO ByteString
BS.readFile String
fp)) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HintTitle
mbOldContent
    ModSummaryResult
modsum <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Action a -> IO a
runAction' forall a b. (a -> b) -> a -> b
$ forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
    let dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts 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 = forall a. Maybe a
Nothing
#ifdef HLINT_ON_GHC_LIB
    let writeFileUTF8NoNewLineTranslation :: String -> HintTitle -> IO ()
writeFileUTF8NoNewLineTranslation String
file HintTitle
txt =
            forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
file IOMode
WriteMode 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 (HintTitle -> String
T.unpack HintTitle
txt)
    Either String String
res <-
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (ShowS
takeFileName String
fp) forall a b. (a -> b) -> a -> b
$ \String
temp Handle
h -> do
            Handle -> IO ()
hClose Handle
h
            String -> HintTitle -> IO ()
writeFileUTF8NoNewLineTranslation String
temp HintTitle
oldContent
            [Extension]
exts <- forall a. Action a -> IO a
runAction' 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Extension]
exts
            let refactExts :: [String]
refactExts = forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ [Extension]
enabled forall a. [a] -> [a] -> [a]
++ [Extension]
disabled
            (forall a b. b -> Either a b
Right 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) forall a. Maybe a
position [[Refactoring SrcSpan]]
commands String
temp [String]
refactExts)
                forall a. IO a -> [Handler a] -> IO a
`catches` forall {b}. [Handler (Either String b)]
errorHandlers
#else
    mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
    res <-
        case mbParsedModule of
            Nothing -> throwE "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 uri :: Uri
uri = NormalizedUri -> Uri
fromNormalizedUri (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
nfp)
        let wsEdit :: WorkspaceEdit
wsEdit = Bool
-> (Uri, HintTitle) -> HintTitle -> WithDeletions -> WorkspaceEdit
diffText' Bool
True (Uri
uri, HintTitle
oldContent) (String -> HintTitle
T.pack String
appliedFile) WithDeletions
IncludeDeletions
        forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right WorkspaceEdit
wsEdit)
      Left String
err ->
        forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE 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) HintTitle
title) [Idea]
ideas =
            let title' :: String
title' = HintTitle -> String
T.unpack HintTitle
title
                ideaPos :: Idea -> (Int, Int)
ideaPos = (RealSrcSpan -> Int
srcSpanStartLine forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& RealSrcSpan -> Int
srcSpanStartCol) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RealSrcSpan
toRealSrcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. Idea -> SrcSpan
ideaSpan
            in forall a. (a -> Bool) -> [a] -> [a]
filter (\Idea
i -> Idea -> String
ideaHint Idea
i forall a. Eq a => a -> a -> Bool
== String
title' Bool -> Bool -> Bool
&& Idea -> (Int, Int)
ideaPos Idea
i forall a. Eq a => a -> a -> Bool
== (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
lforall a. Num a => a -> a -> a
+UInt
1, forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
cforall 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) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"No real source span: " forall a. [a] -> [a] -> [a]
++ 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 [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) = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (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)  = forall a b. a -> Either a b
Left (e -> f
f e
e)
  h (Right a
a) = 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