diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,4 @@ +0.14 Fixes a space leak, fixes integration being factor 2 off 0.13 Removed Show from integrate, added cstep 0.12 Fixed BehaviorFix, added integration 0.11 Fixed import applicative diff --git a/Control/FRPNow/Core.hs b/Control/FRPNow/Core.hs --- a/Control/FRPNow/Core.hs +++ b/Control/FRPNow/Core.hs @@ -26,6 +26,8 @@ runNowMaster, initNow) where import Control.Concurrent.Chan +import Control.Exception +import Data.Typeable import Control.Applicative hiding (empty,Const) import Control.Monad hiding (mapM_) import Control.Monad.IO.Class @@ -92,6 +94,11 @@ | Occ a | E (M (Event a)) +newtype EInternal a = EInternal { runEInternal :: M (Either (EInternal a) (Event a)) } + +data State = Update + | Redirect + runE :: Event a -> M (Event a) runE Never = return Never runE (Occ x) = return (Occ x) @@ -100,7 +107,9 @@ instance Monad Event where return = Occ - e >>= f = memoE (e `bindE` f) + Never >>= _ = Never + (Occ x) >>= f = f x + (E m) >>= f = memoE $ bindInternal m f -- | A never occuring event @@ -108,37 +117,64 @@ 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 +setE :: a -> Event x -> Event a +setE _ Never = Never +setE a (Occ _) = Occ a +setE a (E m) = E $ setE a <$> m -bindEM :: M (Event a) -> (a -> Event b) -> M (Event b) -m `bindEM` f = +bindInternal :: M (Event a) -> (a -> Event b) -> EInternal b +m `bindInternal` f = EInternal $ m >>= \r -> case r of - Never -> return Never - Occ x -> runE (f x) - E m' -> return (E $ m' `bindEM` f) --- Section 6.2 + Never -> return (Right Never) + Occ x -> Right <$> runE (f x) + E m' -> return (Left $ m' `bindInternal` f) +minTime Never r = setE () r +minTime l Never = setE () l +minTime (Occ _) _ = Occ () +minTime _ (Occ _) = Occ () +minTime (E ml) (E mr) = memoE $ minInternal ml mr -memoEIO :: Event a -> IO (Event a) +minInternal :: M (Event a) -> M (Event b) -> EInternal () +minInternal ml mr = EInternal $ + do er <- mr + case er of + Occ x -> return (Right (Occ ())) + Never -> return (Right (setE () $ E ml)) + E mr' -> do el <- ml + return $ case el of + Occ x -> Right (Occ ()) + Never -> Right (setE () $ E mr') + E ml' -> Left (minInternal ml' mr') + + + +memoEIO :: EInternal a -> IO (Event a) memoEIO einit = - do r <- newIORef einit + do r <- newIORef (Left einit,Nothing ) 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 +usePrevE :: IORef (Either (EInternal a) (Event a), (Maybe (Round, Event a))) -> Event a +usePrevE r = self where + self = E $ + do (s,cached) <- liftIO (readIORef r) + round <- getRound + case cached of + Just (cr,cache) | cr == round -> return cache + _ -> case s of + Left ei -> do ri <- runEInternal ei + case ri of + Left _ -> do liftIO (writeIORef r (ri,Just (round,self) ) ) + return self + Right e -> do liftIO (writeIORef r (ri, Just (round,e)) ) + return e + Right e -> do e' <- runE e + liftIO (writeIORef r (Right e', Just (round,e'))) + return e' -memoE :: Event a -> Event a +memoE :: EInternal a -> Event a --memoE e = e -memoE Never = Never -memoE (Occ x) = Occ x memoE e = unsafePerformIO $ memoEIO e -- Section 6.3 @@ -148,73 +184,121 @@ data Behavior a = B (M (a, Event (Behavior a))) | Const a +data BInternal a = BInternal { runBInternal :: M (Either (BInternal a, a, Event ()) (Behavior a)) } + +memoBIIO :: BInternal a -> IO (Behavior a) +memoBIIO einit = + do r <- newIORef (Left einit, Nothing) + return (usePrevBI r) + +usePrevBI :: IORef (Either (BInternal a) (Behavior a), Maybe (a, Event (Behavior a)) ) -> Behavior a +usePrevBI r = self where + self = B $ + do (s,cached) <- liftIO (readIORef r) + case cached of + Just (cache@(i,ev)) -> + do ev' <- runE ev + case ev' of + Occ x -> update s + _ -> do liftIO (writeIORef r (s, Just (i,ev'))) + return (i,ev') + Nothing -> update s + update s = case s of + Left ei -> do ri <- runBInternal ei + case ri of + Left (bi',i,e) -> + do let res = (i, setE self e) + liftIO (writeIORef r (Left bi',Just res)) + return res + Right b -> do res@(h,t) <- runB b + liftIO (writeIORef r (Right (rerunBh res), Just res)) + return res + Right b -> do res@(h,t) <- runB b + liftIO (writeIORef r (Right (rerunBh res), Just res)) + return res + +memoBInt :: BInternal a -> Behavior a +--memoE e = e +memoBInt e = unsafePerformIO $ memoBIIO e + 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 $ - -- liftIO (traceIO "switching!") >> - em >>= \r -> - -- liftIO (traceIO "ran ev") >> - 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') +rerunBh :: (a,Event(Behavior a)) -> Behavior a +rerunBh (h,Never) = Const h +rerunBh (h,t) = B $ runE t >>= \x -> case x of + Occ b -> runB b + t' -> return (h,t') -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' +rerunB :: a -> Event (Behavior a) -> M (a, Event (Behavior a)) +rerunB h Never = return (h, Never) +rerunB h t = runE t >>= \x -> case x of + Occ b -> runB b + t' -> return (h,t') +switchInternal :: M (a, Event (Behavior a)) -> M (Event (Behavior a)) -> BInternal a +switchInternal mb me = BInternal $ + do e <- me + case e of + Occ x -> return (Right x) + Never -> return (Right (B mb)) + E me' -> do (i,ei) <- mb + return $ Left (switchInternal (rerunB i ei) me', i, minTime ei e) + +stepInternal :: a -> M (Event (Behavior a)) -> BInternal a +stepInternal i me =BInternal $ + do e <- me + return $ case e of + Occ x -> Right x + Never -> Right (Const i) + E me' -> Left (stepInternal i me', i, setE () e) + +bindBInternal :: M (a,Event (Behavior a)) -> (a -> Behavior b) -> BInternal b +bindBInternal m f = + BInternal $ + do (h,t) <- m + case t of + Never -> return $ Right (f h) + Occ _ -> error "invariant broken" + _ -> + case f h of + Const x -> return $ Left (bindBInternal (rerunB h t) f, x, setE () t) + B n -> do (hn,tn) <- n + return $ Left (bindBInternal (rerunB h t) f, hn, minTime t tn) + + + 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)) ) +bindB (B m) f = memoBInt $ bindBInternal m f +whenJustInternal :: M (Maybe a, Event (Behavior (Maybe a))) -> Behavior (Event a) -> BInternal (Event a) +whenJustInternal m outerSelf = BInternal $ + do (h, t) <- m + case t of + Never -> return $ Right $ pure $ case h of + Just x -> pure x + Nothing -> never + Occ _ -> error "invariant broken" + _ -> + case h of + Just x -> return $ Left (whenJustInternal (rerunB h t) outerSelf, return x, setE () t) + Nothing -> + do en <- planM (setE (runB outerSelf) t) + return $ Left (whenJustInternal (rerunB h t) outerSelf, en >>= fst, setE () t) 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) - +whenJust' (B m) = let x = memoBInt $ whenJustInternal m x + in x + +{- 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) @@ -224,10 +308,10 @@ Just x -> do v <- fst <$> runB x; return (pure v, whenJustSample' <$> t) Nothing -> do en <- planM (runB . whenJustSample' <$> t) return (en >>= fst, never) - +-} instance Monad Behavior where return x = B $ return (x, never) - m >>= f = memoB (m `bindB` f) + m >>= f = m `bindB` f instance MonadFix Behavior where mfix f = B $ mfix $ \(~(h,_)) -> @@ -242,9 +326,11 @@ -- -- 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) - +switch :: Behavior a -> Event (Behavior a) -> Behavior a +switch b Never = b +switch _ (Occ b) = b +switch (Const x) (E em) = memoBInt (stepInternal x em) +switch (B bm) (E em) = memoBInt (switchInternal bm em) -- | Observe a change over time. -- -- The behavior @whenJust b@ gives at any point in time the event that @@ -267,7 +353,7 @@ whenJust :: Behavior (Maybe a) -> Behavior (Event a) whenJust b = (whenJust' b) - +{- -- | A more optimized version of: -- -- > whenJustSample b = do x <- whenJust b @@ -275,7 +361,7 @@ whenJustSample :: Behavior (Maybe (Behavior a)) -> Behavior (Event a) whenJustSample b = memoB (whenJustSample' b) - +-} -- | Not typically needed, used for event streams. -- @@ -286,9 +372,8 @@ -- 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 +futuristic b = B $ do e <- makeLazy $ fst <$> runB b + return (e,futuristic b <$ e) unrunB :: (a,Event (Behavior a)) -> Behavior a unrunB (h, Never) = Const h @@ -296,7 +381,7 @@ 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 @@ -313,7 +398,7 @@ --memoB b = b memoB b@(Const _) = b memoB b = unsafePerformIO $ memoBIO b - +-} -- Section 6.7 @@ -338,8 +423,7 @@ -- 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) - +newtype Now a = Now { getNow :: M a } deriving (Functor,Applicative,Monad, MonadFix, MonadIO) -- | Sample the present value of a behavior sampleNow :: Behavior a -> Now a @@ -506,7 +590,7 @@ tryPlans = ReaderT $ tryEm where tryEm env = do pl <- readIORef (plansRef env) - -- putStrLn ("nr plans: " ++ show (length pl)) + --putStrLn ("nr plans: " ++ show (length pl)) writeIORef (plansRef env) [] runReaderT (mapM_ tryPlan (reverse pl)) env tryPlan (SomePlan pr) = @@ -534,7 +618,13 @@ Occ _ -> error "Forced lazy was not lazy!" e' -> liftIO $ writeIORef r e' +-- | When using the FRP system in master mode, with 'runNowMaster', this exception is thrown if +-- the FRP system is not doing anything anymore, waiting for 'never'. +data FRPWaitsForNeverException = FRPWaitsForNeverException deriving (Show, Typeable) + +instance Exception FRPWaitsForNeverException + -- | 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. @@ -548,7 +638,9 @@ initNow enqueue m loop chan where loop chan = - do m <- readChan chan + do m <- catch (readChan chan) + (\e -> do let err = (e :: BlockedIndefinitelyOnMVar) + throw FRPWaitsForNeverException) mr <- m case mr of Just x -> return x @@ -569,3 +661,4 @@ instance Applicative Event where pure = return (<*>) = ap + diff --git a/Control/FRPNow/EvStream.hs b/Control/FRPNow/EvStream.hs --- a/Control/FRPNow/EvStream.hs +++ b/Control/FRPNow/EvStream.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables,TypeOperators,MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} + + ----------------------------------------------------------------------------- -- | -- Module : Control.FRPNow.EvStream @@ -16,6 +19,7 @@ -- * Construction emptyEs, merge, +dropEv, toChanges, edges, -- * Folds and scans @@ -139,10 +143,18 @@ +dropEv :: Int -> EvStream a -> EvStream a +dropEv i (S s) = S $ loop i where + loop 0 = s + loop i = do e <- s + join <$> plan (loop (i-1) <$ e) + + -- | Filter the 'Just' values from an event stream. -- catMaybesEs :: EvStream (Maybe a) -> EvStream a catMaybesEs s = S $ loop where +-- loop :: Behavior (Event [a]) loop = do e <- getEs s join <$> plan (nxt <$> e) nxt l = case catMaybes l of @@ -264,10 +276,11 @@ -- | 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 :: forall a. Now (EvStream a, a -> IO ()) callbackStream = do mv <- sync $ newIORef ([], Nothing) (_,s) <- loop mv return (S s, func mv) where + loop :: IORef ( [a], Maybe (() -> IO ()) ) -> Now ([a], Behavior (Event [a])) loop mv = do (l, Nothing) <- sync $ readIORef mv (e,cb) <- callback diff --git a/Control/FRPNow/Private/PrimEv.hs b/Control/FRPNow/Private/PrimEv.hs --- a/Control/FRPNow/Private/PrimEv.hs +++ b/Control/FRPNow/Private/PrimEv.hs @@ -21,6 +21,7 @@ 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 diff --git a/Control/FRPNow/Time.hs b/Control/FRPNow/Time.hs --- a/Control/FRPNow/Time.hs +++ b/Control/FRPNow/Time.hs @@ -130,7 +130,7 @@ integrate time v = do t <- time vp <- delay time (t,zeroVector) ((,) <$> time <*> v) foldB add zeroVector $ (,) <$> vp <*> time - where add total ((t1,v),t2) = total ^+^ (((t2 - t1) * 0.5) *^ v) + where add total ((t1,v),t2) = total ^+^ ((t2 - t1) *^ v) -- | Delay a behavior by one tick of the clock. Occasionally useful to prevent immediate feedback loops. diff --git a/frpnow.cabal b/frpnow.cabal --- a/frpnow.cabal +++ b/frpnow.cabal @@ -1,5 +1,5 @@ Name: frpnow -Version: 0.13 +Version: 0.14 Synopsis: Principled practical FRP Description: FRP with first-class behaviors and interalized IO, without space leaks License: BSD3