[Git][ghc/ghc][wip/T21077-take-two] Look through TH splices in splitHsApps
Ryan Scott (@RyanGlScott)
gitlab at gitlab.haskell.org
Thu Aug 3 11:15:56 UTC 2023
Ryan Scott pushed to branch wip/T21077-take-two at Glasgow Haskell Compiler / GHC
Commits:
30929607 by Ryan Scott at 2023-08-03T06:55:20-04:00
Look through TH splices in splitHsApps
This modifies `splitHsApps` (a key function used in typechecking function
applications) to look through untyped TH splices and quasiquotes. Not doing so
was the cause of #21077. This builds on !7821 by making `splitHsApps` match on
`HsUntypedSpliceTop`, which contains the `ThModFinalizers` that must be run as
part of invoking the TH splice. See the new `Note [Looking through Template
Haskell splices in splitHsApps]` in `GHC.Tc.Gen.Head`.
Along the way, I needed to make the type of `splitHsApps.set` slightly more
general to accommodate the fact that the location attached to a quasiquote is
a `SrcAnn NoEpAnns` rather than a `SrcSpanNoAnn`.
Fixes #21077.
- - - - -
8 changed files:
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- + testsuite/tests/th/T21077.hs
- + testsuite/tests/th/T21077.stderr
- + testsuite/tests/th/T21077_Lib.hs
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -475,18 +475,26 @@ rnUntypedSpliceExpr splice
pend_expr_splice name rn_splice
= (makePending UntypedExpSplice name rn_splice, HsUntypedSplice (HsUntypedSpliceNested name) rn_splice)
- run_expr_splice :: HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice rn_splice
= do { traceRn "rnUntypedSpliceExpr: untyped expression splice" empty
- -- Run it here, see Note [Running splices in the Renamer]
- ; (rn_expr, mod_finalizers) <-
- 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)
- <$> lexpr3
- ; return (gHsPar e, fvs)
+
+ -- Run the splice here, see Note [Running splices in the Renamer]
+ ; (expr_ps, mod_finalizers)
+ <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice
+ -- mod_finalizers: See Note [Delaying modFinalizers in untyped splices].
+
+ -- Rename the expanded expression
+ ; (L l expr_rn, fvs) <- checkNoErrs (rnLExpr expr_ps)
+
+ -- rn_splice :: HsUntypedSplice GhcRn is the original TH expression,
+ -- before expansion
+ -- expr_ps :: LHsExpr GhcPs is the result of running the splice
+ -- expr_rn :: HsExpr GhcRn is the result of renaming ps_expr
+ ; let res :: HsUntypedSpliceResult (HsExpr GhcRn)
+ res = HsUntypedSpliceTop
+ { utsplice_result_finalizers = ThModFinalizers mod_finalizers
+ , utsplice_result = expr_rn }
+ ; return (gHsPar (L l (HsUntypedSplice res rn_splice)), fvs)
}
thSyntaxError :: THSyntaxError -> TcRnMessage
=====================================
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,12 @@ 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
@@ -1253,8 +1242,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
=====================================
@@ -187,16 +187,17 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- Use tcApp to typecheck applications, which are treated specially
-- by Quick Look. Specifically:
--- - HsVar lone variables, to ensure that they can get an
+-- - HsVar lone variables, to ensure that they can get an
-- impredicative instantiation (via Quick Look
-- driven by res_ty (in checking mode)).
--- - HsApp value applications
--- - HsAppType type applications
--- - ExprWithTySig (e :: type)
--- - HsRecSel overloaded record fields
--- - HsExpanded renamer expansions
--- - HsOpApp operator applications
--- - HsOverLit overloaded literals
+-- - HsApp value applications
+-- - HsAppType type applications
+-- - ExprWithTySig (e :: type)
+-- - HsRecSel overloaded record fields
+-- - HsExpanded renamer expansions
+-- - HsUntypedSplice untyped Template Haskell splices
+-- - HsOpApp operator applications
+-- - HsOverLit overloaded literals
-- These constructors are the union of
-- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
@@ -208,6 +209,7 @@ 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@(HsUntypedSplice {}) res_ty = tcApp e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -577,12 +579,6 @@ tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty
tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty
tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty
-tcExpr (HsUntypedSplice splice _) res_ty
- = case splice of
- HsUntypedSpliceTop mod_finalizers expr
- -> do { addModFinalizersWithLclEnv mod_finalizers
- ; tcExpr expr res_ty }
- HsUntypedSpliceNested {} -> panic "tcExpr: invalid nested splice"
{-
************************************************************************
@@ -735,7 +731,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,9 +278,13 @@ addArgWrap wrap args
| otherwise = EWrap (EHsWrap wrap) : args
splitHsApps :: HsExpr GhcRn
- -> ( (HsExpr GhcRn, AppCtxt) -- Head
- , [HsExprArg 'TcpRn]) -- Args
--- See Note [splitHsApps]
+ -> TcM ( (HsExpr GhcRn, AppCtxt) -- Head
+ , [HsExprArg 'TcpRn]) -- Args
+-- See Note [splitHsApps].
+--
+-- This uses the TcM monad solely because we must run modFinalizers when looking
+-- through HsUntypedSplices
+-- (see Note [Looking through Template Haskell splices in splitHsApps]).
splitHsApps e = go e (top_ctxt 0 e) []
where
top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt
@@ -297,34 +301,47 @@ splitHsApps e = go e (top_ctxt 0 e) []
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)
- go (HsAppType _ (L l fun) at ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt at ty : args)
- go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args)
+ go (HsPar _ _ (L l fun) _) ctxt args = go fun (set (locA l) ctxt) (EWrap (EPar ctxt) : args)
+ go (HsPragE _ p (L l fun)) ctxt args = go fun (set (locA l) ctxt) (EPrag ctxt p : args)
+ go (HsAppType _ (L l fun) at ty) ctxt args = go fun (dec (locA l) ctxt) (mkETypeArg ctxt at ty : args)
+ go (HsApp _ (L l fun) arg) ctxt args = go fun (dec (locA 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)
+ -- See Note [Looking through Template Haskell splices in splitHsApps]
+ go e@(HsUntypedSplice splice_res splice) ctxt args
+ = case splice_res of
+ HsUntypedSpliceTop mod_finalizers fun
+ -> do addModFinalizersWithLclEnv mod_finalizers
+ go fun (set loc ctxt) (EWrap (EExpand e) : args)
+ HsUntypedSpliceNested {} -> panic "splitHsApps: invalid nested splice"
+ where
+ loc :: SrcSpan
+ loc = case splice of
+ HsUntypedSpliceExpr _ (L l _) -> locA l
+ HsQuasiQuote _ _ (L l _) -> locA l
+
-- 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)
+ set :: SrcSpan -> AppCtxt -> AppCtxt
+ set l (VACall f n _) = VACall f n l
set _ ctxt@(VAExpansion {}) = ctxt
- dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
- dec l (VACall f n _) = VACall f (n-1) (locA l)
+ dec :: SrcSpan -> AppCtxt -> AppCtxt
+ dec l (VACall f n _) = VACall f (n-1) l
dec _ ctxt@(VAExpansion {}) = ctxt
-- | Rebuild an application: takes a type-checked application head
@@ -756,6 +773,39 @@ as a single application chain `f e1 e2 e3`. Otherwise stuff like overloaded
labels (#19154) won't work.
It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.
+
+Note [Looking through Template Haskell splices in splitHsApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking an application, we must look through untyped TH splices in
+order to typecheck examples like the one in #21077:
+
+ data Foo = MkFoo () (forall a. a -> a)
+
+ foo :: Foo
+ foo = $([| MkFoo () |]) $ \x -> x
+
+In principle, this is straightforward to accomplish. By the time we typecheck
+`foo`, the renamer will have already run the splice, so all we have to do is
+look at the expanded version of the splice in `splitHsApps`. See the
+`HsUntypedSplice` case in `splitHsApps` for how this is accomplished.
+
+There is one slight complication in that untyped TH splices also include
+modFinalizers (see Note [Delaying modFinalizers in untyped splices] in
+GHC.Rename.Splice), which must be run during typechecking. splitHsApps is a
+convenient place to run the modFinalizers, so we do so there. This is the only
+reason that `splitHsApps` uses the TcM monad.
+
+`HsUntypedSplice` covers both ordinary TH splices, such as the example above,
+as well as quasiquotes (see Note [Quasi-quote overview] in
+Language.Haskell.Syntax.Expr). The `splitHsApps` case for `HsUntypedSplice`
+handles both of these. This is easy to accomplish, since all the real work in
+handling splices and quasiquotes has already been performed by the renamer by
+the time we get to `splitHsApps`.
+
+`tcExpr`, which typechecks expressions, handles `HsUntypedSplice` by simply
+delegating to `tcApp`, which in turn calls `splitHsApps`. This means that
+`splitHsApps` is the unique part of the code that runs an `HsUntypedSplice`'s
+modFinalizers.
-}
{- *********************************************************************
@@ -765,7 +815,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 +825,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,26 +832,23 @@ 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
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
=====================================
testsuite/tests/th/T21077.hs
=====================================
@@ -0,0 +1,45 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T21077 where
+
+import Language.Haskell.TH.Syntax
+import System.IO
+import T21077_Lib
+
+worksOnAllGHCs1 :: Foo
+worksOnAllGHCs1 = MkFoo () (\x -> x)
+
+worksOnAllGHCs2 :: Foo
+worksOnAllGHCs2 = MkFoo () $ \x -> x
+
+-- TemplateHaskell
+
+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 (hPutStrLn stderr "C"))
+ [| MkFoo () |]) $ \x -> x
+
+doesn'tWorkOnGHC9'2D :: Foo
+doesn'tWorkOnGHC9'2D = $(do addModFinalizer (runIO (hPutStrLn stderr "D2"))
+ [| $(do addModFinalizer (runIO (hPutStrLn stderr "D1"))
+ [| MkFoo () |])
+ |]) $ \x -> x
+
+-- QuasiQuotes
+
+worksOnAllGHCs4 :: Foo
+worksOnAllGHCs4 = [qq| doesn't matter |] (\x -> x)
+
+doesn'tWorkOnGHC9'2E :: Foo
+doesn'tWorkOnGHC9'2E = [qq| doesn't matter |] $ \x -> x
+
+doesn'tWorkOnGHC9'2F :: Foo
+doesn'tWorkOnGHC9'2F = [qq| doesn't matter |] $ \x -> x
=====================================
testsuite/tests/th/T21077.stderr
=====================================
@@ -0,0 +1,3 @@
+C
+D1
+D2
=====================================
testsuite/tests/th/T21077_Lib.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module T21077_Lib where
+
+import Language.Haskell.TH.Quote
+
+data Foo = MkFoo () (forall a. a -> a)
+
+qq :: QuasiQuoter
+qq = QuasiQuoter
+ { quoteExp = const [| MkFoo () |]
+ , quotePat = undefined
+ , quoteType = undefined
+ , quoteDec = undefined
+ }
=====================================
testsuite/tests/th/all.T
=====================================
@@ -559,6 +559,7 @@ test('T15433a', [extra_files(['T15433_aux.hs'])], multimod_compile_fail, ['T1543
test('T15433b', [extra_files(['T15433_aux.hs'])], multimod_compile, ['T15433b', '-v0'])
test('T20711', normal, compile_and_run, [''])
test('T20868', normal, compile_and_run, [''])
+test('T21077', [extra_files(['T21077_Lib.hs'])], multimod_compile, ['T21077', '-v0'])
test('Lift_ByteArray', normal, compile_and_run, [''])
test('T21920', normal, compile_and_run, [''])
test('T21723', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/309296073af72e5786e652a9c8506423aefd3447
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/309296073af72e5786e652a9c8506423aefd3447
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/20230803/d0e62eb8/attachment-0001.html>
More information about the ghc-commits
mailing list