Commit c2455e64 authored by Matthew Pickering's avatar Matthew Pickering

Run typed splices in the zonker

Summary:
This fixes #15471

In the typechecker we check that the splice has the right type but we
crucially don't zonk the generated expression. This is because we might
end up unifying type variables from outer scopes later on.

Reviewers: simonpj, goldfire, bgamari

Subscribers: rwbarton, carter

GHC Trac Issues: #15471

Differential Revision: https://phabricator.haskell.org/D5286
parent 82d1a88d
Pipeline #1024 passed with stages
in 239 minutes and 50 seconds
...@@ -1255,6 +1255,7 @@ repSplice (HsTypedSplice _ _ n _) = rep_splice n ...@@ -1255,6 +1255,7 @@ repSplice (HsTypedSplice _ _ n _) = rep_splice n
repSplice (HsUntypedSplice _ _ n _) = rep_splice n repSplice (HsUntypedSplice _ _ n _) = rep_splice n
repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n
repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e)
repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e) repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e)
rep_splice :: Name -> DsM (Core a) rep_splice :: Name -> DsM (Core a)
......
...@@ -1504,6 +1504,8 @@ instance ( ToHie (LHsExpr a) ...@@ -1504,6 +1504,8 @@ instance ( ToHie (LHsExpr a)
] ]
HsSpliced _ _ _ -> HsSpliced _ _ _ ->
[] []
HsSplicedT _ ->
[]
XSplice _ -> [] XSplice _ -> []
instance ToHie (LRoleAnnotDecl GhcRn) where instance ToHie (LRoleAnnotDecl GhcRn) where
......
...@@ -43,6 +43,8 @@ import Util ...@@ -43,6 +43,8 @@ import Util
import Outputable import Outputable
import FastString import FastString
import Type import Type
import TcType (TcType)
import {-# SOURCE #-} TcRnTypes (TcLclEnv)
-- libraries: -- libraries:
import Data.Data hiding (Fixity(..)) import Data.Data hiding (Fixity(..))
...@@ -2403,6 +2405,8 @@ data HsSplice id ...@@ -2403,6 +2405,8 @@ data HsSplice id
(XSpliced id) (XSpliced id)
ThModFinalizers -- TH finalizers produced by the splice. ThModFinalizers -- TH finalizers produced by the splice.
(HsSplicedThing id) -- The result of splicing (HsSplicedThing id) -- The result of splicing
| HsSplicedT
DelayedSplice
| XSplice (XXSplice id) -- Note [Trees that Grow] extension point | XSplice (XXSplice id) -- Note [Trees that Grow] extension point
type instance XTypedSplice (GhcPass _) = NoExt type instance XTypedSplice (GhcPass _) = NoExt
...@@ -2442,6 +2446,21 @@ instance Data ThModFinalizers where ...@@ -2442,6 +2446,21 @@ instance Data ThModFinalizers where
toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix
dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a]
-- See Note [Running typed splices in the zonker]
-- These are the arguments that are passed to `TcSplice.runTopSplice`
data DelayedSplice =
DelayedSplice
TcLclEnv -- The local environment to run the splice in
(LHsExpr GhcRn) -- The original renamed expression
TcType -- The result type of running the splice, unzonked
(LHsExpr GhcTcId) -- The typechecked expression to run and splice in the result
-- A Data instance which ignores the argument of 'DelayedSplice'.
instance Data DelayedSplice where
gunfold _ _ _ = panic "DelayedSplice"
toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix
dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a]
-- | Haskell Spliced Thing -- | Haskell Spliced Thing
-- --
-- Values that can result from running a splice. -- Values that can result from running a splice.
...@@ -2573,6 +2592,7 @@ pprSplice (HsUntypedSplice _ NoParens n e) ...@@ -2573,6 +2592,7 @@ pprSplice (HsUntypedSplice _ NoParens n e)
= ppr_splice empty n e empty = ppr_splice empty n e empty
pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s
pprSplice (HsSpliced _ _ thing) = ppr thing pprSplice (HsSpliced _ _ thing) = ppr thing
pprSplice (HsSplicedT {}) = text "Unevaluated typed splice"
pprSplice (XSplice x) = ppr x pprSplice (XSplice x) = ppr x
ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc
......
...@@ -55,6 +55,8 @@ import {-# SOURCE #-} TcSplice ...@@ -55,6 +55,8 @@ import {-# SOURCE #-} TcSplice
, tcTopSpliceExpr , tcTopSpliceExpr
) )
import TcHsSyn
import GHCi.RemoteTypes ( ForeignRef ) import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q) import qualified Language.Haskell.TH as TH (Q)
...@@ -300,12 +302,14 @@ runRnSplice flavour run_meta ppr_res splice ...@@ -300,12 +302,14 @@ runRnSplice flavour run_meta ppr_res splice
HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str
HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice)
HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) HsSpliced {} -> pprPanic "runRnSplice" (ppr splice)
HsSplicedT {} -> pprPanic "runRnSplice" (ppr splice)
XSplice {} -> pprPanic "runRnSplice" (ppr splice) XSplice {} -> pprPanic "runRnSplice" (ppr splice)
-- Typecheck the expression -- Typecheck the expression
; meta_exp_ty <- tcMetaTy meta_ty_name ; meta_exp_ty <- tcMetaTy meta_ty_name
; zonked_q_expr <- tcTopSpliceExpr Untyped $ ; zonked_q_expr <- zonkTopLExpr =<<
tcPolyExpr the_expr meta_exp_ty tcTopSpliceExpr Untyped
(tcPolyExpr the_expr meta_exp_ty)
-- Run the expression -- Run the expression
; mod_finalizers_ref <- newTcRef [] ; mod_finalizers_ref <- newTcRef []
...@@ -346,6 +350,8 @@ makePending _ splice@(HsTypedSplice {}) ...@@ -346,6 +350,8 @@ makePending _ splice@(HsTypedSplice {})
= pprPanic "makePending" (ppr splice) = pprPanic "makePending" (ppr splice)
makePending _ splice@(HsSpliced {}) makePending _ splice@(HsSpliced {})
= pprPanic "makePending" (ppr splice) = pprPanic "makePending" (ppr splice)
makePending _ splice@(HsSplicedT {})
= pprPanic "makePending" (ppr splice)
makePending _ splice@(XSplice {}) makePending _ splice@(XSplice {})
= pprPanic "makePending" (ppr splice) = pprPanic "makePending" (ppr splice)
...@@ -400,6 +406,7 @@ rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) ...@@ -400,6 +406,7 @@ rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
, unitFV quoter') } , unitFV quoter') }
rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)
rnSplice splice@(XSplice {}) = pprPanic "rnSplice" (ppr splice) rnSplice splice@(XSplice {}) = pprPanic "rnSplice" (ppr splice)
--------------------- ---------------------
...@@ -709,6 +716,7 @@ spliceCtxt splice ...@@ -709,6 +716,7 @@ spliceCtxt splice
HsTypedSplice {} -> text "typed splice:" HsTypedSplice {} -> text "typed splice:"
HsQuasiQuote {} -> text "quasi-quotation:" HsQuasiQuote {} -> text "quasi-quotation:"
HsSpliced {} -> text "spliced expression:" HsSpliced {} -> text "spliced expression:"
HsSplicedT {} -> text "spliced expression:"
XSplice {} -> text "spliced expression:" XSplice {} -> text "spliced expression:"
-- | The splice data to be logged -- | The splice data to be logged
......
...@@ -81,6 +81,8 @@ import Util ...@@ -81,6 +81,8 @@ import Util
import UniqFM import UniqFM
import CoreSyn import CoreSyn
import {-# SOURCE #-} TcSplice (runTopSplice)
import Control.Monad import Control.Monad
import Data.List ( partition ) import Data.List ( partition )
import Control.Arrow ( second ) import Control.Arrow ( second )
...@@ -773,6 +775,9 @@ zonkExpr env (HsTcBracketOut x body bs) ...@@ -773,6 +775,9 @@ zonkExpr env (HsTcBracketOut x body bs)
zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
return (PendingTcSplice n e') return (PendingTcSplice n e')
zonkExpr env (HsSpliceE _ (HsSplicedT s)) =
runTopSplice s >>= zonkExpr env
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
return (HsSpliceE x s) return (HsSpliceE x s)
......
...@@ -1028,6 +1028,7 @@ tcPatToExpr name args pat = go pat ...@@ -1028,6 +1028,7 @@ tcPatToExpr name args pat = go pat
go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go1 pat = go1 pat
go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety"
-- The following patterns are not invertible. -- The following patterns are not invertible.
go1 p@(BangPat {}) = notInvertible p -- #14112 go1 p@(BangPat {}) = notInvertible p -- #14112
......
...@@ -421,12 +421,6 @@ tcRnSrcDecls explicit_mod_hdr decls ...@@ -421,12 +421,6 @@ tcRnSrcDecls explicit_mod_hdr decls
-- Emit Typeable bindings -- Emit Typeable bindings
; tcg_env <- mkTypeableBinds ; tcg_env <- mkTypeableBinds
-- Finalizers must run after constraints are simplified, or some types
-- might not be complete when using reify (see #12777).
; (tcg_env, tcl_env) <- setGblEnv tcg_env run_th_modfinalizers
; setEnvs (tcg_env, tcl_env) $ do {
; finishTH
; traceTc "Tc9" empty ; traceTc "Tc9" empty
...@@ -438,32 +432,63 @@ tcRnSrcDecls explicit_mod_hdr decls ...@@ -438,32 +432,63 @@ tcRnSrcDecls explicit_mod_hdr decls
-- Zonk the final code. This must be done last. -- Zonk the final code. This must be done last.
-- Even simplifyTop may do some unification. -- Even simplifyTop may do some unification.
-- This pass also warns about missing type signatures -- This pass also warns about missing type signatures
; let { TcGblEnv { tcg_type_env = type_env,
tcg_binds = binds,
tcg_ev_binds = cur_ev_binds,
tcg_imp_specs = imp_specs,
tcg_rules = rules,
tcg_fords = fords } = tcg_env
; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
; (bind_env, ev_binds', binds', fords', imp_specs', rules') ; (bind_env, ev_binds', binds', fords', imp_specs', rules')
<- {-# SCC "zonkTopDecls" #-} <- zonkTcGblEnv new_ev_binds tcg_env
zonkTopDecls all_ev_binds binds rules
imp_specs fords ; -- Finalizers must run after constraints are simplified, or some types
-- might not be complete when using reify (see #12777).
-- and also after we zonk the first time because we run typed splices
-- in the zonker which gives rise to the finalisers.
; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env)
run_th_modfinalizers
; finishTH
; traceTc "Tc11" empty ; traceTc "Tc11" empty
; let { final_type_env = plusTypeEnv type_env bind_env ; -- zonk the new bindings arising from running the finalisers.
; tcg_env' = tcg_env { tcg_binds = binds', -- This won't give rise to any more finalisers as you can't nest
tcg_ev_binds = ev_binds', -- finalisers inside finalisers.
tcg_imp_specs = imp_specs', ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
tcg_rules = rules', <- zonkTcGblEnv emptyBag tcg_env_mf
tcg_fords = fords' } } ;
; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env)
(plusTypeEnv bind_env_mf bind_env)
; tcg_env' = tcg_env_mf
{ tcg_binds = binds' `unionBags` binds_mf,
tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf ,
tcg_imp_specs = imp_specs' ++ imp_specs_mf ,
tcg_rules = rules' ++ rules_mf ,
tcg_fords = fords' ++ fords_mf } } ;
; setGlobalTypeEnv tcg_env' final_type_env ; setGlobalTypeEnv tcg_env' final_type_env
}
} } } }
zonkTcGblEnv :: Bag EvBind -> TcGblEnv
-> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
[LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv new_ev_binds tcg_env =
let TcGblEnv { tcg_binds = binds,
tcg_ev_binds = cur_ev_binds,
tcg_imp_specs = imp_specs,
tcg_rules = rules,
tcg_fords = fords } = tcg_env
all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
in {-# SCC "zonkTopDecls" #-}
zonkTopDecls all_ev_binds binds rules imp_specs fords
-- | Remove accumulated bindings, rules and so on from TcGblEnv
clearTcGblEnv :: TcGblEnv -> TcGblEnv
clearTcGblEnv tcg_env
= tcg_env { tcg_binds = emptyBag,
tcg_ev_binds = emptyBag ,
tcg_imp_specs = [],
tcg_rules = [],
tcg_fords = [] }
-- | Runs TH finalizers and renames and typechecks the top-level declarations -- | Runs TH finalizers and renames and typechecks the top-level declarations
-- that they could introduce. -- that they could introduce.
run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
......
module TcRnTypes where
-- Build ordering
import GHC.Base()
data TcLclEnv
...@@ -26,7 +26,7 @@ module TcSplice( ...@@ -26,7 +26,7 @@ module TcSplice(
runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
tcTopSpliceExpr, lookupThName_maybe, tcTopSpliceExpr, lookupThName_maybe,
defaultRunMeta, runMeta', runRemoteModFinalizers, defaultRunMeta, runMeta', runRemoteModFinalizers,
finishTH finishTH, runTopSplice
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -58,7 +58,7 @@ import HscMain ...@@ -58,7 +58,7 @@ import HscMain
-- These imports are the reason that TcSplice -- These imports are the reason that TcSplice
-- is very high up the module hierarchy -- is very high up the module hierarchy
import FV import FV
import RnSplice( traceSplice, SpliceInfo(..) ) import RnSplice( traceSplice, SpliceInfo(..))
import RdrName import RdrName
import HscTypes import HscTypes
import Convert import Convert
...@@ -491,28 +491,44 @@ tcTopSplice expr res_ty ...@@ -491,28 +491,44 @@ tcTopSplice expr res_ty
-- making sure it has type Q (T res_ty) -- making sure it has type Q (T res_ty)
res_ty <- expTypeToType res_ty res_ty <- expTypeToType res_ty
; meta_exp_ty <- tcTExpTy res_ty ; meta_exp_ty <- tcTExpTy res_ty
; zonked_q_expr <- tcTopSpliceExpr Typed $ ; q_expr <- tcTopSpliceExpr Typed $
tcMonoExpr expr (mkCheckExpType meta_exp_ty) tcMonoExpr expr (mkCheckExpType meta_exp_ty)
; lcl_env <- getLclEnv
; let delayed_splice
= DelayedSplice lcl_env expr res_ty q_expr
; return (HsSpliceE noExt (HsSplicedT delayed_splice))
-- See Note [Collecting modFinalizers in typed splices]. }
-- This is called in the zonker
-- See Note [Running typed splices in the zonker]
runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
= setLclEnv lcl_env $ do {
zonked_ty <- zonkTcType res_ty
; zonked_q_expr <- zonkTopLExpr q_expr
-- See Note [Collecting modFinalizers in typed splices].
; modfinalizers_ref <- newTcRef [] ; modfinalizers_ref <- newTcRef []
-- Run the expression -- Run the expression
; expr2 <- setStage (RunSplice modfinalizers_ref) $ ; expr2 <- setStage (RunSplice modfinalizers_ref) $
runMetaE zonked_q_expr runMetaE zonked_q_expr
; mod_finalizers <- readTcRef modfinalizers_ref ; mod_finalizers <- readTcRef modfinalizers_ref
; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
-- We use orig_expr here and not q_expr when tracing as a call to
-- unsafeTExpCoerce is added to the original expression by the
-- typechecker when typed quotes are type checked.
; traceSplice (SpliceInfo { spliceDescription = "expression" ; traceSplice (SpliceInfo { spliceDescription = "expression"
, spliceIsDecl = False , spliceIsDecl = False
, spliceSource = Just expr , spliceSource = Just orig_expr
, spliceGenerated = ppr expr2 }) , spliceGenerated = ppr expr2 })
-- Rename and typecheck the spliced-in expression,
-- making sure it has type res_ty
-- These steps should never fail; this is a *typed* splice
; addErrCtxt (spliceResultDoc zonked_q_expr) $ do
{ (exp3, _fvs) <- rnLExpr expr2
; unLoc <$> tcMonoExpr exp3 (mkCheckExpType zonked_ty)} }
-- Rename and typecheck the spliced-in expression,
-- making sure it has type res_ty
-- These steps should never fail; this is a *typed* splice
; addErrCtxt (spliceResultDoc expr) $ do
{ (exp3, _fvs) <- rnLExpr expr2
; exp4 <- tcMonoExpr exp3 (mkCheckExpType res_ty)
; return (unLoc exp4) } }
{- {-
************************************************************************ ************************************************************************
...@@ -527,7 +543,7 @@ spliceCtxtDoc splice ...@@ -527,7 +543,7 @@ spliceCtxtDoc splice
= hang (text "In the Template Haskell splice") = hang (text "In the Template Haskell splice")
2 (pprSplice splice) 2 (pprSplice splice)
spliceResultDoc :: LHsExpr GhcRn -> SDoc spliceResultDoc :: LHsExpr GhcTc -> SDoc
spliceResultDoc expr spliceResultDoc expr
= sep [ text "In the result of the splice:" = sep [ text "In the result of the splice:"
, nest 2 (char '$' <> ppr expr) , nest 2 (char '$' <> ppr expr)
...@@ -559,7 +575,7 @@ tcTopSpliceExpr isTypedSplice tc_action ...@@ -559,7 +575,7 @@ tcTopSpliceExpr isTypedSplice tc_action
; const_binds <- simplifyTop wanted ; const_binds <- simplifyTop wanted
-- Zonk it and tie the knot of dictionary bindings -- Zonk it and tie the knot of dictionary bindings
; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') } ; return $ mkHsDictLet (EvBinds const_binds) expr' }
{- {-
************************************************************************ ************************************************************************
...@@ -578,7 +594,7 @@ runAnnotation target expr = do ...@@ -578,7 +594,7 @@ runAnnotation target expr = do
-- Check the instances we require live in another module (we want to execute it..) -- Check the instances we require live in another module (we want to execute it..)
-- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
-- also resolves the LIE constraints to detect e.g. instance ambiguity -- also resolves the LIE constraints to detect e.g. instance ambiguity
zonked_wrapped_expr' <- tcTopSpliceExpr Untyped $ zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped (
do { (expr', expr_ty) <- tcInferRhoNC expr do { (expr', expr_ty) <- tcInferRhoNC expr
-- We manually wrap the typechecked expression in a call to toAnnotationWrapper -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
-- By instantiating the call >here< it gets registered in the -- By instantiating the call >here< it gets registered in the
...@@ -589,7 +605,8 @@ runAnnotation target expr = do ...@@ -589,7 +605,8 @@ runAnnotation target expr = do
= L loc (mkHsWrap wrapper = L loc (mkHsWrap wrapper
(HsVar noExt (L loc to_annotation_wrapper_id))) (HsVar noExt (L loc to_annotation_wrapper_id)))
; return (L loc (HsApp noExt ; return (L loc (HsApp noExt
specialised_to_annotation_wrapper_expr expr')) } specialised_to_annotation_wrapper_expr expr'))
})
-- Run the appropriately wrapped expression to get the value of -- Run the appropriately wrapped expression to get the value of
-- the annotation and its dictionaries. The return value is of -- the annotation and its dictionaries. The return value is of
...@@ -790,6 +807,58 @@ runMeta' show_code ppr_hs run_and_convert expr ...@@ -790,6 +807,58 @@ runMeta' show_code ppr_hs run_and_convert expr
failWithTc msg failWithTc msg
{- {-
Note [Running typed splices in the zonker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #15471 for the full discussion.
For many years typed splices were run immediately after they were type checked
however, this is too early as it means to zonk some type variables before
they can be unified with type variables in the surrounding context.
For example,
```
module A where
test_foo :: forall a . Q (TExp (a -> a))
test_foo = [|| id ||]
module B where
import A
qux = $$(test_foo)
```
We would expect `qux` to have inferred type `forall a . a -> a` but if
we run the splices too early the unified variables are zonked to `Any`. The
inferred type is the unusable `Any -> Any`.
To run the splice, we must compile `test_foo` all the way to byte code.
But at the moment when the type checker is looking at the splice, test_foo
has type `Q (TExp (alpha -> alpha))` and we
certainly can't compile code involving unification variables!
We could default `alpha` to `Any` but then we infer `qux :: Any -> Any`
which definitely is not what we want. Moreover, if we had
qux = [$$(test_foo), (\x -> x +1::Int)]
then `alpha` would have to be `Int`.
Conclusion: we must defer taking decisions about `alpha` until the
typechecker is done; and *then* we can run the splice. It's fine to do it
later, because we know it'll produce type-correct code.
Deferring running the splice until later, in the zonker, means that the
unification variables propagate upwards from the splice into the surrounding
context and are unified correctly.
This is implemented by storing the arguments we need for running the splice
in a `DelayedSplice`. In the zonker, the arguments are passed to
`TcSplice.runTopSplice` and the expression inserted into the AST as normal.
Note [Exceptions in TH] Note [Exceptions in TH]
~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have something like this Suppose we have something like this
......
...@@ -5,11 +5,11 @@ module TcSplice where ...@@ -5,11 +5,11 @@ module TcSplice where
import GhcPrelude import GhcPrelude
import Name import Name
import HsExpr ( PendingRnSplice ) import HsExpr ( PendingRnSplice, DelayedSplice )
import TcRnTypes( TcM , SpliceType ) import TcRnTypes( TcM , SpliceType )
import TcType ( ExpRhoType ) import TcType ( ExpRhoType )
import Annotations ( Annotation, CoreAnnTarget ) import Annotations ( Annotation, CoreAnnTarget )
import HsExtension ( GhcTcId, GhcRn, GhcPs ) import HsExtension ( GhcTcId, GhcRn, GhcPs, GhcTc )
import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,
LHsDecl, ThModFinalizers ) LHsDecl, ThModFinalizers )
...@@ -29,6 +29,8 @@ tcTypedBracket :: HsExpr GhcRn ...@@ -29,6 +29,8 @@ tcTypedBracket :: HsExpr GhcRn
-> ExpRhoType -> ExpRhoType
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId) tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
......
{-# LANGUAGE TemplateHaskell #-}
module T15471 where
import T15471A
qux = $$(test_foo)
bar y = $$(list_foo [|| y ||] )
main = print (qux 5) >> print (bar True)
{-# LANGUAGE TemplateHaskell #-}
module T15471A where
import Language.Haskell.TH
foo1 x = x
test_foo :: Q (TExp (a -> a))
test_foo = [|| foo1 ||]
list_foo :: Q (TExp a) -> Q (TExp [a])
list_foo x = [|| [ $$x, $$x ] ||]
...@@ -466,3 +466,4 @@ test('T15437', expect_broken(15437), multimod_compile, ...@@ -466,3 +466,4 @@ test('T15437', expect_broken(15437), multimod_compile,
['T15437', '-v0 ' + config.ghc_th_way_flags]) ['T15437', '-v0 ' + config.ghc_th_way_flags])
test('T15985', normal, compile, ['']) test('T15985', normal, compile, [''])
test('T16133', normal, compile_fail, ['']) test('T16133', normal, compile_fail, [''])
test('T15471', normal, multimod_compile, ['T15471.hs', '-v0'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment