+deListComp :: [TypecheckedStmt]
+ -> CoreExpr -> CoreExpr -- Cons and nil resp; can be copied freely
+ -> DsM CoreExpr
+
+deListComp [ReturnStmt expr] cons nil
+ = dsExpr expr `thenDs` \ expr' ->
+ returnDs (mkApps cons [expr', nil])
+
+deListComp (GuardStmt guard locn : quals) cons nil
+ = dsExpr guard `thenDs` \ guard' ->
+ deListComp quals cons nil `thenDs` \ rest' ->
+ returnDs (mkIfThenElse guard' rest' nil)
+
+deListComp (LetStmt binds : quals) cons nil
+ = deListComp quals cons nil `thenDs` \ rest' ->
+ dsLet binds rest'
+
+deListComp (BindStmt pat list locn : quals) cons nil
+ = dsExpr list `thenDs` \ list' ->
+ let
+ pat_ty = outPatType pat
+ nil_ty = coreExprType nil
+ in
+ newSysLocalsDs [pat_ty, nil_ty] `thenDs` \ [x,ys] ->
+
+ dsListComp quals cons (Var ys) `thenDs` \ rest ->
+ matchSimply (Var x) ListCompMatch pat
+ rest (Var ys) `thenDs` \ core_match ->
+ bindNonRecDs (mkLams [x,ys] fn_body) $ \ fn ->
+ dsListExpr list (Var fn) nil
+
+
+data FExpr = FEOther CoreExpr -- Default case
+ | FECons -- cons
+ | FEConsComposedWith CoreExpr -- (cons . e)
+ | FENil -- nil
+
+feComposeWith FECons g
+ = returnDs (FEConsComposedWith g)
+
+feComposeWith (FEOther f) g
+ = composeWith f f `thenDs` \ h ->
+ returnDs (FEOther h)
+
+feComposeWith (FEConsComposedWith f) g
+ = composeWith f f `thenDs` \ h ->
+ returnDs (FEConsComposedWith h)
+
+
+composeWith f g
+ = newSysLocalDs arg_ty `thenDs` \ x ->
+ returnDs (Lam x (App e (App f (Var x))))
+ where
+ arg_ty = case splitFunTy_maybe (coreExprType g) of
+ Just (arg_ty,_) -> arg_ty
+ other -> panic "feComposeWith"
+
+deListExpr :: TypecheckedHsExpr
+ -> FExpr -> FExpr -- Cons and nil expressions
+ -> DsM CoreExpr
+
+deListExpr cons nil (HsDoOut ListComp stmts _ _ _ result_ty src_loc)
+ = deListComp stmts cons nil
+
+deListExpr cons nil (HsVar map, _, [f,xs])
+ | goodInst var mapIdKey = dsExpr f `thenDs` \ f' ->
+ feComposeWith cons f' `thenDs` \ cons' ->
+ in
+ deListExpr xs cons' nil
+
+
+data HsExprForm = GoodForm What [Type] [TypecheckedHsExpr]
+ | BadForm
+
+data What = HsMap | HsConcat | HsFilter | HsZip | HsFoldr
+
+analyseListProducer (HsVar v) ty_args val_args
+ | good_inst mapIdKey 2 = GoodForm HsMap ty_args val_args
+ | good_inst concatIdKey 1 = GoodForm HsConcat ty_args val_args
+ | good_inst filterIdKey 2 = GoodForm HsFilter ty_args val_args
+ | good_id zipIdKey 2 = GoodForm HsZip ty_args val_args
+ | otherwise =
+ where
+ good_inst key arity = isInstIdOf key v && result_is_list && n_args == arity
+ good_id key arity = getUnique v == key && result_is_list && n_args == arity
+
+ n_args :: Int
+ n_args = length val_args
+
+ result_is_list = resultTyIsList (idType v) ty_args val_args
+
+resultTyIsList ty ty_args val_args
+ = go ty ty_args
+ where
+ go1 ty (_:tys) = case splitForAllTy_maybe ty of
+ Just (_,ty) -> go1 ty tys
+ Nothing -> False
+ go1 ty [] = go2 ty val_args
+
+ go2 ty (_:args) = case splitFunTy_maybe of
+ Just (_,ty) -> go2 ty args
+ Nothing -> False
+
+ go2 ty [] = case splitTyConApp_maybe of
+ Just (tycon, [_]) | tycon == listTyCon -> True
+ other -> False
+
+