HFunctor combinators

HFunctorCombinators.hs

{-# LANGUAGE RankNTypes, TypeOperators, KindSignatures, ScopedTypeVariables #-}

import Control.Functor.HigherOrder 
import Control.Functor.Extras

newtype K k    (r :: * -> *) a = K k
newtype I f    (r :: * -> *) a = I (r (f a))
newtype E      (r :: * -> *) a = E a
data (f :*: g) (r :: * -> *) a = f r a :*: g r a
data (f :+: g) (r :: * -> *) a = L (f r a) | R (g r a)

instance HFunctor (K k) where
  ffmap _ (K k) = K k
  hfmap _ (K k) = K k
instance Functor f => HFunctor (I f) where
  ffmap f (I i) = I (fmap (fmap f) i)
  hfmap f (I i) = I (f i)
instance HFunctor E where
  ffmap f (E e) = E (f e)
  hfmap f (E e) = E e
instance (HFunctor f, HFunctor g) => HFunctor (f :*: g) where
  ffmap f (l :*: r) = ffmap f l :*: ffmap f r
  hfmap f (l :*: r) = hfmap f l :*: hfmap f r
instance (HFunctor f, HFunctor g) => HFunctor (f :+: g) where
  ffmap f (L l) = L (ffmap f l)
  ffmap f (R r) = R (ffmap f r)
  hfmap f (L l) = L (hfmap f l)
  hfmap f (R r) = R (hfmap f r)
  
  
-- An example datatype: perfectly balanced trees.
-- The equivalent of data HPTree r a = HPLeaf a | HPNode (r (Pair a))

type HPTree = E :+: I Pair

data Pair a = Pair a a
instance Functor Pair where fmap f (Pair l r) = Pair (f l) (f r)
type PTree = FixH HPTree
  
  
-- Some folds on FixH-ed HFunctors, from Patricia Johann and Neil Ghani

hfold :: (HFunctor h, Functor f) => HAlgebra h f -> FixH h :~> f
hfold alg = alg . hfmap (hfold alg) . outH

hbuild :: HFunctor h => (forall f. HAlgebra h f -> c :~> f) -> c :~> FixH h
hbuild fromAlg = fromAlg InH

hunfold :: forall h f. (HFunctor h, Functor f) => HCoalgebra h f -> f :~> FixH h
hunfold coalg = hbuild fromAlg where
  fromAlg :: forall g. (h g :~> g) -> f :~> g
  fromAlg alg = alg . hfmap (fromAlg alg) . coalg

newtype RanK g f a = RanK { unRanK :: (a -> g) -> f }
instance Functor (RanK g f) where
  fmap f (RanK c) = RanK (\d -> c (d . f))

newtype LanK g f a = LanK { unLanK :: (g -> a, f) }
instance Functor (LanK g f) where
  fmap f (LanK (d, c)) = LanK (f . d, c)
  
gfoldk :: HFunctor h => HAlgebra h (RanK g f) -> (a -> g) -> FixH h a -> f
gfoldk alg g m = unRanK (hfold alg m) g

gbuildk :: HFunctor h => (forall f. HAlgebra h f -> LanK g c :~> f) -> (g -> a) -> c -> FixH h a
gbuildk fromAlg g f = hbuild fromAlg (LanK (g, f))

gunfoldk :: HFunctor h => HCoalgebra h (LanK g f) -> (g -> a) -> f -> FixH h a
gunfoldk coalg g f = hunfold coalg (LanK (g, f))



-- An unfold and a fold for perfect trees.

pTreeOfDepth :: Int -> a -> PTree a
pTreeOfDepth n x = gunfoldk coalg id n where
  coalg (LanK (g, 0)) = L . E $ g x
  coalg (LanK (g, n)) = R . I $ LanK (\x -> Pair (g x) (g x), n - 1)

showPTree :: Show a => PTree a -> String
showPTree = gfoldk alg show where
  alg (L (E a)) = RanK $ \s -> s a
  alg (R (I r)) = RanK $ \s -> unRanK r $ \(Pair a b) -> "(" ++ s a ++ ", " ++ s b ++ ")"
  
test = showPTree $ pTreeOfDepth 3 'x'