Endless.hs

{-# LANGUAGE GADTs, PatternSynonyms #-}
-- | Endless weaves enable (almost) maximally lazy breadth-first unfolds:
-- an @unfoldM@ using this module, when specialized to the @Identity@ functor,
-- has the same lazy behavior as a pure @unfold@.
--
-- The main drawback is that the resulting unfolds are slow, with quadratic complexity.
module Weave.Endless
  ( Weave
  , Weaving
  , weft
  , mesh
  ) where

import Data.Some.Newtype (Some(Some))

{-
-- The implementation I really wanted
-- (not possible because lazy patterns are not supported on existential types):

data Weave m a where
  Weft :: m (Weave m b) -> (b -> a) -> Weave m a

instance Functor (Weave m) where
  fmap f ~(Weft u g) = Weft u (f . g)

instance Applicative m => Applicative (Weave m) where
  pure x = Weft (pure (pure ())) (\_ -> x)
  liftA2 f ~(Weft u g) ~(Weft v h) = Weft ((liftA2 . liftA2) (,) u v) (\ ~(x, y) -> f (g x) (h y))

weft :: m (Weave m a) -> Weave m a
weft u = Weft u id

mesh :: Monad m => Weave m a -> m a
mesh (Weft u f) = f <$> (u >>= mesh)
-}

-- | If you use this, you probably also want to import 'Data.Some.Newtype.Some' from the library @some@.
data Weaving m a b where
  Weft :: m (Weave m b) -> (b -> a) -> Weaving m a b

-- | Endless weaves.
--
-- The 'Applicative' operation @('liftA2')@ combines weaves level-wise.
newtype Weave m a = MkWeave (Some (Weaving m a))

instance Functor (Weave m) where
  fmap f (MkWeave (Some ~(Weft u g))) = MkWeave (Some (Weft u (f . g)))

instance Applicative m => Applicative (Weave m) where
  pure x = MkWeave (Some (Weft (pure (pure ())) (\_ -> x)))
  liftA2 f (MkWeave (Some ~(Weft u g))) (MkWeave (Some ~(Weft v h)))
    = MkWeave (Some (Weft ((liftA2 . liftA2) (,) u v) (\ ~(x, y) -> f (g x) (h y))))

-- | A weft is one level of 'Weave'. It is a computation which returns the remaining levels.
weft :: m (Weave m a) -> Weave m a
weft u = MkWeave (Some (Weft u id))

-- | Run all the wefts in a 'Weave' sequentially.
mesh :: Monad m => Weave m a -> m a
mesh (MkWeave (Some (Weft u f))) = f <$> (u >>= mesh)