{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Monad.Freer.Par.Sequence (
	-- * Sequence and ViewL
	Sequence(..), ViewL(..),
	-- * Combinator
	(<|), (|>), mapS ) where

import Control.Arrow ((>>>))

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

-- * SEQUENCE AND VIEWL
-- * COMBINATOR

---------------------------------------------------------------------------
-- SEQUENCE AND VIEWL
---------------------------------------------------------------------------

infixr 8 ><

class Sequence sq where
	empty :: sq cat a a; singleton :: cat a b -> sq cat a b
	(><) :: sq cat a b -> sq cat b c -> sq cat a c
	viewl :: sq cat a b -> ViewL sq cat a b

data ViewL sq cat a b where
	EmptyL :: ViewL sq cat a a
	(:<|) :: cat a x -> sq cat x b -> ViewL sq cat a b

---------------------------------------------------------------------------
-- COMBINATOR
---------------------------------------------------------------------------

infixr 8 <|

(<|) :: Sequence sq => cat a b -> sq cat b c -> sq cat a c
cat a b
c <| :: forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
cat a b -> sq cat b c -> sq cat a c
<| sq cat b c
s = forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b.
Sequence sq =>
cat a b -> sq cat a b
singleton cat a b
c forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> sq cat b c -> sq cat a c
>< sq cat b c
s

infixl 8 |>

(|>) :: Sequence sq => sq cat a b -> cat b c -> sq cat a c
sq cat a b
s |> :: forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> cat b c -> sq cat a c
|> cat b c
c = sq cat a b
s forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
sq cat a b -> sq cat b c -> sq cat a c
>< forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b.
Sequence sq =>
cat a b -> sq cat a b
singleton cat b c
c

mapS :: (Applicative f, Sequence sq) =>
	(forall x y . cat x y -> f (cat x y)) -> sq cat a b -> f (sq cat a b)
mapS :: 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 forall x y. cat x y -> f (cat x y)
f = 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 cat a b
EmptyL -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a.
Sequence sq =>
sq cat a a
empty; cat a x
c :<| sq cat x b
s -> forall (sq :: (* -> * -> *) -> * -> * -> *) (cat :: * -> * -> *) a
       b c.
Sequence sq =>
cat a b -> sq cat b c -> sq cat a c
(<|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x y. cat x y -> f (cat x y)
f cat a x
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x y. cat x y -> f (cat x y)
f 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 cat x b
s