+ filtered_alts = filter keep con_alts
+ keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
+ better_alts = (DEFAULT, [], rhs1) : filtered_alts
+
+
+--------------------------------------------------
+-- 2. Fill in missing constructor
+--------------------------------------------------
+
+mkAlts scrut case_bndr alts
+ | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
+ isDataTyCon tycon, -- It's a data type
+ (alts_no_deflt, Just rhs) <- findDefault alts,
+ -- There is a DEFAULT case
+ [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
+ -- There is just one missing constructor!
+ = tick (FillInCaseDefault case_bndr) `thenSmpl_`
+ getUniquesSmpl `thenSmpl` \ tv_uniqs ->
+ getUniquesSmpl `thenSmpl` \ id_uniqs ->
+ let
+ (_,_,ex_tyvars,_,_,_) = dataConSig missing_con
+ ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
+ mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
+ arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
+ arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
+ better_alts = (DataAlt missing_con, ex_tyvars' ++ arg_ids, rhs) : alts_no_deflt
+ in
+ returnSmpl better_alts
+ where
+ impossible_cons = otherCons (idUnfolding case_bndr)
+ handled_data_cons = [data_con | DataAlt data_con <- impossible_cons] ++
+ [data_con | (DataAlt data_con, _, _) <- alts]
+ is_missing con = not (con `elem` handled_data_cons)
+
+--------------------------------------------------
+-- 3. Merge nested cases
+--------------------------------------------------
+
+mkAlts scrut outer_bndr outer_alts
+ | opt_SimplCaseMerge,
+ (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
+ Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
+ scruting_same_var scrut_var
+
+ = let -- Eliminate any inner alts which are shadowed by the outer ones
+ outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
+
+ munged_inner_alts = [ (con, args, munge_rhs rhs)
+ | (con, args, rhs) <- inner_alts,
+ not (con `elem` outer_cons) -- Eliminate shadowed inner alts
+ ]
+ munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
+
+ (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts
+
+ new_alts = add_default maybe_inner_default
+ (outer_alts_without_deflt ++ inner_con_alts)
+ in
+ tick (CaseMerge outer_bndr) `thenSmpl_`
+ returnSmpl new_alts
+ -- Warning: don't call mkAlts recursively!
+ -- Firstly, there's no point, because inner alts have already had
+ -- mkCase applied to them, so they won't have a case in their default
+ -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
+ -- in munge_rhs may put a case into the DEFAULT branch!
+ where
+ -- We are scrutinising the same variable if it's
+ -- the outer case-binder, or if the outer case scrutinises a variable
+ -- (and it's the same). Testing both allows us not to replace the
+ -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
+ scruting_same_var = case scrut of
+ Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
+ other -> \ v -> v == outer_bndr