{-# LANGUAGE CPP #-} module Control.Monad.Free.Zip (zipFree, zipFree_) where import Control.Monad.Free import Control.Monad.Trans.Class import Control.Monad.Trans.State import Data.Foldable import Data.Traversable as T import Prelude hiding (fail) zipFree :: (Traversable f, Eq (f ()), MonadFail m) => (Free f a -> Free f b -> m (Free f c)) -> Free f a -> Free f b -> m (Free f c) zipFree :: forall (f :: * -> *) (m :: * -> *) a b c. (Traversable f, Eq (f ()), MonadFail m) => (Free f a -> Free f b -> m (Free f c)) -> Free f a -> Free f b -> m (Free f c) zipFree Free f a -> Free f b -> m (Free f c) f (Impure f (Free f a) a) (Impure f (Free f b) b) | forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a b. a -> b -> a const ()) f (Free f a) a forall a. Eq a => a -> a -> Bool == forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a b. a -> b -> a const ()) f (Free f b) b = forall (f :: * -> *) a. f (Free f a) -> Free f a Impure forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r `liftM` forall (t1 :: * -> *) (t2 :: * -> *) (m :: * -> *) a b c. (Traversable t1, Traversable t2, Monad m, MonadFail m) => (a -> b -> m c) -> t1 a -> t2 b -> m (t2 c) unsafeZipWithG Free f a -> Free f b -> m (Free f c) f f (Free f a) a f (Free f b) b zipFree Free f a -> Free f b -> m (Free f c) _ Free f a _ Free f b _ = forall (m :: * -> *) a. MonadFail m => String -> m a fail String "zipFree: structure mistmatch" zipFree_ :: (Traversable f, Eq (f ()), MonadFail m) => (Free f a -> Free f b -> m ()) -> Free f a -> Free f b -> m () zipFree_ :: forall (f :: * -> *) (m :: * -> *) a b. (Traversable f, Eq (f ()), MonadFail m) => (Free f a -> Free f b -> m ()) -> Free f a -> Free f b -> m () zipFree_ Free f a -> Free f b -> m () f (Impure f (Free f a) a) (Impure f (Free f b) b) | forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a b. a -> b -> a const ()) f (Free f a) a forall a. Eq a => a -> a -> Bool == forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a b. a -> b -> a const ()) f (Free f b) b = forall (m :: * -> *) a b c. Applicative m => (a -> b -> m c) -> [a] -> [b] -> m () zipWithM_ Free f a -> Free f b -> m () f (forall (t :: * -> *) a. Foldable t => t a -> [a] toList f (Free f a) a) (forall (t :: * -> *) a. Foldable t => t a -> [a] toList f (Free f b) b) zipFree_ Free f a -> Free f b -> m () _ Free f a _ Free f b _ = forall (m :: * -> *) a. MonadFail m => String -> m a fail String "zipFree_: structure mismatch" unsafeZipWithG :: (Traversable t1, Traversable t2, Monad m, MonadFail m) => (a -> b -> m c) -> t1 a -> t2 b -> m (t2 c) unsafeZipWithG :: forall (t1 :: * -> *) (t2 :: * -> *) (m :: * -> *) a b c. (Traversable t1, Traversable t2, Monad m, MonadFail m) => (a -> b -> m c) -> t1 a -> t2 b -> m (t2 c) unsafeZipWithG a -> b -> m c f t1 a t1 t2 b t2 = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a evalStateT (forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) T.mapM b -> StateT [a] m c zipG' t2 b t2) (forall (t :: * -> *) a. Foldable t => t a -> [a] toList t1 a t1) where zipG' :: b -> StateT [a] m c zipG' b y = do (a x:[a] xx) <- forall (m :: * -> *) s. Monad m => StateT s m s get forall (m :: * -> *) s. Monad m => s -> StateT s m () put [a] xx forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (a -> b -> m c f a x b y)