Support for resolve for class-plugin lenses

plugins/hls-class-plugin/src/Ide/Plugin/Class.hs

@@ -10,15 +10,16 @@ import           Language.LSP.Protocol.Message
 descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
 descriptor recorder plId = (defaultPluginDescriptor plId)
     { pluginCommands = commands plId
-    , pluginRules = rules recorder
+    , pluginRules = getInstanceBindTypeSigsRule recorder >> getInstanceBindLensRule recorder
     , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder)
         <> mkPluginHandler SMethod_TextDocumentCodeLens codeLens
+        <> mkResolveHandler SMethod_CodeLensResolve codeLensResolve
     }
 
 commands :: PluginId -> [PluginCommand IdeState]
 commands plId
   = [ PluginCommand codeActionCommandId
         "add placeholders for minimal methods" (addMethodPlaceholders plId)
     , PluginCommand typeLensCommandId
-        "add type signatures for instance methods" codeLensCommandHandler
+        "add type signatures for instance methods" (codeLensCommandHandler plId)
     ]

plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs

@@ -106,22 +106,24 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do
             cls <- findClassFromIdentifier docPath ident
             InstanceBindTypeSigsResult sigs <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state
                 $ useE GetInstanceBindTypeSigs docPath
+            (tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath
+            (hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath
             implemented <- findImplementedMethods ast instancePosition
             logWith recorder Info (LogImplementedMethods cls implemented)
             pure
                 $ concatMap mkAction
                 $ nubOrdOn snd
                 $ filter ((/=) mempty . snd)
                 $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))
-                $ mkMethodGroups range sigs cls
+                $ mkMethodGroups hsc gblEnv range sigs cls
             where
                 range = diag ^. L.range
 
-                mkMethodGroups :: Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
-                mkMethodGroups range sigs cls = minimalDef <> [allClassMethods]
+                mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
+                mkMethodGroups hsc gblEnv range sigs cls = minimalDef <> [allClassMethods]
                     where
-                        minimalDef = minDefToMethodGroups range sigs $ classMinimalDef cls
-                        allClassMethods = ("all missing methods", makeMethodDefinitions range sigs)
+                        minimalDef = minDefToMethodGroups hsc gblEnv range sigs $ classMinimalDef cls
+                        allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs)
 
                 mkAction :: MethodGroup -> [Command |? CodeAction]
                 mkAction (name, methods)
@@ -211,15 +213,15 @@ type MethodName = T.Text
 type MethodDefinition = (MethodName, MethodSignature)
 type MethodGroup = (T.Text, [MethodDefinition])
 
-makeMethodDefinition :: InstanceBindTypeSig -> MethodDefinition
-makeMethodDefinition sig = (name, signature)
+makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition
+makeMethodDefinition hsc gblEnv sig = (name, signature)
     where
         name = T.drop (T.length bindingPrefix) (printOutputable  (bindName sig))
-        signature = bindRendered sig
+        signature = prettyBindingNameString (printOutputable (bindName sig)) <> " :: " <> T.pack (showDoc hsc gblEnv (bindType sig))
 
-makeMethodDefinitions :: Range -> [InstanceBindTypeSig] -> [MethodDefinition]
-makeMethodDefinitions range sigs =
-    [ makeMethodDefinition sig
+makeMethodDefinitions :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]
+makeMethodDefinitions hsc gblEnv range sigs =
+    [ makeMethodDefinition hsc gblEnv sig
     | sig <- sigs
     , inRange range (getSrcSpan $ bindName sig)
     ]
@@ -228,14 +230,14 @@ signatureToName :: InstanceBindTypeSig -> T.Text
 signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
 
 -- Return [groupName text, [(methodName text, signature text)]]
-minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
-minDefToMethodGroups range sigs minDef = makeMethodGroup <$> go minDef
+minDefToMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
+minDefToMethodGroups hsc gblEnv range sigs minDef = makeMethodGroup <$> go minDef
     where
         makeMethodGroup methodDefinitions =
             let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions
             in  (name, methodDefinitions)
 
-        go (Var mn)   = pure $ makeMethodDefinitions range $ filter ((==) (printOutputable mn) . signatureToName) sigs
+        go (Var mn)   = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable mn) . signatureToName) sigs
         go (Or ms)    = concatMap (go . unLoc) ms
         go (And ms)   = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms)
         go (Parens m) = go (unLoc m)

plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs

@@ -1,20 +1,21 @@
 {-# LANGUAGE GADTs           #-}
+{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-
+{-# LANGUAGE ViewPatterns    #-}
 module Ide.Plugin.Class.CodeLens where
 
-import           Control.Lens                         ((^.))
+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.GHC.Compat.Util
+import           Development.IDE.Spans.Pragmas        (getFirstPragma,
+                                                       insertNewPragma)
 import           Ide.Plugin.Class.Types
 import           Ide.Plugin.Class.Utils
 import           Ide.Plugin.Error
@@ -25,118 +26,73 @@ 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 state plId CodeLensParams{..} = do
+codeLens state _plId clp = do
+    nfp <-  getNormalizedFilePathE $ clp ^. L.textDocument . L.uri
+    (InstanceBindLensResult (InstanceBindLens{lensRange}), pm)
+        <- runActionE "classplugin.GetInstanceBindLens" state
+            -- Using stale results means that we can almost always return a
+            -- value. In practice this means the lenses don't 'flicker'
+            $ useWithStaleE GetInstanceBindLens nfp
+    pure $ InL $ mapMaybe (toCodeLens pm) lensRange
+    where toCodeLens pm (range, int) =
+            let newRange = toCurrentRange pm range
+            in (\r -> CodeLens r Nothing (Just $ toJSON int)) <$> newRange
+
+-- The code lens resolve method matches a title to each unique id
+codeLensResolve:: ResolveFunction IdeState Int Method_CodeLensResolve
+codeLensResolve state plId cl uri uniqueID = do
     nfp <-  getNormalizedFilePathE uri
-    (tmr, _) <- runActionE "classplugin.TypeCheck" state
-        -- Using stale results means that we can almost always return a value. In practice
-        -- this means the lenses don't 'flicker'
-        $ useWithStaleE TypeCheck nfp
-
-    -- All instance binds
-    (InstanceBindTypeSigsResult allBinds, mp) <- runActionE "classplugin.GetInstanceBindTypeSigs" state
-        -- Using stale results means that we can almost always return a value. In practice
-        -- this means the lenses don't 'flicker'
-        $ useWithStaleE GetInstanceBindTypeSigs nfp
-
-    pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs
-
-    let (hsGroup, _, _, _) = tmrRenamed tmr
-        tycls = hs_tyclds hsGroup
-        -- declared instance methods without signatures
-        bindInfos = [ bind
-                    | instds <- map group_instds tycls -- class instance decls
-                    , instd <- instds
-                    , inst <- maybeToList $ getClsInstD (unLoc instd)
-                    , bind <- getBindSpanWithoutSig inst
-                    ]
-        targetSigs = matchBind bindInfos allBinds
-        makeLens (range, title) =
-            generateLens plId range title
-                $ workspaceEdit pragmaInsertion
-                $ makeEdit range title mp
-        codeLens = makeLens <$> mapMaybe getRangeWithSig targetSigs
-
-    pure $ InL codeLens
+    (InstanceBindLensResult (InstanceBindLens{lensDetails}), pm)
+        <- runActionE "classplugin.GetInstanceBindLens" state
+            $ useWithStaleE GetInstanceBindLens nfp
+    (tmrTypechecked -> gblEnv, _) <- runActionE "classplugin.codeAction.TypeCheck" state $ useWithStaleE TypeCheck nfp
+    (hscEnv -> hsc, _) <- runActionE "classplugin.codeAction.GhcSession" state $ useWithStaleE GhcSession nfp
+    (range, name, typ) <- handleMaybe PluginStaleResolve
+                    $ IntMap.lookup uniqueID lensDetails
+    let title = prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc hsc gblEnv typ)
+    edit <- handleMaybe (PluginInvalidUserState "toCurrentRange") $ makeEdit range title pm
+    let command = mkLspCommand plId typeLensCommandId title (Just [toJSON $ InstanceBindLensCommand uri edit])
+    pure $ cl & L.command ?~ command
     where
-        uri = _textDocument ^. 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 existedBinds allBindWithSigs =
-            [foldl go bindSig existedBinds | bindSig <- 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 bind sp = bind {bindDefSpan = Just sp}
-
-                go :: InstanceBindTypeSig -> BindInfo -> InstanceBindTypeSig
-                go bindSig bind = case (srcSpanToRange . bindNameSpan) bind of
-                    Nothing -> bindSig
-                    Just range ->
-                        if inRange range (getSrcSpan $ bindName bindSig)
-                            then update bindSig (bindSpan bind)
-                            else bindSig
-
-        getClsInstD (ClsInstD _ d) = Just d
-        getClsInstD _              = Nothing
-
-        getSigName (ClassOpSig _ _ sigNames _) = Just $ map unLoc sigNames
-        getSigName _                           = Nothing
-
-        getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo]
-        getBindSpanWithoutSig ClsInstDecl{..} =
-            let bindNames = mapMaybe go (bagToList cid_binds)
-                go (L l bind) = case bind of
-                    FunBind{..}
-                        -- `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
-                        | not $ isGenerated (groupOrigin fun_matches)
-                            -> Just $ L l fun_id
-                    _       -> Nothing
-                -- Existed signatures' name
-                sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs
-                toBindInfo (L l (L l' _)) = BindInfo
-                    (locA l) -- bindSpan
-                    (locA l') -- bindNameSpan
-            in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` sigNames) bindNames
-        getBindSpanWithoutSig _ = []
-
-        -- Get bind definition range with its rendered signature text
-        getRangeWithSig :: InstanceBindTypeSig -> Maybe (Range, T.Text)
-        getRangeWithSig bind = do
-            span <- bindDefSpan bind
-            range <- srcSpanToRange span
-            pure (range, bindRendered bind)
-
-        workspaceEdit pragmaInsertion edits =
-            WorkspaceEdit
-                (pure [(uri, edits ++ pragmaInsertion)])
-                Nothing
-                Nothing
-
-        generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
-        generateLens plId range title edit =
-            let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON edit])
-            in  CodeLens range (Just cmd) Nothing
-
-        makeEdit :: Range -> T.Text -> PositionMapping -> [TextEdit]
+        makeEdit :: Range -> T.Text -> PositionMapping -> Maybe TextEdit
         makeEdit range bind mp =
             let startPos = range ^. L.start
                 insertChar = startPos ^. L.character
                 insertRange = Range startPos startPos
             in case toCurrentRange mp insertRange of
-                Just rg -> [TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")]
-                Nothing -> []
+                Just rg -> Just $ TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")
+                Nothing -> Nothing
+
+-- Finally the command actually generates and applies the workspace edit for the
+-- specified unique id.
+codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand
+codeLensCommandHandler plId state InstanceBindLensCommand{commandUri, commandEdit} = do
+    nfp <-  getNormalizedFilePathE commandUri
+    (InstanceBindLensResult (InstanceBindLens{lensEnabledExtensions}), _)
+        <- runActionE "classplugin.GetInstanceBindLens" state
+            $ useWithStaleE GetInstanceBindLens nfp
+    -- We are only interested in the pragma information if the user does not
+    -- have the InstanceSigs extension enabled
+    mbPragma <- if InstanceSigs `elem` lensEnabledExtensions
+                then pure Nothing
+                else Just <$> getFirstPragma plId state nfp
+    let -- By mapping over our Maybe NextPragmaInfo value, we only compute this
+        -- edit if we actually need to.
+        pragmaInsertion =
+            maybeToList $ flip insertNewPragma InstanceSigs <$> mbPragma
+        wEdit = workspaceEdit pragmaInsertion
+    _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ())
+    pure $ InR Null
+    where
+        workspaceEdit pragmaInsertion=
+            WorkspaceEdit
+                (pure [(commandUri, commandEdit : pragmaInsertion)])
+                Nothing
+                Nothing
+
+
+
 
-codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit
-codeLensCommandHandler _ wedit = do
-  _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
-  pure $ InR Null