{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NumericUnderscores #-}

module Prod.Background (
    BackgroundVal,
    MicroSeconds,
    background,
    backgroundLoop,
    kill,
    link,
    readBackgroundVal,
    Track (..),
)
where

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (Async, async, cancel)
import qualified Control.Concurrent.Async as Async
import Control.Monad (forever)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Prod.Tracer (Tracer (..))

import GHC.Stack (CallStack, HasCallStack, callStack)

data Track r
    = Init r
    | RunStart
    | RunDone r r
    | Kill CallStack
    deriving (Int -> Track r -> ShowS
[Track r] -> ShowS
Track r -> String
(Int -> Track r -> ShowS)
-> (Track r -> String) -> ([Track r] -> ShowS) -> Show (Track r)
forall r. Show r => Int -> Track r -> ShowS
forall r. Show r => [Track r] -> ShowS
forall r. Show r => Track r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall r. Show r => Int -> Track r -> ShowS
showsPrec :: Int -> Track r -> ShowS
$cshow :: forall r. Show r => Track r -> String
show :: Track r -> String
$cshowList :: forall r. Show r => [Track r] -> ShowS
showList :: [Track r] -> ShowS
Show, (forall a b. (a -> b) -> Track a -> Track b)
-> (forall a b. a -> Track b -> Track a) -> Functor Track
forall a b. a -> Track b -> Track a
forall a b. (a -> b) -> Track a -> Track 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) -> Track a -> Track b
fmap :: forall a b. (a -> b) -> Track a -> Track b
$c<$ :: forall a b. a -> Track b -> Track a
<$ :: forall a b. a -> Track b -> Track a
Functor)

-- | A value that is coupled to an async in charge of updating the value.
data BackgroundVal a
    = forall r.
      BackgroundVal
    { ()
transform :: r -> a
    -- ^ a transformation to apply to the background val, allows to turn the IORef into a functor
    , ()
currentValue :: IORef r
    -- ^ a mutable reference for the latest value
    , forall a. BackgroundVal a -> Async ()
backgroundTask :: Async ()
    -- ^ a background task responsible for updating the value, implementations should guarantee that once the Aync () is cancelled, currentValue is never updated
    , ()
tracer :: Tracer IO (Track r)
    }

instance Functor BackgroundVal where
    fmap :: forall a b. (a -> b) -> BackgroundVal a -> BackgroundVal b
fmap a -> b
g (BackgroundVal r -> a
f IORef r
ioref Async ()
task Tracer IO (Track r)
tracer) =
        (r -> b)
-> IORef r -> Async () -> Tracer IO (Track r) -> BackgroundVal b
forall a r.
(r -> a)
-> IORef r -> Async () -> Tracer IO (Track r) -> BackgroundVal a
BackgroundVal (a -> b
g (a -> b) -> (r -> a) -> r -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> a
f) IORef r
ioref Async ()
task Tracer IO (Track r)
tracer

-- | Starts a background task continuously updating a value.
background ::
    Tracer IO (Track a) ->
    -- | initial state
    b ->
    -- | initial value
    a ->
    -- | state-influenced task
    (b -> IO (a, b)) ->
    IO (BackgroundVal a)
background :: forall a b.
Tracer IO (Track a)
-> b -> a -> (b -> IO (a, b)) -> IO (BackgroundVal a)
background Tracer IO (Track a)
tracer b
initState a
defaultValue b -> IO (a, b)
task = do
    Track a -> IO ()
trace (a -> Track a
forall r. r -> Track r
Init a
defaultValue)
    IORef a
ref <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
defaultValue
    (a -> a)
-> IORef a -> Async () -> Tracer IO (Track a) -> BackgroundVal a
forall a r.
(r -> a)
-> IORef r -> Async () -> Tracer IO (Track r) -> BackgroundVal a
BackgroundVal a -> a
forall a. a -> a
id IORef a
ref (Async () -> Tracer IO (Track a) -> BackgroundVal a)
-> IO (Async ()) -> IO (Tracer IO (Track a) -> BackgroundVal a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IORef a -> b -> IO ()
forall {b}. IORef a -> b -> IO b
loop IORef a
ref b
initState) IO (Tracer IO (Track a) -> BackgroundVal a)
-> IO (Tracer IO (Track a)) -> IO (BackgroundVal a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Track a) -> IO (Tracer IO (Track a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer IO (Track a)
tracer
  where
    trace :: Track a -> IO ()
trace = Tracer IO (Track a) -> Track a -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
runTracer Tracer IO (Track a)
tracer
    loop :: IORef a -> b -> IO b
loop IORef a
ref b
st0 = do
        Track a -> IO ()
trace (Track a
forall r. Track r
RunStart)
        (a
newVal, b
st1) <- b -> IO (a, b)
task b
st0
        a
oldVal <- a -> IO a -> IO a
forall a b. a -> b -> b
seq a
newVal (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IORef a -> (a -> (a, a)) -> IO a
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef a
ref (\a
old -> (a
newVal, a
old))
        Track a -> IO ()
trace (a -> a -> Track a
forall r. r -> r -> Track r
RunDone a
oldVal a
newVal)
        b -> IO b -> IO b
forall a b. a -> b -> b
seq b
st1 (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$ IORef a -> b -> IO b
loop IORef a
ref b
st1

-- | Fantom type for annotating Int.
type MicroSeconds n = n

{- | Starts a background task continuously updating a value at a periodic interval.
This is implemented by interspersing a threadDelay before the task and calling background and hiding the 'state-passing' arguments.
-}
backgroundLoop ::
    Tracer IO (Track a) ->
    -- | initial value
    a ->
    -- | periodic task
    IO a ->
    -- | wait period between two executions
    MicroSeconds Int ->
    IO (BackgroundVal a)
backgroundLoop :: forall a.
Tracer IO (Track a) -> a -> IO a -> Int -> IO (BackgroundVal a)
backgroundLoop Tracer IO (Track a)
tracer a
defaultValue IO a
task Int
usecs = do
    Tracer IO (Track a)
-> () -> a -> (() -> IO (a, ())) -> IO (BackgroundVal a)
forall a b.
Tracer IO (Track a)
-> b -> a -> (b -> IO (a, b)) -> IO (BackgroundVal a)
background Tracer IO (Track a)
tracer () a
defaultValue (\()
_ -> Int -> IO ()
threadDelay Int
usecs IO () -> IO (a, ()) -> IO (a, ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> (a, ())) -> IO a -> IO (a, ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> (a, ())
forall {a}. a -> (a, ())
adapt IO a
task)
  where
    adapt :: a -> (a, ())
adapt a
x = (a
x, ())

-- | Kills the watchdog by killing the underlying async.
readBackgroundVal :: (MonadIO m) => BackgroundVal a -> m a
readBackgroundVal :: forall (m :: * -> *) a. MonadIO m => BackgroundVal a -> m a
readBackgroundVal (BackgroundVal r -> a
f IORef r
ioref Async ()
_ Tracer IO (Track r)
_) =
    (r -> a) -> m r -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> a
f (m r -> m a) -> m r -> m a
forall a b. (a -> b) -> a -> b
$ IO r -> m r
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ IORef r -> IO r
forall a. IORef a -> IO a
readIORef IORef r
ioref

-- | Kills the watchdog by killing the underlying async.
kill :: (HasCallStack, MonadIO m) => BackgroundVal a -> m ()
kill :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
BackgroundVal a -> m ()
kill bkg :: BackgroundVal a
bkg@(BackgroundVal r -> a
_ IORef r
_ Async ()
_ Tracer IO (Track r)
tracer) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO (Track r) -> Track r -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
runTracer Tracer IO (Track r)
tracer (CallStack -> Track r
forall r. CallStack -> Track r
Kill CallStack
HasCallStack => CallStack
callStack)
    IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall a. Async a -> IO ()
cancel (Async () -> IO ())
-> (BackgroundVal a -> Async ()) -> BackgroundVal a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackgroundVal a -> Async ()
forall a. BackgroundVal a -> Async ()
backgroundTask (BackgroundVal a -> IO ()) -> BackgroundVal a -> IO ()
forall a b. (a -> b) -> a -> b
$ BackgroundVal a
bkg

link :: BackgroundVal a -> BackgroundVal b -> IO ()
link :: forall a b. BackgroundVal a -> BackgroundVal b -> IO ()
link BackgroundVal a
b1 BackgroundVal b
b2 = Async () -> Async () -> IO ()
forall a b. Async a -> Async b -> IO ()
Async.link2 (BackgroundVal a -> Async ()
forall a. BackgroundVal a -> Async ()
backgroundTask BackgroundVal a
b1) (BackgroundVal b -> Async ()
forall a. BackgroundVal a -> Async ()
backgroundTask BackgroundVal b
b2)