[Git][ghc/ghc][wip/T21077] Draft: Use HsExpanded for untyped TH expression splices
Ryan Scott (@RyanGlScott)
gitlab at gitlab.haskell.org
Wed Jul 19 13:23:44 UTC 2023
Ryan Scott pushed to branch wip/T21077 at Glasgow Haskell Compiler / GHC
Commits:
608fe90d by Ryan Scott at 2023-07-19T09:23:29-04:00
Draft: Use HsExpanded for untyped TH expression splices
This changes the way that untyped Template Haskell expression splices are
handled such that they are folded into the `HsExpanded` machinery. This, in
turn, makes `splitHsApps` look through TH splices, which fixes #21077.
TODO RGS: Add a more detailed description of the changes in the commit message,
and add more documentation.
- - - - -
11 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/Origin.hs
- + testsuite/tests/th/T21077.hs
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -441,10 +441,17 @@ tupArgPresent (Missing {}) = False
********************************************************************* -}
type instance XXExpr GhcPs = DataConCantHappen
-type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)
+type instance XXExpr GhcRn = XXExprGhcRn
type instance XXExpr GhcTc = XXExprGhcTc
-- HsExpansion: see Note [Rebindable syntax and HsExpansion] below
+-- | TODO RGS: Docs
+data XXExprGhcRn
+ = ExpansionRn
+ {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcRn))
+ | AddModFinalizers
+ ThModFinalizers
+ (HsExpr GhcRn)
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
@@ -709,14 +716,19 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcRn -> ppr x
GhcTc -> ppr x
+instance Outputable XXExprGhcRn where
+ ppr (ExpansionRn e)
+ = ppr e
+
+ ppr (AddModFinalizers _ e)
+ = ppr e
+
instance Outputable XXExprGhcTc where
ppr (WrapExpr (HsWrap co_fn e))
= pprHsWrapper co_fn (\_parens -> pprExpr e)
ppr (ExpansionExpr e)
- = ppr e -- e is an HsExpansion, we print the original
- -- expression (LHsExpr GhcPs), not the
- -- desugared one (LHsExpr GhcTc).
+ = ppr e
ppr (ConLikeTc con _ _) = pprPrefixOcc con
-- Used in error messages generated by
@@ -747,15 +759,19 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
GhcTc -> ppr_infix_expr_tc x
ppr_infix_expr _ = Nothing
-ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc
-ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a
+ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
+ppr_infix_expr_rn (ExpansionRn e) = ppr_infix_expansion e
+ppr_infix_expr_rn (AddModFinalizers _ e) = ppr_infix_expr e
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
-ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
-ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a
-ppr_infix_expr_tc (ConLikeTc {}) = Nothing
-ppr_infix_expr_tc (HsTick {}) = Nothing
-ppr_infix_expr_tc (HsBinTick {}) = Nothing
+ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
+ppr_infix_expr_tc (ExpansionExpr e) = ppr_infix_expansion e
+ppr_infix_expr_tc (ConLikeTc {}) = Nothing
+ppr_infix_expr_tc (HsTick {}) = Nothing
+ppr_infix_expr_tc (HsBinTick {}) = Nothing
+
+ppr_infix_expansion :: HsExpansion (HsExpr GhcRn) expansion -> Maybe SDoc
+ppr_infix_expansion (HsExpanded a _) = ppr_infix_expr a
ppr_apps :: (OutputableBndrId p)
=> HsExpr (GhcPass p)
@@ -851,14 +867,18 @@ hsExprNeedsParens prec = go
#endif
go_x_tc :: XXExprGhcTc -> Bool
- go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
- go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a
- go_x_tc (ConLikeTc {}) = False
- go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
- go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
+ go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
+ go_x_tc (ExpansionExpr e) = go_expansion e
+ go_x_tc (ConLikeTc {}) = False
+ go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
+ go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
+
+ go_x_rn :: XXExprGhcRn -> Bool
+ go_x_rn (ExpansionRn e) = go_expansion e
+ go_x_rn (AddModFinalizers _ e) = hsExprNeedsParens prec e
- go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
- go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a
+ go_expansion :: HsExpansion (HsExpr GhcRn) expansion -> Bool
+ go_expansion (HsExpanded a _) = hsExprNeedsParens prec a
-- | Parenthesize an expression without token information
@@ -894,14 +914,18 @@ isAtomicHsExpr (XExpr x)
| GhcRn <- ghcPass @p = go_x_rn x
where
go_x_tc :: XXExprGhcTc -> Bool
- go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e
- go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a
- go_x_tc (ConLikeTc {}) = True
- go_x_tc (HsTick {}) = False
- go_x_tc (HsBinTick {}) = False
-
- go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
- go_x_rn (HsExpanded a _) = isAtomicHsExpr a
+ go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e
+ go_x_tc (ExpansionExpr e) = go_expansion e
+ go_x_tc (ConLikeTc {}) = True
+ go_x_tc (HsTick {}) = False
+ go_x_tc (HsBinTick {}) = False
+
+ go_x_rn :: XXExprGhcRn -> Bool
+ go_x_rn (ExpansionRn e) = go_expansion e
+ go_x_rn (AddModFinalizers _ e) = isAtomicHsExpr e
+
+ go_expansion :: HsExpansion (HsExpr GhcRn) expansion -> Bool
+ go_expansion (HsExpanded a _) = isAtomicHsExpr a
isAtomicHsExpr _ = False
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -566,6 +566,7 @@ deriving instance Eq (IE GhcTc)
-- ---------------------------------------------------------------------
+deriving instance Data XXExprGhcRn
deriving instance Data XXExprGhcTc
deriving instance Data XXPatGhcTc
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1666,11 +1666,18 @@ repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
e1 <- repLE e
repGetField e1 f
repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)
-repE (XExpr (HsExpanded orig_expr ds_expr))
- = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
- ; if rebindable_on -- See Note [Quotation and rebindable syntax]
- then repE ds_expr
- else repE orig_expr }
+repE (XExpr x) =
+ case x of
+ ExpansionRn (HsExpanded orig_expr ds_expr) ->
+ do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
+ ; if rebindable_on -- See Note [Quotation and rebindable syntax]
+ then repE ds_expr
+ else repE orig_expr }
+ AddModFinalizers{} ->
+ -- TODO RGS: Is this right? I believe so, since there is an invariant
+ -- that no AddModFinalizers should appear inside an HsBracket. Spell
+ -- this out explicitly somewhere.
+ pprPanic "repE XExpr" (ppr x)
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -2719,7 +2719,7 @@ mkExpandedExpr
:: HsExpr GhcRn -- ^ source expression
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedExpr a b = XExpr (HsExpanded a b)
+mkExpandedExpr a b = XExpr (ExpansionRn (HsExpanded a b))
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -483,8 +483,8 @@ rnUntypedSpliceExpr splice
runRnSplice UntypedExpSplice runMetaE ppr rn_splice
; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
-- See Note [Delaying modFinalizers in untyped splices].
- ; let e = flip HsUntypedSplice rn_splice
- . HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
+ ; let e = XExpr
+ . AddModFinalizers (ThModFinalizers mod_finalizers)
<$> lexpr3
; return (gHsPar e, fvs)
}
@@ -597,6 +597,7 @@ This note and approach originated in #18102.
{- Note [Delaying modFinalizers in untyped splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+TODO RGS: Update this
When splices run in the renamer, 'reify' does not have access to the local
type environment (#11832, [1]).
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -142,11 +142,11 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
-- True <=> instantiate -- return a rho-type
-- False <=> don't instantiate -- return a sigma-type
tcInferSigma inst (L loc rn_expr)
- | (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
= addExprCtxt rn_expr $
setSrcSpanA loc $
- do { do_ql <- wantQuickLook rn_fun
- ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
+ do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
+ ; do_ql <- wantQuickLook rn_fun
+ ; (tc_fun, fun_sigma) <- tcInferAppHead fun
; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args
; _tc_args <- tcValArgs do_ql inst_args
; return app_res_sigma }
@@ -174,7 +174,6 @@ head ::= f -- HsVar: variables
| fld -- HsRecSel: record field selectors
| (expr :: ty) -- ExprWithTySig: expr with user type sig
| lit -- HsOverLit: overloaded literals
- | $([| head |]) -- HsSpliceE+HsSpliced+HsSplicedExpr: untyped TH expression splices
| other_expr -- Other expressions
When tcExpr sees something that starts an application chain (namely,
@@ -204,16 +203,6 @@ Clearly this should work! But it will /only/ work because if we
instantiate that (forall b. b) impredicatively! And that only happens
in tcApp.
-We also wish to typecheck application chains with untyped Template Haskell
-splices in the head, such as this example from #21038:
- data Foo = MkFoo (forall a. a -> a)
- f = $([| MkFoo |]) $ \x -> x
-This should typecheck just as if the TH splice was never in the way—that is,
-just as if the user had written `MkFoo $ \x -> x`. We could conceivably have
-a case for typed TH expression splices too, but it wouldn't be useful in
-practice, since the types of typed TH expressions aren't allowed to have
-polymorphic types, such as the type of MkFoo.
-
Note [tcApp: typechecking applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcApp implements the APP-Downarrow/Uparrow rule of
@@ -329,12 +318,13 @@ before tcValArgs.
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- See Note [tcApp: typechecking applications]
tcApp rn_expr exp_res_ty
- | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
- = do { traceTc "tcApp {" $
+ = do { (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
+
+ ; traceTc "tcApp {" $
vcat [ text "rn_fun:" <+> ppr rn_fun
, text "rn_args:" <+> ppr rn_args ]
- ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
+ ; (tc_fun, fun_sigma) <- tcInferAppHead fun
-- Instantiate
; do_ql <- wantQuickLook rn_fun
@@ -974,8 +964,8 @@ isGuardedTy ty
quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaTypeFRR
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 guarded delta larg@(L _ arg) arg_ty
- = do { let ((rn_fun, fun_ctxt), rn_args) = splitHsApps arg
- ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args
+ = do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg
+ ; mb_fun_ty <- tcInferAppHead_maybe rn_fun
; traceTc "quickLookArg 1" $
vcat [ text "arg:" <+> ppr arg
, text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -207,7 +207,7 @@ tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
-tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty
+tcExpr e@(XExpr {}) res_ty = tcApp e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -571,6 +571,7 @@ tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not
-- Here we get rid of it and add the finalizers to the global environment.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
+-- TODO RGS: Update this
tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty
tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty
@@ -733,7 +734,7 @@ tcSyntaxOpGen :: CtOrigin
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside
- = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) []
+ = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan)
-- Ugh!! But all this code is scheduled for demolition anyway
; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
; (result, expr_wrap, arg_wraps, res_wrap)
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -278,8 +278,8 @@ addArgWrap wrap args
| otherwise = EWrap (EHsWrap wrap) : args
splitHsApps :: HsExpr GhcRn
- -> ( (HsExpr GhcRn, AppCtxt) -- Head
- , [HsExprArg 'TcpRn]) -- Args
+ -> TcM ( (HsExpr GhcRn, AppCtxt) -- Head
+ , [HsExprArg 'TcpRn]) -- Args
-- See Note [splitHsApps]
splitHsApps e = go e (top_ctxt 0 e) []
where
@@ -291,13 +291,15 @@ splitHsApps e = go e (top_ctxt 0 e) []
top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun
top_ctxt n (HsAppType _ fun _ _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
- top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan
+ top_ctxt n (XExpr x) = case x of
+ ExpansionRn (HsExpanded orig _) -> VACall orig n noSrcSpan
+ AddModFinalizers _ fun -> VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
- -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
+ -> TcM ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
-- Modify the AppCtxt as we walk inwards, so it describes the next argument
go (HsPar _ _ (L l fun) _) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args)
go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args)
@@ -305,19 +307,29 @@ splitHsApps e = go e (top_ctxt 0 e) []
go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args)
-- See Note [Looking through HsExpanded]
- go (XExpr (HsExpanded orig fun)) ctxt args
- = go fun (VAExpansion orig (appCtxtLoc ctxt))
- (EWrap (EExpand orig) : args)
+ go (XExpr x) ctxt args
+ = case x of
+ ExpansionRn (HsExpanded orig fun)
+ -> go fun (VAExpansion orig (appCtxtLoc ctxt))
+ (EWrap (EExpand orig) : args)
+ AddModFinalizers mod_finalizers fun
+ -> do addModFinalizersWithLclEnv mod_finalizers
+ let orig = HsUntypedSplice
+ (HsUntypedSpliceTop mod_finalizers fun)
+ (HsUntypedSpliceExpr
+ (error "TODO RGS: What do I put here?")
+ (L (error "TODO RGS: Which location?") fun))
+ go fun (VAExpansion orig (appCtxtLoc ctxt)) (EWrap (EExpand orig) : args)
-- See Note [Desugar OpApp in the typechecker]
go e@(OpApp _ arg1 (L l op) arg2) _ args
- = ( (op, VACall op 0 (locA l))
- , mkEValArg (VACall op 1 generatedSrcSpan) arg1
- : mkEValArg (VACall op 2 generatedSrcSpan) arg2
- : EWrap (EExpand e)
- : args )
+ = pure ( (op, VACall op 0 (locA l))
+ , mkEValArg (VACall op 1 generatedSrcSpan) arg1
+ : mkEValArg (VACall op 2 generatedSrcSpan) arg2
+ : EWrap (EExpand e)
+ : args )
- go e ctxt args = ((e,ctxt), args)
+ go e ctxt args = pure ((e,ctxt), args)
set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set l (VACall f n _) = VACall f n (locA l)
@@ -749,6 +761,7 @@ where
Note [Looking through HsExpanded]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+TODO RGS: Update me
When creating an application chain in splitHsApps, we must deal with
HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3
@@ -765,7 +778,6 @@ It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.
********************************************************************* -}
tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
- -> [HsExprArg 'TcpRn]
-> TcM (HsExpr GhcTc, TcSigmaType)
-- Infer type of the head of an application
-- i.e. the 'f' in (f e1 ... en)
@@ -776,11 +788,6 @@ tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-- * An expression with a type signature (e :: ty)
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
--
--- Why do we need the arguments to infer the type of the head of the
--- application? Simply to inform add_head_ctxt about whether or not
--- to put push a new "In the expression..." context. (We don't push a
--- new one if there are no arguments, because we already have.)
---
-- Note that [] and (,,) are both HsVar:
-- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr
--
@@ -788,28 +795,30 @@ tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-- cases are dealt with by splitHsApps.
--
-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
-tcInferAppHead (fun,ctxt) args
+tcInferAppHead (fun,ctxt)
= addHeadCtxt ctxt $
- do { mb_tc_fun <- tcInferAppHead_maybe fun args
+ do { mb_tc_fun <- tcInferAppHead_maybe fun
; case mb_tc_fun of
Just (fun', fun_sigma) -> return (fun', fun_sigma)
Nothing -> tcInfer (tcExpr fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
- -> [HsExprArg 'TcpRn]
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-- Returns Nothing for a complicated head
-tcInferAppHead_maybe fun args
+tcInferAppHead_maybe fun
= case fun of
HsVar _ (L _ nm) -> Just <$> tcInferId nm
HsRecSel _ f -> Just <$> tcInferRecSelId f
ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty
HsOverLit _ lit -> Just <$> tcInferOverLit lit
- HsUntypedSplice (HsUntypedSpliceTop _ e) _
- -> tcInferAppHead_maybe e args
_ -> return Nothing
+-- TODO RGS: Figure out how to adapt Richard's suggestion from
+-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7574#note_409921
+-- to this new version of addHeadCtxt, which doesn't have arguments. Perhaps
+-- we should pass the arguments separately? If so, it's not clear to me how
+-- that is meant to interact with the `isGoodSrcSpan` check.
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -739,7 +739,10 @@ exprCtOrigin (HsTypedSplice {}) = Shouldn'tHappenOrigin "TH typed splice"
exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
-exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a
+exprCtOrigin (XExpr x) =
+ case x of
+ ExpansionRn (HsExpanded a _) -> exprCtOrigin a
+ AddModFinalizers{} -> Shouldn'tHappenOrigin "TH splice" -- TODO RGS: Is this right?
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
=====================================
testsuite/tests/th/T21077.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T21077 where
+
+import Language.Haskell.TH.Syntax
+
+data Foo = MkFoo () (forall a. a -> a)
+
+worksOnAllGHCs1 :: Foo
+worksOnAllGHCs1 = MkFoo () (\x -> x)
+
+worksOnAllGHCs2 :: Foo
+worksOnAllGHCs2 = MkFoo () $ \x -> x
+
+worksOnAllGHCs3 :: Foo
+worksOnAllGHCs3 = $([| MkFoo () |]) (\x -> x)
+
+doesn'tWorkOnGHC9'2A :: Foo
+doesn'tWorkOnGHC9'2A = $([| MkFoo () |]) $ \x -> x
+
+doesn'tWorkOnGHC9'2B :: Foo
+doesn'tWorkOnGHC9'2B = $([| $([| MkFoo () |]) |]) $ \x -> x
+
+doesn'tWorkOnGHC9'2C :: Foo
+doesn'tWorkOnGHC9'2C = $(do addModFinalizer (runIO (putStrLn "C"))
+ [| MkFoo () |]) $ \x -> x
+
+doesn'tWorkOnGHC9'2D :: Foo
+doesn'tWorkOnGHC9'2D = $(do addModFinalizer (runIO (putStrLn "D2"))
+ [| $(do addModFinalizer (runIO (putStrLn "D1"))
+ [| MkFoo () |])
+ |]) $ \x -> x
=====================================
testsuite/tests/th/all.T
=====================================
@@ -560,6 +560,7 @@ test('T15433b', [extra_files(['T15433_aux.hs'])], multimod_compile, ['T15433b',
test('T20711', normal, compile_and_run, [''])
test('T20868', normal, compile_and_run, [''])
test('Lift_ByteArray', normal, compile_and_run, [''])
+test('T21077', normal, compile, [''])
test('T21920', normal, compile_and_run, [''])
test('T21723', normal, compile_and_run, [''])
test('T21942', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/608fe90db254e86275e8879063ce036e0f12fff8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/608fe90db254e86275e8879063ce036e0f12fff8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230719/612e786f/attachment-0001.html>
More information about the ghc-commits
mailing list