[Git][ghc/ghc][master] Expand untyped splices in tcPolyExprCheck
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Mar 21 02:44:07 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
97a2bb1c by Simon Peyton Jones at 2024-03-20T17:11:29+00:00
Expand untyped splices in tcPolyExprCheck
Fixes #24559
- - - - -
6 changed files:
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- + testsuite/tests/th/T24559.hs
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -30,7 +30,7 @@ import GHC.Prelude
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import {-# SOURCE #-} GHC.Tc.Gen.Splice
- ( tcTypedSplice, tcTypedBracket, tcUntypedBracket )
+ ( tcTypedSplice, tcTypedBracket, tcUntypedBracket, getUntypedSpliceBody )
import GHC.Hs
import GHC.Hs.Syn.Type
@@ -169,6 +169,12 @@ tcPolyExprCheck expr res_ty
do { e' <- tc_body e
; return (HsPar x (L loc e')) }
+ -- Look through any untyped splices (#24559)
+ -- c.f. Note [Looking through Template Haskell splices in splitHsApps]
+ tc_body (HsUntypedSplice splice_res _)
+ = do { body <- getUntypedSpliceBody splice_res
+ ; tc_body body }
+
-- The special case for lambda: go to tcLambdaMatches, passing pat_tys
tc_body e@(HsLam x lam_variant matches)
= do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys
@@ -673,11 +679,8 @@ tcExpr (HsUntypedSplice splice _) res_ty
-- for `HsUntypedSplice`; to see why, read Wrinkle (UTS1) in
-- Note [Looking through Template Haskell splices in splitHsApps] in
-- GHC.Tc.Gen.Head.
- = case splice of
- HsUntypedSpliceTop mod_finalizers expr
- -> do { addModFinalizersWithLclEnv mod_finalizers
- ; tcExpr expr res_ty }
- HsUntypedSpliceNested {} -> panic "tcExpr: invalid nested splice"
+ = do { expr <- getUntypedSpliceBody splice
+ ; tcExpr expr res_ty }
{-
************************************************************************
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -30,6 +30,7 @@ module GHC.Tc.Gen.Head
, addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
+import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
import GHC.Prelude
import GHC.Hs
@@ -310,15 +311,11 @@ splitHsApps e = go e (top_ctxt 0 e) []
-- 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 ctxt' (EWrap (EExpand (OrigExpr e)) : args)
- HsUntypedSpliceNested {} -> panic "splitHsApps: invalid nested splice"
+ = do { fun <- getUntypedSpliceBody splice_res
+ ; go fun ctxt' (EWrap (EExpand (OrigExpr e)) : args) }
where
ctxt' :: AppCtxt
- ctxt' =
- case splice of
+ ctxt' = case splice of
HsUntypedSpliceExpr _ (L l _) -> set l ctxt -- l :: SrcAnn AnnListItem
HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns
@@ -840,7 +837,7 @@ handling splices and quasiquotes has already been performed by the renamer by
the time we get to `splitHsApps`.
Wrinkle (UTS1):
- `tcExpr` has a separate case for `HsUntypedSplice`s that do not occur at the
+ `tcExpr` has a separate case for `HsUntypedSplice`s that do /not/ occur at the
head of an application. This is important to handle programs like this one:
foo :: (forall a. a -> a) -> b -> b
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -21,7 +21,7 @@
-- | Template Haskell splices
module GHC.Tc.Gen.Splice(
tcTypedSplice, tcTypedBracket, tcUntypedBracket,
- runAnnotation,
+ runAnnotation, getUntypedSpliceBody,
runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
tcTopSpliceExpr, lookupThName_maybe,
@@ -639,13 +639,16 @@ Example:
************************************************************************
-}
+-- None of these functions add constraints to the LIE
+
tcTypedBracket :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType
-> TcM (HsExpr GhcTc)
-tcTypedSplice :: Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
- -- None of these functions add constraints to the LIE
+tcTypedSplice :: Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+
+getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn)
+runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
-runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
{-
************************************************************************
* *
@@ -815,6 +818,16 @@ quotationCtxtDoc br_body
************************************************************************
-}
+-- getUntypedSpliceBody: the renamer has expanded the splice.
+-- Just run the finalizers that it produced, and return
+-- the renamed expression
+getUntypedSpliceBody (HsUntypedSpliceTop { utsplice_result_finalizers = mod_finalizers
+ , utsplice_result = rn_expr })
+ = do { addModFinalizersWithLclEnv mod_finalizers
+ ; return rn_expr }
+getUntypedSpliceBody (HsUntypedSpliceNested {})
+ = panic "tcTopUntypedSplice: invalid nested splice"
+
tcTypedSplice splice_name expr res_ty
= addErrCtxt (typedSpliceCtxtDoc splice_name expr) $
setSrcSpan (getLocA expr) $ do
=====================================
compiler/GHC/Tc/Gen/Splice.hs-boot
=====================================
@@ -10,7 +10,7 @@ import GHC.Tc.Utils.TcType ( ExpRhoType )
import GHC.Types.Annotations ( Annotation, CoreAnnTarget )
import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )
-import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers )
+import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult )
import qualified Language.Haskell.TH as TH
tcTypedSplice :: Name
@@ -30,7 +30,8 @@ tcUntypedBracket :: HsExpr GhcRn
runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
-runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
+runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
+getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn)
tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
=====================================
testsuite/tests/th/T24559.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE GHC2024 #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeAbstractions #-}
+module Foo where
+
+import Data.Kind
+import Data.Proxy
+
+f :: (forall (a :: Type). Proxy a) -> Proxy Bool
+f k = k @Bool
+
+g1 :: Proxy Bool
+g1 = f (\ @a -> Proxy @a)
+
+g2 :: Proxy Bool
+g2 = f $([| \ @a -> Proxy @a |])
=====================================
testsuite/tests/th/all.T
=====================================
@@ -604,3 +604,4 @@ test('T24308', normal, compile_and_run, [''])
test('T14032a', normal, compile, [''])
test('T14032e', normal, compile_fail, ['-dsuppress-uniques'])
test('ListTuplePunsTH', [only_ways(['ghci']), extra_files(['ListTuplePunsTH.hs', 'T15843a.hs'])], ghci_script, ['ListTuplePunsTH.script'])
+test('T24559', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/97a2bb1cdfa4b244a58374658aec6d48ce23a54a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/97a2bb1cdfa4b244a58374658aec6d48ce23a54a
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/20240320/8fe28b00/attachment-0001.html>
More information about the ghc-commits
mailing list