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
if not $ M.null queue2 then do
let (k, Reactive task) = M.findMin queue2
modify $ \as -> as { asQueue2 = M.delete k queue2 }
task
loop
else do
final <- gets asFinal
liftIO final
return ()
outVar <- newIORef undefined
let lock = paLock partition
putMVar lock ()
evalStateT loop $ ReactiveState {
asQueue1 = Seq.singleton (task >>= ioReactive . writeIORef outVar),
asQueue2 = M.empty,
asFinal = return ()
}
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) push
unlistener2 <- unlistenize $ runListen l2 (Just nodeRef) 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) $ \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 $ listenTrans ea $ \a -> do
bs <- ioReactive $ readIORef bsRef
ioReactive $ writeIORef bsRef $ bs { bsUpdate = Just a }
when (isNothing (bsUpdate bs)) $ scheduleLast $ 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 . linkedListenValue
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) $ \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
unlistensRef = unsafePerformIO $ newIORef M.empty
gl = do
beaId <- R.collect (\ea nxtID -> ((ea, nxtID), succ nxtID)) (0 :: ID) bea
(l, push, nodeRef) <- ioReactive newEventImpl
unlistener1 <- unlistenize $ linkedListenValue beaId (Just nodeRef) $ \(ea, iD) -> do
let filtered = filterJust $ snapshotWith (\a activeID ->
if activeID == iD
then Just a
else Nothing
) ea (snd <$> beaId)
unlisten2 <- listenTrans filtered $ \a -> do
push a
ioReactive $ unlistenLessThan unlistensRef iD
ioReactive $ modifyIORef unlistensRef (M.insert iD unlisten2)
addCleanup unlistener1 l
switch :: Behavior (Behavior a) -> Reactive (Behavior a)
switch bba = do
ba <- sample bba
za <- sample ba
(ev, push, nodeRef) <- ioReactive newEventLinked
activeIDRef <- ioReactive $ newIORef (0 :: ID)
unlistensRef <- ioReactive $ newIORef M.empty
unlisten1 <- listenValueRaw bba (Just nodeRef) $ \ba -> do
iD <- ioReactive $ do
modifyIORef activeIDRef succ
readIORef activeIDRef
unlisten2 <- listenValueRaw ba (Just nodeRef) $ \a -> do
activeID <- ioReactive $ readIORef activeIDRef
when (activeID == iD) $ do
push a
ioReactive $ unlistenLessThan unlistensRef iD
ioReactive $ modifyIORef unlistensRef (M.insert iD unlisten2)
hold za (finalizeEvent ev unlisten1)
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) $ \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) $ \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) $ \a -> do
alive <- ioReactive $ readIORef aliveRef
when alive $ do
ioReactive $ writeIORef aliveRef False
scheduleLast 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
type ID = Int64
data ReactiveState = ReactiveState {
asQueue1 :: Seq (Reactive ()),
asQueue2 :: Map Int64 (Reactive ()),
asFinal :: IO ()
}
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 :: IO () -> Reactive ()
scheduleLast task = Reactive $ modify $ \as -> as { asFinal = asFinal as >> task }
data Listen a = Listen { runListen_ :: Maybe (IORef Node) -> (a -> Reactive ()) -> Reactive (IO ()) }
runListen :: Listen a -> Maybe (IORef Node) -> (a -> Reactive ()) -> Reactive (IO ())
runListen l mv handle = do
o <- runListen_ l mv 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) -> (a -> Reactive ()) -> Reactive (IO ())
linkedListen ev mMvTarget handle = do
l <- getListen ev
runListen l mMvTarget handle
listenTrans :: Event a -> (a -> Reactive ()) -> Reactive (IO ())
listenTrans ev handle = linkedListen ev Nothing 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) -> (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 ()
linkNode nodeRef iD mvTarget = do
no <- readIORef nodeRef
ensureBiggerThan S.empty mvTarget (noRank no)
modifyIORef nodeRef $ \no ->
no { noListeners = M.insert iD mvTarget (noListeners no) }
ensureBiggerThan :: Set NodeID -> IORef Node -> Int64 -> IO ()
ensureBiggerThan visited nodeRef limit = do
no <- readIORef nodeRef
if noRank no > limit || noID no `S.member` visited then
return ()
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
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 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))
case mMvTarget of
Just mvTarget -> ioReactive $ linkNode nodeRef iD mvTarget
Nothing -> return ()
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 $ do
modifyMVar_ mvObs $ \ob -> return $ ob { obFirings = [] }
let seqa = seq a a
mapM_ ($ seqa) (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 handle -> do
l <- getListen
runListen l mNodeRef (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) -> (a -> Reactive ()) -> Reactive (IO ())
listenValueRaw ba mNodeRef handle = do
a <- sample ba
handle a
linkedListen (underlyingEvent ba) mNodeRef handle
schedulePrioritized :: Maybe (IORef Node)
-> Reactive ()
-> Reactive ()
schedulePrioritized mNodeRef task = do
mNode <- case mNodeRef of
Just nodeRef -> Just <$> ioReactive (readIORef nodeRef)
Nothing -> pure Nothing
let priority = maybe maxBound noRank mNode
Reactive $ modify $ \as -> as {
asQueue2 = M.alter (\mOldTask -> Just $ case mOldTask of
Just oldTask -> oldTask >> task
Nothing -> task) priority (asQueue2 as)
}
tidy :: (Maybe (IORef Node) -> (a -> Reactive ()) -> Reactive (IO ()))
-> Maybe (IORef Node) -> (a -> Reactive ()) -> Reactive (IO ())
tidy listen mNodeRef handle = do
aRef <- ioReactive $ newIORef Nothing
listen mNodeRef $ \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
linkedListenValue :: Behavior a -> Maybe (IORef Node) -> (a -> Reactive ()) -> Reactive (IO ())
linkedListenValue ba = tidy (listenValueRaw ba)
listenValueTrans :: Behavior a -> (a -> Reactive ()) -> Reactive (IO ())
listenValueTrans ba = linkedListenValue ba Nothing
eventify :: (Maybe (IORef Node) -> (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) 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) $ \f -> do
ioReactive $ writeIORef fRef f
a <- ioReactive $ readIORef aRef
push (f a)
unlistener2 <- unlistenize $ runListen l2 (Just nodeRef) $ \a -> do
f <- ioReactive $ readIORef fRef
ioReactive $ writeIORef aRef a
push (f a)
(addCleanup unlistener1 <=< addCleanup unlistener2) l
s = ($) <$> s1 <*> s2
splitLessThan :: Ord k => k -> Map k a -> (Map k a, Map k a)
splitLessThan k m =
let (lt, mEq, gt) = M.splitLookup k m
in (lt, case mEq of
Just eq -> M.insert k eq gt
Nothing -> gt)
unlistenLessThan :: IORef (Map ID (IO ())) -> ID -> IO ()
unlistenLessThan unlistensRef iD = do
uls <- readIORef unlistensRef
let (toDelete, uls') = splitLessThan iD uls
do
writeIORef unlistensRef uls'
forM_ (M.elems toDelete) $ \unl -> unl