{-# LANGUAGE GADTs #-}
-- | Strict weaves are the naive implementation of the idea "what if we generalized @zip@ to free monads?"
--
-- The resulting breadth-first unfold take quadratic time, which is slow.
--
-- The main reason for making this available is to compare it with the other variants.
module Weave.Strict
  ( Weave(..)
  , weft
  , mesh
  ) where

-- | Strict weaves.
--
-- The 'Applicative' operation @('liftA2')@ combines weaves level-wise.
data Weave m a where
  Pure :: a -> Weave m a
  Weft :: m (Weave m a) -> Weave m a

instance Functor m => Functor (Weave m) where
  fmap :: forall a b. (a -> b) -> Weave m a -> Weave m b
fmap a -> b
f (Pure a
x) = b -> Weave m b
forall a (m :: * -> *). a -> Weave m a
Pure (a -> b
f a
x)
  fmap a -> b
f (Weft m (Weave m a)
u) = m (Weave m b) -> Weave m b
forall (m :: * -> *) a. m (Weave m a) -> Weave m a
Weft (((Weave m a -> Weave m b) -> m (Weave m a) -> m (Weave m b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Weave m a -> Weave m b) -> m (Weave m a) -> m (Weave m b))
-> ((a -> b) -> Weave m a -> Weave m b)
-> (a -> b)
-> m (Weave m a)
-> m (Weave m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Weave m a -> Weave m b
forall a b. (a -> b) -> Weave m a -> Weave m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f m (Weave m a)
u)

instance Applicative m => Applicative (Weave m) where
  pure :: forall a. a -> Weave m a
pure = a -> Weave m a
forall a (m :: * -> *). a -> Weave m a
Pure
  liftA2 :: forall a b c. (a -> b -> c) -> Weave m a -> Weave m b -> Weave m c
liftA2 a -> b -> c
f (Pure a
x) Weave m b
u = (b -> c) -> Weave m b -> Weave m c
forall a b. (a -> b) -> Weave m a -> Weave m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b -> c
f a
x) Weave m b
u
  liftA2 a -> b -> c
f (Weft m (Weave m a)
u) (Pure b
y) = m (Weave m c) -> Weave m c
forall (m :: * -> *) a. m (Weave m a) -> Weave m a
Weft (((Weave m a -> Weave m c) -> m (Weave m a) -> m (Weave m c)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Weave m a -> Weave m c) -> m (Weave m a) -> m (Weave m c))
-> ((a -> c) -> Weave m a -> Weave m c)
-> (a -> c)
-> m (Weave m a)
-> m (Weave m c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> c) -> Weave m a -> Weave m c
forall a b. (a -> b) -> Weave m a -> Weave m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\a
x -> a -> b -> c
f a
x b
y) m (Weave m a)
u)
  liftA2 a -> b -> c
f (Weft m (Weave m a)
u) (Weft m (Weave m b)
v) = m (Weave m c) -> Weave m c
forall (m :: * -> *) a. m (Weave m a) -> Weave m a
Weft (((Weave m a -> Weave m b -> Weave m c)
-> m (Weave m a) -> m (Weave m b) -> m (Weave m c)
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((Weave m a -> Weave m b -> Weave m c)
 -> m (Weave m a) -> m (Weave m b) -> m (Weave m c))
-> ((a -> b -> c) -> Weave m a -> Weave m b -> Weave m c)
-> (a -> b -> c)
-> m (Weave m a)
-> m (Weave m b)
-> m (Weave m c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> c) -> Weave m a -> Weave m b -> Weave m c
forall a b c. (a -> b -> c) -> Weave m a -> Weave m b -> Weave m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2) a -> b -> c
f m (Weave m a)
u m (Weave m b)
v)

-- | 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 :: forall (m :: * -> *) a. m (Weave m a) -> Weave m a
weft = m (Weave m a) -> Weave m a
forall (m :: * -> *) a. m (Weave m a) -> Weave m a
Weft

-- | Run all the wefts in a 'Weave' sequentially.
mesh :: Monad m => Weave m a -> m a
mesh :: forall (m :: * -> *) a. Monad m => Weave m a -> m a
mesh (Pure a
x) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
mesh (Weft m (Weave m a)
u) = m (Weave m a)
u m (Weave m a) -> (Weave m a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Weave m a -> m a
forall (m :: * -> *) a. Monad m => Weave m a -> m a
mesh