diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 3123c15003..4cd3866c8e 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -334,6 +334,7 @@ module Development.IDE.GHC.Compat.Core ( module GHC.Tc.Instance.Family, module GHC.Tc.Module, + module GHC.Tc.TyCl.Class, module GHC.Tc.Types, module GHC.Tc.Types.Evidence, module GHC.Tc.Utils.Env, @@ -445,6 +446,7 @@ import GHC.Rename.Splice import qualified GHC.Runtime.Interpreter as GHCi import GHC.Tc.Instance.Family import GHC.Tc.Module +import GHC.Tc.TyCl.Class import GHC.Tc.Types import GHC.Tc.Types.Evidence hiding ((<.>)) import GHC.Tc.Utils.Env diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8d5b72412a..ff106ab1f6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -358,7 +358,6 @@ library hls-class-plugin , hls-plugin-api == 2.14.0.0 , lens , lsp - , mtl , text , transformers diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 15a9fe0f02..299bead53b 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 "Provides code actions and lenses for working with typeclasses") { pluginCommands = commands plId - , pluginRules = getInstanceBindTypeSigsRule recorder >> getInstanceBindLensRule recorder + , pluginRules = getClassInstancesRule recorder >> getInstanceBindLensRule recorder , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder) <> mkPluginHandler SMethod_TextDocumentCodeLens codeLens <> mkResolveHandler SMethod_CodeLensResolve codeLensResolve 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 959da19d3a..58e3959034 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -10,44 +10,36 @@ module Ide.Plugin.Class.CodeAction ( codeAction, ) where -import Control.Arrow ((>>>)) -import Control.Lens hiding (List, use) -import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Arrow ((>>>)) +import Control.Lens hiding (List, use) import Control.Monad.Extra -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe -import Data.Aeson hiding (Null) +import Data.Aeson hiding (Null) import Data.List -import Data.List.Extra (nubOrdOn) -import qualified Data.Map.Strict as Map -import Data.Maybe (isNothing, listToMaybe, - mapMaybe) -import qualified Data.Set as Set -import qualified Data.Text as T +import Data.List.Extra (nubOrdOn) +import Data.Maybe (listToMaybe, mapMaybe) +import qualified Data.Text as T import Development.IDE -import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.PositionMapping (fromCurrentRange) import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Error (TcRnMessage (..), - _TcRnMessage, - msgEnvelopeErrorL, - stripTcRnMessageContext) +import Development.IDE.GHC.Compat.Error (TcRnMessage (..), + _TcRnMessage, + msgEnvelopeErrorL, + stripTcRnMessageContext) import Development.IDE.GHC.Compat.Util -import Development.IDE.Spans.AtPoint (pointCommand) -import GHC.Iface.Ext.Types (ContextInfo (..), - HieAST (..), Identifier, - IdentifierDetails (..)) import Ide.Plugin.Class.ExactPrint import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils import qualified Ide.Plugin.Config import Ide.Plugin.Error +import qualified Ide.Plugin.RangeMap as RangeMap import Ide.PluginUtils import Ide.Types -import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -109,31 +101,28 @@ codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do -> (FileDiagnostic, ClassMinimalDef) -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction] mkActions docPath verTxtDocId (diag, classMinDef) = do - (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state - $ useWithStaleE GetHieAst docPath - instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $ - fromCurrentRange pmap range ^? _Just . L.start - & fmap (L.character -~ 1) - ident <- findClassIdentifier ast instancePosition - cls <- findClassFromIdentifier docPath ident - InstanceBindTypeSigsResult sigs <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state - $ useE GetInstanceBindTypeSigs docPath - (tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath + ClassInstancesResult instMap <- runActionE "classplugin.codeAction.GetClassInstances" state + $ useE GetClassInstances docPath + inst <- handleMaybe (PluginInvalidUserState "no instance at diagnostic range") + $ listToMaybe (RangeMap.filterByRange range instMap) + (tmrTypechecked -> gblEnv) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath (hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath - logWith recorder Debug (LogImplementedMethods (hsc_dflags hsc) cls classMinDef) + logWith recorder Debug (LogImplementedMethods (hsc_dflags hsc) (instClass inst) classMinDef) pure $ concatMap mkAction $ nubOrdOn snd $ filter ((/=) mempty . snd) - $ mkMethodGroups hsc gblEnv range sigs classMinDef + $ mkMethodGroups hsc gblEnv inst classMinDef where range = diag ^. fdLspDiagnosticL . L.range - mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup] - mkMethodGroups hsc gblEnv range sigs classMinDef = minimalDef <> [allClassMethods] + mkMethodGroups :: HscEnv -> TcGblEnv -> InstanceInfo -> ClassMinimalDef -> [MethodGroup] + mkMethodGroups hsc gblEnv inst classMinDef = minimalDef <> [allClassMethods] where - minimalDef = minDefToMethodGroups hsc gblEnv range sigs classMinDef - allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs) + methods = instMethods inst + minimalDef = minDefToMethodGroups hsc gblEnv methods classMinDef + allClassMethods = + ("all missing methods", map (makeMethodDefinition hsc gblEnv) methods) mkAction :: MethodGroup -> [Command |? CodeAction] mkAction (name, methods) @@ -164,36 +153,6 @@ codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do (Just cmd) Nothing - findClassIdentifier hf instancePosition = - handleMaybe (PluginInternalError "No Identifier found") - $ listToMaybe - $ mapMaybe listToMaybe - $ pointCommand hf instancePosition - ( (Map.keys . Map.filterWithKey isClassNodeIdentifier . getNodeIds) - <=< nodeChildren - ) - - findClassFromIdentifier docPath (Right name) = do - (hscEnv -> hscenv, _) <- runActionE "classplugin.findClassFromIdentifier.GhcSessionDeps" state - $ useWithStaleE GhcSessionDeps docPath - (tmrTypechecked -> thisMod, _) <- runActionE "classplugin.findClassFromIdentifier.TypeCheck" state - $ useWithStaleE TypeCheck docPath - handleMaybeM (PluginInternalError "initTcWithGbl failed") - . liftIO - . fmap snd - . initTcWithGbl hscenv thisMod ghostSpan $ do - tcthing <- tcLookup name - case tcthing of - AGlobal (AConLike (RealDataCon con)) - | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls - _ -> fail "Ide.Plugin.Class.findClassFromIdentifier" - findClassFromIdentifier _ (Left _) = throwError (PluginInternalError "Ide.Plugin.Class.findClassIdentifier") - --- see https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Types.Name.Occurrence.html#mkClassDataConOcc -isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool -isClassNodeIdentifier (Right i) ident | 'C':':':_ <- unpackFS $ occNameFS $ occName i = (isNothing . identType) ident && Use `Set.member` identInfo ident -isClassNodeIdentifier _ _ = False - isClassMethodWarning :: StructuredMessage -> Maybe ClassMinimalDef isClassMethodWarning message = case message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of Nothing -> Nothing @@ -209,36 +168,29 @@ type MethodName = T.Text type MethodDefinition = (MethodName, MethodSignature) type MethodGroup = (T.Text, [MethodDefinition]) -makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition -makeMethodDefinition hsc gblEnv sig = (name, signature) +makeMethodDefinition :: HscEnv -> TcGblEnv -> (Name, Type) -> MethodDefinition +makeMethodDefinition hsc gblEnv (name, ty) = (nameTxt, signature) where - name = T.drop (T.length bindingPrefix) (printOutputable (bindName sig)) - signature = prettyBindingNameString (printOutputable (bindName sig)) <> " :: " <> T.pack (showDoc hsc gblEnv (bindType sig)) - -makeMethodDefinitions :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition] -makeMethodDefinitions hsc gblEnv range sigs = - [ makeMethodDefinition hsc gblEnv sig - | sig <- sigs - , inRange range (getSrcSpan $ bindName sig) - ] - -signatureToName :: InstanceBindTypeSig -> T.Text -signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig)) - --- Return [groupName text, [(methodName text, signature text)]] -minDefToMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup] -minDefToMethodGroups hsc gblEnv range sigs minDef = makeMethodGroup <$> go minDef + -- nameTxt is bare (no parens); ExactPrint.makeMethodDecl applies + -- toMethodName to wrap operators when emitting the placeholder. + nameTxt = printOutputable name + signature = toMethodName nameTxt <> " :: " <> T.pack (showDoc hsc gblEnv ty) + +minDefToMethodGroups :: HscEnv -> TcGblEnv -> [(Name, Type)] -> ClassMinimalDef -> [MethodGroup] +minDefToMethodGroups hsc gblEnv methods minDef = makeMethodGroup <$> go minDef where makeMethodGroup methodDefinitions = let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions in (name, methodDefinitions) + matchMethod n = + map (makeMethodDefinition hsc gblEnv) + $ filter ((== n) . fst) methods #if __GLASGOW_HASKELL__ >= 913 - go (Var lmn) = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable (unLoc lmn)) . signatureToName) sigs + go (Var lmn) = pure $ matchMethod (unLoc lmn) #else - go (Var mn) = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable mn) . signatureToName) sigs + go (Var mn) = pure $ matchMethod mn #endif go (Or ms) = concatMap (go . unLoc) ms go (And ms) = foldr (liftA2 (<>) . 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 9410469516..3143f5ff5c 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -50,7 +50,7 @@ codeLensResolve state plId cl uri uniqueID = do (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) + let title = toMethodName (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 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 1669aba43d..a64e87e69e 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -8,14 +8,13 @@ module Ide.Plugin.Class.Types where import Control.DeepSeq (rwhnf) -import Control.Monad.Extra (mapMaybeM, whenMaybe) +import Control.Monad.Extra (mapMaybeM) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Control.Monad.Trans.Maybe (runMaybeT) import Data.Aeson import qualified Data.IntMap as IntMap -import Data.List.Extra (firstJust) -import Data.Maybe (catMaybes, mapMaybe, - maybeToList) +import Data.Maybe (fromMaybe, listToMaybe, + mapMaybe, maybeToList) import qualified Data.Text as T import Data.Unique (hashUnique, newUnique) import Development.IDE @@ -26,6 +25,7 @@ import Development.IDE.GHC.Compat.Util (bagToList) import Development.IDE.Graph.Classes import GHC.Generics import Ide.Plugin.Class.Utils +import qualified Ide.Plugin.RangeMap as RangeMap import Ide.Types import Language.LSP.Protocol.Types (TextEdit, VersionedTextDocumentIdentifier) @@ -49,27 +49,33 @@ 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 +-- | Indexes the instances declared in a module by their source span, giving +-- each instance's class and the full instantiated type of every class method. +-- Both the placeholder code action (to enumerate missing methods) and the +-- code lens (to display inferred signatures) consume this rule. +data GetClassInstances = GetClassInstances deriving (Generic, Show, Eq, Ord, Hashable, NFData) -data InstanceBindTypeSig = InstanceBindTypeSig - { bindName :: Name - , bindType :: Type +data InstanceInfo = InstanceInfo + { instSpan :: SrcSpan + -- ^ Source span of the instance declaration. + , instClass :: Class + , instMethods :: [(Name, Type)] + -- ^ Each class method paired with its type instantiated for this + -- instance, including any instance context (e.g. @Eq a@ for + -- @instance Eq a => C [a]@). } -newtype InstanceBindTypeSigsResult = - InstanceBindTypeSigsResult [InstanceBindTypeSig] +newtype ClassInstancesResult = + ClassInstancesResult (RangeMap.RangeMap InstanceInfo) -instance Show InstanceBindTypeSigsResult where - show _ = "" +instance Show ClassInstancesResult where + show _ = "" -instance NFData InstanceBindTypeSigsResult where +instance NFData ClassInstancesResult where rnf = rwhnf -type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult +type instance RuleResult GetClassInstances = ClassInstancesResult -- |The necessary data to execute our code lens data InstanceBindLensCommand = InstanceBindLensCommand @@ -80,11 +86,10 @@ data InstanceBindLensCommand = InstanceBindLensCommand , 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. +-- | The InstanceBindLens rule is specifically for code lenses. It correlates +-- user-written instance method bindings (those without an explicit signature) +-- to the instance's 'InstanceInfo', and emits range/name/type triples with +-- unique IDs for resolve. data GetInstanceBindLens = GetInstanceBindLens deriving (Generic, Show, Eq, Ord, Hashable, NFData) @@ -123,11 +128,14 @@ instance Pretty Log where <+> pretty (showSDoc dflags $ ppr methods) LogShake log -> pretty log +-- | A user-written instance binding without an explicit signature. The 'Name' +-- is the renamer-level method name (e.g. @(==)@), used to look up the +-- instance-level type in 'instMethods'. data BindInfo = BindInfo - { bindSpan :: SrcSpan + { bindSpan :: SrcSpan -- ^ SrcSpan of the whole binding - , bindNameSpan :: SrcSpan - -- ^ SrcSpan of the binding name + , bindFunName :: Name + -- ^ The renamed method name of the binding. } getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules () @@ -138,35 +146,34 @@ getInstanceBindLensRule recorder = do #else tmr@(tmrRenamed -> (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp #endif - (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 + ClassInstancesResult instMap <- useMT GetClassInstances nfp + + let -- Correlate renamed ClsInstDecls with their InstanceInfo by source + -- span (the only link between the renamed tree and tcg_insts), then + -- collect user-written bindings that lack an explicit signature. + entries = + [ (bind, ty) + | instds <- map group_instds tycls + , instd <- instds + , inst <- maybeToList $ getClsInstD (unLoc instd) + , info <- maybeToList $ do + instdRange <- srcSpanToRange (getLocA instd) + listToMaybe (RangeMap.elementsInRange instdRange instMap) + , bind <- getBindSpanWithoutSig inst + , ty <- maybeToList (lookup (bindFunName bind) (instMethods info)) + ] + rangeIntNameType <- liftIO $ mapMaybeM tagEntry entries let lensRange = (\(range, int, _, _) -> (range, int)) <$> rangeIntNameType - lensDetails = IntMap.fromList $ (\(range, int, name, typ) -> (int, (range, name, typ))) <$> 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] -> [Maybe (InstanceBindTypeSig, SrcSpan)] - matchBind existedBinds allBindWithSigs = - [firstJust (go bindSig) existedBinds | bindSig <- allBindWithSigs] - where - 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 + tagEntry (bind, ty) = case srcSpanToRange (bindSpan bind) of + Nothing -> pure Nothing + Just r -> do + uniqueID <- hashUnique <$> newUnique + pure $ Just (r, uniqueID, bindFunName bind, ty) getClsInstD (ClsInstD _ d) = Just d getClsInstD _ = Nothing @@ -183,52 +190,54 @@ getInstanceBindLensRule recorder = do 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 + -- `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 - - -- 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 + existingSigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs + toBindInfo (L l (L _ n)) = BindInfo (locA l) n + in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` existingSigNames) bindNames + +getClassInstancesRule :: Recorder (WithPriority Log) -> Rules () +getClassInstancesRule recorder = do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetClassInstances nfp -> runMaybeT $ do + (tmrTypechecked -> gblEnv) <- useMT TypeCheck nfp (hscEnv -> hsc) <- useMT GhcSession nfp - let binds = collectHsBindsBinders $ tcg_binds gblEnv - (_, maybe [] catMaybes -> instanceBinds) <- liftIO $ + (_, mInfos) <- liftIO $ initTcWithGbl hsc gblEnv ghostSpan #if MIN_VERSION_ghc(9,7,0) $ liftZonkM #endif - $ traverse bindToSig binds - pure $ InstanceBindTypeSigsResult instanceBinds + $ mkInfos gblEnv + pure $ ClassInstancesResult $ RangeMap.fromList' + $ mapMaybe (\i -> (,i) <$> srcSpanToRange (instSpan i)) (fromMaybe [] mInfos) where - bindToSig id = do - let name = idName id - whenMaybe (isBindingName name) $ do - env <- tcInitTidyEnv + mkInfos gblEnv = do + env <- tcInitTidyEnv + pure $ map (mkInfo env) (tcg_insts gblEnv) + + mkInfo env inst = do + -- forall tvs. theta => cls tys + let (_tvs, theta, cls, tys) = instanceSig inst + -- Canonicalise internal GHC type-variable names (e.g. a_1 -> a). + tidy ty = #if MIN_VERSION_ghc(9,11,0) - let ty = + tidyOpenType env ty #else - let (_, ty) = + snd (tidyOpenType env ty) #endif - tidyOpenType env (idType id) - pure $ InstanceBindTypeSig name ty + -- `instantiateMethod` substitutes the instance head types into + -- the method's type and drops the leading class predicate, but + -- not the instance's own constraints (`theta`). Re-prepend them + -- so we get every method's full instantiated type. + mkMeth m = (idName m, tidy (mkInvisFunTys theta (instantiateMethod cls m tys))) + InstanceInfo + { instSpan = getSrcSpan (is_dfun inst) + , instClass = cls + , instMethods = map mkMeth (classMethods cls) + } 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 ae4579d115..1677c08032 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -4,39 +4,18 @@ module Ide.Plugin.Class.Utils where import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except -import Data.Char (isAlpha, isDigit) -import Data.List (isPrefixOf) -import Data.String (IsString) +import Data.Char (isAlpha) import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Compat.Util (fsLit) import Development.IDE.Spans.Pragmas (getNextPragmaInfo, insertNewPragma) import Ide.Plugin.Error import Ide.PluginUtils import Language.LSP.Protocol.Types --- | All instance bindings are started with `$c` -bindingPrefix :: IsString s => s -bindingPrefix = "$c" - --- | Superclasses generate bindings in typeclasses as well. --- --- When determining which bindings to create placeholders for, these --- superclass-generated names need to be excluded. --- TODO: This function should be replaced by an equivalent one from GHC: --- https://gitlab.haskell.org/ghc/ghc/-/issues/27195 -isSuperClassesBindingPrefix :: String -> Bool -isSuperClassesBindingPrefix ('$' : 'c' : 'p' : n : _) | isDigit n = True -isSuperClassesBindingPrefix _ = False - -isBindingName :: Name -> Bool -isBindingName name = - let bindingName = occNameString $ nameOccName name - in isPrefixOf bindingPrefix bindingName && not (isSuperClassesBindingPrefix bindingName) - -- | Check if some `HasSrcSpan` value in the given range inRange :: Range -> SrcSpan -> Bool inRange range s = maybe False (subRange range) (srcSpanToRange s) @@ -44,13 +23,6 @@ inRange range s = maybe False (subRange range) (srcSpanToRange s) ghostSpan :: RealSrcSpan ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 --- | "$cname" ==> "name" -prettyBindingNameString :: T.Text -> T.Text -prettyBindingNameString name - | T.isPrefixOf bindingPrefix 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