{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE RankNTypes, PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Monad.Freer.Par (
	-- * Freer
	-- ** Type
	Freer, Fun,
	-- ** Pattern
	pattern Pure, pattern (:>>=), pattern (:=<<),
	-- ** Bind
	(>>>=), (=<<<),
	-- ** Apply
	app, appPar,
	-- * Tagged
	Tagged, runTagged, tag ) where

import Control.Arrow (first, (&&&), (>>>))
import Control.Monad.Freer.Par.Sequence (Sequence(..), ViewL(..), (|>), mapS)
import Control.Monad.Freer.Par.Funable (Funable(..), Taggable(..), sameTag)
import Control.Monad.Freer.Par.Internal.Id (Id(..))
import Numeric.Natural (Natural)
import Unsafe.Coerce (unsafeCoerce)

---------------------------------------------------------------------------

-- * PARALLEL FREER
--	+ TYPE AND MONAD
--	+ PATTERN
--	+ BIND
--	+ APPLICATION
-- * TAGGED

---------------------------------------------------------------------------
-- PARALLEL FREER
---------------------------------------------------------------------------

-- TYPE AND MONAD

infixl 7 ::>>=

data Freer s sq (f :: (* -> *) -> * -> * -> *) t a =
	Pure_ a | forall x . t x ::>>= sq (f (Freer s sq f t)) x a

freer :: (a -> b) -> (forall x . t x -> sq (f (Freer s sq f t)) x a -> b) ->
	Freer s sq f t a -> b
freer :: forall a b (t :: * -> *) (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s.
(a -> b)
-> (forall x. t x -> sq (f (Freer s sq f t)) x a -> b)
-> Freer s sq f t a
-> b
freer a -> b
p forall x. t x -> sq (f (Freer s sq f t)) x a -> b
b = \case Pure_ a
x -> a -> b
p a
x; t x
t ::>>= sq (f (Freer s sq f t)) x a
k -> t x
t forall x. t x -> sq (f (Freer s sq f t)) x a -> b
`b` sq (f (Freer s sq f t)) x a
k

instance (Sequence sq, Funable f) => Functor (Freer s sq f t) where
	fmap :: forall a b. (a -> b) -> Freer s sq f t a -> Freer s sq f t b
fmap a -> b
f = forall a b (t :: * -> *) (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s.
(a -> b)
-> (forall x. t x -> sq (f (Freer s sq f t)) x a -> b)
-> Freer s sq f t a
-> b
freer (forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a.
a -> Freer s sq f t a
Pure_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) \t x
t sq (f (Freer s sq f t)) x a
k -> t x
t forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a x.
t x -> sq (f (Freer s sq f t)) x a -> Freer s sq f t a
::>>= sq (f (Freer s sq f t)) x a
k forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> cat b c -> sq cat a c
|> forall (f :: (* -> *) -> * -> * -> *) a (m :: * -> *) b.
Funable f =>
(a -> m b) -> f m a b
fun (forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a.
a -> Freer s sq f t a
Pure_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance (Sequence sq, Funable f) => Applicative (Freer s sq f t) where
	pure :: forall a. a -> Freer s sq f t a
pure = forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a.
a -> Freer s sq f t a
Pure_
	Freer s sq f t (a -> b)
mf <*> :: forall a b.
Freer s sq f t (a -> b) -> Freer s sq f t a -> Freer s sq f t b
<*> (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>) -> (a -> b) -> Freer s sq f t b
ax) = forall a b (t :: * -> *) (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s.
(a -> b)
-> (forall x. t x -> sq (f (Freer s sq f t)) x a -> b)
-> Freer s sq f t a
-> b
freer (a -> b) -> Freer s sq f t b
ax (\t x
t -> (t x
t forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a x.
t x -> sq (f (Freer s sq f t)) x a -> Freer s sq f t a
::>>=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> cat b c -> sq cat a c
|> forall (f :: (* -> *) -> * -> * -> *) a (m :: * -> *) b.
Funable f =>
(a -> m b) -> f m a b
fun (a -> b) -> Freer s sq f t b
ax)) Freer s sq f t (a -> b)
mf

instance (Sequence sq, Funable f) => Monad (Freer s sq f t) where
	Freer s sq f t a
m >>= :: forall a b.
Freer s sq f t a -> (a -> Freer s sq f t b) -> Freer s sq f t b
>>= a -> Freer s sq f t b
f = forall a b (t :: * -> *) (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s.
(a -> b)
-> (forall x. t x -> sq (f (Freer s sq f t)) x a -> b)
-> Freer s sq f t a
-> b
freer a -> Freer s sq f t b
f (\t x
t -> (t x
t forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a x.
t x -> sq (f (Freer s sq f t)) x a -> Freer s sq f t a
::>>=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> cat b c -> sq cat a c
|> forall (f :: (* -> *) -> * -> * -> *) a (m :: * -> *) b.
Funable f =>
(a -> m b) -> f m a b
fun a -> Freer s sq f t b
f)) Freer s sq f t a
m

newtype Fun s sq f t a b = Fun { forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a b.
Fun s sq f t a b -> sq (f (Freer s sq f t)) a b
unFun :: sq (f (Freer s sq f t)) a b }

-- PATTERN

pattern Pure :: a -> Freer s sq f t a
pattern $mPure :: forall {r} {a} {s} {sq :: (* -> * -> *) -> * -> * -> *}
       {f :: (* -> *) -> * -> * -> *} {t :: * -> *}.
Freer s sq f t a -> (a -> r) -> ((# #) -> r) -> r
Pure x <- Pure_ x

{-# COMPLETE Pure, (:>>=) #-}

pattern (:>>=) :: t x -> Fun s sq f t x a -> Freer s sq f t a
pattern t $m:>>= :: forall {r} {t :: * -> *} {s} {sq :: (* -> * -> *) -> * -> * -> *}
       {f :: (* -> *) -> * -> * -> *} {a}.
Freer s sq f t a
-> (forall {x}. t x -> Fun s sq f t x a -> r) -> ((# #) -> r) -> r
:>>= k <- t ::>>= (Fun -> k)

{-# COMPLETE Pure, (:=<<) #-}

pattern (:=<<) :: Fun s sq f t x a -> t x -> Freer s sq f t a
pattern k $m:=<< :: forall {r} {s} {sq :: (* -> * -> *) -> * -> * -> *}
       {f :: (* -> *) -> * -> * -> *} {t :: * -> *} {a}.
Freer s sq f t a
-> (forall {x}. Fun s sq f t x a -> t x -> r) -> ((# #) -> r) -> r
:=<< t <- t ::>>= (Fun -> k)

-- BIND

infixl 7 >>>=

(>>>=) :: (Sequence sq, Funable f) =>
	t a -> (a -> Freer s sq f t b) -> Freer s sq f t b
>>>= :: forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a s b.
(Sequence sq, Funable f) =>
t a -> (a -> Freer s sq f t b) -> Freer s sq f t b
(>>>=) t a
m = (t a
m forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a x.
t x -> sq (f (Freer s sq f t)) x a -> Freer s sq f t a
::>>=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b.
Sequence sq =>
cat a b -> sq cat a b
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: (* -> *) -> * -> * -> *) a (m :: * -> *) b.
Funable f =>
(a -> m b) -> f m a b
fun

infixr 7 =<<<

(=<<<) :: (Sequence sq, Funable f) =>
	(a -> Freer s sq f t b) -> t a -> Freer s sq f t b
=<<< :: forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) a s (t :: * -> *) b.
(Sequence sq, Funable f) =>
(a -> Freer s sq f t b) -> t a -> Freer s sq f t b
(=<<<) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a s b.
(Sequence sq, Funable f) =>
t a -> (a -> Freer s sq f t b) -> Freer s sq f t b
(>>>=)

-- APPLICATION

app :: (Sequence sq, Funable f) => Fun s sq f t a b -> a -> Freer s sq f t b
app :: forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a b.
(Sequence sq, Funable f) =>
Fun s sq f t a b -> a -> Freer s sq f t b
app = forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a b.
(Sequence sq, Funable f) =>
sq (f (Freer s sq f t)) a b -> a -> Freer s sq f t b
aps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a b.
Fun s sq f t a b -> sq (f (Freer s sq f t)) a b
unFun

appPar :: (Sequence sq, Funable f, Taggable f) =>
	Fun s sq f t a b -> Fun s sq f t a b -> a ->
	(Freer s sq f t b, Freer s sq f t b)
Fun sq (f (Freer s sq f t)) a b
l appPar :: forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a b.
(Sequence sq, Funable f, Taggable f) =>
Fun s sq f t a b
-> Fun s sq f t a b -> a -> (Freer s sq f t b, Freer s sq f t b)
`appPar` Fun sq (f (Freer s sq f t)) a b
r = sq (f (Freer s sq f t)) a b
l forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a b.
(Sequence sq, Funable f, Taggable f) =>
sq (f (Freer s sq f t)) a b
-> sq (f (Freer s sq f t)) a b
-> a
-> (Freer s sq f t b, Freer s sq f t b)
`apsPar` sq (f (Freer s sq f t)) a b
r

aps :: (Sequence sq, Funable f) =>
	sq (f (Freer s sq f t)) a b -> a -> Freer s sq f t b
aps :: forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a b.
(Sequence sq, Funable f) =>
sq (f (Freer s sq f t)) a b -> a -> Freer s sq f t b
aps = forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b.
Sequence sq =>
sq cat a b -> ViewL sq cat a b
viewl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case ViewL sq (f (Freer s sq f t)) a b
EmptyL -> forall (f :: * -> *) a. Applicative f => a -> f a
pure; f (Freer s sq f t) a x
f :<| sq (f (Freer s sq f t)) x b
fs -> forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a x b.
(Sequence sq, Funable f) =>
f (Freer s sq f t) a x
-> sq (f (Freer s sq f t)) x b -> a -> Freer s sq f t b
aps' f (Freer s sq f t) a x
f sq (f (Freer s sq f t)) x b
fs

aps' :: (Sequence sq, Funable f) =>
	f (Freer s sq f t) a x ->
	sq (f (Freer s sq f t)) x b -> a -> Freer s sq f t b
aps' :: forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a x b.
(Sequence sq, Funable f) =>
f (Freer s sq f t) a x
-> sq (f (Freer s sq f t)) x b -> a -> Freer s sq f t b
aps' f (Freer s sq f t) a x
f sq (f (Freer s sq f t)) x b
fs = (f (Freer s sq f t) a x
f forall (f :: (* -> *) -> * -> * -> *) (m :: * -> *) a b.
(Funable f, Applicative m) =>
f m a b -> a -> m b
$$) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case Pure_ x
y -> sq (f (Freer s sq f t)) x b
fs forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a b.
(Sequence sq, Funable f) =>
sq (f (Freer s sq f t)) a b -> a -> Freer s sq f t b
`aps` x
y; t x
t ::>>= sq (f (Freer s sq f t)) x x
k -> t x
t forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a x.
t x -> sq (f (Freer s sq f t)) x a -> Freer s sq f t a
::>>= sq (f (Freer s sq f t)) x x
k forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> sq cat b c -> sq cat a c
>< sq (f (Freer s sq f t)) x b
fs

apsPar :: (Sequence sq, Funable f, Taggable f) =>
	sq (f (Freer s sq f t)) a b -> sq (f (Freer s sq f t)) a b -> a ->
	(Freer s sq f t b, Freer s sq f t b)
(sq (f (Freer s sq f t)) a b
l apsPar :: forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a b.
(Sequence sq, Funable f, Taggable f) =>
sq (f (Freer s sq f t)) a b
-> sq (f (Freer s sq f t)) a b
-> a
-> (Freer s sq f t b, Freer s sq f t b)
`apsPar` sq (f (Freer s sq f t)) a b
r) a
x = case (forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b.
Sequence sq =>
sq cat a b -> ViewL sq cat a b
viewl sq (f (Freer s sq f t)) a b
l, forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b.
Sequence sq =>
sq cat a b -> ViewL sq cat a b
viewl sq (f (Freer s sq f t)) a b
r) of
	(ViewL sq (f (Freer s sq f t)) a b
EmptyL, ViewL sq (f (Freer s sq f t)) a b
EmptyL) -> (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x, forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
	(ViewL sq (f (Freer s sq f t)) a b
EmptyL, f (Freer s sq f t) a x
g :<| sq (f (Freer s sq f t)) x b
gs) -> (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x, forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a x b.
(Sequence sq, Funable f) =>
f (Freer s sq f t) a x
-> sq (f (Freer s sq f t)) x b -> a -> Freer s sq f t b
aps' f (Freer s sq f t) a x
g sq (f (Freer s sq f t)) x b
gs a
x)
	(f (Freer s sq f t) a x
f :<| sq (f (Freer s sq f t)) x b
fs, ViewL sq (f (Freer s sq f t)) a b
EmptyL) -> (forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a x b.
(Sequence sq, Funable f) =>
f (Freer s sq f t) a x
-> sq (f (Freer s sq f t)) x b -> a -> Freer s sq f t b
aps' f (Freer s sq f t) a x
f sq (f (Freer s sq f t)) x b
fs a
x, forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
	(f (Freer s sq f t) a x
f :<| sq (f (Freer s sq f t)) x b
fs, f (Freer s sq f t) a x
g :<| gs :: sq (f (Freer s sq f t)) x b
gs@(forall a b. a -> b
unsafeCoerce -> sq (f (Freer s sq f t)) x b
gs'))
		| forall (t :: (* -> *) -> * -> * -> *) (m :: * -> *) a b.
Taggable t =>
t m a b -> Tag
getTag f (Freer s sq f t) a x
f Tag -> Tag -> Bool
`sameTag` forall (t :: (* -> *) -> * -> * -> *) (m :: * -> *) a b.
Taggable t =>
t m a b -> Tag
getTag f (Freer s sq f t) a x
g -> case f (Freer s sq f t) a x
f forall (f :: (* -> *) -> * -> * -> *) (m :: * -> *) a b.
(Funable f, Applicative m) =>
f m a b -> a -> m b
$$ a
x of
			Pure_ x
y -> sq (f (Freer s sq f t)) x b
fs forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a b.
(Sequence sq, Funable f, Taggable f) =>
sq (f (Freer s sq f t)) a b
-> sq (f (Freer s sq f t)) a b
-> a
-> (Freer s sq f t b, Freer s sq f t b)
`apsPar` sq (f (Freer s sq f t)) x b
gs' forall a b. (a -> b) -> a -> b
$ x
y
			t x
t ::>>= sq (f (Freer s sq f t)) x x
k -> (t x
t forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a x.
t x -> sq (f (Freer s sq f t)) x a -> Freer s sq f t a
::>>= sq (f (Freer s sq f t)) x x
k forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> sq cat b c -> sq cat a c
>< sq (f (Freer s sq f t)) x b
fs, t x
t forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a x.
t x -> sq (f (Freer s sq f t)) x a -> Freer s sq f t a
::>>= sq (f (Freer s sq f t)) x x
k forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> sq cat b c -> sq cat a c
>< sq (f (Freer s sq f t)) x b
gs')
		| Bool
otherwise -> (forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a x b.
(Sequence sq, Funable f) =>
f (Freer s sq f t) a x
-> sq (f (Freer s sq f t)) x b -> a -> Freer s sq f t b
aps' f (Freer s sq f t) a x
f sq (f (Freer s sq f t)) x b
fs a
x, forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a x b.
(Sequence sq, Funable f) =>
f (Freer s sq f t) a x
-> sq (f (Freer s sq f t)) x b -> a -> Freer s sq f t b
aps' f (Freer s sq f t) a x
g sq (f (Freer s sq f t)) x b
gs a
x)

---------------------------------------------------------------------------
-- TAGGED
---------------------------------------------------------------------------

newtype Tagged s a = Tagged { forall s a. Tagged s a -> Natural -> (a, Natural)
unTagged :: Natural -> (a, Natural) }

instance Functor (Tagged s) where a -> b
f fmap :: forall a b. (a -> b) -> Tagged s a -> Tagged s b
`fmap` Tagged Natural -> (a, Natural)
k = forall s a. (Natural -> (a, Natural)) -> Tagged s a
Tagged forall a b. (a -> b) -> a -> b
$ (a -> b
f forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
`first`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> (a, Natural)
k

instance Applicative (Tagged s) where
	pure :: forall a. a -> Tagged s a
pure = forall s a. (Natural -> (a, Natural)) -> Tagged s a
Tagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,)
	Tagged Natural -> (a -> b, Natural)
k <*> :: forall a b. Tagged s (a -> b) -> Tagged s a -> Tagged s b
<*> (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>) -> (a -> b) -> Tagged s b
ax) =
		forall s a. (Natural -> (a, Natural)) -> Tagged s a
Tagged forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall s a. Tagged s a -> Natural -> (a, Natural)
unTagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> b) -> Tagged s b
ax forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
`first`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> (a -> b, Natural)
k

instance Monad (Tagged s) where
	Tagged Natural -> (a, Natural)
k >>= :: forall a b. Tagged s a -> (a -> Tagged s b) -> Tagged s b
>>= a -> Tagged s b
f = forall s a. (Natural -> (a, Natural)) -> Tagged s a
Tagged forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall s a. Tagged s a -> Natural -> (a, Natural)
unTagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Tagged s b
f forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
`first`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> (a, Natural)
k

runTagged :: (forall s . Tagged s a) -> a
runTagged :: forall a. (forall s. Tagged s a) -> a
runTagged (Tagged Natural -> (a, Natural)
k) = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Natural -> (a, Natural)
k Natural
0

tag :: (Sequence sq, Funable f, Taggable f) =>
	Freer s sq f t a -> Tagged s (Freer s sq f t a)
tag :: forall (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) s (t :: * -> *) a.
(Sequence sq, Funable f, Taggable f) =>
Freer s sq f t a -> Tagged s (Freer s sq f t a)
tag m :: Freer s sq f t a
m@(Pure_ a
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Freer s sq f t a
m
tag (t x
t ::>>= sq (f (Freer s sq f t)) x a
k) = (t x
t forall s (sq :: (* -> * -> *) -> * -> * -> *)
       (f :: (* -> *) -> * -> * -> *) (t :: * -> *) a x.
t x -> sq (f (Freer s sq f t)) x a -> Freer s sq f t a
::>>=) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. (Natural -> (a, Natural)) -> Tagged s a
Tagged (Natural -> Id
Id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. Enum a => a -> a
succ)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> * -> *) (m :: * -> *) a b.
Taggable t =>
t m a b -> Id -> t m a b
putTag) forall (f :: * -> *) (sq :: (* -> * -> *) -> * -> * -> *)
       (cat :: * -> * -> *) a b.
(Applicative f, Sequence sq) =>
(forall x y. cat x y -> f (cat x y))
-> sq cat a b -> f (sq cat a b)
`mapS` sq (f (Freer s sq f t)) x a
k