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

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

module WidgetRattus.Channels (
  timer,
  Producer (..),
  chan,
  C (..),
  delayC,
  wait,
  Chan
) where
import WidgetRattus.InternalPrimitives

import WidgetRattus.Plugin.Annotation
import WidgetRattus.Strict
import System.IO.Unsafe
import Data.IORef
import Unsafe.Coerce

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



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

-- | @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
_ -> ()))