{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports    #-}
{-# LANGUAGE TypeFamilies      #-}

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 (getParsedModuleWithComments, defineNoFile)
import Development.IDE.Core.Shake (getDiagnostics)

#ifdef HLINT_ON_GHC_LIB
import Data.List (nub)
import "ghc-lib" GHC hiding (DynFlags(..), ms_hspp_opts)
import "ghc-lib-parser" GHC.LanguageExtensions (Extension)
import "ghc" DynFlags as RealGHC.DynFlags (topDir)
import "ghc" GHC as RealGHC (DynFlags(..))
import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags, ms_hspp_opts)
import qualified "ghc" EnumSet as EnumSet
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
import System.Environment(setEnv, unsetEnv)
import System.FilePath (takeFileName)
import System.IO (hPutStr, noNewlineTranslation, hSetNewlineMode, utf8, hSetEncoding, IOMode(WriteMode), withFile, hClose)
import System.IO.Temp
#else
import Development.IDE.GHC.Compat hiding (DynFlags(..))
import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions)
import Language.Haskell.GHC.ExactPrint.Types (Rigidity(..))
#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
    ( LspFuncs(withIndefiniteProgress),
      ProgressCancellable(Cancellable) )
import Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Types      as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP

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))
#ifndef HLINT_ON_GHC_LIB
        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
#else
        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
          hlintExts <- getExtensions flags nfp
          logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts
          return $ flags { enabledExtensions = hlintExts }

getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension]
getExtensions pflags nfp = do
    dflags <- getFlags
    let hscExts = EnumSet.toList (extensionFlags dflags)
    let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts
    let hlintExts = nub $ enabledExtensions pflags ++ hscExts'
    return hlintExts
  where getFlags :: Action DynFlags
        getFlags = do
          (modsum, _) <- use_ GetModSummary nfp
          return $ ms_hspp_opts modsum
#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
    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
    (ModSummary
modsum, [LImportDecl GhcPs]
_) <- IO (ModSummary, [LImportDecl GhcPs])
-> ExceptT String IO (ModSummary, [LImportDecl GhcPs])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModSummary, [LImportDecl GhcPs])
 -> ExceptT String IO (ModSummary, [LImportDecl GhcPs]))
-> IO (ModSummary, [LImportDecl GhcPs])
-> ExceptT String IO (ModSummary, [LImportDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ Action (ModSummary, [LImportDecl GhcPs])
-> IO (ModSummary, [LImportDecl GhcPs])
forall a. Action a -> IO a
runAction' (Action (ModSummary, [LImportDecl GhcPs])
 -> IO (ModSummary, [LImportDecl GhcPs]))
-> Action (ModSummary, [LImportDecl GhcPs])
-> IO (ModSummary, [LImportDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ GetModSummary
-> NormalizedFilePath -> Action (ModSummary, [LImportDecl GhcPs])
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
modsum
    -- 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).

#ifdef HLINT_ON_GHC_LIB
    let writeFileUTF8NoNewLineTranslation file txt =
            withFile file WriteMode $ \h -> do
                hSetEncoding h utf8
                hSetNewlineMode h noNewlineTranslation
                hPutStr h (T.unpack txt)
    -- 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 = bracket_ (setEnv key $ topDir dflags) (unsetEnv key)
            where key = "GHC_EXACTPRINT_GHC_LIBDIR"
    res <-
        liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do
            hClose h
            writeFileUTF8NoNewLineTranslation temp oldContent
            (pflags, _, _) <- runAction' $ useNoFile_ GetHlintSettings
            exts <- runAction' $ getExtensions pflags nfp
            -- We have to reparse extensions to remove the invalid ones

            let (enabled, disabled, _invalid) = parseExtensions $ map show exts
            let refactExts = map show $ enabled ++ disabled
            (Right <$> withRuntimeLibdir (applyRefactorings Nothing commands temp refactExts))
                `catches` errorHandlers
#else
    Maybe ParsedModule
mbParsedModule <- IO (Maybe ParsedModule) -> ExceptT String IO (Maybe ParsedModule)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ParsedModule) -> ExceptT String IO (Maybe ParsedModule))
-> IO (Maybe ParsedModule)
-> ExceptT String IO (Maybe ParsedModule)
forall a b. (a -> b) -> a -> b
$ Action (Maybe ParsedModule) -> IO (Maybe ParsedModule)
forall a. Action a -> IO a
runAction' (Action (Maybe ParsedModule) -> IO (Maybe ParsedModule))
-> Action (Maybe ParsedModule) -> IO (Maybe ParsedModule)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModuleWithComments NormalizedFilePath
nfp
    Either String String
res <-
        case Maybe ParsedModule
mbParsedModule of
            Maybe ParsedModule
Nothing -> String -> ExceptT String IO (Either String String)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Apply hint: error parsing the module"
            Just ParsedModule
pm -> do
                let anns :: ApiAnns
anns = ParsedModule -> ApiAnns
pm_annotations ParsedModule
pm
                let modu :: Located (HsModule GhcPs)
modu = ParsedModule -> Located (HsModule GhcPs)
pm_parsed_source ParsedModule
pm
                -- apply-refact uses RigidLayout

                let rigidLayout :: DeltaOptions
rigidLayout = Rigidity -> DeltaOptions
deltaOptions Rigidity
RigidLayout
                (Anns
anns', Located (HsModule GhcPs)
modu') <-
                    IO (Either String (Anns, Located (HsModule GhcPs)))
-> ExceptT String IO (Anns, Located (HsModule GhcPs))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String (Anns, Located (HsModule GhcPs)))
 -> ExceptT String IO (Anns, Located (HsModule GhcPs)))
-> IO (Either String (Anns, Located (HsModule GhcPs)))
-> ExceptT String IO (Anns, Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$ Either String (Anns, Located (HsModule GhcPs))
-> IO (Either String (Anns, Located (HsModule GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Anns, Located (HsModule GhcPs))
 -> IO (Either String (Anns, Located (HsModule GhcPs))))
-> Either String (Anns, Located (HsModule GhcPs))
-> IO (Either String (Anns, Located (HsModule GhcPs)))
forall a b. (a -> b) -> a -> b
$ Either
  String (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions -> Either String (Anns, Located (HsModule GhcPs))
forall a.
Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions -> Either a (Anns, Located (HsModule GhcPs))
postParseTransform ((ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either
     String (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. b -> Either a b
Right (ApiAnns
anns, [], DynFlags
dflags, Located (HsModule GhcPs)
modu)) DeltaOptions
rigidLayout
                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 -> 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)
-> [[Refactoring SrcSpan]]
-> Anns
-> Located (HsModule GhcPs)
-> IO String
applyRefactorings' Maybe (Int, Int)
forall a. Maybe a
Nothing [[Refactoring SrcSpan]]
commands Anns
anns' Located (HsModule GhcPs)
modu')
                            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
#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 (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 #-}