{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE OverloadedLabels      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PackageImports        #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# OPTIONS_GHC -Wno-orphans   #-}

#ifdef HLINT_ON_GHC_LIB
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z)
#else
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)
#endif

module Ide.Plugin.Hlint
  (
    descriptor
  --, provider
  ) where
import           Control.Arrow                                      ((&&&))
import           Control.DeepSeq
import           Control.Exception
import           Control.Lens                                       ((^.))
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except
import           Data.Aeson.Types                                   (FromJSON (..),
                                                                     ToJSON (..),
                                                                     Value (..))
import           Data.Binary
import           Data.Default
import qualified Data.HashMap.Strict                                as Map
import           Data.Hashable
import           Data.Maybe
import qualified Data.Text                                          as T
import qualified Data.Text.IO                                       as T
import           Data.Typeable
import           Development.IDE                                    hiding
                                                                    (Error)
import           Development.IDE.Core.Rules                         (defineNoFile,
                                                                     getParsedModuleWithComments,
                                                                     usePropertyAction)
import           Development.IDE.Core.Shake                         (getDiagnostics)
import           Refact.Apply

#ifdef HLINT_ON_GHC_LIB
import           Data.List                                          (nub)
import           "ghc" DynFlags                                     as RealGHC.DynFlags (topDir)
import qualified "ghc" EnumSet                                      as EnumSet
import           "ghc" GHC                                          as RealGHC (DynFlags (..))
import           "ghc-lib" GHC                                      hiding
                                                                    (DynFlags (..),
                                                                     ms_hspp_opts)
import           "ghc-lib-parser" GHC.LanguageExtensions            (Extension)
import           "ghc" HscTypes                                     as RealGHC.HscTypes (hsc_dflags,
                                                                                         ms_hspp_opts)
import           Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
import           System.FilePath                                    (takeFileName)
import           System.IO                                          (IOMode (WriteMode),
                                                                     hClose,
                                                                     hPutStr,
                                                                     hSetEncoding,
                                                                     hSetNewlineMode,
                                                                     noNewlineTranslation,
                                                                     utf8,
                                                                     withFile)
import           System.IO.Temp
#else
import           Development.IDE.GHC.Compat                         hiding
                                                                    (DynFlags (..),
                                                                     OldRealSrcSpan)
import           Language.Haskell.GHC.ExactPrint.Delta              (deltaOptions)
import           Language.Haskell.GHC.ExactPrint.Parsers            (postParseTransform)
import           Language.Haskell.GHC.ExactPrint.Types              (Rigidity (..))
#endif

import           Ide.Logger
import           Ide.Plugin.Config                                  hiding
                                                                    (Config)
import           Ide.Plugin.Properties
import           Ide.PluginUtils
import           Ide.Types
import           Language.Haskell.HLint                             as Hlint hiding
                                                                             (Error)
import           Language.LSP.Server                                (ProgressCancellable (Cancellable),
                                                                     sendRequest,
                                                                     withIndefiniteProgress)
import           Language.LSP.Types
import qualified Language.LSP.Types                                 as LSP
import qualified Language.LSP.Types.Lens                            as LSP

import           GHC.Generics                                       (Generic)
import           Text.Regex.TDFA.Text                               ()

import           System.Environment                                 (setEnv,
                                                                     unsetEnv)
-- ---------------------------------------------------------------------

-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib
pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan
#if MIN_GHC_API_VERSION(9,0,0)
pattern $mOldRealSrcSpan :: forall r. SrcSpan -> (RealSrcSpan -> r) -> (Void# -> r) -> r
OldRealSrcSpan span <- RealSrcSpan span _
#else
pattern OldRealSrcSpan span <- RealSrcSpan span
#endif
{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-}

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
  { pluginRules :: Rules ()
pluginRules = PluginId -> Rules ()
rules PluginId
plId
  , pluginCommands :: [PluginCommand IdeState]
pluginCommands =
      [ CommandId
-> Text
-> CommandFunction IdeState ApplyOneParams
-> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
"applyOne" Text
"Apply a single hint" CommandFunction IdeState ApplyOneParams
applyOneCmd
      , CommandId
-> Text -> CommandFunction IdeState Uri -> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
"applyAll" Text
"Apply all hints to the file" CommandFunction IdeState Uri
applyAllCmd
      ]
  , pluginHandlers :: PluginHandlers IdeState
pluginHandlers = SClientMethod 'TextDocumentCodeAction
-> PluginMethodHandler IdeState 'TextDocumentCodeAction
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider
  , pluginConfigDescriptor :: ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor
defaultConfigDescriptor
      { configHasDiagnostics :: Bool
configHasDiagnostics = Bool
True
      , configCustomConfig :: CustomConfig
configCustomConfig = Properties '[ 'PropertyKey "flags" ('TArray String)]
-> CustomConfig
forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig Properties '[ 'PropertyKey "flags" ('TArray String)]
properties
      }
  }

-- 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:
-- | - A file has been edited via
-- |    - `getIdeas` -> `getParsedModule` in any case
-- |    - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
-- | - The hlint specific settings have changed, via `getHlintSettingsRule`
rules :: PluginId -> Rules ()
rules :: PluginId -> Rules ()
rules PluginId
plugin = do
  (GetHlintDiagnostics
 -> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ()
forall k v.
IdeRule k v =>
(k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((GetHlintDiagnostics
  -> NormalizedFilePath -> Action (IdeResult ()))
 -> Rules ())
-> (GetHlintDiagnostics
    -> NormalizedFilePath -> Action (IdeResult ()))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetHlintDiagnostics
GetHlintDiagnostics NormalizedFilePath
file -> do
    Config
config <- Config -> Action Config
getClientConfigAction Config
forall a. Default a => a
def
    let pluginConfig :: PluginConfig
pluginConfig = Config -> PluginId -> PluginConfig
configForPlugin Config
config PluginId
plugin
    let hlintOn' :: Bool
hlintOn' = Config -> Bool
hlintOn Config
config Bool -> Bool -> Bool
&& PluginConfig -> Bool
plcGlobalOn PluginConfig
pluginConfig Bool -> Bool -> Bool
&& PluginConfig -> Bool
plcDiagnosticsOn PluginConfig
pluginConfig
    Either ParseError [Idea]
ideas <- if Bool
hlintOn' then NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas NormalizedFilePath
file else Either ParseError [Idea] -> Action (Either ParseError [Idea])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right [])
    IdeResult () -> Action (IdeResult ())
forall (m :: * -> *) a. Monad m => a -> m a
return (NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics NormalizedFilePath
file Either ParseError [Idea]
ideas, () -> Maybe ()
forall a. a -> Maybe a
Just ())

  (GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
-> Rules ()
forall k v. IdeRule k v => (k -> Action v) -> Rules ()
defineNoFile ((GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
 -> Rules ())
-> (GetHlintSettings -> Action (ParseFlags, [Classify], Hint))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetHlintSettings
GetHlintSettings -> do
    (Config [String]
flags) <- PluginId -> Action Config
getHlintConfig PluginId
plugin
    IO (ParseFlags, [Classify], Hint)
-> Action (ParseFlags, [Classify], Hint)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ParseFlags, [Classify], Hint)
 -> Action (ParseFlags, [Classify], Hint))
-> IO (ParseFlags, [Classify], Hint)
-> Action (ParseFlags, [Classify], Hint)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (ParseFlags, [Classify], Hint)
argsSettings [String]
flags

  Action () -> Rules ()
forall a. Action a -> Rules ()
action (Action () -> Rules ()) -> Action () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
    HashMap NormalizedFilePath FileOfInterestStatus
files <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
    Action [Maybe ()] -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action [Maybe ()] -> Action ()) -> Action [Maybe ()] -> Action ()
forall a b. (a -> b) -> a -> b
$ GetHlintDiagnostics -> [NormalizedFilePath] -> Action [Maybe ()]
forall k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetHlintDiagnostics
GetHlintDiagnostics ([NormalizedFilePath] -> Action [Maybe ()])
-> [NormalizedFilePath] -> Action [Maybe ()]
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
Map.keys HashMap NormalizedFilePath FileOfInterestStatus
files

  where

      diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
      diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics NormalizedFilePath
file (Right [Idea]
ideas) =
        [(NormalizedFilePath
file, ShowDiagnostic
ShowDiag, Idea -> Diagnostic
ideaToDiagnostic Idea
i) | Idea
i <- [Idea]
ideas, Idea -> Severity
ideaSeverity Idea
i Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
Ignore]
      diagnostics NormalizedFilePath
file (Left ParseError
parseErr) =
        [(NormalizedFilePath
file, ShowDiagnostic
ShowDiag, ParseError -> Diagnostic
parseErrorToDiagnostic ParseError
parseErr)]

      ideaToDiagnostic :: Idea -> Diagnostic
      ideaToDiagnostic :: Idea -> Diagnostic
ideaToDiagnostic Idea
idea =
        Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe (Int |? Text)
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
LSP.Diagnostic {
            $sel:_range:Diagnostic :: Range
_range    = SrcSpan -> Range
srcSpanToRange (SrcSpan -> Range) -> SrcSpan -> Range
forall a b. (a -> b) -> a -> b
$ Idea -> SrcSpan
ideaSpan Idea
idea
          , $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DsInfo
          -- we are encoding the fact that idea has refactorings in diagnostic code
          , $sel:_code:Diagnostic :: Maybe (Int |? Text)
_code     = (Int |? Text) -> Maybe (Int |? Text)
forall a. a -> Maybe a
Just (Text -> Int |? Text
forall a b. b -> a |? b
InR (Text -> Int |? Text) -> Text -> Int |? Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
codePre String -> ShowS
forall a. [a] -> [a] -> [a]
++ Idea -> String
ideaHint Idea
idea)
          , $sel:_source:Diagnostic :: Maybe Text
_source   = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"hlint"
          , $sel:_message:Diagnostic :: Text
_message  = Idea -> Text
idea2Message Idea
idea
          , $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = Maybe (List DiagnosticRelatedInformation)
forall a. Maybe a
Nothing
          , $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags     = Maybe (List DiagnosticTag)
forall a. Maybe a
Nothing
        }
        where codePre :: String
codePre = if [Refactoring SrcSpan] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Refactoring SrcSpan] -> Bool) -> [Refactoring SrcSpan] -> Bool
forall a b. (a -> b) -> a -> b
$ Idea -> [Refactoring SrcSpan]
ideaRefactoring Idea
idea then String
"" else String
"refact:"

      idea2Message :: Idea -> T.Text
      idea2Message :: Idea -> Text
idea2Message Idea
idea = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Idea -> String
ideaHint Idea
idea, Text
"Found:", Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Idea -> String
ideaFrom Idea
idea)]
                                     [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
toIdea [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Note -> Text) -> [Note] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Note -> String) -> Note -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> String
forall a. Show a => a -> String
show) (Idea -> [Note]
ideaNote Idea
idea)
        where
          toIdea :: [T.Text]
          toIdea :: [Text]
toIdea = case Idea -> Maybe String
ideaTo Idea
idea of
            Maybe String
Nothing -> []
            Just String
i  -> [String -> Text
T.pack String
"Why not:", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i]


      parseErrorToDiagnostic :: ParseError -> Diagnostic
      parseErrorToDiagnostic :: ParseError -> Diagnostic
parseErrorToDiagnostic (Hlint.ParseError SrcSpan
l String
msg String
contents) =
        Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe (Int |? Text)
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
LSP.Diagnostic {
            $sel:_range:Diagnostic :: Range
_range    = SrcSpan -> Range
srcSpanToRange SrcSpan
l
          , $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DsInfo
          , $sel:_code:Diagnostic :: Maybe (Int |? Text)
_code     = (Int |? Text) -> Maybe (Int |? Text)
forall a. a -> Maybe a
Just (Text -> Int |? Text
forall a b. b -> a |? b
InR Text
"parser")
          , $sel:_source:Diagnostic :: Maybe Text
_source   = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"hlint"
          , $sel:_message:Diagnostic :: Text
_message  = [Text] -> Text
T.unlines [String -> Text
T.pack String
msg,String -> Text
T.pack String
contents]
          , $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = Maybe (List DiagnosticRelatedInformation)
forall a. Maybe a
Nothing
          , $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags     = Maybe (List DiagnosticTag)
forall a. Maybe a
Nothing
        }

      -- 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 (OldRealSrcSpan RealSrcSpan
span) = Range :: Position -> Position -> Range
Range {
          _start :: Position
_start = Position :: Int -> Int -> Position
LSP.Position {
                _line :: Int
_line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              , _character :: Int
_character  = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
        , _end :: Position
_end   = Position :: Int -> Int -> Position
LSP.Position {
                _line :: Int
_line = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
             , _character :: Int
_character = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
        }
      srcSpanToRange (UnhelpfulSpan UnhelpfulSpanReason
_) = Range
noRange

getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas NormalizedFilePath
nfp = do
  String -> Action ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugm (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:getIdeas:file:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp
  (ParseFlags
flags, [Classify]
classify, Hint
hint) <- GetHlintSettings -> Action (ParseFlags, [Classify], Hint)
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetHlintSettings
GetHlintSettings

  let applyHints' :: Maybe (Either ParseError ModuleEx) -> Either ParseError [Idea]
applyHints' (Just (Right ModuleEx
modEx)) = [Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right ([Idea] -> Either ParseError [Idea])
-> [Idea] -> Either ParseError [Idea]
forall a b. (a -> b) -> a -> b
$ [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints [Classify]
classify Hint
hint [ModuleEx
modEx]
      applyHints' (Just (Left ParseError
err)) = ParseError -> Either ParseError [Idea]
forall a b. a -> Either a b
Left ParseError
err
      applyHints' Maybe (Either ParseError ModuleEx)
Nothing = [Idea] -> Either ParseError [Idea]
forall a b. b -> Either a b
Right []

  (Maybe (Either ParseError ModuleEx) -> Either ParseError [Idea])
-> Action (Maybe (Either ParseError ModuleEx))
-> Action (Either ParseError [Idea])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Either ParseError ModuleEx) -> Either ParseError [Idea]
applyHints' (ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
moduleEx ParseFlags
flags)

  where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
#ifndef HLINT_ON_GHC_LIB
        moduleEx _flags = do
          mbpm <- getParsedModule nfp
          return $ createModule <$> mbpm
          where createModule pm = Right (createModuleEx anns modu)
                  where anns = pm_annotations pm
                        modu = pm_parsed_source pm
#else
        moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
moduleEx ParseFlags
flags = do
          Maybe ParsedModule
mbpm <- NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule NormalizedFilePath
nfp
          -- If ghc was not able to parse the module, we disable hlint diagnostics
          if Maybe ParsedModule -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ParsedModule
mbpm
              then Maybe (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ParseError ModuleEx)
forall a. Maybe a
Nothing
              else do
                     ParseFlags
flags' <- ParseFlags -> Action ParseFlags
setExtensions ParseFlags
flags
                     (UTCTime
_, Maybe Text
contents) <- NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
                     let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
                     let contents' :: Maybe String
contents' = Text -> String
T.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
contents
                     Either ParseError ModuleEx -> Maybe (Either ParseError ModuleEx)
forall a. a -> Maybe a
Just (Either ParseError ModuleEx -> Maybe (Either ParseError ModuleEx))
-> Action (Either ParseError ModuleEx)
-> Action (Maybe (Either ParseError ModuleEx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either ParseError ModuleEx)
-> Action (Either ParseError ModuleEx)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ParseFlags
-> String -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
flags' String
fp Maybe String
contents')

        setExtensions :: ParseFlags -> Action ParseFlags
setExtensions ParseFlags
flags = do
          [Extension]
hlintExts <- ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions ParseFlags
flags NormalizedFilePath
nfp
          String -> Action ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugm (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:getIdeas:setExtensions:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Extension] -> String
forall a. Show a => a -> String
show [Extension]
hlintExts
          ParseFlags -> Action ParseFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseFlags -> Action ParseFlags)
-> ParseFlags -> Action ParseFlags
forall a b. (a -> b) -> a -> b
$ ParseFlags
flags { enabledExtensions :: [Extension]
enabledExtensions = [Extension]
hlintExts }

getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions ParseFlags
pflags NormalizedFilePath
nfp = do
    DynFlags
dflags <- Action DynFlags
getFlags
    let hscExts :: [Extension]
hscExts = EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
EnumSet.toList (DynFlags -> EnumSet Extension
extensionFlags DynFlags
dflags)
    let hscExts' :: [Extension]
hscExts' = (Extension -> Maybe Extension) -> [Extension] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Extension
GhclibParserEx.readExtension (String -> Maybe Extension)
-> (Extension -> String) -> Extension -> Maybe Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> String
forall a. Show a => a -> String
show) [Extension]
hscExts
    let hlintExts :: [Extension]
hlintExts = [Extension] -> [Extension]
forall a. Eq a => [a] -> [a]
nub ([Extension] -> [Extension]) -> [Extension] -> [Extension]
forall a b. (a -> b) -> a -> b
$ ParseFlags -> [Extension]
enabledExtensions ParseFlags
pflags [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
hscExts'
    [Extension] -> Action [Extension]
forall (m :: * -> *) a. Monad m => a -> m a
return [Extension]
hlintExts
  where getFlags :: Action DynFlags
        getFlags :: Action DynFlags
getFlags = do
          ModSummaryResult
modsum <- GetModSummary -> NormalizedFilePath -> Action ModSummaryResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
          DynFlags -> Action DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Action DynFlags) -> DynFlags -> Action DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags) -> ModSummary -> DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum
#endif

-- ---------------------------------------------------------------------

data GetHlintSettings = GetHlintSettings
    deriving (GetHlintSettings -> GetHlintSettings -> Bool
(GetHlintSettings -> GetHlintSettings -> Bool)
-> (GetHlintSettings -> GetHlintSettings -> Bool)
-> Eq GetHlintSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetHlintSettings -> GetHlintSettings -> Bool
$c/= :: GetHlintSettings -> GetHlintSettings -> Bool
== :: GetHlintSettings -> GetHlintSettings -> Bool
$c== :: GetHlintSettings -> GetHlintSettings -> Bool
Eq, Int -> GetHlintSettings -> ShowS
[GetHlintSettings] -> ShowS
GetHlintSettings -> String
(Int -> GetHlintSettings -> ShowS)
-> (GetHlintSettings -> String)
-> ([GetHlintSettings] -> ShowS)
-> Show GetHlintSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetHlintSettings] -> ShowS
$cshowList :: [GetHlintSettings] -> ShowS
show :: GetHlintSettings -> String
$cshow :: GetHlintSettings -> String
showsPrec :: Int -> GetHlintSettings -> ShowS
$cshowsPrec :: Int -> GetHlintSettings -> ShowS
Show, Typeable, (forall x. GetHlintSettings -> Rep GetHlintSettings x)
-> (forall x. Rep GetHlintSettings x -> GetHlintSettings)
-> Generic GetHlintSettings
forall x. Rep GetHlintSettings x -> GetHlintSettings
forall x. GetHlintSettings -> Rep GetHlintSettings x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetHlintSettings x -> GetHlintSettings
$cfrom :: forall x. GetHlintSettings -> Rep GetHlintSettings x
Generic)
instance Hashable GetHlintSettings
instance NFData   GetHlintSettings
instance NFData Hint where rnf :: Hint -> ()
rnf = Hint -> ()
forall a. a -> ()
rwhnf
instance NFData Classify where rnf :: Classify -> ()
rnf = Classify -> ()
forall a. a -> ()
rwhnf
instance NFData ParseFlags where rnf :: ParseFlags -> ()
rnf = ParseFlags -> ()
forall a. a -> ()
rwhnf
instance Show Hint where show :: Hint -> String
show = String -> Hint -> String
forall a b. a -> b -> a
const String
"<hint>"
instance Show ParseFlags where show :: ParseFlags -> String
show = String -> ParseFlags -> String
forall a b. a -> b -> a
const String
"<parseFlags>"
instance Binary GetHlintSettings

type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint)

-- ---------------------------------------------------------------------

newtype Config = Config [String]

properties :: Properties '[ 'PropertyKey "flags" ('TArray String)]
properties :: Properties '[ 'PropertyKey "flags" ('TArray String)]
properties = Properties '[]
emptyProperties
  Properties '[]
-> (Properties '[]
    -> Properties '[ 'PropertyKey "flags" ('TArray String)])
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
forall a b. a -> (a -> b) -> b
& KeyNameProxy "flags"
-> Text
-> [String]
-> Properties '[]
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
forall (s :: Symbol) (r :: [PropertyKey]) a.
(KnownSymbol s, NotElem s r, ToJSON a, FromJSON a) =>
KeyNameProxy s
-> Text
-> [a]
-> Properties r
-> Properties ('PropertyKey s ('TArray a) : r)
defineArrayProperty IsLabel "flags" (KeyNameProxy "flags")
KeyNameProxy "flags"
#flags
    Text
"Flags used by hlint" []

-- | Get the plugin config
getHlintConfig :: PluginId -> Action Config
getHlintConfig :: PluginId -> Action Config
getHlintConfig PluginId
pId =
  [String] -> Config
Config
    ([String] -> Config) -> Action [String] -> Action Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyNameProxy "flags"
-> PluginId
-> Properties '[ 'PropertyKey "flags" ('TArray String)]
-> Action (ToHsType ('TArray String))
forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction IsLabel "flags" (KeyNameProxy "flags")
KeyNameProxy "flags"
#flags PluginId
pId Properties '[ 'PropertyKey "flags" ('TArray String)]
properties

-- ---------------------------------------------------------------------
codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider IdeState
ideState PluginId
plId (CodeActionParams _ _ docId _ context) = List (Command |? CodeAction)
-> Either ResponseError (List (Command |? CodeAction))
forall a b. b -> Either a b
Right (List (Command |? CodeAction)
 -> Either ResponseError (List (Command |? CodeAction)))
-> ([CodeAction] -> List (Command |? CodeAction))
-> [CodeAction]
-> Either ResponseError (List (Command |? CodeAction))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
LSP.List ([Command |? CodeAction] -> List (Command |? CodeAction))
-> ([CodeAction] -> [Command |? CodeAction])
-> [CodeAction]
-> List (Command |? CodeAction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeAction -> Command |? CodeAction)
-> [CodeAction] -> [Command |? CodeAction]
forall a b. (a -> b) -> [a] -> [b]
map CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
InR ([CodeAction]
 -> Either ResponseError (List (Command |? CodeAction)))
-> LspT Config IO [CodeAction]
-> LspT
     Config IO (Either ResponseError (List (Command |? CodeAction)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [CodeAction] -> LspT Config IO [CodeAction]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [CodeAction]
getCodeActions
  where

    getCodeActions :: IO [CodeAction]
getCodeActions = do
        [FileDiagnostic]
allDiags <- IdeState -> IO [FileDiagnostic]
getDiagnostics IdeState
ideState
        let docNfp :: Maybe NormalizedFilePath
docNfp = String -> NormalizedFilePath
toNormalizedFilePath' (String -> NormalizedFilePath)
-> Maybe String -> Maybe NormalizedFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> Maybe String
uriToFilePath' (TextDocumentIdentifier
docId TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
LSP.uri)
            numHintsInDoc :: Int
numHintsInDoc = [Diagnostic] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
              [Diagnostic
d | (NormalizedFilePath
nfp, ShowDiagnostic
_, Diagnostic
d) <- [FileDiagnostic]
allDiags
                 , Diagnostic -> Bool
validCommand Diagnostic
d
                 , NormalizedFilePath -> Maybe NormalizedFilePath
forall a. a -> Maybe a
Just NormalizedFilePath
nfp Maybe NormalizedFilePath -> Maybe NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe NormalizedFilePath
docNfp
              ]
            numHintsInContext :: Int
numHintsInContext = [Diagnostic] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
              [Diagnostic
d | Diagnostic
d <- [Diagnostic]
diags
                 , Diagnostic -> Bool
validCommand Diagnostic
d
              ]
        -- We only want to show the applyAll code action if there is more than 1
        -- hint in the current document and if code action range contains at
        -- least one hint
        if Int
numHintsInDoc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Int
numHintsInContext Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then do
          [CodeAction] -> IO [CodeAction]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CodeAction] -> IO [CodeAction])
-> [CodeAction] -> IO [CodeAction]
forall a b. (a -> b) -> a -> b
$ CodeAction
applyAllActionCodeAction -> [CodeAction] -> [CodeAction]
forall a. a -> [a] -> [a]
:[CodeAction]
applyOneActions
        else
          [CodeAction] -> IO [CodeAction]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeAction]
applyOneActions

    applyAllAction :: CodeAction
applyAllAction =
      let args :: Maybe [Value]
args = [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Uri -> Value
forall a. ToJSON a => a -> Value
toJSON (TextDocumentIdentifier
docId TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
LSP.uri)]
          cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
"applyAll" Text
"Apply all hints" Maybe [Value]
args
        in Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction Text
"Apply all hints" (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionQuickFix) Maybe (List Diagnostic)
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Reason
forall a. Maybe a
Nothing Maybe WorkspaceEdit
forall a. Maybe a
Nothing (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd) Maybe Value
forall a. Maybe a
Nothing

    applyOneActions :: [LSP.CodeAction]
    applyOneActions :: [CodeAction]
applyOneActions = (Diagnostic -> Maybe CodeAction) -> [Diagnostic] -> [CodeAction]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Diagnostic -> Maybe CodeAction
mkHlintAction ((Diagnostic -> Bool) -> [Diagnostic] -> [Diagnostic]
forall a. (a -> Bool) -> [a] -> [a]
filter Diagnostic -> Bool
validCommand [Diagnostic]
diags)

    -- |Some hints do not have an associated refactoring
    validCommand :: Diagnostic -> Bool
validCommand (LSP.Diagnostic Range
_ Maybe DiagnosticSeverity
_ (Just (InR Text
code)) (Just Text
"hlint") Text
_ Maybe (List DiagnosticTag)
_ Maybe (List DiagnosticRelatedInformation)
_) =
        Text
"refact:" Text -> Text -> Bool
`T.isPrefixOf` Text
code
    validCommand Diagnostic
_ =
        Bool
False

    LSP.List [Diagnostic]
diags = CodeActionContext
context CodeActionContext
-> Getting (List Diagnostic) CodeActionContext (List Diagnostic)
-> List Diagnostic
forall s a. s -> Getting a s a -> a
^. Getting (List Diagnostic) CodeActionContext (List Diagnostic)
forall s a. HasDiagnostics s a => Lens' s a
LSP.diagnostics

    mkHlintAction :: LSP.Diagnostic -> Maybe LSP.CodeAction
    mkHlintAction :: Diagnostic -> Maybe CodeAction
mkHlintAction diag :: Diagnostic
diag@(LSP.Diagnostic (LSP.Range Position
start Position
_) Maybe DiagnosticSeverity
_s (Just (InR Text
code)) (Just Text
"hlint") Text
_ Maybe (List DiagnosticTag)
_ Maybe (List DiagnosticRelatedInformation)
_) =
      CodeAction -> Maybe CodeAction
forall a. a -> Maybe a
Just (CodeAction -> Maybe CodeAction)
-> (Command -> CodeAction) -> Command -> Maybe CodeAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> CodeAction
codeAction (Command -> Maybe CodeAction) -> Command -> Maybe CodeAction
forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
"applyOne" Text
title ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
args)
     where
       codeAction :: Command -> CodeAction
codeAction Command
cmd = Text
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction Text
title (CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionQuickFix) (List Diagnostic -> Maybe (List Diagnostic)
forall a. a -> Maybe a
Just ([Diagnostic] -> List Diagnostic
forall a. [a] -> List a
LSP.List [Diagnostic
diag])) Maybe Bool
forall a. Maybe a
Nothing Maybe Reason
forall a. Maybe a
Nothing Maybe WorkspaceEdit
forall a. Maybe a
Nothing (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd) Maybe Value
forall a. Maybe a
Nothing
       -- 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 (Int |? Text)
_c Maybe Text
_source Text
_m Maybe (List DiagnosticTag)
_ Maybe (List DiagnosticRelatedInformation)
_) = Maybe CodeAction
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------

applyAllCmd :: CommandFunction IdeState Uri
applyAllCmd :: CommandFunction IdeState Uri
applyAllCmd IdeState
ide Uri
uri = do
  let file :: NormalizedFilePath
file = NormalizedFilePath
-> (String -> NormalizedFilePath)
-> Maybe String
-> NormalizedFilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NormalizedFilePath
forall a. HasCallStack => String -> a
error (String -> NormalizedFilePath) -> String -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> String
forall a. Show a => a -> String
show Uri
uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a file.")
                    String -> NormalizedFilePath
toNormalizedFilePath'
                   (Uri -> Maybe String
uriToFilePath' Uri
uri)
  Text
-> ProgressCancellable
-> LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
"Applying all hints" ProgressCancellable
Cancellable (LspM Config (Either ResponseError Value)
 -> LspM Config (Either ResponseError Value))
-> LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ do
    String -> LspT Config IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> LspT Config IO ()) -> String -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyAllCmd:file=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
file
    Either String WorkspaceEdit
res <- IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String WorkspaceEdit)
 -> LspT Config IO (Either String WorkspaceEdit))
-> IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint IdeState
ide NormalizedFilePath
file Maybe OneHint
forall a. Maybe a
Nothing
    String -> LspT Config IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> LspT Config IO ()) -> String -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyAllCmd:res=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either String WorkspaceEdit -> String
forall a. Show a => a -> String
show Either String WorkspaceEdit
res
    case Either String WorkspaceEdit
res of
      Left String
err -> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (Text -> ResponseError
responseError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyAll: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
err))
      Right WorkspaceEdit
fs -> do
        LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
fs) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null

-- ---------------------------------------------------------------------

data ApplyOneParams = AOP
  { ApplyOneParams -> Uri
file      :: Uri
  , ApplyOneParams -> Position
start_pos :: Position
  -- | 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 IdeState
ide (AOP Uri
uri Position
pos Text
title) = do
  let oneHint :: OneHint
oneHint = Position -> Text -> OneHint
OneHint Position
pos Text
title
  let file :: NormalizedFilePath
file = NormalizedFilePath
-> (String -> NormalizedFilePath)
-> Maybe String
-> NormalizedFilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NormalizedFilePath
forall a. HasCallStack => String -> a
error (String -> NormalizedFilePath) -> String -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> String
forall a. Show a => a -> String
show Uri
uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a file.") String -> NormalizedFilePath
toNormalizedFilePath'
                   (Uri -> Maybe String
uriToFilePath' Uri
uri)
  let progTitle :: Text
progTitle = Text
"Applying hint: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
title
  Text
-> ProgressCancellable
-> LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
progTitle ProgressCancellable
Cancellable (LspM Config (Either ResponseError Value)
 -> LspM Config (Either ResponseError Value))
-> LspM Config (Either ResponseError Value)
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ do
    String -> LspT Config IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> LspT Config IO ()) -> String -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyOneCmd:file=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
file
    Either String WorkspaceEdit
res <- IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String WorkspaceEdit)
 -> LspT Config IO (Either String WorkspaceEdit))
-> IO (Either String WorkspaceEdit)
-> LspT Config IO (Either String WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint IdeState
ide NormalizedFilePath
file (OneHint -> Maybe OneHint
forall a. a -> Maybe a
Just OneHint
oneHint)
    String -> LspT Config IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> LspT Config IO ()) -> String -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyOneCmd:res=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either String WorkspaceEdit -> String
forall a. Show a => a -> String
show Either String WorkspaceEdit
res
    case Either String WorkspaceEdit
res of
      Left String
err -> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (Text -> ResponseError
responseError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyOne: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
err))
      Right WorkspaceEdit
fs -> do
        LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
fs) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null

applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)
applyHint :: IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint IdeState
ide NormalizedFilePath
nfp Maybe OneHint
mhint =
  ExceptT String IO WorkspaceEdit -> IO (Either String WorkspaceEdit)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO WorkspaceEdit
 -> IO (Either String WorkspaceEdit))
-> ExceptT String IO WorkspaceEdit
-> IO (Either String WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ do
    let runAction' :: Action a -> IO a
        runAction' :: Action a -> IO a
runAction' = String -> IdeState -> Action a -> IO a
forall a. String -> IdeState -> Action a -> IO a
runAction String
"applyHint" IdeState
ide
    let errorHandlers :: [Handler (Either String b)]
errorHandlers = [ (IOException -> IO (Either String b)) -> Handler (Either String b)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO (Either String b))
 -> Handler (Either String b))
-> (IOException -> IO (Either String b))
-> Handler (Either String b)
forall a b. (a -> b) -> a -> b
$ \IOException
e -> Either String b -> IO (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String b
forall a b. a -> Either a b
Left (IOException -> String
forall a. Show a => a -> String
show (IOException
e :: IOException)))
                        , (ErrorCall -> IO (Either String b)) -> Handler (Either String b)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ErrorCall -> IO (Either String b)) -> Handler (Either String b))
-> (ErrorCall -> IO (Either String b)) -> Handler (Either String b)
forall a b. (a -> b) -> a -> b
$ \ErrorCall
e -> Either String b -> IO (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String b
forall a b. a -> Either a b
Left (ErrorCall -> String
forall a. Show a => a -> String
show (ErrorCall
e :: ErrorCall)))
                        ]
    [Idea]
ideas <- (ParseError -> String)
-> ([Idea] -> [Idea])
-> ExceptT ParseError IO [Idea]
-> ExceptT String IO [Idea]
forall (m :: * -> *) e f a b.
Functor m =>
(e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT ParseError -> String
showParseError [Idea] -> [Idea]
forall a. a -> a
id (ExceptT ParseError IO [Idea] -> ExceptT String IO [Idea])
-> ExceptT ParseError IO [Idea] -> ExceptT String IO [Idea]
forall a b. (a -> b) -> a -> b
$ IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea]
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea])
-> IO (Either ParseError [Idea]) -> ExceptT ParseError IO [Idea]
forall a b. (a -> b) -> a -> b
$ Action (Either ParseError [Idea]) -> IO (Either ParseError [Idea])
forall a. Action a -> IO a
runAction' (Action (Either ParseError [Idea])
 -> IO (Either ParseError [Idea]))
-> Action (Either ParseError [Idea])
-> IO (Either ParseError [Idea])
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas NormalizedFilePath
nfp
    let ideas' :: [Idea]
ideas' = [Idea] -> (OneHint -> [Idea]) -> Maybe OneHint -> [Idea]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Idea]
ideas (OneHint -> [Idea] -> [Idea]
`filterIdeas` [Idea]
ideas) Maybe OneHint
mhint
    let commands :: [[Refactoring SrcSpan]]
commands = (Idea -> [Refactoring SrcSpan])
-> [Idea] -> [[Refactoring SrcSpan]]
forall a b. (a -> b) -> [a] -> [b]
map Idea -> [Refactoring SrcSpan]
ideaRefactoring [Idea]
ideas'
    IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"applyHint:apply=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Refactoring SrcSpan]] -> String
forall a. Show a => a -> String
show [[Refactoring SrcSpan]]
commands
    let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
    (UTCTime
_, Maybe Text
mbOldContent) <- IO (UTCTime, Maybe Text) -> ExceptT String IO (UTCTime, Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Maybe Text)
 -> ExceptT String IO (UTCTime, Maybe Text))
-> IO (UTCTime, Maybe Text)
-> ExceptT String IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a. Action a -> IO a
runAction' (Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text))
-> Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
    Text
oldContent <- ExceptT String IO Text
-> (Text -> ExceptT String IO Text)
-> Maybe Text
-> ExceptT String IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO Text -> ExceptT String IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT String IO Text)
-> IO Text -> ExceptT String IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
fp) Text -> ExceptT String IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mbOldContent
    ModSummaryResult
modsum <- IO ModSummaryResult -> ExceptT String IO ModSummaryResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummaryResult -> ExceptT String IO ModSummaryResult)
-> IO ModSummaryResult -> ExceptT String IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ Action ModSummaryResult -> IO ModSummaryResult
forall a. Action a -> IO a
runAction' (Action ModSummaryResult -> IO ModSummaryResult)
-> Action ModSummaryResult -> IO ModSummaryResult
forall a b. (a -> b) -> a -> b
$ GetModSummary -> NormalizedFilePath -> Action ModSummaryResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
    let dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags) -> ModSummary -> DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum
    -- Setting a environment variable with the libdir used by ghc-exactprint.
    -- It is a workaround for an error caused by the use of a hadcoded at compile time libdir
    -- in ghc-exactprint that makes dependent executables non portables.
    -- See https://github.com/alanz/ghc-exactprint/issues/96.
    -- WARNING: this code is not thread safe, so if you try to apply several async refactorings
    -- it could fail. That case is not very likely so we assume the risk.
    let withRuntimeLibdir :: IO a -> IO a
        withRuntimeLibdir :: IO a -> IO a
withRuntimeLibdir = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (String -> String -> IO ()
setEnv String
key (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> String
topDir DynFlags
dflags) (String -> IO ()
unsetEnv String
key)
            where key :: String
key = String
"GHC_EXACTPRINT_GHC_LIBDIR"
    -- set Nothing as "position" for "applyRefactorings" because
    -- applyRefactorings expects the provided position to be _within_ the scope
    -- of each refactoring it will apply.
    -- But "Idea"s returned by HLint point to starting position of the expressions
    -- that contain refactorings, so they are often outside the refactorings' boundaries.
    let position :: Maybe a
position = Maybe a
forall a. Maybe a
Nothing
#ifdef HLINT_ON_GHC_LIB
    let writeFileUTF8NoNewLineTranslation :: String -> Text -> IO ()
writeFileUTF8NoNewLineTranslation String
file Text
txt =
            String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
file IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
                Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
                Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
noNewlineTranslation
                Handle -> String -> IO ()
hPutStr Handle
h (Text -> String
T.unpack Text
txt)
    Either String String
res <-
        IO (Either String String)
-> ExceptT String IO (Either String String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String String)
 -> ExceptT String IO (Either String String))
-> IO (Either String String)
-> ExceptT String IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
-> (String -> Handle -> IO (Either String String))
-> IO (Either String String)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (ShowS
takeFileName String
fp) ((String -> Handle -> IO (Either String String))
 -> IO (Either String String))
-> (String -> Handle -> IO (Either String String))
-> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ \String
temp Handle
h -> do
            Handle -> IO ()
hClose Handle
h
            String -> Text -> IO ()
writeFileUTF8NoNewLineTranslation String
temp Text
oldContent
            (ParseFlags
pflags, [Classify]
_, Hint
_) <- Action (ParseFlags, [Classify], Hint)
-> IO (ParseFlags, [Classify], Hint)
forall a. Action a -> IO a
runAction' (Action (ParseFlags, [Classify], Hint)
 -> IO (ParseFlags, [Classify], Hint))
-> Action (ParseFlags, [Classify], Hint)
-> IO (ParseFlags, [Classify], Hint)
forall a b. (a -> b) -> a -> b
$ GetHlintSettings -> Action (ParseFlags, [Classify], Hint)
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetHlintSettings
GetHlintSettings
            [Extension]
exts <- Action [Extension] -> IO [Extension]
forall a. Action a -> IO a
runAction' (Action [Extension] -> IO [Extension])
-> Action [Extension] -> IO [Extension]
forall a b. (a -> b) -> a -> b
$ ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions ParseFlags
pflags NormalizedFilePath
nfp
            -- We have to reparse extensions to remove the invalid ones
            let ([Extension]
enabled, [Extension]
disabled, [String]
_invalid) = [String] -> ([Extension], [Extension], [String])
parseExtensions ([String] -> ([Extension], [Extension], [String]))
-> [String] -> ([Extension], [Extension], [String])
forall a b. (a -> b) -> a -> b
$ (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show [Extension]
exts
            let refactExts :: [String]
refactExts = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show ([Extension] -> [String]) -> [Extension] -> [String]
forall a b. (a -> b) -> a -> b
$ [Extension]
enabled [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
disabled
            (String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> IO String -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> IO String
forall a. IO a -> IO a
withRuntimeLibdir (Maybe (Int, Int)
-> [[Refactoring SrcSpan]] -> String -> [String] -> IO String
applyRefactorings Maybe (Int, Int)
forall a. Maybe a
position [[Refactoring SrcSpan]]
commands String
temp [String]
refactExts))
                IO (Either String String)
-> [Handler (Either String String)] -> IO (Either String String)
forall a. IO a -> [Handler a] -> IO a
`catches` [Handler (Either String String)]
forall b. [Handler (Either String b)]
errorHandlers
#else
    mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
    res <-
        case mbParsedModule of
            Nothing -> throwE "Apply hint: error parsing the module"
            Just pm -> do
                let anns = pm_annotations pm
                let modu = pm_parsed_source pm
                -- apply-refact uses RigidLayout
                let rigidLayout = deltaOptions RigidLayout
                (anns', modu') <-
                    ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
                liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu'))
                            `catches` errorHandlers
#endif
    case Either String String
res of
      Right String
appliedFile -> do
        let uri :: Uri
uri = NormalizedUri -> Uri
fromNormalizedUri (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
nfp)
        let wsEdit :: WorkspaceEdit
wsEdit = Bool -> (Uri, Text) -> Text -> WithDeletions -> WorkspaceEdit
diffText' Bool
True (Uri
uri, Text
oldContent) (String -> Text
T.pack String
appliedFile) WithDeletions
IncludeDeletions
        IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"hlint:applyHint:diff=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceEdit -> String
forall a. Show a => a -> String
show WorkspaceEdit
wsEdit
        IO (Either String WorkspaceEdit) -> ExceptT String IO WorkspaceEdit
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String WorkspaceEdit)
 -> ExceptT String IO WorkspaceEdit)
-> IO (Either String WorkspaceEdit)
-> ExceptT String IO WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ Either String WorkspaceEdit -> IO (Either String WorkspaceEdit)
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceEdit -> Either String WorkspaceEdit
forall a b. b -> Either a b
Right WorkspaceEdit
wsEdit)
      Left String
err ->
        String -> ExceptT String IO WorkspaceEdit
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
err
    where
          -- | 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 (OldRealSrcSpan RealSrcSpan
real) = RealSrcSpan
real
          toRealSrcSpan (UnhelpfulSpan UnhelpfulSpanReason
x) = String -> RealSrcSpan
forall a. HasCallStack => String -> a
error (String -> RealSrcSpan) -> String -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ String
"No real source span: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnhelpfulSpanReason -> String
forall a. Show a => a -> String
show UnhelpfulSpanReason
x

          showParseError :: Hlint.ParseError -> String
          showParseError :: ParseError -> String
showParseError (Hlint.ParseError SrcSpan
location String
message String
content) =
            [String] -> String
unlines [SrcSpan -> String
forall a. Show a => a -> String
show SrcSpan
location, String
message, String
content]

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