Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: 12e4592e by Apoorv Ingle at 2026-11-02T20:37:15-06:00 accept testcases hard_hole_fits template-haskell-exports - - - - - 1236f8a2 by Apoorv Ingle at 2026-11-03T13:18:21-06:00 do not lookup rebindable syntax functions from the RebindableSyntaxTable - - - - - 4 changed files: - compiler/GHC/Tc/Gen/Expand.hs - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/perf/compiler/hard_hole_fits.stderr Changes: ===================================== compiler/GHC/Tc/Gen/Expand.hs ===================================== @@ -25,14 +25,13 @@ 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.Rename.Env ( lookupOccRnNone, lookupSyntaxName ) 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) @@ -119,6 +118,9 @@ Wrinkle (TBE1) -} +ifThenElseOcc :: KnownOcc +ifThenElseOcc = rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse") + -- See Note [Typechecking by expansion: overview] tcExpand :: HsExpr GhcRn -> TcM (Maybe (HsExpansion GhcRn)) @@ -168,61 +170,55 @@ 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 - = 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 ]) + ; case isRebindableOn of + Just mod -> + do { ifThenElseName <- lookupOccRnNone (mkRdrQual mod ifThenElseOcc) + -- This ought to pass as ifThenElse would be added into the enviornment + -- by the setThRebindableSyntax call below (hopefully) + ; return $ Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2] } + } + _ -> return Nothing + } +tcExpand e@(HsIf (Rebindable _) p b1 b2) + = do { (ifThenElseName, _) <- lookupSyntaxName ifThenElseOcc + ; return $ Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2] + } + } + ------------------------------------------ -- Record dot syntax -tcExpand e@(HsGetField (Rebindable rs_table) expr f) - | Just getField <- lookup getFieldClassOpOcc rs_table - = return $ 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 ]) - -tcExpand e@(HsProjection (Rebindable rs_table) fs) - | Just getField <- lookup getFieldClassOpOcc rs_table - , Just circ <- lookup (rdrNameOcc compose_RDR) rs_table - = return $ 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]) - +tcExpand e@(HsGetField (Rebindable _) expr f) + = do { (getFieldName, _) <- lookupSyntaxName getFieldClassOpOcc + ; return $ Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ (mkGetField getFieldName expr (fmap (unLoc . dfoLabel) f)) } + } +tcExpand (HsGetField _ _ _) = return Nothing +tcExpand e@(HsProjection (Rebindable _) fs) + = do { (getFieldName, _) <- lookupSyntaxName getFieldClassOpOcc + ; (circName, _) <- lookupSyntaxName (rdrNameOcc compose_RDR) + ; return $ Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ (mkProjection getFieldName circName $ NE.map (unLoc . dfoLabel) fs) } + } +tcExpand (HsProjection _ _) = return Nothing + +tcExpand e@(RecordUpd (Rebindable _) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us})) + = do { + (getFieldName, _) <- lookupSyntaxName getFieldClassOpOcc + ; (setFieldName, _) <- lookupSyntaxName setFieldClassOpOcc + ; return $ Just $ + HSE { hse_ctxt = ExprCtxt e + , hse_exp = wrapGenSpan $ mkRecordDotUpd getFieldName setFieldName (L l expr) us } } tcExpand (RecordUpd NoRebindable _ _ ) = return Nothing -- until #27160 is fixed -tcExpand e@(RecordUpd (Rebindable rs_table) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us})) - | Just getField <- lookup getFieldClassOpOcc rs_table - , Just setField <- lookup setFieldClassOpOcc rs_table - = return $ 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 ]) - ------------------------------------------ -- Left and Right Sections @@ -306,6 +302,7 @@ 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) @@ -519,3 +516,24 @@ mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) where fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn fieldUpdate acc lpu = unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc) + + +---------------------------------------------------- +-- Template Haskell Splices with Rebindable Syntax + +-- We have a module name +-- We need to get the toplevel environment of that module +-- so that we can (implicitly) add it to the current module +-- and then type check the splice expression + +-- getExternalModIface :: Name -> TcM (Maybe ModIface) +-- getExternalModIface nm = do +-- isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm +-- if isLocal +-- then pure Nothing -- should not be reached, unless there is a circular dependency +-- else case nameModule_maybe nm of +-- Nothing -> pure Nothing +-- Just modNm -> do +-- hsc_env <- getTopEnv +-- iface <- liftIO $ hscGetModuleInterface hsc_env modNm +-- pure (Just iface) ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -128,6 +128,7 @@ module Language.Haskell.TH where | ForallE [TyVarBndr Specificity] Exp | ForallVisE [TyVarBndr ()] Exp | ConstrainedE [Exp] Exp + | ReSynBindsE GHC.Internal.TH.Syntax.ModName Exp type ExpQ :: * type ExpQ = Q Exp type Extension :: * @@ -1487,6 +1488,7 @@ module Language.Haskell.TH.Syntax where | ForallE [TyVarBndr Specificity] Exp | ForallVisE [TyVarBndr ()] Exp | ConstrainedE [Exp] Exp + | ReSynBindsE ModName Exp type Extension :: * data Extension = Cpp @@ -1914,6 +1916,7 @@ instance forall a. GHC.Boot.TH.Ppr.Ppr a => GHC.Boot.TH.Ppr.Ppr [a] -- Defined i instance GHC.Boot.TH.Ppr.Ppr GHC.Internal.TH.Syntax.Lit -- Defined in ‘GHC.Boot.TH.Ppr’ instance GHC.Boot.TH.Ppr.Ppr GHC.Internal.TH.Syntax.Loc -- Defined in ‘GHC.Boot.TH.Ppr’ instance GHC.Boot.TH.Ppr.Ppr GHC.Internal.TH.Syntax.Match -- Defined in ‘GHC.Boot.TH.Ppr’ +instance GHC.Boot.TH.Ppr.Ppr GHC.Internal.TH.Syntax.ModName -- Defined in ‘GHC.Boot.TH.Ppr’ instance GHC.Boot.TH.Ppr.Ppr GHC.Internal.TH.Syntax.Module -- Defined in ‘GHC.Boot.TH.Ppr’ instance GHC.Boot.TH.Ppr.Ppr GHC.Internal.TH.Syntax.ModuleInfo -- Defined in ‘GHC.Boot.TH.Ppr’ instance GHC.Boot.TH.Ppr.Ppr GHC.Internal.TH.Syntax.Name -- Defined in ‘GHC.Boot.TH.Ppr’ ===================================== testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr ===================================== @@ -1,7 +1,7 @@ RecordDotSyntaxFail8.hs:47:17: error: [GHC-39999] • No instance for ‘HasField "quux1" Quux Quux’ arising from selecting the field ‘quux1’ - NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class. + NB: ‘HasField’ is not the built-in ‘HasField’ class. • In the second argument of ‘($)’, namely ‘a.foo.bar.baz.quux1’ In a stmt of a 'do' block: print @Quux $ a.foo.bar.baz.quux1 In the expression: @@ -29,7 +29,7 @@ RecordDotSyntaxFail8.hs:50:17: error: [GHC-39999] RecordDotSyntaxFail8.hs:53:17: error: [GHC-39999] • No instance for ‘HasField "quux3" Quux r0’ arising from selecting the field ‘quux3’ - NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class. + NB: ‘HasField’ is not the built-in ‘HasField’ class. • In the second argument of ‘($)’, namely ‘a.foo.bar.baz.quux3.wob’ In a stmt of a 'do' block: print @Bool $ a.foo.bar.baz.quux3.wob In the expression: ===================================== testsuite/tests/perf/compiler/hard_hole_fits.stderr ===================================== @@ -621,10 +621,6 @@ hard_hole_fits.hs:45:27: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] (imported from ‘Prelude’ (and originally defined in ‘GHC.Internal.Enum’)) -hard_hole_fits.hs:46:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] - Pattern match is redundant - In an equation for ‘testMe’: testMe (XExpr xe) = ... - hard_hole_fits.hs:46:21: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int • In an equation for ‘testMe’: testMe (XExpr xe) = _ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e691e4013d439d446c6a5668da0ee52... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e691e4013d439d446c6a5668da0ee52... 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