module Control.MonadicFRP(
Event(..),
EvReqs,
EvOccs,
React(..),
exper,
interpret,
Sig(..),
ISig(..),
interpretSig,
first,
parR,
update,
repeat,
spawn,
map,
imap,
scanl,
iscanl,
break,
ibreak,
foldl,
ifoldl,
find,
at,
until,
iuntil,
(<^>),
pairs,
bothStart,
indexBy,
iindexBy,
emitAll,
emit,
always,
waitFor,
hold,
res,
ires,
cur,
icur,
done,
done',
cons,
parList,
iparList,
memo,
memoSig,
imemoSig)
where
import Data.Set hiding (map,filter,foldl)
import qualified Data.Set as Set
import Prelude hiding (null,map,filter,filter,until,repeat,cycle,scanl,span,break,either,foldl)
import Data.Maybe
import Control.Monad
import System.IO.Unsafe
import Data.IORef
import qualified Data.Map as Map
import System.Mem.Weak
data Event a = Request | Occurred a deriving Show
type EvReqs e = Set e
type EvOccs e = Set e
data React e alpha
= Done alpha
| Await (EvReqs e) (EvOccs e -> React e alpha)
exper :: e -> React e e
exper a = Await (singleton a) (Done . head . elems)
interpret :: Monad m => (EvReqs e -> m (EvOccs e))
-> React e a -> m a
interpret p (Done a) = return a
interpret p (Await e c) = p e >>= interpret p . c
newtype Sig e a b = Sig (React e (ISig e a b))
data ISig e a b = a :| (Sig e a b)
| End b
interpretSig :: Monad m => (EvReqs e -> m (EvOccs e))
-> (a -> m r)
-> Sig e a b -> m b
interpretSig p d (Sig s) =
do l <- interpret p s
case l of
h :| t -> d h >> interpretSig p d t
End a -> return a
instance Monad (React e) where
return = Done
(Await e c) >>= f = Await e ((>>= f) . c)
(Done v) >>= f = f v
first :: Ord e => React e a -> React e b ->
React e ( React e a , React e b)
first l r = case (l,r) of
(Await el _, Await er _) ->
let e = el `union` er
c b = first (update l b) (update r b)
in Await e c
_ -> Done (l,r)
parR = first
update :: Ord e => React e a -> EvOccs e -> React e a
update (Await e c) b | b' /= empty = c b'
where b' = b `filterOccs` e
update r _ = r
filterOccs :: Ord e => EvOccs e -> EvReqs e -> EvOccs e
filterOccs = intersection
instance Ord a => Ord (Event a) where
(Occurred a) `compare` (Occurred b) = a `compare` b
Request `compare` _ = EQ
_ `compare` Request = EQ
instance Ord a => Eq (Event a) where
a == b = a `compare` b == EQ
instance Functor (Sig e a) where
fmap = liftM
instance Monad (Sig e a) where
return a = emitAll (End a)
(Sig l) >>= f = Sig (l >>= ib)
where ib (h :| t) = return (h :| (t >>= f))
ib (End a) = let Sig x = f a in x
instance Monad (ISig e a) where
return = End
(End a) >>= f = f a
(h :| t) >>= f = h :| (t >>= emitAll . f)
repeat x = xs where xs = Sig (fmap (:| xs) x )
spawn (Sig l) = repeat l
map f (Sig l) = Sig (fmap (imap f) l)
imap f (h :| t) = f h :| map f t
imap f (End a) = End a
scanl f i l = emitAll (iscanl f i l)
iscanl f i (Sig l) = i :| (waitFor l >>= lsl)
where lsl (h :| t) = scanl f (f i h) t
lsl (End a) = return a
break f (Sig l) = Sig (fmap (ibreak f) l)
ibreak f (h :| t) | f h = return (h :| t)
| otherwise = h :| break f t
ibreak f (End a) = return (End a)
foldl :: (a -> b -> a) -> a -> Sig e b r -> React e a
foldl f i (Sig l) = l >>= ifoldl f i
ifoldl f i (h :| t) = foldl f (f i h) t
ifoldl f i (End a) = return i
find f l = fmap icur (res (break f l))
l `at` a = fmap (cur . fst) (res (l `until` a))
until (Sig l) a = waitFor (first l a) >>= un where
un (Done l,a) = do (l,a) <- emitAll (l `iuntil` a)
return (emitAll l, a)
un (l,a) = return (Sig l,a)
iuntil (End l) a = End (End l,a)
iuntil (h :| Sig t) a = h :| Sig (fmap cont (first t a))
where cont (Done l,a) = l `iuntil` a
cont (t,Done a) = End (h :| Sig t, Done a)
l <^> r = do (l,r) <- waitFor (bothStart l r)
emitAll (imap (\(f,a) -> f a) (pairs l r))
bothStart l (Sig r) = do (Sig l,r) <- res ( l `until` r)
(Sig r,l) <- res (Sig r `until` l)
return (done' l, done' r)
pairs (End a) b = End (End a,b)
pairs a (End b) = End (a,End b)
pairs (hl :| Sig tl) (hr :| Sig tr) = (hl,hr) :| tail
where tail = Sig (fmap cont (first tl tr))
cont (tl,tr) = pairs (lup hl tl) (lup hr tr)
lup _ (Done l) = l; lup h t = h :| Sig t
indexBy :: (Show a, Ord e) => Sig e a l -> Sig e b r
-> Sig e a ()
l `indexBy` (Sig r) =
do (Sig l,r) <- waitFor (res (l `until` r))
case (l,r) of
(_,Done (End _)) -> return ()
(Done l, r) -> l `iindexBy` Sig r
(l,Done (_:| r)) -> Sig l `indexBy` r
l `iindexBy` (Sig r) =
do (l,r) <- waitFor (ires (l `iuntil` r))
case (l,r) of
(hl :| tl, Done (hr :| tr)) -> emit hl >> (hl :| tl) `iindexBy` tr
_ -> return ()
emitAll = Sig . Done
emit a = emitAll (a :| return ())
always a = emit a >> hold
waitFor a = Sig (fmap End a)
hold = waitFor never where never = Await empty undefined
res (Sig l) = l >>= ires
ires (_ :| t) = res t; ires (End a) = Done a
instance Functor (React e) where
fmap f a = a >>= return . f
done (Done a) = Just a ; done _ = Nothing
cur (Sig (Done (h :| _))) = Just h ; cur _ = Nothing
icur (h :| t) = Just h
icur (End _) = Nothing
done' = fromJust . done
cons :: Ord e => ISig e a l -> ISig e [a] r
-> ISig e [a] ()
cons h t = do (h,t) <- imap (uncurry (:)) (pairs h t)
imap (: []) h
t
return ()
parList x = emitAll (iparList x)
iparList :: Ord e => Sig e (ISig e a l) r -> ISig e [a] ()
iparList l = rl ([] :| hold) l >> return () where
rl t (Sig es) = do (t,es) <- t `iuntil` es
case es of
Done (e :| es) -> rl (cons e t) es
_ -> t
memo :: Ord e => React e a -> React e a
memo (Await r c) = Await r (memof (memo . c))
memo (Done a) = Done a
memoSig :: Ord e => Sig e a b -> Sig e a b
memoSig (Sig l) = Sig (memo (fmap imemoSig l))
imemoSig (h :| t) = h :| memoSig t
imemoSig (End a) = End a
memof :: Ord a => (a -> b) -> (a -> b)
memof f = (\x -> unsafePerformIO (lookup x))
where ref = unsafePerformIO (newIORef (f,Map.empty))
cleanup k = do (_,m) <- readIORef ref
let m' = Map.delete k m
writeIORef ref (f,m')
addKey k v = do w <- mkWeak k v (Just (cleanup k))
(_,m) <- readIORef ref
let m' = Map.insert k w m
writeIORef ref (f,m')
lookup k = do (_,m) <- readIORef ref
let w = Map.lookup k m
if isJust w
then do w' <- deRefWeak (fromJust w)
if isJust w'
then return (fromJust w')
else compute k
else compute k
compute k = do addKey k v
return v
where v = f k