a histomorphism which supports types isomorphic to Cofree

HistoWithoutCofree.hs

-- The challenge posed by @sellout on the Monoidal Café
-- (https://discord.com/channels/1005220974523846678/1153280045679390770/1374915124925825104)
-- is to implement a version of histo which supports types which
-- are isomorphic to Cofree without requiring a Corecursive instance on that type.
--
-- The Monoidal Café is a private Discord server, so here is the text of the
-- challenge if you don't have access:
--
-- > So, IIRC, for `histo = gcata distHisto`,  you can generalize from `Cofree`
-- > to an arbitrary `Corecursive (cofreef a) (EnvT a f)`, in which case
-- > `distHisto` uses `ana`, so regardless of your implementation of the
-- > particular cofree type, it needs a `Corecursive` instance (and the existence
-- > is just obscured if you use `Cofree`/`unwrap`/etc. directly). This is
-- > annoying (if you do distinguish (co)data) because if you’re folding a finite
-- > structure, you should be able to hold the history in a finite cofree.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HistoWithoutCofree where

import Data.Fix

-- Let's start with a basic implementation of histo which only supports Cofree.

data Cofree f a = Cofree
  { annotation :: a
  , children :: f (Cofree f a)
  }

histo1
  :: forall f a. Functor f
  => (f (Cofree f a) -> a)
  -> Fix f
  -> a
histo1 fAlg
  = annotation . go
  where
    go :: Fix f -> Cofree f a
    go (Fix fFix)
      = let children_ :: f (Cofree f a)
            children_ = fmap go fFix
     in Cofree (fAlg children_) children_


-- Here is an example of a function which uses 'histo1'.

data ListF e r = Nil | Cons e r
  deriving (Eq, Functor, Show) 

type List e = Fix (ListF e)

nil :: List e
nil = Fix Nil

cons :: e -> List e -> List e
cons x xs = Fix $ Cons x xs

-- >>> zipConsecutive1 $ cons 1 $ cons 2 $ cons 3 $ cons 4 nil
-- [(1,2),(3,4)]
zipConsecutive1 :: List e -> [(e, e)]
zipConsecutive1 = histo1 $ \case
  Cons e0 (Cofree _ (Cons e1 (Cofree pairs _)))
    -> (e0, e1) : pairs
  _
    -> []


-- To support types other than Cofree, we will require the caller to provide an
-- equivalent of the two pieces of Cofree we have used above: 'annotation' and
-- 'Cofree'. We can make this requirement less onerous by writing a variant
-- which does not use 'annotation'.

type AlmostCofree f a = (a, f (Cofree f a))

fromAlmostCofree :: AlmostCofree f a -> Cofree f a
fromAlmostCofree (a, children_) = Cofree a children_

histo2
  :: forall f a. Functor f
  => (f (Cofree f a) -> a)
  -> Fix f
  -> a
histo2 fAlg
  = fst . go
  where
    go :: Fix f -> AlmostCofree f a
    go (Fix fFix)
      = let children_ :: f (Cofree f a)
            children_ = fmap (fromAlmostCofree . go) fFix
     in (fAlg children_, children_)

-- its API is identical to 'histo1':

-- >>> zipConsecutive2 $ cons 1 $ cons 2 $ cons 3 $ cons 4 nil
-- [(1,2),(3,4)]
zipConsecutive2 :: List e -> [(e, e)]
zipConsecutive2 = histo2 $ \case
  Cons e0 (Cofree _ (Cons e1 (Cofree pairs _)))
    -> (e0, e1) : pairs
  _
    -> []


-- We are now ready to support types which are isomorphic to Cofree.
-- pseudoCofree is isomorphic to (Cofree f a).
--
-- the recursion-schemes library supports types which are isomorphic to (Fix f),
-- but for simplicity, we do not bother with this feature in this demo.

type AlmostPseudoCofree pseudoCofree f a = (a, f pseudoCofree)

histo3
  :: forall pseudoCofree f a. Functor f
  => (a -> f pseudoCofree -> pseudoCofree)
  -> (f pseudoCofree -> a)
  -> Fix f
  -> a
histo3 mkCofree fAlg
  = fst . go
  where
    fromAlmostPseudoCofree :: AlmostPseudoCofree pseudoCofree f a -> pseudoCofree
    fromAlmostPseudoCofree (a, children_) = mkCofree a children_

    go :: Fix f -> AlmostPseudoCofree pseudoCofree f a
    go (Fix fFix)
      = let children_ :: f pseudoCofree
            children_ = fmap (fromAlmostPseudoCofree . go) fFix
     in (fAlg children_, children_)


-- For example, we can specialize 'histo3' with pseudoCofree ~ AnnotatedList e a

data AnnotatedList e a
  = ANil a
  | ACons a e (AnnotatedList e a)

histo4
  :: (ListF e (AnnotatedList e a) -> a)
  -> Fix (ListF e)
  -> a
histo4 = histo3 mkCofree
  where
    mkCofree :: a -> ListF e (AnnotatedList e a) -> AnnotatedList e a
    mkCofree a Nil
      = ANil a
    mkCofree a (Cons x xs)
      = ACons a x xs

-- Which allows us to write zipConsecutive with AnnotatedList instead of Cofree.

-- >>> zipConsecutive4 $ cons 1 $ cons 2 $ cons 3 $ cons 4 nil
-- [(1,2)]
zipConsecutive4 :: List e -> [(e, e)]
zipConsecutive4 = histo4 $ \case
  Cons e0 (ACons _ e1 (ANil pairs))
    -> (e0, e1) : pairs
  Cons e0 (ACons _ e1 (ACons pairs _ _))
    -> (e0, e1) : pairs
  _
    -> []


-- Note that since we don't have to provide an implementation for 'annotation',
-- we don't actually have to store the annotation, so we can use a type which is
-- not quite isomorphic to (Cofree (ListF e) a). For example, we can specialize
-- 'histo3' with pseudoCofree ~ [(e, a)].

histo5
  :: (ListF e [(e, a)] -> a)
  -> Fix (ListF e)
  -> a
histo5 = histo3 mkCofree
  where
    mkCofree :: a -> ListF e [(e, a)] -> [(e, a)]
    mkCofree _a Nil
      = []  -- we do not store the annotation
    mkCofree a (Cons x xs)
      = (x, a) : xs

-- Which allows us to write zipConsecutive with [(e, [(e,e)])].

-- >>> zipConsecutive5 $ cons 1 $ cons 2 $ cons 3 $ cons 4 nil
-- [(1,2),(3,4)]
zipConsecutive5 :: List e -> [(e, e)]
zipConsecutive5 = histo5 $ \case
  Cons e0 ((e1, _) : [])
    -> (e0, e1) : []
  Cons e0 ((e1, _) : (_, pairs) : _)
    -> (e0, e1) : pairs
  _
    -> []