{-# LANGUAGE GADTs           #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# 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)

-- The code lens method is only responsible for providing the ranges of the code
-- lenses matched to a unique id
codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens
codeLens :: PluginMethodHandler IdeState 'Method_TextDocumentCodeLens
codeLens IdeState
state PluginId
_plId MessageParams 'Method_TextDocumentCodeLens
clp = do
    NormalizedFilePath
nfp <-  forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE forall a b. (a -> b) -> a -> b
$ MessageParams 'Method_TextDocumentCodeLens
clp forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri
    (InstanceBindLensResult (InstanceBindLens{[(Range, Int)]
lensRange :: InstanceBindLens -> [(Range, Int)]
lensRange :: [(Range, Int)]
lensRange}), PositionMapping
pm)
        <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.GetInstanceBindLens" IdeState
state
            -- Using stale results means that we can almost always return a
            -- value. In practice this means the lenses don't 'flicker'
            forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetInstanceBindLens
GetInstanceBindLens NormalizedFilePath
nfp
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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 forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON a
int)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
newRange

-- The code lens resolve method matches a title to each unique id
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 <-  forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
    (InstanceBindLensResult (InstanceBindLens{IntMap (Range, Name, Type)
lensDetails :: InstanceBindLens -> IntMap (Range, Name, Type)
lensDetails :: IntMap (Range, Name, Type)
lensDetails}), PositionMapping
pm)
        <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.GetInstanceBindLens" IdeState
state
            forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetInstanceBindLens
GetInstanceBindLens NormalizedFilePath
nfp
    (TcModuleResult -> TcGblEnv
tmrTypechecked -> TcGblEnv
gblEnv, PositionMapping
_) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.codeAction.TypeCheck" IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE TypeCheck
TypeCheck NormalizedFilePath
nfp
    (HscEnvEq -> HscEnv
hscEnv -> HscEnv
hsc, PositionMapping
_) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.codeAction.GhcSession" IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSession
GhcSession NormalizedFilePath
nfp
    (Range
range, Name
name, Type
typ) <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe PluginError
PluginStaleResolve
                    forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
uniqueID IntMap (Range, Name, Type)
lensDetails
    let title :: Text
title = Text -> Text
prettyBindingNameString (forall a. Outputable a => a -> Text
printOutputable Name
name) forall a. Semigroup a => a -> a -> a
<> 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 <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (Text -> PluginError
PluginInvalidUserState Text
"toCurrentRange") 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 (forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Uri -> TextEdit -> InstanceBindLensCommand
InstanceBindLensCommand Uri
uri TextEdit
edit])
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MessageParams 'Method_CodeLensResolve
cl forall a b. a -> (a -> b) -> b
& forall s a. HasCommand s a => Lens' s a
L.command 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 forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
L.start
                insertChar :: UInt
insertChar = Position
startPos forall s a. s -> Getting a s a -> a
^. forall s a. HasCharacter s a => Lens' s a
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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Range -> Text -> TextEdit
TextEdit Range
rg (Text
bind forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
insertChar) Text
" ")
                Maybe Range
Nothing -> forall a. Maybe a
Nothing

-- Finally the command actually generates and applies the workspace edit for the
-- specified unique id.
codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand
codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand
codeLensCommandHandler PluginId
plId IdeState
state InstanceBindLensCommand{Uri
commandUri :: InstanceBindLensCommand -> Uri
commandUri :: Uri
commandUri, TextEdit
commandEdit :: InstanceBindLensCommand -> TextEdit
commandEdit :: TextEdit
commandEdit} = do
    NormalizedFilePath
nfp <-  forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
commandUri
    (InstanceBindLensResult (InstanceBindLens{[Extension]
lensEnabledExtensions :: InstanceBindLens -> [Extension]
lensEnabledExtensions :: [Extension]
lensEnabledExtensions}), PositionMapping
_)
        <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.GetInstanceBindLens" IdeState
state
            forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetInstanceBindLens
GetInstanceBindLens NormalizedFilePath
nfp
    -- We are only interested in the pragma information if the user does not
    -- have the InstanceSigs extension enabled
    Maybe NextPragmaInfo
mbPragma <- if Extension
InstanceSigs forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
lensEnabledExtensions
                then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m NextPragmaInfo
getFirstPragma PluginId
plId IdeState
state NormalizedFilePath
nfp
    let -- By mapping over our Maybe NextPragmaInfo value, we only compute this
        -- edit if we actually need to.
        pragmaInsertion :: [TextEdit]
pragmaInsertion =
            forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip NextPragmaInfo -> Extension -> TextEdit
insertNewPragma Extension
InstanceSigs 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
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
wEdit) (\Either ResponseError (MessageResult 'Method_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 -> 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
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Uri
commandUri, TextEdit
commandEdit forall a. a -> [a] -> [a]
: [TextEdit]
pragmaInsertion)])
                forall a. Maybe a
Nothing
                forall a. Maybe a
Nothing