module FRP.Sodium.Plain where
import qualified FRP.Sodium.Context as R
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Exception (evaluate)
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Trans
import Data.Int
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as S
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq
import GHC.Exts
import System.Mem.Weak
import System.IO.Unsafe
data Plain
partition :: Partition
partition = unsafePerformIO createPartition
where
createPartition :: IO Partition
createPartition = do
lock <- newEmptyMVar
nextNodeIDRef <- newIORef (NodeID 0)
return $ Partition {
paLock = lock,
paNextNodeID = nextNodeIDRef
}
type Reactive a = R.Reactive Plain a
type Event a = R.Event Plain a
type Behavior a = R.Behavior Plain a
type Behaviour a = R.Behavior Plain a
instance R.Context Plain where
data Reactive Plain a = Reactive (StateT ReactiveState IO a)
data Event Plain a = Event {
getListenRaw :: Reactive (Listen a),
evCacheRef :: IORef (Maybe (Listen a))
}
data Behavior Plain a = Behavior {
underlyingEvent :: Event a,
behSample :: Reactive a
}
sync = sync
ioReactive = ioReactive
newEvent = newEvent
listen = listen
never = never
merge = merge
filterJust = filterJust
hold = hold
changes = changes
values = values
snapshotWith = snapshotWith
switchE = switchE
switch = switch
execute = execute
sample = sample
coalesce = coalesce
once = once
sync :: Reactive a -> IO a
sync task = do
let loop :: StateT ReactiveState IO () = do
queue1 <- gets asQueue1
if not $ Seq.null queue1 then do
let Reactive task = Seq.index queue1 0
modify $ \as -> as { asQueue1 = Seq.drop 1 queue1 }
task
loop
else do
queue2 <- gets asQueue2
mTask <- lift $ popPriorityQueue queue2
case mTask of
Just (Reactive task) -> do
task
loop
Nothing -> do
final <- gets asFinal
if not $ Seq.null final then do
let Reactive task = Seq.index final 0
modify $ \as -> as { asFinal = Seq.drop 1 final }
task
loop
else
return ()
outVar <- newIORef undefined
let lock = paLock partition
putMVar lock ()
q <- newPriorityQueue
evalStateT loop $ ReactiveState {
asQueue1 = Seq.singleton (task >>= ioReactive . writeIORef outVar),
asQueue2 = q,
asFinal = Seq.empty
}
takeMVar lock
readIORef outVar
newEvent :: Reactive (Event a, a -> Reactive ())
newEvent = do
(ev, push, _) <- ioReactive newEventLinked
return (ev, push)
listen :: Event a -> (a -> IO ()) -> Reactive (IO ())
listen ev handle = listenTrans ev (ioReactive . handle)
never :: Event a
never = Event {
getListenRaw = return $ Listen $ \_ _ _ -> return (return ()),
evCacheRef = unsafePerformIO $ newIORef Nothing
}
merge :: Event a -> Event a -> Event a
merge ea eb = Event gl cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
gl = do
l1 <- getListen ea
l2 <- getListen eb
(l, push, nodeRef) <- ioReactive newEventImpl
unlistener1 <- unlistenize $ runListen l1 (Just nodeRef) False push
unlistener2 <- unlistenize $ runListen l2 (Just nodeRef) False push
(addCleanup unlistener1 <=< addCleanup unlistener2) l
filterJust :: Event (Maybe a) -> Event a
filterJust ema = Event gl cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
gl = do
(l', push, nodeRef) <- ioReactive newEventImpl
l <- getListen ema
unlistener <- unlistenize $ runListen l (Just nodeRef) False $ \ma -> case ma of
Just a -> push a
Nothing -> return ()
addCleanup unlistener l'
hold :: a -> Event a -> Reactive (Behavior a)
hold initA ea = do
bsRef <- ioReactive $ newIORef (BehaviorState initA Nothing)
unlistener <- unlistenize $ (linkedListen ea) Nothing False $ \a -> do
bs <- ioReactive $ readIORef bsRef
ioReactive $ writeIORef bsRef $ bs { bsUpdate = Just a }
when (isNothing (bsUpdate bs)) $ scheduleLast $ ioReactive $ do
bs <- readIORef bsRef
let newCurrent = fromJust (bsUpdate bs)
bs' = newCurrent `seq` BehaviorState newCurrent Nothing
evaluate bs'
writeIORef bsRef bs'
let gl = do
l <- getListen ea
addCleanup unlistener l
beh = Behavior {
underlyingEvent = Event gl (evCacheRef ea),
behSample = ioReactive $ bsCurrent <$> readIORef bsRef
}
return beh
changes :: Behavior a -> Event a
changes = underlyingEvent
values :: Behavior a -> Event a
values = eventify . listenValueRaw
snapshotWith :: (a -> b -> c) -> Event a -> Behavior b -> Event c
snapshotWith f ea bb = Event gl cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
gl = do
(l, push, nodeRef) <- ioReactive newEventImpl
unlistener <- unlistenize $ linkedListen ea (Just nodeRef) False $ \a -> do
b <- sample bb
push (f a b)
addCleanup unlistener l
switchE :: Behavior (Event a) -> Event a
switchE bea = Event gl cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
gl = do
(l, push, nodeRef) <- ioReactive newEventImpl
unlisten2Ref <- ioReactive $ newIORef Nothing
let doUnlisten2 = do
mUnlisten2 <- readIORef unlisten2Ref
fromMaybe (return ()) mUnlisten2
unlistener1 <- unlistenize $ do
initEa <- sample bea
(ioReactive . writeIORef unlisten2Ref) =<< (Just <$> linkedListen initEa (Just nodeRef) False push)
unlisten1 <- linkedListen (changes bea) (Just nodeRef) False $ \ea -> scheduleLast $ do
ioReactive doUnlisten2
(ioReactive . writeIORef unlisten2Ref) =<< (Just <$> linkedListen ea (Just nodeRef) True push)
return $ unlisten1 >> doUnlisten2
addCleanup unlistener1 l
switch :: Behavior (Behavior a) -> Reactive (Behavior a)
switch bba = do
ba <- sample bba
za <- sample ba
(ev, push, nodeRef) <- ioReactive newEventLinked
unlisten2Ref <- ioReactive $ newIORef Nothing
let doUnlisten2 = do
mUnlisten2 <- readIORef unlisten2Ref
fromMaybe (return ()) mUnlisten2
unlisten1 <- listenValueRaw bba (Just nodeRef) False $ \ba -> do
ioReactive doUnlisten2
(ioReactive . writeIORef unlisten2Ref . Just) =<< listenValueRaw ba (Just nodeRef) False push
hold za (finalizeEvent ev (unlisten1 >> doUnlisten2))
execute :: Event (Reactive a) -> Event a
execute ev = Event gl cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
gl = do
(l', push, nodeRef) <- ioReactive newEventImpl
unlistener <- unlistenize $ do
l <- getListen ev
runListen l (Just nodeRef) False $ \action -> action >>= push
addCleanup unlistener l'
sample :: Behavior a -> Reactive a
sample = behSample
coalesce :: (a -> a -> a) -> Event a -> Event a
coalesce combine e = Event gl cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
gl = do
l1 <- getListen e
(l, push, nodeRef) <- ioReactive newEventImpl
outRef <- ioReactive $ newIORef Nothing
unlistener <- unlistenize $ runListen l1 (Just nodeRef) False $ \a -> do
first <- isNothing <$> ioReactive (readIORef outRef)
ioReactive $ modifyIORef outRef $ \ma -> Just $ case ma of
Just a0 -> a0 `combine` a
Nothing -> a
when first $ schedulePrioritized (Just nodeRef) $ do
Just out <- ioReactive $ readIORef outRef
ioReactive $ writeIORef outRef Nothing
push out
addCleanup unlistener l
once :: Event a -> Event a
once e = Event gl cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
gl = do
l1 <- getListen e
(l, push, nodeRef) <- ioReactive newEventImpl
aliveRef <- ioReactive $ newIORef True
unlistener <- unlistenize $ do
rec
unlisten <- runListen l1 (Just nodeRef) False $ \a -> do
alive <- ioReactive $ readIORef aliveRef
when alive $ do
ioReactive $ writeIORef aliveRef False
scheduleLast $ ioReactive unlisten
push a
return unlisten
addCleanup unlistener l
newBehavior :: a
-> Reactive (Behavior a, a -> Reactive ())
newBehavior = R.newBehavior
mergeWith :: (a -> a -> a) -> Event a -> Event a -> Event a
mergeWith = R.mergeWith
filterE :: (a -> Bool) -> Event a -> Event a
filterE = R.filterE
snapshot :: Event a -> Behavior b -> Event b
snapshot = R.snapshot
gate :: Event a -> Behavior Bool -> Event a
gate = R.gate
collectE :: (a -> s -> (b, s)) -> s -> Event a -> Reactive (Event b)
collectE = R.collectE
collect :: (a -> s -> (b, s)) -> s -> Behavior a -> Reactive (Behavior b)
collect = R.collect
accumE :: (a -> s -> s) -> s -> Event a -> Reactive (Event s)
accumE = R.accumE
accum :: (a -> s -> s) -> s -> Event a -> Reactive (Behavior s)
accum = R.accum
countE :: Event a -> Reactive (Event Int)
countE = R.countE
count :: Event a -> Reactive (Behavior Int)
count = R.count
class PriorityQueueable k where
priorityOf :: k -> IO Int64
newtype Sequence = Sequence Int64 deriving (Eq, Ord, Enum)
data PriorityQueue k v = PriorityQueue {
pqNextSeq :: IORef Sequence,
pqDirty :: IORef Bool,
pqQueue :: IORef (Map (Int64, Sequence) v),
pqData :: IORef (Map Sequence (k, v))
}
newPriorityQueue :: IO (PriorityQueue k v)
newPriorityQueue =
PriorityQueue <$> newIORef (Sequence 0) <*> newIORef False
<*> newIORef M.empty <*> newIORef M.empty
pushPriorityQueue :: PriorityQueueable k => PriorityQueue k v -> k -> v -> IO ()
pushPriorityQueue pq k v = do
prio <- priorityOf k
seq <- readIORef (pqNextSeq pq)
modifyIORef (pqNextSeq pq) succ
modifyIORef (pqQueue pq) (M.insert (prio, seq) v)
modifyIORef (pqData pq) (M.insert seq (k, v))
dirtyPriorityQueue :: PriorityQueue k v -> IO ()
dirtyPriorityQueue pq = writeIORef (pqDirty pq) True
popPriorityQueue :: PriorityQueueable k => PriorityQueue k v -> IO (Maybe v)
popPriorityQueue pq = do
maybeRegen
q <- readIORef (pqQueue pq)
if M.null q
then return Nothing
else do
let (pseq@(prio, seq), v) = M.findMin q
modifyIORef (pqQueue pq) (M.delete pseq)
modifyIORef (pqData pq) (M.delete seq)
return $ Just v
where
maybeRegen = do
dirty <- readIORef (pqDirty pq)
when dirty $ do
writeIORef (pqDirty pq) False
dat <- readIORef (pqData pq)
writeIORef (pqQueue pq) M.empty
forM_ (M.assocs dat) $ \(seq,(k,v)) -> do
prio <- priorityOf k
modifyIORef (pqQueue pq) (M.insert (prio, seq) v)
type ID = Int64
instance PriorityQueueable (Maybe (IORef Node)) where
priorityOf (Just nodeRef) = noRank <$> readIORef nodeRef
priorityOf Nothing = return maxBound
data ReactiveState = ReactiveState {
asQueue1 :: Seq (Reactive ()),
asQueue2 :: PriorityQueue (Maybe (IORef Node)) (Reactive ()),
asFinal :: Seq (Reactive ())
}
instance Functor (R.Reactive Plain) where
fmap f rm = Reactive (fmap f (unReactive rm))
unReactive :: Reactive a -> StateT ReactiveState IO a
unReactive (Reactive m) = m
instance Applicative (R.Reactive Plain) where
pure a = Reactive $ return a
rf <*> rm = Reactive $ unReactive rf <*> unReactive rm
instance Monad (R.Reactive Plain) where
return a = Reactive $ return a
rma >>= kmb = Reactive $ do
a <- unReactive rma
unReactive (kmb a)
instance MonadFix (R.Reactive Plain) where
mfix f = Reactive $ mfix $ \a -> unReactive (f a)
ioReactive :: IO a -> Reactive a
ioReactive io = Reactive $ liftIO io
newtype NodeID = NodeID Int deriving (Eq, Ord, Enum)
data Partition = Partition {
paLock :: MVar (),
paNextNodeID :: IORef NodeID
}
scheduleEarly :: Reactive () -> Reactive ()
scheduleEarly task = Reactive $ modify $ \as -> as { asQueue1 = asQueue1 as |> task }
scheduleLast :: Reactive () -> Reactive ()
scheduleLast task = Reactive $ modify $ \as -> as { asFinal = asFinal as |> task }
data Listen a = Listen { runListen_ :: Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) }
runListen :: Listen a -> Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())
runListen l mv suppressEarlierFirings handle = do
o <- runListen_ l mv suppressEarlierFirings handle
_ <- ioReactive $ evaluate l
return o
getListen :: Event a -> Reactive (Listen a)
getListen (Event getLRaw cacheRef) = do
mL <- ioReactive $ readIORef cacheRef
case mL of
Just l -> return l
Nothing -> do
l <- getLRaw
ioReactive $ writeIORef cacheRef (Just l)
return l
linkedListen :: Event a -> Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())
linkedListen ev mMvTarget suppressEarlierFirings handle = do
l <- getListen ev
runListen l mMvTarget suppressEarlierFirings handle
listenTrans :: Event a -> (a -> Reactive ()) -> Reactive (IO ())
listenTrans ev handle = linkedListen ev Nothing False handle
data Observer p a = Observer {
obNextID :: ID,
obListeners :: Map ID (a -> Reactive ()),
obFirings :: [a]
}
data Node = Node {
noID :: NodeID,
noRank :: Int64,
noListeners :: Map ID (IORef Node)
}
newNode :: IO (IORef Node)
newNode = do
nodeID <- readIORef (paNextNodeID partition)
modifyIORef (paNextNodeID partition) succ
newIORef (Node nodeID 0 M.empty)
wrap :: (Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> IO (Listen a)
wrap l = return (Listen l)
touch :: Listen a -> IO ()
touch l = evaluate l >> return ()
linkNode :: IORef Node -> ID -> IORef Node -> IO Bool
linkNode nodeRef iD mvTarget = do
no <- readIORef nodeRef
modified <- ensureBiggerThan S.empty mvTarget (noRank no)
modifyIORef nodeRef $ \no ->
no { noListeners = M.insert iD mvTarget (noListeners no) }
return modified
ensureBiggerThan :: Set NodeID -> IORef Node -> Int64 -> IO Bool
ensureBiggerThan visited nodeRef limit = do
no <- readIORef nodeRef
if noRank no > limit || noID no `S.member` visited then
return False
else do
let newSerial = succ limit
modifyIORef nodeRef $ \no -> no { noRank = newSerial }
forM_ (M.elems . noListeners $ no) $ \mvTarget -> do
ensureBiggerThan (S.insert (noID no) visited) mvTarget newSerial
return True
unlinkNode :: IORef Node -> ID -> IO ()
unlinkNode nodeRef iD = do
modifyIORef nodeRef $ \no ->
no { noListeners = M.delete iD (noListeners no) }
newEventImpl :: forall p a . IO (Listen a, a -> Reactive (), IORef Node)
newEventImpl = do
nodeRef <- newNode
mvObs <- newMVar (Observer 0 M.empty [])
cacheRef <- newIORef Nothing
rec
let l mMvTarget suppressEarlierFirings handle = do
(firings, unlisten, iD) <- ioReactive $ modifyMVar mvObs $ \ob -> return $
let iD = obNextID ob
handle' a = handle a >> ioReactive (touch listen)
ob' = ob { obNextID = succ iD,
obListeners = M.insert iD handle' (obListeners ob) }
unlisten = do
modifyMVar_ mvObs $ \ob -> return $ ob {
obListeners = M.delete iD (obListeners ob)
}
unlinkNode nodeRef iD
return ()
in (ob', (reverse . obFirings $ ob, unlisten, iD))
modified <- case mMvTarget of
Just mvTarget -> ioReactive $ linkNode nodeRef iD mvTarget
Nothing -> return False
when modified $ dirtyPrioritized
unless suppressEarlierFirings $ mapM_ handle firings
return unlisten
listen <- wrap l
let push a = do
ob <- ioReactive $ modifyMVar mvObs $ \ob -> return $
(ob { obFirings = a : obFirings ob }, ob)
when (null (obFirings ob)) $ scheduleLast $ ioReactive $ do
modifyMVar_ mvObs $ \ob -> return $ ob { obFirings = [] }
ioReactive $ evaluate a
mapM_ ($ a) (M.elems . obListeners $ ob)
return (listen, push, nodeRef)
newEventLinked :: IO (Event a, a -> Reactive (), IORef Node)
newEventLinked = do
(listen, push, nodeRef) <- newEventImpl
cacheRef <- newIORef Nothing
let ev = Event {
getListenRaw = return listen,
evCacheRef = cacheRef
}
return (ev, push, nodeRef)
instance Functor (R.Event Plain) where
f `fmap` Event getListen cacheRef = Event getListen' cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
getListen' = do
return $ Listen $ \mNodeRef suppressEarlierFirings handle -> do
l <- getListen
runListen l mNodeRef suppressEarlierFirings (handle . f)
instance Functor (R.Behavior Plain) where
f `fmap` Behavior underlyingEvent sample =
Behavior (f `fmap` underlyingEvent) (f `fmap` sample)
constant :: a -> Behavior a
constant a = Behavior {
underlyingEvent = never,
behSample = return a
}
data BehaviorState a = BehaviorState {
bsCurrent :: a,
bsUpdate :: Maybe a
}
finalizeEvent :: Event a -> IO () -> Event a
finalizeEvent ea unlisten = Event gl (evCacheRef ea)
where
gl = do
l <- getListen ea
ioReactive $ finalizeListen l unlisten
finalizeListen :: Listen a -> IO () -> IO (Listen a)
finalizeListen l unlisten = do
addFinalizer l unlisten
return l
newtype Unlistener = Unlistener (MVar (Maybe (IO ())))
unlistenize :: Reactive (IO ()) -> Reactive Unlistener
unlistenize doListen = do
unlistener@(Unlistener ref) <- newUnlistener
scheduleEarly $ do
mOldUnlisten <- ioReactive $ takeMVar ref
case mOldUnlisten of
Just _ -> do
unlisten <- doListen
ioReactive $ putMVar ref (Just unlisten)
Nothing -> ioReactive $ putMVar ref mOldUnlisten
return unlistener
where
newUnlistener :: Reactive Unlistener
newUnlistener = Unlistener <$> ioReactive (newMVar (Just $ return ()))
addCleanup :: Unlistener -> Listen a -> Reactive (Listen a)
addCleanup (Unlistener ref) l = ioReactive $ finalizeListen l $ do
mUnlisten <- takeMVar ref
fromMaybe (return ()) mUnlisten
putMVar ref Nothing
listenValueRaw :: Behavior a -> Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())
listenValueRaw ba = lastFiringOnly $ \mNodeRef suppressEarlierFirings handle -> do
a <- sample ba
handle a
linkedListen (underlyingEvent ba) mNodeRef suppressEarlierFirings handle
schedulePrioritized :: Maybe (IORef Node)
-> Reactive ()
-> Reactive ()
schedulePrioritized mNodeRef task = Reactive $ do
q <- gets asQueue2
lift $ pushPriorityQueue q mNodeRef task
dirtyPrioritized :: Reactive ()
dirtyPrioritized = Reactive $ do
q <- gets asQueue2
lift $ dirtyPriorityQueue q
lastFiringOnly :: (Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()))
-> Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())
lastFiringOnly listen mNodeRef suppressEarlierFirings handle = do
aRef <- ioReactive $ newIORef Nothing
listen mNodeRef suppressEarlierFirings $ \a -> do
ma <- ioReactive $ readIORef aRef
ioReactive $ writeIORef aRef (Just a)
when (isNothing ma) $ schedulePrioritized mNodeRef $ do
Just a <- ioReactive $ readIORef aRef
ioReactive $ writeIORef aRef Nothing
handle a
listenValueTrans :: Behavior a -> (a -> Reactive ()) -> Reactive (IO ())
listenValueTrans ba = listenValueRaw ba Nothing False
eventify :: (Maybe (IORef Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ())) -> Event a
eventify listen = Event gl cacheRef
where
cacheRef = unsafePerformIO $ newIORef Nothing
gl = do
(l, push, nodeRef) <- ioReactive newEventImpl
unlistener <- unlistenize $ listen (Just nodeRef) False push
addCleanup unlistener l
instance Applicative (R.Behavior Plain) where
pure = constant
Behavior u1 s1 <*> Behavior u2 s2 = Behavior u s
where
cacheRef = unsafePerformIO $ newIORef Nothing
u = Event gl cacheRef
gl = do
fRef <- ioReactive . newIORef =<< s1
aRef <- ioReactive . newIORef =<< s2
l1 <- getListen u1
l2 <- getListen u2
(l, push, nodeRef) <- ioReactive newEventImpl
unlistener1 <- unlistenize $ runListen l1 (Just nodeRef) False $ \f -> do
ioReactive $ writeIORef fRef f
a <- ioReactive $ readIORef aRef
push (f a)
unlistener2 <- unlistenize $ runListen l2 (Just nodeRef) False $ \a -> do
f <- ioReactive $ readIORef fRef
ioReactive $ writeIORef aRef a
push (f a)
(addCleanup unlistener1 <=< addCleanup unlistener2) l
s = ($) <$> s1 <*> s2