Track TH stage in the renamer.

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}
 
 %************************************************************************

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

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 }

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}
 
 %************************************************************************

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)

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)