+mkCoAlgCaseMatchResult :: Id -- Scrutinee
+ -> Type -- Type of exp
+ -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
+ -> MatchResult
+mkCoAlgCaseMatchResult var ty match_alts
+ | isNewTyCon tycon -- Newtype case; use a let
+ = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
+ mkCoLetsMatchResult [NonRec arg_id1 newtype_rhs] match_result1
+
+ | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
+ = MatchResult CanFail mk_parrCase
+
+ | otherwise -- Datatype case; use a case
+ = MatchResult fail_flag mk_case
+ where
+ tycon = dataConTyCon con1
+ -- [Interesting: becuase of GADTs, we can't rely on the type of
+ -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
+
+ -- Stuff for newtype
+ (con1, arg_ids1, match_result1) = head match_alts
+ arg_id1 = head arg_ids1
+ newtype_rhs = mkNewTypeBody tycon (idType arg_id1) (Var var)
+
+ -- Stuff for data types
+ data_cons = tyConDataCons tycon
+ match_results = [match_result | (_,_,match_result) <- match_alts]
+
+ fail_flag | exhaustive_case
+ = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+ | otherwise
+ = CanFail
+
+ wild_var = mkWildId (idType var)
+ sorted_alts = sortWith get_tag match_alts
+ get_tag (con, _, _) = dataConTag con
+ mk_case fail = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
+ returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))
+
+ mk_alt fail (con, args, MatchResult _ body_fn)
+ = body_fn fail `thenDs` \ body ->
+ newUniqueSupply `thenDs` \ us ->
+ returnDs (mkReboxingAlt (uniqsFromSupply us) con args body)
+
+ mk_default fail | exhaustive_case = []
+ | otherwise = [(DEFAULT, [], fail)]
+
+ un_mentioned_constructors
+ = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
+ exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+ -- Stuff for parallel arrays
+ --
+ -- * the following is to desugar cases over fake constructors for
+ -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
+ -- case
+ --
+ -- Concerning `isPArrFakeAlts':
+ --
+ -- * it is *not* sufficient to just check the type of the type
+ -- constructor, as we have to be careful not to confuse the real
+ -- representation of parallel arrays with the fake constructors;
+ -- moreover, a list of alternatives must not mix fake and real
+ -- constructors (this is checked earlier on)
+ --
+ -- FIXME: We actually go through the whole list and make sure that
+ -- either all or none of the constructors are fake parallel
+ -- array constructors. This is to spot equations that mix fake
+ -- constructors with the real representation defined in
+ -- `PrelPArr'. It would be nicer to spot this situation
+ -- earlier and raise a proper error message, but it can really
+ -- only happen in `PrelPArr' anyway.
+ --
+ isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
+ isPArrFakeAlts ((dcon, _, _):alts) =
+ case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
+ (True , True ) -> True
+ (False, False) -> False
+ _ ->
+ panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
+ --
+ mk_parrCase fail =
+ dsLookupGlobalId lengthPName `thenDs` \lengthP ->
+ unboxAlt `thenDs` \alt ->
+ returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
+ where
+ elemTy = case splitTyConApp (idType var) of
+ (_, [elemTy]) -> elemTy
+ _ -> panic panicMsg
+ panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
+ len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
+ --
+ unboxAlt =
+ newSysLocalDs intPrimTy `thenDs` \l ->
+ dsLookupGlobalId indexPName `thenDs` \indexP ->
+ mappM (mkAlt indexP) sorted_alts `thenDs` \alts ->
+ returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
+ where
+ wild = mkWildId intPrimTy
+ dft = (DEFAULT, [], fail)
+ --
+ -- each alternative matches one array length (corresponding to one
+ -- fake array constructor), so the match is on a literal; each
+ -- alternative's body is extended by a local binding for each
+ -- constructor argument, which are bound to array elements starting
+ -- with the first
+ --
+ mkAlt indexP (con, args, MatchResult _ bodyFun) =
+ bodyFun fail `thenDs` \body ->
+ returnDs (LitAlt lit, [], mkDsLets binds body)
+ where
+ lit = MachInt $ toInteger (dataConSourceArity con)
+ binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
+ --
+ indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]