Recursion schemeとHaskell

Recursion schemeという、foldr、unfoldrを一般化した概念があるらしいのでHaskellで色々実装してみた。あとchronomorphismのかっこよさは異常(←しつこい)。

{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-}

import Control.Monad
import Control.Monad.Free
import Control.Comonad
import Control.Comonad.Cofree

newtype Fix f = Fix (f (Fix f))

unfix (Fix f) = f

deriving instance Show (f (Fix f)) => Show (Fix f)

-- morphisms

hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo f g = f . fmap (hylo f g) . g

cata :: Functor f => (f a -> a) -> Fix f -> a
cata f = hylo f unfix

ana :: Functor f => (a -> f a) -> a -> Fix f
ana f = hylo Fix f

histo :: Functor f => (f (Cofree f a) -> a) -> Fix f -> a
histo f = extract . cata (\x -> f x :< x)

futu :: Functor f => (a -> f (Free f a)) -> a -> Fix f
futu f = ana g . return where
    g (Pure a) = f a
    g (Free fm) = fm

chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> a -> b
chrono f g = histo f . futu g

-- list from Fix

data ListF e a = Empty | Cons e a deriving Show

instance Functor (ListF e) where
    fmap _ Empty = Empty
    fmap f (Cons e a) = Cons e (f a)

listF :: b -> (e -> a -> b) -> ListF e a -> b
listF a _ Empty = a
listF _ f (Cons e a) = f e a

type List e = Fix (ListF e)

fromList :: [a] -> List a
fromList = ana (uncons Empty Cons) where

toList :: List a -> [a]
toList = cata (listF [] (:))

unfoldr_ :: (b -> Maybe (a, b)) -> b -> List a
unfoldr_ f = ana $ maybe Empty (uncurry Cons) . f

foldr_ :: (a -> b -> b) -> b -> List a -> b
foldr_ = (cata.) . flip listF

uncons :: b -> (a -> [a] -> b) -> [a] -> b
uncons e _ [] = e
uncons _ f (x:xs) = f x xs