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

module Control.Moffy.Event.Lock.Internal (
	-- * Type Synonym
	LockEv, GetThreadIdNewLockId, GetThreadIdGetLock, SingletonUnlock,
	-- * Event Type
	NewLockId(..), pattern OccNewLockId, GetLock(..), pattern OccGetLock,
	Unlock(..), pattern OccUnlock, LockId(..),
	-- * Event
	newLockId, withLock, withLockSig ) where

import Control.Moffy (Sig, React, Request(..), Adjustable, adjust, await, waitFor, adjustSig)
import Control.Moffy.Event.ThreadId (GetThreadId, getThreadId, ThreadId)
import Data.Type.Set (numbered, pattern Nil, Singleton, (:-), (:+:))
import Data.OneOrMore (Selectable(..))
import Data.Bool (bool)

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

-- * LOCK ID
-- * EVENT
--	+ NEW LOCK ID
--	+ GET LOCK
--	+ UNLOCK
-- * WITH LOCK

---------------------------------------------------------------------------
-- LOCK ID
---------------------------------------------------------------------------

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

---------------------------------------------------------------------------
-- EVENT
---------------------------------------------------------------------------

-- NEW LOCK ID

newtype NewLockId = NewLockIdReq ThreadId deriving (Int -> NewLockId -> ShowS
[NewLockId] -> ShowS
NewLockId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NewLockId] -> ShowS
$cshowList :: [NewLockId] -> ShowS
show :: NewLockId -> String
$cshow :: NewLockId -> String
showsPrec :: Int -> NewLockId -> ShowS
$cshowsPrec :: Int -> NewLockId -> ShowS
Show, NewLockId -> NewLockId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NewLockId -> NewLockId -> Bool
$c/= :: NewLockId -> NewLockId -> Bool
== :: NewLockId -> NewLockId -> Bool
$c== :: NewLockId -> NewLockId -> Bool
Eq)
numbered [t| NewLockId |]
instance Selectable NewLockId where NewLockId
l select :: NewLockId -> NewLockId -> NewLockId
`select` NewLockId
_r = NewLockId
l
instance Request NewLockId where
	data Occurred NewLockId = OccNewLockId LockId ThreadId

type GetThreadIdNewLockId = GetThreadId :- NewLockId :- 'Nil

newLockId :: React s GetThreadIdNewLockId LockId
newLockId :: forall s. React s GetThreadIdNewLockId LockId
newLockId = forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust forall s. React s (Singleton GetThreadId) ThreadId
getThreadId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ThreadId
t -> forall s. React s GetThreadIdNewLockId LockId
newLockId forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` forall (f :: * -> *) a. Applicative f => a -> f a
pure
	forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e r s. e -> (Occurred e -> r) -> React s (Singleton e) r
await (ThreadId -> NewLockId
NewLockIdReq ThreadId
t))
		\(OccNewLockId LockId
i ThreadId
t') -> forall a. a -> a -> Bool -> a
bool forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just LockId
i) forall a b. (a -> b) -> a -> b
$ ThreadId
t forall a. Eq a => a -> a -> Bool
== ThreadId
t'

-- GET LOCK

data GetLock = GetLockReq LockId ThreadId RetryTime deriving (Int -> GetLock -> ShowS
[GetLock] -> ShowS
GetLock -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetLock] -> ShowS
$cshowList :: [GetLock] -> ShowS
show :: GetLock -> String
$cshow :: GetLock -> String
showsPrec :: Int -> GetLock -> ShowS
$cshowsPrec :: Int -> GetLock -> ShowS
Show, GetLock -> GetLock -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetLock -> GetLock -> Bool
$c/= :: GetLock -> GetLock -> Bool
== :: GetLock -> GetLock -> Bool
$c== :: GetLock -> GetLock -> Bool
Eq)
type RetryTime = Int
numbered [t| GetLock |]
instance Selectable GetLock where
	l :: GetLock
l@(GetLockReq LockId
_ ThreadId
_ Int
rtl) select :: GetLock -> GetLock -> GetLock
`select` r :: GetLock
r@(GetLockReq LockId
_ ThreadId
_ Int
rtr)
		| Int
rtl forall a. Ord a => a -> a -> Bool
>= Int
rtr = GetLock
l | Bool
otherwise = GetLock
r
instance Request GetLock where
	data Occurred GetLock = OccGetLock LockId ThreadId

type GetThreadIdGetLock = GetThreadId :- GetLock :- 'Nil

getLock :: LockId -> RetryTime -> React s GetThreadIdGetLock ()
getLock :: forall s. LockId -> Int -> React s GetThreadIdGetLock ()
getLock LockId
i Int
rt = forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust forall s. React s (Singleton GetThreadId) ThreadId
getThreadId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ThreadId
t -> forall s. LockId -> Int -> React s GetThreadIdGetLock ()
getLock LockId
i (Int
rt forall a. Num a => a -> a -> a
+ Int
1) forall a. a -> a -> Bool -> a
`bool` forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
	forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e r s. e -> (Occurred e -> r) -> React s (Singleton e) r
await (LockId -> ThreadId -> Int -> GetLock
GetLockReq LockId
i ThreadId
t Int
rt))
		\(OccGetLock LockId
i' ThreadId
t') -> LockId
i forall a. Eq a => a -> a -> Bool
== LockId
i' Bool -> Bool -> Bool
&& ThreadId
t forall a. Eq a => a -> a -> Bool
== ThreadId
t'

-- UNLOCK

newtype Unlock = UnlockReq LockId deriving Int -> Unlock -> ShowS
[Unlock] -> ShowS
Unlock -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Unlock] -> ShowS
$cshowList :: [Unlock] -> ShowS
show :: Unlock -> String
$cshow :: Unlock -> String
showsPrec :: Int -> Unlock -> ShowS
$cshowsPrec :: Int -> Unlock -> ShowS
Show
numbered [t| Unlock |]
instance Selectable Unlock where Unlock
l select :: Unlock -> Unlock -> Unlock
`select` Unlock
_r = Unlock
l
instance Request Unlock where data Occurred Unlock = OccUnlock

type SingletonUnlock = Singleton Unlock

unlock :: LockId -> React s (Singleton Unlock) ()
unlock :: forall s. LockId -> React s (Singleton Unlock) ()
unlock LockId
l = forall e r s. e -> (Occurred e -> r) -> React s (Singleton e) r
await (LockId -> Unlock
UnlockReq LockId
l) \Occurred Unlock
R:OccurredUnlock
OccUnlock -> ()

---------------------------------------------------------------------------
-- WITH LOCK
---------------------------------------------------------------------------

type LockEv = NewLockId :- GetLock :- Unlock :- 'Nil

withLock :: (
	(es :+: es') ~ es',
	(GetThreadIdGetLock :+: es') ~ es', (SingletonUnlock :+: es') ~ es',
	Adjustable es es',
	Adjustable GetThreadIdGetLock es', Adjustable SingletonUnlock es' ) =>
	LockId -> React s es a -> React s es' a
withLock :: forall (es :: Set (*)) (es' :: Set (*)) s a.
((es :+: es') ~ es', (GetThreadIdGetLock :+: es') ~ es',
 (Singleton Unlock :+: es') ~ es', Adjustable es es',
 Adjustable GetThreadIdGetLock es',
 Adjustable (Singleton Unlock) es') =>
LockId -> React s es a -> React s es' a
withLock LockId
l React s es a
act = forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust (forall s. LockId -> Int -> React s GetThreadIdGetLock ()
getLock LockId
l Int
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust React s es a
act forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust (forall s. LockId -> React s (Singleton Unlock) ()
unlock LockId
l)

withLockSig :: (
	(es :+: es') ~ es',
	(GetThreadIdGetLock :+: es') ~ es', (SingletonUnlock :+: es') ~ es',
	Adjustable es es',
	Adjustable GetThreadIdGetLock es', Adjustable SingletonUnlock es' ) =>
	LockId -> Sig s es a r -> Sig s es' a r
withLockSig :: forall (es :: Set (*)) (es' :: Set (*)) s a r.
((es :+: es') ~ es', (GetThreadIdGetLock :+: es') ~ es',
 (Singleton Unlock :+: es') ~ es', Adjustable es es',
 Adjustable GetThreadIdGetLock es',
 Adjustable (Singleton Unlock) es') =>
LockId -> Sig s es a r -> Sig s es' a r
withLockSig LockId
l Sig s es a r
s = do
	forall s (es :: Set (*)) r a. React s es r -> Sig s es a r
waitFor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust forall a b. (a -> b) -> a -> b
$ forall s. LockId -> Int -> React s GetThreadIdGetLock ()
getLock LockId
l Int
0
	forall (es :: Set (*)) (es' :: Set (*)) s a r.
Adjustable es es' =>
Sig s es a r -> Sig s es' a r
adjustSig Sig s es a r
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (es :: Set (*)) r a. React s es r -> Sig s es a r
waitFor (forall (es :: Set (*)) (es' :: Set (*)) s a.
Adjustable es es' =>
React s es a -> React s es' a
adjust forall a b. (a -> b) -> a -> b
$ forall s. LockId -> React s (Singleton Unlock) ()
unlock LockId
l)