{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DataKinds, TypeOperators, ConstraintKinds #-}
{-# LANGUAGE GADTs, TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Moffy.Internal.React.Type (
	-- * React
	-- ** Type React and Data Rct
	React, Rct(..), EvReqs, EvOccs,
	-- ** Class Request
	Request(..),
	-- ** Constraint Synonym for Data Occurred
	ExpandableOccurred, CollapsableOccurred, MergeableOccurred,
	-- * Never and Await
	never, await, await',
	-- * Handle
	Handle, HandleSt, St, liftHandle, liftSt,
	-- * ThreadId
	ThreadId, rootThreadId, noThreadId, forkThreadId ) where

import Control.Monad.Freer.Par (Freer, (=<<<), (>>>=))
import Control.Monad.Freer.Par.FTCQueue (FTCQueue)
import Control.Monad.Freer.Par.TaggableFunction (TaggableFun)
import Data.Kind (Type)
import Data.Type.Set (Set, Numbered, Singleton)
import Data.OneOrMore (OneOrMore, Selectable, pattern Singleton)
import Data.Bits (setBit)
import Numeric.Natural (Natural)

import Data.Type.SetApp
import Data.OneOrMoreApp (
	OneOrMoreApp, Expandable, Collapsable, Mergeable, unSingleton )

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

-- * REACT
--	+ TYPE
--	+ NEVER AND AWAIT
-- * CONSTRAINT SYNONYM
-- * HANDLE
-- * THREAD ID

---------------------------------------------------------------------------
-- REACT
---------------------------------------------------------------------------

-- TYPE

type React s es = Freer s FTCQueue TaggableFun (Rct es)

data Rct es r where
	Never :: Rct es r; GetThreadId :: Rct es ThreadId
	Await :: EvReqs es -> Rct es (EvOccs es)

class (Numbered e, Selectable e) => Request e where data Occurred e

type EvReqs (es :: Set Type) = OneOrMore es
type EvOccs (es :: Set Type) = OneOrMoreApp (Occurred :$: es)

-- NEVER AND AWAIT

never :: React s es a
never :: forall s (es :: Set (*)) a. React s es a
never = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (es :: Set (*)) r. Rct es r
Never

await :: e -> (Occurred e -> r) -> React s (Singleton e) r
await :: forall e r s. e -> (Occurred e -> r) -> React s (Singleton e) r
await e
rq Occurred e -> r
f = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Occurred e -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. OneOrMoreApp ('SetApp f (Singleton a)) -> a
unSingleton 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 (es :: Set (*)). EvReqs es -> Rct es (EvOccs es)
Await (forall a. a -> OneOrMore (Singleton a)
Singleton e
rq)

await' :: e -> (ThreadId -> Occurred e -> r) -> React s (Singleton e) r
await' :: forall e r s.
e -> (ThreadId -> Occurred e -> r) -> React s (Singleton e) r
await' e
rq ThreadId -> Occurred e -> r
f = forall e r s. e -> (Occurred e -> r) -> React s (Singleton e) r
await e
rq forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> Occurred e -> r
f 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 (es :: Set (*)). Rct es ThreadId
GetThreadId

---------------------------------------------------------------------------
-- CONSTRAINT SYNONYM
---------------------------------------------------------------------------

type ExpandableOccurred es es' = Expandable Occurred es es'

type CollapsableOccurred es es' = Collapsable Occurred es es'

type MergeableOccurred es es' mrg = Mergeable Occurred es es' mrg

---------------------------------------------------------------------------
-- HANDLE
---------------------------------------------------------------------------

type Handle m es = EvReqs es -> m (EvOccs es)
type HandleSt st m es = EvReqs es -> St st m (EvOccs es)
type St st m a = st -> m (a, st)

liftHandle :: Functor m => Handle m es -> HandleSt st m es
liftHandle :: forall (m :: * -> *) (es :: Set (*)) st.
Functor m =>
Handle m es -> HandleSt st m es
liftHandle = (forall (m :: * -> *) r st. Functor m => m r -> St st m r
liftSt forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

liftSt :: Functor m => m r -> St st m r
liftSt :: forall (m :: * -> *) r st. Functor m => m r -> St st m r
liftSt m r
m = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m r
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)

---------------------------------------------------------------------------
-- THREAD ID
---------------------------------------------------------------------------

data ThreadId = NoThreadId | ThreadId Natural Int deriving (Int -> ThreadId -> ShowS
[ThreadId] -> ShowS
ThreadId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadId] -> ShowS
$cshowList :: [ThreadId] -> ShowS
show :: ThreadId -> String
$cshow :: ThreadId -> String
showsPrec :: Int -> ThreadId -> ShowS
$cshowsPrec :: Int -> ThreadId -> ShowS
Show, ThreadId -> ThreadId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadId -> ThreadId -> Bool
$c/= :: ThreadId -> ThreadId -> Bool
== :: ThreadId -> ThreadId -> Bool
$c== :: ThreadId -> ThreadId -> Bool
Eq)

rootThreadId :: ThreadId
rootThreadId :: ThreadId
rootThreadId = Natural -> Int -> ThreadId
ThreadId Natural
0 Int
0

noThreadId :: React s es (ThreadId, ThreadId)
noThreadId :: forall s (es :: Set (*)). React s es (ThreadId, ThreadId)
noThreadId = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadId
NoThreadId, ThreadId
NoThreadId)

forkThreadId :: React s es (ThreadId, ThreadId)
forkThreadId :: forall s (es :: Set (*)). React s es (ThreadId, ThreadId)
forkThreadId = forall (es :: Set (*)). Rct es ThreadId
GetThreadId 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
>>>= \(ThreadId Natural
n Int
i) ->
	forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> Int -> ThreadId
ThreadId Natural
n forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1, Natural -> Int -> ThreadId
ThreadId (Natural
n forall a. Bits a => a -> Int -> a
`setBit` Int
i) forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1)