[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"