Hannes Siebenhandl pushed to branch wip/fendor/has-field-hie at Glasgow Haskell Compiler / GHC Commits: 047ccb45 by fendor at 2026-09-17T11:55:40+02:00 Add additional details to evidence bindings Evidence bindings can be all sorts of things, such as tpe class evidence, a record selector or other builtin constructs such as `Typeable`. For some special evidence binding dependencies, we can include additional information for the user. For example, when we have a record selector, we can say from which type the record selector originates from. - - - - - 6a08787c by fendor at 2026-09-17T11:55:40+02:00 Typeable test - - - - - 8 changed files: - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Iface/Ext/Utils.hs - testsuite/tests/hiefile/should_run/HasFieldQueries.stdout - + testsuite/tests/hiefile/should_run/HieTypeable.hs - + testsuite/tests/hiefile/should_run/HieTypeable.stdout - testsuite/tests/hiefile/should_run/NoFieldSelectorQueries.stdout - testsuite/tests/hiefile/should_run/all.T Changes: ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -32,7 +32,8 @@ import GHC.Types.Basic import GHC.Types.UnresolvedImport ( isGeneratedImport ) import GHC.Types.FieldLabel import GHC.Types.Avail ( Avails ) -import GHC.Types.Id ( isDataConId_maybe, isId ) +import GHC.Types.Id ( isDataConId_maybe, isId, idDetails ) +import GHC.Types.Id.Info ( IdDetails(..), recSelParentName ) import GHC.Types.Name ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe, getName ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.Name.Reader ( RecFieldInfo(..), WithUserRdr(..) ) @@ -689,7 +690,7 @@ instance ToHie (EvBindContext (LocatedA TcEvBinds)) where where go evbind = do let evDeps = hieEvIdsOfTerm $ eb_rhs evbind - depNames = EvBindDeps $ map varName evDeps + depNames = EvBindDeps $ map classifyEvBindDep evDeps concatM $ [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) (L span $ eb_lhs evbind)) @@ -697,6 +698,12 @@ instance ToHie (EvBindContext (LocatedA TcEvBinds)) where ] toHie _ = pure [] +classifyEvBindDep :: EvId -> EvBindDep +classifyEvBindDep evId = + case idDetails evId of + RecSelId{sel_tycon} -> RecordField (varName evId) (recSelParentName sel_tycon) + _ -> EvidenceVar (varName evId) + instance ToHie (LocatedA HsWrapper) where toHie (L osp wrap) = case wrap of ===================================== compiler/GHC/Iface/Ext/Types.hs ===================================== @@ -598,17 +598,79 @@ instance Outputable EvVarSource where ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps +-- | Evidence binding dependency with additional details. +data EvBindDep + = EvidenceVar Name + -- ^ Evidence variable such as a type class constructor. + -- + -- For example, @C:HasField@, @$dShow@ (dictionaries) or @$fCList@. + -- + -- This is the default representation of a 'EvBindDep'. + | RecordField + -- ^ Evidence variable of a record selector. + -- + -- This is for example generated with @-XOverloadedRecordDot@, where + -- the evidence includes a reference to which record selector is used + -- to implement @getField@. + Name + -- ^ 'Name' of the record selector + Name + -- ^ 'Name' of the parent type. + | TypeableEvidence + -- ^ Evidence of a @Typeable@ constraint. + Name + -- ^ Name of the type the evidence was generated for. + deriving (Eq, Ord) + +instance Outputable EvBindDep where + ppr = \ case + EvidenceVar n -> ppr n + RecordField sel parent -> ppr sel <+> text "of Record" <+> ppr parent + TypeableEvidence n -> ppr n <+> text "bound by Typeable" + +evBindDepName :: EvBindDep -> Name +evBindDepName = \ case + EvidenceVar n -> n + RecordField selector _record -> selector + TypeableEvidence n -> n + +evBindDepHieName :: EvBindDep -> HieName +evBindDepHieName = toHieName . evBindDepName + +instance Binary EvBindDep where + put_ bh = \ case + EvidenceVar n -> do + putByte bh 0 + put_ bh n + RecordField n sel -> do + putByte bh 1 + put_ bh n + put_ bh sel + TypeableEvidence n -> do + putByte bh 2 + put_ bh n + + get bh = + getByte bh >>= \ case + 0 -> EvidenceVar <$> get bh + 1 -> RecordField <$> get bh <*> get bh + 2 -> TypeableEvidence <$> get bh + t -> fail $ "EvBindDep: Unknown tag: " ++ show t + -- | Eq/Ord instances compare on the converted HieName, -- as non-exported names may have different uniques after -- a roundtrip -newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] } +newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [EvBindDep] } deriving Outputable +evBindDepsNames :: EvBindDeps -> [Name] +evBindDepsNames = map evBindDepName . getEvBindDeps + instance Eq EvBindDeps where - (==) = coerce ((==) `on` map toHieName) + (==) = coerce ((==) `on` map evBindDepHieName) instance Ord EvBindDeps where - compare = coerce (compare `on` map toHieName) + compare = coerce (compare `on` map evBindDepHieName) instance Binary EvBindDeps where put_ bh (EvBindDeps xs) = put_ bh xs ===================================== compiler/GHC/Iface/Ext/Utils.hs ===================================== @@ -145,7 +145,7 @@ getEvidenceTree refmap var = go emptyNameSet var det <- S.toList $ identInfo dets case det of EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn -> - pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs) + pure $ Just ((src,scp,spn),mapMaybe (go (extendNameSet seen var) . evBindDepName) xs) EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[]) _ -> pure Nothing pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children @@ -390,7 +390,7 @@ definedInAsts asts n = case nameSrcSpan n of getEvidenceBindDeps :: ContextInfo -> [Name] getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) = - getEvBindDeps xs + evBindDepsNames xs getEvidenceBindDeps _ = [] isEvidenceBind :: ContextInfo -> Bool ===================================== testsuite/tests/hiefile/should_run/HasFieldQueries.stdout ===================================== @@ -4,7 +4,7 @@ At point (13,17), we found: ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char │ is an evidence variable bound by a let, depending on: [C:HasField, -│ field1] +│ field1 of Record Thing] │ with scope: ModuleScope │ │ Defined at <no location info> @@ -31,7 +31,7 @@ At point (16,27), we found: ┌ │ $dHasField at HasFieldQueries.hs:16:1-32, of type: HasField "field1" Thing Char │ is an evidence variable bound by a let, depending on: [C:HasField, -│ field1] +│ field1 of Record Thing] │ with scope: LocalScope HasFieldQueries.hs:16:1-32 │ bound at: HasFieldQueries.hs:16:1-32 │ Defined at <no location info> @@ -55,7 +55,7 @@ At point (23,17), we found: ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "nested1" NestedThing Thing │ is an evidence variable bound by a let, depending on: [C:HasField, -│ nested1] +│ nested1 of Record NestedThing] │ with scope: ModuleScope │ │ Defined at <no location info> @@ -87,7 +87,7 @@ At point (23,25), we found: `- ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char │ is an evidence variable bound by a let, depending on: [C:HasField, - │ field1] + │ field1 of Record Thing] │ with scope: ModuleScope │ │ Defined at <no location info> @@ -176,7 +176,7 @@ At point (37,14), we found: `- ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char │ is an evidence variable bound by a let, depending on: [C:HasField, - │ field1] + │ field1 of Record Thing] │ with scope: ModuleScope │ │ Defined at <no location info> @@ -200,7 +200,7 @@ At point (41,21), we found: ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "nested1" NestedThing Thing │ is an evidence variable bound by a let, depending on: [C:HasField, -│ nested1] +│ nested1 of Record NestedThing] │ with scope: ModuleScope │ │ Defined at <no location info> @@ -224,7 +224,7 @@ At point (41,30), we found: ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char │ is an evidence variable bound by a let, depending on: [C:HasField, -│ field1] +│ field1 of Record Thing] │ with scope: ModuleScope │ │ Defined at <no location info> ===================================== testsuite/tests/hiefile/should_run/HieTypeable.hs ===================================== @@ -0,0 +1,28 @@ +module Main where + +import Data.Dynamic +import Data.Typeable +import TestUtils + +data Thing = Thing {field1 :: Char, field2 :: Bool} + deriving (Show, Eq) + +castFromDynamic :: Dynamic -> Maybe Thing +castFromDynamic d = fromDynamic d + -- ^ this is the point + +rep :: Thing -> TypeRep +rep d = typeOf d + -- ^ this is the point + +points = + [ (11,21) + , (15,10) + ] + +main = do + (df, hf) <- readTestHie "HieTypeable.hie" + let refmap = generateReferencesMap $ getAsts $ hie_asts hf + + traverse (explainEv df hf refmap) points + return () ===================================== testsuite/tests/hiefile/should_run/HieTypeable.stdout ===================================== @@ -0,0 +1,30 @@ +========================== +At point (11,21), we found: +========================== +┌ +│ $dTypeable at HieTypeable.hs:1:1, of type: Typeable Thing +│ is an evidence variable bound by a let, depending on: [$dTypeable] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ +| +`- ┌ + │ $dTypeable at HieTypeable.hs:1:1, of type: Typeable Thing + │ is an evidence variable bound by a let, depending on: [] + │ with scope: ModuleScope + │ + │ Defined at <no location info> + └ + +========================== +At point (15,10), we found: +========================== +┌ +│ $dTypeable at HieTypeable.hs:1:1, of type: Typeable Thing +│ is an evidence variable bound by a let, depending on: [] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ + ===================================== testsuite/tests/hiefile/should_run/NoFieldSelectorQueries.stdout ===================================== @@ -4,7 +4,7 @@ At point (23,16), we found: ┌ │ $dHasField at NoFieldSelectorQueries.hs:1:1, of type: HasField "a" A Int │ is an evidence variable bound by a let, depending on: [C:HasField, -│ a] +│ a of Record A] │ with scope: ModuleScope │ │ Defined at <no location info> @@ -47,7 +47,7 @@ At point (30,15), we found: ┌ │ $dHasField at NoFieldSelectorQueries.hs:30:1-17, of type: HasField "n" B A │ is an evidence variable bound by a let, depending on: [C:HasField, -│ n] +│ n of Record B] │ with scope: LocalScope NoFieldSelectorQueries.hs:30:1-17 │ bound at: NoFieldSelectorQueries.hs:30:1-17 │ Defined at <no location info> @@ -71,7 +71,7 @@ At point (30,17), we found: ┌ │ $dHasField at NoFieldSelectorQueries.hs:30:1-17, of type: HasField "b" A Char │ is an evidence variable bound by a let, depending on: [C:HasField, -│ b] +│ b of Record A] │ with scope: LocalScope NoFieldSelectorQueries.hs:30:1-17 │ bound at: NoFieldSelectorQueries.hs:30:1-17 │ Defined at <no location info> @@ -95,7 +95,7 @@ At point (33,16), we found: ┌ │ $dHasField at NoFieldSelectorQueries.hs:33:1-16, of type: HasField "c" C Float │ is an evidence variable bound by a let, depending on: [C:HasField, -│ c] +│ c of Record C] │ with scope: LocalScope NoFieldSelectorQueries.hs:33:1-16 │ bound at: NoFieldSelectorQueries.hs:33:1-16 │ Defined at <no location info> @@ -119,7 +119,7 @@ At point (36,16), we found: ┌ │ $dHasField at NoFieldSelectorQueries.hs:36:1-16, of type: HasField "c" C Float │ is an evidence variable bound by a let, depending on: [C:HasField, -│ c] +│ c of Record C] │ with scope: LocalScope NoFieldSelectorQueries.hs:36:1-16 │ bound at: NoFieldSelectorQueries.hs:36:1-16 │ Defined at <no location info> @@ -143,7 +143,7 @@ At point (40,23), we found: ┌ │ $dHasField at NoFieldSelectorQueries.hs:1:1, of type: HasField "c" C Float │ is an evidence variable bound by a let, depending on: [C:HasField, -│ c] +│ c of Record C] │ with scope: ModuleScope │ │ Defined at <no location info> @@ -167,7 +167,7 @@ At point (43,15), we found: ┌ │ $dHasField at NoFieldSelectorQueries.hs:43:1-15, of type: HasField "e" C Int │ is an evidence variable bound by a let, depending on: [C:HasField, -│ e] +│ e of Record C] │ with scope: LocalScope NoFieldSelectorQueries.hs:43:1-15 │ bound at: NoFieldSelectorQueries.hs:43:1-15 │ Defined at <no location info> @@ -191,7 +191,7 @@ At point (46,15), we found: ┌ │ $dHasField at NoFieldSelectorQueries.hs:46:1-15, of type: HasField "e" C Int │ is an evidence variable bound by a let, depending on: [C:HasField, -│ e] +│ e of Record C] │ with scope: LocalScope NoFieldSelectorQueries.hs:46:1-15 │ bound at: NoFieldSelectorQueries.hs:46:1-15 │ Defined at <no location info> ===================================== testsuite/tests/hiefile/should_run/all.T ===================================== @@ -12,3 +12,4 @@ test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files([ test('T25709', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) test('HasFieldQueries', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) test('NoFieldSelectorQueries', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) +test('HieTypeable', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/edb461ac99ab714f296e2ebf19fca8d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/edb461ac99ab714f296e2ebf19fca8d... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help