Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: e691e401 by Apoorv Ingle at 2026-11-02T20:24:08-06:00 lookup ifThenElse while expanding HsIf TH splice with Rebindable syntax enabled - - - - - 8 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Utils/Monad.hs - testsuite/tests/th/T18102b.stdout Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -57,6 +57,7 @@ import GHC.Core.Type import GHC.Builtin.WiredIn.Types (mkTupleStr) import GHC.Tc.Utils.TcType (TcType) import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv) +import GHC.Unit.Module.Name ( ModuleName ) import GHCi.RemoteTypes ( ForeignRef ) import qualified GHC.Boot.TH.Monad as TH (Q) @@ -684,7 +685,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) + | ReSynBindsRn ModuleName (HsExpr GhcRn) data XXExprGhcTc ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -2616,14 +2616,14 @@ 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 +repReSynBindsE :: ModuleName -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) +repReSynBindsE mod (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)) + MkC s <- lift $ coreStringLit (moduleNameFS mod) rep2_nw mkModNameOcc [s] repDoBlock :: KnownOcc -> Maybe HsModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -47,7 +47,7 @@ import GHC.Builtin.KnownKeys import GHC.Builtin.KnownOccs import GHC.Builtin.WiredIn.Types ( nilDataConName, oneDataConName ) -import GHC.Unit.Module ( isInteractiveModule ) +import GHC.Unit.Module ( isInteractiveModule, hsModuleName ) import GHC.Types.Basic (TypeOrKind (TypeLevel)) import GHC.Types.FieldLabel @@ -610,7 +610,7 @@ rnExpr (HsFunArr _ mult arg res) rnExpr (XExpr (ReSynBindsPs m e)) = do { traceRn "XExpr ReSynBinds" (text "module:" <+> ppr m) ; (e', fvs) <- rnExpr e - ; return (XExpr (ReSynBindsRn m e'), fvs) + ; return (XExpr (ReSynBindsRn (hsModuleName m) e'), fvs) } {- ===================================== compiler/GHC/Tc/Gen/Expand.hs ===================================== @@ -25,12 +25,14 @@ import GHC.Types.SourceText ( SourceText(..) ) import GHC.Builtin.KnownOccs import GHC.Builtin.WiredIn.Ids ( leftSectionName, rightSectionName ) import GHC.Rename.Utils +import GHC.Rename.Env ( lookupOccRnNone ) 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 Data.Maybe ( isJust ) import qualified GHC.LanguageExtensions as LangExt import GHC.Builtin.KnownKeys (getFieldClassOpOcc) @@ -162,10 +164,22 @@ tcExpand e@(OpApp _ arg1 op arg2) -- NoRebindable <=> rebindable is turned off -- so we typecheck the HsIf in tcExprNoExpand -tcExpand (HsIf NoRebindable _ _ _ ) - = return Nothing +tcExpand e@(HsIf NoRebindable p b1 b2 ) + = do { isRebindableOn <- getThRebindableSyntax + -- Check if we are actually expanding a template haskell generated spliced-in expression + -- and the original expression was typed in a rebindable context + ; if isJust isRebindableOn + then do + { ifThenElseName <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse")) + -- This ought to pass as ifThenElse would be added into the enviornment + -- by the setThRebindableSyntax call below + ; return $ Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2] } + } + else return Nothing } tcExpand e@(HsIf (Rebindable rs_table) p b1 b2) - | Just ifThenElseName <- lookup (rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse")) rs_table + | Just ifThenElseName <- lookup (rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse")) rs_table = return $ Just $ HSE { hse_ctxt = ExprCtxt e , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2] @@ -288,11 +302,13 @@ tcExpand e@(HsUntypedSplice splice_res _) ------------------------ -- XExpr -tcExpand e@(XExpr (ReSynBindsRn _ inner_e)) - = do { -- set environment variable to be in rebindable syntax - -- add the required rebindable syntax binding names into the environment - -- try expanding inner_e - traceTc "tcExpand: ReSynBindsRn" (ppr e) +tcExpand e@(XExpr (ReSynBindsRn m inner_e)) + = setThRebindableSyntax m $ + -- set environment variable to be in rebindable syntax + -- add the required rebindable syntax binding names into the environment + do { + -- now try expanding inner_e + ; traceTc "tcExpand: ReSynBindsRn" (ppr e) ; e' <- tcExpand inner_e ; let expr = case e' of Just (HSE {hse_exp = expanded_e}) -> ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -715,11 +715,11 @@ tcTypedBracket rn_expr expr res_ty ; bracket_ty <- mkAppTy m_var <$> tcMetaKnownOccTy expTyConOcc -- wrap the expression with ReSynBinds if rebindable syntax is on in this module ; isRebindableSyntaxOn <- xoptM LangExt.RebindableSyntax - ; mname <- moduleName <$> getModule + ; mod <- moduleName <$> getModule ; let expr' = if isRebindableSyntaxOn - then case expr of { L loc e -> L loc (XExpr $ ReSynBindsRn (toHsModuleName mname) e) } + then case expr of { L loc e -> L loc (XExpr $ ReSynBindsRn mod e) } else expr - ; traceTc "tc_bracket rebindable wrap" (vcat [ppr isRebindableSyntaxOn, ppr mname]) + ; traceTc "tc_bracket rebindable wrap" (vcat [ppr isRebindableSyntaxOn, ppr mod]) ; 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. ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -12,6 +12,7 @@ module GHC.Tc.Types.LclEnv ( , getLclEnvRdrEnv , getLclEnvTcLevel , getLclEnvThLevel + , getLclEnvThRebindable , setLclEnvTcLevel , setLclEnvLoc , setLclEnvRdrEnv @@ -19,6 +20,8 @@ module GHC.Tc.Types.LclEnv ( , setLclEnvErrCtxt , setLclEnvThLevel , setLclEnvTypeEnv + , setLclEnvThRebindable + , unsetLclEnvThRebindable , modifyLclEnvTcLevel , setLclEnvHsCtxt @@ -53,6 +56,8 @@ import GHC.Tc.Types.TcRef import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.Constraint ( WantedConstraints ) +import GHC.Unit.Module.Name ( ModuleName ) + {- ************************************************************************ * * @@ -111,7 +116,10 @@ data TcLclCtxt -- We still need the unsullied global name env so that -- we can look up record field names - + tcl_th_rs :: Maybe ModuleName, -- Are we type checking a splice + -- declared with rebindable syntax enabled? + -- Nothing <=> No rebindable syntax + -- Just m <=> Rebindable syntax enabled in module m tcl_th_ctxt :: ThLevel, -- Template Haskell context tcl_th_bndrs :: ThBindEnv, -- and binder info -- The ThBindEnv records the TH binding level of in-scope Names @@ -135,6 +143,15 @@ setLclEnvThLevel l = modifyLclCtxt (\env -> env { tcl_th_ctxt = l }) getLclEnvThBndrs :: TcLclEnv -> ThBindEnv getLclEnvThBndrs = tcl_th_bndrs . tcl_lcl_ctxt +getLclEnvThRebindable :: TcLclEnv -> Maybe ModuleName +getLclEnvThRebindable = tcl_th_rs . tcl_lcl_ctxt + +setLclEnvThRebindable :: ModuleName -> TcLclEnv -> TcLclEnv +setLclEnvThRebindable mod = modifyLclCtxt (\env -> env {tcl_th_rs = Just mod} ) + +unsetLclEnvThRebindable :: TcLclEnv -> TcLclEnv +unsetLclEnvThRebindable = modifyLclCtxt (\env -> env {tcl_th_rs = Nothing} ) + getLclEnvArrowCtxt :: TcLclEnv -> ArrowCtxt getLclEnvArrowCtxt = tcl_arrow_ctxt . tcl_lcl_ctxt ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -129,6 +129,8 @@ module GHC.Tc.Utils.Monad( recordThUse, recordThNeededRuntimeDeps, keepAlive, getThLevel, getCurrentAndBindLevel, setThLevel, addModFinalizersWithLclEnv, + setThRebindableSyntax, unsetThRebindableSyntax, + getThRebindableSyntax, -- * Safe Haskell context recordUnsafeInfer, finalSafeMode, fixSafeInstances, @@ -476,6 +478,7 @@ initTcWithGbl hsc_env gbl_env loc do_this tcl_in_gen_code = False, tcl_err_ctxt = [], tcl_rdr = emptyLocalRdrEnv, + tcl_th_rs = Nothing, tcl_th_ctxt = topLevel, tcl_th_bndrs = emptyNameEnv, tcl_arrow_ctxt = NoArrowCtxt, @@ -2501,6 +2504,17 @@ addModFinalizersWithLclEnv mod_finalizers updTcRef th_modfinalizers_var $ \fins -> (lcl_env, mod_finalizers) : fins +setThRebindableSyntax :: ModuleName -> TcM a -> TcM a +setThRebindableSyntax m = updLclEnv (setLclEnvThRebindable m) + +-- TODO: ANI we probably won't need the unset bit +unsetThRebindableSyntax :: TcM a -> TcM a +unsetThRebindableSyntax = updLclEnv (unsetLclEnvThRebindable) + +getThRebindableSyntax :: TcM (Maybe ModuleName) +getThRebindableSyntax = getLclEnvThRebindable <$> getLclEnv + + {- ************************************************************************ * * ===================================== testsuite/tests/th/T18102b.stdout ===================================== @@ -1 +1 @@ -10 +25 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e691e4013d439d446c6a5668da0ee52f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e691e4013d439d446c6a5668da0ee52f... 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