module Data.Traversable.Parts
(Parts(..)
,liftParts
,queueTraversable
,runParts
,queueTraversal
,runPartsWith
,transformTraversal
,transformTraversable)
where
import Data.Queue.Indexed.Class
import GHC.TypeLits
data Parts f g a b r where
Parts :: (forall n. g (m + n) b -> (g n b, r))
-> !(f m a)
-> Parts f g a b r
instance Functor (Parts f g a b) where
fmap f (Parts g h) =
Parts (\h' -> case g h' of (remn, r) -> (remn, f r)) h
instance (IndexedQueue f x, MeldableIndexedQueue f x) =>
Applicative (Parts f g x y) where
pure x = Parts (\h -> (h, x)) empty
(Parts f (xs :: f m x) :: Parts f g x y (a -> b)) <*> Parts g (ys :: f n x) =
Parts h (merge xs ys)
where
h :: forall o . g ((m + n) + o) y -> (g o y, b)
h v = case f v of { (v', a) ->
case g v' of { (v'', b) ->
(v'', a b)}}
liftParts :: (IndexedQueue g a, IndexedQueue f x) => x -> Parts f g x a a
liftParts a = Parts (\h -> case minView h of (x, h') -> (h', x)) (singleton a)
runParts :: forall a b f. Parts f f b b a -> a
runParts (Parts (f :: f (m + 0) b -> (f 0 b, a)) xs) = snd $ f xs
runPartsWith :: forall a b c f g. (forall n. f n a -> g n b) -> Parts f g a b c -> c
runPartsWith f (Parts (g :: g (m + 0) b -> (g 0 b, c)) xs) = snd $ g (f xs)
queueTraversable :: (MeldableIndexedQueue f a, Traversable t) => p f -> t a -> t a
queueTraversable (_ :: p f) =
runParts .
traverse
(liftParts :: (IndexedQueue g x, IndexedQueue f x) =>
x -> Parts f g x x x)
transformTraversable
:: (MeldableIndexedQueue f a, IndexedQueue g b, Traversable t)
=> (forall n. f n a -> g n b) -> t a -> t b
transformTraversable f = runPartsWith f . traverse liftParts
transformTraversal
:: (IndexedQueue g b, IndexedQueue f a)
=> (forall n. f n a -> g n b)
-> ((a -> Parts f g a b b) -> t -> Parts f g a b t)
-> t
-> t
transformTraversal f trav = runPartsWith f . trav liftParts
queueTraversal
:: (IndexedQueue f b, IndexedQueue f a)
=> ((a -> Parts f f a b b) -> t -> Parts f f a a t) -> t -> t
queueTraversal trav = runParts . trav liftParts