{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.Hlint
(
descriptor
) where
import Refact.Apply
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 (ToJSON(..), FromJSON(..), Value(..))
import Data.Binary
import Data.Hashable
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Typeable
import Development.IDE
import Development.IDE.Core.Rules (defineNoFile)
import Development.IDE.Core.Shake (getDiagnostics)
#ifdef GHC_LIB
import Data.List (nub)
import "ghc-lib" GHC hiding (DynFlags(..))
import "ghc" GHC as RealGHC (DynFlags(..))
import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags)
import qualified "ghc" EnumSet as EnumSet
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
#else
import Development.IDE.GHC.Compat hiding (DynFlags(..))
#endif
import Ide.Logger
import Ide.Types
import Ide.Plugin.Config
import Ide.PluginUtils
import Language.Haskell.HLint as Hlint
import Language.Haskell.LSP.Core
import Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Types as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP
import System.FilePath (takeFileName)
import System.IO (hPutStr, noNewlineTranslation, hSetNewlineMode, utf8, hSetEncoding, IOMode(WriteMode), withFile, hClose)
import System.IO.Temp
import Text.Regex.TDFA.Text()
import GHC.Generics (Generic)
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
]
, pluginCodeActionProvider :: Maybe (CodeActionProvider IdeState)
pluginCodeActionProvider = CodeActionProvider IdeState -> Maybe (CodeActionProvider IdeState)
forall a. a -> Maybe a
Just CodeActionProvider IdeState
codeActionProvider
}
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 <- Action Config
forall a. (Default a, FromJSON a) => Action a
getClientConfigAction
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 -> (PluginConfig -> Bool) -> Bool
pluginEnabled PluginConfig
pluginConfig PluginConfig -> Bool
plcDiagnosticsOn
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 ())
HlintUsage -> Rules ()
getHlintSettingsRule ([String] -> HlintUsage
HlintEnabled [])
Action () -> Rules ()
forall a. Partial => Action a -> Rules ()
action (Action () -> Rules ()) -> Action () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
HashMap NormalizedFilePath FileOfInterestStatus
files <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest
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 NumberOrString
-> 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 NumberOrString
_code = NumberOrString -> Maybe NumberOrString
forall a. a -> Maybe a
Just (Text -> NumberOrString
LSP.StringValue (Text -> NumberOrString) -> Text -> NumberOrString
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 NumberOrString
-> 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 NumberOrString
_code = NumberOrString -> Maybe NumberOrString
forall a. a -> Maybe a
Just (Text -> NumberOrString
LSP.StringValue 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 (RealSrcSpan 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 FastString
_) = 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 ()
logm (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))
#ifdef GHC_LIB
moduleEx flags = do
mbpm <- getParsedModule nfp
if isNothing mbpm
then return Nothing
else do
flags' <- setExtensions flags
(_, contents) <- getFileContents nfp
let fp = fromNormalizedFilePath nfp
let contents' = T.unpack <$> contents
Just <$> (liftIO $ parseModuleEx flags' fp contents')
setExtensions flags = do
hsc <- hscEnv <$> use_ GhcSession nfp
let dflags = hsc_dflags hsc
let hscExts = EnumSet.toList (extensionFlags dflags)
let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts
let hlintExts = nub $ enabledExtensions flags ++ hscExts'
logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts
return $ flags { enabledExtensions = hlintExts }
#else
moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
moduleEx ParseFlags
_flags = do
Maybe ParsedModule
mbpm <- NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule NormalizedFilePath
nfp
Maybe (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx)))
-> Maybe (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx))
forall a b. (a -> b) -> a -> b
$ ParsedModule -> Either ParseError ModuleEx
forall a. ParsedModule -> Either a ModuleEx
createModule (ParsedModule -> Either ParseError ModuleEx)
-> Maybe ParsedModule -> Maybe (Either ParseError ModuleEx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParsedModule
mbpm
where createModule :: ParsedModule -> Either a ModuleEx
createModule ParsedModule
pm = ModuleEx -> Either a ModuleEx
forall a b. b -> Either a b
Right (ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
createModuleEx ApiAnns
anns Located (HsModule GhcPs)
modu)
where anns :: ApiAnns
anns = ParsedModule -> ApiAnns
pm_annotations ParsedModule
pm
modu :: Located (HsModule GhcPs)
modu = ParsedModule -> Located (HsModule GhcPs)
pm_parsed_source ParsedModule
pm
#endif
data HlintUsage
= HlintEnabled { HlintUsage -> [String]
cmdArgs :: [String] }
| HlintDisabled
deriving Int -> HlintUsage -> ShowS
[HlintUsage] -> ShowS
HlintUsage -> String
(Int -> HlintUsage -> ShowS)
-> (HlintUsage -> String)
-> ([HlintUsage] -> ShowS)
-> Show HlintUsage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HlintUsage] -> ShowS
$cshowList :: [HlintUsage] -> ShowS
show :: HlintUsage -> String
$cshow :: HlintUsage -> String
showsPrec :: Int -> HlintUsage -> ShowS
$cshowsPrec :: Int -> HlintUsage -> ShowS
Show
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)
getHlintSettingsRule :: HlintUsage -> Rules ()
getHlintSettingsRule :: HlintUsage -> Rules ()
getHlintSettingsRule HlintUsage
usage =
(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 ->
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
$ case HlintUsage
usage of
HlintEnabled [String]
cmdArgs -> [String] -> IO (ParseFlags, [Classify], Hint)
argsSettings [String]
cmdArgs
HlintUsage
HlintDisabled -> String -> IO (ParseFlags, [Classify], Hint)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"hlint configuration unspecified"
codeActionProvider :: CodeActionProvider IdeState
codeActionProvider :: CodeActionProvider IdeState
codeActionProvider LspFuncs Config
_lf IdeState
ideState PluginId
plId TextDocumentIdentifier
docId Range
_ CodeActionContext
context = List CAResult -> Either ResponseError (List CAResult)
forall a b. b -> Either a b
Right (List CAResult -> Either ResponseError (List CAResult))
-> ([CodeAction] -> List CAResult)
-> [CodeAction]
-> Either ResponseError (List CAResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CAResult] -> List CAResult
forall a. [a] -> List a
LSP.List ([CAResult] -> List CAResult)
-> ([CodeAction] -> [CAResult]) -> [CodeAction] -> List CAResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeAction -> CAResult) -> [CodeAction] -> [CAResult]
forall a b. (a -> b) -> [a] -> [b]
map CodeAction -> CAResult
CACodeAction ([CodeAction] -> Either ResponseError (List CAResult))
-> IO [CodeAction] -> IO (Either ResponseError (List CAResult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [CodeAction]
getCodeActions
where
getCodeActions :: IO [CodeAction]
getCodeActions = do
[CodeAction]
applyOne <- IO [CodeAction]
applyOneActions
[FileDiagnostic]
diags <- 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]
diags
, 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
]
if Int
numHintsInDoc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then do
CodeAction
applyAll <- IO CodeAction
applyAllAction
[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
applyAllCodeAction -> [CodeAction] -> [CodeAction]
forall a. a -> [a] -> [a]
:[CodeAction]
applyOne
else
[CodeAction] -> IO [CodeAction]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeAction]
applyOne
applyAllAction :: IO CodeAction
applyAllAction = do
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)]
Command
cmd <- PluginId -> CommandId -> Text -> Maybe [Value] -> IO Command
mkLspCommand PluginId
plId CommandId
"applyAll" Text
"Apply all hints" Maybe [Value]
args
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
$ Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe WorkspaceEdit
-> Maybe Command
-> 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 WorkspaceEdit
forall a. Maybe a
Nothing (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd)
applyOneActions :: IO [LSP.CodeAction]
applyOneActions :: IO [CodeAction]
applyOneActions = [Maybe CodeAction] -> [CodeAction]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CodeAction] -> [CodeAction])
-> IO [Maybe CodeAction] -> IO [CodeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Diagnostic -> IO (Maybe CodeAction))
-> [Diagnostic] -> IO [Maybe CodeAction]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Diagnostic -> IO (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 (LSP.StringValue 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 -> IO (Maybe LSP.CodeAction)
mkHlintAction :: Diagnostic -> IO (Maybe CodeAction)
mkHlintAction diag :: Diagnostic
diag@(LSP.Diagnostic (LSP.Range Position
start Position
_) Maybe DiagnosticSeverity
_s (Just (LSP.StringValue 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)
-> IO Command -> IO (Maybe CodeAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginId -> CommandId -> Text -> Maybe [Value] -> IO 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 WorkspaceEdit
-> Maybe Command
-> 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 WorkspaceEdit
forall a. Maybe a
Nothing (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd)
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 NumberOrString
_c Maybe Text
_source Text
_m Maybe (List DiagnosticTag)
_ Maybe (List DiagnosticRelatedInformation)
_) = Maybe CodeAction -> IO (Maybe CodeAction)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CodeAction
forall a. Maybe a
Nothing
applyAllCmd :: CommandFunction IdeState Uri
applyAllCmd :: CommandFunction IdeState Uri
applyAllCmd LspFuncs Config
lf 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. Partial => 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)
LspFuncs Config
-> Text
-> ProgressCancellable
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall c.
LspFuncs c -> forall a. Text -> ProgressCancellable -> IO a -> IO a
withIndefiniteProgress LspFuncs Config
lf Text
"Applying all hints" ProgressCancellable
Cancellable (IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams)))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> IO ()) -> String -> 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 <- IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint IdeState
ide NormalizedFilePath
file Maybe OneHint
forall a. Maybe a
Nothing
String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> IO ()) -> String -> 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
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams)))
-> (Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall a b. (a -> b) -> a -> b
$
case Either String WorkspaceEdit
res of
Left String
err -> (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)), Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. Maybe a
Nothing)
Right WorkspaceEdit
fs -> (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null, (ServerMethod, ApplyWorkspaceEditParams)
-> Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. a -> Maybe a
Just (ServerMethod
WorkspaceApplyEdit, WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams WorkspaceEdit
fs))
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 LspFuncs Config
lf 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. Partial => 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
LspFuncs Config
-> Text
-> ProgressCancellable
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall c.
LspFuncs c -> forall a. Text -> ProgressCancellable -> IO a -> IO a
withIndefiniteProgress LspFuncs Config
lf Text
progTitle ProgressCancellable
Cancellable (IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams)))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> IO ()) -> String -> 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 <- 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 -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> IO ()) -> String -> 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
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams)))
-> (Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
(Either ResponseError Value,
Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall a b. (a -> b) -> a -> b
$
case Either String WorkspaceEdit
res of
Left String
err -> (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)), Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. Maybe a
Nothing)
Right WorkspaceEdit
fs -> (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null, (ServerMethod, ApplyWorkspaceEditParams)
-> Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. a -> Maybe a
Just (ServerMethod
WorkspaceApplyEdit, WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams WorkspaceEdit
fs))
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
[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
$ IO (Either ParseError [Idea]) -> IO (Either ParseError [Idea])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ParseError [Idea]) -> IO (Either ParseError [Idea]))
-> IO (Either ParseError [Idea]) -> IO (Either ParseError [Idea])
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> Action (Either ParseError [Idea])
-> IO (Either ParseError [Idea])
forall a. String -> IdeState -> Action a -> IO a
runAction String
"applyHint" IdeState
ide (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 :: [(String, [Refactoring SrcSpan])]
commands = (Idea -> (String, [Refactoring SrcSpan]))
-> [Idea] -> [(String, [Refactoring SrcSpan])]
forall a b. (a -> b) -> [a] -> [b]
map (Idea -> String
forall a. Show a => a -> String
show (Idea -> String)
-> (Idea -> [Refactoring SrcSpan])
-> Idea
-> (String, [Refactoring SrcSpan])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& 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]
++ [(String, [Refactoring SrcSpan])] -> String
forall a. Show a => a -> String
show [(String, [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
$ String
-> IdeState
-> Action (UTCTime, Maybe Text)
-> IO (UTCTime, Maybe Text)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"hlint" IdeState
ide (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
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
(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
<$> Maybe (Int, Int)
-> [(String, [Refactoring SrcSpan])] -> String -> IO String
applyRefactorings Maybe (Int, Int)
forall a. Maybe a
Nothing [(String, [Refactoring SrcSpan])]
commands String
temp) IO (Either String String)
-> [Handler (Either String String)] -> IO (Either String String)
forall a. IO a -> [Handler a] -> IO a
`catches`
[ (IOException -> IO (Either String String))
-> Handler (Either String String)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO (Either String String))
-> Handler (Either String String))
-> (IOException -> IO (Either String String))
-> Handler (Either String String)
forall a b. (a -> b) -> a -> b
$ \IOException
e -> Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left (IOException -> String
forall a. Show a => a -> String
show (IOException
e :: IOException)))
, (ErrorCall -> IO (Either String String))
-> Handler (Either String String)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ErrorCall -> IO (Either String String))
-> Handler (Either String String))
-> (ErrorCall -> IO (Either String String))
-> Handler (Either String String)
forall a b. (a -> b) -> a -> b
$ \ErrorCall
e -> Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left (ErrorCall -> String
forall a. Show a => a -> String
show (ErrorCall
e :: ErrorCall)))
]
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 (ShowS
forall a. Show a => a -> String
show 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 (RealSrcSpan RealSrcSpan
real) = RealSrcSpan
real
toRealSrcSpan (UnhelpfulSpan FastString
x) = String -> RealSrcSpan
forall a. Partial => 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]
++ FastString -> String
forall a. Show a => a -> String
show FastString
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 #-}
writeFileUTF8NoNewLineTranslation :: FilePath -> T.Text -> IO()
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)