{-# 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.MVar
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

{-# ANN module AsyncRattus #-}
{-# ANN module AllowLazyData #-}

instance Producer p a => Producer (O p) a where
  getCurrent :: O p -> Maybe' a
getCurrent O p
_ = 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 = 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 = forall p a. Producer p a => p -> Maybe' a
getCurrent (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 = forall p a b.
Producer p a =>
p -> (forall q. Producer q a => O q -> b) -> b
getNext (forall a. Box a -> a
unbox Box p
p) forall q. Producer q a => O q -> b
cb


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


{-# NOINLINE input #-}
input :: MVar InputValue
input :: MVar InputValue
input = forall a. IO a -> a
unsafePerformIO 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 = forall a. IO a -> a
unsafePerformIO (forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new)

{-# NOINLINE eventLoopStarted #-}
eventLoopStarted :: IORef Bool
eventLoopStarted :: IORef Bool
eventLoopStarted = forall a. IO a -> a
unsafePerformIO (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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef InputChannelIdentifier
nextFreshChannel (\ InputChannelIdentifier
x -> (InputChannelIdentifier
x forall a. Num a => a -> a -> a
- InputChannelIdentifier
1, InputChannelIdentifier
x))
              forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a. a -> Box a
box (forall a. Clock -> (InputValue -> a) -> O a
Delay (InputChannelIdentifier -> Clock
singletonClock InputChannelIdentifier
ch) (\ (InputValue InputChannelIdentifier
_ a
v) -> forall a b. a -> b
unsafeCoerce a
v)))
                       forall a b. a -> b -> a :* b
:* \ a
x -> forall a. MVar a -> a -> IO ()
putMVar MVar InputValue
input (forall a. InputChannelIdentifier -> a -> InputValue
InputValue InputChannelIdentifier
ch a
x))

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 <- forall a. a -> IO (IORef a)
newIORef (forall a. a -> Maybe' a
Just' (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 = (forall a. a -> Maybe a
Just (IORef (Maybe' OutputChannel)
ref forall a. a -> List a -> List a
:! forall a. List a
Nil),())
      upd (Just List (IORef (Maybe' OutputChannel))
ls) = (forall a. a -> Maybe a
Just (IORef (Maybe' OutputChannel)
ref 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. MVar a -> a -> IO ()
putMVar MVar InputValue
input (forall a. InputChannelIdentifier -> a -> InputValue
InputValue InputChannelIdentifier
ch ()))
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (IORef (Maybe' OutputChannel)
ref forall a. a -> List a -> List a
:! forall a. List a
Nil),())
      upd' InputChannelIdentifier
_ (Just List (IORef (Maybe' OutputChannel))
ls) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (IORef (Maybe' OutputChannel)
ref 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 forall a. Ord a => a -> a -> Bool
> InputChannelIdentifier
0 then
          IO ()
pre forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
  forall a. (a -> InputChannelIdentifier -> a) -> a -> Clock -> a
IntSet.foldl' IO () -> InputChannelIdentifier -> IO ()
run (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (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 forall p a. Producer p a => p -> Maybe' a
getCurrent p
sig of
    Just' a
cur' -> a -> IO ()
cb a
cur'
    Maybe' a
Nothing' -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall p a b.
Producer p a =>
p -> (forall q. Producer q a => O q -> b) -> b
getNext p
sig (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) <- forall a. IO (Box (O a) :* (a -> IO ()))
getInput
               forall p a. Producer p a => p -> (a -> IO ()) -> IO ()
setOutput p
p a -> IO ()
cb
               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 = forall a. a -> Box a
Box (forall a. Clock -> (InputValue -> a) -> O a
Delay (InputChannelIdentifier -> Clock
singletonClock (InputChannelIdentifier
d 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 <- forall a. IORef a -> IO a
readIORef IORef (Maybe' OutputChannel)
ref
  case Maybe' OutputChannel
mout of
    Maybe' OutputChannel
Nothing' -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just' (OutputChannel (Delay Clock
_ InputValue -> p
sigf) a -> IO ()
cb) -> do
      forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe' OutputChannel)
ref forall a. Maybe' a
Nothing'
      let new :: p
new = InputValue -> p
sigf InputValue
inp
      case forall p a. Producer p a => p -> Maybe' a
getCurrent p
new of
        Just' a
w' -> a -> IO ()
cb a
w'
        Maybe' a
Nothing' -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      forall p a b.
Producer p a =>
p -> (forall q. Producer q a => O q -> b) -> b
getNext p
new (forall p a. Producer p a => (a -> IO ()) -> O p -> IO ()
setOutput' a -> IO ()
cb)


{-# ANN eventLoop NotAsyncRattus #-}

eventLoop :: IO ()
eventLoop :: IO ()
eventLoop = do inp :: InputValue
inp@(InputValue InputChannelIdentifier
ch a
_) <- forall a. MVar a -> IO a
takeMVar MVar InputValue
input
               Maybe (List (IORef (Maybe' OutputChannel)))
res <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 Just List (IORef (Maybe' OutputChannel))
ls -> do
                   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
                   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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
eventLoopStarted (\Bool
b -> (Bool
True,Bool
b))
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
started) IO ()
eventLoop