module SimpleH.Reactive (
module SimpleH.Reactive.Time,
module SimpleH.Reactive.TimeVal,
Event,_event,headE,Reactive(..),
atTimes,mkEvent,
withTime,times,
mapFutures,
(//),(<|*>),(<*|>),
groupE,mask,
sink,event,
Future,_future,_time,_value,futureIO,
) where
import SimpleH
import Control.Concurrent
import SimpleH.Reactive.TimeVal
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.List (group)
import SimpleH.Reactive.Time
newtype Event t a = Event { getEvent :: (OrdList:.:Future t) a }
deriving (Unit,Functor,Foldable,Traversable)
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 f fs<*>cons x xs)
where cons a = _event %%~ ((minBound,a)^._future :)
instance (Ord t,Show t,Show a) => Show (Event t a) where show = show . at' _event
instance Ord t => Semigroup (Event t a) where
(+) = warp2 (from _Event) (+)
instance Ord t => Monoid (Event t a) where zero = []^._event
instance Ord t => Applicative (Event t) where
fe@(at' _event -> ff:_) <*> xe@(at' _event -> fx:_) =
ste & traverse (at state) & at' state & map snd & \st ->
br ((ff^._time)+(fx^._time)) (st (ff^._value,fx^._value))
where ste = map (\f (_,x) -> ((f,x),f x)) fe
+ map (\x (f,_) -> ((f,x),f x)) xe
br t (at' _event -> e) = uniq (map (_time %- t) b + a)^._event
where (b,a) = span (\f -> f^._time<t) e
uniq = map last . group
_ <*> _ = zero
instance Ord t => Monad (Event t) where
join = map (at' _event) >>> at' _event >>> map (sequence >>> map join)
>>> merge >>> at _event
where merge [] = []
merge [t] = t
merge ([]:t) = merge t
merge ((x:xs):ys:t) = x:merge (add xs ys : t)
where add = warp2 _OrdList (+)
type EventRep t a = OrdList (Future t a)
_Event :: Iso (Event t a) (Event t' b) (EventRep t a) (EventRep t' b)
_Event = _Compose.iso Event getEvent
_event :: Iso (Event t a) (Event t' b) [Future t a] [Future t' b]
_event = _OrdList._Event
atTimes :: [t] -> Event t ()
atTimes ts = (ts <&> \t -> (pure t,())^._future)^._event
mkEvent :: [(t,a)] -> Event t a
mkEvent as = (as <&> at _future . (_1 %~ pure))^._event
(//) :: Ord t => Event t a -> Event t b -> Event t (a, Event t b)
ea // eb = mapAccum_ fun (ea^.._event) (eb^.._event) ^. _event
where fun a bs = (ys,a & _value %~ (,xs^._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 2 <*|>
(<|*>) :: 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 = _event %%~ group_ . (+repeat (Future (maxBound,undefined)))
where group_ fs = (f & _value %- (xs^._event))
: (z & _time %~ (sum_ (at _time<$>xs)+)):zs
where (xs,ys) = span ((==f^._value) . at _value) fs ; f = head fs
~(z:zs) = group_ ys
sum_ = foldl' (+) zero
headE :: Event t a -> a
headE = at _value . head . at' _event
mapFutures :: (Future t a -> Future t' b) -> Event t a -> Event t' b
mapFutures f = _event %%~ map f
withTime :: Ord t => Event t a -> Event t (TimeVal t,a)
withTime = mapFutures (\(Future f) -> Future (_1%~timeVal <$> listen f))
times :: Ord t => Event t a -> Event t (TimeVal t)
times = map2 fst withTime
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
sink :: Event Seconds (IO ()) -> IO ()
sink l = traverse_ sink_ (withTime l)
where sink_ (Since t,v) = waitTill t >> v
sink_ (Always,v) = v
sink_ (Never,_) = unit
event :: IO a -> IO (Event Seconds a)
event m = at _event <$> do
c <- newChan
_ <- forkIO $ forever $ do
a <- newEmptyMVar
writeChan c a
putMVar a =<< m
let event' ~(a:as) = unsafeInterleaveIO $ do
(:)<$>futureIO (takeMVar a)<*>event' as
(event' =<< getChanContents c)
<*= forkIO . traverse_ (at' _thunk . timeVal . at _time)
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 => 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)
_future :: Iso (Future t a) (Future t' b) (Time t,a) (Time t',b)
_future = iso Future (\(Future ~(t,a)) -> (t,a))
_time :: Lens (Time t) (Time t') (Future t a) (Future t' a)
_time = from _future._1
_value :: Lens a b (Future t a) (Future t b)
_value = from _future._2
cmpFut :: Ord t => Future t a -> Future t b -> Ordering
cmpFut a b = compare (a^._time) (b^._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,readMVar val^._thunk))