{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module AsyncRattus.InternalPrimitives where
import Prelude hiding (Left, Right)
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.IORef
import Control.Concurrent.MVar
import System.IO.Unsafe
import System.Mem.Weak
import Control.Monad
type InputChannelIdentifier = Int
type Clock = IntSet
singletonClock :: InputChannelIdentifier -> Clock
singletonClock :: InputChannelIdentifier -> Clock
singletonClock = InputChannelIdentifier -> Clock
IntSet.singleton
emptyClock :: Clock
emptyClock :: Clock
emptyClock = Clock
IntSet.empty
clockUnion :: Clock -> Clock -> Clock
clockUnion :: Clock -> Clock -> Clock
clockUnion = Clock -> Clock -> Clock
IntSet.union
channelMember :: InputChannelIdentifier -> Clock -> Bool
channelMember :: InputChannelIdentifier -> Clock -> Bool
channelMember = InputChannelIdentifier -> Clock -> Bool
IntSet.member
data InputValue where
OneInput :: !InputChannelIdentifier -> !a -> InputValue
MoreInputs :: !InputChannelIdentifier -> !a -> !InputValue -> InputValue
inputInClock :: InputValue -> Clock -> Bool
inputInClock :: InputValue -> Clock -> Bool
inputInClock (OneInput InputChannelIdentifier
ch a
_) Clock
cl = InputChannelIdentifier -> Clock -> Bool
channelMember InputChannelIdentifier
ch Clock
cl
inputInClock (MoreInputs InputChannelIdentifier
ch a
_ InputValue
more) Clock
cl = InputChannelIdentifier -> Clock -> Bool
channelMember InputChannelIdentifier
ch Clock
cl Bool -> Bool -> Bool
|| InputValue -> Clock -> Bool
inputInClock InputValue
more Clock
cl
data O a = Delay !Clock (InputValue -> a)
data Select a b = Fst !a !(O b) | Snd !(O a) !b | Both !a !b
asyncRattusError :: [Char] -> a
asyncRattusError [Char]
pr = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
pr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": Did you forget to mark this as Async Rattus code?")
{-# INLINE [1] delay #-}
delay :: a -> O a
delay :: forall a. a -> O a
delay a
_ = [Char] -> O a
forall {a}. [Char] -> a
asyncRattusError [Char]
"delay"
extractClock :: O a -> Clock
(Delay Clock
cl InputValue -> a
_) = Clock
cl
{-# INLINE [1] adv' #-}
adv' :: O a -> InputValue -> a
adv' :: forall a. O a -> InputValue -> a
adv' (Delay Clock
_ InputValue -> a
f) InputValue
inp = InputValue -> a
f InputValue
inp
{-# INLINE [1] adv #-}
adv :: O a -> a
adv :: forall a. O a -> a
adv O a
_ = [Char] -> a
forall {a}. [Char] -> a
asyncRattusError [Char]
"adv"
{-# INLINE [1] select #-}
select :: O a -> O b -> Select a b
select :: forall a b. O a -> O b -> Select a b
select O a
_ O b
_ = [Char] -> Select a b
forall {a}. [Char] -> a
asyncRattusError [Char]
"select"
select' :: O a -> O b -> InputValue -> Select a b
select' :: forall a b. O a -> O b -> InputValue -> Select a b
select' a :: O a
a@(Delay Clock
clA InputValue -> a
inpFA) b :: O b
b@(Delay Clock
clB InputValue -> b
inpFB) InputValue
inp
= if InputValue -> Clock -> Bool
inputInClock InputValue
inp Clock
clA then
if InputValue -> Clock -> Bool
inputInClock InputValue
inp Clock
clB then a -> b -> Select a b
forall a b. a -> b -> Select a b
Both (InputValue -> a
inpFA InputValue
inp) (InputValue -> b
inpFB InputValue
inp)
else a -> O b -> Select a b
forall a b. a -> O b -> Select a b
Fst (InputValue -> a
inpFA InputValue
inp) O b
b
else O a -> b -> Select a b
forall a b. O a -> b -> Select a b
Snd O a
a (InputValue -> b
inpFB InputValue
inp)
never :: O a
never :: forall a. O a
never = Clock -> (InputValue -> a) -> O a
forall a. Clock -> (InputValue -> a) -> O a
Delay Clock
emptyClock ([Char] -> InputValue -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Trying to adv on the 'never' delayed computation")
class Stable a where
data Box a = Box a
{-# INLINE [1] box #-}
box :: a -> Box a
box :: forall a. a -> Box a
box a
x = a -> Box a
forall a. a -> Box a
Box a
x
{-# INLINE [1] unbox #-}
unbox :: Box a -> a
unbox :: forall a. Box a -> a
unbox (Box a
d) = a
d
defaultPromote :: Continuous a => a -> Box a
defaultPromote :: forall a. Continuous a => a -> Box a
defaultPromote a
x = IO (Box a) -> Box a
forall a. IO a -> a
unsafePerformIO (IO (Box a) -> Box a) -> IO (Box a) -> Box a
forall a b. (a -> b) -> a -> b
$
do IORef a
r <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
x
Weak (IORef a)
r' <- IORef a -> IO () -> IO (Weak (IORef a))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef a
r (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
IORef [ContinuousData]
-> ([ContinuousData] -> [ContinuousData]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [ContinuousData]
promoteStore (Weak (IORef a) -> ContinuousData
forall a. Continuous a => Weak (IORef a) -> ContinuousData
ContinuousData Weak (IORef a)
r' ContinuousData -> [ContinuousData] -> [ContinuousData]
forall a. a -> [a] -> [a]
:)
Box a -> IO (Box a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Box a
forall a. a -> Box a
Box (IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
r))
class Continuous p where
progressAndNext :: InputValue -> p -> (p , Clock)
progressInternal :: InputValue -> p -> p
nextProgress :: p -> Clock
promoteInternal :: p -> Box p
promoteInternal = p -> Box p
forall a. Continuous a => a -> Box a
defaultPromote
instance {-# OVERLAPPABLE #-} Stable a => Continuous a where
progressAndNext :: InputValue -> a -> (a, Clock)
progressAndNext InputValue
_ a
x = (a
x , Clock
emptyClock)
progressInternal :: InputValue -> a -> a
progressInternal InputValue
_ a
x = a
x
nextProgress :: a -> Clock
nextProgress a
_ = Clock
emptyClock
promoteInternal :: a -> Box a
promoteInternal = a -> Box a
forall a. a -> Box a
Box
data ContinuousData where
ContinuousData :: Continuous a => !(Weak (IORef a)) -> ContinuousData
{-# NOINLINE promoteStore #-}
promoteStore :: IORef [ContinuousData]
promoteStore :: IORef [ContinuousData]
promoteStore = IO (IORef [ContinuousData]) -> IORef [ContinuousData]
forall a. IO a -> a
unsafePerformIO ([ContinuousData] -> IO (IORef [ContinuousData])
forall a. a -> IO (IORef a)
newIORef [])
{-# NOINLINE progressPromoteStoreMutex #-}
progressPromoteStoreMutex :: MVar ()
progressPromoteStoreMutex :: MVar ()
progressPromoteStoreMutex = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (() -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ())
progressPromoteStoreAtomic :: InputValue -> IO ()
progressPromoteStoreAtomic :: InputValue -> IO ()
progressPromoteStoreAtomic InputValue
inp = do
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
progressPromoteStoreMutex
InputValue -> IO ()
progressPromoteStore InputValue
inp
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
progressPromoteStoreMutex ()
progressPromoteStore :: InputValue -> IO ()
progressPromoteStore :: InputValue -> IO ()
progressPromoteStore InputValue
inp = do
[ContinuousData]
xs <- IORef [ContinuousData]
-> ([ContinuousData] -> ([ContinuousData], [ContinuousData]))
-> IO [ContinuousData]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ContinuousData]
promoteStore (\[ContinuousData]
x -> ([],[ContinuousData]
x))
[ContinuousData]
xs' <- (ContinuousData -> IO Bool)
-> [ContinuousData] -> IO [ContinuousData]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ContinuousData -> IO Bool
run [ContinuousData]
xs
IORef [ContinuousData]
-> ([ContinuousData] -> ([ContinuousData], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ContinuousData]
promoteStore (\[ContinuousData]
x -> ([ContinuousData]
x [ContinuousData] -> [ContinuousData] -> [ContinuousData]
forall a. [a] -> [a] -> [a]
++ [ContinuousData]
xs',()))
where run :: ContinuousData -> IO Bool
run (ContinuousData Weak (IORef a)
x) = do
Maybe (IORef a)
d <- Weak (IORef a) -> IO (Maybe (IORef a))
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (IORef a)
x
case Maybe (IORef a)
d of
Maybe (IORef a)
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just IORef a
x -> IORef a -> (a -> a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef a
x (InputValue -> a -> a
forall p. Continuous p => InputValue -> p -> p
progressInternal InputValue
inp) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
promote :: Continuous a => a -> Box a
promote :: forall a. Continuous a => a -> Box a
promote a
x = a -> Box a
forall a. Continuous a => a -> Box a
promoteInternal a
x
newtype Chan a = Chan InputChannelIdentifier
{-# RULES
"unbox/box" forall x. unbox (box x) = x
#-}
{-# RULES
"box/unbox" forall x. box (unbox x) = x
#-}