{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE DuplicateRecordFields     #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# 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 TypeApplications          #-}
{-# 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 hiding
                                                                             (Error)
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)
#else
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 -> 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
    LogResolve a
msg -> 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 ) = 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 =
  let resolveRecorder :: Recorder (WithPriority Log)
resolveRecorder = forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio forall a. Pretty a => a -> Log
LogResolve Recorder (WithPriority Log)
recorder
      ([PluginCommand IdeState]
pluginCommands, PluginHandlers IdeState
pluginHandlers) = 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)
  in (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 = [PluginCommand IdeState]
pluginCommands
  , pluginHandlers :: PluginHandlers IdeState
pluginHandlers = PluginHandlers IdeState
pluginHandlers
  , 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.DiagnosticSeverity_Information
          -- 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 [DiagnosticRelatedInformation]
_relatedInformation = forall a. Maybe a
Nothing
          , $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags     = forall a. Maybe a
Nothing
          , $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = forall a. Maybe a
Nothing
          , $sel:_data_:Diagnostic :: Maybe Value
_data_ = 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.DiagnosticSeverity_Information
          , $sel:_code:Diagnostic :: Maybe (Int32 |? HintTitle)
_code     = forall a. a -> Maybe a
Just (forall a b. b -> a |? b
InR HintTitle
sourceParser)
          , $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 [DiagnosticRelatedInformation]
_relatedInformation = forall a. Maybe a
Nothing
          , $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags     = forall a. Maybe a
Nothing
          , $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = forall a. Maybe a
Nothing
          , $sel:_data_:Diagnostic :: Maybe Value
_data_ = 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 = 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
              , $sel:_character:Position :: 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}
        , $sel:_end:Range :: Position
_end   = LSP.Position {
                $sel:_line:Position :: 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
             , $sel:_character:Position :: 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

-- ---------------------------------------------------------------------
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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc TextDocumentIdentifier
documentId
    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. a -> a |? b
InL 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
            ]
      let singleHintCodeActions :: [CodeAction]
singleHintCodeActions = [Diagnostic]
diags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VersionedTextDocumentIdentifier -> Diagnostic -> [CodeAction]
diagnosticToCodeActions VersionedTextDocumentIdentifier
verTxtDocId
      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]
++ [VersionedTextDocumentIdentifier -> CodeAction
applyAllAction VersionedTextDocumentIdentifier
verTxtDocId]
      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. a -> a |? b
InL []

  where
    applyAllAction :: VersionedTextDocumentIdentifier -> CodeAction
applyAllAction VersionedTextDocumentIdentifier
verTxtDocId =
      let args :: Maybe Value
args = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON (VersionedTextDocumentIdentifier
-> Maybe OneHint -> HlintResolveCommands
ApplyHint VersionedTextDocumentIdentifier
verTxtDocId forall a. Maybe a
Nothing)
        in HintTitle
-> Maybe CodeActionKind
-> Maybe [Diagnostic]
-> Maybe Bool
-> Maybe (Rec (("reason" .== HintTitle) .+ Empty))
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction HintTitle
"Apply all hints" (forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionKind_QuickFix) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing 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 HintTitle
code)) Maybe CodeDescription
_ (Just HintTitle
"hlint") HintTitle
_ Maybe [DiagnosticTag]
_ Maybe [DiagnosticRelatedInformation]
_ Maybe Value
_) =
        HintTitle
"refact:" HintTitle -> HintTitle -> Bool
`T.isPrefixOf` HintTitle
code
    validCommand Diagnostic
_ =
        Bool
False

    diags :: [Diagnostic]
diags = CodeActionContext
context forall s a. s -> Getting a s a -> a
^. forall s a. HasDiagnostics s a => Lens' s a
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 <-  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 <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MessageParams 'Method_CodeActionResolve
ca forall a b. a -> (a -> b) -> b
& forall s a. HasEdit s a => Lens' s a
LSP.edit forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ WorkspaceEdit
edit
    (IgnoreHint VersionedTextDocumentIdentifier
verTxtDocId HintTitle
hintTitle ) -> do
        WorkspaceEdit
edit <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> VersionedTextDocumentIdentifier
-> HintTitle
-> IO (Either PluginError WorkspaceEdit)
ignoreHint Recorder (WithPriority Log)
recorder IdeState
ideState NormalizedFilePath
file VersionedTextDocumentIdentifier
verTxtDocId HintTitle
hintTitle
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MessageParams 'Method_CodeActionResolve
ca forall a b. a -> (a -> b) -> b
& forall s a. HasEdit s a => Lens' s a
LSP.edit 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 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 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 suppressHintArguments :: HlintResolveCommands
suppressHintArguments = VersionedTextDocumentIdentifier
-> HintTitle -> HlintResolveCommands
IgnoreHint VersionedTextDocumentIdentifier
verTxtDocId HintTitle
hint
  = 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 :: HlintResolveCommands
applyHintArguments = VersionedTextDocumentIdentifier
-> Maybe OneHint -> HlintResolveCommands
ApplyHint VersionedTextDocumentIdentifier
verTxtDocId (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Position -> HintTitle -> OneHint
OneHint Position
start HintTitle
hint) ->
               forall a. a -> Maybe a
Just (HintTitle -> Diagnostic -> Maybe Value -> Bool -> CodeAction
mkCodeAction HintTitle
applyHintTitle Diagnostic
diagnostic (forall a. a -> Maybe a
Just (forall a. ToJSON a => a -> Value
toJSON HlintResolveCommands
applyHintArguments)) Bool
True)
           | Bool
otherwise -> forall a. Maybe a
Nothing
      , forall a. a -> Maybe a
Just (HintTitle -> Diagnostic -> Maybe Value -> Bool -> CodeAction
mkCodeAction HintTitle
suppressHintTitle Diagnostic
diagnostic (forall a. a -> Maybe a
Just (forall a. ToJSON a => a -> Value
toJSON HlintResolveCommands
suppressHintArguments)) Bool
False)
      ]
  | Bool
otherwise = []

mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe Value -> Bool -> LSP.CodeAction
mkCodeAction :: HintTitle -> Diagnostic -> Maybe Value -> Bool -> CodeAction
mkCodeAction HintTitle
title Diagnostic
diagnostic Maybe Value
data_  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.CodeActionKind_QuickFix
    , $sel:_diagnostics:CodeAction :: Maybe [Diagnostic]
_diagnostics = forall a. a -> Maybe a
Just [Diagnostic
diagnostic]
    , $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = forall a. a -> Maybe a
Just Bool
isPreferred
    , $sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== HintTitle) .+ Empty))
_disabled = forall a. Maybe a
Nothing
    , $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = forall a. Maybe a
Nothing
    , $sel:_command:CodeAction :: Maybe Command
_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 -> 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
-- ---------------------------------------------------------------------

ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit)
ignoreHint :: Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> VersionedTextDocumentIdentifier
-> HintTitle
-> IO (Either PluginError WorkspaceEdit)
ignoreHint Recorder (WithPriority Log)
_recorder IdeState
ideState NormalizedFilePath
nfp VersionedTextDocumentIdentifier
verTxtDocId HintTitle
ignoreHintTitle = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  (FileVersion
_, Maybe HintTitle
fileContents) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"Hlint.GetFileContents" IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetFileContents
GetFileContents NormalizedFilePath
nfp
  (ModSummaryResult
msr, PositionMapping
_) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"Hlint.GetModSummaryWithoutTimestamps" IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
nfp
  case Maybe HintTitle
fileContents of
    Just HintTitle
contents -> do
        let dynFlags :: DynFlags
dynFlags = ModSummary -> DynFlags
ms_hspp_opts forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
msr
            textEdits :: [TextEdit]
textEdits = DynFlags -> HintTitle -> HintTitle -> [TextEdit]
mkSuppressHintTextEdits DynFlags
dynFlags HintTitle
contents HintTitle
ignoreHintTitle
            workspaceEdit :: WorkspaceEdit
workspaceEdit =
                Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
LSP.WorkspaceEdit
                  (forall a. a -> Maybe a
Just (forall k a. k -> a -> Map k a
M.singleton (VersionedTextDocumentIdentifier
verTxtDocId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
LSP.uri) [TextEdit]
textEdits))
                  forall a. Maybe a
Nothing
                  forall a. Maybe a
Nothing
        forall (f :: * -> *) a. Applicative f => a -> f a
pure WorkspaceEdit
workspaceEdit
    Maybe HintTitle
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ HintTitle -> PluginError
PluginInternalError HintTitle
"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 -> HintTitle
ignoreHintTitle :: HintTitle
      } deriving (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
$cto :: forall x. Rep HlintResolveCommands x -> HlintResolveCommands
$cfrom :: forall x. HlintResolveCommands -> Rep HlintResolveCommands x
Generic, [HlintResolveCommands] -> Encoding
[HlintResolveCommands] -> Value
HlintResolveCommands -> Encoding
HlintResolveCommands -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [HlintResolveCommands] -> Encoding
$ctoEncodingList :: [HlintResolveCommands] -> Encoding
toJSONList :: [HlintResolveCommands] -> Value
$ctoJSONList :: [HlintResolveCommands] -> Value
toEncoding :: HlintResolveCommands -> Encoding
$ctoEncoding :: HlintResolveCommands -> Encoding
toJSON :: HlintResolveCommands -> Value
$ctoJSON :: HlintResolveCommands -> Value
ToJSON, Value -> Parser [HlintResolveCommands]
Value -> Parser HlintResolveCommands
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [HlintResolveCommands]
$cparseJSONList :: Value -> Parser [HlintResolveCommands]
parseJSON :: Value -> Parser HlintResolveCommands
$cparseJSON :: Value -> Parser HlintResolveCommands
FromJSON)

type HintTitle = T.Text

data OneHint =
  OneHint
    { OneHint -> Position
oneHintPos   :: Position
    , OneHint -> HintTitle
oneHintTitle :: HintTitle
    } deriving (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
$cto :: forall x. Rep OneHint x -> OneHint
$cfrom :: forall x. OneHint -> Rep OneHint x
Generic, 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, [OneHint] -> Encoding
[OneHint] -> Value
OneHint -> Encoding
OneHint -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [OneHint] -> Encoding
$ctoEncodingList :: [OneHint] -> Encoding
toJSONList :: [OneHint] -> Value
$ctoJSONList :: [OneHint] -> Value
toEncoding :: OneHint -> Encoding
$ctoEncoding :: OneHint -> Encoding
toJSON :: OneHint -> Value
$ctoJSON :: OneHint -> Value
ToJSON, Value -> Parser [OneHint]
Value -> Parser OneHint
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [OneHint]
$cparseJSONList :: Value -> Parser [OneHint]
parseJSON :: Value -> Parser OneHint
$cparseJSON :: Value -> Parser 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 =
  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 (HintTitle -> PluginError
PluginInternalError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HintTitle
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> 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, HintTitle)
-> HintTitle
-> WithDeletions
-> WorkspaceEdit
diffText' Bool
True (VersionedTextDocumentIdentifier
verTxtDocId, 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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ HintTitle -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ String -> HintTitle
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) 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