X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=76e03121c24e95aff5dff1d9576c2c5275c8d96b;hb=9a4c93a59e008ddc376fde5f9eb468b762f0d0a7;hp=10b9fb9a62c19ea4b815ced95494fe68fdf692aa;hpb=da6b7fce09f98a0fbe66b6d218e6473c1845e354;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 10b9fb9..76e0312 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -438,10 +438,17 @@ tcTopSplice expr res_ty
 
         -- Rename it, but bale out if there are errors
         -- otherwise the type checker just gives more spurious errors
-       ; (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
+       ; addErrCtxt (spliceResultDoc expr) $ do 
+       { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
 
-       ; exp4 <- tcMonoExpr exp3 res_ty
-       ; return (unLoc exp4) }
+       ; exp4 <- tcMonoExpr exp3 res_ty 
+       ; return (unLoc exp4) } }
+
+spliceResultDoc :: LHsExpr Name -> SDoc
+spliceResultDoc 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")]
 
 -------------------
 tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id)
@@ -522,11 +529,11 @@ kcTopSpliceType expr
   
 	-- Rename it, but bale out if there are errors
 	-- otherwise the type checker just gives more spurious errors
-	; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
+        ; addErrCtxt (spliceResultDoc expr) $ do 
+	{ let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
 	; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
-
 	; (ty4, kind) <- kcLHsType hs_ty3
-        ; return (unLoc ty4, kind) }
+        ; return (unLoc ty4, kind) }}
 \end{code}
 
 %************************************************************************
@@ -964,8 +971,8 @@ reifyThing (AGlobal (AnId id))
 	; fix <- reifyFixity (idName id)
 	; let v = reifyName id
 	; case idDetails id of
-	    ClassOpId cls    -> return (TH.ClassOpI v ty (reifyName cls) fix)
-	    _                -> return (TH.VarI     v ty Nothing fix)
+	    ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
+	    _             -> return (TH.VarI     v ty Nothing fix)
     }
 
 reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
@@ -1063,17 +1070,22 @@ reifyClass cls
 
 ------------------------------
 reifyType :: TypeRep.Type -> TcM TH.Type
+reifyType ty@(ForAllTy _ _)        = reify_for_all ty
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty	        -- Types like ((?x::Int) => Char -> Char)
 reifyType (TyVarTy tv)	    = return (TH.VarT (reifyName tv))
-reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
+reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys   -- Do not expand type synonyms here
 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
 reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
-reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; 
-				 ; tau' <- reifyType tau 
-				 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
-			    where
-				(tvs, cxt, tau) = tcSplitSigmaTy ty
-reifyType (PredTy {}) = panic "reifyType PredTy"
+reifyType ty@(PredTy {})    = pprPanic "reifyType PredTy" (ppr ty)
 
+reify_for_all :: TypeRep.Type -> TcM TH.Type
+reify_for_all ty
+  = do { cxt' <- reifyCxt cxt; 
+       ; tau' <- reifyType tau 
+       ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
+  where
+    (tvs, cxt, tau) = tcSplitSigmaTy ty   
+				
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType