packages feed

definitive-reactive (empty) → 1.0

raw patch · 5 files changed

+462/−0 lines, 5 filesdep +arraydep +basedep +bytestring

Dependencies added: array, base, bytestring, clock, containers, deepseq, definitive-base, primitive, vector

Files

+ Data/Reactive.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE RebindableSyntax, GeneralizedNewtypeDeriving, TupleSections, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ViewPatterns #-}+module Data.Reactive (+  -- * Reactive Modules+  module IO.Time,++  -- * Reactive Events+  Event,i'event,headE,Reactive(..),++  -- ** Contructing events+  atTimes,mkEvent,+  withTime,times,times',+  mapFutures,++  -- ** Combining events+  (//),(<|*>),(<*|>),+               +  -- ** Filtering events+  groupE,mask,++  -- ** Real-world event synchronization+  realize,realtime,realizeRT,eventMay,event,react,react2,react3,+  +  -- * Future values+  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)++-- |An event (a list of time-value pairs of increasing times)+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++-- |A reactive variable, consisting of an initial value and an Event of changes+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++{-| The \'splice\' operator. Occurs when @a@ occurs.++> by t: a // b = (a,before t: b)+-}+(//) :: 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 //++{-|+The \'over\' operator. Occurs only when @a@ occurs.++> by t: a <|*> (bi,b) = a <*> (minBound,bi):b+-}+(<*|>) :: 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 <|*>++-- |Group the occurences of an event by equality. Occurs when the first occurence of a group occurs. +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++-- |Sinks an action event into the Real World. Actions are evaluated+-- as closely to their specified time as possible. However, they are+-- all executed in order, even if it means delaying the next action+-- further than its required time. For real-time realization of+-- events, see the 'realizeRT' function+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++-- |Creates a real-time action event (an event that skips "frames" as needed) from an ordinary event.+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+        +-- |Sinks a frame event into the real-world, skipping frames if they come+-- too late, thus always performing the frame closest to the current time.+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)++-- |A Future value (a value with a timestamp)+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))++
+ Data/TimeVal.hs view
@@ -0,0 +1,30 @@+module Data.TimeVal (+  TimeVal(..)+  ) where++import Definitive++-- |A type wrapper that adds a Bounded instance for types that don't possess one.+data TimeVal t = Always | Since t | Never+                 deriving (Show,Eq,Ord)+instance Functor TimeVal where+  map f (Since a) = Since (f a)+  map _ Always = Always+  map _ Never = Never+instance Unit TimeVal where pure = Since+instance Applicative TimeVal+instance Monad TimeVal where+  join (Since b) = b+  join Always = Always+  join Never = Never+instance Foldable TimeVal where+  fold (Since t) = t+  fold _ = zero+instance Traversable TimeVal where+  sequence (Since t) = Since<$>t+  sequence Always = pure Always+  sequence Never = pure Never++instance Bounded (TimeVal t) where+  minBound = Always ; maxBound = Never+
+ IO/Time.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE TupleSections, RecursiveDo, Rank2Types, DeriveDataTypeable, ImplicitParams #-}+module IO.Time (+  -- * Unambiguous times+  Time,+  module Data.TimeVal,+  timeVal,freezed,++  -- * Time utilities+  Seconds,+  timeIO,waitTill,currentTime,timeOrigin,++  -- * Conversion functions+  ms,mus,ns,minutes,hours,days+                          +  ) where++import Definitive+import Control.Concurrent+import Data.TimeVal+import System.IO.Unsafe+import Data.IORef+import System.Clock+import Control.Exception (handle,Exception(..))+import Data.Typeable++data Freezed = Freezed+             deriving (Typeable,Show)+instance Exception Freezed  ++freezed :: a+freezed = throw (toException Freezed)^.thunk++protect :: TimeVal t -> TimeVal t+protect = thunk %%~ try (pure Never)++-- |A type wrappers for timestamps that can be compared unambiguously+data Time t = Time (TimeVal t -> TimeVal t) (TimeVal t -> TimeVal t)+instance (Eq t,Show t) => Show (Time t) where show = show . timeVal+instance Ord t => Eq (Time t) where+  a == b = compare a b == EQ+instance Ord t => Ord (Time t) where+  compare ~(Time fa fa') ~(Time fb fb') =+    unamb (cmp fa fb') (invertOrd (cmp fb fa'))+    where cmp f f' = compare a (protect (f' a))+            where a = protect (f maxBound)+-- |The Time semigroup where @ta + tb == max ta tb@+instance Ord t => Semigroup (Time t) where+  ~(Time fa fb) + ~(Time fa' fb') = Time (mapTL mini fa fa') (mapTL maxi fb fb')+    where mini h x x' = if h < x then x else max x x'+          maxi h x x' = if h > x then max x x' else x+-- |The Time monoid where @zero == minBound@+instance Ord t => Monoid (Time t) where+  zero = minBound+-- |The Time ring where @(*) == min@ and @one == maxBound@+instance Ord t => Semiring (Time t) where+  ~(Time fa fb) * ~(Time fa' fb') = Time (mapTL mini fa fa') (mapTL maxi fb fb')+    where mini h x x' = if h < x then min x x' else x+          maxi h x x' = if h > x then x else min x x'+instance Ord t => Ring (Time t) where+  one = maxBound+instance Ord t => Orderable (Time t) where+  inOrder a b = (a*b,if z then b else a,z)+    where z = a<=b++type TimeFun t = TimeVal t -> TimeVal t+mapTL :: (TimeVal t -> TimeVal t -> TimeFun t) -> TimeFun t -> TimeFun t -> TimeFun t+mapTL _max fa fa' h = _max h x x'`unamb`_max h x' x+  where x = protect (fa h) ; x' = protect (fa' h)++instance Bounded (Time t) where+  minBound = Time (pure minBound) (pure minBound)+  maxBound = Time (pure maxBound) (pure maxBound)+instance Unit Time where+  pure t = Time (pure (pure t)) (pure (pure t)) ++amb :: IO a -> IO a -> IO a+ma `amb` mb = do+  res <- newEmptyMVar+  ta <- forkIO $ handle (\Freezed -> unit) $ ma >>= putMVar res . Left+  tb <- forkIO $ handle (\Freezed -> unit) $ mb >>= putMVar res . Right++  takeMVar res >>= \c -> case c of+    Left a -> a <$ killThread tb+    Right a -> a <$ killThread ta+unamb :: a -> a -> a+unamb = warp2 (from thunk) amb++type Seconds = Double++-- |A Time's pure value. Reduction to normal form may block.+timeVal :: Time t -> TimeVal t+timeVal (Time fa _) = protect (fa maxBound)++-- |Constructs a Time representing the time by which the argument terminates.+--+-- Warning: This function executes its argument, ignoring its+-- value. Thus, it would be wise to use it on idempotent blocking+-- actions, such as @readMVar@.+timeIO :: IO a -> IO (Time Seconds)+timeIO io = do+  sem <- newEmptyMVar+  ret <- newIORef id+  +  minAction <- newIORef $ \tm -> readIORef ret <**> amb (readMVar sem) (+    Since<$>case tm of+       Always -> currentTime+       Since t -> waitTill t >> currentTime+       Never -> throw (toException Freezed))+  maxAction <- newIORef $ \tm -> readIORef ret <**> amb (readMVar sem) (+    case tm of+      Always -> throw (toException Freezed)+      Since t -> waitTill t >> pure Never+      Never -> Since<$>currentTime)+    +  let refAction ref = \t -> unsafePerformIO (join (readIORef ref<*>pure t))+  _ <- forkIO $ void $ mfix $ \t -> do +    t' <- catch (\_ -> return Never) (io >> return (pure t))+    writeIORef minAction (const (pure t'))+    writeIORef maxAction (const (pure t'))+    writeIORef ret (const t')+    putMVar sem t'+    currentTime+    +  return $ Time (refAction minAction) (refAction maxAction)+  +waitTill :: Seconds -> IO ()+waitTill t = do+  now <- t `seq` currentTime+  when (t>now) $ threadDelay (floor $ (t-now)*1000000)++seconds :: TimeSpec -> Seconds+seconds t = fromIntegral (sec t) + fromIntegral (nsec t)/1000000000 :: Seconds+currentTime :: IO Seconds+currentTime = seconds<$>getTime Realtime+timeOrigin :: (( ?birthTime :: Seconds ) => IO a) -> IO a+timeOrigin m = currentTime >>= \t -> let ?birthTime = t in m++ms,mus,ns,minutes,hours,days :: Seconds -> Seconds+ms = (/1000)+mus = (/1000000)+ns = (/1000000000)+minutes = (*60)+hours = (*3600)+days = (*(3600*24))
+ LICENSE view
@@ -0,0 +1,39 @@+THE FREE BEER PUBLIC LICENSE+--------++The Free Beer Public License is designed to provide free (as in beer,+hence the name), unlimited access to any content for anyone who wishes+it, without restrictions such as property rights or affordability.++This license embodies the philosophy that all software (and more+generally all good ideas) is designed to solve a particular problem,+and that the only way to judge its quality is by how well it solves+that problem, rather than other unrelated criteria such as sellability+or merchandability.++All kinds of works may be licensed under the FBPL, as long as the+aforementioned works are within the legal rights of the provider to+give.++TERMS AND CONDITIONS+--------------------++### 1. Free as in Beer++The provider of this work shall make it available, free of any charge,+monetary or otherwise, to the consumer, to use without restrictions or+any kind of supervision.++### 2. Freely taken is freely given++The consumer of this work may redistribute it as well as derived works+in any way he or she chooses, as long as the work itself and any+derived work remain Free as in Beer, as per the first clause.++### 3. The Burden of Proof++The provider of this work shall also supply explanations for how the+work was realized if requested, in the form of source code for example, or+supply the means to access such explanations.++Every such explanation shall be Free as in Beer, as per the first clause.
+ definitive-reactive.cabal view
@@ -0,0 +1,23 @@+-- content information+name:          definitive-reactive+category:      Reactive+synopsis:      A simple Reactive library.+description:   ++-- meta-information+author:        Marc Coiffier+maintainer:    marc.coiffier@gmail.com+version:       1.0+license:       OtherLicense+license-file:  LICENSE++-- build information+build-type:    Simple+cabal-version: >=1.10++library+  exposed-modules: IO.Time Data.TimeVal Data.Reactive+  build-depends: base (== 4.6.*), definitive-base (== 1.2.*), containers (== 0.5.*), deepseq (== 1.3.*), array (== 0.5.*), bytestring (== 0.10.*), vector (== 0.10.*), primitive (== 0.5.*), clock (== 0.4.*)+  default-extensions: TypeSynonymInstances NoMonomorphismRestriction StandaloneDeriving GeneralizedNewtypeDeriving TypeOperators RebindableSyntax FlexibleInstances FlexibleContexts FunctionalDependencies TupleSections MultiParamTypeClasses Rank2Types+  ghc-options: -Wall -fno-warn-orphans -threaded+  default-language: Haskell2010