- newIds [
- ty1, -- a :: t1
- mkListTy ty1, -- b :: [t1]
- ty2, -- v :: t2
- mkListTy ty1, -- x :: t1
- mkListTy ty1 `mkFunTy` ty2,
- -- h :: [t1] -> t2
- ty1 `mkFunTy` (ty2 `mkFunTy` ty2),
- -- f
- ty2, -- z
- mkListTy ty1 -- xs
- ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
- let
- h_rhs = (CoLam [x] (CoCase (CoVar x)
- (CoAlgAlts
- [(nilDataCon,[],atomToExpr (CoVarAtom z)),
- (consDataCon,[a,b],body)]
- CoNoDefault)))
- body = CoLet (CoNonRec v (CoApp (CoVar h) (CoVarAtom b)))
- (CoApp (CoApp (atomToExpr (CoVarAtom f))
- (CoVarAtom a))
- (CoVarAtom v))
- in
- returnSmpl (Just
- (applyToArgs
- (CoLam [f,z,xs]
- (CoLet (CoRec [(h,h_rhs)])
- (CoApp (CoVar h) (CoVarAtom xs))))
- (ValArg arg_k:rest_args)))
+ = Just (newIds [
+ ty1, -- a :: t1
+ mkListTy ty1, -- b :: [t1]
+ ty2, -- v :: t2
+ mkListTy ty1, -- x :: t1
+ mkFunTys [mkListTy ty1] ty2,
+ -- h :: [t1] -> t2
+ mkFunTys [ty1, ty2] ty2,
+ -- f
+ ty2, -- z
+ mkListTy ty1 -- xs
+ ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
+ let
+ h_rhs = (Lam x (Case (Var x)
+ (AlgAlts
+ [(nilDataCon,[],argToExpr (VarArg z)),
+ (consDataCon,[a,b],body)]
+ NoDefault)))
+ body = Let (NonRec v (App (Var h) (VarArg b)))
+ (App (App (argToExpr (VarArg f))
+ (VarArg a))
+ (VarArg v))
+ in
+ returnSmpl (
+ mkGenApp
+ (Lam f (Lam z (Lam xs
+ (Let (Rec [(h,h_rhs)])
+ (App (Var h) (VarArg xs))))))
+ (ValArg arg_k:rest_args))
+ )