{-# 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 #-}
{-# 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]
| 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
#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
}
}
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 = ()
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
, $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
}
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 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 }
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" []
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
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
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
[ 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")
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
, 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
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
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
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
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]
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 #-}
applyRefactorings ::
FilePath ->
Maybe (Int, Int) ->
[[Refact.Refactoring Refact.SrcSpan]] ->
FilePath ->
[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
withRuntimeLibdir :: FilePath -> IO a -> IO a
withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key)
where key = "GHC_EXACTPRINT_GHC_LIBDIR"
#endif