From: simonpj <unknown>
Date: Thu, 2 Sep 2004 15:21:26 +0000 (+0000)
Subject: [project @ 2004-09-02 15:21:12 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~1642
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=dcb182ad063e95c9075bf2c8e34e7215fc38ef3d

[project @ 2004-09-02 15:21:12 by simonpj]
Preserve ExprWithTySig after type checking
---

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index cedb95f..51e01bd 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -156,7 +156,8 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 
 dsExpr :: HsExpr Id -> DsM CoreExpr
 
-dsExpr (HsPar x) = dsLExpr x
+dsExpr (HsPar e) 	      = dsLExpr e
+dsExpr (ExprWithTySigOut e _) = dsLExpr e
 dsExpr (HsVar var)  = returnDs (Var var)
 dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
 dsExpr (HsLit lit)  = dsLit lit
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index df81fe1..88b681c 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -123,9 +123,14 @@ data HsExpr id
 					-- 	type of input record)
 		 (HsRecordBinds id)
 
-  | ExprWithTySig			-- signature binding
+  | ExprWithTySig			-- e :: type
 		(LHsExpr id)
 		(LHsType id)
+
+  | ExprWithTySigOut			-- TRANSLATION
+		(LHsExpr id)
+		(LHsType Name)		-- Retain the signature for round-tripping purposes
+
   | ArithSeqIn				-- arithmetic sequence
 		(ArithSeqInfo id)
   | ArithSeqOut
@@ -355,6 +360,9 @@ ppr_expr (RecordUpdOut aexp _ _ rbinds)
 ppr_expr (ExprWithTySig expr sig)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
 	 4 (ppr sig)
+ppr_expr (ExprWithTySigOut expr sig)
+  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
+	 4 (ppr sig)
 
 ppr_expr (ArithSeqIn info)
   = brackets (ppr info)
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index a66147e..6a3c514 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -166,8 +166,7 @@ tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty
  = addErrCtxt (exprCtxt in_expr)			$
    tcHsSigType ExprSigCtxt poly_ty			`thenM` \ sig_tc_ty ->
    tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty	`thenM` \ (co_fn, expr') ->
-   returnM (co_fn <$> unLoc expr')
-	-- ToDo: nasty unLoc
+   returnM (co_fn <$> ExprWithTySigOut expr' poly_ty)
 
 tc_expr (HsType ty) res_ty
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 0670a0c..349bd25 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -482,6 +482,10 @@ zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
     zonkRbinds env rbinds	`thenM` \ new_rbinds ->
     returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
 
+zonkExpr env (ExprWithTySigOut e ty) 
+  = do { e' <- zonkLExpr env e
+       ; return (ExprWithTySigOut e' ty) }
+
 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
 zonkExpr env (ArithSeqIn _)      = panic "zonkExpr env:ArithSeqIn"
 zonkExpr env (PArrSeqIn _)       = panic "zonkExpr env:PArrSeqIn"