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

module Ide.Plugin.Class.CodeLens where

import           Control.Lens                    ((^.))
import           Control.Monad.IO.Class          (liftIO)
import           Data.Aeson
import           Data.Maybe                      (mapMaybe, maybeToList)
import qualified Data.Text                       as T
import           Development.IDE
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util
import           GHC.LanguageExtensions.Type
import           Ide.Plugin.Class.Types
import           Ide.Plugin.Class.Utils
import           Ide.PluginUtils
import           Ide.Types
import           Language.LSP.Server             (sendRequest)
import           Language.LSP.Types
import qualified Language.LSP.Types.Lens         as J

codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens
codeLens :: PluginMethodHandler IdeState '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
..} = forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT String m NormalizedFilePath
getNormalizedFilePath Uri
uri
    TcModuleResult
tmr <- forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"Unable to typecheck"
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"classplugin.TypeCheck" IdeState
state
        forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
nfp

    -- All instance binds
    InstanceBindTypeSigsResult [InstanceBindTypeSig]
allBinds <-
        forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"Unable to get InstanceBindTypeSigsResult"
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"classplugin.GetInstanceBindTypeSigs" IdeState
state
        forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetInstanceBindTypeSigs
GetInstanceBindTypeSigs NormalizedFilePath
nfp

    [TextEdit]
pragmaInsertion <- forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath -> Extension -> ExceptT String 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 -> [TextEdit]
makeEdit Range
range Text
title
        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. [a] -> List a
List [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
J.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} {idR}.
GenLocated l (HsBindLR idL idR)
-> Maybe (GenLocated l (XRec idL (IdP idL)))
go (forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
cid_binds)
                go :: GenLocated l (HsBindLR idL idR)
-> Maybe (GenLocated l (XRec idL (IdP idL)))
go (L l
l HsBindLR idL idR
bind) = case HsBindLR idL idR
bind of
                    FunBind{[CoreTickish]
MatchGroup idR (LHsExpr idR)
XRec idL (IdP idL)
XFunBind idL idR
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 idR (LHsExpr idR)
fun_id :: XRec idL (IdP idL)
fun_ext :: XFunBind idL idR
..} -> 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 idR
_           -> 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 WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Uri
uri, forall a. [a] -> List a
List forall a b. (a -> b) -> a -> b
$ [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 -> [TextEdit]
        makeEdit :: Range -> Text -> [TextEdit]
makeEdit Range
range Text
bind =
            let startPos :: Position
startPos = Range
range forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
J.start
                insertChar :: UInt
insertChar = Position
startPos forall s a. s -> Getting a s a -> a
^. forall s a. HasCharacter s a => Lens' s a
J.character
                insertRange :: Range
insertRange = Position -> Position -> Range
Range Position
startPos Position
startPos
            in [Range -> Text -> TextEdit
TextEdit Range
insertRange (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
" ")]

codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit
codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit
codeLensCommandHandler IdeState
_ WorkspaceEdit
wedit = 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 Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
wedit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
Null