{-# OPTIONS -fplugin=AsyncRattus.Plugin #-}

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | This module is meant for library authors that want to build APIs
-- for interacting with asynchronous resources, e.g. a GUI framework. 

module AsyncRattus.Channels (
  getInput,
  setOutput,
  mkInput,
  startEventLoop,
  timer,
  Producer (..),
  chan,
  C (..),
  delayC,
  wait,
  Chan
) where
import AsyncRattus.InternalPrimitives

import AsyncRattus.Plugin.Annotation
import AsyncRattus.Strict
import Control.Monad
import System.IO.Unsafe
import Data.IORef
import Unsafe.Coerce
import qualified Data.HashTable.IO as H
import Data.HashTable.IO (BasicHashTable)
import qualified Data.IntSet as IntSet
import Control.Concurrent hiding (Chan)

-- | A type @p@ satisfying @Producer p a@ is essentially a signal that
-- produces values of type @a@ but it might not produce such values at
-- each tick.
class Producer p a | p -> a where
  -- | Get the current value of the producer if any.
  getCurrent :: p -> Maybe' a
  -- | Get the next state of the producer. Morally, the type of this
  -- method should be
  --
  -- > getNext :: p -> (exists q. Producer q a => O q)
  --
  -- We encode the existential type using continuation-passing style.
  getNext :: p -> (forall q. Producer q a => O q -> b) -> b

instance Producer p a => Producer (O p) a where
  getCurrent :: O p -> Maybe' a
getCurrent O p
_ = Maybe' a
forall a. Maybe' a
Nothing'
  getNext :: forall b. O p -> (forall q. Producer q a => O q -> b) -> b
getNext O p
p forall q. Producer q a => O q -> b
cb = O p -> b
forall q. Producer q a => O q -> b
cb O p
p

instance Producer p a => Producer (Box p) a where
  getCurrent :: Box p -> Maybe' a
getCurrent Box p
p = p -> Maybe' a
forall p a. Producer p a => p -> Maybe' a
getCurrent (Box p -> p
forall a. Box a -> a
unbox Box p
p)
  getNext :: forall b. Box p -> (forall q. Producer q a => O q -> b) -> b
getNext Box p
p forall q. Producer q a => O q -> b
cb = p -> (forall q. Producer q a => O q -> b) -> b
forall b. p -> (forall q. Producer q a => O q -> b) -> b
forall p a b.
Producer p a =>
p -> (forall q. Producer q a => O q -> b) -> b
getNext (Box p -> p
forall a. Box a -> a
unbox Box p
p) O q -> b
forall q. Producer q a => O q -> b
cb

newtype C a = C {forall a. C a -> IO a
unC :: IO a} deriving ((forall a b. (a -> b) -> C a -> C b)
-> (forall a b. a -> C b -> C a) -> Functor C
forall a b. a -> C b -> C a
forall a b. (a -> b) -> C a -> C 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) -> C a -> C b
fmap :: forall a b. (a -> b) -> C a -> C b
$c<$ :: forall a b. a -> C b -> C a
<$ :: forall a b. a -> C b -> C a
Functor, Functor C
Functor C =>
(forall a. a -> C a)
-> (forall a b. C (a -> b) -> C a -> C b)
-> (forall a b c. (a -> b -> c) -> C a -> C b -> C c)
-> (forall a b. C a -> C b -> C b)
-> (forall a b. C a -> C b -> C a)
-> Applicative C
forall a. a -> C a
forall a b. C a -> C b -> C a
forall a b. C a -> C b -> C b
forall a b. C (a -> b) -> C a -> C b
forall a b c. (a -> b -> c) -> C a -> C b -> C c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> C a
pure :: forall a. a -> C a
$c<*> :: forall a b. C (a -> b) -> C a -> C b
<*> :: forall a b. C (a -> b) -> C a -> C b
$cliftA2 :: forall a b c. (a -> b -> c) -> C a -> C b -> C c
liftA2 :: forall a b c. (a -> b -> c) -> C a -> C b -> C c
$c*> :: forall a b. C a -> C b -> C b
*> :: forall a b. C a -> C b -> C b
$c<* :: forall a b. C a -> C b -> C a
<* :: forall a b. C a -> C b -> C a
Applicative, Applicative C
Applicative C =>
(forall a b. C a -> (a -> C b) -> C b)
-> (forall a b. C a -> C b -> C b)
-> (forall a. a -> C a)
-> Monad C
forall a. a -> C a
forall a b. C a -> C b -> C b
forall a b. C a -> (a -> C b) -> C b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. C a -> (a -> C b) -> C b
>>= :: forall a b. C a -> (a -> C b) -> C b
$c>> :: forall a b. C a -> C b -> C b
>> :: forall a b. C a -> C b -> C b
$creturn :: forall a. a -> C a
return :: forall a. a -> C a
Monad)

chan :: C (Chan a)
chan :: forall a. C (Chan a)
chan = IO (Chan a) -> C (Chan a)
forall a. IO a -> C a
C (InputChannelIdentifier -> Chan a
forall a. InputChannelIdentifier -> Chan a
Chan (InputChannelIdentifier -> Chan a)
-> IO InputChannelIdentifier -> IO (Chan a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef InputChannelIdentifier
-> (InputChannelIdentifier
    -> (InputChannelIdentifier, InputChannelIdentifier))
-> IO InputChannelIdentifier
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef InputChannelIdentifier
nextFreshChannel (\ InputChannelIdentifier
x -> (InputChannelIdentifier
x InputChannelIdentifier
-> InputChannelIdentifier -> InputChannelIdentifier
forall a. Num a => a -> a -> a
- InputChannelIdentifier
1, InputChannelIdentifier
x)))

delayC :: O (C a) -> C (O a)
delayC :: forall a. O (C a) -> C (O a)
delayC O (C a)
d = O a -> C (O a)
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> O a
forall a. a -> O a
delay (IO a -> a
forall a. IO a -> a
unsafePerformIO (C a -> IO a
forall a. C a -> IO a
unC (O (C a) -> C a
forall a. O a -> a
adv O (C a)
d))))

{-# ANN wait AllowRecursion #-}
wait :: Chan a -> O a
wait :: forall a. Chan a -> O a
wait (Chan InputChannelIdentifier
ch) = Clock -> (InputValue -> a) -> O a
forall a. Clock -> (InputValue -> a) -> O a
Delay (InputChannelIdentifier -> Clock
singletonClock InputChannelIdentifier
ch) (InputChannelIdentifier -> InputValue -> a
forall a. InputChannelIdentifier -> InputValue -> a
lookupInp InputChannelIdentifier
ch) 

{-# NOINLINE nextFreshChannel #-}
nextFreshChannel :: IORef InputChannelIdentifier
nextFreshChannel :: IORef InputChannelIdentifier
nextFreshChannel = IO (IORef InputChannelIdentifier) -> IORef InputChannelIdentifier
forall a. IO a -> a
unsafePerformIO (InputChannelIdentifier -> IO (IORef InputChannelIdentifier)
forall a. a -> IO (IORef a)
newIORef (-InputChannelIdentifier
1))


{-# NOINLINE inputValue #-}
inputValue :: MVar (Maybe' InputValue)
inputValue :: MVar (Maybe' InputValue)
inputValue = IO (MVar (Maybe' InputValue)) -> MVar (Maybe' InputValue)
forall a. IO a -> a
unsafePerformIO (Maybe' InputValue -> IO (MVar (Maybe' InputValue))
forall a. a -> IO (MVar a)
newMVar Maybe' InputValue
forall a. Maybe' a
Nothing')

{-# NOINLINE inputSem #-}
inputSem :: MVar ()
inputSem :: MVar ()
inputSem = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

data OutputChannel where
  OutputChannel :: Producer p a => !(O p) -> !(a -> IO ()) -> OutputChannel


{-# NOINLINE output #-}
output :: BasicHashTable InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
output :: BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
output = IO
  (HashTable
     RealWorld
     InputChannelIdentifier
     (List (IORef (Maybe' OutputChannel))))
-> HashTable
     RealWorld
     InputChannelIdentifier
     (List (IORef (Maybe' OutputChannel)))
forall a. IO a -> a
unsafePerformIO (IO
  (HashTable
     RealWorld
     InputChannelIdentifier
     (List (IORef (Maybe' OutputChannel))))
IO
  (BasicHashTable
     InputChannelIdentifier (List (IORef (Maybe' OutputChannel))))
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new)

{-# NOINLINE eventLoopStarted #-}
eventLoopStarted :: IORef Bool
eventLoopStarted :: IORef Bool
eventLoopStarted = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False)


-- | This function can be used to implement input signals. It returns
-- a boxed delayed computation @s@ and a callback function @cb@. The
-- signal @mkSig s@ will produce a new value @v@ whenever the callback
-- function @cb@ is called with argument @v@.
getInput :: IO (Box (O a) :* (a -> IO ()))
getInput :: forall a. IO (Box (O a) :* (a -> IO ()))
getInput = do InputChannelIdentifier
ch <- IORef InputChannelIdentifier
-> (InputChannelIdentifier
    -> (InputChannelIdentifier, InputChannelIdentifier))
-> IO InputChannelIdentifier
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef InputChannelIdentifier
nextFreshChannel (\ InputChannelIdentifier
x -> (InputChannelIdentifier
x InputChannelIdentifier
-> InputChannelIdentifier -> InputChannelIdentifier
forall a. Num a => a -> a -> a
- InputChannelIdentifier
1, InputChannelIdentifier
x))
              (Box (O a) :* (a -> IO ())) -> IO (Box (O a) :* (a -> IO ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((O a -> Box (O a)
forall a. a -> Box a
box (Clock -> (InputValue -> a) -> O a
forall a. Clock -> (InputValue -> a) -> O a
Delay (InputChannelIdentifier -> Clock
singletonClock InputChannelIdentifier
ch) (InputChannelIdentifier -> InputValue -> a
forall a. InputChannelIdentifier -> InputValue -> a
lookupInp InputChannelIdentifier
ch)))
                       Box (O a) -> (a -> IO ()) -> Box (O a) :* (a -> IO ())
forall a b. a -> b -> a :* b
:* \ a
x -> InputChannelIdentifier -> a -> IO ()
forall a. InputChannelIdentifier -> a -> IO ()
newInput InputChannelIdentifier
ch a
x)


newInput :: InputChannelIdentifier -> a -> IO ()
newInput :: forall a. InputChannelIdentifier -> a -> IO ()
newInput InputChannelIdentifier
ch a
x = do Maybe' InputValue
iv <- MVar (Maybe' InputValue) -> IO (Maybe' InputValue)
forall a. MVar a -> IO a
takeMVar MVar (Maybe' InputValue)
inputValue
                   case Maybe' InputValue
iv of 
                    Maybe' InputValue
Nothing' -> MVar (Maybe' InputValue) -> Maybe' InputValue -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe' InputValue)
inputValue (InputValue -> Maybe' InputValue
forall a. a -> Maybe' a
Just' (InputChannelIdentifier -> a -> InputValue
forall a. InputChannelIdentifier -> a -> InputValue
OneInput InputChannelIdentifier
ch a
x)) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
inputSem ()
                    Just' InputValue
more -> MVar (Maybe' InputValue) -> Maybe' InputValue -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe' InputValue)
inputValue (InputValue -> Maybe' InputValue
forall a. a -> Maybe' a
Just' (InputChannelIdentifier -> a -> InputValue -> InputValue
forall a. InputChannelIdentifier -> a -> InputValue -> InputValue
MoreInputs InputChannelIdentifier
ch a
x InputValue
more))

{-# ANN lookupInp AllowRecursion #-}
lookupInp :: InputChannelIdentifier -> InputValue -> a
lookupInp :: forall a. InputChannelIdentifier -> InputValue -> a
lookupInp InputChannelIdentifier
_ (OneInput InputChannelIdentifier
_ a
v) = a -> a
forall a b. a -> b
unsafeCoerce a
v
lookupInp InputChannelIdentifier
ch (MoreInputs InputChannelIdentifier
ch' a
v InputValue
more) = if InputChannelIdentifier
ch' InputChannelIdentifier -> InputChannelIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== InputChannelIdentifier
ch then a -> a
forall a b. a -> b
unsafeCoerce a
v else InputChannelIdentifier -> InputValue -> a
forall a. InputChannelIdentifier -> InputValue -> a
lookupInp InputChannelIdentifier
ch InputValue
more

{-# ANN setOutput' AllowLazyData #-}
setOutput' :: Producer p a => (a -> IO ()) -> O p -> IO ()
setOutput' :: forall p a. Producer p a => (a -> IO ()) -> O p -> IO ()
setOutput' a -> IO ()
cb !O p
sig = do
  IORef (Maybe' OutputChannel)
ref <- Maybe' OutputChannel -> IO (IORef (Maybe' OutputChannel))
forall a. a -> IO (IORef a)
newIORef (OutputChannel -> Maybe' OutputChannel
forall a. a -> Maybe' a
Just' (O p -> (a -> IO ()) -> OutputChannel
forall p a. Producer p a => O p -> (a -> IO ()) -> OutputChannel
OutputChannel O p
sig a -> IO ()
cb))
  let upd :: Maybe (List (IORef (Maybe' OutputChannel)))
-> (Maybe (List (IORef (Maybe' OutputChannel))), ())
upd Maybe (List (IORef (Maybe' OutputChannel)))
Nothing = (List (IORef (Maybe' OutputChannel))
-> Maybe (List (IORef (Maybe' OutputChannel)))
forall a. a -> Maybe a
Just (IORef (Maybe' OutputChannel)
ref IORef (Maybe' OutputChannel)
-> List (IORef (Maybe' OutputChannel))
-> List (IORef (Maybe' OutputChannel))
forall a. a -> List a -> List a
:! List (IORef (Maybe' OutputChannel))
forall a. List a
Nil),())
      upd (Just List (IORef (Maybe' OutputChannel))
ls) = (List (IORef (Maybe' OutputChannel))
-> Maybe (List (IORef (Maybe' OutputChannel)))
forall a. a -> Maybe a
Just (IORef (Maybe' OutputChannel)
ref IORef (Maybe' OutputChannel)
-> List (IORef (Maybe' OutputChannel))
-> List (IORef (Maybe' OutputChannel))
forall a. a -> List a -> List a
:! List (IORef (Maybe' OutputChannel))
ls),())
  let upd' :: InputChannelIdentifier
-> Maybe (List (IORef (Maybe' OutputChannel)))
-> IO (Maybe (List (IORef (Maybe' OutputChannel))), ())
upd' InputChannelIdentifier
ch Maybe (List (IORef (Maybe' OutputChannel)))
Nothing = do
        IO () -> IO ThreadId
forkIO (InputChannelIdentifier -> IO ()
threadDelay InputChannelIdentifier
ch IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InputChannelIdentifier -> () -> IO ()
forall a. InputChannelIdentifier -> a -> IO ()
newInput InputChannelIdentifier
ch ())
        (Maybe (List (IORef (Maybe' OutputChannel))), ())
-> IO (Maybe (List (IORef (Maybe' OutputChannel))), ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (List (IORef (Maybe' OutputChannel))
-> Maybe (List (IORef (Maybe' OutputChannel)))
forall a. a -> Maybe a
Just (IORef (Maybe' OutputChannel)
ref IORef (Maybe' OutputChannel)
-> List (IORef (Maybe' OutputChannel))
-> List (IORef (Maybe' OutputChannel))
forall a. a -> List a -> List a
:! List (IORef (Maybe' OutputChannel))
forall a. List a
Nil),())
      upd' InputChannelIdentifier
_ (Just List (IORef (Maybe' OutputChannel))
ls) = (Maybe (List (IORef (Maybe' OutputChannel))), ())
-> IO (Maybe (List (IORef (Maybe' OutputChannel))), ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (List (IORef (Maybe' OutputChannel))
-> Maybe (List (IORef (Maybe' OutputChannel)))
forall a. a -> Maybe a
Just (IORef (Maybe' OutputChannel)
ref IORef (Maybe' OutputChannel)
-> List (IORef (Maybe' OutputChannel))
-> List (IORef (Maybe' OutputChannel))
forall a. a -> List a -> List a
:! List (IORef (Maybe' OutputChannel))
ls),())
  let run :: IO () -> InputChannelIdentifier -> IO ()
run IO ()
pre InputChannelIdentifier
ch =
        if InputChannelIdentifier
ch InputChannelIdentifier -> InputChannelIdentifier -> Bool
forall a. Ord a => a -> a -> Bool
> InputChannelIdentifier
0 then
          IO ()
pre IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
-> InputChannelIdentifier
-> (Maybe (List (IORef (Maybe' OutputChannel)))
    -> IO (Maybe (List (IORef (Maybe' OutputChannel))), ()))
-> IO ()
forall (h :: * -> * -> * -> *) k v a.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a
H.mutateIO BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
output InputChannelIdentifier
ch (InputChannelIdentifier
-> Maybe (List (IORef (Maybe' OutputChannel)))
-> IO (Maybe (List (IORef (Maybe' OutputChannel))), ())
upd' InputChannelIdentifier
ch)
        else 
          IO ()
pre IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
-> InputChannelIdentifier
-> (Maybe (List (IORef (Maybe' OutputChannel)))
    -> (Maybe (List (IORef (Maybe' OutputChannel))), ()))
-> IO ()
forall (h :: * -> * -> * -> *) k v a.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a
H.mutate BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
output InputChannelIdentifier
ch Maybe (List (IORef (Maybe' OutputChannel)))
-> (Maybe (List (IORef (Maybe' OutputChannel))), ())
upd
  (IO () -> InputChannelIdentifier -> IO ())
-> IO () -> Clock -> IO ()
forall a. (a -> InputChannelIdentifier -> a) -> a -> Clock -> a
IntSet.foldl' IO () -> InputChannelIdentifier -> IO ()
run (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (O p -> Clock
forall a. O a -> Clock
extractClock O p
sig)


-- | This function can be used to produces outputs. Given a signal @s@
-- and function @f@, the call @setOutput s f@ registers @f@ as a
-- callback function that is called with argument @v@ whenever the
-- signal produces a new value @v@. For this function to work,
-- 'startEventLoop' must be called.
setOutput :: Producer p a => p -> (a -> IO ()) -> IO ()
setOutput :: forall p a. Producer p a => p -> (a -> IO ()) -> IO ()
setOutput !p
sig a -> IO ()
cb = do
  case p -> Maybe' a
forall p a. Producer p a => p -> Maybe' a
getCurrent p
sig of
    Just' a
cur' -> a -> IO ()
cb a
cur'
    Maybe' a
Nothing' -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  p -> (forall q. Producer q a => O q -> IO ()) -> IO ()
forall b. p -> (forall q. Producer q a => O q -> b) -> b
forall p a b.
Producer p a =>
p -> (forall q. Producer q a => O q -> b) -> b
getNext p
sig ((a -> IO ()) -> O q -> IO ()
forall p a. Producer p a => (a -> IO ()) -> O p -> IO ()
setOutput' a -> IO ()
cb)

-- | This function is essentially the composition of 'getInput' and
-- 'setOutput'. It turns any producer into a signal.
mkInput :: Producer p a => p -> IO (Box (O a))
mkInput :: forall p a. Producer p a => p -> IO (Box (O a))
mkInput p
p = do (Box (O a)
out :* a -> IO ()
cb) <- IO (Box (O a) :* (a -> IO ()))
forall a. IO (Box (O a) :* (a -> IO ()))
getInput
               p -> (a -> IO ()) -> IO ()
forall p a. Producer p a => p -> (a -> IO ()) -> IO ()
setOutput p
p a -> IO ()
cb
               Box (O a) -> IO (Box (O a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Box (O a)
out

-- | @timer n@ produces a delayed computation that ticks every @n@
-- milliseconds. In particular @mkSig (timer n)@ is a signal that
-- produces a new value every #n# milliseconds.
timer :: Int -> Box (O ())
timer :: InputChannelIdentifier -> Box (O ())
timer InputChannelIdentifier
d = O () -> Box (O ())
forall a. a -> Box a
Box (Clock -> (InputValue -> ()) -> O ()
forall a. Clock -> (InputValue -> a) -> O a
Delay (InputChannelIdentifier -> Clock
singletonClock (InputChannelIdentifier
d InputChannelIdentifier
-> InputChannelIdentifier -> InputChannelIdentifier
forall a. Ord a => a -> a -> a
`max` InputChannelIdentifier
10)) (\ InputValue
_ -> ()))


update :: InputValue -> IORef (Maybe' OutputChannel) -> IO ()
update :: InputValue -> IORef (Maybe' OutputChannel) -> IO ()
update InputValue
inp IORef (Maybe' OutputChannel)
ref = do
  Maybe' OutputChannel
mout <- IORef (Maybe' OutputChannel) -> IO (Maybe' OutputChannel)
forall a. IORef a -> IO a
readIORef IORef (Maybe' OutputChannel)
ref
  case Maybe' OutputChannel
mout of
    Maybe' OutputChannel
Nothing' -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just' (OutputChannel (Delay Clock
_ InputValue -> p
sigf) a -> IO ()
cb) -> do
      IORef (Maybe' OutputChannel) -> Maybe' OutputChannel -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe' OutputChannel)
ref Maybe' OutputChannel
forall a. Maybe' a
Nothing'
      let new :: p
new = InputValue -> p
sigf InputValue
inp
      case p -> Maybe' a
forall p a. Producer p a => p -> Maybe' a
getCurrent p
new of
        Just' a
w' -> a -> IO ()
cb a
w'
        Maybe' a
Nothing' -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      p -> (forall q. Producer q a => O q -> IO ()) -> IO ()
forall b. p -> (forall q. Producer q a => O q -> b) -> b
forall p a b.
Producer p a =>
p -> (forall q. Producer q a => O q -> b) -> b
getNext p
new ((a -> IO ()) -> O q -> IO ()
forall p a. Producer p a => (a -> IO ()) -> O p -> IO ()
setOutput' a -> IO ()
cb)


{-# ANN getOutputsForInputs AllowRecursion #-}
{-# ANN getOutputsForInputs AllowLazyData #-}
getOutputsForInputs :: List (IORef (Maybe' OutputChannel)) -> InputValue -> IO (List (IORef (Maybe' OutputChannel)))
getOutputsForInputs :: List (IORef (Maybe' OutputChannel))
-> InputValue -> IO (List (IORef (Maybe' OutputChannel)))
getOutputsForInputs List (IORef (Maybe' OutputChannel))
acc (OneInput InputChannelIdentifier
ch a
_) = do Maybe (List (IORef (Maybe' OutputChannel)))
res <- BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
-> InputChannelIdentifier
-> IO (Maybe (List (IORef (Maybe' OutputChannel))))
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
output InputChannelIdentifier
ch
                                             case Maybe (List (IORef (Maybe' OutputChannel)))
res of 
                                              Maybe (List (IORef (Maybe' OutputChannel)))
Nothing -> List (IORef (Maybe' OutputChannel))
-> IO (List (IORef (Maybe' OutputChannel)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return List (IORef (Maybe' OutputChannel))
acc
                                              Just List (IORef (Maybe' OutputChannel))
ls -> BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
-> InputChannelIdentifier -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO ()
H.delete BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
output InputChannelIdentifier
ch IO ()
-> IO (List (IORef (Maybe' OutputChannel)))
-> IO (List (IORef (Maybe' OutputChannel)))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> List (IORef (Maybe' OutputChannel))
-> IO (List (IORef (Maybe' OutputChannel)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (List (IORef (Maybe' OutputChannel))
acc List (IORef (Maybe' OutputChannel))
-> List (IORef (Maybe' OutputChannel))
-> List (IORef (Maybe' OutputChannel))
forall a. Eq a => List a -> List a -> List a
`union'` List (IORef (Maybe' OutputChannel))
ls)
getOutputsForInputs List (IORef (Maybe' OutputChannel))
acc (MoreInputs InputChannelIdentifier
ch a
_ InputValue
more) = do Maybe (List (IORef (Maybe' OutputChannel)))
res <- BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
-> InputChannelIdentifier
-> IO (Maybe (List (IORef (Maybe' OutputChannel))))
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
output InputChannelIdentifier
ch
                                                    case Maybe (List (IORef (Maybe' OutputChannel)))
res of 
                                                      Maybe (List (IORef (Maybe' OutputChannel)))
Nothing -> List (IORef (Maybe' OutputChannel))
-> InputValue -> IO (List (IORef (Maybe' OutputChannel)))
getOutputsForInputs List (IORef (Maybe' OutputChannel))
acc InputValue
more
                                                      Just List (IORef (Maybe' OutputChannel))
ls -> BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
-> InputChannelIdentifier -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO ()
H.delete BasicHashTable
  InputChannelIdentifier (List (IORef (Maybe' OutputChannel)))
output InputChannelIdentifier
ch IO ()
-> IO (List (IORef (Maybe' OutputChannel)))
-> IO (List (IORef (Maybe' OutputChannel)))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> List (IORef (Maybe' OutputChannel))
-> InputValue -> IO (List (IORef (Maybe' OutputChannel)))
getOutputsForInputs (List (IORef (Maybe' OutputChannel))
acc List (IORef (Maybe' OutputChannel))
-> List (IORef (Maybe' OutputChannel))
-> List (IORef (Maybe' OutputChannel))
forall a. Eq a => List a -> List a -> List a
`union'` List (IORef (Maybe' OutputChannel))
ls) InputValue
more

{-# ANN eventLoop AllowRecursion #-}
{-# ANN eventLoop AllowLazyData #-}

eventLoop :: IO ()
eventLoop :: IO ()
eventLoop = do ()
_ <- MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
inputSem
               Maybe' InputValue
minp <- MVar (Maybe' InputValue) -> IO (Maybe' InputValue)
forall a. MVar a -> IO a
takeMVar MVar (Maybe' InputValue)
inputValue
               MVar (Maybe' InputValue) -> Maybe' InputValue -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe' InputValue)
inputValue Maybe' InputValue
forall a. Maybe' a
Nothing'
               case Maybe' InputValue
minp of
                 Maybe' InputValue
Nothing' -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"AsyncRattus.Channels.eventLoop unexpected state"
                 Just' InputValue
inp -> do
                   List (IORef (Maybe' OutputChannel))
ls <- List (IORef (Maybe' OutputChannel))
-> InputValue -> IO (List (IORef (Maybe' OutputChannel)))
getOutputsForInputs List (IORef (Maybe' OutputChannel))
forall a. List a
Nil InputValue
inp
                   (IORef (Maybe' OutputChannel) -> IO ())
-> List (IORef (Maybe' OutputChannel)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (InputValue -> IORef (Maybe' OutputChannel) -> IO ()
update InputValue
inp) List (IORef (Maybe' OutputChannel))
ls
               IO ()
eventLoop

-- | In order for 'setOutput' to work, this IO action must be invoked.
startEventLoop :: IO ()
startEventLoop :: IO ()
startEventLoop = do
  Bool
started <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
eventLoopStarted (\Bool
b -> (Bool
True,Bool
b))
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
started) IO ()
eventLoop