diff --git a/hls-class-plugin.cabal b/hls-class-plugin.cabal --- a/hls-class-plugin.cabal +++ b/hls-class-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-class-plugin -version: 2.2.0.0 +version: 2.3.0.0 synopsis: Class/instance management plugin for Haskell Language Server @@ -39,10 +39,10 @@ , deepseq , extra , ghc - , ghcide == 2.2.0.0 + , ghcide == 2.3.0.0 , ghc-boot-th , hls-graph - , hls-plugin-api == 2.2.0.0 + , hls-plugin-api == 2.3.0.0 , lens , lsp , mtl @@ -75,7 +75,7 @@ , ghcide , hls-class-plugin , hls-plugin-api - , hls-test-utils == 2.2.0.0 + , hls-test-utils == 2.3.0.0 , lens , lsp-types , row-types diff --git a/src/Ide/Plugin/Class.hs b/src/Ide/Plugin/Class.hs --- a/src/Ide/Plugin/Class.hs +++ b/src/Ide/Plugin/Class.hs @@ -10,9 +10,10 @@ 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] @@ -20,5 +21,5 @@ = [ 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/src/Ide/Plugin/Class/CodeAction.hs b/src/Ide/Plugin/Class/CodeAction.hs --- a/src/Ide/Plugin/Class/CodeAction.hs +++ b/src/Ide/Plugin/Class/CodeAction.hs @@ -106,6 +106,8 @@ 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 @@ $ 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 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 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/src/Ide/Plugin/Class/CodeLens.hs b/src/Ide/Plugin/Class/CodeLens.hs --- a/src/Ide/Plugin/Class/CodeLens.hs +++ b/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.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 - 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 +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 - pure $ InL codeLens +-- 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 + (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) + 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 - workspaceEdit pragmaInsertion edits = +-- 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 [(uri, edits ++ pragmaInsertion)]) + (pure [(commandUri, commandEdit : 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 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 -> [] -codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit -codeLensCommandHandler _ wedit = do - _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - pure $ InR Null + diff --git a/src/Ide/Plugin/Class/Types.hs b/src/Ide/Plugin/Class/Types.hs --- a/src/Ide/Plugin/Class/Types.hs +++ b/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 (MaybeT, runMaybeT)) import Data.Aeson -import Data.Maybe (catMaybes) -import qualified Data.Text as T +import qualified Data.IntMap as IntMap +import Data.List.Extra (firstJust) +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, + VersionedTextDocumentIdentifier) typeLensCommandId :: CommandId typeLensCommandId = "classplugin.typelens" @@ -41,14 +50,15 @@ } 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 = @@ -62,6 +72,46 @@ type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult +-- |The necessary data to execute our code lens +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 command + , 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 + { -- |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] + } + +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 +131,89 @@ -- ^ 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 + tmr@(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 + 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 - 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] -> [Maybe (InstanceBindTypeSig, SrcSpan)] + matchBind existedBinds allBindWithSigs = + [firstJust (go bindSig) existedBinds | bindSig <- allBindWithSigs] where - rdrEnv = tcg_rdr_env gblEnv - showDoc ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc rdrEnv) (pprSigmaType ty) + 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 - 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 + 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 :: 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, bindName bind, bindType bind) + getRangeWithSig Nothing = pure Nothing + + +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 binds + pure $ InstanceBindTypeSigsResult instanceBinds + where + bindToSig id = do + let name = idName id + whenMaybe (isBindingName name) $ do + env <- tcInitTidyEnv + let (_, ty) = tidyOpenType env (idType id) + pure $ InstanceBindTypeSig name ty diff --git a/src/Ide/Plugin/Class/Utils.hs b/src/Ide/Plugin/Class/Utils.hs --- a/src/Ide/Plugin/Class/Utils.hs +++ b/src/Ide/Plugin/Class/Utils.hs @@ -39,6 +39,10 @@ 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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -10,8 +10,8 @@ ( 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 @@ [ testCase "Has code lens" $ do runSessionWithServer def 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 @@ , testCase "No lens for TH" $ do runSessionWithServer def 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 @@ , testCase "keep stale lens" $ do runSessionWithServer def 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 @@ goldenCodeLens :: TestName -> FilePath -> Int -> TestTree goldenCodeLens title path idx = goldenWithHaskellDoc def 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)