Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: c08de6dd by Apoorv Ingle at 2026-11-01T22:53:44-06:00 add ReSynBindsE, ReSynBindsRn and ReSynBindsTc - - - - - 15 changed files: - compiler/GHC/Builtin/TH.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs Changes: ===================================== compiler/GHC/Builtin/TH.hs ===================================== @@ -108,7 +108,7 @@ varEOcc, conEOcc, litEOcc, appEOcc, appTypeEOcc, infixAppOcc, sectionLOcc, unboxedSumEOcc, condEOcc, multiIfEOcc, letEOcc, caseEOcc, doEOcc, mdoEOcc, compEOcc, staticEOcc, unboundVarEOcc, labelEOcc, implicitParamVarEOcc, getFieldEOcc, projectionEOcc, typeEOcc, forallEOcc, forallVisEOcc, - constrainedEOcc :: KnownOcc + constrainedEOcc, resynbindEOcc :: KnownOcc varEOcc = mkVarOcc "varE" conEOcc = mkVarOcc "conE" litEOcc = mkVarOcc "litE" @@ -152,6 +152,7 @@ typeEOcc = mkVarOcc "typeE" forallEOcc = mkVarOcc "forallE" forallVisEOcc = mkVarOcc "forallVisE" constrainedEOcc = mkVarOcc "constrainedE" +resynbindEOcc = mkVarOcc "reSynBindsE" -- type FieldExp = ... fieldExpOcc :: KnownOcc ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -666,7 +666,7 @@ type instance XXExpr GhcTc = XXExprGhcTc ********************************************************************* -} data XXExprGhcPs - = ReSynBinds HsModuleName (HsExpr GhcPs) + = ReSynBindsPs HsModuleName (HsExpr GhcPs) -- See Note [Rebindable syntax and XXExprGhcRn] @@ -684,6 +684,7 @@ data XXExprGhcRn | HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector -- See Note [Non-overloaded record field selectors] and -- Note [Record selectors in the AST] + | ReSynBindsRn HsModuleName (HsExpr GhcRn) data XXExprGhcTc @@ -714,6 +715,7 @@ data XXExprGhcTc | HsRecSelTc (FieldOcc GhcTc) -- ^ Variable pointing to record selector -- See Note [Non-overloaded record field selectors] and -- Note [Record selectors in the AST] + | ReSynBindsTc HsModuleName (HsExpr GhcTc) {- ********************************************************************* * * @@ -1039,7 +1041,7 @@ ppr_expr (XExpr x) = case ghcPass @p of GhcTc -> ppr x instance Outputable XXExprGhcPs where - ppr (ReSynBinds m e) = text "{{" <+> ppr m <+> text "}}" <+> ppr e + ppr (ReSynBindsPs m e) = text "{{" <+> ppr m <+> text "}}" <+> ppr e ppr_hse :: forall p. (IsPass p) => HsExpansion (GhcPass p) -> SDoc ppr_hse hse @@ -1061,6 +1063,7 @@ ppr_hse hse instance Outputable XXExprGhcRn where ppr (HsRecSelRn f) = pprPrefixOcc f ppr (ExpandedThingRn hse) = ppr_hse hse + ppr (ReSynBindsRn m e) = text "{{" <+> ppr m <+> text "}}" <+> ppr e instance Outputable XXExprGhcTc where @@ -1088,6 +1091,8 @@ instance Outputable XXExprGhcTc where ppr exp, text ")"] ppr (HsRecSelTc f) = pprPrefixOcc f + ppr (ReSynBindsTc m e) = text "{{" <+> ppr m <+> text "}}" <+> ppr e + ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) ppr_infix_expr (HsHole x) = Just $ pprInfixOcc $ case (ghcPass @p, x) of @@ -1102,11 +1107,12 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of ppr_infix_expr _ = Nothing ppr_infix_expr_ps :: XXExprGhcPs -> Maybe SDoc -ppr_infix_expr_ps (ReSynBinds{}) = Nothing +ppr_infix_expr_ps (ReSynBindsPs{}) = Nothing ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc ppr_infix_expr_rn (ExpandedThingRn (HSE thing _)) = ppr_infix_hs_expansion thing ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f) +ppr_infix_expr_rn (ReSynBindsRn _ e) = ppr_infix_expr e ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc ppr_infix_expr_tc (WrapExpr _ e) = ppr_infix_expr e @@ -1115,6 +1121,7 @@ ppr_infix_expr_tc (ConLikeTc con) = Just (pprInfixOcc (conLikeName co ppr_infix_expr_tc (HsTick {}) = Nothing ppr_infix_expr_tc (HsBinTick {}) = Nothing ppr_infix_expr_tc (HsRecSelTc f) = Just (pprInfixOcc f) +ppr_infix_expr_tc (ReSynBindsTc _ e) = ppr_infix_expr e ppr_infix_hs_expansion :: HsCtxt -> Maybe SDoc ppr_infix_hs_expansion (ExprCtxt e) = ppr_infix_expr e @@ -1199,7 +1206,7 @@ hsExprNeedsParens prec = go GhcRn -> go_x_rn x go_x_ps :: XXExprGhcPs -> Bool - go_x_ps (ReSynBinds _ e) = hsExprNeedsParens prec e + go_x_ps (ReSynBindsPs _ e) = hsExprNeedsParens prec e go_x_tc :: XXExprGhcTc -> Bool go_x_tc (WrapExpr _ e) = hsExprNeedsParens prec e @@ -1208,10 +1215,12 @@ hsExprNeedsParens prec = go go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e go_x_tc (HsRecSelTc{}) = False + go_x_tc (ReSynBindsTc _ e) = hsExprNeedsParens prec e go_x_rn :: XXExprGhcRn -> Bool go_x_rn (ExpandedThingRn (HSE thing _)) = hsExpandedNeedsParens thing go_x_rn (HsRecSelRn{}) = False + go_x_rn (ReSynBindsRn _ e) = hsExprNeedsParens prec e hsExpandedNeedsParens :: HsCtxt -> Bool hsExpandedNeedsParens (ExprCtxt e) = hsExprNeedsParens prec e @@ -1260,10 +1269,12 @@ isAtomicHsExpr (XExpr x) go_x_tc (HsTick {}) = False go_x_tc (HsBinTick {}) = False go_x_tc (HsRecSelTc{}) = True + go_x_tc (ReSynBindsTc _ e) = isAtomicHsExpr e go_x_rn :: XXExprGhcRn -> Bool go_x_rn (ExpandedThingRn (HSE thing _)) = isAtomicExpandedThingRn thing go_x_rn (HsRecSelRn{}) = True + go_x_rn (ReSynBindsRn _ e) = isAtomicHsExpr e isAtomicExpandedThingRn :: HsCtxt -> Bool isAtomicExpandedThingRn (ExprCtxt e) = isAtomicHsExpr e @@ -2388,7 +2399,7 @@ type instance XTypBr GhcPs = (EpToken "[t|", EpUniToken "|]" "⟧") type instance XVarBr GhcPs = EpaLocation type instance XXQuote GhcPs = DataConCantHappen -type instance XExpBr GhcRn = NoExtField +type instance XExpBr GhcRn = NoExtField -- TODO ANI: What if we add the module name here? type instance XPatBr GhcRn = NoExtField type instance XDecBrL GhcRn = NoExtField type instance XDecBrG GhcRn = NoExtField ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -170,6 +170,7 @@ hsExprType (XExpr (ConLikeTc con)) = conLikeType con hsExprType (XExpr (HsTick _ e)) = lhsExprType e hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e hsExprType (XExpr (HsRecSelTc (FieldOcc _ id))) = idType (unLoc id) +hsExprType (XExpr (ReSynBindsTc _ e)) = hsExprType e arithSeqInfoType :: ArithSeqInfo GhcTc -> Type arithSeqInfoType asi = mkListTy $ case asi of ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -310,6 +310,10 @@ dsExpr e@(XExpr ext_expr_tc) ConLikeTc {} -> dsApp e ExpandedThingTc (HSE _ e) -> dsLExpr e + ReSynBindsTc m e -> + do + tracePm "dsExpr XExpr" (ppr m) + dsExpr e --TODO ANI: This should never happen? -- Hpc Support HsTick tickish e -> do @@ -570,7 +574,9 @@ dsExpr (RecordCon { rcon_con = L _ con_like -- Template Haskell stuff -- See Note [The life cycle of a TH quotation] -dsExpr (HsTypedBracket bracket_tc _) = dsBracket bracket_tc +dsExpr (HsTypedBracket bracket_tc _) = do + tracePm "dsExpr:dsBracket typed bracket" empty + dsBracket bracket_tc dsExpr (HsUntypedBracket bracket_tc _) = dsBracket bracket_tc dsExpr (HsTypedSplice _ s) = pprPanic "dsExpr:typed splice" (pprTypedSplice Nothing s) dsExpr (HsUntypedSplice ext _) = dataConCantHappen ext ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1763,6 +1763,9 @@ repE e@(XExpr (ExpandedThingRn (HSE o x))) | otherwise = notHandled (ThExpressionForm e) repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x)) +repE (XExpr (ReSynBindsRn m e)) = do + e' <- repE e + repReSynBindsE m e' repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e) repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e) repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e) @@ -2613,6 +2616,16 @@ repDoE = repDoBlock doEOcc repMDoE :: Maybe HsModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) repMDoE = repDoBlock mdoEOcc +repReSynBindsE :: HsModuleName -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repReSynBindsE m (MkC e) = do + MkC coreModName <- coreModNameM + krep2 resynbindEOcc [coreModName, e] + where + coreModNameM :: MetaM (Core TH.ModName) + coreModNameM = do + MkC s <- lift $ coreStringLit (moduleNameFS (hsModuleName m)) + rep2_nw mkModNameOcc [s] + repDoBlock :: KnownOcc -> Maybe HsModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) repDoBlock doName maybeModName (MkC ss) = do MkC coreModName <- coreModNameM ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -708,6 +708,9 @@ addTickHsExpr (XExpr (HsBinTick t0 t1 e)) = liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e) addTickHsExpr e@(XExpr (HsRecSelTc (FieldOcc _ id))) = do freeVar (unLoc id); return e +addTickHsExpr (XExpr (ReSynBindsTc m e)) = + liftM (XExpr . ReSynBindsTc m) (addTickHsExpr e) + addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1377,6 +1377,8 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where HsBinTick _ _ expr -> [ toHie expr ] + ReSynBindsTc _ _ + -> [] HsRecSelTc fld -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) ] ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -607,10 +607,10 @@ rnExpr (HsFunArr _ mult arg res) _ -> False oneType = noLocA $ HsVar noExtField $ noLocA $ noUserRdr oneDataConName -rnExpr (XExpr (ReSynBinds m e')) +rnExpr (XExpr (ReSynBindsPs m e)) = do { traceRn "XExpr ReSynBinds" (text "module:" <+> ppr m) - ; rnExpr e' -- for now just return the renamed expression - -- TODO: Bring into scope top level environment of the module m + ; (e', fvs) <- rnExpr e + ; return (e', fvs) } {- ===================================== compiler/GHC/Tc/Gen/Expand.hs ===================================== @@ -287,6 +287,7 @@ tcExpand e@(HsUntypedSplice splice_res _) ------------------------ -- XExpr + -- Expansions are idempotent, XExprs do not expand again tcExpand (XExpr (ExpandedThingRn hse)) = return $ Just hse ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -767,6 +767,11 @@ tcExprNoExpand (ArithSeq _ witness seq) res_ty tcExprNoExpand (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty tcExprNoExpand e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty tcExprNoExpand e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty +tcExprNoExpand (XExpr (ReSynBindsRn m e)) res_ty + = do { traceTc "XExpr ReSynBinds" (text "module:" <+> ppr m) + ; e' <- tcExpr e res_ty + ; return $ XExpr (ReSynBindsTc m e') + } {- ************************************************************************ ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -713,7 +713,14 @@ tcTypedBracket rn_expr expr res_ty ; ps' <- readMutVar ps_var ; codeco <- tcLookupKnownOccId unsafeCodeCoerceOcc ; bracket_ty <- mkAppTy m_var <$> tcMetaKnownOccTy expTyConOcc - ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr, hsb_ty = bracket_ty + -- wrap the expression with ReSynBinds if rebindable syntax is on in this module + ; isRebindableSyntaxOn <- xoptM LangExt.RebindableSyntax + ; mname <- moduleName <$> getModule + ; let expr' = if isRebindableSyntaxOn + then case expr of { L loc e -> L loc (XExpr $ ReSynBindsRn (toHsModuleName mname) e) } + else expr + ; traceTc "tc_bracket rebindable wrap" (vcat [ppr isRebindableSyntaxOn, ppr mname]) + ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr', hsb_ty = bracket_ty , hsb_wrap = Just wrapper, hsb_splices = ps' } -- The tc_expr is stored here so that the expression can be used in HIE files. brack_expr = HsTypedBracket brack_tc tc_expr ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -639,6 +639,7 @@ exprCtOrigin (RecordUpd{}) = RecordUpdOrigin exprCtOrigin (HsGetField _ _ f) = GetFieldOrigin (fmap (mkFastStringShortText . field_label) $ dfoLabel (unLoc f)) exprCtOrigin (XExpr (ExpandedThingRn (HSE o _))) = hsCtxtCtOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) +exprCtOrigin (XExpr (ReSynBindsRn _ e)) = exprCtOrigin e hsCtxtCtOrigin :: HsCtxt -> CtOrigin hsCtxtCtOrigin (ExprCtxt (ExprWithTySig _ (L _ e) _)) = exprCtOrigin e ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1096,6 +1096,10 @@ zonkExpr (XExpr (HsRecSelTc (FieldOcc occ (L l v)))) = do { v' <- zonkIdOcc v ; return (XExpr (HsRecSelTc (FieldOcc occ (L l v')))) } +zonkExpr (XExpr (ReSynBindsTc m e)) + = do e' <- zonkExpr e + return $ (XExpr (ReSynBindsTc m e')) + zonkExpr (RecordUpd x _ _) = dataConCantHappen x zonkExpr (HsGetField x _ _) = dataConCantHappen x zonkExpr (HsProjection x _) = dataConCantHappen x ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1229,7 +1229,7 @@ cvtl e = wrapLA (cvt e) mkHsForAllVisTele noAnn tvs' ; return $ HsForAll noExtField tele body' } cvt (ReSynBindsE m e) = do { e' <- cvt e - ; return $ XExpr (ReSynBinds (mk_modtext m) e') } + ; return $ XExpr (ReSynBindsPs (mk_modtext m) e') } {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example: ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs ===================================== @@ -438,6 +438,8 @@ forallVisE tvars body = ForallVisE <$> sequenceA tvars <*> body constrainedE :: Quote m => [m Exp] -> m Exp -> m Exp constrainedE ctx body = ConstrainedE <$> sequenceA ctx <*> body +reSynBindsE :: Quote m => ModName -> m Exp -> m Exp +reSynBindsE m e = ReSynBindsE m <$> e ------------------------------------------------------------------------------- -- * Dec View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c08de6ddecb5f2170a4148b0213f1157... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c08de6ddecb5f2170a4148b0213f1157... 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