X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsExpr.lhs;h=164316cf99d07c8a85885dca8873cb4d2ee1a8ad;hb=04feba252e40d16101b92948cd1e13c7bc1f3062;hp=ce5a9d8e7b2b7380754fd9fc84d681b05d4fa69e;hpb=36436bc62a98f53e126ec02fe946337c4c766c3f;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index ce5a9d8..164316c 100644
--- 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 ->
@@ -257,14 +258,29 @@ dsExpr (HsCoreAnn fs expr)
     returnDs (Note (CoreNote $ unpackFS fs) core_expr)
 
 -- Special case to handle unboxed tuple patterns; they can't appear nested
+-- The idea is that 
+--	case e of (# p1, p2 #) -> rhs
+-- should desugar to
+--	case e of (# x1, x2 #) -> ... match p1, p2 ...
+-- NOT
+--	let x = e in case x of ....
+--
+-- But there may be a big 
+--	let fail = ... in case e of ...
+-- wrapping the whole case, which complicates matters slightly
+-- It all seems a bit fragile.  Test is dsrun013.
+
 dsExpr (HsCase discrim matches@(MatchGroup _ ty))
  | isUnboxedTupleType (funArgTy ty)
  =  dsLExpr discrim			`thenDs` \ core_discrim ->
     matchWrapper CaseAlt matches 	`thenDs` \ ([discrim_var], matching_code) ->
-    case matching_code of
-	Case (Var x) bndr ty alts | x == discrim_var -> 
-		returnDs (Case core_discrim bndr ty alts)
-	_ -> panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
+    let
+	scrungle (Case (Var x) bndr ty alts) 
+		| x == discrim_var = Case core_discrim bndr ty alts
+	scrungle (Let binds body)  = Let binds (scrungle body)
+	scrungle other = panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr other))
+    in
+    returnDs (scrungle matching_code)
 
 dsExpr (HsCase discrim matches)
   = dsLExpr discrim			`thenDs` \ core_discrim ->
@@ -548,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
@@ -718,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