{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
#ifdef HLINT_ON_GHC_LIB
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z)
#else
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)
#endif
module Ide.Plugin.Hlint
(
descriptor
, Log(..)
) where
import Control.Arrow ((&&&))
import Control.Concurrent.STM
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 qualified Data.ByteString as BS
import Data.Hashable
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable
import Development.IDE hiding
(Error,
getExtensions)
import Development.IDE.Core.Rules (defineNoFile,
getParsedModuleWithComments)
import Development.IDE.Core.Shake (getDiagnostics)
import qualified Refact.Apply as Refact
import qualified Refact.Types as Refact
#ifdef HLINT_ON_GHC_LIB
import Development.IDE.GHC.Compat (DynFlags,
WarningFlag (Opt_WarnUnrecognisedPragmas),
extensionFlags,
ms_hspp_opts,
topDir,
wopt)
import qualified Development.IDE.GHC.Compat.Util as EnumSet
#if MIN_GHC_API_VERSION(9,4,0)
import qualified "ghc-lib-parser" GHC.Data.Strict as Strict
#endif
#if MIN_GHC_API_VERSION(9,0,0)
import "ghc-lib-parser" GHC.Types.SrcLoc hiding
(RealSrcSpan)
import qualified "ghc-lib-parser" GHC.Types.SrcLoc as GHC
#else
import "ghc-lib-parser" SrcLoc hiding
(RealSrcSpan)
import qualified "ghc-lib-parser" SrcLoc as GHC
#endif
import "ghc-lib-parser" GHC.LanguageExtensions (Extension)
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
(setEnv,
(<+>))
import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative))
#if MIN_GHC_API_VERSION(9,2,0)
import Language.Haskell.GHC.ExactPrint.ExactPrint (deltaOptions)
#else
import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions)
#endif
import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..))
import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities)
import qualified Refact.Fixity as Refact
#endif
import Ide.Plugin.Config hiding
(Config)
import Ide.Plugin.Properties
import Ide.PluginUtils
import Ide.Types hiding
(Config)
import Language.Haskell.HLint as Hlint hiding
(Error)
import Language.LSP.Server (ProgressCancellable (Cancellable),
sendRequest,
withIndefiniteProgress)
import Language.LSP.Types hiding
(SemanticTokenAbsolute (length, line),
SemanticTokenRelative (length),
SemanticTokensEdit (_start))
import qualified Language.LSP.Types as LSP
import qualified Language.LSP.Types.Lens as LSP
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits),
NextPragmaInfo (NextPragmaInfo),
getNextPragmaInfo,
lineSplitDeleteTextEdit,
lineSplitInsertTextEdit,
lineSplitTextEdits,
nextPragmaLine)
import GHC.Generics (Generic)
import System.Environment (setEnv,
unsetEnv)
import Text.Regex.TDFA.Text ()
data Log
= LogShake Shake.Log
| LogApplying NormalizedFilePath (Either String WorkspaceEdit)
| LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]]
| LogGetIdeas NormalizedFilePath
| LogUsingExtensions NormalizedFilePath [String]
deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
LogShake Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log
LogApplying NormalizedFilePath
fp Either String WorkspaceEdit
res -> Doc ann
"Applying hint(s) for" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
fp forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Either String WorkspaceEdit
res
LogGeneratedIdeas NormalizedFilePath
fp [[Refactoring SrcSpan]]
ideas -> Doc ann
"Generated hlint ideas for for" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
fp forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow [[Refactoring SrcSpan]]
ideas
LogUsingExtensions NormalizedFilePath
fp [String]
exts -> Doc ann
"Using extensions for " forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
fp forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [String]
exts
LogGetIdeas NormalizedFilePath
fp -> Doc ann
"Getting hlint ideas for " forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow NormalizedFilePath
fp
#ifdef HLINT_ON_GHC_LIB
#if !MIN_GHC_API_VERSION(9,0,0)
type BufSpan = ()
#endif
pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan
#if MIN_GHC_API_VERSION(9,4,0)
pattern $mRealSrcSpan :: forall {r}.
SrcSpan -> (RealSrcSpan -> Maybe BufSpan -> r) -> ((# #) -> r) -> r
RealSrcSpan x y <- GHC.RealSrcSpan x (fromStrictMaybe -> y)
#elif MIN_GHC_API_VERSION(9,0,0)
pattern RealSrcSpan x y = GHC.RealSrcSpan x y
#else
pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))
#endif
{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
#endif
#if MIN_GHC_API_VERSION(9,4,0)
fromStrictMaybe :: Strict.Maybe a -> Maybe a
fromStrictMaybe :: forall a. Maybe a -> Maybe a
fromStrictMaybe (Strict.Just a
a ) = forall a. a -> Maybe a
Just a
a
fromStrictMaybe Maybe a
Strict.Nothing = forall a. Maybe a
Nothing
#endif
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> PluginId -> Rules ()
rules Recorder (WithPriority Log)
recorder PluginId
plId
, pluginCommands :: [PluginCommand IdeState]
pluginCommands =
[ forall ideState a.
FromJSON a =>
CommandId
-> HintTitle
-> CommandFunction ideState a
-> PluginCommand ideState
PluginCommand CommandId
"applyOne" HintTitle
"Apply a single hint" (Recorder (WithPriority Log)
-> CommandFunction IdeState ApplyOneParams
applyOneCmd Recorder (WithPriority Log)
recorder)
, forall ideState a.
FromJSON a =>
CommandId
-> HintTitle
-> CommandFunction ideState a
-> PluginCommand ideState
PluginCommand CommandId
"applyAll" HintTitle
"Apply all hints to the file" (Recorder (WithPriority Log) -> CommandFunction IdeState Uri
applyAllCmd Recorder (WithPriority Log)
recorder)
]
, pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider
, pluginConfigDescriptor :: ConfigDescriptor
pluginConfigDescriptor = ConfigDescriptor
defaultConfigDescriptor
{ configHasDiagnostics :: Bool
configHasDiagnostics = Bool
True
, configCustomConfig :: CustomConfig
configCustomConfig = forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig Properties '[ 'PropertyKey "flags" ('TArray String)]
properties
}
}
data GetHlintDiagnostics = GetHlintDiagnostics
deriving (GetHlintDiagnostics -> GetHlintDiagnostics -> Bool
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
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. 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
type instance RuleResult GetHlintDiagnostics = ()
rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
rules Recorder (WithPriority Log)
recorder PluginId
plugin = do
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetHlintDiagnostics
GetHlintDiagnostics NormalizedFilePath
file -> do
PluginConfig
config <- PluginId -> Action PluginConfig
getPluginConfigAction PluginId
plugin
let hlintOn :: Bool
hlintOn = (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcDiagnosticsOn PluginConfig
config
Either ParseError [Idea]
ideas <- if Bool
hlintOn then Recorder (WithPriority Log)
-> NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas Recorder (WithPriority Log)
recorder NormalizedFilePath
file else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right [])
forall (m :: * -> *) a. Monad m => a -> m a
return (NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic]
diagnostics NormalizedFilePath
file Either ParseError [Idea]
ideas, forall a. a -> Maybe a
Just ())
forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
defineNoFile (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetHlintSettings
GetHlintSettings -> do
(Config [String]
flags) <- PluginId -> Action Config
getHlintConfig PluginId
plugin
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [String] -> IO (ParseFlags, [Classify], Hint)
argsSettings [String]
flags
forall a. Action a -> Rules ()
action forall a b. (a -> b) -> a -> b
$ do
HashMap NormalizedFilePath FileOfInterestStatus
files <- Action (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterestUntracked
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetHlintDiagnostics
GetHlintDiagnostics forall a b. (a -> b) -> a -> b
$ 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 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 =
LSP.Diagnostic {
$sel:_range:Diagnostic :: Range
_range = SrcSpan -> Range
srcSpanToRange forall a b. (a -> b) -> a -> b
$ Idea -> SrcSpan
ideaSpan Idea
idea
, $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DsInfo
, $sel:_code:Diagnostic :: Maybe (Int32 |? HintTitle)
_code = forall a. a -> Maybe a
Just (forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ String
codePre forall a. [a] -> [a] -> [a]
++ Idea -> String
ideaHint Idea
idea)
, $sel:_source:Diagnostic :: Maybe HintTitle
_source = forall a. a -> Maybe a
Just HintTitle
"hlint"
, $sel:_message:Diagnostic :: HintTitle
_message = Idea -> HintTitle
idea2Message Idea
idea
, $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = forall a. Maybe a
Nothing
, $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags = forall a. Maybe a
Nothing
}
where codePre :: String
codePre = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Idea -> [Refactoring SrcSpan]
ideaRefactoring Idea
idea then String
"" else String
"refact:"
idea2Message :: Idea -> T.Text
idea2Message :: Idea -> HintTitle
idea2Message Idea
idea = [HintTitle] -> HintTitle
T.unlines forall a b. (a -> b) -> a -> b
$ [String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ Idea -> String
ideaHint Idea
idea, HintTitle
"Found:", HintTitle
" " forall a. Semigroup a => a -> a -> a
<> String -> HintTitle
T.pack (Idea -> String
ideaFrom Idea
idea)]
forall a. Semigroup a => a -> a -> a
<> [HintTitle]
toIdea forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (String -> HintTitle
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (Idea -> [Note]
ideaNote Idea
idea)
where
toIdea :: [T.Text]
toIdea :: [HintTitle]
toIdea = case Idea -> Maybe String
ideaTo Idea
idea of
Maybe String
Nothing -> []
Just String
i -> [String -> HintTitle
T.pack String
"Why not:", String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ String
" " forall a. [a] -> [a] -> [a]
++ String
i]
parseErrorToDiagnostic :: ParseError -> Diagnostic
parseErrorToDiagnostic :: ParseError -> Diagnostic
parseErrorToDiagnostic (Hlint.ParseError SrcSpan
l String
msg String
contents) =
LSP.Diagnostic {
$sel:_range:Diagnostic :: Range
_range = SrcSpan -> Range
srcSpanToRange SrcSpan
l
, $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DsInfo
, $sel:_code:Diagnostic :: Maybe (Int32 |? HintTitle)
_code = forall a. a -> Maybe a
Just (forall a b. b -> a |? b
InR HintTitle
"parser")
, $sel:_source:Diagnostic :: Maybe HintTitle
_source = forall a. a -> Maybe a
Just HintTitle
"hlint"
, $sel:_message:Diagnostic :: HintTitle
_message = [HintTitle] -> HintTitle
T.unlines [String -> HintTitle
T.pack String
msg,String -> HintTitle
T.pack String
contents]
, $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = forall a. Maybe a
Nothing
, $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags = forall a. Maybe a
Nothing
}
srcSpanToRange :: SrcSpan -> LSP.Range
srcSpanToRange :: SrcSpan -> Range
srcSpanToRange (RealSrcSpan RealSrcSpan
span Maybe BufSpan
_) = Range {
_start :: Position
_start = LSP.Position {
_line :: UInt
_line = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1
, _character :: UInt
_character = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1}
, _end :: Position
_end = LSP.Position {
_line :: UInt
_line = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1
, _character :: UInt
_character = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1}
}
srcSpanToRange (UnhelpfulSpan UnhelpfulSpanReason
_) = Range
noRange
getIdeas :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas :: Recorder (WithPriority Log)
-> NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas Recorder (WithPriority Log)
recorder NormalizedFilePath
nfp = do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogGetIdeas NormalizedFilePath
nfp
(ParseFlags
flags, [Classify]
classify, Hint
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)) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints [Classify]
classify Hint
hint [ModuleEx
modEx]
applyHints' (Just (Left ParseError
err)) = forall a b. a -> Either a b
Left ParseError
err
applyHints' Maybe (Either ParseError ModuleEx)
Nothing = forall a b. b -> Either a b
Right []
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 <- getParsedModuleWithComments nfp
return $ createModule <$> mbpm
where
createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu))
where anns = pm_annotations pm
modu = pm_parsed_source pm
applyParseFlagsFixities :: ParsedSource -> ParsedSource
applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul
parseFlagsToFixities :: ParseFlags -> [(String, Fixity)]
parseFlagsToFixities = map toFixity . Hlint.fixities
toFixity :: FixityInfo -> (String, Fixity)
toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
where
f LeftAssociative = InfixL
f RightAssociative = InfixR
f NotAssociative = InfixN
#else
moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
moduleEx ParseFlags
flags = do
Maybe ParsedModule
mbpm <- NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModuleWithComments NormalizedFilePath
nfp
if forall a. Maybe a -> Bool
isNothing Maybe ParsedModule
mbpm
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
ParseFlags
flags' <- ParseFlags -> Action ParseFlags
setExtensions ParseFlags
flags
(UTCTime
_, Maybe HintTitle
contents) <- NormalizedFilePath -> Action (UTCTime, Maybe HintTitle)
getFileContents NormalizedFilePath
nfp
let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
let contents' :: Maybe String
contents' = HintTitle -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HintTitle
contents
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- NormalizedFilePath -> Action [Extension]
getExtensions NormalizedFilePath
nfp
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [String] -> Log
LogUsingExtensions NormalizedFilePath
nfp (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
show [Extension]
hlintExts)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParseFlags
flags { enabledExtensions :: [Extension]
enabledExtensions = [Extension]
hlintExts }
getExtensions :: NormalizedFilePath -> Action [Extension]
getExtensions :: NormalizedFilePath -> Action [Extension]
getExtensions NormalizedFilePath
nfp = do
DynFlags
dflags <- Action DynFlags
getFlags
let hscExts :: [Extension]
hscExts = forall a. Enum a => EnumSet a -> [a]
EnumSet.toList (DynFlags -> EnumSet Extension
extensionFlags DynFlags
dflags)
let hscExts' :: [Extension]
hscExts' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Extension
GhclibParserEx.readExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Extension]
hscExts
forall (m :: * -> *) a. Monad m => a -> m a
return [Extension]
hscExts'
where getFlags :: Action DynFlags
getFlags :: Action DynFlags
getFlags = do
ModSummaryResult
modsum <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum
#endif
data GetHlintSettings = GetHlintSettings
deriving (GetHlintSettings -> GetHlintSettings -> Bool
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
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. 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 = forall a. a -> ()
rwhnf
instance NFData Classify where rnf :: Classify -> ()
rnf = forall a. a -> ()
rwhnf
instance NFData ParseFlags where rnf :: ParseFlags -> ()
rnf = forall a. a -> ()
rwhnf
instance Show Hint where show :: Hint -> String
show = forall a b. a -> b -> a
const String
"<hint>"
instance Show ParseFlags where show :: ParseFlags -> String
show = forall a b. a -> b -> a
const String
"<parseFlags>"
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
forall a b. a -> (a -> b) -> b
& forall (s :: Symbol) (r :: [PropertyKey]) a.
(KnownSymbol s, NotElem s r, ToJSON a, FromJSON a) =>
KeyNameProxy s
-> HintTitle
-> [a]
-> Properties r
-> Properties ('PropertyKey s ('TArray a) : r)
defineArrayProperty forall a. IsLabel "flags" a => a
#flags
HintTitle
"Flags used by hlint" []
getHlintConfig :: PluginId -> Action Config
getHlintConfig :: PluginId -> Action Config
getHlintConfig PluginId
pId =
[String] -> Config
Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
(r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction forall a. IsLabel "flags" a => a
#flags PluginId
pId Properties '[ 'PropertyKey "flags" ('TArray String)]
properties
runHlintAction
:: (Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k, Typeable (RuleResult k), NFData k, NFData (RuleResult k))
=> IdeState
-> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction :: forall k.
(Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k,
Typeable (RuleResult k), NFData k, NFData (RuleResult k)) =>
IdeState
-> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction IdeState
ideState NormalizedFilePath
normalizedFilePath String
desc k
rule = forall a. String -> IdeState -> Action a -> IO a
runAction String
desc IdeState
ideState forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use k
rule NormalizedFilePath
normalizedFilePath
runGetFileContentsAction :: IdeState -> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe T.Text))
runGetFileContentsAction :: IdeState
-> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe HintTitle))
runGetFileContentsAction IdeState
ideState NormalizedFilePath
normalizedFilePath = forall k.
(Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k,
Typeable (RuleResult k), NFData k, NFData (RuleResult k)) =>
IdeState
-> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction IdeState
ideState NormalizedFilePath
normalizedFilePath String
"Hlint.GetFileContents" GetFileContents
GetFileContents
runGetModSummaryAction :: IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult)
runGetModSummaryAction :: IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult)
runGetModSummaryAction IdeState
ideState NormalizedFilePath
normalizedFilePath = forall k.
(Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k,
Typeable (RuleResult k), NFData k, NFData (RuleResult k)) =>
IdeState
-> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction IdeState
ideState NormalizedFilePath
normalizedFilePath String
"Hlint.GetModSummary" GetModSummary
GetModSummary
codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider IdeState
ideState PluginId
pluginId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
documentId Range
_ CodeActionContext
context)
| let TextDocumentIdentifier Uri
uri = TextDocumentIdentifier
documentId
, Just NormalizedFilePath
docNormalizedFilePath <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (Uri -> NormalizedUri
toNormalizedUri Uri
uri)
= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> List a
LSP.List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> a |? b
LSP.InR) forall a b. (a -> b) -> a -> b
$ do
[FileDiagnostic]
allDiagnostics <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ IdeState -> STM [FileDiagnostic]
getDiagnostics IdeState
ideState
let numHintsInDoc :: Int
numHintsInDoc = forall (t :: * -> *) a. Foldable t => t a -> Int
length
[Diagnostic
diagnostic | (NormalizedFilePath
diagnosticNormalizedFilePath, ShowDiagnostic
_, Diagnostic
diagnostic) <- [FileDiagnostic]
allDiagnostics
, Diagnostic -> Bool
validCommand Diagnostic
diagnostic
, NormalizedFilePath
diagnosticNormalizedFilePath forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
docNormalizedFilePath
]
let numHintsInContext :: Int
numHintsInContext = forall (t :: * -> *) a. Foldable t => t a -> Int
length
[Diagnostic
diagnostic | Diagnostic
diagnostic <- [Diagnostic]
diags
, Diagnostic -> Bool
validCommand Diagnostic
diagnostic
]
Maybe (FileVersion, Maybe HintTitle)
file <- IdeState
-> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe HintTitle))
runGetFileContentsAction IdeState
ideState NormalizedFilePath
docNormalizedFilePath
[CodeAction]
singleHintCodeActions <-
if | Just (FileVersion
_, Maybe HintTitle
source) <- Maybe (FileVersion, Maybe HintTitle)
file -> do
Maybe ModSummaryResult
modSummaryResult <- IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult)
runGetModSummaryAction IdeState
ideState NormalizedFilePath
docNormalizedFilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure if | Just ModSummaryResult
modSummaryResult <- Maybe ModSummaryResult
modSummaryResult
, Just HintTitle
source <- Maybe HintTitle
source
, let dynFlags :: DynFlags
dynFlags = ModSummary -> DynFlags
ms_hspp_opts forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modSummaryResult ->
[Diagnostic]
diags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynFlags
-> HintTitle
-> PluginId
-> TextDocumentIdentifier
-> Diagnostic
-> [CodeAction]
diagnosticToCodeActions DynFlags
dynFlags HintTitle
source PluginId
pluginId TextDocumentIdentifier
documentId
| Bool
otherwise -> []
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
if Int
numHintsInDoc forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Int
numHintsInContext forall a. Ord a => a -> a -> Bool
> Int
0 then do
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [CodeAction]
singleHintCodeActions forall a. [a] -> [a] -> [a]
++ [CodeAction
applyAllAction]
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeAction]
singleHintCodeActions
| Bool
otherwise
= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
LSP.List []
where
applyAllAction :: CodeAction
applyAllAction =
let args :: Maybe [Value]
args = forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON (TextDocumentIdentifier
documentId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
LSP.uri)]
cmd :: Command
cmd = PluginId -> CommandId -> HintTitle -> Maybe [Value] -> Command
mkLspCommand PluginId
pluginId CommandId
"applyAll" HintTitle
"Apply all hints" Maybe [Value]
args
in HintTitle
-> Maybe CodeActionKind
-> Maybe (List Diagnostic)
-> Maybe Bool
-> Maybe Reason
-> Maybe WorkspaceEdit
-> Maybe Command
-> Maybe Value
-> CodeAction
LSP.CodeAction HintTitle
"Apply all hints" (forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionQuickFix) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Command
cmd) forall a. Maybe a
Nothing
validCommand :: Diagnostic -> Bool
validCommand (LSP.Diagnostic Range
_ Maybe DiagnosticSeverity
_ (Just (InR HintTitle
code)) (Just HintTitle
"hlint") HintTitle
_ Maybe (List DiagnosticTag)
_ Maybe (List DiagnosticRelatedInformation)
_) =
HintTitle
"refact:" HintTitle -> HintTitle -> Bool
`T.isPrefixOf` HintTitle
code
validCommand Diagnostic
_ =
Bool
False
LSP.List [Diagnostic]
diags = CodeActionContext
context forall s a. s -> Getting a s a -> a
^. forall s a. HasDiagnostics s a => Lens' s a
LSP.diagnostics
diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> TextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]
diagnosticToCodeActions :: DynFlags
-> HintTitle
-> PluginId
-> TextDocumentIdentifier
-> Diagnostic
-> [CodeAction]
diagnosticToCodeActions DynFlags
dynFlags HintTitle
fileContents PluginId
pluginId TextDocumentIdentifier
documentId Diagnostic
diagnostic
| LSP.Diagnostic{ $sel:_source:Diagnostic :: Diagnostic -> Maybe HintTitle
_source = Just HintTitle
"hlint", $sel:_code:Diagnostic :: Diagnostic -> Maybe (Int32 |? HintTitle)
_code = Just (InR HintTitle
code), $sel:_range:Diagnostic :: Diagnostic -> Range
_range = LSP.Range Position
start Position
_ } <- Diagnostic
diagnostic
, let TextDocumentIdentifier Uri
uri = TextDocumentIdentifier
documentId
, let isHintApplicable :: Bool
isHintApplicable = HintTitle
"refact:" HintTitle -> HintTitle -> Bool
`T.isPrefixOf` HintTitle
code
, let hint :: HintTitle
hint = HintTitle -> HintTitle -> HintTitle -> HintTitle
T.replace HintTitle
"refact:" HintTitle
"" HintTitle
code
, let suppressHintTitle :: HintTitle
suppressHintTitle = HintTitle
"Ignore hint \"" forall a. Semigroup a => a -> a -> a
<> HintTitle
hint forall a. Semigroup a => a -> a -> a
<> HintTitle
"\" in this module"
, let suppressHintTextEdits :: [TextEdit]
suppressHintTextEdits = DynFlags -> HintTitle -> HintTitle -> [TextEdit]
mkSuppressHintTextEdits DynFlags
dynFlags HintTitle
fileContents HintTitle
hint
, let suppressHintWorkspaceEdit :: WorkspaceEdit
suppressHintWorkspaceEdit =
Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
LSP.WorkspaceEdit
(forall a. a -> Maybe a
Just (forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton Uri
uri (forall a. [a] -> List a
List [TextEdit]
suppressHintTextEdits)))
forall a. Maybe a
Nothing
forall a. Maybe a
Nothing
= forall a. [Maybe a] -> [a]
catMaybes
[ if | Bool
isHintApplicable
, let applyHintTitle :: HintTitle
applyHintTitle = HintTitle
"Apply hint \"" forall a. Semigroup a => a -> a -> a
<> HintTitle
hint forall a. Semigroup a => a -> a -> a
<> HintTitle
"\""
applyHintArguments :: [Value]
applyHintArguments = [forall a. ToJSON a => a -> Value
toJSON (Uri -> Position -> HintTitle -> ApplyOneParams
AOP (TextDocumentIdentifier
documentId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
LSP.uri) Position
start HintTitle
hint)]
applyHintCommand :: Command
applyHintCommand = PluginId -> CommandId -> HintTitle -> Maybe [Value] -> Command
mkLspCommand PluginId
pluginId CommandId
"applyOne" HintTitle
applyHintTitle (forall a. a -> Maybe a
Just [Value]
applyHintArguments) ->
forall a. a -> Maybe a
Just (HintTitle
-> Diagnostic
-> Maybe WorkspaceEdit
-> Maybe Command
-> Bool
-> CodeAction
mkCodeAction HintTitle
applyHintTitle Diagnostic
diagnostic forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Command
applyHintCommand) Bool
True)
| Bool
otherwise -> forall a. Maybe a
Nothing
, forall a. a -> Maybe a
Just (HintTitle
-> Diagnostic
-> Maybe WorkspaceEdit
-> Maybe Command
-> Bool
-> CodeAction
mkCodeAction HintTitle
suppressHintTitle Diagnostic
diagnostic (forall a. a -> Maybe a
Just WorkspaceEdit
suppressHintWorkspaceEdit) forall a. Maybe a
Nothing Bool
False)
]
| Bool
otherwise = []
mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe LSP.WorkspaceEdit -> Maybe LSP.Command -> Bool -> LSP.CodeAction
mkCodeAction :: HintTitle
-> Diagnostic
-> Maybe WorkspaceEdit
-> Maybe Command
-> Bool
-> CodeAction
mkCodeAction HintTitle
title Diagnostic
diagnostic Maybe WorkspaceEdit
workspaceEdit Maybe Command
command Bool
isPreferred =
LSP.CodeAction
{ $sel:_title:CodeAction :: HintTitle
_title = HintTitle
title
, $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just CodeActionKind
LSP.CodeActionQuickFix
, $sel:_diagnostics:CodeAction :: Maybe (List Diagnostic)
_diagnostics = forall a. a -> Maybe a
Just (forall a. [a] -> List a
LSP.List [Diagnostic
diagnostic])
, $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = forall a. a -> Maybe a
Just Bool
isPreferred
, $sel:_disabled:CodeAction :: Maybe Reason
_disabled = forall a. Maybe a
Nothing
, $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = Maybe WorkspaceEdit
workspaceEdit
, $sel:_command:CodeAction :: Maybe Command
_command = Maybe Command
command
, $sel:_xdata:CodeAction :: Maybe Value
_xdata = forall a. Maybe a
Nothing
}
mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit]
mkSuppressHintTextEdits :: DynFlags -> HintTitle -> HintTitle -> [TextEdit]
mkSuppressHintTextEdits DynFlags
dynFlags HintTitle
fileContents HintTitle
hint =
let
NextPragmaInfo{ Int
nextPragmaLine :: Int
$sel:nextPragmaLine:NextPragmaInfo :: NextPragmaInfo -> Int
nextPragmaLine, Maybe LineSplitTextEdits
lineSplitTextEdits :: Maybe LineSplitTextEdits
$sel:lineSplitTextEdits:NextPragmaInfo :: NextPragmaInfo -> Maybe LineSplitTextEdits
lineSplitTextEdits } = DynFlags -> Maybe HintTitle -> NextPragmaInfo
getNextPragmaInfo DynFlags
dynFlags (forall a. a -> Maybe a
Just HintTitle
fileContents)
nextPragmaLinePosition :: Position
nextPragmaLinePosition = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nextPragmaLine) UInt
0
nextPragmaRange :: Range
nextPragmaRange = Position -> Position -> Range
Range Position
nextPragmaLinePosition Position
nextPragmaLinePosition
wnoUnrecognisedPragmasText :: Maybe HintTitle
wnoUnrecognisedPragmasText =
if WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnrecognisedPragmas DynFlags
dynFlags
then forall a. a -> Maybe a
Just HintTitle
"{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n"
else forall a. Maybe a
Nothing
hlintIgnoreText :: Maybe HintTitle
hlintIgnoreText = forall a. a -> Maybe a
Just (HintTitle
"{-# HLINT ignore \"" forall a. Semigroup a => a -> a -> a
<> HintTitle
hint forall a. Semigroup a => a -> a -> a
<> HintTitle
"\" #-}\n")
combinedText :: HintTitle
combinedText = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe HintTitle
wnoUnrecognisedPragmasText, Maybe HintTitle
hlintIgnoreText]
combinedTextEdit :: TextEdit
combinedTextEdit = Range -> HintTitle -> TextEdit
LSP.TextEdit Range
nextPragmaRange HintTitle
combinedText
lineSplitTextEditList :: [TextEdit]
lineSplitTextEditList = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\LineSplitTextEdits{TextEdit
lineSplitDeleteTextEdit :: TextEdit
lineSplitInsertTextEdit :: TextEdit
$sel:lineSplitInsertTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
$sel:lineSplitDeleteTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
..} -> [TextEdit
lineSplitInsertTextEdit, TextEdit
lineSplitDeleteTextEdit]) Maybe LineSplitTextEdits
lineSplitTextEdits
in
TextEdit
combinedTextEdit forall a. a -> [a] -> [a]
: [TextEdit]
lineSplitTextEditList
applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
applyAllCmd Recorder (WithPriority Log)
recorder IdeState
ide Uri
uri = do
let file :: NormalizedFilePath
file = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Uri
uri forall a. [a] -> [a] -> [a]
++ String
" is not a file.")
String -> NormalizedFilePath
toNormalizedFilePath'
(Uri -> Maybe String
uriToFilePath' Uri
uri)
forall c (m :: * -> *) a.
MonadLsp c m =>
HintTitle -> ProgressCancellable -> m a -> m a
withIndefiniteProgress HintTitle
"Applying all hints" ProgressCancellable
Cancellable forall a b. (a -> b) -> a -> b
$ do
Either String WorkspaceEdit
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file forall a. Maybe a
Nothing
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Either String WorkspaceEdit -> Log
LogApplying NormalizedFilePath
file Either String WorkspaceEdit
res
case Either String WorkspaceEdit
res of
Left String
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (HintTitle -> ResponseError
responseError (String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ String
"hlint:applyAll: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
err))
Right WorkspaceEdit
fs -> do
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 SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe HintTitle -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
fs) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
Null
data ApplyOneParams = AOP
{ ApplyOneParams -> Uri
file :: Uri
, ApplyOneParams -> Position
start_pos :: Position
, ApplyOneParams -> HintTitle
hintTitle :: HintTitle
} deriving (ApplyOneParams -> ApplyOneParams -> Bool
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
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. 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
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
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 -> HintTitle
oneHintTitle :: HintTitle
} deriving (OneHint -> OneHint -> Bool
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
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 :: Recorder (WithPriority Log) -> CommandFunction IdeState ApplyOneParams
applyOneCmd :: Recorder (WithPriority Log)
-> CommandFunction IdeState ApplyOneParams
applyOneCmd Recorder (WithPriority Log)
recorder IdeState
ide (AOP Uri
uri Position
pos HintTitle
title) = do
let oneHint :: OneHint
oneHint = Position -> HintTitle -> OneHint
OneHint Position
pos HintTitle
title
let file :: NormalizedFilePath
file = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Uri
uri forall a. [a] -> [a] -> [a]
++ String
" is not a file.") String -> NormalizedFilePath
toNormalizedFilePath'
(Uri -> Maybe String
uriToFilePath' Uri
uri)
let progTitle :: HintTitle
progTitle = HintTitle
"Applying hint: " forall a. Semigroup a => a -> a -> a
<> HintTitle
title
forall c (m :: * -> *) a.
MonadLsp c m =>
HintTitle -> ProgressCancellable -> m a -> m a
withIndefiniteProgress HintTitle
progTitle ProgressCancellable
Cancellable forall a b. (a -> b) -> a -> b
$ do
Either String WorkspaceEdit
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
file (forall a. a -> Maybe a
Just OneHint
oneHint)
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Either String WorkspaceEdit -> Log
LogApplying NormalizedFilePath
file Either String WorkspaceEdit
res
case Either String WorkspaceEdit
res of
Left String
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (HintTitle -> ResponseError
responseError (String -> HintTitle
T.pack forall a b. (a -> b) -> a -> b
$ String
"hlint:applyOne: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
err))
Right WorkspaceEdit
fs -> do
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 SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe HintTitle -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
fs) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
Null
applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)
applyHint :: Recorder (WithPriority Log)
-> IdeState
-> NormalizedFilePath
-> Maybe OneHint
-> IO (Either String WorkspaceEdit)
applyHint Recorder (WithPriority Log)
recorder IdeState
ide NormalizedFilePath
nfp Maybe OneHint
mhint =
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
let runAction' :: Action a -> IO a
runAction' :: forall a. Action a -> IO a
runAction' = forall a. String -> IdeState -> Action a -> IO a
runAction String
"applyHint" IdeState
ide
let errorHandlers :: [Handler (Either String b)]
errorHandlers = [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \IOException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (IOException
e :: IOException)))
, forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \ErrorCall
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (ErrorCall
e :: ErrorCall)))
]
[Idea]
ideas <- forall (m :: * -> *) e f a b.
Functor m =>
(e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT ParseError -> String
showParseError forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall a. Action a -> IO a
runAction' forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> NormalizedFilePath -> Action (Either ParseError [Idea])
getIdeas Recorder (WithPriority Log)
recorder NormalizedFilePath
nfp
let ideas' :: [Idea]
ideas' = 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 = forall a b. (a -> b) -> [a] -> [b]
map Idea -> [Refactoring SrcSpan]
ideaRefactoring [Idea]
ideas'
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [[Refactoring SrcSpan]] -> Log
LogGeneratedIdeas NormalizedFilePath
nfp [[Refactoring SrcSpan]]
commands
let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
(UTCTime
_, Maybe HintTitle
mbOldContent) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Action a -> IO a
runAction' forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe HintTitle)
getFileContents NormalizedFilePath
nfp
HintTitle
oldContent <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> HintTitle
T.decodeUtf8 (String -> IO ByteString
BS.readFile String
fp)) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HintTitle
mbOldContent
ModSummaryResult
modsum <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Action a -> IO a
runAction' forall a b. (a -> b) -> a -> b
$ forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp
let dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
modsum
let withRuntimeLibdir :: IO a -> IO a
withRuntimeLibdir :: forall a. IO a -> IO a
withRuntimeLibdir = forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (String -> String -> IO ()
setEnv String
key forall a b. (a -> b) -> a -> b
$ DynFlags -> String
topDir DynFlags
dflags) (String -> IO ()
unsetEnv String
key)
where key :: String
key = String
"GHC_EXACTPRINT_GHC_LIBDIR"
let position :: Maybe a
position = forall a. Maybe a
Nothing
#ifdef HLINT_ON_GHC_LIB
let writeFileUTF8NoNewLineTranslation :: String -> HintTitle -> IO ()
writeFileUTF8NoNewLineTranslation String
file HintTitle
txt =
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
file IOMode
WriteMode 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 (HintTitle -> String
T.unpack HintTitle
txt)
Either String String
res <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (ShowS
takeFileName String
fp) forall a b. (a -> b) -> a -> b
$ \String
temp Handle
h -> do
Handle -> IO ()
hClose Handle
h
String -> HintTitle -> IO ()
writeFileUTF8NoNewLineTranslation String
temp HintTitle
oldContent
[Extension]
exts <- forall a. Action a -> IO a
runAction' forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action [Extension]
getExtensions NormalizedFilePath
nfp
let ([Extension]
enabled, [Extension]
disabled, [String]
_invalid) = [String] -> ([Extension], [Extension], [String])
Refact.parseExtensions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Extension]
exts
let refactExts :: [String]
refactExts = forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ [Extension]
enabled forall a. [a] -> [a] -> [a]
++ [Extension]
disabled
(forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO a -> IO a
withRuntimeLibdir (Maybe (Int, Int)
-> [[Refactoring SrcSpan]] -> String -> [String] -> IO String
Refact.applyRefactorings forall a. Maybe a
position [[Refactoring SrcSpan]]
commands String
temp [String]
refactExts))
forall a. IO a -> [Handler a] -> IO a
`catches` forall {b}. [Handler (Either String b)]
errorHandlers
#else
mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
res <-
case mbParsedModule of
Nothing -> throwE "Apply hint: error parsing the module"
Just pm -> do
let anns = pm_annotations pm
let modu = pm_parsed_source pm
let rigidLayout = deltaOptions RigidLayout
(anns', modu') <-
ExceptT $ mapM (uncurry Refact.applyFixities)
$ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
liftIO $ (Right <$> withRuntimeLibdir (Refact.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, HintTitle) -> HintTitle -> WithDeletions -> WorkspaceEdit
diffText' Bool
True (Uri
uri, HintTitle
oldContent) (String -> HintTitle
T.pack String
appliedFile) WithDeletions
IncludeDeletions
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right WorkspaceEdit
wsEdit)
Left String
err ->
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
err
where
filterIdeas :: OneHint -> [Idea] -> [Idea]
filterIdeas :: OneHint -> [Idea] -> [Idea]
filterIdeas (OneHint (Position UInt
l UInt
c) HintTitle
title) [Idea]
ideas =
let title' :: String
title' = HintTitle -> String
T.unpack HintTitle
title
ideaPos :: Idea -> (Int, Int)
ideaPos = (RealSrcSpan -> Int
srcSpanStartLine forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& RealSrcSpan -> Int
srcSpanStartCol) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RealSrcSpan
toRealSrcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. Idea -> SrcSpan
ideaSpan
in forall a. (a -> Bool) -> [a] -> [a]
filter (\Idea
i -> Idea -> String
ideaHint Idea
i forall a. Eq a => a -> a -> Bool
== String
title' Bool -> Bool -> Bool
&& Idea -> (Int, Int)
ideaPos Idea
i forall a. Eq a => a -> a -> Bool
== (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
lforall a. Num a => a -> a -> a
+UInt
1, forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
cforall a. Num a => a -> a -> a
+UInt
1)) [Idea]
ideas
toRealSrcSpan :: SrcSpan -> RealSrcSpan
toRealSrcSpan (RealSrcSpan RealSrcSpan
real Maybe BufSpan
_) = RealSrcSpan
real
toRealSrcSpan (UnhelpfulSpan UnhelpfulSpanReason
x) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"No real source span: " forall a. [a] -> [a] -> [a]
++ 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 [forall a. Show a => a -> String
show SrcSpan
location, String
message, String
content]
bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b
bimapExceptT :: forall (m :: * -> *) e f a b.
Functor m =>
(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) = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (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) = forall a b. a -> Either a b
Left (e -> f
f e
e)
h (Right a
a) = forall a b. b -> Either a b
Right (a -> b
g a
a)
{-# INLINE bimapExceptT #-}