{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.ChangeTypeSignature (descriptor
, errorMessageRegexes
) where
import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Except (ExceptT)
import Data.Foldable (asum)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Development.IDE (realSrcSpanToRange)
import Development.IDE.Core.PluginUtils
import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule))
import Development.IDE.Core.Service (IdeState)
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Util (printOutputable)
import Generics.SYB (extQ, something)
import Ide.Plugin.Error (PluginError,
getNormalizedFilePathE)
import Ide.Types (PluginDescriptor (..),
PluginId (PluginId),
PluginMethodHandler,
defaultPluginDescriptor,
mkPluginHandler)
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Text.Regex.TDFA ((=~))
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId) { $sel:pluginHandlers:PluginDescriptor :: PluginHandlers IdeState
pluginHandlers = forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentCodeAction
SMethod_TextDocumentCodeAction (PluginId
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionHandler PluginId
plId) }
codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionHandler :: PluginId
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionHandler PluginId
plId IdeState
ideState PluginId
_ CodeActionParams {$sel:_textDocument:CodeActionParams :: CodeActionParams -> TextDocumentIdentifier
_textDocument = TextDocumentIdentifier Uri
uri, $sel:_context:CodeActionParams :: CodeActionParams -> CodeActionContext
_context = CodeActionContext [Diagnostic]
diags Maybe [CodeActionKind]
_ Maybe CodeActionTriggerKind
_} = do
NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls <- forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m [LHsDecl GhcPs]
getDecls PluginId
plId IdeState
ideState NormalizedFilePath
nfp
let actions :: [Command |? CodeAction]
actions = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SigName =>
PluginId
-> Uri
-> [LHsDecl GhcPs]
-> Diagnostic
-> Maybe (Command |? CodeAction)
generateAction PluginId
plId Uri
uri [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls) [Diagnostic]
diags
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL [Command |? CodeAction]
actions
getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs]
getDecls :: forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m [LHsDecl GhcPs]
getDecls (PluginId Text
changeTypeSignatureId) IdeState
state =
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE (Text -> String
T.unpack Text
changeTypeSignatureId forall a. Semigroup a => a -> a -> a
<> String
".GetParsedModule") IdeState
state
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsModule -> [LHsDecl GhcPs]
hsmodDecls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ParsedSource
pm_parsed_source))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GetParsedModule
GetParsedModule
type DeclName = Text
type ExpectedSig = Text
type ActualSig = Text
data ChangeSignature = ChangeSignature {
ChangeSignature -> Text
expectedType :: ExpectedSig
, ChangeSignature -> Text
actualType :: ActualSig
, ChangeSignature -> Text
declName :: DeclName
, ChangeSignature -> RealSrcSpan
declSrcSpan :: RealSrcSpan
, ChangeSignature -> Diagnostic
diagnostic :: Diagnostic
}
type SigName = (HasOccName (IdP GhcPs))
generateAction :: SigName => PluginId -> Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction)
generateAction :: SigName =>
PluginId
-> Uri
-> [LHsDecl GhcPs]
-> Diagnostic
-> Maybe (Command |? CodeAction)
generateAction PluginId
plId Uri
uri [LHsDecl GhcPs]
decls Diagnostic
diag = PluginId -> Uri -> ChangeSignature -> Command |? CodeAction
changeSigToCodeAction PluginId
plId Uri
uri forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
diagnosticToChangeSig [LHsDecl GhcPs]
decls Diagnostic
diag
diagnosticToChangeSig :: SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
diagnosticToChangeSig :: SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
diagnosticToChangeSig [LHsDecl GhcPs]
decls Diagnostic
diagnostic = do
(Text
expectedType, Text
actualType, Text
declName) <- Diagnostic -> Maybe (Text, Text, Text)
matchingDiagnostic Diagnostic
diagnostic
RealSrcSpan
declSrcSpan <- SigName => [LHsDecl GhcPs] -> Text -> String -> Maybe RealSrcSpan
findSigLocOfStringDecl [LHsDecl GhcPs]
decls Text
expectedType (Text -> String
T.unpack Text
declName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ChangeSignature{Text
RealSrcSpan
Diagnostic
declSrcSpan :: RealSrcSpan
declName :: Text
actualType :: Text
expectedType :: Text
diagnostic :: Diagnostic
diagnostic :: Diagnostic
declSrcSpan :: RealSrcSpan
declName :: Text
actualType :: Text
expectedType :: Text
..}
matchingDiagnostic :: Diagnostic -> Maybe (ExpectedSig, ActualSig, DeclName)
matchingDiagnostic :: Diagnostic -> Maybe (Text, Text, Text)
matchingDiagnostic Diagnostic{Text
$sel:_message:Diagnostic :: Diagnostic -> Text
_message :: Text
_message} = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Text, Text, Text, [Text]) -> Maybe (Text, Text, Text)
unwrapMatch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
(=~) Text
_message) [Text]
errorMessageRegexes
where
unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (ExpectedSig, ActualSig, DeclName)
unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (Text, Text, Text)
unwrapMatch (Text
_, Text
_, Text
_, [Text
expect, Text
actual, Text
_, Text
name]) = forall a. a -> Maybe a
Just (Text
expect, Text
actual, Text
name)
unwrapMatch (Text, Text, Text, [Text])
_ = forall a. Maybe a
Nothing
errorMessageRegexes :: [Text]
errorMessageRegexes :: [Text]
errorMessageRegexes = [
Text
"Expected type: (.+)\n +Actual type: (.+)\n(.|\n)+In an equation for ‘(.+)’"
, Text
"Couldn't match expected type ‘(.+)’ with actual type ‘(.+)’\n(.|\n)+In an equation for ‘(.+)’"
, Text
"Expected: (.+)\n +Actual: (.+)\n(.|\n)+In an equation for ‘(.+)’"
]
findSigLocOfStringDecl :: SigName => [LHsDecl GhcPs] -> ExpectedSig -> String -> Maybe RealSrcSpan
findSigLocOfStringDecl :: SigName => [LHsDecl GhcPs] -> Text -> String -> Maybe RealSrcSpan
findSigLocOfStringDecl [LHsDecl GhcPs]
decls Text
expectedType String
declName = forall u. GenericQ (Maybe u) -> GenericQ (Maybe u)
something (forall a b. a -> b -> a
const forall a. Maybe a
Nothing forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` LHsDecl GhcPs -> Maybe RealSrcSpan
findSig forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` LSig GhcPs -> Maybe RealSrcSpan
findLocalSig) [LHsDecl GhcPs]
decls
where
findSig :: LHsDecl GhcPs -> Maybe RealSrcSpan
findSig :: LHsDecl GhcPs -> Maybe RealSrcSpan
findSig = \case
L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> (RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_)) (SigD XSigD GhcPs
_ Sig GhcPs
sig) -> case Sig GhcPs
sig of
ts :: Sig GhcPs
ts@(TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
idsSig LHsSigWcType GhcPs
_) -> forall {t :: * -> *} {name} {l}.
(Foldable t, HasOccName name) =>
Sig GhcPs -> t (GenLocated l name) -> Maybe ()
isMatch Sig GhcPs
ts [LIdP GhcPs]
idsSig forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure RealSrcSpan
rss
Sig GhcPs
_ -> forall a. Maybe a
Nothing
LHsDecl GhcPs
_ -> forall a. Maybe a
Nothing
findLocalSig :: LSig GhcPs -> Maybe RealSrcSpan
findLocalSig :: LSig GhcPs -> Maybe RealSrcSpan
findLocalSig = \case
(L (forall a. SrcSpanAnn' a -> SrcSpan
locA -> (RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_)) ts :: Sig GhcPs
ts@(TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
idsSig LHsSigWcType GhcPs
_)) -> forall {t :: * -> *} {name} {l}.
(Foldable t, HasOccName name) =>
Sig GhcPs -> t (GenLocated l name) -> Maybe ()
isMatch Sig GhcPs
ts [LIdP GhcPs]
idsSig forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure RealSrcSpan
rss
LSig GhcPs
_ -> forall a. Maybe a
Nothing
isMatch :: Sig GhcPs -> t (GenLocated l name) -> Maybe ()
isMatch Sig GhcPs
ts t (GenLocated l name)
idsSig = do
Text
ghcSig <- Sig GhcPs -> Maybe Text
sigToText Sig GhcPs
ts
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {name} {l}. HasOccName name => GenLocated l name -> Bool
compareId t (GenLocated l name)
idsSig Bool -> Bool -> Bool
&& Text
expectedType forall a. Eq a => a -> a -> Bool
== Text
ghcSig)
compareId :: GenLocated l name -> Bool
compareId (L l
_ name
id') = String
declName forall a. Eq a => a -> a -> Bool
== OccName -> String
occNameString (forall name. HasOccName name => name -> OccName
occName name
id')
sigToText :: Sig GhcPs -> Maybe Text
sigToText :: Sig GhcPs -> Maybe Text
sigToText = \case
ts :: Sig GhcPs
ts@TypeSig {} -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Text
stripSignature forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> Text
printOutputable Sig GhcPs
ts
Sig GhcPs
_ -> forall a. Maybe a
Nothing
stripSignature :: Text -> Text
stripSignature :: Text -> Text
stripSignature ((Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\n') -> Text
sig) = if Text -> Text -> Bool
T.isInfixOf Text
" => " Text
sig
then Text -> Text
T.strip forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd Text
" => " Text
sig
else Text -> Text
T.strip forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd Text
" :: " Text
sig
changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAction
changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAction
changeSigToCodeAction (PluginId Text
changeTypeSignatureId) Uri
uri ChangeSignature{Text
RealSrcSpan
Diagnostic
diagnostic :: Diagnostic
declSrcSpan :: RealSrcSpan
declName :: Text
actualType :: Text
expectedType :: Text
diagnostic :: ChangeSignature -> Diagnostic
declSrcSpan :: ChangeSignature -> RealSrcSpan
declName :: ChangeSignature -> Text
actualType :: ChangeSignature -> Text
expectedType :: ChangeSignature -> Text
..} =
forall a b. b -> a |? b
InR CodeAction { $sel:_title:CodeAction :: Text
_title = Text -> Text -> Text
mkChangeSigTitle Text
declName Text
actualType
, $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just (Text -> CodeActionKind
CodeActionKind_Custom (Text
"quickfix." forall a. Semigroup a => a -> a -> a
<> Text
changeTypeSignatureId))
, $sel:_diagnostics:CodeAction :: Maybe [Diagnostic]
_diagnostics = forall a. a -> Maybe a
Just [Diagnostic
diagnostic]
, $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = forall a. Maybe a
Nothing
, $sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== Text) .+ Empty))
_disabled = forall a. Maybe a
Nothing
, $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Uri -> RealSrcSpan -> Text -> WorkspaceEdit
mkChangeSigEdit Uri
uri RealSrcSpan
declSrcSpan (Text -> Text -> Text
mkNewSignature Text
declName Text
actualType)
, $sel:_command:CodeAction :: Maybe Command
_command = forall a. Maybe a
Nothing
, $sel:_data_:CodeAction :: Maybe Value
_data_ = forall a. Maybe a
Nothing
}
mkChangeSigTitle :: Text -> Text -> Text
mkChangeSigTitle :: Text -> Text -> Text
mkChangeSigTitle Text
declName Text
actualType = Text
"Change signature for ‘" forall a. Semigroup a => a -> a -> a
<> Text
declName forall a. Semigroup a => a -> a -> a
<> Text
"’ to: " forall a. Semigroup a => a -> a -> a
<> Text
actualType
mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit
mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit
mkChangeSigEdit Uri
uri RealSrcSpan
ss Text
replacement =
let txtEdit :: TextEdit
txtEdit = Range -> Text -> TextEdit
TextEdit (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
ss) Text
replacement
changes :: Maybe (Map Uri [TextEdit])
changes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Uri
uri [TextEdit
txtEdit]
in Maybe (Map Uri [TextEdit])
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit Maybe (Map Uri [TextEdit])
changes forall a. Maybe a
Nothing forall a. Maybe a
Nothing
mkNewSignature :: Text -> Text -> Text
mkNewSignature :: Text -> Text -> Text
mkNewSignature Text
declName Text
actualType = Text
declName forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
actualType