Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: 0ceec1e3 by Apoorv Ingle at 2026-04-20T23:42:56-05:00 split tcExpand into two functions. Call Expansion in HsToCore.Quote - - - - - 7 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/TyCl/PatSyn.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -279,7 +279,7 @@ type instance XCase GhcRn = HsMatchContextRn type instance XCase GhcTc = HsMatchContextRn type instance XIf GhcPs = AnnsIf -type instance XIf GhcRn = Maybe RebindableSyntaxTable -- Nothing <=> RebindableSyntax is off +type instance XIf GhcRn = RebindableSyntaxTable -- NoRebindable <=> RebindableSyntax is off type instance XIf GhcTc = NoExtField type instance XMultiIf GhcPs = (EpToken "if", EpToken "{", EpToken "}") @@ -295,7 +295,7 @@ type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type type instance XExplicitList GhcPs = AnnList () -type instance XExplicitList GhcRn = Maybe RebindableSyntaxTable -- Nothing <=> RebindableSyntax is off +type instance XExplicitList GhcRn = RebindableSyntaxTable -- NoRebindable <=> RebindableSyntax is off type instance XExplicitList GhcTc = Type -- GhcPs: ExplicitList includes all source-level -- list literals, including overloaded ones @@ -310,7 +310,7 @@ type instance XRecordCon GhcRn = NoExtField type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function type instance XRecordUpd GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) -type instance XRecordUpd GhcRn = Maybe RebindableSyntaxTable -- Nothing <=> RebindableSyntaxTable is off +type instance XRecordUpd GhcRn = RebindableSyntaxTable -- NoRebindable <=> RebindableSyntaxTable is off type instance XRecordUpd GhcTc = DataConCantHappen -- We desugar record updates in the typechecker. -- See [Handling overloaded and rebindable constructs], @@ -1485,11 +1485,15 @@ type instance XXCmd GhcTc = HsWrap HsCmd type CmdSyntaxTable p = [(Name, HsExpr p)] -- See Note [CmdSyntaxTable] -type RebindableSyntaxTable = [(String, Name)] +data RebindableSyntaxTable = NoRebindable | Rebindable [(OccName, Name)] -- Stores the names of the operators for rebindable syntax -- eg. getField, setField etc. -- GHC.Tc.Expand will use these names to build the expansions +isNoRebindable :: RebindableSyntaxTable -> Bool +isNoRebindable NoRebindable = True +isNoRebindable Rebindable{} = False + {- Note [CmdSyntaxTable] ~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -340,6 +340,8 @@ deriving instance Data (RoleAnnotDecl GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Expr ----------------------------------- +deriving instance Data RebindableSyntaxTable -- maybe don't traverse? + deriving instance Data (FieldLabelStrings GhcPs) deriving instance Data (FieldLabelStrings GhcRn) deriving instance Data (FieldLabelStrings GhcTc) @@ -684,7 +686,6 @@ deriving instance Data (HsExpansion GhcTc) deriving instance Data a => Data (WithUserRdr a) -- ------------------------------- --------------------------------------- deriving instance Data XXExprGhcTc deriving instance Data XXPatGhcTc ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -44,6 +44,8 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.ErrCtxt import GHC.Tc.TyCl ( IsPrefixConGADT(..), unannotatedMultIsLinear ) +import GHC.Tc.Gen.Expand ( tcExpandNoTcM ) + import GHC.Core.Class import GHC.Core.DataCon import GHC.Core.TyCon @@ -1618,11 +1620,13 @@ repE (HsCase _ e (MG { mg_alts = (L _ ms) })) ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreListM matchTyConName ms2 ; repCaseE arg core_ms2 } -repE (HsIf _ x y z) = do - a <- repLE x - b <- repLE y - c <- repLE z - repCond a b c +repE e@(HsIf _ x y z) = case (tcExpandNoTcM e) of + Nothing -> do { a <- repLE x + ; b <- repLE y + ; c <- repLE z + ; repCond a b c } + Just (HSE _ (L _ e')) -> repE e' + repE (HsMultiIf _ alts) = do { (binds, alts') <- NE.unzip <$> mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList' alts') ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -344,7 +344,7 @@ rnExpr (HsHole h) -- HsOverLabel: see Note [Handling overloaded and rebindable constructs] rnExpr (HsOverLabel src v) = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName - ; let rs_table = [("fromLabel", from_label)] + ; let rs_table = Rebindable [(nameOccName fromLabelClassOpName, from_label)] ; return (HsOverLabel (src, rs_table) v, fvs) } @@ -416,14 +416,14 @@ rnExpr (HsGetField _ e f) = do { (getField, fv_getField) <- lookupSyntaxName getFieldName ; (e, fv_e) <- rnLExpr e ; let f' = rnDotFieldOcc <$> f - rs_table = [("getField", getField)] + rs_table = Rebindable [(nameOccName getFieldName, getField)] ; return (HsGetField rs_table e f', fv_e `plusFN` fv_getField) } rnExpr (HsProjection _ fs) = do { (getFieldName, fv_getField) <- lookupSyntaxName getFieldName ; circName <- lookupOccRn WL_TermVariable compose_RDR ; let fs' = NE.map rnDotFieldOcc fs - rs_table = [("getField" , getFieldName), ("circ", circName)] + rs_table = Rebindable [(nameOccName getFieldName , getFieldName), (rdrNameOcc compose_RDR, circName)] ; return (HsProjection rs_table fs', unitFN circName `plusFN` fv_getField) } ------------------------------------------ @@ -487,10 +487,10 @@ rnExpr (ExplicitList _ exps) = do { (exps', fvs) <- rnExprs exps ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; if not opt_OverloadedLists - then return (ExplicitList Nothing exps', fvs) + then return (ExplicitList NoRebindable exps', fvs) else do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; let rs_table = Just [("fromListN", from_list_n_name)] + ; let rs_table = Rebindable [(nameOccName fromListNName, from_list_n_name)] rn_list = ExplicitList rs_table exps' ; return ( rn_list , fvs `plusFN` fvs') } } @@ -536,7 +536,7 @@ rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds }) RegularRecUpdFields { xRecUpdFields = parents , recUpdFields = flds } - ; return ( RecordUpd Nothing (L l e) upd_flds + ; return ( RecordUpd NoRebindable (L l e) upd_flds , fv_e `plusFN` fv_flds ) } -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. @@ -554,7 +554,7 @@ rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds }) ; let upd_flds = OverloadedRecUpdFields { xOLRecUpdFields = noExtField , olRecUpdFields = us } - rs_table = Just [("getFieldName", getField) , ("setFieldName", setField)] + rs_table = Rebindable [(nameOccName getField, getField) , (nameOccName getField, setField)] ; return (RecordUpd rs_table (L l e) upd_flds , plusFNs [fv_getField, fv_setField, fv_e, fv_us] ) } @@ -2698,11 +2698,11 @@ rnHsIf p b1 b2 ; mb_ite <- lookupIfThenElse ; case mb_ite of Nothing -- Non rebindable-syntax case - -> return (HsIf Nothing p' b1' b2', fvs_if) + -> return (HsIf NoRebindable p' b1' b2', fvs_if) Just ite_name -- Rebindable-syntax case -> do { let fvs = plusFNs [fvs_if, unitFN ite_name] - ; return (HsIf (Just [("ifThenElse" , ite_name)]) p' b1' b2', fvs) } } + ; return (HsIf (Rebindable [(rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse"), ite_name)]) p' b1' b2', fvs) } } rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeNames) ===================================== compiler/GHC/Tc/Gen/Expand.hs ===================================== @@ -5,30 +5,34 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -module GHC.Tc.Gen.Expand( tcExpand ) where +module GHC.Tc.Gen.Expand( tcExpand, tcExpandNoTcM ) where import GHC.Prelude hiding (last, init, tail) - -import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) +import GHC.Data.FastString import GHC.Hs import GHC.Tc.Utils.Monad import GHC.Tc.Types.ErrCtxt import GHC.Tc.Gen.Do +import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Id.Make import GHC.Types.SrcLoc import GHC.Types.SourceText ( mkIntegralLit , SourceText(..) ) +import GHC.Builtin.Names + import GHC.Rename.Utils -import qualified Data.List.NonEmpty as NE ( map, head, (<|) ) -import Data.List.NonEmpty ( NonEmpty(..), init, last, tail ) import GHC.Utils.Panic import GHC.Utils.Outputable +import qualified Data.List.NonEmpty as NE ( map, head, (<|) ) +import Data.List.NonEmpty ( NonEmpty(..), init, last, tail ) + import qualified GHC.LanguageExtensions as LangExt {- Note [Typechecking by expansion: overview] @@ -116,14 +120,15 @@ Wrinkle (TBE1) -- See Note [Typechecking by expansion: overview] tcExpand :: HsExpr GhcRn -> TcM (Maybe (HsExpansion GhcRn)) +tcExpandNoTcM :: HsExpr GhcRn -> Maybe (HsExpansion GhcRn) ------------------------------------------ -- Overloaded labels -tcExpand e@(HsOverLabel (_, rs_table) v) - | Just fromLabelName <- lookup "fromLabel" rs_table +tcExpandNoTcM e@(HsOverLabel (_, Rebindable rs_table) v) + | Just fromLabelName <- lookup (nameOccName fromLabelClassOpName) rs_table , let hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $ HsTyLit noExtField (HsString NoSourceText v) - = return $ Just $ + = Just $ HSE { hse_ctxt = ExprCtxt e , hse_exp = wrapGenSpan $ HsAppType noExtField (genLHsVar fromLabelName) hs_ty_arg } @@ -134,26 +139,92 @@ tcExpand e@(HsOverLabel (_, rs_table) v) ------------------------------------------ -- Qualified Literals -tcExpand e@(HsQualLit _ QualLit{ql_val = ql_val, ql_ext = (L _ fromStringName)}) +tcExpandNoTcM e@(HsQualLit _ QualLit{ql_val = ql_val, ql_ext = (L _ fromStringName)}) = do { let hsLit = case ql_val of -- See Note [Implementation of QualifiedStrings] HsQualString st s -> HsString st s - ; return $ Just $ - HSE { hse_ctxt = ExprCtxt e - , hse_exp = wrapGenSpan $ genHsApps fromStringName [genLHsLit hsLit] - } + ; Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ genHsApps fromStringName [genLHsLit hsLit] + } } ------------------------------------------ -- Operator Applications -tcExpand e@(OpApp _ arg1 op arg2) - = return $ Just $ +tcExpandNoTcM e@(OpApp _ arg1 op arg2) + = Just $ HSE { hse_ctxt = ExprCtxt e , hse_exp = foldl ap op [arg1,arg2] } where ap f a = wrapGenSpan (HsApp noExtField f a) +------------------------------------------ +-- If + +-- NoRebindable <=> rebindable is turned off +-- so we typecheck the HsIf in tcExprNoExpand +tcExpandNoTcM (HsIf NoRebindable _ _ _ ) + = Nothing +tcExpandNoTcM e@(HsIf (Rebindable rs_table) p b1 b2) + | Just ifThenElseName <- lookup (rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse")) rs_table + = Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2] + } + | otherwise + = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find ifThenElse in rs_table" + , ppr e ]) + +------------------------------------------ +-- Record dot syntax + +tcExpandNoTcM e@(HsGetField (Rebindable rs_table) expr f) + | Just getField <- lookup (nameOccName getFieldName) rs_table + = Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ (mkGetField getField expr (fmap (unLoc . dfoLabel) f)) } + | otherwise + = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField in rs_table" + , ppr e ]) + +tcExpandNoTcM e@(HsProjection (Rebindable rs_table) fs) + | Just getField <- lookup (nameOccName getFieldName) rs_table + , Just circ <- lookup (rdrNameOcc compose_RDR) rs_table + = Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ (mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs) } + | otherwise + = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or circ in rs_table" + , ppr e]) + + +tcExpandNoTcM (RecordUpd NoRebindable _ _ ) = Nothing -- until #27160 is fixed + +tcExpandNoTcM e@(RecordUpd (Rebindable rs_table) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us})) + | Just getField <- lookup (nameOccName getFieldName) rs_table + , Just setField <- lookup (nameOccName setFieldName) rs_table + = Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ mkRecordDotUpd getField setField (L l expr) us } + | otherwise + = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or setfield in rs_table" + , ppr e ]) + + + +------------------------ +-- XExpr +-- Expansions are idempotent, XExprs do not expand again +tcExpandNoTcM (XExpr (ExpandedThingRn hse)) + = Just hse + + +tcExpandNoTcM _ + = Nothing + + + ------------------------------------------ -- Left and Right Sections @@ -174,15 +245,20 @@ tcExpand e@(SectionL _ expr op) HSE { hse_ctxt = ExprCtxt e , hse_exp = wrapGenSpan ds_section } } -tcExpand (ExplicitList Nothing _ ) +------------------------------------------ +-- Explicit Lists + +tcExpand (ExplicitList NoRebindable _ ) = return Nothing -- rebindable syntax is off -tcExpand e@(ExplicitList (Just rs_table) exps) - | Just from_list_n_name <- lookup "fromListN" rs_table +tcExpand e@(ExplicitList (Rebindable rs_table) exps) + | Just from_list_n_name <- lookup (nameOccName fromListNName) rs_table = do { loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] ; let lit_n = mkIntegralLit (length exps) hs_lit = genHsIntegralLit lit_n exp_list = genHsApps' (wrapGenSpan' loc from_list_n_name) - [hs_lit, wrapGenSpan (ExplicitList Nothing exps)] + [hs_lit, wrapGenSpan (ExplicitList NoRebindable exps)] + -- important to make it NoRebindable + -- Or we will go into an infinite loop ; return $ Just $ HSE { hse_ctxt = ExprCtxt e , hse_exp = wrapGenSpan $ exp_list } @@ -193,7 +269,7 @@ tcExpand e@(ExplicitList (Just rs_table) exps) ------------------------------------------ --- Do expression statements +-- Do statements tcExpand (HsDo _ do_or_lc stmts) | DoExpr{} <- do_or_lc @@ -214,66 +290,6 @@ tcExpand (HsDo _ do_or_lc stmts) -- GHCiStmts are handled completely separate = return Nothing ------------------------------------------- --- If - --- Nothing <=> rebindable is turned off --- so we typecheck the HsIf in tcExprNoExpand -tcExpand (HsIf Nothing _ _ _ ) - = return Nothing -tcExpand e@(HsIf (Just rs_table) p b1 b2) - | Just ifThenElseName <- lookup "ifThenElse" rs_table - = return $ Just $ - HSE { hse_ctxt = ExprCtxt e - , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2] - } - | otherwise - = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find ifThenElse in rs_table" - , ppr e ]) - ------------------------------------------- --- Record dot syntax - -tcExpand e@(HsGetField rs_table expr f) - | Just getFieldName <- lookup "getField" rs_table - = return $ Just $ - HSE { hse_ctxt = ExprCtxt e - , hse_exp = wrapGenSpan $ (mkGetField getFieldName expr (fmap (unLoc . dfoLabel) f)) } - | otherwise - = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField in rs_table" - , ppr e ]) - -tcExpand e@(HsProjection rs_table fs) - | Just getFieldName <- lookup "getField" rs_table - , Just circName <- lookup "circ" rs_table - = return $ Just $ - HSE { hse_ctxt = ExprCtxt e - , hse_exp = wrapGenSpan $ (mkProjection getFieldName circName $ NE.map (unLoc . dfoLabel) fs) } - | otherwise - = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or circ in rs_table" - , ppr e]) - - -tcExpand (RecordUpd Nothing _ _ ) = return Nothing -- until #27160 is fixed - -tcExpand e@(RecordUpd (Just rs_table) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us})) - | Just getFieldName <- lookup "getFieldName" rs_table - , Just setFieldName <- lookup "setFieldName" rs_table - = return $ Just $ - HSE { hse_ctxt = ExprCtxt e - , hse_exp = wrapGenSpan $ mkRecordDotUpd getFieldName setFieldName (L l expr) us } - | otherwise - = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or setfield in rs_table" - , ppr e ]) - - - ------------------------- --- XExpr --- Expansions are idempotent, XExprs do not expand again -tcExpand (XExpr (ExpandedThingRn hse)) - = return (Just hse) - ------------------------------------------ -- Template Haskell Splices @@ -281,10 +297,11 @@ tcExpand e@(HsUntypedSplice splice_res _) -- See Note [Looking through Template Haskell splices in splitHsApps] = do { fun <- getUntypedSpliceBody splice_res ; return $ Just $ - HSE { hse_ctxt = ExprCtxt e - , hse_exp = wrapGenSpan fun } } + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan fun } + } -tcExpand _ = return Nothing +tcExpand e = return $ tcExpandNoTcM e ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -445,7 +445,7 @@ tcExprNoExpand e@HsQualLit{} _ = pprPanic "tcExpr: HsQualLit" (ppr e) -- list type, so that's all we need concern ourselves with here. See -- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs] tcExprNoExpand (ExplicitList x exprs) res_ty - = assert (isNothing x) $ + = assert (isNoRebindable x) $ do { res_ty <- expTypeToType res_ty ; (coi, elt_ty) <- matchExpectedListTy res_ty ; let tc_elt expr = tcCheckPolyExpr expr elt_ty @@ -540,7 +540,7 @@ tcExprNoExpand (HsCase ctxt scrut matches) res_ty tcExprNoExpand (HsIf x pred b1 b2) res_ty -- HsIf in rebindable case would be expanded out so we would not -- have a Just RebindableSyntaxTable here, only Nothing - = assert (isNothing x) $ + = assert (isNoRebindable x) $ do { pred' <- tcCheckMonoExpr pred boolTy ; let res_ty' = adjustExpTypeForCaseBranches res_ty [b1,b2] ; (u1,b1') <- tcCollectingUsage $ tcMonoLExpr b1 res_ty' @@ -680,7 +680,7 @@ tcExprNoExpand expr@(RecordCon { rcon_con = L loc qcon@(WithUserRdr _ con_name) orig = OccurrenceOf con_name -- Record updates via dot syntax are replaced by expanded expressions --- in the renamer. See Note [Overview of record dot syntax] in +-- in GHC.Tc.Expand. See Note [Overview of record dot syntax] in -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. -- WIP: To be fixed soon (#27160) expandRecordUpd needs to return HsExpansion and not a separate ds_res_ty @@ -1644,7 +1644,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty RegularRecUpdFields { xRecUpdFields = parents , recUpdFields = rbnds } - , rupd_ext = Nothing } + , rupd_ext = NoRebindable } loc = getLocA (head rbnds) {- ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -1087,7 +1087,7 @@ tcPatToExpr args pat = go pat go1 (ParPat _ pat) = fmap (HsPar noExtField) (go pat) go1 (ListPat _ pats) = do { exprs <- mapM go pats - ; return $ ExplicitList Nothing exprs } + ; return $ ExplicitList NoRebindable exprs } go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExtField (map (Present noExtField) exprs) box } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ceec1e334fa838664b974883fbb3147... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ceec1e334fa838664b974883fbb3147... You're receiving this email because of your account on gitlab.haskell.org.