frpnow (empty) → 0.1
raw patch · 12 files changed
+1529/−0 lines, 12 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, transformers
Files
- ChangeLog +1/−0
- Control/FRPNow.hs +33/−0
- Control/FRPNow/BehaviorEnd.hs +155/−0
- Control/FRPNow/Core.hs +567/−0
- Control/FRPNow/EvStream.hs +309/−0
- Control/FRPNow/Lib.hs +194/−0
- Control/FRPNow/Private/PrimEv.hs +85/−0
- Control/FRPNow/Private/Ref.hs +24/−0
- Control/FRPNow/Time.hs +126/−0
- LICENSE +10/−0
- Setup.hs +2/−0
- frpnow.cabal +23/−0
+ ChangeLog view
@@ -0,0 +1,1 @@+0.1 Initial version
+ Control/FRPNow.hs view
@@ -0,0 +1,33 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.FRPNow+-- Copyright : (c) Atze van der Ploeg 2015+-- License : BSD-style+-- Maintainer : atzeus@gmail.org+-- Stability : provisional+-- Portability : portable+-- +-- An FRP library with first-class and higher-order behaviors, and interalized IO. +--+-- Based on the paper <http://www.cse.chalmers.se/~atze/papers/prprfrp.pdf Principled Practical FRP: Forget the past, Change the future, FRPNow!>, ICFP 2015, by Atze van der Ploeg and Koenem Claessem.+--+-- The packages @FRPNow-GTK@ and @FRPNow-Gloss@ hook up FRPNow to GUI toolkits via the functions 'Control.FRPNow.GTK.runNowGTK' and 'Control.FRPNow.Gloss.runNowGloss'+--+--+-- To understand what is going on, I suggest you look at the <https://github.com/atzeus/FRPNow/tree/master/Examples examples>, and read section 1-5 of the <http://www.cse.chalmers.se/~atze/papers/prprfrp.pdf paper>. +--+-- The package contains the following modules:+--+-- [@Core@] The core FRP primitives with denotational semantics.+-- [@Lib@] Utility functions.+-- [@EvStream@] Event streams.+-- [@Time@] Utility functions related to passing the of time.+-- [@BehaviorEnd@] A monadic abstraction for behaviors consisting of multiple phases (a bit advanced stuff, not needed to get going).++module Control.FRPNow( module Control.FRPNow.Core, module Control.FRPNow.Lib, module Control.FRPNow.EvStream, module Control.FRPNow.Time, module Control.FRPNow.BehaviorEnd) where++import Control.FRPNow.Core+import Control.FRPNow.Lib+import Control.FRPNow.EvStream+import Control.FRPNow.Time+import Control.FRPNow.BehaviorEnd
+ Control/FRPNow/BehaviorEnd.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DoAndIfThenElse, FlexibleInstances , MultiParamTypeClasses,GADTs, TypeOperators, TupleSections, ScopedTypeVariables,ConstraintKinds,FlexibleContexts,UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.FRPNow.Until+-- Copyright : (c) Atze van der Ploeg 2015+-- License : BSD-style+-- Maintainer : atzeus@gmail.org+-- Stability : provisional+-- Portability : portable+-- +-- The until abstraction, and related definitions.+--+--+-- A value of type @BehaviorEnd@ is a behavior and an ending event.+-- This also forms a monad, such that we can write+-- +-- > do a1 `Until` e1+-- > b1 `Until` e2+--+-- for behaviors consisting of multiple phases.+-- This concept is similar to "Monadic FRP" (Haskell symposium 2013, van der Ploeg) and+-- the Task monad abstraction (Lambda in motion: Controlling robots with haskell, Peterson, Hudak and Elliot, PADL 1999) +module Control.FRPNow.BehaviorEnd(+ -- * Until+ BehaviorEnd(..), combineUntil, (.:),parList,+ -- * Derived monads+ -- $compose+ + till,+ (:.)(..), + Swap(..),+ liftLeft,+ liftRight)+ where+import Control.FRPNow.Core+import Control.FRPNow.Lib+import Control.FRPNow.EvStream+import Control.Monad++data BehaviorEnd x a = Until { behavior :: Behavior x, end :: Event a }++instance Monad (BehaviorEnd x) where+ return x = pure (error "ended!") `Until` pure x+ (b `Until` e) >>= f =+ let v = f <$> e+ b' = b `switch` (behavior <$> v)+ e' = v >>= end+ in b' `Until` e'++instance Functor (BehaviorEnd x) where fmap = liftM+instance Applicative (BehaviorEnd x) where pure = return ; (<*>) = ap++-- | Combine the behavior of the @Until@ and the other behavior until the+-- with the given function until the end event happens.+combineUntil :: (a -> b -> b) -> BehaviorEnd a x -> Behavior b -> Behavior b+combineUntil f (bx `Until` e) b = (f <$> bx <*> b) `switch` fmap (const b) e++-- | Add the values in the behavior of the @Until@ to the front of the list +-- until the end event happsens.+(.:) :: BehaviorEnd a x -> Behavior [a] -> Behavior [a]+(.:) = combineUntil (:)++-- | Given an eventstream that spawns behaviors with an end,+-- returns a behavior with list of the values of currently active +-- behavior ends.+parList :: EvStream (BehaviorEnd b ()) -> Behavior (Behavior [b])+parList = foldBs (pure []) (flip (.:))++-- $compose+-- The monad for @Until@ is a bit restrictive, because we cannot sample other behaviors +-- in this monad. For this reason we also define a monad for @(Behavior :. Until x)@, +-- where @ :. @ is functor composition, which can sample other monads. +-- This relies on the @swap@ construction from "Composing monads", Mark Jones and Luc Duponcheel.+-- ++-- | Like 'Until', but the event can now be generated by a behavior (@Behavior (Event a)@) or even+-- (@Now (Event a)@). +--+-- Name is not "until" to prevent a clash with 'Prelude.until'.+till :: Swap b (BehaviorEnd x) =>+ Behavior x -> b (Event a) -> (b :. BehaviorEnd x) a+till b e = liftLeft e >>= liftRight . (b `Until`)++instance (Swap b e, Sample b) => Sample (b :. e) where sample b = liftLeft (sample b)++assoc :: Functor f => ((f :. g) :. h) x -> (f :. (g :. h)) x+assoc = Close . fmap Close . open . open++coassoc :: Functor f => (f :. (g :. h)) x -> ((f :. g) :. h) x+coassoc = Close . Close . fmap open . open++instance (Functor a, Functor b) => Functor (a :. b) where + fmap f = Close . fmap (fmap f) . open++-- | Composition of functors.+newtype (f :. g) x = Close { open :: f (g x) }++-- | Lift a value from the left monad into the composite monad.+liftLeft :: (Monad f, Monad g) => f x -> (f :. g) x +liftLeft = Close . liftM return ++-- | Lift a value from the right monad into the composite monad.+liftRight :: Monad f => g x -> (f :. g) x +liftRight = Close . return +++class (Monad f, Monad g) => Swap f g where+ -- | Swap the composition of two monads.+ -- Laws (from Composing Monads, Jones and Duponcheel)+ -- + -- > swap . fmap (fmap f) == fmap (fmap f) . swap+ -- > swap . return == fmap unit+ -- > swap . fmap return == return+ -- > prod . fmap dorp == dorp . prod + -- > where prod = fmap join . swap+ -- > dorp = join . fmap swap+ swap :: g (f a) -> f (g a)++instance Plan b => Swap b Event where+ swap = plan++instance (Monad b, Plan b) => Swap b (BehaviorEnd x) where+ swap (Until b e) = liftM (Until b) (plan e)++instance Swap f g => Monad (f :. g) where+ -- see (Composing Monads, Jones and Duponcheel) for proof+ return = Close . return . return+ m >>= f = joinComp (fmap2m f m)++-- anoyance that Monad is not a subclass of functor+fmap2m f = Close . liftM (liftM f) . open++joinComp :: (Swap b e) => (b :. e) ((b :. e) x) -> (b :. e) x+joinComp = Close . joinFlip . open . fmap2m open++joinFlip :: (Swap b e, Monad e, Monad b) => b (e (b (e x))) -> b (e x)+joinFlip = liftM join . join . liftM swap +-- this works as follows, we have +-- b . e . b . e flip middle two+-- b . b . e . e join left and right+-- b . e +++instance (Applicative b, Applicative e) => Applicative (b :. e) where+ pure = Close . pure . pure+ x <*> y = Close $ (<*>) <$> open x <*> open y +++++++++
+ Control/FRPNow/Core.hs view
@@ -0,0 +1,567 @@+{-# LANGUAGE LambdaCase,RecursiveDo, FlexibleContexts, ExistentialQuantification, Rank2Types,GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.FRPNow.Core+-- Copyright : (c) Atze van der Ploeg 2015+-- License : BSD-style+-- Maintainer : atzeus@gmail.org+-- Stability : provisional+-- Portability : portable+-- +-- The core FRPNow interface, based on the paper "Principled Practical FRP: Forget the past, Change the future, FRPNow!", ICFP 2015, by Atze van der Ploeg and Koenem Claessem.+-- +-- This module contains the core FRPNow interface, which consists of:+--+-- * The pure interface, which has denotational semantics+-- * The IO interface+-- * The entry points, i.e. the functions that are used to start the FRP system.++module Control.FRPNow.Core(+ -- * Pure interface+ -- $time+ Event,Behavior, never, switch, whenJust, futuristic,+ -- * IO interface+ Now, async, asyncOS, callback, sampleNow, planNow, sync,+ -- * Entry point+ runNowMaster,+ initNow) where+import Control.Concurrent.Chan+import Control.Applicative hiding (empty,Const)+import Control.Monad hiding (mapM_)+import Control.Monad.IO.Class+import Control.Monad.Reader hiding (mapM_)+import Control.Monad.Writer hiding (mapM_)+import Data.IORef+import Control.FRPNow.Private.Ref+import Control.FRPNow.Private.PrimEv+import System.IO.Unsafe+import Debug.Trace++import Prelude ++{--------------------------------------------------------------------+ Pure interface+--------------------------------------------------------------------}++-- $time+-- The FRPNow interface is centered around behaviors, values that change over time, and events, value that are known from some point in time on.+--+-- What the pure part of the FRPNow interface does is made precise by denotation semantics, i.e. mathematical meaning. The denotational semantics of the pure interface are+-- +-- @ +-- type Event a = (Time+,a)+-- +-- never :: Event a+-- never = (∞, undefined)+--+-- instance Monad Event where+-- return x = (-∞,x)+-- (ta,a) >>= f = let (tb,b) = f a+-- in (max ta tb, b)+--+-- type Behavior a = Time -> a +--+-- instance Monad Behavior where+-- return x = λt -> x+-- m >>= f = λt -> f (m t) t +--+-- instance MonadFix Behavior where+-- mfix f = λt -> let x = f x t in x +-- +-- switch :: Behavior a -> Event (Behavior a) -> Behavior a+-- switch b (ts,s) = λn -> +-- if n < ts then b n else s n+--+-- whenJust :: Behavior (Maybe a) -> Behavior (Event a)+-- whenJust b = λt -> +-- let w = minSet { t' | t' >= t && isJust (b t') }+-- in if w == ∞ then never+-- else (w, fromJust (b w))+-- @+-- +-- Where @Time@ is a set that is totally ordered set and has a least element, -∞.+-- For events, we also use @Time+ = Time ∪ ∞@. +--+-- The notation @minSet x@ indicates the minimum element of the set @x@, which is not valid Haskell, but is a valid denotation. Note that if there is no time at which the input behavior is @Just@ in the present or future, then @minSet@ will give the minimum element of the empty set, which is @∞@.+-- +-- The monad instance of events is denotationally a writer monad in time, whereas the monad instance of behaviors is denotationally a reader monad in time.++-- | An event is a value that is known from some point in time on. +data Event a + = Never+ | Occ a + | E (M (Event a))++runE :: Event a -> M (Event a)+runE Never = return Never+runE (Occ x) = return (Occ x)+runE (E m) = m +++instance Monad Event where+ return = Occ+ e >>= f = memoE (e `bindE` f)+++-- | A never occuring event++never :: Event a+never = Never++bindE :: Event a -> (a -> Event b) -> Event b+Never `bindE` _ = Never+(Occ x) `bindE` f = f x+(E m) `bindE` f = E $ bindEM m f+++bindEM :: M (Event a) -> (a -> Event b) -> M (Event b)+m `bindEM` f = + m >>= \r -> case r of+ Never -> return Never+ Occ x -> runE (f x)+ E m' -> return (E $ m' `bindEM` f)+-- Section 6.2+++memoEIO :: Event a -> IO (Event a)+memoEIO einit = + do r <- newIORef einit + return (usePrevE r)++usePrevE :: IORef (Event a) -> Event a+usePrevE r = E $ + do e <- liftIO (readIORef r)+ res <- runE e+ liftIO (writeIORef r res)+ return res++memoE :: Event a -> Event a+--memoE e = e+memoE Never = Never+memoE (Occ x) = Occ x+memoE e = unsafePerformIO $ memoEIO e+ +-- Section 6.3++-- | An behavior is a value that changes over time.++data Behavior a = B (M (a, Event (Behavior a)))+ | Const a +++runB :: Behavior a -> M (a, Event (Behavior a))+runB (B m) = m+runB (Const a) = return (a, never)++switch' :: Behavior a -> Event (Behavior a) -> Behavior a+switch' b Never = b+switch' _ (Occ b) = b+switch' (Const x) (E em) = B $ + em >>= \r -> case r of+ Never -> return (x,never)+ Occ b' -> runB b'+ E em' -> return (x, E em')+switch' (B bm) (E em) = B $+ em >>= \r -> case r of+ Never -> bm+ Occ b' -> runB b'+ E em' -> + do (h,t) <- bm+ return $ case t of+ Occ _ -> error "switch already occured!"+ Never -> (h, E em')+ E tm -> (h, switchEM tm em')++switchEM :: M (Event (Behavior a)) -> M (Event (Behavior a)) -> Event (Behavior a)+switchEM lm rm = E $ + rm >>= \case + Never -> lm+ Occ b -> return (Occ b)+ E rm' -> lm >>= return . \case+ Never -> E rm'+ Occ b -> Occ (b `switch'` E rm')+ E lm' -> switchEM lm' rm'+++bindB :: Behavior a -> (a -> Behavior b) -> Behavior b+bindB (Const x) f = f x+bindB (B m) f = B $+ do (h,t) <- m+ case f h of+ Const x -> return (x, (`bindB` f) <$> t)+ B n -> do (hn,tn) <- n+ tn <- runE tn+ return $ case (t,tn) of+ (_, Occ _) -> error "switch already occured!"+ (Occ _ , _) -> error "switch already occured!"+ (Never , e) -> (hn, e)+ (e, Never ) -> (hn, (`bindB` f) <$> t)+ (e, E tm) -> (hn, switchEM tm (runE ((`bindB` f) <$> e)) )++++whenJust' :: Behavior (Maybe a) -> Behavior (Event a)+whenJust' (Const Nothing) = pure never+whenJust' (Const (Just x)) = pure (pure x)+whenJust' (B m) = B $ + do (h, t) <- m+ case h of+ Just x -> return (return x, whenJust' <$> t)+ Nothing -> + do en <- planM (runB . whenJust' <$> t)+ return (en >>= fst, en >>= snd)+++whenJustSample' :: Behavior (Maybe (Behavior a)) -> Behavior (Event a)+whenJustSample' (Const Nothing) = pure never+whenJustSample' (Const (Just x)) = B $ do v <- fst <$> runB x; return (pure v, never)+whenJustSample' (B bm) = B $+ do (h, t) <- bm+ case h of+ Just x -> do v <- fst <$> runB x; return (pure v, whenJustSample' <$> t)+ Nothing -> do en <- planM (runB . whenJustSample' <$> t)+ return (en >>= fst, en >>= snd)++instance Monad Behavior where+ return x = B $ return (x, never)+ m >>= f = memoB (m `bindB` f)++instance MonadFix Behavior where+ mfix f = B $ mfix $ \(~(h,_)) ->+ do ~(h',t) <- runB (f h)+ return (h, mfix f <$ t)++-- | Introduce a change over time.+--+-- +-- > b `switch` e +-- +--+-- Gives a behavior that acts as @b@ initially, and switches to the behavior inside @e@ as soon as @e@ occurs.+-- +switch :: Behavior a -> Event (Behavior a) -> Behavior a+switch b e = memoB (switch' b e)++-- | Observe a change over time.+-- +-- The behavior @whenJust b@ gives at any point in time the event that +-- the behavior @b@ is @Just@ at that time or afterwards. +--+-- As an example,+--+-- +-- > let getPos x +-- > | x > 0 = Just x+-- > | otherwise = Nothing+-- > in whenJust (getPos <$> b)+-- +-- Gives gives the event that+-- the behavior @b@ is positive. If @b@ is currently positive+-- then the event will occur now, otherwise it+-- will be the first time that @b@ becomes positive in the future.+-- If @b@ never again is positive then the result is 'never'.++whenJust :: Behavior (Maybe a) -> Behavior (Event a)+whenJust b = memoB (whenJust' b)+++-- | A more optimized version of:+-- +-- > whenJustSample b = do x <- whenJust b +-- > plan x++whenJustSample :: Behavior (Maybe (Behavior a)) -> Behavior (Event a)+whenJustSample b = memoB (whenJustSample' b)+++-- | Not typically needed, used for event streams.+-- +-- If we have a behavior giving events, such that each time the behavior is+-- sampled the obtained event is in the future, then this function+-- ensures that we can use the event without inspecting it (i.e. before binding it).+--+-- If the implementation samples such an event and it turns out the event does actually occur at the time+-- the behavior is sampled, an error is thrown.+futuristic :: Behavior (Event a) -> Behavior (Event a)+futuristic b = B $ do e <- makeLazy (joinEm <$> runB b) + return (fst <$> e, snd <$> e)+ where joinEm (e,es) = (,) <$> e <*> es++unrunB :: (a,Event (Behavior a)) -> Behavior a +unrunB (h, Never) = Const h+unrunB (h,t) = B $ + runE t >>= \x -> case x of+ Occ b -> runB b+ t' -> return (h,t')++memoBIO :: Behavior a -> IO (Behavior a)+memoBIO einit = + do r <- newIORef einit + return (usePrevB r)++usePrevB :: IORef (Behavior a) -> Behavior a+usePrevB r = B $ + do b <- liftIO (readIORef r)+ res <- runB b+ liftIO (writeIORef r (unrunB res))+ return res+ +memoB :: Behavior a -> Behavior a+--memoB b = b+memoB b@(Const _) = b+memoB b = unsafePerformIO $ memoBIO b++-- Section 6.7+++data Env = Env {+ plansRef :: IORef Plans,+ laziesRef :: IORef Lazies,+ clock :: Clock }++++type M = ReaderT Env IO++-- | A monad that alows you to:+-- +-- * Sample the current value of a behavior via 'sampleNow'+-- * Interact with the outside world via 'async', 'callback' and 'sync'.+-- * Plan to do Now actions later, via 'planNow'+--+-- All actions in the @Now@ monad are conceptually instantaneous, which entails it is guaranteed that for any behavior @b@ and Now action @m@:+-- +-- @+-- do x <- sample b; m ; y <- sample b; return (x,y) +-- == do x <- sample b; m ; return (x,x) +-- @+newtype Now a = Now { getNow :: M a } deriving (Functor,Applicative,Monad, MonadFix)+++-- | Sample the present value of a behavior+sampleNow :: Behavior a -> Now a+sampleNow (B m) = Now $ fst <$> m+++-- | Create an event that occurs when the callback is called. +-- +-- The callback can be safely called from any thread. An error occurs if the callback is called more than once. +--+-- See 'Control.FRPNow.EvStream.callbackStream' for a callback that can be called repeatidly.+-- +-- The event occurs strictly later than the time that +-- the callback was created, even if the callback is called immediately.+callback :: Now (Event a, a -> IO ())+callback = Now $ do c <- clock <$> ask+ (pe, cb) <- liftIO $ callbackp c+ return (toE pe,cb)+-- | Synchronously execte an IO action.+-- +-- Use this is for IO actions which do not take a long time, such as +-- opening a file or creating a widget.+sync :: IO a -> Now a+sync m = Now $ liftIO m++-- | Asynchronously execte an IO action, and obtain the event that it is done.+-- +-- Starts a seperate thread for the IO action, and then immediatly returns the +-- event that the IO action is done. Since all actions in the 'Now' monad are instantaneous,+-- the resulting event is guaranteed to occur in the future (not now).+--+-- Use this for IO actions which might take a long time, such as waiting for a network message,+-- reading a large file, or expensive computations.+--+-- /Note/:Use this only when using FRPNow with Gloss or something else that does not block haskell threads. +-- For use with GTK or other GUI libraries that do block Haskell threads, use 'asyncOS' instead.+async :: IO a -> Now (Event a)+async m = Now $ do c <- clock <$> ask+ toE <$> liftIO (spawn c m)+++-- | Like 'async', but uses an OS thread instead of a regular lightweight thread.+--+-- Useful when interacting with GUI systems that claim the main loop, such as GTK.+asyncOS :: IO a -> Now (Event a)+asyncOS m = Now $ do c <- clock <$> ask+ toE <$> liftIO (spawnOS c m)++toE :: PrimEv a -> Event a+toE p = E toEM where+ toEM = (toEither . (p `observeAt`) <$> getRound) + toEither Nothing = E toEM+ toEither (Just x) = Occ x++getRound :: M Round+getRound = ReaderT $ \env -> curRound (clock env) +++-- IORef+type Plan a = IORef (Either (Event (M a)) a)++planToEv :: Plan a -> Event a+planToEv ref = self where+ self = E $ + liftIO (readIORef ref) >>= \pstate -> + case pstate of+ Right x -> return (Occ x)+ Left ev -> runE ev >>= \estate ->+ case estate of+ Occ m -> do x <- m+ liftIO $ writeIORef ref (Right x)+ return $ Occ x+ ev' -> do liftIO $ writeIORef ref (Left ev')+ return self+++data SomePlan = forall a. SomePlan (Ref (Plan a))+type Plans = [SomePlan]+++type Lazies = [Lazy]+data Lazy = forall a. Lazy (M (Event a)) (IORef (Event a))+++makeLazy :: M (Event a) -> M (Event a)+makeLazy m = ReaderT $ \env ->+ do n <- curRound (clock env) + r <- newIORef undefined+ modifyIORef (laziesRef env) (Lazy m r :)+ return (readLazyState n r)++readLazyState :: Round -> IORef (Event a) -> Event a+readLazyState n r =+ let x = E $+ do m <- getRound+ case compare n m of+ LT -> liftIO (readIORef r) >>= runE+ EQ -> return x+ GT -> error "Round seems to decrease.."+ in x+++planM :: Event (M a) -> M (Event a)+planM e = plan makeWeakIORef e+++-- | Plan to execute a 'Now' computation.+--+-- When given a event carrying a now computation, execute that now computation as soon as the event occurs.+-- If the event has already occured when 'planNow' is called, then the 'Now' computation will be executed immediatly.+planNow :: Event (Now a) -> Now (Event a)+planNow e = Now $ plan makeStrongRef (getNow <$> e)++plan :: (forall v. IORef v -> IO (Ref (IORef v))) -> Event (M a) -> M (Event a)+plan makeRef e = + do p <- liftIO (newIORef $ Left e)+ let ev = planToEv p+ pr <- liftIO (makeRef p)+ addPlan pr+ return ev++addPlan :: Ref (Plan a) -> M ()+addPlan p = ReaderT $ \env -> modifyIORef (plansRef env) (SomePlan p :) ++++-- | General interface to interact with the FRP system. +--+-- Typically, you don't need this function, but instead use a specialized function for whatever library you want to use FRPNow with such as 'Control.FRPNow.GTK.runNowGTK' or 'Control.FRPNow.Gloss.runNowGloss', which themselves are implemented using this function.++initNow :: + (IO (Maybe a) -> IO ()) -- ^ An IO action that schedules some FRP actions to be run. The callee should ensure that all actions that are scheduled are ran on the same thread. If a scheduled action returns @Just x@, then the ending event has occured with value @x@ and now more FRP actions are scheduled.+ -> Now (Event a) -- ^ The @Now@ computation to execute, resulting in the ending event, i.e. the event that stops the FRP system.+ -> IO ()+initNow schedule (Now m) = + mdo c <- newClock (schedule it)+ pr <- newIORef []+ lr <- newIORef []+ let env = Env pr lr c+ let it = runReaderT (iteration e) env+ e <- runReaderT m env+ schedule (runReaderT (iterationMeat e) env)+ return ()++iteration :: Event a -> M (Maybe a)+iteration ev = + newRoundM >>= \new ->+ if new + then iterationMeat ev+ else return Nothing++iterationMeat ev = + do er <- runE ev+ case er of+ Occ x -> return (Just x)+ _ -> tryPlans >> runLazies >> return Nothing+++newRoundM :: M Bool+newRoundM = ReaderT $ \env -> newRound (clock env)+++tryPlans :: M ()+tryPlans = ReaderT $ tryEm where+ tryEm env = + do pl <- readIORef (plansRef env)+ --putStrLn ("nr plans: " ++ show (length pl))+ writeIORef (plansRef env) []+ runReaderT (mapM_ tryPlan (reverse pl)) env+ tryPlan (SomePlan pr) = + do ps <- liftIO (deRef pr) + case ps of+ Just p -> do eres <- runE (planToEv p)+ case eres of+ Occ x -> return ()+ _ -> addPlan pr+ Nothing -> return ()++runLazies :: M ()+runLazies = ReaderT $ runEm where+ runEm env = + readIORef (laziesRef env) >>= \pl ->+ if null pl + then return ()+ else do writeIORef (laziesRef env) []+ runReaderT (mapM_ runLazy (reverse pl)) env+ runEm env where+ runLazy (Lazy m r) = do e <- m+ x <- runE e+ case x of+ Occ _ -> error "Forced lazy was not lazy!"+ e' -> liftIO $ writeIORef r e'+++-- | Run the FRP system in master mode.+--+-- Typically, you don't need this function, but instead use a function for whatever library you want to use FRPNow with such as 'Control.FRPNow.GTK.runNowGTK', 'Control.FRPNow.Gloss.runNowGloss'. This function can be used in case you are not interacting with any GUI library, only using FRPNow.+--+-- Runs the given @Now@ computation and the plans it makes until the ending event (given by the inital @Now@ computation) occurs. Returns the value of the ending event.++runNowMaster :: Now (Event a) -> IO a+runNowMaster m = + do chan <- newChan+ let enqueue m = writeChan chan m+ initNow enqueue m+ loop chan where+ loop chan = + do m <- readChan chan+ mr <- m+ case mr of+ Just x -> return x+ Nothing -> loop chan++++instance Functor Behavior where+ fmap = liftM++instance Applicative Behavior where+ pure = return+ (<*>) = ap+ +instance Functor Event where+ fmap = liftM++instance Applicative Event where+ pure = return+ (<*>) = ap
+ Control/FRPNow/EvStream.hs view
@@ -0,0 +1,309 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.FRPNow.EvStream+-- Copyright : (c) Atze van der Ploeg 2015+-- License : BSD-style+-- Maintainer : atzeus@gmail.org+-- Stability : provisional+-- Portability : portable+-- +-- Event streams for FRPNow++module Control.FRPNow.EvStream(+ EvStream,+ -- * Observe + next, nextAll, + -- * Construction+ emptyEs, + merge,+ toChanges,+ edges,+ -- * Folds and scans+ scanlEv,+ foldrEv,+ foldriEv,+ fromChanges,+ foldrSwitch,+ foldEs,+ foldBs,+ -- * Filter and scan+ catMaybesEs,filterEs,filterMapEs,filterMapEsB, filterB, during, beforeEs,+ -- * Combine behavior and eventstream+ (<@@>) , snapshots,+ -- * IO interface+ callbackStream,callStream, callIOStream,+ -- * Debug + traceEs)++ where++import Data.Maybe+import Control.Monad hiding (when)+import Control.Applicative hiding (empty)+import Data.IORef+import qualified Data.Sequence as Seq+import Prelude hiding (until,length)+import qualified Prelude as P+import Debug.Trace+import Data.Monoid++import Control.FRPNow.Core+import Control.FRPNow.Lib+import Debug.Trace++-- | The (abstract) type of event streams.+--+-- Denotationally, one can think of an eventstream a value +-- of type +--+-- > [(Time,a)]+--+-- Where the points in time are non-strictly increasing.+-- There can be multiple simulatinous events in an event stream.++newtype EvStream a = S { getEs :: Behavior (Event [a]) }++instance Functor EvStream where+ fmap f (S b) = S $ (fmap f <$>) <$> b++instance Monoid (EvStream a) where+ mempty = emptyEs+ mappend = merge++-- | The empty event stream+emptyEs :: EvStream a+emptyEs = S $ pure never++-- | Merge two event stream.+-- +-- In case of simultaneity, the left elements come first+merge :: EvStream a -> EvStream a -> EvStream a+merge l r = loop where+ loop = S $+ do l' <- getEs l+ r' <- getEs r+ e <- fmap nxt <$> cmpTime l' r'+ let again = getEs loop+ pure e `switch` fmap (const again) e+ nxt (Simul l r) = l ++ r+ nxt (LeftEarlier l) = l+ nxt (RightEarlier r) = r++-- | Obtain the next element of the event stream. The obtained event is guaranteed to lie in the future.+next :: EvStream a -> Behavior (Event a)+next s = (head <$>) <$> (nextAll s)++-- | Obtain all simultaneous next elements of the event stream. The obtained event is guaranteed to lie in the future.+nextAll :: EvStream a -> Behavior (Event [a])+nextAll e = futuristic $ getEs e++-- | Sample the behavior each time an event in the stream+-- occurs, and combine the outcomes.+(<@@>) :: Behavior (a -> b) -> EvStream a -> EvStream b+(<@@>) f es = S $ loop where+ loop = do e <- getEs es+ plan (nxt <$> e)+ nxt l = (<$> l) <$> f++-- | Sample the behavior each time an event in the stream+-- occurs.+snapshots :: Behavior a -> EvStream () -> EvStream a+snapshots b s = S $+ do e <- getEs s+ ((\x -> [x]) <$>) <$> snapshot b (head <$> e)++-- | Get the event stream of changes to the input behavior.+toChanges :: Eq a => Behavior a -> EvStream a+toChanges = repeatEv . change++-- | Get the events that the behavior changes from @False@ to @True@+edges :: Behavior Bool -> EvStream ()+edges = repeatEv . edge+ ++ +repeatEv :: Behavior (Event a) -> EvStream a+repeatEv b = S $ loop where+ loop = do e <- b+ return $ (\x -> [x]) <$> e+++-- | Create a behavior from an initial value and +-- a event stream of updates.+--+fromChanges :: a -> EvStream a -> Behavior (Behavior a)+fromChanges i s = loop i where+ loop i = do e <- nextAll s+ e' <- plan (loop . last <$> e)+ return (i `step` e')++++-- | Filter the 'Just' values from an event stream.+--+catMaybesEs :: EvStream (Maybe a) -> EvStream a+catMaybesEs s = S $ loop where+ loop = do e <- getEs s+ join <$> plan (nxt <$> e)+ nxt l = case catMaybes l of+ [] -> loop+ l -> return (return l)++-- | Filter events from an event stream+--+filterEs :: (a -> Bool) -> EvStream a -> EvStream a+filterEs f s = catMaybesEs (toMaybef <$> s)+ where toMaybef x | f x = Just x+ | otherwise = Nothing++-- | Shorthand for +-- +-- > filterMapEs f e = catMaybesEs $ f <$> e+filterMapEs :: (a -> Maybe b) -> EvStream a -> EvStream b+filterMapEs f e = catMaybesEs $ f <$> e++-- | Shorthand for +-- +-- > filterMapEs b e = catMaybesEs $ b <@@> e+--+filterMapEsB :: Behavior (a -> Maybe b) -> EvStream a -> EvStream b+filterMapEsB f e = catMaybesEs $ f <@@> e+++-- | Filter events from an eventstream based on a function that+-- changes over time +--+filterB :: Behavior (a -> Bool) -> EvStream a -> EvStream a+filterB f = filterMapEsB (toMaybe <$> f)+ where toMaybe f = \a -> if f a then Just a else Nothing++-- | Obtain only the events from input stream that occur while+-- the input behavior is 'True'+--+during :: EvStream a -> Behavior Bool -> EvStream a+e `during` b = filterB (const <$> b) e+++-- | A left scan over an event stream+scanlEv :: (a -> b -> a) -> a -> EvStream b -> Behavior (EvStream a)+scanlEv f i es = S <$> loop i where+ loop i =+ do e <- nextAll es+ let e' = (\(h : t) -> tail $ scanl f i (h : t)) <$> e+ ev <- plan (loop . last <$> e')+ return (pure e' `switch` ev)+++++++-- | Left fold over an eventstream to create a behavior (behavior depends on when+-- the fold started).+foldEs :: (a -> b -> a) -> a -> EvStream b -> Behavior (Behavior a)+foldEs f i s = loop i where+ loop i = do e <- nextAll s+ let e' = foldl f i <$> e+ ev <- plan (loop <$> e')+ return (i `step` ev)++-- | Right fold over an eventstream+-- +-- The result of folding over the rest of the event stream is in an event,+-- since it can be only known in the future.+-- +-- No initial value needs to be given, since the initial value is 'Control.FRPNow.Core.never'+foldrEv :: (a -> Event b -> b) -> EvStream a -> Behavior (Event b)+foldrEv f es = loop where+ loop =+ do e <- nextAll es+ plan (nxt <$> e)+ nxt [h] = f h <$> loop+ nxt (h : t) = f h . return <$> nxt t+++-- | Right fold over an eventstream with a left initial value+-- +-- Defined as:+--+-- > foldriEv i f ev = f i <$> foldrEv f es+foldriEv :: a -> (a -> Event b -> b) -> EvStream a -> Behavior b+foldriEv i f es = f i <$> foldrEv f es++++-- | Start with the argument behavior, and switch to a new behavior each time +-- an event in the event stream occurs.+--+-- Defined as:+-- +-- > foldrSwitch b = foldriEv b switch+-- +foldrSwitch :: Behavior a -> EvStream (Behavior a) -> Behavior (Behavior a)+foldrSwitch b = foldriEv b switch++-- | Yet another type of fold.+--+-- Defined as:+--+-- > foldBs b f es = scanlEv f b es >>= foldrSwitch b+foldBs :: Behavior a -> (Behavior a -> b -> Behavior a) -> EvStream b -> Behavior (Behavior a)+foldBs b f es = scanlEv f b es >>= foldrSwitch b++-- | An event stream with only elements that occur before the argument event.+beforeEs :: EvStream a -> Event () -> EvStream a+beforeEs s e = S $ beforeEv `switch` en+ where en = pure never <$ e+ beforeEv = do se <- getEs s+ ev <- first (Left <$> e) (Right <$> se)+ return (ev >>= choose)+ choose (Left _) = never+ choose (Right x) = return x+ +++-- | Create an event stream that has an event each time the+-- returned function is called. The function can be called from any thread.+callbackStream :: Now (EvStream a, a -> IO ())+callbackStream = do mv <- sync $ newIORef ([], Nothing)+ (_,s) <- loop mv+ return (S s, func mv) where+ loop mv =+ do (l, Nothing) <- sync $ readIORef mv+ (e,cb) <- callback+ sync $ writeIORef mv ([], Just cb)+ es <- planNow $ loop mv <$ e+ let h = fst <$> es+ let t = snd <$> es+ return (reverse l, h `step` t)++ func mv x =+ do (l,mcb) <- readIORef mv+ writeIORef mv (x:l, Nothing)+ case mcb of+ Just x -> x ()+ Nothing -> return ()++++-- | Call the given function each time an event occurs, and execute the resulting Now computation++callStream :: ([a] -> Now ()) -> EvStream a -> Now ()+callStream f evs = do e2 <- sample (nextAll evs)+ planNow (again <$> e2)+ return () where+ again a = do f a+ e <- sample (nextAll evs)+ planNow (again <$> e)+ return ()+++-- | Execute the given IO action each time an event occurs. The IO action is executed on the main thread, so it should not take a long time.+callIOStream :: (a -> IO ()) -> EvStream a -> Now ()+callIOStream f = callStream (\x -> sync (mapM_ f x) >> return ())++-- | Debug function, print all values in the event stream to stderr, prepended with the given string.+traceEs :: (Show a, Eq a) => String -> EvStream a -> Now ()+traceEs s es = callIOStream (\x -> traceIO (s ++ show x)) es++
+ Control/FRPNow/Lib.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE DoAndIfThenElse, FlexibleInstances , MultiParamTypeClasses,GADTs, TypeOperators, TupleSections, ScopedTypeVariables,ConstraintKinds,FlexibleContexts,UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.FRPNow.Lib+-- Copyright : (c) Atze van der Ploeg 2015+-- License : BSD-style+-- Maintainer : atzeus@gmail.org+-- Stability : provisional+-- Portability : portable+-- +-- Utility FRPNow functions+module Control.FRPNow.Lib(+ -- * Behavior construction+ step,+ -- * Getting events from behaviors + when,+ change,+ edge,+ -- * Events and their ordering+ tryGetEv,+ hasOccured,+ first,+ cmpTime,+ EvOrd(..),+ -- * Fold and state+ foldB,+ sampleUntil,+ -- * Sample behaviors on events+ planB,+ snapshot,+ (<@>),+ -- * Type classes for uniform interface+ Plan(..),+ Sample(..),+ -- * Debugging + traceChanges )+ + where+++import Control.FRPNow.Core+import Control.Applicative+import Control.Monad hiding (when)+import Prelude hiding (until)+import Debug.Trace+++-- | Shorthand for +-- +-- > pure a `switch` s+step :: a -> Event (Behavior a) -> Behavior a+step a s = pure a `switch` s++-- | Like 'Control.FRPNow.whenJust' but on behaviors of type @Bool@ instead of @Maybe@. +-- +-- Gives the event that the input behavior is @True@+when :: Behavior Bool -> Behavior (Event ())+when b = whenJust (boolToMaybe <$> b) where+ boolToMaybe True = Just ()+ boolToMaybe False = Nothing+++-- | Gives at any point in time the event that the input behavior changes, and the new value of the input behavior.+change :: Eq a => Behavior a -> Behavior (Event a)+change b = futuristic $ + do v <- b ;+ whenJust (notSame v <$> b) where+ notSame v v' | v /= v' = Just v'+ | otherwise = Nothing+ +++-- | The resulting behavior gives at any point in time, the event that the input+-- behavior next /becomes/ true. I.e. the next event that there is an edge from False to True. If the input behavior is True already, the event gives the+-- time that it is True again, after first being False for a period of time.+edge :: Behavior Bool -> Behavior (Event ())+edge b = futuristic $ + b >>= \v -> + if v then (do e <- when (not <$> b)+ join <$> plan (when b <$ e))+ else when b++-- | A (left) fold over a behavior.+--+-- The inital value of the resulting behavior is @f i x@ where @i@ the initial value given, and @x@ is the current value of the behavior.+--+foldB :: Eq a => (b -> a -> b) -> b -> Behavior a -> Behavior (Behavior b)+foldB f i b = loop i where+ loop i = do c <- b+ let i' = f i c+ e <- change b+ e' <- snapshot (loop i') (() <$ e)+ return (pure i' `switch` e')++-- | When sampled at a point in time t, the behavior gives an event with +-- the list of all values of the input behavior between time t and the+-- time that the argument event occurs (including the value when the event occurs). +sampleUntil :: Eq a => Behavior a -> Event () -> Behavior (Event [a])+sampleUntil b end = loop [] where+ loop ss = do s <- b+ let ss' = s : ss+ e <- hasOccured end+ if e then return (pure (reverse ss'))+ else do c <- change b+ join <$> plan (loop ss' <$ c)+++-- | Convert an event into a behavior that gives +-- @Nothing@ if the event has not occured yet, and @Just@ the value of the event if the event has already occured.+tryGetEv :: Event a -> Behavior (Maybe a)+tryGetEv e = pure Nothing `switch` ((pure . Just) <$> e)++-- | The resulting behavior states wheter the input event has already occured.+hasOccured :: Event x -> Behavior Bool+hasOccured e = False `step` (pure True <$ e)++-- | Gives the first of two events. +-- +-- If either of the events lies in the future, then the result will be the first of these events.+-- If both events have already occured, the left event is returned.+first :: Event a -> Event a -> Behavior (Event a)+first l r = whenJust (tryGetEv r `switch` ((pure . Just) <$> l))++-- | Compare the time of two events.+-- +-- The resulting behavior gives an event, occuring at the same time +-- as the earliest input event, of which the value indicates if the event where+-- simultanious, or if one was earlier. +--+-- If at the time of sampling both event lie in the past, then +-- the result is that they are simulatinous.+cmpTime :: Event a -> Event b -> Behavior (Event (EvOrd a b))+cmpTime l r = whenJust (outcome <$> tryGetEv l <*> tryGetEv r) where+ outcome Nothing Nothing = Nothing+ outcome (Just x) Nothing = Just (LeftEarlier x)+ outcome Nothing (Just y) = Just (RightEarlier y)+ outcome (Just x) (Just y) = Just (Simul x y)++-- | The outcome of a 'cmpTime': the events occur simultanious, left is earlier or right is earlier.+data EvOrd l r = Simul l r+ | LeftEarlier l+ | RightEarlier r+++-- | Plan to sample the behavior carried by the event as soon as possible. +-- +-- If the resulting behavior is sampled after the event occurs,+-- then the behavior carried by the event will be sampled now.+planB :: Event (Behavior a) -> Behavior (Event a)+planB e = whenJust + (pure Nothing `switch` ((Just <$>) <$> e)) +++-- | Obtain the value of the behavior at the time the event occurs+--+-- If the event has already occured when sampling the resulting behavior,+-- we sample not the past, but the current value of the input behavior.+snapshot :: Behavior a -> Event () -> Behavior (Event a)+snapshot b e = let e' = (Just <$> b) <$ e+ in whenJust (pure Nothing `switch` e')++-- | Like 'snapshot', but feeds the result of the event to the+-- value of the given behavior at that time.+(<@>) :: Behavior (a -> b) -> Event a -> Behavior (Event b)+b <@> e = plan $ fmap (\x -> b <*> pure x) e+++++-- | A type class to unifying 'planNow' and 'planB'+class Monad b => Plan b where+ plan :: Event (b a) -> b (Event a)++instance Plan Now where plan = planNow+instance Plan Behavior where plan = planB++-- | A type class for behavior-like monads, such 'Now' and the monads from "Control.FRPNow.BehaviorEnd"+class Monad n => Sample n where+ sample :: Behavior a -> n a++instance Sample Behavior where sample = id+instance Sample Now where sample = sampleNow+++++-- | A debug function, prints all values of the behavior to stderr, prepended with the given string.+traceChanges :: (Eq a, Show a) => String -> Behavior a -> Now ()+traceChanges s b = loop where+ loop = do v <- sample b+ sync $ traceIO (s ++ show v)+ e <- sample $ change b+ planNow (loop <$ e)+ return ()
+ Control/FRPNow/Private/PrimEv.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE LambdaCase #-}+module Control.FRPNow.Private.PrimEv(Round, Clock, PrimEv, newClock , callbackp, spawn, spawnOS, curRound, newRound ,observeAt ) where++import Control.Applicative+import System.IO.Unsafe+import Data.IORef+import Data.Unique+import Control.Concurrent+import Debug.Trace++data Clock = Clock {+ identClock :: Unique,+ scheduleRound :: IO (),+ roundRef :: IORef Integer,+ changedRef :: IORef Bool }++data Round = Round Unique Integer+data PrimEv a = PrimEv Unique (IORef (Maybe (Round, a)))++instance Show Round where+ show (Round _ i) = show i+++-- when given a IO action that schedules a round, create a new clock+newClock :: IO () -> IO Clock+newClock schedule = Clock <$> newUnique <*> pure schedule <*> newIORef 0 <*> newIORef False++callbackp :: Clock -> IO (PrimEv a, a -> IO ())+callbackp c =+ do mv <- newIORef Nothing+ return (PrimEv (identClock c) mv, setValue mv)+ where setValue mv x =+ do i <- readIORef (roundRef c)+ v <- readIORef mv+ case v of+ Just _ -> error "Already called callback!"+ _ -> return ()+ writeIORef mv (Just (Round (identClock c) (i + 1), x))+ writeIORef (changedRef c) True+ scheduleRound c++spawn :: Clock -> IO a -> IO (PrimEv a)+spawn c m =+ do (pe,setVal) <- callbackp c+ forkIO $ m >>= setVal + return pe++spawnOS :: Clock -> IO a -> IO (PrimEv a)+spawnOS c m =+ do (pe,setVal) <- callbackp c+ forkOS $ m >>= setVal + return pe++curRound :: Clock -> IO Round+curRound c = Round (identClock c) <$> readIORef (roundRef c)++newRound :: Clock -> IO Bool+newRound c =+ readIORef (changedRef c) >>= \change ->+ if change + then do writeIORef (changedRef c) False+ modifyIORef (roundRef c) (+1)+ return True+ else return False+ ++++observeAt :: PrimEv a -> Round -> Maybe a+observeAt (PrimEv uv m) (Round ur t)+ | uv /= ur = error "Observation of TIVar from another context!"+ | otherwise = unsafePerformIO $+ do v <- readIORef m+ return $ case v of+ Just (Round _ t',a) | t' <= t -> Just a+ _ -> Nothing++instance Eq Round where+ (Round lu lt) == (Round ru rt) | lu == ru = lt == rt+ | otherwise = error "Rounds not from same clock!"++instance Ord Round where+ compare (Round lu lt) (Round ru rt)+ | lu == ru = compare lt rt+ | otherwise = error "Rounds not from same clock!"
+ Control/FRPNow/Private/Ref.hs view
@@ -0,0 +1,24 @@+module Control.FRPNow.Private.Ref where++import System.Mem.Weak+import Control.Applicative+import Data.IORef+import Debug.Trace++data Ref a = W (Weak a)+ | S a+++makeWeakIORef :: IORef a -> IO (Ref (IORef a))+makeWeakIORef v = W <$> mkWeakIORef v (return ())+{-+makeWeakRef :: k -> v -> IO (Ref v)+makeWeakRef k v = W <$> mkWeak k v Nothing+-}+makeStrongRef :: v -> IO (Ref v)+makeStrongRef v = return $ S v+++deRef :: Ref a -> IO (Maybe a)+deRef (S a) = return (Just a)+deRef (W a) = deRefWeak a
+ Control/FRPNow/Time.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Control.FRPNow.Time+-- Copyright : (c) Atze van der Ploeg 2015+-- License : BSD-style+-- Maintainer : atzeus@gmail.org+-- Stability : provisional+-- Portability : portable+-- +-- Various utility functions for FRPNow related to the passing of time.+-- All take a "clock" as an argument, i.e. a behavior that+-- gives the seconds since the program started.+--+-- The clock itself is created by a function specialized to the+-- GUI library you are using FRP with such as 'Control.FRPNow.GTK.getClock'++module Control.FRPNow.Time(localTime,timeFrac, lastInputs, bufferBehavior,delayBy, delayByN) where++import Control.FRPNow.Core+import Control.FRPNow.Lib+import Control.FRPNow.EvStream+import Data.Sequence+import Control.Applicative hiding (empty)+import Data.Foldable+import Debug.Trace+++++-- | When sampled at time t, gives the time since time t+localTime :: (Floating time, Ord time) => Behavior time -> Behavior (Behavior time)+localTime t = do n <- t+ return ((\x -> x - n) <$> t)++-- | Gives a behavior that linearly increases from 0 to 1 in the specified duration+timeFrac :: (Floating time, Ord time) => Behavior time -> time -> Behavior (Behavior time)+timeFrac t d = do t' <- localTime t+ e <- when $ (>= d) <$> t'+ let frac = (\x -> min 1.0 (x / d)) <$> t'+ return (frac `switch` (pure 1.0 <$ e))+++-- | Tag the events in a stream with their time+tagTime :: (Floating time, Ord time) => Behavior time -> EvStream a -> EvStream (time,a)+tagTime c s = ((,) <$> c) <@@> s++-- | Gives a behavior containing the values of the events in the stream that occured in the last n seconds+lastInputs :: (Floating time, Ord time) => + Behavior time -- ^ The "clock" behavior, the behavior monotonically increases with time+ -> time -- ^ The duration of the history to be kept+ -> EvStream a -- ^ The input stream+ -> Behavior (Behavior [a])+lastInputs clock dur s = do s' <- bufferStream clock dur s+ bs <- fromChanges [] s'+ let dropIt cur s = dropWhile (\(t,_) -> t + dur < cur) s+ return $ (fmap snd) <$> (dropIt <$> clock <*> bs)++bufferStream :: (Floating time, Ord time) => Behavior time -> time -> EvStream a -> Behavior (EvStream [(time,a)])+bufferStream clock dur s = do s' <- scanlEv addDrop empty $ tagTime clock s+ return $ toList <$> s' where+ addDrop ss s@(last,v) = dropWhileL (\(tn,_) -> tn + dur < last) (ss |> s)+++data TimeTag t a = TimeTag t a++instance Eq t => Eq (TimeTag t a) where+ (TimeTag t1 _) == (TimeTag t2 _) = t1 == t2++++-- | Gives a behavior containing the values of the behavior during the last n seconds, with time stamps+bufferBehavior :: (Floating time, Ord time) =>+ Behavior time -- ^ The "clock" behavior, the behavior monotonically increases with time+ -> time -- ^ The duration of the history to be kept+ -> Behavior a -- ^ The input behavior+ -> Behavior (Behavior [(time,a)])+bufferBehavior clock dur b = fmap toList <$> foldB update empty (TimeTag <$> clock <*> b)+ where update l (TimeTag now x) = trimList (l |> (now,x)) (now - dur)+ trimList l after = loop l where+ loop l = + case viewl l of+ EmptyL -> empty+ (t1,v1) :< tail1 + | after <= t1 -> l + | otherwise -> + case viewl tail1 of+ (t2,v2) :< tail2 + | t2 <= after -> loop tail2+ | otherwise -> l+++-- | Give a version of the behavior delayed by n seconds+delayBy :: (Floating time, Ord time) =>+ Behavior time -- ^ The "clock" behavior, the behavior monotonically increases with time+ -> time -- ^ The duration of the delay+ -> Behavior a -- ^ The input behavior+ -> Behavior (Behavior a)+delayBy time d b = fmap (snd . head) <$> bufferBehavior time d b+++-- | Give n delayed versions of the behavior, each with the given duration in delay between them. +delayByN :: (Floating time, Ord time) => + Behavior time -- ^ The "clock" behavior, the behavior monotonically increases with time+ -> time -- ^ The duration _between_ delayed versions+ -> Integer -- ^ The number of delayed versions + -> Behavior a -- ^ The input behavior+ -> Behavior (Behavior [a])+delayByN clock dur n b =+ let durN = (fromIntegral n) * dur+ in do samples <- bufferBehavior clock durN b+ return $ interpolateFromList <$> clock <*> samples where+ interpolateFromList now l= loop (n - 1) l where+ loop n l = + if n < 0 then []+ else let sampleTime = now - (fromIntegral n * dur)+ in case l of+ [] -> []+ [(_,v)] -> v : loop (n-1) l+ ((t1,v1) : (t2,v2) : rest)+ | sampleTime >= t2 -> loop n ((t2,v2) : rest)+ | otherwise -> v1 : loop (n-1) l+ ++
+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2015, Atze van der Ploeg+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the Atze van der Ploeg nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ frpnow.cabal view
@@ -0,0 +1,23 @@+Name: frpnow+Version: 0.1+Synopsis: Principled practical FRP+Description: FRP with first-class behaviors and interalized IO, without space leaks+License: BSD3+License-file: LICENSE+Author: Atze van der Ploeg+Maintainer: atzeus@gmail.com+Homepage: https://github.com/atzeus/FRPNow+Build-Type: Simple+Cabal-Version: >=1.6+Data-files: ChangeLog+Category: Control+Tested-With: GHC==7.10.1+Library+ Build-Depends: base >= 2 && <= 6, mtl >= 1.0, containers, transformers+ Exposed-modules: Control.FRPNow,Control.FRPNow.Core, Control.FRPNow.Lib, Control.FRPNow.EvStream, Control.FRPNow.Time, Control.FRPNow.BehaviorEnd+ other-modules: Control.FRPNow.Private.PrimEv, Control.FRPNow.Private.Ref+ Extensions: RankNTypes, GADTs, CPP, EmptyDataDecls++source-repository head+ type: git+ location: https://github.com/atzeus/FRPNow