{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
#ifdef HLINT_ON_GHC_LIB
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z)
#else
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)
#endif
module Ide.Plugin.Hlint
(
descriptor
) where
import Control.Arrow ((&&&))
import Control.DeepSeq
import Control.Exception
import Control.Lens ((^.))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson.Types (FromJSON (..),
ToJSON (..),
Value (..))
import Data.Binary
import Data.Default
import qualified Data.HashMap.Strict as Map
import Data.Hashable
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Typeable
import Development.IDE hiding
(Error)
import Development.IDE.Core.Rules (defineNoFile,
getParsedModuleWithComments,
usePropertyAction)
import Development.IDE.Core.Shake (getDiagnostics)
import Refact.Apply
#ifdef HLINT_ON_GHC_LIB
import Data.List (nub)
import "ghc" DynFlags as RealGHC.DynFlags (topDir)
import qualified "ghc" EnumSet as EnumSet
import "ghc" GHC as RealGHC (DynFlags (..))
import "ghc-lib" GHC hiding
(DynFlags (..),
ms_hspp_opts)
import "ghc-lib-parser" GHC.LanguageExtensions (Extension)
import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags,
ms_hspp_opts)
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
(DynFlags (..),
OldRealSrcSpan)
import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions)
import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..))
#endif
import Ide.Logger
import Ide.Plugin.Config hiding
(Config)
import Ide.Plugin.Properties
import Ide.PluginUtils
import Ide.Types
import Language.Haskell.HLint as Hlint hiding
(Error)
import Language.LSP.Server (ProgressCancellable (Cancellable),
sendRequest,
withIndefiniteProgress)
import Language.LSP.Types
import qualified Language.LSP.Types as LSP
import qualified Language.LSP.Types.Lens as LSP
import GHC.Generics (Generic)
import Text.Regex.TDFA.Text ()
import System.Environment (setEnv,
unsetEnv)
pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan
#if MIN_GHC_API_VERSION(9,0,0)
pattern $mOldRealSrcSpan :: forall r. SrcSpan -> (RealSrcSpan -> r) -> (Void# -> r) -> r
OldRealSrcSpan span <- RealSrcSpan span _
#else
pattern OldRealSrcSpan span <- RealSrcSpan span
#endif
{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-}
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ pluginRules :: Rules ()
pluginRules = PluginId -> Rules ()
rules PluginId
plId
, pluginCommands :: [PluginCommand IdeState]
pluginCommands =
[ CommandId
-> Text
-> CommandFunction IdeState ApplyOneParams
-> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
"applyOne" Text
"Apply a single hint" CommandFunction IdeState ApplyOneParams
applyOneCmd
, CommandId
-> Text -> CommandFunction IdeState Uri -> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
"applyAll" Text
"Apply all hints to the file" CommandFunction IdeState Uri
applyAllCmd
]
, pluginHandlers :: PluginHandlers IdeState
pluginHandlers = SClientMethod 'TextDocumentCodeAction
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider
, pluginConfigDescriptor :: ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor
defaultConfigDescriptor
{ configHasDiagnostics :: Bool
configHasDiagnostics = Bool
True
, configCustomConfig :: CustomConfig
configCustomConfig = Properties '[ 'PropertyKey "flags" ('TArray String)]
-> CustomConfig
forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig Properties '[ 'PropertyKey "flags" ('TArray String)]
properties
}
}
data GetHlintDiagnostics = GetHlintDiagnostics
deriving (GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
(GetHlintDiagnostics -> GetHlintDiagnostics -> Bool)
-> (GetHlintDiagnostics -> GetHlintDiagnostics -> Bool)
-> Eq GetHlintDiagnostics
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
$c/= :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
== :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
$c== :: GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
Eq, Int -> GetHlintDiagnostics -> ShowS
[GetHlintDiagnostics] -> ShowS
GetHlintDiagnostics -> String
(Int -> GetHlintDiagnostics -> ShowS)
-> (GetHlintDiagnostics -> String)
-> ([GetHlintDiagnostics] -> ShowS)
-> Show GetHlintDiagnostics
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetHlintDiagnostics] -> ShowS
$cshowList :: [GetHlintDiagnostics] -> ShowS
show :: GetHlintDiagnostics -> String
$cshow :: GetHlintDiagnostics -> String
showsPrec :: Int -> GetHlintDiagnostics -> ShowS
$cshowsPrec :: Int -> GetHlintDiagnostics -> ShowS
Show, Typeable, (forall x. GetHlintDiagnostics -> Rep GetHlintDiagnostics x)
-> (forall x. Rep GetHlintDiagnostics x -> GetHlintDiagnostics)
-> Generic GetHlintDiagnostics
forall x. Rep GetHlintDiagnostics x -> GetHlintDiagnostics
forall x. GetHlintDiagnostics -> Rep GetHlintDiagnostics x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetHlintDiagnostics x -> GetHlintDiagnostics
$cfrom :: forall x. GetHlintDiagnostics -> Rep GetHlintDiagnostics x
Generic)
instance Hashable GetHlintDiagnostics
instance NFData GetHlintDiagnostics
instance Binary GetHlintDiagnostics
type instance RuleResult GetHlintDiagnostics = ()
rules :: PluginId -> Rules ()
rules :: PluginId -> Rules ()
rules PluginId
plugin = do
(GetHlintDiagnostics
-> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((GetHlintDiagnostics
-> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ())
-> (GetHlintDiagnostics
-> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetHlintDiagnostics
GetHlintDiagnostics NormalizedFilePath
file -> do
Config
config <- Config -> Action Config
getClientConfigAction Config
forall a. Default a => a
def
let pluginConfig :: PluginConfig
pluginConfig = Config -> PluginId -> PluginConfig
configForPlugin Config
config PluginId
plugin
let hlintOn' :: Bool
hlintOn' = Config -> Bool
hlintOn Config
config Bool -> Bool -> Bool
&& PluginConfig -> Bool
plcGlobalOn PluginConfig
pluginConfig Bool -> Bool -> Bool
&& PluginConfig -> Bool
plcDiagnosticsOn PluginConfig
pluginConfig
Either ParseError [Idea]
ideas <- if Bool
hlintOn' then NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas NormalizedFilePath
file else Either ParseError [Idea] -> Action (Either ParseError [Idea])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right [])
IdeResult () -> Action (IdeResult ())
forall (m :: * -> *) a. Monad m => a -> m a
return (NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics NormalizedFilePath
file Either ParseError [Idea]
ideas, () -> Maybe ()
forall a. a -> Maybe a
Just ())
(GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
-> Rules ()
forall k v. IdeRule k v => (k -> Action v) -> Rules ()
defineNoFile ((GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
-> Rules ())
-> (GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetHlintSettings
GetHlintSettings -> do
(Config [String]
flags) <- PluginId -> Action Config
getHlintConfig PluginId
plugin
IO (ParseFlags, [Classify], Hint)
-> Action (ParseFlags, [Classify], Hint)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ParseFlags, [Classify], Hint)
-> Action (ParseFlags, [Classify], Hint))
-> IO (ParseFlags, [Classify], Hint)
-> Action (ParseFlags, [Classify], Hint)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (ParseFlags, [Classify], Hint)
argsSettings [String]
flags
Action () -> Rules ()
forall a. Action a -> Rules ()
action (Action () -> Rules ()) -> Action () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
HashMap NormalizedFilePath FileOfInterestStatus
files <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
Action [Maybe ()] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [Maybe ()] -> Action ()) -> Action [Maybe ()] -> Action ()
forall a b. (a -> b) -> a -> b
$ GetHlintDiagnostics -> [NormalizedFilePath] -> Action [Maybe ()]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetHlintDiagnostics
GetHlintDiagnostics ([NormalizedFilePath] -> Action [Maybe ()])
-> [NormalizedFilePath] -> Action [Maybe ()]
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
Map.keys HashMap NormalizedFilePath FileOfInterestStatus
files
where
diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics NormalizedFilePath
file (Right [Idea]
ideas) =
[(NormalizedFilePath
file, ShowDiagnostic
ShowDiag, Idea -> Diagnostic
ideaToDiagnostic Idea
i) | Idea
i <- [Idea]
ideas, Idea -> Severity
ideaSeverity Idea
i Severity -> Severity -> Bool
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 =
Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe (Int |? Text)
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
LSP.Diagnostic {
$sel:_range:Diagnostic :: Range
_range = SrcSpan -> Range
srcSpanToRange (SrcSpan -> Range) -> SrcSpan -> Range
forall a b. (a -> b) -> a -> b
$ Idea -> SrcSpan
ideaSpan Idea
idea
, $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DsInfo
, $sel:_code:Diagnostic :: Maybe (Int |? Text)
_code = (Int |? Text) -> Maybe (Int |? Text)
forall a. a -> Maybe a
Just (Text -> Int |? Text
forall a b. b -> a |? b
InR (Text -> Int |? Text) -> Text -> Int |? Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
codePre String -> ShowS
forall a. [a] -> [a] -> [a]
++ Idea -> String
ideaHint Idea
idea)
, $sel:_source:Diagnostic :: Maybe Text
_source = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"hlint"
, $sel:_message:Diagnostic :: Text
_message = Idea -> Text
idea2Message Idea
idea
, $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = Maybe (List DiagnosticRelatedInformation)
forall a. Maybe a
Nothing
, $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags = Maybe (List DiagnosticTag)
forall a. Maybe a
Nothing
}
where codePre :: String
codePre = if [Refactoring SrcSpan] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Refactoring SrcSpan] -> Bool) -> [Refactoring SrcSpan] -> Bool
forall a b. (a -> b) -> a -> b
$ Idea -> [Refactoring SrcSpan]
ideaRefactoring Idea
idea then String
"" else String
"refact:"
idea2Message :: Idea -> T.Text
idea2Message :: Idea -> Text
idea2Message Idea
idea = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Idea -> String
ideaHint Idea
idea, Text
"Found:", Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Idea -> String
ideaFrom Idea
idea)]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
toIdea [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Note -> Text) -> [Note] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Note -> String) -> Note -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> String
forall a. Show a => a -> String
show) (Idea -> [Note]
ideaNote Idea
idea)
where
toIdea :: [T.Text]
toIdea :: [Text]
toIdea = case Idea -> Maybe String
ideaTo Idea
idea of
Maybe String
Nothing -> []
Just String
i -> [String -> Text
T.pack String
"Why not:", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i]
parseErrorToDiagnostic :: ParseError -> Diagnostic
parseErrorToDiagnostic :: ParseError -> Diagnostic
parseErrorToDiagnostic (Hlint.ParseError SrcSpan
l String
msg String
contents) =
Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe (Int |? Text)
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
LSP.Diagnostic {
$sel:_range:Diagnostic :: Range
_range = SrcSpan -> Range
srcSpanToRange SrcSpan
l
, $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DsInfo
, $sel:_code:Diagnostic :: Maybe (Int |? Text)
_code = (Int |? Text) -> Maybe (Int |? Text)
forall a. a -> Maybe a
Just (Text -> Int |? Text
forall a b. b -> a |? b
InR Text
"parser")
, $sel:_source:Diagnostic :: Maybe Text
_source = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"hlint"
, $sel:_message:Diagnostic :: Text
_message = [Text] -> Text
T.unlines [String -> Text
T.pack String
msg,String -> Text
T.pack String
contents]
, $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = Maybe (List DiagnosticRelatedInformation)
forall a. Maybe a
Nothing
, $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags = Maybe (List DiagnosticTag)
forall a. Maybe a
Nothing
}
srcSpanToRange :: SrcSpan -> LSP.Range
srcSpanToRange :: SrcSpan -> Range
srcSpanToRange (OldRealSrcSpan RealSrcSpan
span) = Range :: Position -> Position -> Range
Range {
_start :: Position
_start = Position :: Int -> Int -> Position
LSP.Position {
_line :: Int
_line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
, _character :: Int
_character = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
, _end :: Position
_end = Position :: Int -> Int -> Position
LSP.Position {
_line :: Int
_line = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
, _character :: Int
_character = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
}
srcSpanToRange (UnhelpfulSpan UnhelpfulSpanReason
_) = Range
noRange
getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas NormalizedFilePath
nfp = do
String -> Action ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugm (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:getIdeas:file:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp
(ParseFlags
flags, [Classify]
classify, Hint
hint) <- GetHlintSettings -> Action (ParseFlags, [Classify], Hint)
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetHlintSettings
GetHlintSettings
let applyHints' :: Maybe (Either ParseError ModuleEx) -> Either ParseError [Idea]
applyHints' (Just (Right ModuleEx
modEx)) = [Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right ([Idea] -> Either ParseError [Idea])
-> [Idea] -> Either ParseError [Idea]
forall a b. (a -> b) -> a -> b
$ [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints [Classify]
classify Hint
hint [ModuleEx
modEx]
applyHints' (Just (Left ParseError
err)) = ParseError -> Either ParseError [Idea]
forall a b. a -> Either a b
Left ParseError
err
applyHints' Maybe (Either ParseError ModuleEx)
Nothing = [Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right []
(Maybe (Either ParseError ModuleEx) -> Either ParseError [Idea])
-> Action (Maybe (Either ParseError ModuleEx))
-> Action (Either ParseError [Idea])
forall (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 <- getParsedModule nfp
return $ createModule <$> mbpm
where createModule pm = Right (createModuleEx anns modu)
where anns = pm_annotations pm
modu = pm_parsed_source pm
#else
moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
moduleEx ParseFlags
flags = do
Maybe ParsedModule
mbpm <- NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule NormalizedFilePath
nfp
if Maybe ParsedModule -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ParsedModule
mbpm
then Maybe (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ParseError ModuleEx)
forall a. Maybe a
Nothing
else do
ParseFlags
flags' <- ParseFlags -> Action ParseFlags
setExtensions ParseFlags
flags
(UTCTime
_, Maybe Text
contents) <- NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
let contents' :: Maybe String
contents' = Text -> String
T.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
contents
Either ParseError ModuleEx -> Maybe (Either ParseError ModuleEx)
forall a. a -> Maybe a
Just (Either ParseError ModuleEx -> Maybe (Either ParseError ModuleEx))
-> Action (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either ParseError ModuleEx)
-> Action (Either ParseError ModuleEx)
forall (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 <- ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions ParseFlags
flags NormalizedFilePath
nfp
String -> Action ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugm (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:getIdeas:setExtensions:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Extension] -> String
forall a. Show a => a -> String
show [Extension]
hlintExts
ParseFlags -> Action ParseFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseFlags -> Action ParseFlags)
-> ParseFlags -> Action ParseFlags
forall a b. (a -> b) -> a -> b
$ ParseFlags
flags { enabledExtensions :: [Extension]
enabledExtensions = [Extension]
hlintExts }
getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions ParseFlags
pflags NormalizedFilePath
nfp = do
DynFlags
dflags <- Action DynFlags
getFlags
let hscExts :: [Extension]
hscExts = EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
EnumSet.toList (DynFlags -> EnumSet Extension
extensionFlags DynFlags
dflags)
let hscExts' :: [Extension]
hscExts' = (Extension -> Maybe Extension) -> [Extension] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Extension
GhclibParserEx.readExtension (String -> Maybe Extension)
-> (Extension -> String) -> Extension -> Maybe Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> String
forall a. Show a => a -> String
show) [Extension]
hscExts
let hlintExts :: [Extension]
hlintExts = [Extension] -> [Extension]
forall a. Eq a => [a] -> [a]
nub ([Extension] -> [Extension]) -> [Extension] -> [Extension]
forall a b. (a -> b) -> a -> b
$ ParseFlags -> [Extension]
enabledExtensions ParseFlags
pflags [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
hscExts'
[Extension] -> Action [Extension]
forall (m :: * -> *) a. Monad m => a -> m a
return [Extension]
hlintExts
where getFlags :: Action DynFlags
getFlags :: Action DynFlags
getFlags = do
ModSummaryResult
modsum <- GetModSummary -> NormalizedFilePath -> Action ModSummaryResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
DynFlags -> Action DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Action DynFlags) -> DynFlags -> Action DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags) -> ModSummary -> DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum
#endif
data GetHlintSettings = GetHlintSettings
deriving (GetHlintSettings -> GetHlintSettings -> Bool
(GetHlintSettings -> GetHlintSettings -> Bool)
-> (GetHlintSettings -> GetHlintSettings -> Bool)
-> Eq GetHlintSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetHlintSettings -> GetHlintSettings -> Bool
$c/= :: GetHlintSettings -> GetHlintSettings -> Bool
== :: GetHlintSettings -> GetHlintSettings -> Bool
$c== :: GetHlintSettings -> GetHlintSettings -> Bool
Eq, Int -> GetHlintSettings -> ShowS
[GetHlintSettings] -> ShowS
GetHlintSettings -> String
(Int -> GetHlintSettings -> ShowS)
-> (GetHlintSettings -> String)
-> ([GetHlintSettings] -> ShowS)
-> Show GetHlintSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetHlintSettings] -> ShowS
$cshowList :: [GetHlintSettings] -> ShowS
show :: GetHlintSettings -> String
$cshow :: GetHlintSettings -> String
showsPrec :: Int -> GetHlintSettings -> ShowS
$cshowsPrec :: Int -> GetHlintSettings -> ShowS
Show, Typeable, (forall x. GetHlintSettings -> Rep GetHlintSettings x)
-> (forall x. Rep GetHlintSettings x -> GetHlintSettings)
-> Generic GetHlintSettings
forall x. Rep GetHlintSettings x -> GetHlintSettings
forall x. GetHlintSettings -> Rep GetHlintSettings x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 = Hint -> ()
forall a. a -> ()
rwhnf
instance NFData Classify where rnf :: Classify -> ()
rnf = Classify -> ()
forall a. a -> ()
rwhnf
instance NFData ParseFlags where rnf :: ParseFlags -> ()
rnf = ParseFlags -> ()
forall a. a -> ()
rwhnf
instance Show Hint where show :: Hint -> String
show = String -> Hint -> String
forall a b. a -> b -> a
const String
"<hint>"
instance Show ParseFlags where show :: ParseFlags -> String
show = String -> ParseFlags -> String
forall a b. a -> b -> a
const String
"<parseFlags>"
instance Binary GetHlintSettings
type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint)
newtype Config = Config [String]
properties :: Properties '[ 'PropertyKey "flags" ('TArray String)]
properties :: Properties '[ 'PropertyKey "flags" ('TArray String)]
properties = Properties '[]
emptyProperties
Properties '[]
-> (Properties '[]
-> Properties '[ 'PropertyKey "flags" ('TArray String)])
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "flags"
-> Text
-> [String]
-> Properties '[]
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
forall (s :: Symbol) (r :: [PropertyKey]) a.
(KnownSymbol s, NotElem s r, ToJSON a, FromJSON a) =>
KeyNameProxy s
-> Text
-> [a]
-> Properties r
-> Properties ('PropertyKey s ('TArray a) : r)
defineArrayProperty IsLabel "flags" (KeyNameProxy "flags")
KeyNameProxy "flags"
#flags
Text
"Flags used by hlint" []
getHlintConfig :: PluginId -> Action Config
getHlintConfig :: PluginId -> Action Config
getHlintConfig PluginId
pId =
[String] -> Config
Config
([String] -> Config) -> Action [String] -> Action Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyNameProxy "flags"
-> PluginId
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
-> Action (ToHsType ('TArray String))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
(r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction IsLabel "flags" (KeyNameProxy "flags")
KeyNameProxy "flags"
#flags PluginId
pId Properties '[ 'PropertyKey "flags" ('TArray String)]
properties
codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider IdeState
ideState PluginId
plId (CodeActionParams _ _ docId _ context) = List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction)))
-> ([CodeAction] -> List (Command |? CodeAction))
-> [CodeAction]
-> Either ResponseError (List (Command |? CodeAction))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
LSP.List ([Command |? CodeAction] -> List (Command |? CodeAction))
-> ([CodeAction] -> [Command |? CodeAction])
-> [CodeAction]
-> List (Command |? CodeAction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeAction -> Command |? CodeAction)
-> [CodeAction] -> [Command |? CodeAction]
forall a b. (a -> b) -> [a] -> [b]
map CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
InR ([CodeAction]
-> Either ResponseError (List (Command |? CodeAction)))
-> LspT Config IO [CodeAction]
-> LspT
Config IO (Either ResponseError (List (Command |? CodeAction)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [CodeAction] -> LspT Config IO [CodeAction]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [CodeAction]
getCodeActions
where
getCodeActions :: IO [CodeAction]
getCodeActions = do
[FileDiagnostic]
allDiags <- IdeState -> IO [FileDiagnostic]
getDiagnostics IdeState
ideState
let docNfp :: Maybe NormalizedFilePath
docNfp = String -> NormalizedFilePath
toNormalizedFilePath' (String -> NormalizedFilePath)
-> Maybe String -> Maybe NormalizedFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> Maybe String
uriToFilePath' (TextDocumentIdentifier
docId TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
LSP.uri)
numHintsInDoc :: Int
numHintsInDoc = [Diagnostic] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
[Diagnostic
d | (NormalizedFilePath
nfp, ShowDiagnostic
_, Diagnostic
d) <- [FileDiagnostic]
allDiags
, Diagnostic -> Bool
validCommand Diagnostic
d
, NormalizedFilePath -> Maybe NormalizedFilePath
forall a. a -> Maybe a
Just NormalizedFilePath
nfp Maybe NormalizedFilePath -> Maybe NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe NormalizedFilePath
docNfp
]
numHintsInContext :: Int
numHintsInContext = [Diagnostic] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
[Diagnostic
d | Diagnostic
d <- [Diagnostic]
diags
, Diagnostic -> Bool
validCommand Diagnostic
d
]
if Int
numHintsInDoc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Int
numHintsInContext Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then do
[CodeAction] -> IO [CodeAction]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CodeAction] -> IO [CodeAction])
-> [CodeAction] -> IO [CodeAction]
forall a b. (a -> b) -> a -> b
$ CodeAction
applyAllActionCodeAction -> [CodeAction] -> [CodeAction]
forall a. a -> [a] -> [a]
:[CodeAction]
applyOneActions
else
[CodeAction] -> IO [CodeAction]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeAction]
applyOneActions
applyAllAction :: CodeAction
applyAllAction =
let args :: Maybe [Value]
args = [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Uri -> Value
forall a. ToJSON a => a -> Value
toJSON (TextDocumentIdentifier
docId TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
LSP.uri)]
cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
"applyAll" Text
"Apply all hints" Maybe [Value]
args
in Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction Text
"Apply all hints" (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionQuickFix) Maybe (List Diagnostic)
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Reason
forall a. Maybe a
Nothing Maybe WorkspaceEdit
forall a. Maybe a
Nothing (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd) Maybe Value
forall a. Maybe a
Nothing
applyOneActions :: [LSP.CodeAction]
applyOneActions :: [CodeAction]
applyOneActions = (Diagnostic -> Maybe CodeAction) -> [Diagnostic] -> [CodeAction]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Diagnostic -> Maybe CodeAction
mkHlintAction ((Diagnostic -> Bool) -> [Diagnostic] -> [Diagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter Diagnostic -> Bool
validCommand [Diagnostic]
diags)
validCommand :: Diagnostic -> Bool
validCommand (LSP.Diagnostic Range
_ Maybe DiagnosticSeverity
_ (Just (InR Text
code)) (Just Text
"hlint") Text
_ Maybe (List DiagnosticTag)
_ Maybe (List DiagnosticRelatedInformation)
_) =
Text
"refact:" Text -> Text -> Bool
`T.isPrefixOf` Text
code
validCommand Diagnostic
_ =
Bool
False
LSP.List [Diagnostic]
diags = CodeActionContext
context CodeActionContext
-> Getting (List Diagnostic) CodeActionContext (List Diagnostic)
-> List Diagnostic
forall s a. s -> Getting a s a -> a
^. Getting (List Diagnostic) CodeActionContext (List Diagnostic)
forall s a. HasDiagnostics s a => Lens' s a
LSP.diagnostics
mkHlintAction :: LSP.Diagnostic -> Maybe LSP.CodeAction
mkHlintAction :: Diagnostic -> Maybe CodeAction
mkHlintAction diag :: Diagnostic
diag@(LSP.Diagnostic (LSP.Range Position
start Position
_) Maybe DiagnosticSeverity
_s (Just (InR Text
code)) (Just Text
"hlint") Text
_ Maybe (List DiagnosticTag)
_ Maybe (List DiagnosticRelatedInformation)
_) =
CodeAction -> Maybe CodeAction
forall a. a -> Maybe a
Just (CodeAction -> Maybe CodeAction)
-> (Command -> CodeAction) -> Command -> Maybe CodeAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> CodeAction
codeAction (Command -> Maybe CodeAction) -> Command -> Maybe CodeAction
forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
"applyOne" Text
title ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
args)
where
codeAction :: Command -> CodeAction
codeAction Command
cmd = Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction Text
title (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionQuickFix) (List Diagnostic -> Maybe (List Diagnostic)
forall a. a -> Maybe a
Just ([Diagnostic] -> List Diagnostic
forall a. [a] -> List a
LSP.List [Diagnostic
diag])) Maybe Bool
forall a. Maybe a
Nothing Maybe Reason
forall a. Maybe a
Nothing Maybe WorkspaceEdit
forall a. Maybe a
Nothing (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd) Maybe Value
forall a. Maybe a
Nothing
ideaHint :: Text
ideaHint = Text -> Text -> Text -> Text
T.replace Text
"refact:" Text
"" Text
code
title :: Text
title = Text
"Apply hint: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ideaHint
args :: [Value]
args = [ApplyOneParams -> Value
forall a. ToJSON a => a -> Value
toJSON (Uri -> Position -> Text -> ApplyOneParams
AOP (TextDocumentIdentifier
docId TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
LSP.uri) Position
start Text
ideaHint)]
mkHlintAction (LSP.Diagnostic Range
_r Maybe DiagnosticSeverity
_s Maybe (Int |? Text)
_c Maybe Text
_source Text
_m Maybe (List DiagnosticTag)
_ Maybe (List DiagnosticRelatedInformation)
_) = Maybe CodeAction
forall a. Maybe a
Nothing
applyAllCmd :: CommandFunction IdeState Uri
applyAllCmd :: CommandFunction IdeState Uri
applyAllCmd IdeState
ide Uri
uri = do
let file :: NormalizedFilePath
file = NormalizedFilePath
-> (String -> NormalizedFilePath)
-> Maybe String
-> NormalizedFilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NormalizedFilePath
forall a. HasCallStack => String -> a
error (String -> NormalizedFilePath) -> String -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> String
forall a. Show a => a -> String
show Uri
uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a file.")
String -> NormalizedFilePath
toNormalizedFilePath'
(Uri -> Maybe String
uriToFilePath' Uri
uri)
Text
-> ProgressCancellable
-> LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
"Applying all hints" ProgressCancellable
Cancellable (LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value))
-> LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ do
String -> LspT Config IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> LspT Config IO ()) -> String -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyAllCmd:file=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
file
Either String WorkspaceEdit
res <- IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit))
-> IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint IdeState
ide NormalizedFilePath
file Maybe OneHint
forall a. Maybe a
Nothing
String -> LspT Config IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> LspT Config IO ()) -> String -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyAllCmd:res=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either String WorkspaceEdit -> String
forall a. Show a => a -> String
show Either String WorkspaceEdit
res
case Either String WorkspaceEdit
res of
Left String
err -> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
-> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (Text -> ResponseError
responseError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyAll: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
err))
Right WorkspaceEdit
fs -> do
LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
fs) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
-> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null
data ApplyOneParams = AOP
{ ApplyOneParams -> Uri
file :: Uri
, ApplyOneParams -> Position
start_pos :: Position
, ApplyOneParams -> Text
hintTitle :: HintTitle
} deriving (ApplyOneParams -> ApplyOneParams -> Bool
(ApplyOneParams -> ApplyOneParams -> Bool)
-> (ApplyOneParams -> ApplyOneParams -> Bool) -> Eq ApplyOneParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplyOneParams -> ApplyOneParams -> Bool
$c/= :: ApplyOneParams -> ApplyOneParams -> Bool
== :: ApplyOneParams -> ApplyOneParams -> Bool
$c== :: ApplyOneParams -> ApplyOneParams -> Bool
Eq,Int -> ApplyOneParams -> ShowS
[ApplyOneParams] -> ShowS
ApplyOneParams -> String
(Int -> ApplyOneParams -> ShowS)
-> (ApplyOneParams -> String)
-> ([ApplyOneParams] -> ShowS)
-> Show ApplyOneParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApplyOneParams] -> ShowS
$cshowList :: [ApplyOneParams] -> ShowS
show :: ApplyOneParams -> String
$cshow :: ApplyOneParams -> String
showsPrec :: Int -> ApplyOneParams -> ShowS
$cshowsPrec :: Int -> ApplyOneParams -> ShowS
Show,(forall x. ApplyOneParams -> Rep ApplyOneParams x)
-> (forall x. Rep ApplyOneParams x -> ApplyOneParams)
-> Generic ApplyOneParams
forall x. Rep ApplyOneParams x -> ApplyOneParams
forall x. ApplyOneParams -> Rep ApplyOneParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ApplyOneParams x -> ApplyOneParams
$cfrom :: forall x. ApplyOneParams -> Rep ApplyOneParams x
Generic,Value -> Parser [ApplyOneParams]
Value -> Parser ApplyOneParams
(Value -> Parser ApplyOneParams)
-> (Value -> Parser [ApplyOneParams]) -> FromJSON ApplyOneParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ApplyOneParams]
$cparseJSONList :: Value -> Parser [ApplyOneParams]
parseJSON :: Value -> Parser ApplyOneParams
$cparseJSON :: Value -> Parser ApplyOneParams
FromJSON,[ApplyOneParams] -> Encoding
[ApplyOneParams] -> Value
ApplyOneParams -> Encoding
ApplyOneParams -> Value
(ApplyOneParams -> Value)
-> (ApplyOneParams -> Encoding)
-> ([ApplyOneParams] -> Value)
-> ([ApplyOneParams] -> Encoding)
-> ToJSON ApplyOneParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ApplyOneParams] -> Encoding
$ctoEncodingList :: [ApplyOneParams] -> Encoding
toJSONList :: [ApplyOneParams] -> Value
$ctoJSONList :: [ApplyOneParams] -> Value
toEncoding :: ApplyOneParams -> Encoding
$ctoEncoding :: ApplyOneParams -> Encoding
toJSON :: ApplyOneParams -> Value
$ctoJSON :: ApplyOneParams -> Value
ToJSON)
type HintTitle = T.Text
data OneHint = OneHint
{ OneHint -> Position
oneHintPos :: Position
, OneHint -> Text
oneHintTitle :: HintTitle
} deriving (OneHint -> OneHint -> Bool
(OneHint -> OneHint -> Bool)
-> (OneHint -> OneHint -> Bool) -> Eq OneHint
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
(Int -> OneHint -> ShowS)
-> (OneHint -> String) -> ([OneHint] -> ShowS) -> Show OneHint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OneHint] -> ShowS
$cshowList :: [OneHint] -> ShowS
show :: OneHint -> String
$cshow :: OneHint -> String
showsPrec :: Int -> OneHint -> ShowS
$cshowsPrec :: Int -> OneHint -> ShowS
Show)
applyOneCmd :: CommandFunction IdeState ApplyOneParams
applyOneCmd :: CommandFunction IdeState ApplyOneParams
applyOneCmd IdeState
ide (AOP Uri
uri Position
pos Text
title) = do
let oneHint :: OneHint
oneHint = Position -> Text -> OneHint
OneHint Position
pos Text
title
let file :: NormalizedFilePath
file = NormalizedFilePath
-> (String -> NormalizedFilePath)
-> Maybe String
-> NormalizedFilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NormalizedFilePath
forall a. HasCallStack => String -> a
error (String -> NormalizedFilePath) -> String -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> String
forall a. Show a => a -> String
show Uri
uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a file.") String -> NormalizedFilePath
toNormalizedFilePath'
(Uri -> Maybe String
uriToFilePath' Uri
uri)
let progTitle :: Text
progTitle = Text
"Applying hint: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
title
Text
-> ProgressCancellable
-> LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
progTitle ProgressCancellable
Cancellable (LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value))
-> LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ do
String -> LspT Config IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> LspT Config IO ()) -> String -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyOneCmd:file=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
file
Either String WorkspaceEdit
res <- IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit))
-> IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint IdeState
ide NormalizedFilePath
file (OneHint -> Maybe OneHint
forall a. a -> Maybe a
Just OneHint
oneHint)
String -> LspT Config IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> LspT Config IO ()) -> String -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyOneCmd:res=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either String WorkspaceEdit -> String
forall a. Show a => a -> String
show Either String WorkspaceEdit
res
case Either String WorkspaceEdit
res of
Left String
err -> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
-> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (Text -> ResponseError
responseError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyOne: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
err))
Right WorkspaceEdit
fs -> do
LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
fs) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
-> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null
applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)
applyHint :: IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint IdeState
ide NormalizedFilePath
nfp Maybe OneHint
mhint =
ExceptT String IO WorkspaceEdit -> IO (Either String WorkspaceEdit)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO WorkspaceEdit
-> IO (Either String WorkspaceEdit))
-> ExceptT String IO WorkspaceEdit
-> IO (Either String WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ do
let runAction' :: Action a -> IO a
runAction' :: Action a -> IO a
runAction' = String -> IdeState -> Action a -> IO a
forall a. String -> IdeState -> Action a -> IO a
runAction String
"applyHint" IdeState
ide
let errorHandlers :: [Handler (Either String b)]
errorHandlers = [ (IOException -> IO (Either String b)) -> Handler (Either String b)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO (Either String b))
-> Handler (Either String b))
-> (IOException -> IO (Either String b))
-> Handler (Either String b)
forall a b. (a -> b) -> a -> b
$ \IOException
e -> Either String b -> IO (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String b
forall a b. a -> Either a b
Left (IOException -> String
forall a. Show a => a -> String
show (IOException
e :: IOException)))
, (ErrorCall -> IO (Either String b)) -> Handler (Either String b)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ErrorCall -> IO (Either String b)) -> Handler (Either String b))
-> (ErrorCall -> IO (Either String b)) -> Handler (Either String b)
forall a b. (a -> b) -> a -> b
$ \ErrorCall
e -> Either String b -> IO (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String b
forall a b. a -> Either a b
Left (ErrorCall -> String
forall a. Show a => a -> String
show (ErrorCall
e :: ErrorCall)))
]
[Idea]
ideas <- (ParseError -> String)
-> ([Idea] -> [Idea])
-> ExceptT ParseError IO [Idea]
-> ExceptT String IO [Idea]
forall (m :: * -> *) e f a b.
Functor m =>
(e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT ParseError -> String
showParseError [Idea] -> [Idea]
forall a. a -> a
id (ExceptT ParseError IO [Idea] -> ExceptT String IO [Idea])
-> ExceptT ParseError IO [Idea] -> ExceptT String IO [Idea]
forall a b. (a -> b) -> a -> b
$ IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea]
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea])
-> IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea]
forall a b. (a -> b) -> a -> b
$ Action (Either ParseError [Idea]) -> IO (Either ParseError [Idea])
forall a. Action a -> IO a
runAction' (Action (Either ParseError [Idea])
-> IO (Either ParseError [Idea]))
-> Action (Either ParseError [Idea])
-> IO (Either ParseError [Idea])
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas NormalizedFilePath
nfp
let ideas' :: [Idea]
ideas' = [Idea] -> (OneHint -> [Idea]) -> Maybe OneHint -> [Idea]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Idea]
ideas (OneHint -> [Idea] -> [Idea]
`filterIdeas` [Idea]
ideas) Maybe OneHint
mhint
let commands :: [[Refactoring SrcSpan]]
commands = (Idea -> [Refactoring SrcSpan])
-> [Idea] -> [[Refactoring SrcSpan]]
forall a b. (a -> b) -> [a] -> [b]
map Idea -> [Refactoring SrcSpan]
ideaRefactoring [Idea]
ideas'
IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"applyHint:apply=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Refactoring SrcSpan]] -> String
forall a. Show a => a -> String
show [[Refactoring SrcSpan]]
commands
let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
(UTCTime
_, Maybe Text
mbOldContent) <- IO (UTCTime, Maybe Text) -> ExceptT String IO (UTCTime, Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Maybe Text)
-> ExceptT String IO (UTCTime, Maybe Text))
-> IO (UTCTime, Maybe Text)
-> ExceptT String IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a. Action a -> IO a
runAction' (Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text))
-> Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
Text
oldContent <- ExceptT String IO Text
-> (Text -> ExceptT String IO Text)
-> Maybe Text
-> ExceptT String IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO Text -> ExceptT String IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT String IO Text)
-> IO Text -> ExceptT String IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
fp) Text -> ExceptT String IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mbOldContent
ModSummaryResult
modsum <- IO ModSummaryResult -> ExceptT String IO ModSummaryResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummaryResult -> ExceptT String IO ModSummaryResult)
-> IO ModSummaryResult -> ExceptT String IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ Action ModSummaryResult -> IO ModSummaryResult
forall a. Action a -> IO a
runAction' (Action ModSummaryResult -> IO ModSummaryResult)
-> Action ModSummaryResult -> IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ GetModSummary -> NormalizedFilePath -> Action ModSummaryResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
let dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags) -> ModSummary -> DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum
let withRuntimeLibdir :: IO a -> IO a
withRuntimeLibdir :: IO a -> IO a
withRuntimeLibdir = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (String -> String -> IO ()
setEnv String
key (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> String
topDir DynFlags
dflags) (String -> IO ()
unsetEnv String
key)
where key :: String
key = String
"GHC_EXACTPRINT_GHC_LIBDIR"
let position :: Maybe a
position = Maybe a
forall a. Maybe a
Nothing
#ifdef HLINT_ON_GHC_LIB
let writeFileUTF8NoNewLineTranslation :: String -> Text -> IO ()
writeFileUTF8NoNewLineTranslation String
file Text
txt =
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
file IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
noNewlineTranslation
Handle -> String -> IO ()
hPutStr Handle
h (Text -> String
T.unpack Text
txt)
Either String String
res <-
IO (Either String String)
-> ExceptT String IO (Either String String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String String)
-> ExceptT String IO (Either String String))
-> IO (Either String String)
-> ExceptT String IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
-> (String -> Handle -> IO (Either String String))
-> IO (Either String String)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (ShowS
takeFileName String
fp) ((String -> Handle -> IO (Either String String))
-> IO (Either String String))
-> (String -> Handle -> IO (Either String String))
-> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ \String
temp Handle
h -> do
Handle -> IO ()
hClose Handle
h
String -> Text -> IO ()
writeFileUTF8NoNewLineTranslation String
temp Text
oldContent
(ParseFlags
pflags, [Classify]
_, Hint
_) <- Action (ParseFlags, [Classify], Hint)
-> IO (ParseFlags, [Classify], Hint)
forall a. Action a -> IO a
runAction' (Action (ParseFlags, [Classify], Hint)
-> IO (ParseFlags, [Classify], Hint))
-> Action (ParseFlags, [Classify], Hint)
-> IO (ParseFlags, [Classify], Hint)
forall a b. (a -> b) -> a -> b
$ GetHlintSettings -> Action (ParseFlags, [Classify], Hint)
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetHlintSettings
GetHlintSettings
[Extension]
exts <- Action [Extension] -> IO [Extension]
forall a. Action a -> IO a
runAction' (Action [Extension] -> IO [Extension])
-> Action [Extension] -> IO [Extension]
forall a b. (a -> b) -> a -> b
$ ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions ParseFlags
pflags NormalizedFilePath
nfp
let ([Extension]
enabled, [Extension]
disabled, [String]
_invalid) = [String] -> ([Extension], [Extension], [String])
parseExtensions ([String] -> ([Extension], [Extension], [String]))
-> [String] -> ([Extension], [Extension], [String])
forall a b. (a -> b) -> a -> b
$ (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show [Extension]
exts
let refactExts :: [String]
refactExts = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show ([Extension] -> [String]) -> [Extension] -> [String]
forall a b. (a -> b) -> a -> b
$ [Extension]
enabled [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
disabled
(String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> IO String -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> IO String
forall a. IO a -> IO a
withRuntimeLibdir (Maybe (Int, Int)
-> [[Refactoring SrcSpan]] -> String -> [String] -> IO String
applyRefactorings Maybe (Int, Int)
forall a. Maybe a
position [[Refactoring SrcSpan]]
commands String
temp [String]
refactExts))
IO (Either String String)
-> [Handler (Either String String)] -> IO (Either String String)
forall a. IO a -> [Handler a] -> IO a
`catches` [Handler (Either String String)]
forall b. [Handler (Either String b)]
errorHandlers
#else
mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
res <-
case mbParsedModule of
Nothing -> throwE "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 $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu'))
`catches` errorHandlers
#endif
case Either String String
res of
Right String
appliedFile -> do
let uri :: Uri
uri = NormalizedUri -> Uri
fromNormalizedUri (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
nfp)
let wsEdit :: WorkspaceEdit
wsEdit = Bool -> (Uri, Text) -> Text -> WithDeletions -> WorkspaceEdit
diffText' Bool
True (Uri
uri, Text
oldContent) (String -> Text
T.pack String
appliedFile) WithDeletions
IncludeDeletions
IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyHint:diff=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceEdit -> String
forall a. Show a => a -> String
show WorkspaceEdit
wsEdit
IO (Either String WorkspaceEdit) -> ExceptT String IO WorkspaceEdit
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String WorkspaceEdit)
-> ExceptT String IO WorkspaceEdit)
-> IO (Either String WorkspaceEdit)
-> ExceptT String IO WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ Either String WorkspaceEdit -> IO (Either String WorkspaceEdit)
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceEdit -> Either String WorkspaceEdit
forall a b. b -> Either a b
Right WorkspaceEdit
wsEdit)
Left String
err ->
String -> ExceptT String IO WorkspaceEdit
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
err
where
filterIdeas :: OneHint -> [Idea] -> [Idea]
filterIdeas :: OneHint -> [Idea] -> [Idea]
filterIdeas (OneHint (Position Int
l Int
c) Text
title) [Idea]
ideas =
let title' :: String
title' = Text -> String
T.unpack Text
title
ideaPos :: Idea -> (Int, Int)
ideaPos = (RealSrcSpan -> Int
srcSpanStartLine (RealSrcSpan -> Int)
-> (RealSrcSpan -> Int) -> RealSrcSpan -> (Int, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& RealSrcSpan -> Int
srcSpanStartCol) (RealSrcSpan -> (Int, Int))
-> (Idea -> RealSrcSpan) -> Idea -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RealSrcSpan
toRealSrcSpan (SrcSpan -> RealSrcSpan)
-> (Idea -> SrcSpan) -> Idea -> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Idea -> SrcSpan
ideaSpan
in (Idea -> Bool) -> [Idea] -> [Idea]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Idea
i -> Idea -> String
ideaHint Idea
i String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
title' Bool -> Bool -> Bool
&& Idea -> (Int, Int)
ideaPos Idea
i (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) [Idea]
ideas
toRealSrcSpan :: SrcSpan -> RealSrcSpan
toRealSrcSpan (OldRealSrcSpan RealSrcSpan
real) = RealSrcSpan
real
toRealSrcSpan (UnhelpfulSpan UnhelpfulSpanReason
x) = String -> RealSrcSpan
forall a. HasCallStack => String -> a
error (String -> RealSrcSpan) -> String -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ String
"No real source span: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnhelpfulSpanReason -> String
forall a. Show a => a -> String
show UnhelpfulSpanReason
x
showParseError :: Hlint.ParseError -> String
showParseError :: ParseError -> String
showParseError (Hlint.ParseError SrcSpan
location String
message String
content) =
[String] -> String
unlines [SrcSpan -> String
forall a. Show a => a -> String
show SrcSpan
location, String
message, String
content]
bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT :: (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT e -> f
f a -> b
g (ExceptT m (Either e a)
m) = m (Either f b) -> ExceptT f m b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((Either e a -> Either f b) -> m (Either e a) -> m (Either f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either e a -> Either f b
h m (Either e a)
m) where
h :: Either e a -> Either f b
h (Left e
e) = f -> Either f b
forall a b. a -> Either a b
Left (e -> f
f e
e)
h (Right a
a) = b -> Either f b
forall a b. b -> Either a b
Right (a -> b
g a
a)
{-# INLINE bimapExceptT #-}