Track TH stage in the renamer.
authorGeoffrey Mainland <mainland@apeiron.net>
Wed, 1 May 2013 16:45:22 +0000 (17:45 +0100)
committerGeoffrey Mainland <mainland@apeiron.net>
Thu, 27 Jun 2013 08:44:09 +0000 (09:44 +0100)
12 files changed:
compiler/basicTypes/RdrName.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/HsExpr.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnSplice.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcSplice.lhs-boot

index 3ff3bbb..e32ad66 100644 (file)
@@ -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}
 
 %************************************************************************
index 8c53c1a..4ce7583 100644 (file)
@@ -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
index 6232825..2d4601e 100644 (file)
@@ -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 }
index 36d6cee..79d53ae 100644 (file)
@@ -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}
 
 %************************************************************************
index c3fd407..bf32dba 100644 (file)
@@ -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)
index 62f0709..a556d07 100644 (file)
@@ -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)
index 53c5167..2e81335 100644 (file)
@@ -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}
index 01bffd9..3675b4e 100644 (file)
@@ -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)
index 41e9dc2..0adb2ee 100644 (file)
@@ -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 */
index 1ddcd31..ad937d1 100644 (file)
@@ -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)
index ac7aa7c..ea4ea11 100644 (file)
@@ -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}
 
 %************************************************************************
index de14aa3..bf95156 100644 (file)
@@ -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}