From 165f1490f2b48befaed995538bae8f11ab9cc708 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 21 Aug 2023 18:27:27 +0300 Subject: [PATCH 1/4] Initial support for resolve for class-plugin lenses --- .../hls-class-plugin/src/Ide/Plugin/Class.hs | 2 +- .../src/Ide/Plugin/Class/CodeLens.hs | 126 ++++---------- .../src/Ide/Plugin/Class/Types.hs | 164 ++++++++++++++---- 3 files changed, 162 insertions(+), 130 deletions(-) diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 418f55a590..eb77290ded 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -10,7 +10,7 @@ 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 } diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs index daf5f4e2bc..43e0827e69 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/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 #-} 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 Data.Maybe (mapMaybe, maybeToList) +import qualified Data.IntMap.Strict as IntMap +import Data.Maybe (mapMaybe) 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 @@ -26,115 +27,48 @@ import Language.LSP.Protocol.Types import Language.LSP.Server (sendRequest) codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLens state plId CodeLensParams{..} = do - nfp <- getNormalizedFilePathE uri - (tmr, _) <- runActionE "classplugin.TypeCheck" state +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 TypeCheck nfp - - -- All instance binds - (InstanceBindTypeSigsResult allBinds, mp) <- runActionE "classplugin.GetInstanceBindTypeSigs" state + $ 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 + +codeLensResolve:: ResolveFunction IdeState Int Method_CodeLensResolve +codeLensResolve state plId cl uri uniqueID = do + nfp <- getNormalizedFilePathE uri + pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs + (InstanceBindLensResult (InstanceBindLens{lensRendered}), 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 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 + $ useWithStaleE GetInstanceBindLens nfp + resolveData <- handleMaybe PluginStaleResolve $ IntMap.lookup uniqueID lensRendered + let makeCommand (TextEdit range title) = + case makeEdit range title pm of + Just edit -> Just + $ mkLspCommand plId typeLensCommandId title (Just [toJSON (workspaceEdit pragmaInsertion [edit])]) + Nothing -> Nothing + codeLensCommand <- handleMaybe PluginStaleResolve $ makeCommand resolveData + pure $ cl & L.command ?~ codeLensCommand 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 codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit codeLensCommandHandler _ wedit = do diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index 220682487c..f0fcc8b9bd 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -2,25 +2,34 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Class.Types where -import Control.DeepSeq (rwhnf) -import Control.Monad.Extra (whenMaybe) -import Control.Monad.IO.Class (liftIO) +import Control.DeepSeq (rwhnf) +import Control.Monad.Extra (mapMaybeM, whenMaybe) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT), + hoistMaybe) import Data.Aeson -import Data.Maybe (catMaybes) -import qualified Data.Text as T +import qualified Data.IntMap as IntMap +import Data.Maybe (catMaybes, mapMaybe, + maybeToList) +import qualified Data.Text as T +import Data.Unique (hashUnique, newUnique) import Development.IDE -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat hiding ((<+>)) +import Development.IDE.Core.PluginUtils (useMT) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (newUnique, (<+>)) +import Development.IDE.GHC.Compat.Util (bagToList) import Development.IDE.Graph.Classes import GHC.Generics import Ide.Plugin.Class.Utils import Ide.Types -import Language.LSP.Protocol.Types (VersionedTextDocumentIdentifier) +import Language.LSP.Protocol.Types (TextEdit (TextEdit), + VersionedTextDocumentIdentifier) typeLensCommandId :: CommandId typeLensCommandId = "classplugin.typelens" @@ -62,6 +71,25 @@ instance NFData InstanceBindTypeSigsResult where type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult +data GetInstanceBindLens = GetInstanceBindLens + deriving (Generic, Show, Eq, Ord, Hashable, NFData) + +data InstanceBindLens = InstanceBindLens + { lensRange :: [(Range, Int)] + , lensRendered :: IntMap.IntMap TextEdit + } + +newtype InstanceBindLensResult = + InstanceBindLensResult InstanceBindLens + +instance Show InstanceBindLensResult where + show _ = "" + +instance NFData InstanceBindLensResult where + rnf = rwhnf + +type instance RuleResult GetInstanceBindLens = InstanceBindLensResult + data Log = LogImplementedMethods Class [T.Text] | LogShake Shake.Log @@ -81,30 +109,100 @@ data BindInfo = BindInfo -- ^ SrcSpan of the binding name } -rules :: Recorder (WithPriority Log) -> Rules () -rules recorder = do - define (cmapWithPrio LogShake recorder) $ \GetInstanceBindTypeSigs nfp -> do - tmr <- use TypeCheck nfp - hsc <- use GhcSession nfp - result <- liftIO $ instanceBindType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) - pure ([], result) +getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules () +getInstanceBindLensRule recorder = do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindLens nfp -> runMaybeT $ do + (tmrRenamed -> (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp + (InstanceBindTypeSigsResult allBinds) <- useMT GetInstanceBindTypeSigs nfp + + let -- 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 + rangeIntText <- liftIO $ mapMaybeM getRangeWithSig targetSigs + let lensRange = (\(range, int, _) -> (range, int)) <$> rangeIntText + lensRendered = IntMap.fromList $ (\(range, int, text) -> (int, TextEdit range text)) <$> rangeIntText + pure $ InstanceBindLensResult $ InstanceBindLens{..} where - instanceBindType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe InstanceBindTypeSigsResult) - instanceBindType (Just hsc) (Just gblEnv) = do - let binds = collectHsBindsBinders $ tcg_binds gblEnv - (_, maybe [] catMaybes -> instanceBinds) <- - initTcWithGbl hsc gblEnv ghostSpan $ traverse bindToSig binds - pure $ Just $ InstanceBindTypeSigsResult instanceBinds + -- 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 - rdrEnv = tcg_rdr_env gblEnv - showDoc ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc rdrEnv) (pprSigmaType ty) - - bindToSig id = do - let name = idName id - whenMaybe (isBindingName name) $ do - env <- tcInitTidyEnv - let (_, ty) = tidyOpenType env (idType id) - pure $ InstanceBindTypeSig name - (prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc ty)) - Nothing - instanceBindType _ _ = pure Nothing + -- | 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 nonsense 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 -> IO (Maybe (Range, Int, T.Text)) + getRangeWithSig bind = runMaybeT $ do + span <- hoistMaybe $ bindDefSpan bind + range <- hoistMaybe $ srcSpanToRange span + uniqueID <- liftIO $ hashUnique <$> newUnique + pure (range, uniqueID, bindRendered bind) + + + +getInstanceBindTypeSigsRule :: Recorder (WithPriority Log) -> Rules () +getInstanceBindTypeSigsRule recorder = do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindTypeSigs nfp -> runMaybeT $ do + (tmrTypechecked -> gblEnv ) <- useMT TypeCheck nfp + (hscEnv -> hsc) <- useMT GhcSession nfp + let binds = collectHsBindsBinders $ tcg_binds gblEnv + (_, maybe [] catMaybes -> instanceBinds) <- liftIO $ + initTcWithGbl hsc gblEnv ghostSpan $ traverse (bindToSig hsc gblEnv) binds + pure $ InstanceBindTypeSigsResult instanceBinds + where + rdrEnv gblEnv= tcg_rdr_env gblEnv + showDoc hsc gblEnv ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc (rdrEnv gblEnv)) (pprSigmaType ty) + bindToSig hsc gblEnv id = do + let name = idName id + whenMaybe (isBindingName name) $ do + env <- tcInitTidyEnv + let (_, ty) = tidyOpenType env (idType id) + pure $ InstanceBindTypeSig name + (prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc hsc gblEnv ty)) + Nothing From bd36b70d8f9fd716f1383e5c352b980dad06e969 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 22 Aug 2023 19:58:12 +0300 Subject: [PATCH 2/4] WIP --- .../hls-class-plugin/src/Ide/Plugin/Class.hs | 3 +- .../src/Ide/Plugin/Class/CodeLens.hs | 75 ++++++++++++------- .../src/Ide/Plugin/Class/Types.hs | 13 +++- plugins/hls-class-plugin/test/Main.hs | 16 ++-- 4 files changed, 68 insertions(+), 39 deletions(-) diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index eb77290ded..49abbe9710 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -13,6 +13,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) , pluginRules = getInstanceBindTypeSigsRule recorder >> getInstanceBindLensRule recorder , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder) <> mkPluginHandler SMethod_TextDocumentCodeLens codeLens + <> mkResolveHandler SMethod_CodeLensResolve codeLensResolve } commands :: PluginId -> [PluginCommand IdeState] @@ -20,5 +21,5 @@ 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) ] diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs index 43e0827e69..5d4338da2d 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -1,8 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-overlapping-patterns #-} module Ide.Plugin.Class.CodeLens where @@ -10,14 +8,15 @@ 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) +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 @@ -26,38 +25,63 @@ 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 clp = 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 + (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 - pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs - (InstanceBindLensResult (InstanceBindLens{lensRendered}), 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 - resolveData <- handleMaybe PluginStaleResolve $ IntMap.lookup uniqueID lensRendered - let makeCommand (TextEdit range title) = - case makeEdit range title pm of - Just edit -> Just - $ mkLspCommand plId typeLensCommandId title (Just [toJSON (workspaceEdit pragmaInsertion [edit])]) - Nothing -> Nothing - codeLensCommand <- handleMaybe PluginStaleResolve $ makeCommand resolveData - pure $ cl & L.command ?~ codeLensCommand + (InstanceBindLensResult (InstanceBindLens{lensRendered}), _) + <- runActionE "classplugin.GetInstanceBindLens" state + $ useWithStaleE GetInstanceBindLens nfp + resolveData <- handleMaybe PluginStaleResolve + $ IntMap.lookup uniqueID lensRendered + let makeCommand (TextEdit _ title) = + mkLspCommand plId typeLensCommandId title (Just [toJSON $ InstanceBindLensCommand uri uniqueID]) + pure $ cl & L.command ?~ makeCommand resolveData + +-- 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, commandUid} = do + nfp <- getNormalizedFilePathE commandUri + (InstanceBindLensResult (InstanceBindLens{lensRendered, lensEnabledExtensions}), pm) + <- 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 + resolveData <- handleMaybe PluginStaleResolve + $ IntMap.lookup commandUid lensRendered + let -- By mapping over our Maybe NextPragmaInfo value, we only compute this + -- edit if we actually need to. + pragmaInsertion = + maybeToList $ flip insertNewPragma InstanceSigs <$> mbPragma + makeWEdit (TextEdit range title) = + workspaceEdit pragmaInsertion . pure <$> makeEdit range title pm + wEdit <- handleMaybe (PluginInvalidUserState "toCurrentRange") + $ makeWEdit resolveData + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ()) + pure $ InR Null where workspaceEdit pragmaInsertion edits = WorkspaceEdit - (pure [(uri, edits ++ pragmaInsertion)]) + (pure [(commandUri, edits ++ pragmaInsertion)]) Nothing Nothing @@ -70,7 +94,4 @@ codeLensResolve state plId cl uri uniqueID = do Just rg -> Just $ TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ") Nothing -> Nothing -codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit -codeLensCommandHandler _ wedit = do - _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - pure $ InR Null + diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index f0fcc8b9bd..a2ead6fcda 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -71,12 +71,18 @@ instance NFData InstanceBindTypeSigsResult where type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult +data InstanceBindLensCommand = InstanceBindLensCommand + { commandUri :: Uri + , commandUid :: Int} + deriving (Generic, FromJSON, ToJSON) + data GetInstanceBindLens = GetInstanceBindLens deriving (Generic, Show, Eq, Ord, Hashable, NFData) data InstanceBindLens = InstanceBindLens - { lensRange :: [(Range, Int)] - , lensRendered :: IntMap.IntMap TextEdit + { lensRange :: [(Range, Int)] + , lensRendered :: IntMap.IntMap TextEdit + , lensEnabledExtensions :: [Extension] } newtype InstanceBindLensResult = @@ -112,7 +118,7 @@ data BindInfo = BindInfo getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules () getInstanceBindLensRule recorder = do defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindLens nfp -> runMaybeT $ do - (tmrRenamed -> (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp + tmr@(tmrRenamed -> (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp (InstanceBindTypeSigsResult allBinds) <- useMT GetInstanceBindTypeSigs nfp let -- declared instance methods without signatures @@ -126,6 +132,7 @@ getInstanceBindLensRule recorder = do rangeIntText <- liftIO $ mapMaybeM getRangeWithSig targetSigs let lensRange = (\(range, int, _) -> (range, int)) <$> rangeIntText lensRendered = IntMap.fromList $ (\(range, int, text) -> (int, TextEdit range text)) <$> rangeIntText + lensEnabledExtensions = getExtensions $ tmrParsed tmr pure $ InstanceBindLensResult $ InstanceBindLens{..} where -- Match Binds with their signatures diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index b102c64f73..9b6ac6c7ca 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -10,8 +10,8 @@ module Main ( main ) where -import Control.Lens (Prism', prism', (^.), (^..), - (^?)) +import Control.Lens (Prism', prism', view, (^.), + (^..), (^?)) import Control.Monad (void) import Data.Maybe import Data.Row ((.==)) @@ -111,7 +111,7 @@ codeLensTests = testGroup [ testCase "Has code lens" $ do runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "CodeLensSimple.hs" "haskell" - lens <- getCodeLenses doc + lens <- getAndResolveCodeLenses doc let titles = map (^. L.title) $ mapMaybe (^. L.command) lens liftIO $ titles @?= [ "(==) :: B -> B -> Bool" @@ -120,7 +120,7 @@ codeLensTests = testGroup , testCase "No lens for TH" $ do runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "TH.hs" "haskell" - lens <- getCodeLenses doc + lens <- getAndResolveCodeLenses doc liftIO $ length lens @?= 0 , goldenCodeLens "Apply code lens" "CodeLensSimple" 1 , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0 @@ -133,11 +133,11 @@ codeLensTests = testGroup , testCase "keep stale lens" $ do runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "Stale.hs" "haskell" - oldLens <- getCodeLenses doc + oldLens <- getAndResolveCodeLenses doc let edit = TextEdit (mkRange 4 11 4 12) "" -- Remove the `_` _ <- applyEdit doc edit - newLens <- getCodeLenses doc - liftIO $ newLens @?= oldLens + newLens <- getAndResolveCodeLenses doc + liftIO $ (view L.command <$> newLens ) @?= (view L.command <$> oldLens) ] _CACodeAction :: Prism' (Command |? CodeAction) CodeAction @@ -148,7 +148,7 @@ _CACodeAction = prism' InR $ \case goldenCodeLens :: TestName -> FilePath -> Int -> TestTree goldenCodeLens title path idx = goldenWithHaskellDoc classPlugin title testDataDir path "expected" "hs" $ \doc -> do - lens <- getCodeLenses doc + lens <- getAndResolveCodeLenses doc executeCommand $ fromJust $ (lens !! idx) ^. L.command void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) From 86966ddc18d1948605c16cd6024586c68aac64bf Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 31 Aug 2023 13:54:03 +0300 Subject: [PATCH 3/4] move the signature printing to as late as possible --- .../src/Ide/Plugin/Class/CodeAction.hs | 30 ++++--- .../src/Ide/Plugin/Class/CodeLens.hs | 51 +++++------ .../src/Ide/Plugin/Class/Types.hs | 88 ++++++++++--------- .../src/Ide/Plugin/Class/Utils.hs | 4 + 4 files changed, 92 insertions(+), 81 deletions(-) diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 18accdbc6f..a3d75465bd 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -106,6 +106,8 @@ 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 @@ -113,15 +115,15 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do $ 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) diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs index 5d4338da2d..ab345b2171 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} - +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Class.CodeLens where import Control.Lens ((&), (?~), (^.)) @@ -17,6 +17,7 @@ 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 @@ -44,21 +45,33 @@ codeLens state _plId clp = do codeLensResolve:: ResolveFunction IdeState Int Method_CodeLensResolve codeLensResolve state plId cl uri uniqueID = do nfp <- getNormalizedFilePathE uri - (InstanceBindLensResult (InstanceBindLens{lensRendered}), _) + (InstanceBindLensResult (InstanceBindLens{lensDetails}), pm) <- runActionE "classplugin.GetInstanceBindLens" state $ useWithStaleE GetInstanceBindLens nfp - resolveData <- handleMaybe PluginStaleResolve - $ IntMap.lookup uniqueID lensRendered - let makeCommand (TextEdit _ title) = - mkLspCommand plId typeLensCommandId title (Just [toJSON $ InstanceBindLensCommand uri uniqueID]) - pure $ cl & L.command ?~ makeCommand resolveData + (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 + 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 -> 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, commandUid} = do +codeLensCommandHandler plId state InstanceBindLensCommand{commandUri, commandEdit} = do nfp <- getNormalizedFilePathE commandUri - (InstanceBindLensResult (InstanceBindLens{lensRendered, lensEnabledExtensions}), pm) + (InstanceBindLensResult (InstanceBindLens{lensEnabledExtensions}), _) <- runActionE "classplugin.GetInstanceBindLens" state $ useWithStaleE GetInstanceBindLens nfp -- We are only interested in the pragma information if the user does not @@ -66,32 +79,20 @@ codeLensCommandHandler plId state InstanceBindLensCommand{commandUri, commandUid mbPragma <- if InstanceSigs `elem` lensEnabledExtensions then pure Nothing else Just <$> getFirstPragma plId state nfp - resolveData <- handleMaybe PluginStaleResolve - $ IntMap.lookup commandUid lensRendered let -- By mapping over our Maybe NextPragmaInfo value, we only compute this -- edit if we actually need to. pragmaInsertion = maybeToList $ flip insertNewPragma InstanceSigs <$> mbPragma - makeWEdit (TextEdit range title) = - workspaceEdit pragmaInsertion . pure <$> makeEdit range title pm - wEdit <- handleMaybe (PluginInvalidUserState "toCurrentRange") - $ makeWEdit resolveData + wEdit = workspaceEdit pragmaInsertion _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ()) pure $ InR Null where - workspaceEdit pragmaInsertion edits = + workspaceEdit pragmaInsertion= WorkspaceEdit - (pure [(commandUri, edits ++ pragmaInsertion)]) + (pure [(commandUri, commandEdit : pragmaInsertion)]) Nothing Nothing - 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 -> Just $ TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ") - Nothing -> Nothing + diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index a2ead6fcda..0b81dc430e 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -11,10 +11,10 @@ module Ide.Plugin.Class.Types where import Control.DeepSeq (rwhnf) import Control.Monad.Extra (mapMaybeM, whenMaybe) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Maybe (MaybeT (runMaybeT), - hoistMaybe) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Data.Aeson import qualified Data.IntMap as IntMap +import Data.List.Extra (firstJust) import Data.Maybe (catMaybes, mapMaybe, maybeToList) import qualified Data.Text as T @@ -28,7 +28,7 @@ import Development.IDE.Graph.Classes import GHC.Generics import Ide.Plugin.Class.Utils import Ide.Types -import Language.LSP.Protocol.Types (TextEdit (TextEdit), +import Language.LSP.Protocol.Types (TextEdit, VersionedTextDocumentIdentifier) typeLensCommandId :: CommandId @@ -50,14 +50,15 @@ data AddMinimalMethodsParams = AddMinimalMethodsParams } deriving (Show, Eq, Generic, ToJSON, FromJSON) +-- |The InstanceBindTypeSigs Rule collects the instance bindings type +-- signatures (both name and type). It is used by both the code actions and the +-- code lenses data GetInstanceBindTypeSigs = GetInstanceBindTypeSigs deriving (Generic, Show, Eq, Ord, Hashable, NFData) data InstanceBindTypeSig = InstanceBindTypeSig - { bindName :: Name - , bindRendered :: !T.Text - , bindDefSpan :: Maybe SrcSpan - -- ^SrcSpan for the bind definition + { bindName :: Name + , bindType :: Type } newtype InstanceBindTypeSigsResult = @@ -71,17 +72,32 @@ instance NFData InstanceBindTypeSigsResult where type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult +-- |The necessary data to execute our code lens data InstanceBindLensCommand = InstanceBindLensCommand - { commandUri :: Uri - , commandUid :: Int} + { -- |The URI needed to run actions in the command + commandUri :: Uri + -- |The specific TextEdit we want to apply. This does not include the + -- pragma edit which is computed in the rule + , commandEdit :: TextEdit } deriving (Generic, FromJSON, ToJSON) +-- | The InstanceBindLens rule is specifically for code lenses. It relies on +-- the InstanceBindTypeSigs rule, filters out irrelevant matches and signatures +-- that can't be matched to a source span. It provides all the signatures linked +-- to a unique ID to aid in resolving. It also provides a list of enabled +-- extensions. data GetInstanceBindLens = GetInstanceBindLens deriving (Generic, Show, Eq, Ord, Hashable, NFData) data InstanceBindLens = InstanceBindLens - { lensRange :: [(Range, Int)] - , lensRendered :: IntMap.IntMap TextEdit + { -- |What we need to provide the code lens. The range linked with + -- a unique ID that will allow us to resolve the rest of the data later + lensRange :: [(Range, Int)] + -- |Provides the necessary data to allow us to display the + -- title of the lens and compute a TextEdit for it. + , lensDetails :: IntMap.IntMap (Range, Name, Type) + -- |Provides currently enabled extensions, allowing us to conditionally + -- insert needed extensions. , lensEnabledExtensions :: [Extension] } @@ -129,32 +145,25 @@ getInstanceBindLensRule recorder = do , bind <- getBindSpanWithoutSig inst ] targetSigs = matchBind bindInfos allBinds - rangeIntText <- liftIO $ mapMaybeM getRangeWithSig targetSigs - let lensRange = (\(range, int, _) -> (range, int)) <$> rangeIntText - lensRendered = IntMap.fromList $ (\(range, int, text) -> (int, TextEdit range text)) <$> rangeIntText + rangeIntNameType <- liftIO $ mapMaybeM getRangeWithSig targetSigs + let lensRange = (\(range, int, _, _) -> (range, int)) <$> rangeIntNameType + lensDetails = IntMap.fromList $ (\(range, int, name, typ) -> (int, (range, name, typ))) <$> rangeIntNameType lensEnabledExtensions = getExtensions $ tmrParsed tmr pure $ InstanceBindLensResult $ InstanceBindLens{..} where -- 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] -> [Maybe (InstanceBindTypeSig, SrcSpan)] matchBind existedBinds allBindWithSigs = - [foldl go bindSig existedBinds | bindSig <- allBindWithSigs] + [firstJust (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 + go :: InstanceBindTypeSig -> BindInfo -> Maybe (InstanceBindTypeSig, SrcSpan) + go bindSig bind = do + range <- (srcSpanToRange . bindNameSpan) bind + if inRange range (getSrcSpan $ bindName bindSig) + then Just (bindSig, bindSpan bind) + else Nothing getClsInstD (ClsInstD _ d) = Just d getClsInstD _ = Nothing @@ -184,13 +193,12 @@ getInstanceBindLensRule recorder = do getBindSpanWithoutSig _ = [] -- Get bind definition range with its rendered signature text - getRangeWithSig :: InstanceBindTypeSig -> IO (Maybe (Range, Int, T.Text)) - getRangeWithSig bind = runMaybeT $ do - span <- hoistMaybe $ bindDefSpan bind - range <- hoistMaybe $ srcSpanToRange span + getRangeWithSig :: Maybe (InstanceBindTypeSig, SrcSpan) -> IO (Maybe (Range, Int, Name, Type)) + getRangeWithSig (Just (bind, span)) = runMaybeT $ do + range <- MaybeT . pure $ srcSpanToRange span uniqueID <- liftIO $ hashUnique <$> newUnique - pure (range, uniqueID, bindRendered bind) - + pure (range, uniqueID, bindName bind, bindType bind) + getRangeWithSig Nothing = pure Nothing getInstanceBindTypeSigsRule :: Recorder (WithPriority Log) -> Rules () @@ -200,16 +208,12 @@ getInstanceBindTypeSigsRule recorder = do (hscEnv -> hsc) <- useMT GhcSession nfp let binds = collectHsBindsBinders $ tcg_binds gblEnv (_, maybe [] catMaybes -> instanceBinds) <- liftIO $ - initTcWithGbl hsc gblEnv ghostSpan $ traverse (bindToSig hsc gblEnv) binds + initTcWithGbl hsc gblEnv ghostSpan $ traverse bindToSig binds pure $ InstanceBindTypeSigsResult instanceBinds where - rdrEnv gblEnv= tcg_rdr_env gblEnv - showDoc hsc gblEnv ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc (rdrEnv gblEnv)) (pprSigmaType ty) - bindToSig hsc gblEnv id = do + bindToSig id = do let name = idName id whenMaybe (isBindingName name) $ do env <- tcInitTidyEnv let (_, ty) = tidyOpenType env (idType id) - pure $ InstanceBindTypeSig name - (prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc hsc gblEnv ty)) - Nothing + pure $ InstanceBindTypeSig name ty diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs index 164d75ddc4..129251ffe5 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -39,6 +39,10 @@ prettyBindingNameString name toMethodName $ T.drop (T.length bindingPrefix) name | otherwise = name +showDoc :: HscEnv -> TcGblEnv -> Type -> String +showDoc hsc gblEnv ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc (rdrEnv gblEnv)) (pprSigmaType ty) + where rdrEnv gblEnv = tcg_rdr_env gblEnv + -- | Paren the name for pretty display if necessary toMethodName :: T.Text -> T.Text toMethodName n From 285df2ebd906e5fb724562a27a349104ac195174 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 31 Aug 2023 16:06:31 +0300 Subject: [PATCH 4/4] Fix comment in Types.hs --- plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index 0b81dc430e..9f4e5185a8 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -77,7 +77,7 @@ data InstanceBindLensCommand = InstanceBindLensCommand { -- |The URI needed to run actions in the command commandUri :: Uri -- |The specific TextEdit we want to apply. This does not include the - -- pragma edit which is computed in the rule + -- pragma edit which is computed in the command , commandEdit :: TextEdit } deriving (Generic, FromJSON, ToJSON)