{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.Util.STM (
Watcher (..)
, forkLinkedWatcher
, withWatcher
, Fingerprint (..)
, WithFingerprint (..)
, blockUntilAllJust
, blockUntilChanged
, blockUntilJust
, runWhenJust
, Sim (..)
, simId
, simStateT
) where
import Control.Monad (void)
import Control.Monad.State (StateT (..))
import Data.Void
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Stack
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
blockUntilChanged :: forall m a b. (MonadSTM m, Eq b)
=> (a -> b) -> b -> STM m a -> STM m (a, b)
blockUntilChanged :: forall (m :: * -> *) a b.
(MonadSTM m, Eq b) =>
(a -> b) -> b -> STM m a -> STM m (a, b)
blockUntilChanged a -> b
f b
b STM m a
getA = do
a
a <- STM m a
getA
let b' :: b
b' = a -> b
f a
a
if b
b' b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
b
then STM m (a, b)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
else (a, b) -> STM m (a, b)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b')
runWhenJust :: IOLike m
=> ResourceRegistry m
-> String
-> STM m (Maybe a)
-> (a -> m ())
-> m ()
runWhenJust :: forall (m :: * -> *) a.
IOLike m =>
ResourceRegistry m
-> String -> STM m (Maybe a) -> (a -> m ()) -> m ()
runWhenJust ResourceRegistry m
registry String
label STM m (Maybe a)
getMaybeA a -> m ()
action =
m (Thread m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m ()) -> m ()) -> m (Thread m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
label (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$
a -> m ()
action (a -> m ()) -> m a -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe a) -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m (Maybe a) -> STM m a
blockUntilJust STM m (Maybe a)
getMaybeA)
blockUntilJust :: MonadSTM m => STM m (Maybe a) -> STM m a
blockUntilJust :: forall (m :: * -> *) a. MonadSTM m => STM m (Maybe a) -> STM m a
blockUntilJust STM m (Maybe a)
getMaybeA = do
Maybe a
ma <- STM m (Maybe a)
getMaybeA
case Maybe a
ma of
Maybe a
Nothing -> STM m a
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
Just a
a -> a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
blockUntilAllJust :: MonadSTM m => [STM m (Maybe a)] -> STM m [a]
blockUntilAllJust :: forall (m :: * -> *) a.
MonadSTM m =>
[STM m (Maybe a)] -> STM m [a]
blockUntilAllJust = (STM m (Maybe a) -> STM m a) -> [STM m (Maybe a)] -> STM m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM STM m (Maybe a) -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m (Maybe a) -> STM m a
blockUntilJust
newtype Fingerprint = Fingerprint Word64
deriving stock (Int -> Fingerprint -> ShowS
[Fingerprint] -> ShowS
Fingerprint -> String
(Int -> Fingerprint -> ShowS)
-> (Fingerprint -> String)
-> ([Fingerprint] -> ShowS)
-> Show Fingerprint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Fingerprint -> ShowS
showsPrec :: Int -> Fingerprint -> ShowS
$cshow :: Fingerprint -> String
show :: Fingerprint -> String
$cshowList :: [Fingerprint] -> ShowS
showList :: [Fingerprint] -> ShowS
Show, Fingerprint -> Fingerprint -> Bool
(Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool) -> Eq Fingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fingerprint -> Fingerprint -> Bool
== :: Fingerprint -> Fingerprint -> Bool
$c/= :: Fingerprint -> Fingerprint -> Bool
/= :: Fingerprint -> Fingerprint -> Bool
Eq, (forall x. Fingerprint -> Rep Fingerprint x)
-> (forall x. Rep Fingerprint x -> Fingerprint)
-> Generic Fingerprint
forall x. Rep Fingerprint x -> Fingerprint
forall x. Fingerprint -> Rep Fingerprint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Fingerprint -> Rep Fingerprint x
from :: forall x. Fingerprint -> Rep Fingerprint x
$cto :: forall x. Rep Fingerprint x -> Fingerprint
to :: forall x. Rep Fingerprint x -> Fingerprint
Generic)
deriving newtype (Int -> Fingerprint
Fingerprint -> Int
Fingerprint -> [Fingerprint]
Fingerprint -> Fingerprint
Fingerprint -> Fingerprint -> [Fingerprint]
Fingerprint -> Fingerprint -> Fingerprint -> [Fingerprint]
(Fingerprint -> Fingerprint)
-> (Fingerprint -> Fingerprint)
-> (Int -> Fingerprint)
-> (Fingerprint -> Int)
-> (Fingerprint -> [Fingerprint])
-> (Fingerprint -> Fingerprint -> [Fingerprint])
-> (Fingerprint -> Fingerprint -> [Fingerprint])
-> (Fingerprint -> Fingerprint -> Fingerprint -> [Fingerprint])
-> Enum Fingerprint
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Fingerprint -> Fingerprint
succ :: Fingerprint -> Fingerprint
$cpred :: Fingerprint -> Fingerprint
pred :: Fingerprint -> Fingerprint
$ctoEnum :: Int -> Fingerprint
toEnum :: Int -> Fingerprint
$cfromEnum :: Fingerprint -> Int
fromEnum :: Fingerprint -> Int
$cenumFrom :: Fingerprint -> [Fingerprint]
enumFrom :: Fingerprint -> [Fingerprint]
$cenumFromThen :: Fingerprint -> Fingerprint -> [Fingerprint]
enumFromThen :: Fingerprint -> Fingerprint -> [Fingerprint]
$cenumFromTo :: Fingerprint -> Fingerprint -> [Fingerprint]
enumFromTo :: Fingerprint -> Fingerprint -> [Fingerprint]
$cenumFromThenTo :: Fingerprint -> Fingerprint -> Fingerprint -> [Fingerprint]
enumFromThenTo :: Fingerprint -> Fingerprint -> Fingerprint -> [Fingerprint]
Enum)
deriving anyclass (Context -> Fingerprint -> IO (Maybe ThunkInfo)
Proxy Fingerprint -> String
(Context -> Fingerprint -> IO (Maybe ThunkInfo))
-> (Context -> Fingerprint -> IO (Maybe ThunkInfo))
-> (Proxy Fingerprint -> String)
-> NoThunks Fingerprint
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Fingerprint -> IO (Maybe ThunkInfo)
noThunks :: Context -> Fingerprint -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Fingerprint -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Fingerprint -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Fingerprint -> String
showTypeOf :: Proxy Fingerprint -> String
NoThunks)
data WithFingerprint a = WithFingerprint
{ forall a. WithFingerprint a -> a
forgetFingerprint :: !a
, forall a. WithFingerprint a -> Fingerprint
getFingerprint :: !Fingerprint
} deriving (Int -> WithFingerprint a -> ShowS
[WithFingerprint a] -> ShowS
WithFingerprint a -> String
(Int -> WithFingerprint a -> ShowS)
-> (WithFingerprint a -> String)
-> ([WithFingerprint a] -> ShowS)
-> Show (WithFingerprint a)
forall a. Show a => Int -> WithFingerprint a -> ShowS
forall a. Show a => [WithFingerprint a] -> ShowS
forall a. Show a => WithFingerprint a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> WithFingerprint a -> ShowS
showsPrec :: Int -> WithFingerprint a -> ShowS
$cshow :: forall a. Show a => WithFingerprint a -> String
show :: WithFingerprint a -> String
$cshowList :: forall a. Show a => [WithFingerprint a] -> ShowS
showList :: [WithFingerprint a] -> ShowS
Show, WithFingerprint a -> WithFingerprint a -> Bool
(WithFingerprint a -> WithFingerprint a -> Bool)
-> (WithFingerprint a -> WithFingerprint a -> Bool)
-> Eq (WithFingerprint a)
forall a. Eq a => WithFingerprint a -> WithFingerprint a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => WithFingerprint a -> WithFingerprint a -> Bool
== :: WithFingerprint a -> WithFingerprint a -> Bool
$c/= :: forall a. Eq a => WithFingerprint a -> WithFingerprint a -> Bool
/= :: WithFingerprint a -> WithFingerprint a -> Bool
Eq, (forall a b. (a -> b) -> WithFingerprint a -> WithFingerprint b)
-> (forall a b. a -> WithFingerprint b -> WithFingerprint a)
-> Functor WithFingerprint
forall a b. a -> WithFingerprint b -> WithFingerprint a
forall a b. (a -> b) -> WithFingerprint a -> WithFingerprint b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> WithFingerprint a -> WithFingerprint b
fmap :: forall a b. (a -> b) -> WithFingerprint a -> WithFingerprint b
$c<$ :: forall a b. a -> WithFingerprint b -> WithFingerprint a
<$ :: forall a b. a -> WithFingerprint b -> WithFingerprint a
Functor, (forall x. WithFingerprint a -> Rep (WithFingerprint a) x)
-> (forall x. Rep (WithFingerprint a) x -> WithFingerprint a)
-> Generic (WithFingerprint a)
forall x. Rep (WithFingerprint a) x -> WithFingerprint a
forall x. WithFingerprint a -> Rep (WithFingerprint a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (WithFingerprint a) x -> WithFingerprint a
forall a x. WithFingerprint a -> Rep (WithFingerprint a) x
$cfrom :: forall a x. WithFingerprint a -> Rep (WithFingerprint a) x
from :: forall x. WithFingerprint a -> Rep (WithFingerprint a) x
$cto :: forall a x. Rep (WithFingerprint a) x -> WithFingerprint a
to :: forall x. Rep (WithFingerprint a) x -> WithFingerprint a
Generic, Context -> WithFingerprint a -> IO (Maybe ThunkInfo)
Proxy (WithFingerprint a) -> String
(Context -> WithFingerprint a -> IO (Maybe ThunkInfo))
-> (Context -> WithFingerprint a -> IO (Maybe ThunkInfo))
-> (Proxy (WithFingerprint a) -> String)
-> NoThunks (WithFingerprint a)
forall a.
NoThunks a =>
Context -> WithFingerprint a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Proxy (WithFingerprint a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall a.
NoThunks a =>
Context -> WithFingerprint a -> IO (Maybe ThunkInfo)
noThunks :: Context -> WithFingerprint a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a.
NoThunks a =>
Context -> WithFingerprint a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> WithFingerprint a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall a. NoThunks a => Proxy (WithFingerprint a) -> String
showTypeOf :: Proxy (WithFingerprint a) -> String
NoThunks)
newtype Sim n m = Sim { forall (n :: * -> *) (m :: * -> *).
Sim n m -> forall a. n a -> STM m a
runSim :: forall a. n a -> STM m a }
simId :: Sim (STM m) m
simId :: forall (m :: * -> *). Sim (STM m) m
simId = (forall a. STM m a -> STM m a) -> Sim (STM m) m
forall (n :: * -> *) (m :: * -> *).
(forall a. n a -> STM m a) -> Sim n m
Sim STM m a -> STM m a
forall a. a -> a
forall a. STM m a -> STM m a
id
simStateT :: IOLike m => StrictTVar m st -> Sim n m -> Sim (StateT st n) m
simStateT :: forall (m :: * -> *) st (n :: * -> *).
IOLike m =>
StrictTVar m st -> Sim n m -> Sim (StateT st n) m
simStateT StrictTVar m st
stVar (Sim forall a. n a -> STM m a
k) = (forall a. StateT st n a -> STM m a) -> Sim (StateT st n) m
forall (n :: * -> *) (m :: * -> *).
(forall a. n a -> STM m a) -> Sim n m
Sim ((forall a. StateT st n a -> STM m a) -> Sim (StateT st n) m)
-> (forall a. StateT st n a -> STM m a) -> Sim (StateT st n) m
forall a b. (a -> b) -> a -> b
$ \(StateT st -> n (a, st)
f) -> do
st
st <- StrictTVar m st -> STM m st
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m st
stVar
(a
a, st
st') <- n (a, st) -> STM m (a, st)
forall a. n a -> STM m a
k (st -> n (a, st)
f st
st)
StrictTVar m st -> st -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m st
stVar st
st'
a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
data Watcher m a fp = Watcher {
forall (m :: * -> *) a fp. Watcher m a fp -> a -> fp
wFingerprint :: a -> fp
, forall (m :: * -> *) a fp. Watcher m a fp -> Maybe fp
wInitial :: Maybe fp
, forall (m :: * -> *) a fp. Watcher m a fp -> a -> m ()
wNotify :: a -> m ()
, forall (m :: * -> *) a fp. Watcher m a fp -> STM m a
wReader :: STM m a
}
runWatcher :: forall m a fp. (IOLike m, Eq fp, HasCallStack)
=> Watcher m a fp
-> m Void
runWatcher :: forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
Watcher m a fp -> m Void
runWatcher Watcher m a fp
watcher = do
fp
initB <- case Maybe fp
mbInitFP of
Just fp
fp -> fp -> m fp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return fp
fp
Maybe fp
Nothing -> do
a
a <- STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m a
getA
a -> m ()
notify a
a
fp -> m fp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (fp -> m fp) -> fp -> m fp
forall a b. (a -> b) -> a -> b
$ a -> fp
f a
a
fp -> m Void
loop fp
initB
where
Watcher {
wFingerprint :: forall (m :: * -> *) a fp. Watcher m a fp -> a -> fp
wFingerprint = a -> fp
f
, wInitial :: forall (m :: * -> *) a fp. Watcher m a fp -> Maybe fp
wInitial = Maybe fp
mbInitFP
, wNotify :: forall (m :: * -> *) a fp. Watcher m a fp -> a -> m ()
wNotify = a -> m ()
notify
, wReader :: forall (m :: * -> *) a fp. Watcher m a fp -> STM m a
wReader = STM m a
getA
} = Watcher m a fp
watcher
loop :: fp -> m Void
loop :: fp -> m Void
loop fp
fp = do
(a
a, fp
fp') <- STM m (a, fp) -> m (a, fp)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (a, fp) -> m (a, fp)) -> STM m (a, fp) -> m (a, fp)
forall a b. (a -> b) -> a -> b
$ (a -> fp) -> fp -> STM m a -> STM m (a, fp)
forall (m :: * -> *) a b.
(MonadSTM m, Eq b) =>
(a -> b) -> b -> STM m a -> STM m (a, b)
blockUntilChanged a -> fp
f fp
fp STM m a
getA
a -> m ()
notify a
a
fp -> m Void
loop fp
fp'
forkLinkedWatcher :: forall m a fp. (IOLike m, Eq fp, HasCallStack)
=> ResourceRegistry m
-> String
-> Watcher m a fp
-> m (Thread m Void)
forkLinkedWatcher :: forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
ResourceRegistry m -> String -> Watcher m a fp -> m (Thread m Void)
forkLinkedWatcher ResourceRegistry m
registry String
label Watcher m a fp
watcher =
ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
label (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$ Watcher m a fp -> m Void
forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
Watcher m a fp -> m Void
runWatcher Watcher m a fp
watcher
withWatcher :: forall m a fp r. (IOLike m, Eq fp, HasCallStack)
=> String
-> Watcher m a fp
-> m r
-> m r
withWatcher :: forall (m :: * -> *) a fp r.
(IOLike m, Eq fp, HasCallStack) =>
String -> Watcher m a fp -> m r -> m r
withWatcher String
label Watcher m a fp
watcher m r
k =
m Void -> (Async m Void -> m r) -> m r
forall a b. m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync
(do String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
label; Watcher m a fp -> m Void
forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
Watcher m a fp -> m Void
runWatcher Watcher m a fp
watcher)
(\Async m Void
h -> do Async m Void -> m ()
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
Async m a -> m ()
link Async m Void
h; m r
k)