{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.Class.CodeLens where
import Control.Lens ((&), (?~), (^.))
import Control.Monad.Trans.Class (MonadTrans (lift))
import Data.Aeson hiding (Null)
import qualified Data.IntMap.Strict as IntMap
import Data.Maybe (mapMaybe, maybeToList)
import qualified Data.Text as T
import Development.IDE
import Development.IDE.Core.PluginUtils
import Development.IDE.Core.PositionMapping
import Development.IDE.GHC.Compat
import Development.IDE.Spans.Pragmas (getFirstPragma,
insertNewPragma)
import Ide.Plugin.Class.Types
import Ide.Plugin.Class.Utils
import Ide.Plugin.Error
import Ide.PluginUtils
import Ide.Types
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server (sendRequest)
codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens
codeLens :: PluginMethodHandler IdeState 'Method_TextDocumentCodeLens
codeLens IdeState
state PluginId
_plId MessageParams 'Method_TextDocumentCodeLens
clp = do
NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath)
-> Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ CodeLensParams
MessageParams 'Method_TextDocumentCodeLens
clp CodeLensParams -> Getting Uri CodeLensParams Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> CodeLensParams -> Const Uri CodeLensParams
forall s a. HasTextDocument s a => Lens' s a
Lens' CodeLensParams TextDocumentIdentifier
L.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> CodeLensParams -> Const Uri CodeLensParams)
-> ((Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri CodeLensParams Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
L.uri
(InstanceBindLensResult (InstanceBindLens{[(Range, Int)]
lensRange :: [(Range, Int)]
lensRange :: InstanceBindLens -> [(Range, Int)]
lensRange}), PositionMapping
pm)
<- String
-> IdeState
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (InstanceBindLensResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.GetInstanceBindLens" IdeState
state
(ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError
(LspM Config)
(InstanceBindLensResult, PositionMapping))
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (InstanceBindLensResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetInstanceBindLens
-> NormalizedFilePath
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetInstanceBindLens
GetInstanceBindLens NormalizedFilePath
nfp
([CodeLens] |? Null)
-> ExceptT PluginError (LspM Config) ([CodeLens] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([CodeLens] |? Null)
-> ExceptT PluginError (LspM Config) ([CodeLens] |? Null))
-> ([CodeLens] |? Null)
-> ExceptT PluginError (LspM Config) ([CodeLens] |? Null)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> [CodeLens] |? Null
forall a b. a -> a |? b
InL ([CodeLens] -> [CodeLens] |? Null)
-> [CodeLens] -> [CodeLens] |? Null
forall a b. (a -> b) -> a -> b
$ ((Range, Int) -> Maybe CodeLens) -> [(Range, Int)] -> [CodeLens]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PositionMapping -> (Range, Int) -> Maybe CodeLens
forall {a}.
ToJSON a =>
PositionMapping -> (Range, a) -> Maybe CodeLens
toCodeLens PositionMapping
pm) [(Range, Int)]
lensRange
where toCodeLens :: PositionMapping -> (Range, a) -> Maybe CodeLens
toCodeLens PositionMapping
pm (Range
range, a
int) =
let newRange :: Maybe Range
newRange = PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
pm Range
range
in (\Range
r -> Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
r Maybe Command
forall a. Maybe a
Nothing (Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToJSON a => a -> Value
toJSON a
int)) (Range -> CodeLens) -> Maybe Range -> Maybe CodeLens
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
newRange
codeLensResolve:: ResolveFunction IdeState Int Method_CodeLensResolve
codeLensResolve :: ResolveFunction IdeState Int 'Method_CodeLensResolve
codeLensResolve IdeState
state PluginId
plId MessageParams 'Method_CodeLensResolve
cl Uri
uri Int
uniqueID = do
NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
(InstanceBindLensResult (InstanceBindLens{IntMap (Range, Name, Type)
lensDetails :: IntMap (Range, Name, Type)
lensDetails :: InstanceBindLens -> IntMap (Range, Name, Type)
lensDetails}), PositionMapping
pm)
<- String
-> IdeState
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (InstanceBindLensResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.GetInstanceBindLens" IdeState
state
(ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError
(LspM Config)
(InstanceBindLensResult, PositionMapping))
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (InstanceBindLensResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetInstanceBindLens
-> NormalizedFilePath
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetInstanceBindLens
GetInstanceBindLens NormalizedFilePath
nfp
(TcModuleResult -> TcGblEnv
tmrTypechecked -> TcGblEnv
gblEnv, PositionMapping
_) <- String
-> IdeState
-> ExceptT PluginError Action (TcModuleResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (TcModuleResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.codeAction.TypeCheck" IdeState
state (ExceptT PluginError Action (TcModuleResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (TcModuleResult, PositionMapping))
-> ExceptT PluginError Action (TcModuleResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (TcModuleResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ TypeCheck
-> NormalizedFilePath
-> ExceptT PluginError Action (TcModuleResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE TypeCheck
TypeCheck NormalizedFilePath
nfp
(HscEnvEq -> HscEnv
hscEnv -> HscEnv
hsc, PositionMapping
_) <- String
-> IdeState
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.codeAction.GhcSession" IdeState
state (ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping))
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError (LspM Config) (HscEnvEq, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GhcSession
-> NormalizedFilePath
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSession
GhcSession NormalizedFilePath
nfp
(Range
range, Name
name, Type
typ) <- PluginError
-> Maybe (Range, Name, Type)
-> ExceptT PluginError (LspM Config) (Range, Name, Type)
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe PluginError
PluginStaleResolve
(Maybe (Range, Name, Type)
-> ExceptT PluginError (LspM Config) (Range, Name, Type))
-> Maybe (Range, Name, Type)
-> ExceptT PluginError (LspM Config) (Range, Name, Type)
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (Range, Name, Type) -> Maybe (Range, Name, Type)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
uniqueID IntMap (Range, Name, Type)
lensDetails
let title :: Text
title = Text -> Text
prettyBindingNameString (Name -> Text
forall a. Outputable a => a -> Text
printOutputable Name
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (HscEnv -> TcGblEnv -> Type -> String
showDoc HscEnv
hsc TcGblEnv
gblEnv Type
typ)
TextEdit
edit <- PluginError
-> Maybe TextEdit -> ExceptT PluginError (LspM Config) TextEdit
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (Text -> PluginError
PluginInvalidUserState Text
"toCurrentRange") (Maybe TextEdit -> ExceptT PluginError (LspM Config) TextEdit)
-> Maybe TextEdit -> ExceptT PluginError (LspM Config) TextEdit
forall a b. (a -> b) -> a -> b
$ Range -> Text -> PositionMapping -> Maybe TextEdit
makeEdit Range
range Text
title PositionMapping
pm
let command :: Command
command = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
typeLensCommandId Text
title ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [InstanceBindLensCommand -> Value
forall a. ToJSON a => a -> Value
toJSON (InstanceBindLensCommand -> Value)
-> InstanceBindLensCommand -> Value
forall a b. (a -> b) -> a -> b
$ Uri -> TextEdit -> InstanceBindLensCommand
InstanceBindLensCommand Uri
uri TextEdit
edit])
CodeLens -> ExceptT PluginError (LspM Config) CodeLens
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeLens -> ExceptT PluginError (LspM Config) CodeLens)
-> CodeLens -> ExceptT PluginError (LspM Config) CodeLens
forall a b. (a -> b) -> a -> b
$ CodeLens
MessageParams 'Method_CodeLensResolve
cl CodeLens -> (CodeLens -> CodeLens) -> CodeLens
forall a b. a -> (a -> b) -> b
& (Maybe Command -> Identity (Maybe Command))
-> CodeLens -> Identity CodeLens
forall s a. HasCommand s a => Lens' s a
Lens' CodeLens (Maybe Command)
L.command ((Maybe Command -> Identity (Maybe Command))
-> CodeLens -> Identity CodeLens)
-> Command -> CodeLens -> CodeLens
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Command
command
where
makeEdit :: Range -> T.Text -> PositionMapping -> Maybe TextEdit
makeEdit :: Range -> Text -> PositionMapping -> Maybe TextEdit
makeEdit Range
range Text
bind PositionMapping
mp =
let startPos :: Position
startPos = Range
range Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
forall s a. HasStart s a => Lens' s a
Lens' Range Position
L.start
insertChar :: UInt
insertChar = Position
startPos Position -> Getting UInt Position UInt -> UInt
forall s a. s -> Getting a s a -> a
^. Getting UInt Position UInt
forall s a. HasCharacter s a => Lens' s a
Lens' Position UInt
L.character
insertRange :: Range
insertRange = Position -> Position -> Range
Range Position
startPos Position
startPos
in case PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
mp Range
insertRange of
Just Range
rg -> TextEdit -> Maybe TextEdit
forall a. a -> Maybe a
Just (TextEdit -> Maybe TextEdit) -> TextEdit -> Maybe TextEdit
forall a b. (a -> b) -> a -> b
$ Range -> Text -> TextEdit
TextEdit Range
rg (Text
bind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
insertChar) Text
" ")
Maybe Range
Nothing -> Maybe TextEdit
forall a. Maybe a
Nothing
codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand
codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand
codeLensCommandHandler PluginId
plId IdeState
state Maybe ProgressToken
_ InstanceBindLensCommand{Uri
commandUri :: Uri
commandUri :: InstanceBindLensCommand -> Uri
commandUri, TextEdit
commandEdit :: TextEdit
commandEdit :: InstanceBindLensCommand -> TextEdit
commandEdit} = do
NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
commandUri
(InstanceBindLensResult (InstanceBindLens{[Extension]
lensEnabledExtensions :: [Extension]
lensEnabledExtensions :: InstanceBindLens -> [Extension]
lensEnabledExtensions}), PositionMapping
_)
<- String
-> IdeState
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (InstanceBindLensResult, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.GetInstanceBindLens" IdeState
state
(ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError
(LspM Config)
(InstanceBindLensResult, PositionMapping))
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
-> ExceptT
PluginError (LspM Config) (InstanceBindLensResult, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetInstanceBindLens
-> NormalizedFilePath
-> ExceptT
PluginError Action (InstanceBindLensResult, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetInstanceBindLens
GetInstanceBindLens NormalizedFilePath
nfp
Maybe NextPragmaInfo
mbPragma <- if Extension
InstanceSigs Extension -> [Extension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
lensEnabledExtensions
then Maybe NextPragmaInfo
-> ExceptT PluginError (LspM Config) (Maybe NextPragmaInfo)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NextPragmaInfo
forall a. Maybe a
Nothing
else NextPragmaInfo -> Maybe NextPragmaInfo
forall a. a -> Maybe a
Just (NextPragmaInfo -> Maybe NextPragmaInfo)
-> ExceptT PluginError (LspM Config) NextPragmaInfo
-> ExceptT PluginError (LspM Config) (Maybe NextPragmaInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError (LspM Config) NextPragmaInfo
forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m NextPragmaInfo
getFirstPragma PluginId
plId IdeState
state NormalizedFilePath
nfp
let
pragmaInsertion :: [TextEdit]
pragmaInsertion =
Maybe TextEdit -> [TextEdit]
forall a. Maybe a -> [a]
maybeToList (Maybe TextEdit -> [TextEdit]) -> Maybe TextEdit -> [TextEdit]
forall a b. (a -> b) -> a -> b
$ (NextPragmaInfo -> Extension -> TextEdit)
-> Extension -> NextPragmaInfo -> TextEdit
forall a b c. (a -> b -> c) -> b -> a -> c
flip NextPragmaInfo -> Extension -> TextEdit
insertNewPragma Extension
InstanceSigs (NextPragmaInfo -> TextEdit)
-> Maybe NextPragmaInfo -> Maybe TextEdit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NextPragmaInfo
mbPragma
wEdit :: WorkspaceEdit
wEdit = [TextEdit] -> WorkspaceEdit
workspaceEdit [TextEdit]
pragmaInsertion
LspId 'Method_WorkspaceApplyEdit
_ <- LspM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit))
-> LspM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
PluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
-> LspT Config IO ())
-> LspM Config (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
wEdit) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
(Value |? Null)
-> ExceptT PluginError (LspM Config) (Value |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value |? Null)
-> ExceptT PluginError (LspM Config) (Value |? Null))
-> (Value |? Null)
-> ExceptT PluginError (LspM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null
where
workspaceEdit :: [TextEdit] -> WorkspaceEdit
workspaceEdit [TextEdit]
pragmaInsertion=
Maybe (Map Uri [TextEdit])
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit
(Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Uri
commandUri, TextEdit
commandEdit TextEdit -> [TextEdit] -> [TextEdit]
forall a. a -> [a] -> [a]
: [TextEdit]
pragmaInsertion)])
Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing
Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing