Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263

[ghc-hetmet.git] / compiler / typecheck / TcSplice.lhs

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 650c0b4..bbb76a4 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -13,7 +13,7 @@ TcSplice: Template Haskell splices
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
-module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket,
+module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
                  lookupThName_maybe,
                  runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
 
@@ -213,30 +213,31 @@ Desugared:        f = do { s7 <- g Int 3
                       ; return (ConE "Data.Maybe.Just" s7) }
 
 \begin{code}
-tcBracket brack res_ty = do
-   level <- getStage
-   case bracketOK level of {
-       Nothing         -> failWithTc (illegalBracket level) ;
-       Just next_level -> do
+tcBracket brack res_ty 
+  = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
+                   2 (ppr brack)) $
+    do { level <- getStage
+       ; case bracketOK level of {
+          Nothing         -> failWithTc (illegalBracket level) ;
+          Just next_level -> do {
 
        -- Typecheck expr to make sure it is valid,
        -- but throw away the results.  We'll type check
        -- it again when we actually use it.
-    recordThUse
-    pending_splices <- newMutVar []
-    lie_var <- getLIEVar
+          recordThUse
+       ; pending_splices <- newMutVar []
+       ; lie_var <- getLIEVar
 
-    (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
-                               (getLIE (tc_bracket next_level brack))
-    tcSimplifyBracket lie
+       ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
+                                    (getLIE (tc_bracket next_level brack))
+       ; tcSimplifyBracket lie
 
        -- Make the expected type have the right shape
-    boxyUnify meta_ty res_ty
+       ; _ <- boxyUnify meta_ty res_ty
 
        -- Return the original expression, not the type-decorated one
-    pendings <- readMutVar pending_splices
-    return (noLoc (HsBracketOut brack pendings))
-    }
+       ; pendings <- readMutVar pending_splices
+       ; return (noLoc (HsBracketOut brack pendings)) }}}
 
 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
 tc_bracket use_lvl (VarBr name)        -- Note [Quoting names]
@@ -256,17 +257,17 @@ tc_bracket use_lvl (VarBr name)   -- Note [Quoting names]
 
 tc_bracket _ (ExpBr expr) 
   = do { any_ty <- newFlexiTyVarTy liftedTypeKind
-       ; tcMonoExpr expr any_ty
+       ; _ <- tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
        ; tcMetaTy expQTyConName }
        -- Result type is Expr (= Q Exp)
 
 tc_bracket _ (TypBr typ) 
-  = do { tcHsSigType ExprSigCtxt typ
+  = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
        ; tcMetaTy typeQTyConName }
        -- Result type is Type (= Q Typ)
 
 tc_bracket _ (DecBr decls)
-  = do {  tcTopSrcDecls emptyModDetails decls
+  = do { _ <- tcTopSrcDecls emptyModDetails decls
        -- Typecheck the declarations, dicarding the result
        -- We'll get all that stuff later, when we splice it in
 
@@ -311,7 +312,7 @@ tcSpliceExpr (HsSplice name expr) res_ty
        -- Here (h 4) :: Q Exp
        -- but $(h 4) :: forall a.a     i.e. anything!
 
-      unBox res_ty
+      _ <- unBox res_ty
       meta_exp_ty <- tcMetaTy expQTyConName
       expr' <- setStage (Splice next_level) (
                  setLIEVar lie_var    $
@@ -347,8 +348,7 @@ tcTopSplice expr res_ty = do
 
     traceTc (text "Got result" <+> ppr expr2)
 
-    showSplice "expression" 
-               zonked_q_expr (ppr expr2)
+    showSplice "expression" expr (ppr expr2)
 
         -- Rename it, but bale out if there are errors
         -- otherwise the type checker just gives more spurious errors
@@ -488,7 +488,7 @@ runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_
        ; traceTc (text "About to run" <+> ppr zonked_q_expr)
        ; result <- runMetaQ convert zonked_q_expr
        ; traceTc (text "Got result" <+> ppr result)
-       ; showSplice desc zonked_q_expr (ppr result)
+       ; showSplice desc quoteExpr (ppr result)
        ; return result
        }
 
@@ -558,7 +558,7 @@ kcTopSpliceType expr
   
        ; traceTc (text "Got result" <+> ppr hs_ty2)
 
-       ; showSplice "type" zonked_q_expr (ppr hs_ty2)
+       ; showSplice "type" expr (ppr hs_ty2)
 
        -- Rename it, but bale out if there are errors
        -- otherwise the type checker just gives more spurious errors
@@ -590,7 +590,7 @@ tcSpliceDecls expr
 
        ; traceTc (text "Got result" <+> vcat (map ppr decls))
        ; showSplice "declarations"
-                    zonked_q_expr 
+                    expr 
                     (ppr (getLoc expr) $$ (vcat (map ppr decls)))
        ; return decls }
 \end{code}
@@ -763,13 +763,18 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
 %************************************************************************
 
 \begin{code}
-showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
-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])])
+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 :: ThStage -> SDoc
 illegalBracket level