hls-class-plugin 2.2.0.0 → 2.3.0.0
raw patch · 7 files changed
+246/−174 lines, 7 filesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
Files
- hls-class-plugin.cabal +4/−4
- src/Ide/Plugin/Class.hs +3/−2
- src/Ide/Plugin/Class/CodeAction.hs +16/−14
- src/Ide/Plugin/Class/CodeLens.hs +66/−110
- src/Ide/Plugin/Class/Types.hs +145/−36
- src/Ide/Plugin/Class/Utils.hs +4/−0
- test/Main.hs +8/−8
hls-class-plugin.cabal view
@@ -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
src/Ide/Plugin/Class.hs view
@@ -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) ]
src/Ide/Plugin/Class/CodeAction.hs view
@@ -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)
src/Ide/Plugin/Class/CodeLens.hs view
@@ -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+
src/Ide/Plugin/Class/Types.hs view
@@ -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 _ = "<InstanceBindLens>"++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
src/Ide/Plugin/Class/Utils.hs view
@@ -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
test/Main.hs view
@@ -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)