From 262eb168805b09df52532a5c207457f5d75d4459 Mon Sep 17 00:00:00 2001 From: Geoffrey Mainland Date: Wed, 1 May 2013 17:45:22 +0100 Subject: [PATCH] Track TH stage in the renamer. --- compiler/basicTypes/RdrName.lhs | 48 ++-- compiler/deSugar/DsExpr.lhs | 1 + compiler/deSugar/DsMeta.hs | 2 +- compiler/hsSyn/HsExpr.lhs | 70 ++++- compiler/rename/RnEnv.lhs | 13 +- compiler/rename/RnExpr.lhs | 11 +- compiler/rename/RnSplice.lhs | 379 ++++++++++++++++++++------- compiler/typecheck/TcEnv.lhs | 34 ++- compiler/typecheck/TcExpr.lhs | 10 +- compiler/typecheck/TcHsSyn.lhs | 23 +- compiler/typecheck/TcSplice.lhs | 234 ++++++++--------- compiler/typecheck/TcSplice.lhs-boot | 13 +- 12 files changed, 557 insertions(+), 281 deletions(-) diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 3ff3bbb82f8d..e32ad661dc19 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -46,7 +46,8 @@ module RdrName ( -- * Local mapping of 'RdrName' to 'Name.Name' LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope, + lookupLocalRdrEnv, lookupLocalRdrThLvl, lookupLocalRdrOcc, + elemLocalRdrEnv, inLocalRdrEnvScope, localRdrEnvElts, delLocalRdrEnvList, -- * Global mapping of 'RdrName' to 'GlobalRdrElt's @@ -331,40 +332,51 @@ instance Ord RdrName where -- It is keyed by OccName, because we never use it for qualified names -- We keep the current mapping, *and* the set of all Names in scope -- Reason: see Note [Splicing Exact Names] in RnEnv -type LocalRdrEnv = (OccEnv Name, NameSet) +type ThLevel = Int +type LocalRdrEnv = (OccEnv Name, OccEnv ThLevel, NameSet) emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet) - -extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv -extendLocalRdrEnv (env, ns) name - = (extendOccEnv env (nameOccName name) name, addOneToNameSet ns name) - -extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnvList (env, ns) names - = (extendOccEnvList env [(nameOccName n, n) | n <- names], addListToNameSet ns names) +emptyLocalRdrEnv = (emptyOccEnv, emptyOccEnv, emptyNameSet) + +extendLocalRdrEnv :: LocalRdrEnv -> ThLevel -> Name -> LocalRdrEnv +extendLocalRdrEnv (env, thenv, ns) thlvl name + = ( extendOccEnv env (nameOccName name) name + , extendOccEnv thenv (nameOccName name) thlvl + , addOneToNameSet ns name + ) + +extendLocalRdrEnvList :: LocalRdrEnv -> ThLevel -> [Name] -> LocalRdrEnv +extendLocalRdrEnvList (env, thenv, ns) thlvl names + = ( extendOccEnvList env [(nameOccName n, n) | n <- names] + , extendOccEnvList thenv [(nameOccName n, thlvl) | n <- names] + , addListToNameSet ns names + ) lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ -lookupLocalRdrEnv _ _ = Nothing +lookupLocalRdrEnv (env, _, _) (Unqual occ) = lookupOccEnv env occ +lookupLocalRdrEnv _ _ = Nothing + +lookupLocalRdrThLvl :: LocalRdrEnv -> RdrName -> Maybe ThLevel +lookupLocalRdrThLvl (_, thenv, _) (Unqual occ) = lookupOccEnv thenv occ +lookupLocalRdrThLvl _ _ = Nothing lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ +lookupLocalRdrOcc (env, _, _) occ = lookupOccEnv env occ elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name (env, _) +elemLocalRdrEnv rdr_name (env, _, _) | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env | otherwise = False localRdrEnvElts :: LocalRdrEnv -> [Name] -localRdrEnvElts (env, _) = occEnvElts env +localRdrEnvElts (env, _, _) = occEnvElts env inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool -- This is the point of the NameSet -inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns +inLocalRdrEnvScope name (_, _, ns) = name `elemNameSet` ns delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv -delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns) +delLocalRdrEnvList (env, thenv, ns) occs = (delListFromOccEnv env occs, delListFromOccEnv thenv occs, ns) \end{code} %************************************************************************ diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 8c53c1aea1e7..4ce75839dd73 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -568,6 +568,7 @@ Here is where we desugar the Template Haskell brackets and escapes \begin{code} -- Template Haskell stuff +dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" #ifdef GHCI dsExpr (HsBracketOut x ps) = dsBracket x ps #else diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 6232825aa689..2d4601e0b659 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -74,7 +74,7 @@ dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr dsBracket brack splices = dsExtendMetaEnv new_bit (do_brack brack) where - new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices] + new_bit = mkNameEnv [(n, Splice (unLoc e)) | PendingTcSplice n e <- splices] do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 } do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 36d6ceec80f8..79d53ae47409 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -218,6 +218,13 @@ data HsExpr id | HsBracket (HsBracket id) + -- See Note [Pending Renamer Splices] + | HsRnBracketOut (HsBracket Name) -- Output of the renamer is + -- the *original* + [PendingSplice] -- renamed expression, plus + -- _renamed_ splices to be + -- type checked + | HsBracketOut (HsBracket Name) -- Output of the type checker is -- the *original* [PendingSplice] -- renamed expression, plus @@ -308,11 +315,50 @@ tupArgPresent :: HsTupArg id -> Bool tupArgPresent (Present {}) = True tupArgPresent (Missing {}) = False -type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be - -- pasted back in by the desugarer - +-- See Note [Pending Splices] +data PendingSplice + = PendingRnExpSplice Name (LHsExpr Name) + | PendingRnTypeSplice Name (LHsExpr Name) + | PendingRnCrossStageSplice Name + | PendingTcSplice Name (LHsExpr Id) + deriving (Data, Typeable) \end{code} +Note [Pending Splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Now that untyped brackets are not type checked, we need a mechanism to ensure +that splices contained in untyped brackets *are* type checked. Therefore the +renamer now renames every HsBracket into a HsRnBracketOut, which contains the +splices that need to be type checked. There are three varieties of pending +splices generated by the renamer: + + * Pending expression splices (PendingRnExpSplice), e.g., + + [|$(f x) + 2|] + + * Pending type splices (PendingRnTypeSplice), e.g., + + [|f :: $(g x)|] + + * Pending cross-stage splices (PendingRnCrossStageSplice), e.g., + + \x -> [| x |] + +There is a fourth variety of pending splice, which is generated by the type +checker: + + * Pending *typed* expression splices, (PendingTcSplice), e.g., + + [||1 + $$(f 2)||] + +It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the +output of the renamer. However, when pretty printing the output of the renamer, +e.g., in a type error message, we *do not* want to print out the pending +splices. In contrast, when pretty printing the output of the type checker, we +*do* want to print the pending splices. So splitting them up seems to make +sense, although I hate to add another constructor to HsExpr. + Note [Parens in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~ HsPar (and ParPat in patterns, HsParTy in types) is used as follows @@ -517,11 +563,12 @@ ppr_expr (HsSCC lbl expr) ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn ppr_expr (HsType id) = ppr id -ppr_expr (HsSpliceE s) = pprSplice s -ppr_expr (HsBracket b) = pprHsBracket b -ppr_expr (HsBracketOut e []) = ppr e -ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps -ppr_expr (HsQuasiQuoteE qq) = ppr qq +ppr_expr (HsSpliceE s) = pprSplice s +ppr_expr (HsBracket b) = pprHsBracket b +ppr_expr (HsRnBracketOut e _) = ppr e +ppr_expr (HsBracketOut e []) = ppr e +ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps +ppr_expr (HsQuasiQuoteE qq) = ppr qq ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd] @@ -608,6 +655,7 @@ hsExprNeedsParens (ExplicitList {}) = False hsExprNeedsParens (ExplicitPArr {}) = False hsExprNeedsParens (HsPar {}) = False hsExprNeedsParens (HsBracket {}) = False +hsExprNeedsParens (HsRnBracketOut {}) = False hsExprNeedsParens (HsBracketOut _ []) = False hsExprNeedsParens (HsDo sc _ _) | isListCompExpr sc = False @@ -1237,6 +1285,12 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> thTyBrackets :: SDoc -> SDoc thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]") + +instance Outputable PendingSplice where + ppr (PendingRnExpSplice name expr) = ppr (name, expr) + ppr (PendingRnTypeSplice name expr) = ppr (name, expr) + ppr (PendingRnCrossStageSplice name) = ppr name + ppr (PendingTcSplice name expr) = ppr (name, expr) \end{code} %************************************************************************ diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c3fd407ff96a..bf32dbafec88 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -9,6 +9,7 @@ module RnEnv ( lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, + lookupLocalOccThLvl_maybe, lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, @@ -536,6 +537,12 @@ lookupLocalOccRn_maybe rdr_name = do { local_env <- getLocalRdrEnv ; return (lookupLocalRdrEnv local_env rdr_name) } +lookupLocalOccThLvl_maybe :: RdrName -> RnM (Maybe ThLevel) +-- Just look in the local environment +lookupLocalOccThLvl_maybe rdr_name + = do { local_env <- getLocalRdrEnv + ; return (lookupLocalRdrThLvl local_env rdr_name) } + -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name = do @@ -1236,13 +1243,15 @@ bindLocatedLocalsRn rdr_names_w_loc enclosed_scope bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names enclosed_scope = do { name_env <- getLocalRdrEnv - ; setLocalRdrEnv (extendLocalRdrEnvList name_env names) + ; stage <- getStage + ; setLocalRdrEnv (extendLocalRdrEnvList name_env (thLevel stage) names) enclosed_scope } bindLocalName :: Name -> RnM a -> RnM a bindLocalName name enclosed_scope = do { name_env <- getLocalRdrEnv - ; setLocalRdrEnv (extendLocalRdrEnv name_env name) + ; stage <- getStage + ; setLocalRdrEnv (extendLocalRdrEnv name_env (thLevel stage) name) enclosed_scope } bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 62f0709f61dc..a556d079554f 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -98,8 +98,15 @@ finishHsVar name ; return (e, unitFV name) } } rnExpr (HsVar v) - = do name <- lookupOccRn v - finishHsVar name + = do { name <- lookupOccRn v + ; mb_bind_lvl <- lookupLocalOccThLvl_maybe v + ; case mb_bind_lvl of + { Nothing -> return () + ; Just bind_lvl + | isExternalName name -> return () + | otherwise -> checkThLocalName name bind_lvl + } + ; finishHsVar name } rnExpr (HsIPVar v) = return (HsIPVar v, emptyFVs) diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs index 53c5167db4aa..2e8133501591 100644 --- a/compiler/rename/RnSplice.lhs +++ b/compiler/rename/RnSplice.lhs @@ -1,27 +1,54 @@ \begin{code} module RnSplice ( rnSpliceType, rnSpliceExpr, - rnBracket, checkTH + rnBracket, checkTH, + checkThLocalName ) where -import Control.Monad ( unless, when ) -import DynFlags import FastString import Name import NameSet import HsSyn -import LoadIface ( loadInterfaceForName ) import Outputable import RdrName +import TcRnMonad + +#ifdef GHCI +import Control.Monad ( unless, when ) +import DynFlags +import DsMeta ( expQTyConName, typeQTyConName ) +import LoadIface ( loadInterfaceForName ) import RnEnv import RnPat import RnSource ( rnSrcDecls, findSplice ) import RnTypes import SrcLoc -import TcEnv ( tcLookup, thTopLevelId ) -import TcRnMonad +import TcEnv ( checkWellStaged, tcLookup, tcMetaTy, thTopLevelId ) + +import {-# SOURCE #-} RnExpr ( rnLExpr ) +import {-# SOURCE #-} TcExpr ( tcMonoExpr ) +import {-# SOURCE #-} TcSplice ( runMetaE, runMetaT, tcTopSpliceExpr ) +#endif +\end{code} + +\begin{code} +#ifndef GHCI +rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) +rnBracket e _ = failTH e "bracket" -import {-# SOURCE #-} RnExpr( rnLExpr ) +rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) +rnSpliceType e _ = failTH e "splice" + +rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) +rnSpliceExpr e = failTH e "splice" + +failTH :: Outputable a => a -> String -> RnM b +failTH e what -- Raise an error in a stage-1 compiler + = failWithTc (vcat [ptext (sLit "Template Haskell") <+> text what <+> + ptext (sLit "requires GHC with interpreter support"), + ptext (sLit "Perhaps you are using a stage-1 compiler?"), + nest 2 (ppr e)]) +#else \end{code} %********************************************************* @@ -57,89 +84,128 @@ rnSplice (HsSplice isTyped n expr) ; n' <- newLocalBndrRn (L loc n) ; (expr', fvs) <- rnLExpr expr - -- Ugh! See Note [Splices] above - ; lcl_rdr <- getLocalRdrEnv - ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, - isLocalGRE gre] - lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + ; if isTyped + then do + { -- Ugh! See Note [Splices] above + lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, + isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - ; return (HsSplice isTyped n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } + ; return (HsSplice isTyped n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) + } + else return (HsSplice isTyped n' expr', fvs) + } \end{code} \begin{code} rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) -rnSpliceType splice@(HsSplice _ _ hs_expr) k - = setSrcSpan (getLoc hs_expr) $ do +rnSpliceType splice@(HsSplice isTypedSplice _ expr) k + = setSrcSpan (getLoc expr) $ do { stage <- getStage - ; case stage of { - Splice {} -> rnTopSpliceType splice k ; - Comp -> rnTopSpliceType splice k ; - - Brack _ pop_level _ _ -> do - -- See Note [How brackets and nested splices are handled] - -- A splice inside brackets - { (splice', fvs) <- setStage pop_level $ - rnSplice splice -- ToDo: deal with fvs - ; return (HsSpliceTy splice' fvs k, fvs) - }}} - -rnTopSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) -rnTopSpliceType splice@(HsSplice _ _ hs_expr) k - = do { (splice', fvs) <- addErrCtxt (spliceResultDoc hs_expr) $ - rnSplice splice -- ToDo: deal with fvs - ; return (HsSpliceTy splice' fvs k, fvs) + ; case stage of + { Brack isTypedBrack pop_stage ps_var _ -> + do { when (isTypedBrack && not isTypedSplice) $ + failWithTc illegalUntypedSplice + ; when (not isTypedBrack && isTypedSplice) $ + failWithTc illegalTypedSplice + + -- ToDo: deal with fvs + ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $ + rnSplice splice + + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendingRnTypeSplice name expr' : ps) + + ; return (HsSpliceTy splice' fvs k, fvs) + } + ; _ -> + do { -- ToDo: deal with fvs + (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $ + setStage (Splice isTypedSplice) $ + rnSplice splice + ; maybeExpandTopSplice splice' fvs + } } + } + where + maybeExpandTopSplice :: HsSplice Name -> FreeVars -> RnM (HsType Name, FreeVars) + maybeExpandTopSplice splice@(HsSplice True _ _) fvs + = return (HsSpliceTy splice fvs k, fvs) + + maybeExpandTopSplice (HsSplice False _ expr) _ + = do { -- The splice must have type TypeQ + ; meta_exp_ty <- tcMetaTy typeQTyConName + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr False $ + tcMonoExpr expr meta_exp_ty + + -- Run the expression + ; hs_ty2 <- runMetaT zonked_q_expr + ; showSplice "type" expr (ppr hs_ty2) + + ; (hs_ty3, fvs) <- addErrCtxt (spliceResultDoc expr) $ + do { let doc = SpliceTypeCtx hs_ty2 + ; checkNoErrs $ rnLHsType doc hs_ty2 + -- checkNoErrs: see Note [Renamer errors] + } + ; return (unLoc hs_ty3, fvs) + } \end{code} \begin{code} rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) rnSpliceExpr splice@(HsSplice isTypedSplice _ expr) - = setSrcSpan (getLoc expr) $ do + = addErrCtxt (exprCtxt (HsSpliceE splice)) $ + setSrcSpan (getLoc expr) $ do { stage <- getStage - ; case stage of { - Splice {} -> rnTopSplice ; - Comp -> rnTopSplice ; - - Brack isTypedBrack pop_stage _ _ -> do - - -- See Note [How brackets and nested splices are handled] - -- A splice inside brackets - -- NB: ignore res_ty, apart from zapping it to a mono-type - -- e.g. [| reverse $(h 4) |] - -- Here (h 4) :: Q Exp - -- but $(h 4) :: forall a.a i.e. anything! - - { when (isTypedBrack && not isTypedSplice) $ - failWithTc illegalUntypedSplice - ; when (not isTypedBrack && isTypedSplice) $ - failWithTc illegalTypedSplice - - ; (splice', fvs) <- setStage pop_stage $ - rnSplice splice - ; return (HsSpliceE splice', fvs) - }}} + ; case stage of + { Brack isTypedBrack pop_stage ps_var _ -> + do { when (isTypedBrack && not isTypedSplice) $ + failWithTc illegalUntypedSplice + ; when (not isTypedBrack && isTypedSplice) $ + failWithTc illegalTypedSplice + + ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $ + rnSplice splice + + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendingRnExpSplice name expr' : ps) + + ; return (HsSpliceE splice', fvs) + } + ; _ -> + do { (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $ + setStage (Splice isTypedSplice) $ + rnSplice splice + ; maybeExpandTopSplice splice' fvs + } + } + } where - rnTopSplice :: RnM (HsExpr Name, FreeVars) - rnTopSplice - = do { (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $ - setStage (Splice isTypedSplice) $ - rnSplice splice - ; return (HsSpliceE splice', fvs) - } -\end{code} - -\begin{code} -checkTH :: Outputable a => a -> String -> RnM () -#ifdef GHCI -checkTH _ _ = return () -- OK -#else -checkTH e what -- Raise an error in a stage-1 compiler - = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "requires GHC with interpreter support"), - ptext (sLit "Perhaps you are using a stage-1 compiler?"), - nest 2 (ppr e)]) -#endif + maybeExpandTopSplice :: HsSplice Name -> FreeVars -> RnM (HsExpr Name, FreeVars) + maybeExpandTopSplice splice@(HsSplice True _ _) fvs + = return (HsSpliceE splice, fvs) + + maybeExpandTopSplice (HsSplice False _ expr) _ + = do { -- The splice must have type ExpQ + ; meta_exp_ty <- tcMetaTy expQTyConName + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr False $ + tcMonoExpr expr meta_exp_ty + + -- Run the expression + ; expr2 <- runMetaE zonked_q_expr + ; showSplice "expression" expr (ppr expr2) + + ; (lexpr3, fvs) <- addErrCtxt (spliceResultDoc expr) $ + checkNoErrs $ + rnLExpr expr2 + ; return (unLoc lexpr3, fvs) + } \end{code} %************************************************************************ @@ -172,11 +238,14 @@ rnBracket e br_body -- Brackets are desugared to code that mentions the TH package ; recordThUse - ; let brack_stage = Brack (isTypedBracket br_body) cur_stage (error "rnBracket1") (error "rnBracket2") + ; pending_splices <- newMutVar [] + ; let brack_stage = Brack (isTypedBracket br_body) cur_stage pending_splices (error "rnBracket: don't neet lie") ; (body', fvs_e) <- setStage brack_stage $ rn_bracket cur_stage br_body - ; return (HsBracket body', fvs_e) + ; pendings <- readMutVar pending_splices + + ; return (HsRnBracketOut body' pendings, fvs_e) } rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars) @@ -184,26 +253,42 @@ rn_bracket outer_stage br@(VarBr flg n) = do { name <- lookupOccRn n ; this_mod <- getModule - -- Reason: deprecation checking assumes - -- the home interface is loaded, and - -- this is the only way that is going - -- to happen - ; unless (nameIsLocalOrFrom this_mod name) $ - do { _ <- loadInterfaceForName msg name - ; thing <- tcLookup name - ; case thing of - { AGlobal {} -> return () - ; ATyVar {} -> return () - ; ATcId { tct_level = bind_lvl, tct_id = id } - | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting - -> keepAliveTc id - | otherwise - -> do { checkTc (thLevel outer_stage + 1 == bind_lvl) - (quotedNameStageErr br) } - ; _ -> pprPanic "rh_bracket" (ppr name $$ ppr thing) - } - } - + ; case flg of + { -- Type variables can be quoted in TH. See #5721. + False -> return () + ; True | nameIsLocalOrFrom this_mod name -> + do { mb_bind_lvl <- lookupLocalOccThLvl_maybe n + ; case mb_bind_lvl of + { Nothing -> return () + ; Just bind_lvl + | isExternalName name -> return () + -- Local non-external things can still be + -- top-level in GHCi, so check for that here. + | bind_lvl == impLevel -> return () + | otherwise -> checkTc (thLevel outer_stage + 1 == bind_lvl) + (quotedNameStageErr br) + } + } + ; True | otherwise -> + -- Reason: deprecation checking assumes + -- the home interface is loaded, and + -- this is the only way that is going + -- to happen + do { _ <- loadInterfaceForName msg name + ; thing <- tcLookup name + ; case thing of + { AGlobal {} -> return () + ; ATyVar {} -> return () + ; ATcId { tct_level = bind_lvl, tct_id = id } + | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting + -> keepAliveTc id + | otherwise + -> do { checkTc (thLevel outer_stage + 1 == bind_lvl) + (quotedNameStageErr br) } + ; _ -> pprPanic "rh_bracket" (ppr name $$ ppr thing) + } + } + } ; return (VarBr flg name, unitFV name) } where msg = ptext (sLit "Need interface for Template Haskell quoted Name") @@ -246,6 +331,23 @@ rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e \end{code} \begin{code} +exprCtxt :: HsExpr RdrName -> SDoc +exprCtxt expr + = hang (ptext (sLit "In the expression:")) 2 (ppr expr) + +showSplice :: String -> LHsExpr Name -> SDoc -> TcM () +-- Note that 'before' is *renamed* but not *typechecked* +-- Reason (a) less typechecking crap +-- (b) data constructors after type checking have been +-- changed to their *wrappers*, and that makes them +-- print always fully qualified +showSplice what before after + = do { loc <- getSrcSpanM + ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, + nest 2 (sep [nest 2 (ppr before), + text "======>", + nest 2 after])]) } + illegalBracket :: SDoc illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)") @@ -266,7 +368,84 @@ quotedNameStageErr br = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br , ptext (sLit "must be used at the same stage at which is is bound")] -spliceResultDoc :: LHsExpr RdrName -> SDoc +spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc spliceResultDoc expr - = hang (ptext (sLit "In the splice:")) 2 (char '$' <> pprParendExpr expr) + = sep [ ptext (sLit "In the result of the splice:") + , nest 2 (char '$' <> pprParendExpr expr) + , ptext (sLit "To see what the splice expanded to, use -ddump-splices")] +#endif +\end{code} + +\begin{code} +checkTH :: Outputable a => a -> String -> RnM () +#ifdef GHCI +checkTH _ _ = return () -- OK +#else +checkTH e what -- Raise an error in a stage-1 compiler + = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> + ptext (sLit "requires GHC with interpreter support"), + ptext (sLit "Perhaps you are using a stage-1 compiler?"), + nest 2 (ppr e)]) +#endif +\end{code} + +\begin{code} +checkThLocalName :: Name -> ThLevel -> RnM () +#ifndef GHCI /* GHCI and TH is off */ +-------------------------------------- +-- Check for cross-stage lifting +checkThLocalName _name _bind_lvl + = return () + +#else /* GHCI and TH is on */ +checkThLocalName name bind_lvl + = do { use_stage <- getStage -- TH case + ; let use_lvl = thLevel use_stage + ; traceRn (text "checkThLocalName" <+> ppr name) + ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl + ; traceTc "thLocalId" (ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl) + ; when (use_lvl > bind_lvl) $ + checkCrossStageLifting name bind_lvl use_stage } + +-------------------------------------- +checkCrossStageLifting :: Name -> ThLevel -> ThStage -> TcM () +-- We are inside brackets, and (use_lvl > bind_lvl) +-- Now we must check whether there's a cross-stage lift to do +-- Examples \x -> [| x |] +-- [| map |] + +checkCrossStageLifting _ _ Comp = return () +checkCrossStageLifting _ _ (Splice _) = return () + +checkCrossStageLifting name _ (Brack _ _ ps_var _) + | isExternalName name + = -- Top-level identifiers in this module, + -- (which have External Names) + -- are just like the imported case: + -- no need for the 'lifting' treatment + -- E.g. this is fine: + -- f x = x + -- g y = [| f 3 |] + -- But we do need to put f into the keep-alive + -- set, because after desugaring the code will + -- only mention f's *name*, not f itself. + -- + -- The type checker will put f into the keep-alive set. + return () + | otherwise + = -- Nested identifiers, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the splice proxy, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same splice proxy, but that doesn't + -- matter, although it's a mite untidy. + do { traceRn (text "checkCrossStageLifting" <+> ppr name) + ; -- Update the pending splices + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendingRnCrossStageSplice name : ps) + } +#endif /* GHCI */ \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 01bffd998163..3675b4e26873 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -328,7 +328,9 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv \begin{code} tcExtendTcTyThingEnv :: [(Name, TcTyThing)] -> TcM r -> TcM r tcExtendTcTyThingEnv things thing_inside - = updLclEnv (extend_local_env things) thing_inside + = do { stage <- getStage + ; updLclEnv (extend_local_env (thLevel stage) things) thing_inside + } tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r tcExtendKindEnv name_kind_prs @@ -342,10 +344,11 @@ tcExtendTyVarEnv tvs thing_inside tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r tcExtendTyVarEnv2 binds thing_inside - = tc_extend_local_env [(name, ATyVar name tv) | (name, tv) <- binds] $ - do { env <- getLclEnv - ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) } - ; setLclEnv env' thing_inside } + = do { stage <- getStage + ; tc_extend_local_env (thLevel stage) [(name, ATyVar name tv) | (name, tv) <- binds] $ + do { env <- getLclEnv + ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) } + ; setLclEnv env' thing_inside }} where add_tidy_tvs env = foldl add env binds @@ -371,7 +374,8 @@ getScopedTyVarBinds tcExtendLetEnv :: TopLevelFlag -> [TcId] -> TcM a -> TcM a tcExtendLetEnv closed ids thing_inside = do { stage <- getStage - ; tc_extend_local_env [ (idName id, ATcId { tct_id = id + ; tc_extend_local_env (thLevel stage) + [ (idName id, ATcId { tct_id = id , tct_closed = closed , tct_level = thLevel stage }) | id <- ids] @@ -389,7 +393,8 @@ tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) tcExtendIdEnv2 names_w_ids thing_inside = do { stage <- getStage - ; tc_extend_local_env [ (name, ATcId { tct_id = id + ; tc_extend_local_env (thLevel stage) + [ (name, ATcId { tct_id = id , tct_closed = NotTopLevel , tct_level = thLevel stage }) | (name,id) <- names_w_ids] @@ -404,7 +409,8 @@ tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a -- * Closedness flag is TopLevel. The thing's type is closed tcExtendGhciEnv ids thing_inside - = tc_extend_local_env [ (idName id, ATcId { tct_id = id + = tc_extend_local_env impLevel + [ (idName id, ATcId { tct_id = id , tct_closed = is_top id , tct_level = impLevel }) | id <- ids] @@ -414,7 +420,7 @@ tcExtendGhciEnv ids thing_inside | otherwise = NotTopLevel -tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a +tc_extend_local_env :: ThLevel -> [(Name, TcTyThing)] -> TcM a -> TcM a -- This is the guy who does the work -- Invariant: the TcIds are fully zonked. Reasons: -- (a) The kinds of the forall'd type variables are defaulted @@ -423,10 +429,10 @@ tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a -- in the types, because instantiation does not look through such things -- (c) The call to tyVarsOfTypes is ok without looking through refs -tc_extend_local_env extra_env thing_inside +tc_extend_local_env thlvl extra_env thing_inside = do { traceTc "env2" (ppr extra_env) ; env1 <- getLclEnv - ; let env2 = extend_local_env extra_env env1 + ; let env2 = extend_local_env thlvl extra_env env1 ; env3 <- extend_gtvs env2 ; setLclEnv env3 thing_inside } where @@ -461,10 +467,10 @@ tc_extend_local_env extra_env thing_inside -- -- Nor must we generalise g over any kind variables free in r's kind -extend_local_env :: [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv +extend_local_env :: ThLevel -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv -- Extend the local TcTypeEnv *and* the local LocalRdrEnv simultaneously -extend_local_env pairs env@(TcLclEnv { tcl_rdr = rdr_env, tcl_env = type_env }) - = env { tcl_rdr = extendLocalRdrEnvList rdr_env (map fst pairs) +extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env, tcl_env = type_env }) + = env { tcl_rdr = extendLocalRdrEnvList rdr_env thlvl (map fst pairs) , tcl_env = extendNameEnvList type_env pairs } tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 41e9dc2a28a3..0adb2ee23807 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -806,9 +806,11 @@ tcExpr (PArrSeq _ _) _ \begin{code} #ifdef GHCI /* Only if bootstrapped */ -- Rename excludes these cases otherwise -tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty -tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty - ; return (unLoc e) } +tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty +tcExpr (HsRnBracketOut brack ps) res_ty = do { e <- tcBracket brack ps res_ty + ; return (unLoc e) } +tcExpr e@(HsBracketOut _ _) _ = + pprPanic "Should never see HsBracketOut in type checker" (ppr e) tcExpr e@(HsQuasiQuoteE _) _ = pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e) #endif /* GHCI */ @@ -1283,7 +1285,7 @@ checkCrossStageLifting id _ (Brack _ _ ps_var lie_var) -- Update the pending splices ; ps <- readMutVar ps_var - ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps) + ; writeMutVar ps_var (PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id)) : ps) ; return () } #endif /* GHCI */ diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 1ddcd316c1fa..ad937d1966c4 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -567,12 +567,25 @@ zonkExpr env (HsApp e1 e2) zonkLExpr env e2 `thenM` \ new_e2 -> returnM (HsApp new_e1 new_e2) -zonkExpr env (HsBracketOut body bs) - = mappM zonk_b bs `thenM` \ bs' -> - returnM (HsBracketOut body bs') +zonkExpr _ e@(HsRnBracketOut _ _) + = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) + +zonkExpr env (HsBracketOut body bs) + = do bs' <- mapM zonk_b bs + return (HsBracketOut body bs') where - zonk_b (n,e) = zonkLExpr env e `thenM` \ e' -> - returnM (n,e') + zonk_b (PendingRnExpSplice _ e) + = pprPanic "zonkExpr: PendingRnExpSplice" (ppr e) + + zonk_b (PendingRnCrossStageSplice n) + = pprPanic "zonkExpr: PendingRnCrossStageSplice" (ppr n) + + zonk_b (PendingRnTypeSplice _ e) + = pprPanic "zonkExpr: PendingRnTypeSplice" (ppr e) + + zonk_b (PendingTcSplice n e) + = do e' <- zonkLExpr env e + return (PendingTcSplice n e') zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen returnM (HsSpliceE s) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index ac7aa7c84333..ea4ea115fcc6 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -8,15 +8,16 @@ TcSplice: Template Haskell splices \begin{code} module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, + tcTopSpliceExpr, lookupThName_maybe, runQuasiQuoteExpr, runQuasiQuotePat, runQuasiQuoteDecl, runQuasiQuoteType, - runAnnotation ) where + runAnnotation, + runMetaE,runMetaT, runMetaD ) where #include "HsVersions.h" import HscMain -import TcRnDriver -- These imports are the reason that TcSplice -- is very high up the module hierarchy @@ -26,7 +27,6 @@ import RnExpr import RnEnv import RdrName import RnTypes -import TcPat import TcExpr import TcHsSyn import TcSimplify @@ -283,7 +283,7 @@ The predicate we use is TcEnv.thTopLevelId. %************************************************************************ \begin{code} -tcBracket :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId) +tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) @@ -299,9 +299,9 @@ runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation #ifndef GHCI -tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) -tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) -tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) +tcBracket x _ _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) +tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) +tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n) @@ -323,7 +323,7 @@ runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q) \begin{code} -- See Note [How brackets and nested splices are handled] -tcBracket brack res_ty +tcBracket brack ps res_ty = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation")) 2 (ppr brack)) $ do { -- Check for nested brackets @@ -341,87 +341,89 @@ tcBracket brack res_ty -- Typecheck expr to make sure it is valid, -- but throw away the results. We'll type check -- it again when we actually use it. - ; pending_splices <- newMutVar [] + ; ps_ref <- newMutVar [] ; lie_var <- getConstraintVar - ; let brack_stage = Brack (isTypedBracket brack) cur_stage pending_splices lie_var - - -- We want to check that there aren't any constraints that - -- can't be satisfied (e.g. Show Foo, where Foo has no Show - -- instance), but we aren't otherwise interested in the - -- results. Nor do we care about ambiguous dictionaries etc. - -- We will type check this bracket again at its usage site. - -- - -- We build a single implication constraint with a BracketSkol; - -- that in turn tells simplifyCheck to report only definite - -- errors - ; ((_binds1, meta_ty), lie) <- captureConstraints $ - newImplication BracketSkol [] [] $ - setStage brack_stage $ - tc_bracket cur_stage brack - - -- It's best to simplify the constraint now, even though in - -- principle some later unification might be useful for it, - -- because we don't want these essentially-junk TH implication - -- contraints floating around nested inside other constraints - -- See for example Trac #4949 - ; _binds2 <- simplifyTop lie + ; meta_ty <- + if isTypedBracket brack + then do { let brack_stage = Brack True cur_stage ps_ref lie_var + -- We want to check that there aren't any constraints that + -- can't be satisfied (e.g. Show Foo, where Foo has no Show + -- instance), but we aren't otherwise interested in the + -- results. Nor do we care about ambiguous dictionaries etc. + -- We will type check this bracket again at its usage site. + -- + -- We build a single implication constraint with a BracketSkol; + -- that in turn tells simplifyTop to report only definite + -- errors + ; ((_binds1, meta_ty), lie) <- captureConstraints $ + newImplication BracketSkol [] [] $ + setStage brack_stage $ + tc_bracket brack + + -- It's best to simplify the constraint now, even though in + -- principle some later unification might be useful for it, + -- because we don't want these essentially-junk TH implication + -- contraints floating around nested inside other constraints + -- See for example Trac #4949 + ; _binds2 <- simplifyTop lie + ; return meta_ty } + else do { let brack_stage = Brack False cur_stage ps_ref lie_var + ; setStage brack_stage $ + mapM_ tcPendingSplice ps + ; tc_bracket brack + } -- Return the original expression, not the type-decorated one - ; pendings <- readMutVar pending_splices + ; ps' <- readMutVar ps_ref ; co <- unifyType meta_ty res_ty - ; return (noLoc (mkHsWrapCo co (HsBracketOut brack pendings))) } + ; return (mkHsWrapCo co (HsBracketOut brack ps')) } -tc_bracket :: ThStage -> HsBracket Name -> TcM TcType -tc_bracket outer_stage br@(VarBr _ name) -- Note [Quoting names] - = do { thing <- tcLookup name - ; case thing of - AGlobal {} -> return () - ATyVar {} -> return () - ATcId { tct_level = bind_lvl, tct_id = id } - | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting - -> keepAliveTc id - | otherwise - -> do { checkTc (thLevel outer_stage + 1 == bind_lvl) - (quotedNameStageErr br) } - _ -> pprPanic "th_bracket" (ppr name $$ ppr thing) - - ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) - } +tcPendingSplice :: PendingSplice -> TcM () +tcPendingSplice (PendingRnExpSplice n expr) + = do { res_ty <- newFlexiTyVarTy openTypeKind + ; _ <- tcSpliceExpr (HsSplice False n expr) res_ty + ; return () + } -tc_bracket _ (ExpBr expr) - = do { any_ty <- newFlexiTyVarTy openTypeKind - ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that - ; tcMetaTy expQTyConName } - -- Result type is ExpQ (= Q Exp) +tcPendingSplice (PendingRnCrossStageSplice n) + = do { res_ty <- newFlexiTyVarTy openTypeKind + ; _ <- tcCheckId n res_ty + ; return () + } -tc_bracket _ (TypBr typ) - = do { _ <- tcLHsType typ -- Do not check type validity; we can have a bracket - -- inside a "knot" where things are not yet settled - -- eg data T a = MkT $(foo [t| a |]) - ; tcMetaTy typeQTyConName } - -- Result type is Type (= Q Typ) +tcPendingSplice (PendingRnTypeSplice n expr) + = do { _ <- tcSpliceType (HsSplice False n expr) emptyFVs + ; return () + } -tc_bracket _ (DecBrG decls) - = do { _ <- tcTopSrcDecls emptyModDetails decls - -- Typecheck the declarations, dicarding the result - -- We'll get all that stuff later, when we splice it in +tcPendingSplice (PendingTcSplice _ expr) + = pprPanic "tcPendingSplice: PendingTcSplice" (ppr expr) - -- Top-level declarations in the bracket get unqualified names - -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames +tc_bracket :: HsBracket Name -> TcM TcType +tc_bracket (VarBr _ _) -- Note [Quoting names] + = tcMetaTy nameTyConName + -- Result type is Var (not Q-monadic) - ; tcMetaTy decsQTyConName } -- Result type is Q [Dec] +tc_bracket (ExpBr _) + = tcMetaTy expQTyConName + -- Result type is ExpQ (= Q Exp) -tc_bracket _ (PatBr pat) - = do { any_ty <- newFlexiTyVarTy openTypeKind - ; _ <- tcPat ThPatQuote pat any_ty $ - return () - ; tcMetaTy patQTyConName } - -- Result type is PatQ (= Q Pat) +tc_bracket (TypBr _) + = tcMetaTy typeQTyConName + -- Result type is Type (= Q Typ) + +tc_bracket (DecBrG _) + = tcMetaTy decsQTyConName + -- Result type is Q [Dec] -tc_bracket _ (DecBrL _) +tc_bracket (PatBr _) + = tcMetaTy patQTyConName + -- Result type is PatQ (= Q Pat) + +tc_bracket (DecBrL _) = panic "tc_bracket: Unexpected DecBrL" -tc_bracket _ (TExpBr expr) +tc_bracket (TExpBr expr) = do { any_ty <- newFlexiTyVarTy openTypeKind ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that ; tcTExpTy any_ty } @@ -431,11 +433,6 @@ tcTExpTy :: TcType -> TcM TcType tcTExpTy tau = do t <- tcLookupTyCon tExpTyConName return (mkTyConApp t [tau]) - -quotedNameStageErr :: HsBracket Name -> SDoc -quotedNameStageErr br - = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br - , ptext (sLit "must be used at the same stage at which is is bound")] \end{code} @@ -446,14 +443,15 @@ quotedNameStageErr br %************************************************************************ \begin{code} -tcSpliceExpr (HsSplice isTypedSplice name expr) res_ty +tcSpliceExpr splice@(HsSplice isTypedSplice name expr) res_ty = setSrcSpan (getLoc expr) $ do { stage <- getStage - ; case stage of { - Splice {} -> tcTopSplice isTypedSplice expr res_ty ; - Comp -> tcTopSplice isTypedSplice expr res_ty ; - - Brack isTypedBrack pop_stage ps_var lie_var -> do + ; case stage of + { Splice {} | not isTypedSplice -> pprPanic "tcSpliceExpr: encountered unexpanded top-level untyped splice" (ppr splice) + ; Comp {} | not isTypedSplice -> pprPanic "tcSpliceExpr: encountered unexpanded top-level untyped splice" (ppr splice) + ; Splice {} -> tcTopSplice expr res_ty + ; Comp -> tcTopSplice expr res_ty + ; Brack isTypedBrack pop_stage ps_var lie_var -> do -- See Note [How brackets and nested splices are handled] -- A splice inside brackets @@ -478,22 +476,19 @@ tcSpliceExpr (HsSplice isTypedSplice name expr) res_ty -- Write the pending splice into the bucket ; ps <- readMutVar ps_var - ; writeMutVar ps_var ((name,expr') : ps) + ; writeMutVar ps_var (PendingTcSplice name expr' : ps) ; return (panic "tcSpliceExpr") -- The returned expression is ignored }}} -tcTopSplice :: Bool -> LHsExpr Name -> TcRhoType -> TcM (HsExpr Id) --- Note [How top-level splices are handled] -tcTopSplice isTypedSplice expr res_ty - = do { meta_exp_ty <- if isTypedSplice - then do { any_ty <- newFlexiTyVarTy openTypeKind - ; tcTExpTy any_ty - } - else tcMetaTy expQTyConName +tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id) +tcTopSplice expr res_ty + = do { any_ty <- newFlexiTyVarTy openTypeKind + ; meta_exp_ty <- tcTExpTy any_ty -- Typecheck the expression - ; zonked_q_expr <- tcTopSpliceExpr isTypedSplice (tcMonoExpr expr meta_exp_ty) + ; zonked_q_expr <- tcTopSpliceExpr True $ + tcMonoExpr expr meta_exp_ty -- Run the expression ; expr2 <- runMetaE zonked_q_expr @@ -559,24 +554,28 @@ We don't want the type checker to see these bogus unbound variables. Very like splicing an expression, but we don't yet share code. \begin{code} -tcSpliceType (HsSplice _ name hs_expr) _ - = setSrcSpan (getLoc hs_expr) $ do +tcSpliceType splice@(HsSplice True _ _) _ + = pprPanic "tcSpliceType: encountered a typed type splice" (ppr splice) + +tcSpliceType splice@(HsSplice False name expr) _ + = setSrcSpan (getLoc expr) $ do { stage <- getStage - ; case stage of { - Splice {} -> tcTopSpliceType hs_expr ; - Comp -> tcTopSpliceType hs_expr ; + ; case stage of + { Brack isTypedBrack pop_stage ps_var lie_var -> do - Brack _ pop_level ps_var lie_var -> do - -- See Note [How brackets and nested splices are handled] - -- A splice inside brackets + -- See Note [How brackets and nested splices are handled] + -- A splice inside brackets { meta_ty <- tcMetaTy typeQTyConName - ; expr' <- setStage pop_level $ + ; when isTypedBrack $ + failWithTc illegalUntypedSplice + + ; expr' <- setStage pop_stage $ setConstraintVar lie_var $ - tcMonoExpr hs_expr meta_ty + tcMonoExpr expr meta_ty -- Write the pending splice into the bucket ; ps <- readMutVar ps_var - ; writeMutVar ps_var ((name,expr') : ps) + ; writeMutVar ps_var (PendingTcSplice name expr' : ps) -- e.g. [| f (g :: Int -> $(h 4)) |] -- Here (h 4) :: Q Type @@ -585,25 +584,10 @@ tcSpliceType (HsSplice _ name hs_expr) _ ; kind <- newMetaKindVar ; ty <- newFlexiTyVarTy kind ; return (ty, kind) - }}} - -tcTopSpliceType :: LHsExpr Name -> TcM (TcType, TcKind) --- Note [How top-level splices are handled] -tcTopSpliceType expr - = do { meta_ty <- tcMetaTy typeQTyConName - - -- Typecheck the expression - ; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr meta_ty) + } - -- Run the expression - ; hs_ty2 <- runMetaT zonked_q_expr - ; showSplice "type" expr (ppr hs_ty2) - - ; addErrCtxt (spliceResultDoc expr) $ do - { let doc = SpliceTypeCtx hs_ty2 - ; (hs_ty3, _fvs) <- checkNoErrs $ rnLHsType doc hs_ty2 - -- checkNoErrs: see Note [Renamer errors] - ; tcLHsType hs_ty3 }} + ; _ -> pprPanic "tcSpliceType: encountered unexpanded top-level type splice" (ppr splice) + }} \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index de14aa3b95ef..bf9515664f33 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -2,6 +2,8 @@ module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, HsExpr, LHsType, LHsExpr, LPat, LHsDecl ) +import HsExpr ( PendingSplice ) +import Id ( Id ) import Name ( Name ) import NameSet ( FreeVars ) import RdrName ( RdrName ) @@ -16,11 +18,14 @@ tcSpliceExpr :: HsSplice Name tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) +tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] + tcBracket :: HsBracket Name + -> [PendingSplice] -> TcRhoType - -> TcM (LHsExpr TcId) + -> TcM (HsExpr TcId) -tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] +tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) lookupThName_maybe :: TH.Name -> TcM (Maybe Name) @@ -29,4 +34,8 @@ runQuasiQuoteExpr :: HsQuasiQuote RdrName -> TcM (LHsExpr RdrName) runQuasiQuoteType :: HsQuasiQuote RdrName -> TcM (LHsType RdrName) runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName) runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation + +runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName) +runMetaT :: LHsExpr Id -> TcM (LHsType RdrName) +runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName] \end{code}