Unfolds and hylo

Unfold.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types                #-}

module Unfold where

import           Control.Applicative
import           Data.List

data Fold a b = forall x . Fold (x -> a -> x) x (x -> b)

data Pair a b = Pair !a !b

instance Functor (Fold a) where
  fmap f (Fold step begin done) =
    Fold step begin (f . done)

instance Applicative (Fold a) where
  pure x = Fold const x id
  Fold stepA beginA doneA <*> Fold stepB beginB doneB =
    Fold
      (\(Pair x y) a -> (Pair (stepA x a) (stepB y a)))
      (Pair beginA beginB)
      (\(Pair x y) -> doneA x (doneB y))

sumF :: Num a => Fold a a
sumF = Fold (flip (+)) 0 id

fold :: Fold a b -> [a] -> b
fold (Fold step begin done) = done . foldl' step begin



data Unfold a b = forall x. Unfold (x -> Maybe (Pair b x)) (a -> x)

instance Functor (Unfold a) where
  fmap f (Unfold step begin) =
    Unfold (fmap (\(Pair x y) -> Pair (f x) y) . step) begin

instance Applicative (Unfold a) where
  pure x = Unfold (Just . Pair x) (const ())
  Unfold stepA beginA <*> Unfold stepB beginB =
    Unfold
      (\(Pair x y) -> do
          (Pair f x') <- stepA x
          (Pair a y') <- stepB y
          return (Pair (f a) (Pair x' y')))
      (\a -> Pair (beginA a) (beginB a))

unfold :: Unfold a b -> a -> [b]
unfold (Unfold step begin) =
  unfoldr (fmap (\(Pair x y) -> (x,y)) . step) . begin

downFrom :: Unfold Int Int
downFrom = Unfold (\n -> if n < 0 then Nothing else Just (Pair n (pred n))) id

hylo :: Unfold a b -> Fold b c -> a -> c
hylo (Unfold stepU beginU) (Fold stepF beginF doneF) = flip go beginF . beginU
  where
    go x y = maybe (doneF y) (\(Pair b x') -> go x' (stepF y b)) (stepU x)



main :: IO ()
main = return ()