{-# LANGUAGE GADTs           #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}

module Ide.Plugin.Class.CodeLens where

import           Control.Lens                         ((^.))
import           Control.Monad.Trans.Class            (MonadTrans (lift))
import           Data.Aeson                           hiding (Null)
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.GHC.Compat.Util
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 CodeLensParams{Maybe ProgressToken
TextDocumentIdentifier
$sel:_workDoneToken:CodeLensParams :: CodeLensParams -> Maybe ProgressToken
$sel:_partialResultToken:CodeLensParams :: CodeLensParams -> Maybe ProgressToken
$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_textDocument :: TextDocumentIdentifier
_partialResultToken :: Maybe ProgressToken
_workDoneToken :: Maybe ProgressToken
..} = do
    NormalizedFilePath
nfp <-  forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
    (TcModuleResult
tmr, PositionMapping
_) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.TypeCheck" 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 TypeCheck
TypeCheck NormalizedFilePath
nfp

    -- All instance binds
    (InstanceBindTypeSigsResult [InstanceBindTypeSig]
allBinds, PositionMapping
mp) <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"classplugin.GetInstanceBindTypeSigs" 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 GetInstanceBindTypeSigs
GetInstanceBindTypeSigs NormalizedFilePath
nfp

    [TextEdit]
pragmaInsertion <- forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> Extension
-> ExceptT PluginError m [TextEdit]
insertPragmaIfNotPresent IdeState
state NormalizedFilePath
nfp Extension
InstanceSigs

    let (HsGroup GhcRn
hsGroup, [LImportDecl GhcRn]
_, Maybe [(LIE GhcRn, Avails)]
_, Maybe LHsDocString
_) = TcModuleResult
-> (HsGroup GhcRn, [LImportDecl GhcRn],
    Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString)
tmrRenamed TcModuleResult
tmr
        tycls :: [TyClGroup GhcRn]
tycls = forall p. HsGroup p -> [TyClGroup p]
hs_tyclds HsGroup GhcRn
hsGroup
        -- declared instance methods without signatures
        bindInfos :: [BindInfo]
bindInfos = [ BindInfo
bind
                    | [GenLocated SrcSpanAnnA (InstDecl GhcRn)]
instds <- forall a b. (a -> b) -> [a] -> [b]
map forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds [TyClGroup GhcRn]
tycls -- class instance decls
                    , GenLocated SrcSpanAnnA (InstDecl GhcRn)
instd <- [GenLocated SrcSpanAnnA (InstDecl GhcRn)]
instds
                    , ClsInstDecl GhcRn
inst <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall {pass}. InstDecl pass -> Maybe (ClsInstDecl pass)
getClsInstD (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (InstDecl GhcRn)
instd)
                    , BindInfo
bind <- ClsInstDecl GhcRn -> [BindInfo]
getBindSpanWithoutSig ClsInstDecl GhcRn
inst
                    ]
        targetSigs :: [InstanceBindTypeSig]
targetSigs = [BindInfo] -> [InstanceBindTypeSig] -> [InstanceBindTypeSig]
matchBind [BindInfo]
bindInfos [InstanceBindTypeSig]
allBinds
        makeLens :: (Range, Text) -> CodeLens
makeLens (Range
range, Text
title) =
            PluginId -> Range -> Text -> WorkspaceEdit -> CodeLens
generateLens PluginId
plId Range
range Text
title
                forall a b. (a -> b) -> a -> b
$ [TextEdit] -> [TextEdit] -> WorkspaceEdit
workspaceEdit [TextEdit]
pragmaInsertion
                forall a b. (a -> b) -> a -> b
$ Range -> Text -> PositionMapping -> [TextEdit]
makeEdit Range
range Text
title PositionMapping
mp
        codeLens :: [CodeLens]
codeLens = (Range, Text) -> CodeLens
makeLens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe InstanceBindTypeSig -> Maybe (Range, Text)
getRangeWithSig [InstanceBindTypeSig]
targetSigs

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL [CodeLens]
codeLens
    where
        uri :: Uri
uri = TextDocumentIdentifier
_textDocument forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri

        -- Match Binds with their signatures
        -- We try to give every `InstanceBindTypeSig` a `SrcSpan`,
        -- hence we can display signatures for `InstanceBindTypeSig` with span later.
        matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [InstanceBindTypeSig]
        matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [InstanceBindTypeSig]
matchBind [BindInfo]
existedBinds [InstanceBindTypeSig]
allBindWithSigs =
            [forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl InstanceBindTypeSig -> BindInfo -> InstanceBindTypeSig
go InstanceBindTypeSig
bindSig [BindInfo]
existedBinds | InstanceBindTypeSig
bindSig <- [InstanceBindTypeSig]
allBindWithSigs]
            where
                -- | The `bindDefSpan` of the bind is `Nothing` before,
                -- we update it with the span where binding occurs.
                -- Hence, we can infer the place to display the signature later.
                update :: InstanceBindTypeSig -> SrcSpan -> InstanceBindTypeSig
                update :: InstanceBindTypeSig -> SrcSpan -> InstanceBindTypeSig
update InstanceBindTypeSig
bind SrcSpan
sp = InstanceBindTypeSig
bind {bindDefSpan :: Maybe SrcSpan
bindDefSpan = forall a. a -> Maybe a
Just SrcSpan
sp}

                go :: InstanceBindTypeSig -> BindInfo -> InstanceBindTypeSig
                go :: InstanceBindTypeSig -> BindInfo -> InstanceBindTypeSig
go InstanceBindTypeSig
bindSig BindInfo
bind = case (SrcSpan -> Maybe Range
srcSpanToRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindInfo -> SrcSpan
bindNameSpan) BindInfo
bind of
                    Maybe Range
Nothing -> InstanceBindTypeSig
bindSig
                    Just Range
range ->
                        if Range -> SrcSpan -> Bool
inRange Range
range (forall a. NamedThing a => a -> SrcSpan
getSrcSpan forall a b. (a -> b) -> a -> b
$ InstanceBindTypeSig -> Name
bindName InstanceBindTypeSig
bindSig)
                            then InstanceBindTypeSig -> SrcSpan -> InstanceBindTypeSig
update InstanceBindTypeSig
bindSig (BindInfo -> SrcSpan
bindSpan BindInfo
bind)
                            else InstanceBindTypeSig
bindSig

        getClsInstD :: InstDecl pass -> Maybe (ClsInstDecl pass)
getClsInstD (ClsInstD XClsInstD pass
_ ClsInstDecl pass
d) = forall a. a -> Maybe a
Just ClsInstDecl pass
d
        getClsInstD InstDecl pass
_              = forall a. Maybe a
Nothing

        getSigName :: Sig pass -> Maybe [IdP pass]
getSigName (ClassOpSig XClassOpSig pass
_ Bool
_ [XRec pass (IdP pass)]
sigNames LHsSigType pass
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [XRec pass (IdP pass)]
sigNames
        getSigName Sig pass
_                           = forall a. Maybe a
Nothing

        getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo]
        getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo]
getBindSpanWithoutSig ClsInstDecl{[LTyFamInstDecl GhcRn]
[LDataFamInstDecl GhcRn]
[LSig GhcRn]
Maybe (XRec GhcRn OverlapMode)
LHsSigType GhcRn
XCClsInstDecl GhcRn
LHsBinds GhcRn
cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_ext :: forall pass. ClsInstDecl pass -> XCClsInstDecl pass
cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (XRec pass OverlapMode)
cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_overlap_mode :: Maybe (XRec GhcRn OverlapMode)
cid_datafam_insts :: [LDataFamInstDecl GhcRn]
cid_tyfam_insts :: [LTyFamInstDecl GhcRn]
cid_sigs :: [LSig GhcRn]
cid_binds :: LHsBinds GhcRn
cid_poly_ty :: LHsSigType GhcRn
cid_ext :: XCClsInstDecl GhcRn
..} =
            let bindNames :: [GenLocated SrcSpanAnnA (GenLocated SrcSpanAnnN (IdP GhcRn))]
bindNames = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {l} {idL} {p}.
GenLocated l (HsBindLR idL p)
-> Maybe (GenLocated l (XRec idL (IdP idL)))
go (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
cid_binds)
                go :: GenLocated l (HsBindLR idL p)
-> Maybe (GenLocated l (XRec idL (IdP idL)))
go (L l
l HsBindLR idL p
bind) = case HsBindLR idL p
bind of
                    FunBind{[CoreTickish]
MatchGroup p (LHsExpr p)
XRec idL (IdP idL)
XFunBind idL p
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
fun_tick :: [CoreTickish]
fun_matches :: MatchGroup p (LHsExpr p)
fun_id :: XRec idL (IdP idL)
fun_ext :: XFunBind idL p
..}
                        -- `Generated` tagged for Template Haskell,
                        -- here we filter out nonsence generated bindings
                        -- that are nonsense for displaying code lenses.
                        --
                        -- See https://github.com/haskell/haskell-language-server/issues/3319
                        | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Origin -> Bool
isGenerated (forall {p} {body}. MatchGroup p body -> Origin
groupOrigin MatchGroup p (LHsExpr p)
fun_matches)
                            -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L l
l XRec idL (IdP idL)
fun_id
                    HsBindLR idL p
_       -> forall a. Maybe a
Nothing
                -- Existed signatures' name
                sigNames :: [IdP GhcRn]
sigNames = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(L SrcSpanAnnA
_ Sig GhcRn
r) -> forall {pass} {l}.
(XRec pass (IdP pass) ~ GenLocated l (IdP pass)) =>
Sig pass -> Maybe [IdP pass]
getSigName Sig GhcRn
r) [LSig GhcRn]
cid_sigs
                toBindInfo :: GenLocated (SrcSpanAnn' a) (GenLocated (SrcSpanAnn' a) e)
-> BindInfo
toBindInfo (L SrcSpanAnn' a
l (L SrcSpanAnn' a
l' e
_)) = SrcSpan -> SrcSpan -> BindInfo
BindInfo
                    (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
l) -- bindSpan
                    (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
l') -- bindNameSpan
            in forall {a} {a} {e}.
GenLocated (SrcSpanAnn' a) (GenLocated (SrcSpanAnn' a) e)
-> BindInfo
toBindInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (\(L SrcSpanAnnA
_ GenLocated SrcSpanAnnN (IdP GhcRn)
name) -> forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN (IdP GhcRn)
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [IdP GhcRn]
sigNames) [GenLocated SrcSpanAnnA (GenLocated SrcSpanAnnN (IdP GhcRn))]
bindNames
        getBindSpanWithoutSig ClsInstDecl GhcRn
_ = []

        -- Get bind definition range with its rendered signature text
        getRangeWithSig :: InstanceBindTypeSig -> Maybe (Range, T.Text)
        getRangeWithSig :: InstanceBindTypeSig -> Maybe (Range, Text)
getRangeWithSig InstanceBindTypeSig
bind = do
            SrcSpan
span <- InstanceBindTypeSig -> Maybe SrcSpan
bindDefSpan InstanceBindTypeSig
bind
            Range
range <- SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
span
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Range
range, InstanceBindTypeSig -> Text
bindRendered InstanceBindTypeSig
bind)

        workspaceEdit :: [TextEdit] -> [TextEdit] -> WorkspaceEdit
workspaceEdit [TextEdit]
pragmaInsertion [TextEdit]
edits =
            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
uri, [TextEdit]
edits forall a. [a] -> [a] -> [a]
++ [TextEdit]
pragmaInsertion)])
                forall a. Maybe a
Nothing
                forall a. Maybe a
Nothing

        generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
        generateLens :: PluginId -> Range -> Text -> WorkspaceEdit -> CodeLens
generateLens PluginId
plId Range
range Text
title WorkspaceEdit
edit =
            let cmd :: Command
cmd = 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 WorkspaceEdit
edit])
            in  Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
range (forall a. a -> Maybe a
Just Command
cmd) forall a. Maybe a
Nothing

        makeEdit :: Range -> T.Text -> PositionMapping -> [TextEdit]
        makeEdit :: Range -> Text -> PositionMapping -> [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 -> [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 -> []

codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit
codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit
codeLensCommandHandler IdeState
_ WorkspaceEdit
wedit = do
  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