Record the type in TuplePat (necessary for GADTs)

[ghc-hetmet.git] / ghc / compiler / deSugar / DsExpr.lhs

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 04511ce..164316c 100644 (file)
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -11,7 +11,7 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
 
 import Match           ( matchWrapper, matchSimply, matchSinglePat )
 import MatchLit                ( dsLit, dsOverLit )
-import DsBinds         ( dsLHsBinds )
+import DsBinds         ( dsLHsBinds, dsCoercion )
 import DsGRHSs         ( dsGuarded )
 import DsListComp      ( dsListComp, dsPArrComp )
 import DsUtils         ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
@@ -26,7 +26,7 @@ import DsMeta         ( dsBracket )
 #endif
 
 import HsSyn
-import TcHsSyn         ( hsPatType )
+import TcHsSyn         ( hsPatType, mkVanillaTuplePat )
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types (newtypes etc), and sometimes not
@@ -121,13 +121,14 @@ ds_val_bind (is_rec, hsbinds) body
                                    (showSDoc (ppr pat))
     in
     case bagToList binds of
-      [L loc (FunBind (L _ fun) _ matches _)]
+      [L loc (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })]
        -> putSrcSpanDs loc                                     $
           matchWrapper (FunRhs (idName fun)) matches           `thenDs` \ (args, rhs) ->
           ASSERT( null args )  -- Functions aren't lifted
+          ASSERT( isIdCoercion co_fn )
           returnDs (bindNonRec fun rhs body_w_exports)
 
-      [L loc (PatBind pat grhss ty _)]
+      [L loc (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })]
        -> putSrcSpanDs loc                     $
           dsGuarded grhss ty                   `thenDs` \ rhs ->
           mk_error_app pat                     `thenDs` \ error_expr ->
@@ -563,6 +564,8 @@ dsExpr (DictLam dictvars expr)
 dsExpr (DictApp expr dicts)    -- becomes a curried application
   = dsLExpr expr                       `thenDs` \ core_expr ->
     returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
+
+dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
 \end{code}
 
 Here is where we desugar the Template Haskell brackets and escapes
@@ -733,7 +736,7 @@ dsMDo tbl stmts body result_ty
 
        mk_tup_pat :: [LPat Id] -> LPat Id
        mk_tup_pat [p] = p
-       mk_tup_pat ps  = noLoc $ TuplePat ps Boxed
+       mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 
        mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
        mk_ret_tup [r] = r