[project @ 2004-09-02 15:21:12 by simonpj]

Preserve ExprWithTySig after type checking

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

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)

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)

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"