-mkBigLHsPatTup = mkBigTuple mkLHsPatTup
-
-\end{code}
-
-
-@mkTupleSelector@ builds a selector which scrutises the given
-expression and extracts the one name from the list given.
-If you want the no-shadowing rule to apply, the caller
-is responsible for making sure that none of these names
-are in scope.
-
-If there is just one id in the ``tuple'', then the selector is
-just the identity.
-
-If it's big, it does nesting
- mkTupleSelector [a,b,c,d] b v e
- = case e of v {
- (p,q) -> case p of p {
- (a,b) -> b }}
-We use 'tpl' vars for the p,q, since shadowing does not matter.
-
-In fact, it's more convenient to generate it innermost first, getting
-
- case (case e of v
- (p,q) -> p) of p
- (a,b) -> b
-
-\begin{code}
-mkTupleSelector :: [Id] -- The tuple args
- -> Id -- The selected one
- -> Id -- A variable of the same type as the scrutinee
- -> CoreExpr -- Scrutinee
- -> CoreExpr
-
-mkTupleSelector vars the_var scrut_var scrut
- = mk_tup_sel (chunkify vars) the_var
- where
- mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
- mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
- mk_tup_sel (chunkify tpl_vs) tpl_v
- where
- tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
- tpl_vs = mkTemplateLocals tpl_tys
- [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
- the_var `elem` gp ]
-\end{code}
-
-A generalization of @mkTupleSelector@, allowing the body
-of the case to be an arbitrary expression.
-
-If the tuple is big, it is nested:
-
- mkTupleCase uniqs [a,b,c,d] body v e
- = case e of v { (p,q) ->
- case p of p { (a,b) ->
- case q of q { (c,d) ->
- body }}}
-
-To avoid shadowing, we use uniqs to invent new variables p,q.
-
-ToDo: eliminate cases where none of the variables are needed.
-
-\begin{code}
-mkTupleCase
- :: UniqSupply -- for inventing names of intermediate variables
- -> [Id] -- the tuple args
- -> CoreExpr -- body of the case
- -> Id -- a variable of the same type as the scrutinee
- -> CoreExpr -- scrutinee
- -> CoreExpr
-
-mkTupleCase uniqs vars body scrut_var scrut
- = mk_tuple_case uniqs (chunkify vars) body
- where
- -- This is the case where don't need any nesting
- mk_tuple_case _ [vars] body
- = mkSmallTupleCase vars body scrut_var scrut
-
- -- This is the case where we must make nest tuples at least once
- mk_tuple_case us vars_s body
- = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
- in mk_tuple_case us' (chunkify vars') body'
-
- one_tuple_case chunk_vars (us, vs, body)
- = let (us1, us2) = splitUniqSupply us
- scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1)
- (mkCoreTupTy (map idType chunk_vars))
- body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
- in (us2, scrut_var:vs, body')
-\end{code}
-
-The same, but with a tuple small enough not to need nesting.
-
-\begin{code}
-mkSmallTupleCase
- :: [Id] -- the tuple args
- -> CoreExpr -- body of the case
- -> Id -- a variable of the same type as the scrutinee
- -> CoreExpr -- scrutinee
- -> CoreExpr
-
-mkSmallTupleCase [var] body _scrut_var scrut
- = bindNonRec var scrut body
-mkSmallTupleCase vars body scrut_var scrut
--- One branch no refinement?
- = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[mkFailurePair]{Code for pattern-matching and other failures}
-%* *
-%************************************************************************
-
-Call the constructor Ids when building explicit lists, so that they
-interact well with rules.
-
-\begin{code}
-mkNilExpr :: Type -> CoreExpr
-mkNilExpr ty = mkConApp nilDataCon [Type ty]
-
-mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
-mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
-
-mkListExpr :: Type -> [CoreExpr] -> CoreExpr
-mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
-
-mkFoldrExpr :: PostTcType -> PostTcType -> CoreExpr -> CoreExpr -> CoreExpr -> DsM CoreExpr
-mkFoldrExpr elt_ty result_ty c n list = do
- foldr_id <- dsLookupGlobalId foldrName
- return (Var foldr_id `App` Type elt_ty
- `App` Type result_ty
- `App` c
- `App` n
- `App` list)
-
-mkBuildExpr :: Type -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr
-mkBuildExpr elt_ty mk_build_inside = do
- [n_tyvar] <- newTyVarsDs [alphaTyVar]
- let n_ty = mkTyVarTy n_tyvar
- c_ty = mkFunTys [elt_ty, n_ty] n_ty
- [c, n] <- newSysLocalsDs [c_ty, n_ty]
-
- build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
-
- build_id <- dsLookupGlobalId buildName
- return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
-
-mkCoreSel :: [Id] -- The tuple args
- -> Id -- The selected one
- -> Id -- A variable of the same type as the scrutinee
- -> CoreExpr -- Scrutinee
- -> CoreExpr
-
--- mkCoreSel [x] x v e
--- ===> e
-mkCoreSel [var] should_be_the_same_var _ scrut
- = ASSERT(var == should_be_the_same_var)
- scrut
-
--- mkCoreSel [x,y,z] x v e
--- ===> case e of v { (x,y,z) -> x
-mkCoreSel vars the_var scrut_var scrut
- = ASSERT( notNull vars )
- Case scrut scrut_var (idType the_var)
- [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]