{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Observe.Event.Backend
( EventBackend (..),
EventImpl (..),
unitEventBackend,
pairEventBackend,
hoistEventBackend,
hoistEventImpl,
narrowEventBackend,
narrowEventBackend',
OnceFlag (..),
FlagState (..),
runOnce,
hoistOnceFlag,
alwaysNewOnceFlag,
newOnceFlagMVar,
)
where
import Control.Exception
import Control.Monad.Primitive
import Data.Functor
import Data.Primitive.MVar
data EventBackend m r s = EventBackend
{
forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl :: !(forall f. s f -> m (EventImpl m r f)),
forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag :: !(m (OnceFlag m))
}
data EventImpl m r f = EventImpl
{ forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl :: !r,
forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl :: !(f -> m ()),
forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: !(r -> m ()),
forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl :: !(r -> m ()),
forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl :: !(m ()),
forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl :: !(Maybe SomeException -> m ())
}
unitEventBackend :: Applicative m => EventBackend m () s
unitEventBackend :: forall (m :: * -> *) (s :: * -> *).
Applicative m =>
EventBackend m () s
unitEventBackend =
EventBackend
{ newEventImpl :: forall f. s f -> m (EventImpl m () f)
newEventImpl = \s f
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
EventImpl
{ referenceImpl :: ()
referenceImpl = (),
addFieldImpl :: f -> m ()
addFieldImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
addParentImpl :: () -> m ()
addParentImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
addProximateImpl :: () -> m ()
addProximateImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
finalizeImpl :: m ()
finalizeImpl = forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
failImpl :: Maybe SomeException -> m ()
failImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
},
newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). Applicative m => OnceFlag m
alwaysNewOnceFlag
}
pairEventBackend :: Applicative m => EventBackend m a s -> EventBackend m b s -> EventBackend m (a, b) s
pairEventBackend :: forall (m :: * -> *) a (s :: * -> *) b.
Applicative m =>
EventBackend m a s -> EventBackend m b s -> EventBackend m (a, b) s
pairEventBackend EventBackend m a s
x EventBackend m b s
y =
EventBackend
{ newEventImpl :: forall f. s f -> m (EventImpl m (a, b) f)
newEventImpl = \s f
sel -> do
EventImpl m a f
xImpl <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m a s
x s f
sel
EventImpl m b f
yImpl <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m b s
y s f
sel
pure $
EventImpl
{ referenceImpl :: (a, b)
referenceImpl = (forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m a f
xImpl, forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m b f
yImpl),
addFieldImpl :: f -> m ()
addFieldImpl = \f
f -> forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m a f
xImpl f
f forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m b f
yImpl f
f,
addParentImpl :: (a, b) -> m ()
addParentImpl = \(a
px, b
py) -> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m a f
xImpl a
px forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m b f
yImpl b
py,
addProximateImpl :: (a, b) -> m ()
addProximateImpl = \(a
px, b
py) -> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m a f
xImpl a
px forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m b f
yImpl b
py,
finalizeImpl :: m ()
finalizeImpl = forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m a f
xImpl forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m b f
yImpl,
failImpl :: Maybe SomeException -> m ()
failImpl = \Maybe SomeException
e -> forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl EventImpl m a f
xImpl Maybe SomeException
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
failImpl EventImpl m b f
yImpl Maybe SomeException
e
},
newOnceFlag :: m (OnceFlag m)
newOnceFlag = do
OnceFlag m
xOnce <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m a s
x
OnceFlag m
yOnce <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m b s
y
pure $
forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag forall a b. (a -> b) -> a -> b
$ do
FlagState
xSet <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
xOnce
FlagState
ySet <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
yOnce
pure $ case (FlagState
xSet, FlagState
ySet) of
(FlagState
NewlySet, FlagState
NewlySet) -> FlagState
NewlySet
(FlagState, FlagState)
_ -> FlagState
AlreadySet
}
hoistEventBackend ::
(Functor m, Functor n) =>
(forall x. m x -> n x) ->
EventBackend m r s ->
EventBackend n r s
hoistEventBackend :: forall (m :: * -> *) (n :: * -> *) r (s :: * -> *).
(Functor m, Functor n) =>
(forall x. m x -> n x) -> EventBackend m r s -> EventBackend n r s
hoistEventBackend forall x. m x -> n x
nt EventBackend m r s
backend =
EventBackend
{ newEventImpl :: forall f. s f -> n (EventImpl n r f)
newEventImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> EventImpl m r f -> EventImpl n r f
hoistEventImpl forall x. m x -> n x
nt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m r s
backend,
newOnceFlag :: n (OnceFlag n)
newOnceFlag = forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> OnceFlag f -> OnceFlag g
hoistOnceFlag forall x. m x -> n x
nt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. m x -> n x
nt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r s
backend)
}
hoistEventImpl :: (forall x. m x -> n x) -> EventImpl m r f -> EventImpl n r f
hoistEventImpl :: forall (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> EventImpl m r f -> EventImpl n r f
hoistEventImpl forall x. m x -> n x
nt (EventImpl {r
m ()
r -> m ()
f -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: r
failImpl :: forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
finalizeImpl :: forall (m :: * -> *) r f. EventImpl m r f -> m ()
addProximateImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addFieldImpl :: forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
referenceImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r
..}) =
EventImpl
{ r
referenceImpl :: r
referenceImpl :: r
referenceImpl,
addFieldImpl :: f -> n ()
addFieldImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> m ()
addFieldImpl,
addParentImpl :: r -> n ()
addParentImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m ()
addParentImpl,
addProximateImpl :: r -> n ()
addProximateImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m ()
addProximateImpl,
finalizeImpl :: n ()
finalizeImpl = forall x. m x -> n x
nt m ()
finalizeImpl,
failImpl :: Maybe SomeException -> n ()
failImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SomeException -> m ()
failImpl
}
narrowEventBackend ::
(Functor m) =>
(forall f. s f -> t f) ->
EventBackend m r t ->
EventBackend m r s
narrowEventBackend :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> t f) -> EventBackend m r t -> EventBackend m r s
narrowEventBackend forall f. s f -> t f
inj =
forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a)
-> EventBackend m r t -> EventBackend m r s
narrowEventBackend'
(\s f
sel forall g. t g -> (f -> g) -> a
withInjField -> forall g. t g -> (f -> g) -> a
withInjField (forall f. s f -> t f
inj s f
sel) forall a. a -> a
id)
narrowEventBackend' ::
(Functor m) =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a) ->
EventBackend m r t ->
EventBackend m r s
narrowEventBackend' :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a)
-> EventBackend m r t -> EventBackend m r s
narrowEventBackend' forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
inj EventBackend m r t
backend =
EventBackend
{ newEventImpl :: forall f. s f -> m (EventImpl m r f)
newEventImpl = \s f
sel -> forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
inj s f
sel \t g
sel' f -> g
injField ->
forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m r t
backend t g
sel' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
EventImpl {r
m ()
r -> m ()
g -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
addFieldImpl :: g -> m ()
referenceImpl :: r
failImpl :: forall (m :: * -> *) r f.
EventImpl m r f -> Maybe SomeException -> m ()
finalizeImpl :: forall (m :: * -> *) r f. EventImpl m r f -> m ()
addProximateImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addFieldImpl :: forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
referenceImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r
..} ->
EventImpl
{ addFieldImpl :: f -> m ()
addFieldImpl = g -> m ()
addFieldImpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> g
injField,
r
m ()
r -> m ()
Maybe SomeException -> m ()
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
referenceImpl :: r
failImpl :: Maybe SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
referenceImpl :: r
..
},
newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r t
backend
}
data FlagState
=
NewlySet
|
AlreadySet
newtype OnceFlag m = OnceFlag
{
forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet :: m FlagState
}
runOnce :: (Monad m) => OnceFlag m -> m () -> m ()
runOnce :: forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
f m ()
go =
forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
FlagState
NewlySet -> m ()
go
FlagState
AlreadySet -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
newOnceFlagMVar :: (PrimMonad m) => m (OnceFlag m)
newOnceFlagMVar :: forall (m :: * -> *). PrimMonad m => m (OnceFlag m)
newOnceFlagMVar = do
MVar (PrimState m) ()
flag <- forall (m :: * -> *) a. PrimMonad m => m (MVar (PrimState m) a)
newEmptyMVar
pure $
forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
PrimMonad m =>
MVar (PrimState m) a -> a -> m Bool
tryPutMVar MVar (PrimState m) ()
flag () forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Bool
False -> FlagState
AlreadySet
Bool
True -> FlagState
NewlySet
alwaysNewOnceFlag :: (Applicative m) => OnceFlag m
alwaysNewOnceFlag :: forall (m :: * -> *). Applicative m => OnceFlag m
alwaysNewOnceFlag = forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure FlagState
NewlySet
hoistOnceFlag ::
(forall x. f x -> g x) ->
OnceFlag f ->
OnceFlag g
hoistOnceFlag :: forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> OnceFlag f -> OnceFlag g
hoistOnceFlag forall x. f x -> g x
nt (OnceFlag f FlagState
cs) = forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag (forall x. f x -> g x
nt f FlagState
cs)