module Data.Traversable.Fair
( foldMapBoth
, traverseBoth
, foldMapWithKeyBoth
, traverseWithKeyBoth
, foldMapBoth1
, traverseBoth1
, foldMapWithKeyBoth1
, traverseWithKeyBoth1
) where
import Control.Applicative
import Control.Arrow
import Data.Key
import Data.Functor.Apply
import Data.Foldable
import Data.Traversable
import Data.Semigroup
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.List.NonEmpty as NonEmpty hiding (toList)
refill :: Traversable t => t a -> [b] -> t b
refill t l = snd (mapAccumL (\xs _ -> (Prelude.tail xs, Prelude.head xs)) l t)
toNonEmptyList :: Foldable1 f => f a -> NonEmpty a
toNonEmptyList = NonEmpty.fromList . toList
toKeyedNonEmptyList :: FoldableWithKey1 f => f a -> NonEmpty (Key f, a)
toKeyedNonEmptyList = NonEmpty.fromList . toKeyedList
foldMapBoth :: (Foldable f, Foldable g, Monoid m) => (a -> m) -> f a -> g a -> m
foldMapBoth f as bs = go (toList as) (toList bs) where
go [] [] = mempty
go xs [] = foldMap f xs
go [] ys = foldMap f ys
go (x:xs) (y:ys) = f x `mappend` f y `mappend` go xs ys
traverseBoth :: (Traversable f, Traversable g, Applicative m) => (a -> m b) -> f a -> g a -> m (f b, g b)
traverseBoth f as bs = (refill as *** refill bs) <$> go (toList as) (toList bs)
where
go [] [] = pure ([],[])
go xs [] = flip (,) [] <$> traverse f xs
go [] ys = (,) [] <$> traverse f ys
go (x:xs) (y:ys) = (\x' y' (xs',ys') -> (x':xs',y':ys')) <$> f x <*> f y <*> go xs ys
foldMapBoth1 :: (Foldable1 f, Foldable1 g, Semigroup m) => (a -> m) -> f a -> g a -> m
foldMapBoth1 f as bs = go (toNonEmptyList as) (toNonEmptyList bs)
where
go (x:|[]) (y:|[]) = f x <> f y
go (x:|z:zs) (y:|[]) = f x <> f y <> foldMap1 f (z:|zs)
go (x:|[]) ys = f x <> foldMap1 f ys
go (x:|z:zs) (y:|w:ws) = f x <> f y <> go (z:|zs) (w:|ws)
traverseBoth1 :: (Traversable1 f, Traversable1 g, Apply m) => (a -> m b) -> f a -> g a -> m (f b, g b)
traverseBoth1 f as bs = (refill as *** refill bs) <$> go (toNonEmptyList as) (toNonEmptyList bs)
where
go (x:|[]) (y:|[]) = (\x' y' -> ([x'], [y'] )) <$> f x <.> f y
go (x:|z:zs) (y:|[]) = (\x' y' (x'':|xs') -> (x':x'':xs', [y'] )) <$> f x <.> f y <.> traverse1 f (z:|zs)
go (x:|[]) ys = (\x' (y':|ys') -> ([x'], y':ys')) <$> f x <.> traverse1 f ys
go (x:|z:zs) (y:|w:ws) = (\x' y' (xs', ys') -> (x':xs', y':ys')) <$> f x <.> f y <.> go (z:|zs) (w:|ws)
foldMapWithKeyBoth
:: (FoldableWithKey f, FoldableWithKey g, Monoid m)
=> (Key f -> a -> m)
-> (Key g -> a -> m)
-> f a
-> g a
-> m
foldMapWithKeyBoth f g as bs = go (toKeyedList as) (toKeyedList bs) where
f' = uncurry f
g' = uncurry g
go [] [] = mempty
go xs [] = foldMap f' xs
go [] ys = foldMap g' ys
go (x:xs) (y:ys) = f' x `mappend` g' y `mappend` go xs ys
traverseWithKeyBoth
:: (TraversableWithKey f, TraversableWithKey g, Applicative m)
=> (Key f -> a -> m b)
-> (Key g -> a -> m b)
-> f a
-> g a
-> m (f b, g b)
traverseWithKeyBoth f g as bs = (refill as *** refill bs) <$> go (toKeyedList as) (toKeyedList bs)
where
f' = uncurry f
g' = uncurry g
go [] [] = pure ([],[])
go xs [] = flip (,) [] <$> traverse f' xs
go [] ys = (,) [] <$> traverse g' ys
go (x:xs) (y:ys) = (\x' y' (xs',ys') -> (x':xs',y':ys')) <$> f' x <*> g' y <*> go xs ys
foldMapWithKeyBoth1
:: (FoldableWithKey1 f, FoldableWithKey1 g, Semigroup m)
=> (Key f -> a -> m)
-> (Key g -> a -> m)
-> f a
-> g a
-> m
foldMapWithKeyBoth1 f g as bs = go (toKeyedNonEmptyList as) (toKeyedNonEmptyList bs)
where
f' = uncurry f
g' = uncurry g
go (x:|[]) (y:|[]) = f' x <> g' y
go (x:|z:zs) (y:|[]) = f' x <> g' y <> foldMap1 f' (z:|zs)
go (x:|[]) ys = f' x <> foldMap1 g' ys
go (x:|z:zs) (y:|w:ws) = f' x <> g' y <> go (z:|zs) (w:|ws)
traverseWithKeyBoth1
:: (TraversableWithKey1 f, TraversableWithKey1 g, Apply m)
=> (Key f -> a -> m b)
-> (Key g -> a -> m b)
-> f a
-> g a
-> m (f b, g b)
traverseWithKeyBoth1 f g as bs = (refill as *** refill bs) <$> go (toKeyedNonEmptyList as) (toKeyedNonEmptyList bs)
where
f' = uncurry f
g' = uncurry g
go (x:|[]) (y:|[]) = (\x' y' -> ([x'], [y'] )) <$> f' x <.> g' y
go (x:|z:zs) (y:|[]) = (\x' y' (z':|zs') -> (x':z':zs', [y'] )) <$> f' x <.> g' y <.> traverse1 f' (z:|zs)
go (x:|[]) ys = (\x' (y':|ys') -> ([x'], y':ys')) <$> f' x <.> traverse1 g' ys
go (x:|z:zs) (y:|w:ws) = (\x' y' (xs', ys') -> (x':xs', y':ys')) <$> f' x <.> g' y <.> go (z:|zs) (w:|ws)