Refactor HsExpr.MatchGroup

 * Make MatchGroup into a record, and use the record fields

 * Split the type field into two: mg_arg_tys and mg_res_ty
   This makes life much easier for the desugarer when the
   case alterantives are empty

A little bit of this change unavoidably ended up in the preceding
commit about empty case alternatives

5 files changed, 29 insertions, 30 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 14e875a6ec..c4afc5b9e5 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -271,7 +271,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
   -- See Note [inline sccs]
   if inline && gopt Opt_SccProfilingOn dflags then return (L pos funBind) else do
 
-  (fvs, (MatchGroup matches' ty)) <-
+  (fvs, mg@(MG { mg_alts = matches' })) <-
         getFreeVars $
         addPathEntry name $
         addTickMatchGroup False (fun_matches funBind)
@@ -293,7 +293,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
              else
                 return Nothing
 
-  return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
+  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
                            , fun_tick = tick }
 
    where
@@ -586,10 +586,10 @@ addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
 addTickTupArg (Missing ty) = return (Missing ty)
 
 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
-addTickMatchGroup is_lam (MatchGroup matches ty) = do
+addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
   let isOneOfMany = matchesOneOfMany matches
   matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
-  return $ MatchGroup matches' ty
+  return $ mg { mg_alts = matches' }
 
 addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
 addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
@@ -799,9 +799,9 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) =
 --addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
 
 addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
-addTickCmdMatchGroup (MatchGroup matches ty) = do
+addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
   matches' <- mapM (liftL addTickCmdMatch) matches
-  return $ MatchGroup matches' ty
+  return $ mg { mg_alts = matches' }
 
 addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
 addTickCmdMatch (Match pats opSig gRHSs) =
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index b74c88529b..4fb5174f27 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -33,7 +33,6 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
 
 import TcType
 import TcEvidence
-import Type
 import CoreSyn
 import CoreFVs
 import CoreUtils
@@ -382,7 +381,7 @@ dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do
 --		---> premap (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) c
 
 dsCmd ids local_vars stack res_ty
-        (HsCmdLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
+        (HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] }))
         env_ids = do
     let
         pat_vars = mkVarSet (collectPatsBinders pats)
@@ -483,8 +482,9 @@ case bodies, containing the following fields:
    bodies with |||.
 
 \begin{code}
-dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty))
-        env_ids = do
+dsCmd ids local_vars stack res_ty 
+      (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys }))
+      env_ids = do
     stack_ids <- mapM newSysLocalDs stack
 
     -- Extract and desugar the leaf commands in the case, building tuple
@@ -526,12 +526,11 @@ dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty))
         (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
         in_ty = envStackType env_ids stack
 
-        pat_ty    = funArgTy match_ty
-        match_ty' = mkFunTy pat_ty sum_ty
+    core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys
+                                        , mg_res_ty = sum_ty }))
         -- Note that we replace the HsCase result type by sum_ty,
         -- which is the type of matches'
-    
-    core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty'))
+
     core_matches <- matchEnvStack env_ids stack_ids core_body
     return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
             exprFreeIds core_body  `intersectVarSet` local_vars)
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 7f439eabe6..d0b71ed2d0 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -490,7 +490,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
         -- constructor aguments.
         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
         ; ([discrim_var], matching_code) 
-                <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
+                <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty })
 
         ; return (add_field_binds field_binds' $
                   bindNonRec discrim_var record_expr' matching_code) }
@@ -512,7 +512,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
         -- from instance type to family type
     tycon     = dataConTyCon (head cons_to_upd)
     in_ty     = mkTyConApp tycon in_inst_tys
-    in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
+    out_ty    = mkFamilyTyConApp tycon out_inst_tys
 
     mk_alt upd_fld_env con
       = do { let (univ_tvs, ex_tvs, eq_spec, 
@@ -761,8 +761,8 @@ dsDo stmts
         later_pats   = rec_tup_pats
         rets         = map noLoc rec_rets
         mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
-        mfix_arg     = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
-                                                 (mkFunTy tup_ty body_ty))
+        mfix_arg     = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
+                                         , mg_arg_tys = [tup_ty], mg_res_ty = body_ty })
         mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
         body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
         ret_app      = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index bc71fa8493..4573e54ce0 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -25,6 +25,7 @@ import TysWiredIn
 import PrelNames
 import Module
 import Name
+import Util
 import SrcLoc
 import Outputable
 \end{code}
@@ -56,16 +57,15 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchCon
         -> GRHSs Id (LHsExpr Id)                -- Guarded RHSs
         -> Type                                 -- Type of RHS
         -> DsM MatchResult
-dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
-    match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
-    let
-        match_result1 = foldr1 combineMatchResults match_results
-        match_result2 = adjustMatchResultDs
+dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty 
+  = ASSERT( notNull grhss )
+    do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
+       ; let match_result1 = foldr1 combineMatchResults match_results
+             match_result2 = adjustMatchResultDs
                                  (\e -> dsLocalBinds binds e)
                                  match_result1
                 -- NB: nested dsLet inside matchResult
-    --
-    return match_result2
+       ; return match_result2 }
 
 dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult
 dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index fcaff4bd9a..fd57f4656a 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -917,8 +917,8 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 	-- HsOverlit can definitely occur
 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
-repE (HsLam (MatchGroup [m] _)) = repLambda m
-repE (HsLamCase _ (MatchGroup ms _))
+repE (HsLam (MG { mg_alts = [m] })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = ms }))
                    = do { ms' <- mapM repMatchTup ms
                         ; repLamCase (nonEmptyCoreList ms') }
 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
@@ -935,7 +935,7 @@ repE (NegApp x _)        = do
 repE (HsPar x)            = repLE x
 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e (MatchGroup ms _))
+repE (HsCase e (MG { mg_alts = ms }))
                           = do { arg <- repLE e
                                ; ms2 <- mapM repMatchTup ms
                                ; repCaseE arg (nonEmptyCoreList ms2) }
@@ -1166,7 +1166,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 -- with an empty list of patterns
 rep_bind (L loc (FunBind { fun_id = fn,
-			   fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
+			   fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } }))
  = do { (ss,wherecore) <- repBinds wheres
 	; guardcore <- addBinds ss (repGuards guards)
 	; fn'  <- lookupLBinder fn
@@ -1175,7 +1175,7 @@ rep_bind (L loc (FunBind { fun_id = fn,
 	; ans' <- wrapGenSyms ss ans
 	; return (loc, ans') }
 
-rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
+rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))
  =   do { ms1 <- mapM repClauseTup ms
 	; fn' <- lookupLBinder fn
         ; ans <- repFun fn' (nonEmptyCoreList ms1)