[project @ 2006-01-06 16:30:17 by simonmar]

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

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 2e21538..04511ce 100644 (file)
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -83,7 +83,7 @@ dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
 
 -------------------------
 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
-dsValBinds (ValBindsOut binds) body = foldrDs ds_val_bind body binds
+dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
 
 -------------------------
 dsIPBinds (IPBinds ip_binds dict_binds) body
@@ -257,14 +257,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 ->
@@ -484,7 +499,7 @@ dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
 
        mk_alt con
          = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
-               -- This call to dataConArgTys won't work for existentials
+               -- This call to dataConInstOrigArgTys won't work for existentials
                -- but existentials don't have record types anyway
            let 
                val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
@@ -680,7 +695,7 @@ dsMDo tbl stmts body result_ty
        go (new_bind_stmt : let_stmt : stmts)
       where
         new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
-       let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)]))
+       let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 
        
                -- Remove the later_ids that appear (without fancy coercions)