module Data.Reactive (
module IO.Time,
Event,i'event,headE,Reactive(..),
atTimes,mkEvent,
withTime,times,times',
mapFutures,
(//),(<|*>),(<*|>),
groupE,mask,
realize,realtime,realizeRT,eventMay,event,react,react2,react3,
Future,i'future,l'time,l'value,futureIO,
) where
import Definitive
import Control.Concurrent
import Data.TimeVal
import System.IO.Unsafe (unsafeInterleaveIO)
import IO.Time
infixr 5 :-:
data Many a = a:-:Many a
deriving (Show,Eq,Ord)
instance Unit Many where pure a = a:-:freezed
instance Functor Many where map f (a:-:as) = f a:-:map f as
instance Stream a (Many a) where
cons = (:-:)
uncons ~(a:-:as) = Just (a,as)
instance Lens1 a a (Many a) (Many a) where
l'1 = lens (\ ~(a:-:_) -> a) (\ ~(_:-:as) a -> a:-:as)
finite :: [a] -> Many a
finite = (++freezed)
newtype Event t a = Event { getEvent :: (Many:.:Future t) a }
deriving (Unit,Functor)
instance Ord t => Foldable (Event t) where
fold = fold' . yb i'event
where fold' ~(a:-:as) | a^.l'time == maxBound = zero
| otherwise = a^.l'value + fold' as
instance Ord t => Traversable (Event t) where
sequence e = sequence' (e^..i'event)^.mapping i'event
where sequence' ~(a:-:as) | a^.l'time == maxBound = pure freezed
| otherwise = (:-:)<$>sequence a<*>sequence' as
data Reactive t a = Reactive a (Event t a)
instance Ord t => Unit (Reactive t) where
pure a = Reactive a zero
instance Functor (Reactive t) where
map f (Reactive a e) = Reactive (f a) (map f e)
instance Ord t => Applicative (Reactive t) where
Reactive f fs <*> Reactive x xs = Reactive (f x) (cons (pure f) fs<*>cons (pure x) xs)
instance Stream (Future t a) (Event t a) where
cons a = i'event %%~ cons a
uncons e = map (l'2 %~ (^.i'event)) (uncons (e^..i'event))
instance (Ord t,Show t,Show a) => Show (Event t a) where show = show . yb i'event
instance Ord t => Semigroup (Event t a) where
(+) = add^.(i'event<.>i'event<.>i'event)
where add ~(x:-:xt) ~(y:-:yt) = a :-: zs
where (a,b,sw) = inOrder x y
zs | b==maxBound = if sw then xt else yt
| sw = add xt (y:-:yt)
| otherwise = add (x:-:xt) yt
instance Ord t => Monoid (Event t a) where
zero = pure maxBound^.i'event
instance Ord t => Applicative (Event t) where
fe@(yb i'event -> ff:-:_) <*> xe@(yb i'event -> fx:-:_) =
ste & traverse (by state) & yb state & map snd & \st ->
br (ff^.l'time + fx^.l'time) (st (ff^.l'value,fx^.l'value))
where ste = map (\f (_,x) -> ((f,x),f x)) fe
+ map (\x (f,_) -> ((f,x),f x)) xe
br t (yb i'event -> e) = (map (l'time %- t) b ++ a)^.i'event
where (b,a) = span (\f -> f^.l'time<t) e
instance Ord t => Monad (Event t) where
join m = m & (i'event %%~ merge . trace "merge" . map2 (trace "map2" . yb i'event . trace "map"))
where
merge (xs:-:ys:-:t) = trace "xi" (xi ++ merge ((ys&l'value%~add xe) :-: t) & l'1.l'time %~ (+tx))
where add = warp2 i'event (+)
(tx,~(xi,xe)) = xs^..i'future & l'2%~(break (ltFut ys).trace "break")
type EventRep t a = Many (Future t a)
i'event :: Iso (Event t a) (Event t' b) (EventRep t a) (EventRep t' b)
i'event = i'Compose.iso Event getEvent
atTimes :: [t] -> Event t ()
atTimes ts = finite (ts <&> \t -> (pure t,())^.i'future)^.i'event
mkEvent :: [(t,a)] -> Event t a
mkEvent as = finite (as <&> by i'future . (l'1 %~ pure))^.i'event
futures :: Ord t => Event t a -> Event t (Future t a)
futures = map (^.i'future) . withTime
(//) :: Ord t => Event t a -> Event t b -> Event t (a, Event t b)
ea // eb = mapAccum_ fun (futures ea) (eb^..i'event)
where fun a bs = (ys,(a^.l'value,finite xs^.i'event))
where (xs,ys) = span (flip ltFut a) bs
infixl 1 //
(<*|>) :: Ord t => Event t (a -> b) -> Reactive t a -> Event t b
ef <*|> Reactive a ea = (traverse tr (ef // ea) ^.. state <&> snd) a
where tr (f,as) = traverse_ put as >> f<$>get
infixl 1 <*|>
(<|*>) :: Ord t => Reactive t (a -> b) -> Event t a -> Event t b
f <|*> a = (&)<$>a<*|>f
infixr 1 <|*>
groupE :: (Eq a, Ord t) => Event t a -> Event t (Event t a)
groupE = i'event %%~ group_
where group_ fs = (f & l'value %- (finite xs^.i'event))
:-: (z & l'time %~ (sum_ (by l'time<$>xs)+)):-:zs
where (xs,ys) = span ((==f^.l'value) . by l'value) fs ; f = fs^.l'1
~(z:-:zs) = group_ ys
sum_ = foldl' (+) zero
headE :: Event t a -> a
headE e = e^.from i'event.l'1.l'value
mapFutures :: (Future t a -> Future t' b) -> Event t a -> Event t' b
mapFutures f = i'event %%~ map f
withTime :: Ord t => Event t a -> Event t (Time t,a)
withTime = mapFutures (i'future %%~ listen)
times :: Ord t => Event t a -> Event t (Time t)
times = map2 fst withTime
times' :: (Ord t,Monoid t) => Event t a -> Event t t
times' = map2 (fold . timeVal) times
mask :: Ord t => Event t Bool -> Event t a -> Event t a
mask m ea = (m // ea) `withNext` (True,zero) >>= \((b,_),(_,a)) -> guard b >> a
realize :: Event Seconds (IO ()) -> IO ()
realize l = traverse_ (sink_ . first timeVal) (withTime l)
where sink_ (Since t,v) = waitTill t >> v
sink_ (Always,v) = v
sink_ (Never,_) = unit
realtime :: Event Seconds (IO ()) -> Event Seconds (IO ())
realtime e = (e & flip withNext (maxBound,undefined).withTime) <&> \((_,m),(t,_)) -> do
c <- currentTime
when (pure c<t) m
realizeRT :: Event Seconds (IO ()) -> IO ()
realizeRT = realize . realtime
eventMay :: IO (Maybe a) -> IO (Event Seconds a)
eventMay m = by i'event <$> do
c <- newChan
_ <- forkIO $ do
while $ do
a <- newEmptyMVar
writeChan c a
foldMap (const True)<$>(m <*= maybe unit (putMVar a))
let event' ~(a:as) = unsafeInterleaveIO $ do
(:-:)<$>futureIO (takeMVar a)<*>event' as
(event' =<< getChanContents c)
event :: IO a -> IO (Event Seconds a)
event = eventMay . try (pure Nothing) . map Just
react :: IO a -> (Event Seconds a -> IO (Event Seconds (IO ()))) -> IO ()
react a f = realize =<< join (f<$>event a)
react2 :: IO a -> IO b -> (Event Seconds a -> Event Seconds b -> IO (Event Seconds (IO ()))) -> IO ()
react2 a b f = realize =<< join (f<$>event a<*>event b)
react3 :: IO a -> IO b -> IO c -> (Event Seconds a -> Event Seconds b -> Event Seconds c -> IO (Event Seconds (IO ()))) -> IO ()
react3 a b c f = realize =<< join (f<$>event a<*>event b<*>event c)
newtype Future t a = Future (Time t,a)
deriving (Show,Functor,Unit,Applicative,Traversable,Foldable,Monad,Semigroup,Monoid)
instance Ord t => Eq (Future t a) where f == f' = compare f f'==EQ
instance Ord t => Ord (Future t a) where compare = cmpFut
instance Ord t => Bounded (Future t a) where
minBound = (minBound,undefined)^.i'future
maxBound = (maxBound,undefined)^.i'future
instance Ord t => Orderable (Future t a) where
inOrder (Future ~(t,a)) (Future ~(t',b)) = (Future (tx,x),Future (ty,y),z)
where (tx,ty,z) = inOrder t t'
~(x,y) = if z then (a,b) else (b,a)
i'future :: Iso (Future t a) (Future t' b) (Time t,a) (Time t',b)
i'future = iso Future (\ ~(Future ~(t,a)) -> (t,a))
l'time :: Lens (Time t) (Time t') (Future t a) (Future t' a)
l'time = from i'future.l'1
l'value :: Lens a b (Future t a) (Future t b)
l'value = from i'future.l'2
cmpFut :: Ord t => Future t a -> Future t b -> Ordering
cmpFut a b = compare (a^.l'time) (b^.l'time)
ltFut :: Ord t => Future t a -> Future t b -> Bool
ltFut a b = cmpFut a b == LT
futureIO :: IO a -> IO (Future Seconds a)
futureIO m = do
val <- newEmptyMVar
_ <- forkIO $ putMVar val =<< m
time <- timeIO (readMVar val)
return (Future (time,try (return undefined) (readMVar val)^.thunk))