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

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

-- | 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 (..),
) where

import AsyncRattus.InternalPrimitives

import AsyncRattus.Plugin.Annotation
import AsyncRattus.Strict
import Control.Concurrent.Chan
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

-- | 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


{-# 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 input #-}
input :: Chan InputValue
input :: Chan InputValue
input = IO (Chan InputValue) -> Chan InputValue
forall a. IO a -> a
unsafePerformIO IO (Chan InputValue)
forall a. IO (Chan a)
newChan

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) (\ (InputValue InputChannelIdentifier
_ a
v) -> a -> a
forall a b. a -> b
unsafeCoerce a
v)))
                       Box (O a) -> (a -> IO ()) -> Box (O a) :* (a -> IO ())
forall a b. a -> b -> a :* b
:* \ a
x -> Chan InputValue -> InputValue -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan InputValue
input (InputChannelIdentifier -> a -> InputValue
forall a. InputChannelIdentifier -> a -> InputValue
InputValue InputChannelIdentifier
ch a
x))

{-# 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
>> Chan InputValue -> InputValue -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan InputValue
input (InputChannelIdentifier -> () -> InputValue
forall a. InputChannelIdentifier -> a -> InputValue
InputValue 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 eventLoop AllowRecursion #-}
{-# ANN eventLoop AllowLazyData #-}

eventLoop :: IO ()
eventLoop :: IO ()
eventLoop = do inp :: InputValue
inp@(InputValue InputChannelIdentifier
ch a
_) <- Chan InputValue -> IO InputValue
forall a. Chan a -> IO a
readChan Chan InputValue
input
               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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 Just List (IORef (Maybe' OutputChannel))
ls -> do
                   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
                   (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