{-# 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 (
LockEv, GetThreadIdNewLockId, GetThreadIdGetLock, SingletonUnlock,
NewLockId(..), pattern OccNewLockId, GetLock(..), pattern OccGetLock,
Unlock(..), pattern OccUnlock, LockId(..),
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)
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)
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'
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'
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 -> ()
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)