{-# 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
  --, provider

  ) 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
  }

-- This rule only exists for generating file diagnostics

-- so the RuleResult is empty

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 = ()

-- | Hlint rules to generate file diagnostics based on hlint hints

-- | This rule is recomputed when:

-- | - The files of interest have changed via `getFilesOfInterest`

-- | - One of those files has been edited via

-- |    - `getIdeas` -> `getParsedModule` in any case

-- |    - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc

-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`

-- | - The hlint specific settings have changed, via `getHlintSettingsRule`

rules :: 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
          -- we are encoding the fact that idea has refactorings in diagnostic code

          , $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
        }

      -- This one is defined in Development.IDE.GHC.Error but here

      -- the types could come from ghc-lib or ghc

      srcSpanToRange :: SrcSpan -> LSP.Range
      srcSpanToRange :: SrcSpan -> Range
srcSpanToRange (RealSrcSpan RealSrcSpan
span) = 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 ghc was not able to parse the module, we disable hlint diagnostics

          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
              ]
        -- We only want to show the applyAll code action if there is more than 1

        -- hint in the current document

        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)

    -- |Some hints do not have an associated refactoring

    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)
       -- we have to recover the original ideaHint removing the prefix

       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
       -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)

       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
  -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.

  , 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
    -- set Nothing as "position" for "applyRefactorings" because

    -- applyRefactorings expects the provided position to be _within_ the scope

    -- of each refactoring it will apply.

    -- But "Idea"s returned by HLint point to starting position of the expressions

    -- that contain refactorings, so they are often outside the refactorings' boundaries.

    -- Example:

    -- Given an expression "hlintTest = reid $ (myid ())"

    -- Hlint returns an idea at the position (1,13)

    -- That contains "Redundant brackets" refactoring at position (1,20):

    --

    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]

    --

    -- If we provide "applyRefactorings" with "Just (1,13)" then

    -- the "Redundant bracket" hint will never be executed

    -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).

    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
    -- We need to save a file with last edited contents cause `apply-refact`

    -- doesn't expose a function taking directly contents instead a file path.

    -- Ideally we should try to expose that function upstream and remove this.

    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
          -- | If we are only interested in applying a particular hint then

          -- let's filter out all the irrelevant ideas

          filterIdeas :: OneHint -> [Idea] -> [Idea]
          filterIdeas :: OneHint -> [Idea] -> [Idea]
filterIdeas (OneHint (Position 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]

-- | Map over both failure and success.

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)