GitLab

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		-10
	1	+25