Recursive/Corecursive over F

Main.hs

{-# LANGUAGE DeriveFoldable, DeriveFunctor, FlexibleContexts, KindSignatures, RankNTypes, TypeFamilies #-}
module Main where

import Data.Bifunctor

newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r }

wrap :: Functor f => f (F f a) -> F f a
wrap f = F (\ p i -> i (fmap (\ (F r) -> r p i) f))

data FreeF f a b = Impure (f b) | Pure a
  deriving Functor

freeF :: (a -> c) -> (f b -> c) -> FreeF f a b -> c
freeF p i r = case r of
  Pure a -> p a
  Impure f -> i f

instance Functor f => Bifunctor (FreeF f) where
  bimap f g = freeF (Pure . f) (Impure . fmap g)


type family Base t :: * -> *

class Functor (Base t) => Recursive t where
  project :: t -> Base t t

  cata :: (Base t a -> a) -> t -> a
  cata f = go where go = f . fmap go . project

class Functor (Base t) => Corecursive t where
  embed :: Base t t -> t

  ana :: (a -> Base t a) -> a -> t
  ana f = go where go = embed .fmap go . f

type instance Base (F f a) = FreeF f a

instance Functor f => Recursive (F f a) where
  project (F f) = f Pure (Impure . fmap embed)

instance Functor f => Corecursive (F f a) where
  embed r = case r of
    Pure a -> F (\ p _ -> p a)
    Impure f -> F (\ p i -> i (fmap (\ (F g) -> g p i) f))


instance Functor (F f) where
  fmap f (F r) = F (\ g -> r (g . f))

instance Applicative (F f) where
  pure a = F (\ p _ -> p a)

  F f <*> F g = F (\ p i -> f (\ a -> g (p . a) i) i)


iter :: Functor f => (f a -> a) -> F f a -> a
iter alg = cata (freeF id alg)


data Both f = Both { fst' :: !f, snd' :: !f }
  deriving (Eq, Foldable, Functor, Show)

type BinaryTree a = F Both a

tree :: BinaryTree Integer
tree = wrap (Both (pure 1) (wrap (Both (pure 2) (pure 3))))

main :: IO ()
main = print $ show $ (`cata` tree) $ \ r -> case r of
  Pure a -> a
  Impure f -> sum f