Hannes Siebenhandl pushed to branch wip/fendor/has-field-hie at Glasgow Haskell Compiler / GHC Commits: f453b126 by fendor at 2026-08-11T11:13:11+02:00 WIP - - - - - 9 changed files: - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Utils.hs - − testsuite/tests/hiefile/should_run/HasFieldQueries - testsuite/tests/hiefile/should_run/HasFieldQueries.hs - testsuite/tests/hiefile/should_run/HasFieldQueries.stdout - testsuite/tests/hiefile/should_run/RecordDotTypes.stdout - testsuite/tests/hiefile/should_run/T23492.hs - testsuite/tests/hiefile/should_run/T23492.stdout Changes: ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Core.Class ( className, classSCSelIds ) import GHC.Core.Utils (exprType) import GHC.Core.TyCo.Rep (Type(TyConApp)) import GHC.Core.TyCon (TyCon(..)) -import GHC.Builtin.Names (hasFieldClassName, getFieldName) +import GHC.Builtin.Names (hasFieldClassName) import GHC.Core.ConLike ( conLikeName ) import GHC.Core.DataCon ( dataConWrapperType ) import GHC.Core.Type ( Type, ForAllTyFlag(..) ) @@ -687,21 +687,12 @@ hieEvIdsOfTerm :: EvTerm -> [EvId] -- Returns only EvIds satisfying relevantEvId hieEvIdsOfTerm = runFVSelectiveList isEvId . evTermFVs -evFreeVarsOfTermList :: EvTerm -> [Var] -evFreeVarsOfTermList (EvExpr e) = exprFreeVarsList e -evFreeVarsOfTermList _ = [] - -evDepsOfTermList :: EvTerm -> [EvId] -evDepsOfTermList e - | isHasFieldEvTerm e = evFreeVarsOfTermList e - | otherwise = evVarsOfTermList e - instance ToHie (EvBindContext (LocatedA TcEvBinds)) where toHie (EvBindContext sc sp (L span (EvBinds bs))) = concatMapM go $ bagToList bs where go evbind = do - let evDeps = evDepsOfTermList $ eb_rhs evbind + let evDeps = hieEvIdsOfTerm $ eb_rhs evbind depNames = EvBindDeps $ map varName evDeps concatM $ [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) @@ -731,7 +722,8 @@ instance ToHie (LocatedA HsWrapper) where (WpEvApp a) | isHasFieldEvTerm a -> -- concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a - pprTrace "HasField" (ppr (a, osp)) $ concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a + pprTrace "HasField" (ppr (a, osp)) $ + concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a | otherwise -> -- pprTrace "Not HasField" (ppr (a, osp)) $ concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -418,12 +418,11 @@ rnExpr (NegApp _ e _) rnExpr (HsGetField _ e f) = do { (getField, fv_getField) <- lookupSyntaxName getFieldName ; (e, fv_e) <- rnLExpr e - ; let f' = rnDotFieldOcc f - ; srcSpan <- getSrcSpanM + ; let f' = rnDotFieldOcc <$> f ; return ( mkExpandedExpr (HsGetField noExtField e f') - (mkGetField srcSpan getField e (fmap (unLoc . dfoLabel) f')) - , fv_e `plusFV` fv_getField ) } + (mkGetField getField e (fmap (unLoc . dfoLabel) f')) + , fv_e `plusFN` fv_getField ) } rnExpr (HsProjection _ fs) = do { (getField, fv_getField) <- lookupSyntaxName getFieldName @@ -2860,10 +2859,11 @@ rnHsIf p b1 b2 -- mkGetField arg field calculates a get_field @field arg expression. -- e.g. z.x = mkGetField z x = get_field @x z -mkGetField :: SrcSpan -> Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn -mkGetField srcSpan get_field arg (L _ (FieldLabelString field)) = +mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn +mkGetField get_field arg (L ann (FieldLabelString field)) = + pprTrace "mkGetField" (ppr ann <+> ppr field) -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast - genHsAppWith srcSpan (genAppTypeWith srcSpan (genHsVar get_field) (genHsTyLit field)) arg + genHsAppWith (getHasLoc ann) (genHsVar get_field `genAppType` genHsTyLit field) arg -- mkSetField a field b calculates a set_field @field expression. -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' to a on b"). ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -17,7 +17,7 @@ module GHC.Rename.Utils ( DeprecationWarnings(..), warnIfDeprecated, checkUnusedRecordWildcard, badQualBndrErr, typeAppErr, badFieldConErr, - wrapGenSpan, wrapGenSpan', genHsVar, genHsVarWith, genLHsVar, genHsApp, genHsAppWith, genHsApps, genHsApps', genHsExpApps, + wrapGenSpan, wrapGenSpan', wrapNoSpan, genHsVar, genHsVarWith, genLHsVar, genHsApp, genHsAppWith, genHsApps, genHsApps', genHsExpApps, genLHsApp, genAppType, genAppTypeWith, genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat, genVarPat, genWildPat, @@ -740,7 +740,7 @@ genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg genHsAppWith :: SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn -genHsAppWith srcSpan fun arg = HsApp noExtField (wrapSrcSpan srcSpan fun) arg +genHsAppWith srcSpan fun arg = HsApp noExtField (wrapGenSpan' srcSpan fun) arg genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn genLHsApp fun arg = wrapGenSpan (genHsApp fun arg) ===================================== testsuite/tests/hiefile/should_run/HasFieldQueries deleted ===================================== Binary files a/testsuite/tests/hiefile/should_run/HasFieldQueries and /dev/null differ ===================================== testsuite/tests/hiefile/should_run/HasFieldQueries.hs ===================================== @@ -1,6 +1,4 @@ {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} module Main where import TestUtils @@ -8,46 +6,43 @@ import GHC.Records import GHC.TypeLits import Data.Tree -class C a where - f :: a -> Char - -instance C Char where - f x = x - data Thing = Thing {field1 :: Char, field2 :: Bool} deriving (Show, Eq) foo :: Thing -> String foo t = show t.field1 ++ show t.field2 - -- ^ this is the point -point :: (Int,Int) -point = (21,17) - -bar :: Show x => x -> String -bar x = show [(1,x,A)] --- ^ this is the point' -point' :: (Int,Int) -point' = (21,33) - -add :: Num a => a -> a -> a -add x y = x + y - -testing (x :: Int) = - add (add x x) x - +-- ^ this is the point + testing2 (x :: Thing) = x.field1 +-- ^ this is the point +-- ^ this is the point + +data NestedThing = NestedThing { nested1 :: Thing } -data A = A deriving Show +nestedSig :: NestedThing -> Char +nestedSig n = n.nested1.field1 +-- ^ this is the point +-- ^ this is the point -data Another = Another +nestedNoSig n = n.nested1.field2 :: Bool +-- ^ this is the point +-- ^ this is the point -testing3 = (natSing :: SNat 0) + + +points = + [ (13,17) + , (16,25) + , (16,27) + , (23,17) + , (23,25) + , (27,20) + , (27,28) + ] main = do (df, hf) <- readTestHie "HasFieldQueries.hie" let refmap = generateReferencesMap $ getAsts $ hie_asts hf - explainEv df hf refmap point - - explainEv df hf refmap point' + traverse (explainEv df hf refmap) points return () ===================================== testsuite/tests/hiefile/should_run/HasFieldQueries.stdout ===================================== @@ -1,34 +1,109 @@ ========================== -At point (21,17), we found: +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: [field1] +│ is an evidence variable bound by a let, depending on: [C:HasField] │ with scope: ModuleScope │ │ Defined at <no location info> └ | `- ┌ - │ field1 at HasFieldQueries.hs:1:1, of type: Thing -> Char + │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a │ is a usage of an external evidence variable - │ Defined at HasFieldQueries.hs:17:21 + │ Defined in `GHC.Internal.Records' └ ========================== -At point (21,33), we found: +At point (16,25), we found: +========================== +========================== +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] +│ with scope: LocalScope HasFieldQueries.hs:16:1-32 +│ bound at: HasFieldQueries.hs:16:1-32 +│ Defined at <no location info> +└ +| +`- ┌ + │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a + │ is a usage of an external evidence variable + │ Defined in `GHC.Internal.Records' + └ + +========================== +At point (23,17), we found: ========================== ┌ -│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field2" Thing Bool -│ is an evidence variable bound by a let, depending on: [field2] +│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "nested1" NestedThing Thing +│ is an evidence variable bound by a let, depending on: [C:HasField] │ with scope: ModuleScope │ │ Defined at <no location info> └ | `- ┌ - │ field2 at HasFieldQueries.hs:1:1, of type: Thing -> Bool + │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a │ is a usage of an external evidence variable - │ Defined at HasFieldQueries.hs:17:37 + │ Defined in `GHC.Internal.Records' + └ + +========================== +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] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ +| +`- ┌ + │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a + │ is a usage of an external evidence variable + │ Defined in `GHC.Internal.Records' + └ + +========================== +At point (27,20), we found: +========================== +┌ +│ $dHasField at HasFieldQueries.hs:27:1-40, of type: HasField "nested1" r r +│ is an evidence variable bound by a let, depending on: [$dHasField] +│ with scope: LocalScope HasFieldQueries.hs:27:1-40 +│ bound at: HasFieldQueries.hs:27:1-40 +│ Defined at <no location info> +└ +| +`- ┌ + │ $dHasField at HasFieldQueries.hs:27:1-40, of type: HasField "nested1" r r + │ is an evidence variable bound by a type signature + │ with scope: LocalScope HasFieldQueries.hs:27:1-40 + │ bound at: HasFieldQueries.hs:27:1-40 + │ Defined at <no location info> + └ + +========================== +At point (27,28), we found: +========================== +┌ +│ $dHasField at HasFieldQueries.hs:27:1-40, of type: HasField "field2" r Bool +│ is an evidence variable bound by a let, depending on: [$dHasField] +│ with scope: LocalScope HasFieldQueries.hs:27:1-40 +│ bound at: HasFieldQueries.hs:27:1-40 +│ Defined at <no location info> +└ +| +`- ┌ + │ $dHasField at HasFieldQueries.hs:27:1-40, of type: HasField "field2" r Bool + │ is an evidence variable bound by a type signature + │ with scope: LocalScope HasFieldQueries.hs:27:1-40 + │ bound at: HasFieldQueries.hs:27:1-40 + │ Defined at <no location info> └ ===================================== testsuite/tests/hiefile/should_run/RecordDotTypes.stdout ===================================== @@ -1,14 +1,5 @@ At (22,6), got type: MyRecord -At (22,20), got type: Integer -MyRecord -> Integer -forall {k} (x :: k) r a. HasField x r a => r -> a -forall (x :: Symbol) r a. HasField x r a => r -> a +At (22,20), got type: MyRecord -> Integer At (22,25), got type: MyRecord -At (22,28), got type: String -MyChild -> String -forall {k} (x :: k) r a. HasField x r a => r -> a -forall (x :: Symbol) r a. HasField x r a => r -> a -At (22,29), got type: String -MyChild -> String -forall {k} (x :: k) r a. HasField x r a => r -> a -forall (x :: Symbol) r a. HasField x r a => r -> a +At (22,28), got type: MyChild -> String +At (22,29), got type: MyChild -> String ===================================== testsuite/tests/hiefile/should_run/T23492.hs ===================================== @@ -24,12 +24,20 @@ g x = x.a -- ^^^ -- 345 -p1, p2, p3, p4, p5 :: (Int,Int) +h :: PartialFieldSelector -> Bool +h x = (.a) x +-- ^^ ^ +-- 67 8 + +p1, p2, p3, p4, p5, p6, p7, p8 :: (Int,Int) p1 = (13,20) p2 = (18,7) p3 = (23,7) p4 = (23,8) p5 = (23,9) +p6 = (28,8) +p7 = (28,9) +p8 = (28,12) selectPoint' :: HieFile -> (Int,Int) -> HieAST Int selectPoint' hf loc = @@ -37,7 +45,7 @@ selectPoint' hf loc = main = do (df, hf) <- readTestHie "T23492.hie" - forM_ [p1,p2,p3,p4,p5] $ \point -> do + forM_ [p1,p2,p3,p4,p5,p6,p7,p8] $ \point -> do putStr $ "At " ++ show point ++ ", got type: " let types = concatMap nodeType $ getSourcedNodeInfo $ sourcedNodeInfo $ selectPoint' hf point forM_ types $ \typ -> do ===================================== testsuite/tests/hiefile/should_run/T23492.stdout ===================================== @@ -4,4 +4,7 @@ PartialFieldSelector At (18,7), got type: PartialFieldSelector -> Bool At (23,7), got type: PartialFieldSelector At (23,8), got type: PartialFieldSelector -At (23,9), got type: Bool +At (23,9), got type: PartialFieldSelector -> Bool +At (28,8), got type: PartialFieldSelector -> Bool +At (28,9), got type: PartialFieldSelector -> Bool +At (28,12), got type: PartialFieldSelector View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f453b12681a5846712b8b9ed85eb2c38... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f453b12681a5846712b8b9ed85eb2c38... 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