├── ChangeLog ├── Control ├── FRPNow.hs └── FRPNow │ ├── BehaviorEnd.hs │ ├── Core.hs │ ├── EvStream.hs │ ├── Lib.hs │ ├── Private │ ├── PrimEv.hs │ └── Ref.hs │ └── Time.hs ├── Examples ├── GTK │ ├── CountClicks.hs │ ├── EnterCode.hs │ └── Sliders.hs ├── Gloss │ ├── Draw.hs │ ├── FollowMouse.hs │ ├── Simple.hs │ └── TimeFlows.hs └── Test.hs ├── FRPNow-GTK ├── ChangeLog ├── Control │ └── FRPNow │ │ └── GTK.hs ├── LICENSE ├── Setup.hs ├── frpnow-gtk.cabal └── frpnow-gtk.cabal~ ├── FRPNow-Gloss ├── ChangeLog ├── Control │ └── FRPNow │ │ └── Gloss.hs ├── LICENSE ├── Setup.hs └── frpnow-gloss.cabal ├── LICENSE ├── PaperImpl ├── ConcFlag.hs ├── EventStream.hs ├── FRPNow.hs ├── Lib.hs ├── PrimEv.hs ├── Ref.hs └── Test.hs ├── README.md ├── Setup.hs ├── extra.pdf └── frpnow.cabal /ChangeLog: -------------------------------------------------------------------------------- 1 | 0.17 Added EvStream.collapseSimul 2 | 0.17 Added EvStream.joinEs 3 | 0.16 Added EvStream.delay 4 | 0.15 Fixes a Prelude.undefined error 5 | 0.14 Fixes a space leak, fixes integration being factor 2 off 6 | 0.13 Removed Show from integrate, added cstep 7 | 0.12 Fixed BehaviorFix, added integration 8 | 0.11 Fixed import applicative 9 | 0.1 Initial version 10 | -------------------------------------------------------------------------------- /Control/FRPNow.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.FRPNow 4 | -- Copyright : (c) Atze van der Ploeg 2015 5 | -- License : BSD-style 6 | -- Maintainer : atzeus@gmail.org 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- An FRP library with first-class and higher-order behaviors, and internalized IO. 11 | -- 12 | -- Based on the paper , ICFP 2015, by Atze van der Ploeg and Koenem Claessem. 13 | -- 14 | -- 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' 15 | -- 16 | -- 17 | -- To understand what is going on, I suggest you look at the , and read section 1-5 of the . 18 | -- 19 | -- The package contains the following modules: 20 | -- 21 | -- [@Core@] The core FRP primitives with denotational semantics. 22 | -- [@Lib@] Utility functions. 23 | -- [@EvStream@] Event streams. 24 | -- [@Time@] Utility functions related to passing the of time. 25 | -- [@BehaviorEnd@] A monadic abstraction for behaviors consisting of multiple phases (a bit advanced stuff, not needed to get going). 26 | 27 | module Control.FRPNow( module Control.FRPNow.Core, module Control.FRPNow.Lib, module Control.FRPNow.EvStream, module Control.FRPNow.Time, module Control.FRPNow.BehaviorEnd) where 28 | 29 | import Control.FRPNow.Core 30 | import Control.FRPNow.Lib 31 | import Control.FRPNow.EvStream 32 | import Control.FRPNow.Time 33 | import Control.FRPNow.BehaviorEnd 34 | -------------------------------------------------------------------------------- /Control/FRPNow/BehaviorEnd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DoAndIfThenElse, FlexibleInstances , MultiParamTypeClasses,GADTs, TypeOperators, TupleSections, ScopedTypeVariables,ConstraintKinds,FlexibleContexts,UndecidableInstances #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Control.FRPNow.Until 5 | -- Copyright : (c) Atze van der Ploeg 2015 6 | -- License : BSD-style 7 | -- Maintainer : atzeus@gmail.org 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- The until abstraction, and related definitions. 12 | -- 13 | -- 14 | -- A value of type @BehaviorEnd@ is a behavior and an ending event. 15 | -- This also forms a monad, such that we can write 16 | -- 17 | -- > do a1 `Until` e1 18 | -- > b1 `Until` e2 19 | -- 20 | -- for behaviors consisting of multiple phases. 21 | -- This concept is similar to "Monadic FRP" (Haskell symposium 2013, van der Ploeg) and 22 | -- the Task monad abstraction (Lambda in motion: Controlling robots with haskell, Peterson, Hudak and Elliot, PADL 1999) 23 | module Control.FRPNow.BehaviorEnd( 24 | -- * Until 25 | BehaviorEnd(..), combineUntil, (.:),parList, 26 | -- * Derived monads 27 | -- $compose 28 | 29 | till, 30 | (:.)(..), 31 | Swap(..), 32 | liftLeft, 33 | liftRight) 34 | where 35 | import Control.FRPNow.Core 36 | import Control.FRPNow.Lib 37 | import Control.FRPNow.EvStream 38 | import Control.Monad 39 | import Control.Applicative 40 | 41 | data BehaviorEnd x a = Until { behavior :: Behavior x, end :: Event a } 42 | 43 | instance Monad (BehaviorEnd x) where 44 | return x = pure (error "ended!") `Until` pure x 45 | (b `Until` e) >>= f = 46 | let v = f <$> e 47 | b' = b `switch` (behavior <$> v) 48 | e' = v >>= end 49 | in b' `Until` e' 50 | 51 | instance Functor (BehaviorEnd x) where fmap = liftM 52 | instance Applicative (BehaviorEnd x) where pure = return ; (<*>) = ap 53 | 54 | -- | Combine the behavior of the @Until@ and the other behavior until the 55 | -- with the given function until the end event happens. 56 | combineUntil :: (a -> b -> b) -> BehaviorEnd a x -> Behavior b -> Behavior b 57 | combineUntil f (bx `Until` e) b = (f <$> bx <*> b) `switch` fmap (const b) e 58 | 59 | -- | Add the values in the behavior of the @Until@ to the front of the list 60 | -- until the end event happens. 61 | (.:) :: BehaviorEnd a x -> Behavior [a] -> Behavior [a] 62 | (.:) = combineUntil (:) 63 | 64 | -- | Given an eventstream that spawns behaviors with an end, 65 | -- returns a behavior with list of the values of currently active 66 | -- behavior ends. 67 | parList :: EvStream (BehaviorEnd b ()) -> Behavior (Behavior [b]) 68 | parList = foldBs (pure []) (flip (.:)) 69 | 70 | -- $compose 71 | -- The monad for @Until@ is a bit restrictive, because we cannot sample other behaviors 72 | -- in this monad. For this reason we also define a monad for @(Behavior :. Until x)@, 73 | -- where @ :. @ is functor composition, which can sample other monads. 74 | -- This relies on the @swap@ construction from "Composing monads", Mark Jones and Luc Duponcheel. 75 | -- 76 | 77 | -- | Like 'Until', but the event can now be generated by a behavior (@Behavior (Event a)@) or even 78 | -- (@Now (Event a)@). 79 | -- 80 | -- Name is not "until" to prevent a clash with 'Prelude.until'. 81 | till :: Swap b (BehaviorEnd x) => 82 | Behavior x -> b (Event a) -> (b :. BehaviorEnd x) a 83 | till b e = liftLeft e >>= liftRight . (b `Until`) 84 | 85 | instance (Swap b e, Sample b) => Sample (b :. e) where sample b = liftLeft (sample b) 86 | 87 | assoc :: Functor f => ((f :. g) :. h) x -> (f :. (g :. h)) x 88 | assoc = Close . fmap Close . open . open 89 | 90 | coassoc :: Functor f => (f :. (g :. h)) x -> ((f :. g) :. h) x 91 | coassoc = Close . Close . fmap open . open 92 | 93 | instance (Functor a, Functor b) => Functor (a :. b) where 94 | fmap f = Close . fmap (fmap f) . open 95 | 96 | -- | Composition of functors. 97 | newtype (f :. g) x = Close { open :: f (g x) } 98 | 99 | -- | Lift a value from the left monad into the composite monad. 100 | liftLeft :: (Monad f, Monad g) => f x -> (f :. g) x 101 | liftLeft = Close . liftM return 102 | 103 | -- | Lift a value from the right monad into the composite monad. 104 | liftRight :: Monad f => g x -> (f :. g) x 105 | liftRight = Close . return 106 | 107 | 108 | class (Monad f, Monad g) => Swap f g where 109 | -- | Swap the composition of two monads. 110 | -- Laws (from Composing Monads, Jones and Duponcheel) 111 | -- 112 | -- > swap . fmap (fmap f) == fmap (fmap f) . swap 113 | -- > swap . return == fmap unit 114 | -- > swap . fmap return == return 115 | -- > prod . fmap dorp == dorp . prod 116 | -- > where prod = fmap join . swap 117 | -- > dorp = join . fmap swap 118 | swap :: g (f a) -> f (g a) 119 | 120 | instance Plan b => Swap b Event where 121 | swap = plan 122 | 123 | instance (Monad b, Plan b) => Swap b (BehaviorEnd x) where 124 | swap (Until b e) = liftM (Until b) (plan e) 125 | 126 | instance Swap f g => Monad (f :. g) where 127 | -- see (Composing Monads, Jones and Duponcheel) for proof 128 | return = Close . return . return 129 | m >>= f = joinComp (fmap2m f m) 130 | 131 | -- annoyance that Monad is not a subclass of functor 132 | fmap2m f = Close . liftM (liftM f) . open 133 | 134 | joinComp :: (Swap b e) => (b :. e) ((b :. e) x) -> (b :. e) x 135 | joinComp = Close . joinFlip . open . fmap2m open 136 | 137 | joinFlip :: (Swap b e, Monad e, Monad b) => b (e (b (e x))) -> b (e x) 138 | joinFlip = liftM join . join . liftM swap 139 | -- this works as follows, we have 140 | -- b . e . b . e flip middle two 141 | -- b . b . e . e join left and right 142 | -- b . e 143 | 144 | 145 | instance (Applicative b, Applicative e) => Applicative (b :. e) where 146 | pure = Close . pure . pure 147 | x <*> y = Close $ (<*>) <$> open x <*> open y 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | -------------------------------------------------------------------------------- /Control/FRPNow/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, RecursiveDo, FlexibleContexts, ExistentialQuantification, Rank2Types,GeneralizedNewtypeDeriving #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | 5 | -- Module : Control.FRPNow.Core 6 | -- Copyright : (c) Atze van der Ploeg 2015 7 | -- License : BSD-style 8 | -- Maintainer : atzeus@gmail.org 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- 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. 13 | -- 14 | -- This module contains the core FRPNow interface, which consists of: 15 | -- 16 | -- * The pure interface, which has denotational semantics 17 | -- * The IO interface 18 | -- * The entry points, i.e. the functions that are used to start the FRP system. 19 | 20 | module Control.FRPNow.Core( 21 | -- * Pure interface 22 | -- $time 23 | Event,Behavior, never, switch, whenJust, futuristic, 24 | -- * IO interface 25 | Now, async, asyncOS, callback, sampleNow, planNow, sync, 26 | -- * Entry point 27 | runNowMaster, 28 | initNow) where 29 | import Control.Concurrent.Chan 30 | import Control.Exception 31 | import Data.Typeable 32 | import Control.Applicative hiding (empty,Const) 33 | import Control.Monad hiding (mapM_) 34 | import Control.Monad.IO.Class 35 | import Control.Monad.Reader hiding (mapM_) 36 | import Control.Monad.Writer hiding (mapM_) 37 | import Data.IORef 38 | import Control.FRPNow.Private.Ref 39 | import Control.FRPNow.Private.PrimEv 40 | import System.IO.Unsafe 41 | import Debug.Trace 42 | 43 | import Prelude 44 | 45 | {-------------------------------------------------------------------- 46 | Pure interface 47 | --------------------------------------------------------------------} 48 | 49 | -- $time 50 | -- The FRPNow interface is centered around behaviors, values that change over time, and events, values that are known from some point in time on. 51 | -- 52 | -- What the pure part of the FRPNow interface does is made precise by denotational semantics, i.e. mathematical meaning. The denotational semantics of the pure interface are 53 | -- 54 | -- @ 55 | -- type Event a = (Time+,a) 56 | -- 57 | -- never :: Event a 58 | -- never = (∞, undefined) 59 | -- 60 | -- instance Monad Event where 61 | -- return x = (-∞,x) 62 | -- (ta,a) >>= f = let (tb,b) = f a 63 | -- in (max ta tb, b) 64 | -- 65 | -- type Behavior a = Time -> a 66 | -- 67 | -- instance Monad Behavior where 68 | -- return x = λt -> x 69 | -- m >>= f = λt -> f (m t) t 70 | -- 71 | -- instance MonadFix Behavior where 72 | -- mfix f = λt -> let x = f x t in x 73 | -- 74 | -- switch :: Behavior a -> Event (Behavior a) -> Behavior a 75 | -- switch b (ts,s) = λn -> 76 | -- if n < ts then b n else s n 77 | -- 78 | -- whenJust :: Behavior (Maybe a) -> Behavior (Event a) 79 | -- whenJust b = λt -> 80 | -- let w = minSet { t' | t' >= t && isJust (b t') } 81 | -- in if w == ∞ then never 82 | -- else (w, fromJust (b w)) 83 | -- @ 84 | -- 85 | -- Where @Time@ is a set that is totally ordered set and has a least element, -∞. 86 | -- For events, we also use @Time+ = Time ∪ ∞@. 87 | -- 88 | -- 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 @∞@. 89 | -- 90 | -- 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. 91 | 92 | -- | An event is a value that is known from some point in time on. 93 | data Event a 94 | = Never 95 | | Occ a 96 | | E (M (Event a)) 97 | 98 | newtype EInternal a = EInternal { runEInternal :: M (Either (EInternal a) (Event a)) } 99 | 100 | data State = Update 101 | | Redirect 102 | 103 | runE :: Event a -> M (Event a) 104 | runE Never = return Never 105 | runE (Occ x) = return (Occ x) 106 | runE (E m) = m 107 | 108 | 109 | instance Monad Event where 110 | return = Occ 111 | Never >>= _ = Never 112 | (Occ x) >>= f = f x 113 | (E m) >>= f = memoE $ bindInternal m f 114 | 115 | 116 | -- | A never occurring event 117 | 118 | never :: Event a 119 | never = Never 120 | 121 | 122 | setE :: a -> Event x -> Event a 123 | setE _ Never = Never 124 | setE a (Occ _) = Occ a 125 | setE a (E m) = E $ setE a <$> m 126 | 127 | bindInternal :: M (Event a) -> (a -> Event b) -> EInternal b 128 | m `bindInternal` f = EInternal $ 129 | m >>= \r -> case r of 130 | Never -> return (Right Never) 131 | Occ x -> Right <$> runE (f x) 132 | E m' -> return (Left $ m' `bindInternal` f) 133 | 134 | minTime Never r = setE () r 135 | minTime l Never = setE () l 136 | minTime (Occ _) _ = Occ () 137 | minTime _ (Occ _) = Occ () 138 | minTime (E ml) (E mr) = memoE $ minInternal ml mr 139 | 140 | minInternal :: M (Event a) -> M (Event b) -> EInternal () 141 | minInternal ml mr = EInternal $ 142 | do er <- mr 143 | case er of 144 | Occ x -> return (Right (Occ ())) 145 | Never -> return (Right (setE () $ E ml)) 146 | E mr' -> do el <- ml 147 | return $ case el of 148 | Occ x -> Right (Occ ()) 149 | Never -> Right (setE () $ E mr') 150 | E ml' -> Left (minInternal ml' mr') 151 | 152 | 153 | 154 | memoEIO :: EInternal a -> IO (Event a) 155 | memoEIO einit = 156 | do r <- newIORef (Left einit,Nothing ) 157 | return (usePrevE r) 158 | 159 | usePrevE :: IORef (Either (EInternal a) (Event a), (Maybe (Round, Event a))) -> Event a 160 | usePrevE r = self where 161 | self = E $ 162 | do (s,cached) <- liftIO (readIORef r) 163 | round <- getRound 164 | case cached of 165 | Just (cr,cache) | cr == round -> return cache 166 | _ -> case s of 167 | Left ei -> do ri <- runEInternal ei 168 | case ri of 169 | Left _ -> do liftIO (writeIORef r (ri,Just (round,self) ) ) 170 | return self 171 | Right e -> do liftIO (writeIORef r (ri, Just (round,e)) ) 172 | return e 173 | Right e -> do e' <- runE e 174 | liftIO (writeIORef r (Right e', Just (round,e'))) 175 | return e' 176 | 177 | memoE :: EInternal a -> Event a 178 | --memoE e = e 179 | memoE e = unsafePerformIO $ memoEIO e 180 | 181 | -- Section 6.3 182 | 183 | -- | A behavior is a value that changes over time. 184 | 185 | data Behavior a = B (M (a, Event (Behavior a))) 186 | | Const a 187 | 188 | data BInternal a = BInternal { runBInternal :: M (Either (BInternal a, a, Event ()) (Behavior a)) } 189 | 190 | 191 | memoBIIO :: BInternal a -> IO (Behavior a) 192 | memoBIIO einit = 193 | do r <- newIORef (Left einit, Nothing) 194 | return (usePrevBI r) 195 | 196 | usePrevBI :: IORef (Either (BInternal a) (Behavior a), Maybe (a, Event (Behavior a)) ) -> Behavior a 197 | usePrevBI r = self where 198 | self = B $ 199 | do (s,cached) <- liftIO (readIORef r) 200 | case cached of 201 | Just (cache@(i,ev)) -> 202 | do ev' <- runE ev 203 | case ev' of 204 | Occ x -> update s 205 | _ -> do liftIO (writeIORef r (s, Just (i,ev'))) 206 | return (i,ev') 207 | Nothing -> update s 208 | update s = case s of 209 | Left ei -> do ri <- runBInternal ei 210 | case ri of 211 | Left (bi',i,e) -> 212 | do let res = (i, setE self e) 213 | liftIO (writeIORef r (Left bi',Just res)) 214 | return res 215 | Right b -> do res@(h,t) <- runB b 216 | liftIO (writeIORef r (Right (rerunBh res), Just res)) 217 | return res 218 | Right b -> do res@(h,t) <- runB b 219 | liftIO (writeIORef r (Right (rerunBh res), Just res)) 220 | return res 221 | 222 | memoBInt :: BInternal a -> Behavior a 223 | --memoE e = e 224 | memoBInt e = unsafePerformIO $ memoBIIO e 225 | 226 | runB :: Behavior a -> M (a, Event (Behavior a)) 227 | runB (B m) = m 228 | runB (Const a) = return (a, never) 229 | 230 | rerunBh :: (a,Event(Behavior a)) -> Behavior a 231 | rerunBh (h,Never) = Const h 232 | rerunBh (h,t) = B $ runE t >>= \x -> case x of 233 | Occ b -> runB b 234 | t' -> return (h,t') 235 | 236 | rerunB :: a -> Event (Behavior a) -> M (a, Event (Behavior a)) 237 | rerunB h Never = return (h, Never) 238 | rerunB h t = runE t >>= \x -> case x of 239 | Occ b -> runB b 240 | t' -> return (h,t') 241 | 242 | 243 | switchInternal :: M (a, Event (Behavior a)) -> M (Event (Behavior a)) -> BInternal a 244 | switchInternal mb me = BInternal $ 245 | do e <- me 246 | case e of 247 | Occ x -> return (Right x) 248 | Never -> return (Right (B mb)) 249 | E me' -> do (i,ei) <- mb 250 | return $ Left (switchInternal (rerunB i ei) me', i, minTime ei e) 251 | 252 | stepInternal :: a -> M (Event (Behavior a)) -> BInternal a 253 | stepInternal i me =BInternal $ 254 | do e <- me 255 | return $ case e of 256 | Occ x -> Right x 257 | Never -> Right (Const i) 258 | E me' -> Left (stepInternal i me', i, setE () e) 259 | 260 | bindBInternal :: M (a,Event (Behavior a)) -> (a -> Behavior b) -> BInternal b 261 | bindBInternal m f = 262 | BInternal $ 263 | do (h,t) <- m 264 | case t of 265 | Never -> return $ Right (f h) 266 | Occ _ -> error "invariant broken" 267 | _ -> 268 | case f h of 269 | Const x -> return $ Left (bindBInternal (rerunB h t) f, x, setE () t) 270 | B n -> do (hn,tn) <- n 271 | return $ Left (bindBInternal (rerunB h t) f, hn, minTime t tn) 272 | 273 | 274 | 275 | bindB :: Behavior a -> (a -> Behavior b) -> Behavior b 276 | bindB (Const x) f = f x 277 | bindB (B m) f = memoBInt $ bindBInternal m f 278 | 279 | whenJustInternal :: M (Maybe a, Event (Behavior (Maybe a))) -> Behavior (Event a) -> BInternal (Event a) 280 | whenJustInternal m outerSelf = BInternal $ 281 | do (h, t) <- m 282 | case t of 283 | Never -> return $ Right $ pure $ case h of 284 | Just x -> pure x 285 | Nothing -> never 286 | Occ _ -> error "invariant broken" 287 | _ -> 288 | case h of 289 | Just x -> return $ Left (whenJustInternal (rerunB h t) outerSelf, return x, setE () t) 290 | Nothing -> 291 | do en <- planM (setE (runB outerSelf) t) 292 | return $ Left (whenJustInternal (rerunB h t) outerSelf, en >>= fst, setE () t) 293 | 294 | 295 | whenJust' :: Behavior (Maybe a) -> Behavior (Event a) 296 | whenJust' (Const Nothing) = pure never 297 | whenJust' (Const (Just x)) = pure (pure x) 298 | whenJust' (B m) = let x = memoBInt $ whenJustInternal m x 299 | in x 300 | 301 | 302 | {- 303 | whenJustSample' :: Behavior (Maybe (Behavior a)) -> Behavior (Event a) 304 | whenJustSample' (Const Nothing) = pure never 305 | whenJustSample' (Const (Just x)) = B $ do v <- fst <$> runB x; return (pure v, never) 306 | whenJustSample' (B bm) = B $ 307 | do (h, t) <- bm 308 | case h of 309 | Just x -> do v <- fst <$> runB x; return (pure v, whenJustSample' <$> t) 310 | Nothing -> do en <- planM (runB . whenJustSample' <$> t) 311 | return (en >>= fst, never) 312 | -} 313 | instance Monad Behavior where 314 | return x = B $ return (x, never) 315 | m >>= f = m `bindB` f 316 | 317 | instance MonadFix Behavior where 318 | mfix f = B $ mfix $ \(~(h,_)) -> 319 | do (h',t) <- runB (f h) 320 | return (h', mfix f <$ t ) 321 | 322 | -- | Introduce a change over time. 323 | -- 324 | -- 325 | -- > b `switch` e 326 | -- 327 | -- 328 | -- Gives a behavior that acts as @b@ initially, and switches to the behavior inside @e@ as soon as @e@ occurs. 329 | -- 330 | switch :: Behavior a -> Event (Behavior a) -> Behavior a 331 | switch b Never = b 332 | switch _ (Occ b) = b 333 | switch (Const x) (E em) = memoBInt (stepInternal x em) 334 | switch (B bm) (E em) = memoBInt (switchInternal bm em) 335 | -- | Observe a change over time. 336 | -- 337 | -- The behavior @whenJust b@ gives at any point in time the event that 338 | -- the behavior @b@ is @Just@ at that time or afterwards. 339 | -- 340 | -- As an example, 341 | -- 342 | -- 343 | -- > let getPos x 344 | -- > | x > 0 = Just x 345 | -- > | otherwise = Nothing 346 | -- > in whenJust (getPos <$> b) 347 | -- 348 | -- Gives gives the event that 349 | -- the behavior @b@ is positive. If @b@ is currently positive 350 | -- then the event will occur now, otherwise it 351 | -- will be the first time that @b@ becomes positive in the future. 352 | -- If @b@ never again is positive then the result is 'never'. 353 | 354 | whenJust :: Behavior (Maybe a) -> Behavior (Event a) 355 | whenJust b = (whenJust' b) 356 | 357 | {- 358 | -- | A more optimized version of: 359 | -- 360 | -- > whenJustSample b = do x <- whenJust b 361 | -- > plan x 362 | 363 | whenJustSample :: Behavior (Maybe (Behavior a)) -> Behavior (Event a) 364 | whenJustSample b = memoB (whenJustSample' b) 365 | -} 366 | 367 | -- | Not typically needed, used for event streams. 368 | -- 369 | -- If we have a behavior giving events, such that each time the behavior is 370 | -- sampled the obtained event is in the future, then this function 371 | -- ensures that we can use the event without inspecting it (i.e. before binding it). 372 | -- 373 | -- If the implementation samples such an event and it turns out the event does actually occur at the time 374 | -- the behavior is sampled, an error is thrown. 375 | futuristic :: Behavior (Event a) -> Behavior (Event a) 376 | futuristic b = B $ do e <- makeLazy $ fst <$> runB b 377 | return (e,futuristic b <$ e) 378 | 379 | unrunB :: (a,Event (Behavior a)) -> Behavior a 380 | unrunB (h, Never) = Const h 381 | unrunB (h,t) = B $ 382 | runE t >>= \x -> case x of 383 | Occ b -> runB b 384 | t' -> return (h,t') 385 | {- 386 | memoBIO :: Behavior a -> IO (Behavior a) 387 | memoBIO einit = 388 | do r <- newIORef einit 389 | return (usePrevB r) 390 | 391 | usePrevB :: IORef (Behavior a) -> Behavior a 392 | usePrevB r = B $ 393 | do b <- liftIO (readIORef r) 394 | res <- runB b 395 | liftIO (writeIORef r (unrunB res)) 396 | return res 397 | 398 | memoB :: Behavior a -> Behavior a 399 | --memoB b = b 400 | memoB b@(Const _) = b 401 | memoB b = unsafePerformIO $ memoBIO b 402 | -} 403 | -- Section 6.7 404 | 405 | 406 | data Env = Env { 407 | plansRef :: IORef Plans, 408 | laziesRef :: IORef Lazies, 409 | clock :: Clock } 410 | 411 | 412 | 413 | type M = ReaderT Env IO 414 | 415 | -- | A monad that allows you to: 416 | -- 417 | -- * Sample the current value of a behavior via 'sampleNow' 418 | -- * Interact with the outside world via 'async', 'callback' and 'sync'. 419 | -- * Plan to do Now actions later, via 'planNow' 420 | -- 421 | -- All actions in the @Now@ monad are conceptually instantaneous, which entails it is guaranteed that for any behavior @b@ and Now action @m@: 422 | -- 423 | -- @ 424 | -- do x <- sample b; m ; y <- sample b; return (x,y) 425 | -- == do x <- sample b; m ; return (x,x) 426 | -- @ 427 | newtype Now a = Now { getNow :: M a } deriving (Functor,Applicative,Monad, MonadFix, MonadIO) 428 | 429 | -- | Sample the present value of a behavior 430 | sampleNow :: Behavior a -> Now a 431 | sampleNow (B m) = Now $ fst <$> m 432 | 433 | 434 | -- | Create an event that occurs when the callback is called. 435 | -- 436 | -- The callback can be safely called from any thread. An error occurs if the callback is called more than once. 437 | -- 438 | -- See 'Control.FRPNow.EvStream.callbackStream' for a callback that can be called repeatedly. 439 | -- 440 | -- The event occurs strictly later than the time that 441 | -- the callback was created, even if the callback is called immediately. 442 | callback :: Now (Event a, a -> IO ()) 443 | callback = Now $ do c <- clock <$> ask 444 | (pe, cb) <- liftIO $ callbackp c 445 | return (toE pe,cb) 446 | -- | Synchronously execute an IO action. 447 | -- 448 | -- Use this is for IO actions which do not take a long time, such as 449 | -- opening a file or creating a widget. 450 | sync :: IO a -> Now a 451 | sync m = Now $ liftIO m 452 | 453 | -- | Asynchronously execute an IO action, and obtain the event that it is done. 454 | -- 455 | -- Starts a separate thread for the IO action, and then immediatly returns the 456 | -- event that the IO action is done. Since all actions in the 'Now' monad are instantaneous, 457 | -- the resulting event is guaranteed to occur in the future (not now). 458 | -- 459 | -- Use this for IO actions which might take a long time, such as waiting for a network message, 460 | -- reading a large file, or expensive computations. 461 | -- 462 | -- /Note/:Use this only when using FRPNow with Gloss or something else that does not block haskell threads. 463 | -- For use with GTK or other GUI libraries that do block Haskell threads, use 'asyncOS' instead. 464 | async :: IO a -> Now (Event a) 465 | async m = Now $ do c <- clock <$> ask 466 | toE <$> liftIO (spawn c m) 467 | 468 | 469 | -- | Like 'async', but uses an OS thread instead of a regular lightweight thread. 470 | -- 471 | -- Useful when interacting with GUI systems that claim the main loop, such as GTK. 472 | asyncOS :: IO a -> Now (Event a) 473 | asyncOS m = Now $ do c <- clock <$> ask 474 | toE <$> liftIO (spawnOS c m) 475 | 476 | toE :: PrimEv a -> Event a 477 | toE p = E toEM where 478 | toEM = (toEither . (p `observeAt`) <$> getRound) 479 | toEither Nothing = E toEM 480 | toEither (Just x) = Occ x 481 | 482 | getRound :: M Round 483 | getRound = ReaderT $ \env -> curRound (clock env) 484 | 485 | 486 | -- IORef 487 | type Plan a = IORef (Either (Event (M a)) a) 488 | 489 | planToEv :: Plan a -> Event a 490 | planToEv ref = self where 491 | self = E $ 492 | liftIO (readIORef ref) >>= \pstate -> 493 | case pstate of 494 | Right x -> return (Occ x) 495 | Left ev -> runE ev >>= \estate -> 496 | case estate of 497 | Occ m -> do x <- m 498 | liftIO $ writeIORef ref (Right x) 499 | return $ Occ x 500 | ev' -> do liftIO $ writeIORef ref (Left ev') 501 | return self 502 | 503 | 504 | data SomePlan = forall a. SomePlan (Ref (Plan a)) 505 | type Plans = [SomePlan] 506 | 507 | 508 | type Lazies = [Lazy] 509 | data Lazy = forall a. Lazy (M (Event a)) (IORef (Event a)) 510 | 511 | 512 | makeLazy :: M (Event a) -> M (Event a) 513 | makeLazy m = ReaderT $ \env -> 514 | do n <- curRound (clock env) 515 | r <- newIORef (error "should not have read lazy yet") 516 | modifyIORef (laziesRef env) (Lazy m r :) 517 | return (readLazyState n r) 518 | 519 | readLazyState :: Round -> IORef (Event a) -> Event a 520 | readLazyState n r = 521 | let x = E $ 522 | do m <- getRound 523 | case compare n m of 524 | LT -> liftIO (readIORef r) >>= runE 525 | EQ -> return x 526 | GT -> error "Round seems to decrease.." 527 | in x 528 | 529 | 530 | planM :: Event (M a) -> M (Event a) 531 | planM e = plan makeWeakIORef e 532 | 533 | 534 | -- | Plan to execute a 'Now' computation. 535 | -- 536 | -- When given a event carrying a now computation, execute that now computation as soon as the event occurs. 537 | -- If the event has already occurred when 'planNow' is called, then the 'Now' computation will be executed immediately. 538 | planNow :: Event (Now a) -> Now (Event a) 539 | planNow e = Now $ 540 | do e' <- runE e 541 | case e' of 542 | Occ x -> pure <$> getNow x 543 | Never -> return Never 544 | _ -> plan makeStrongRef (getNow <$> e) 545 | 546 | plan :: (forall v. IORef v -> IO (Ref (IORef v))) -> Event (M a) -> M (Event a) 547 | plan makeRef e = 548 | do p <- liftIO (newIORef $ Left e) 549 | let ev = planToEv p 550 | pr <- liftIO (makeRef p) 551 | addPlan pr 552 | return ev 553 | 554 | addPlan :: Ref (Plan a) -> M () 555 | addPlan p = ReaderT $ \env -> modifyIORef (plansRef env) (SomePlan p :) 556 | 557 | 558 | 559 | -- | General interface to interact with the FRP system. 560 | -- 561 | -- 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. 562 | 563 | initNow :: 564 | (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 occurred with value @x@ and now more FRP actions are scheduled. 565 | -> Now (Event a) -- ^ The @Now@ computation to execute, resulting in the ending event, i.e. the event that stops the FRP system. 566 | -> IO () 567 | initNow schedule (Now m) = 568 | mdo c <- newClock (schedule it) 569 | pr <- newIORef [] 570 | lr <- newIORef [] 571 | let env = Env pr lr c 572 | let it = runReaderT (iteration e) env 573 | e <- runReaderT m env 574 | runReaderT (iterationMeat e) env 575 | return () 576 | 577 | iteration :: Event a -> M (Maybe a) 578 | iteration ev = 579 | newRoundM >>= \new -> 580 | if new 581 | then iterationMeat ev 582 | else return Nothing 583 | 584 | iterationMeat ev = 585 | do er <- runE ev 586 | case er of 587 | Occ x -> return (Just x) 588 | _ -> tryPlans >> runLazies >> return Nothing 589 | 590 | 591 | newRoundM :: M Bool 592 | newRoundM = ReaderT $ \env -> newRound (clock env) 593 | 594 | 595 | tryPlans :: M () 596 | tryPlans = ReaderT $ tryEm where 597 | tryEm env = 598 | do pl <- readIORef (plansRef env) 599 | --putStrLn ("nr plans: " ++ show (length pl)) 600 | writeIORef (plansRef env) [] 601 | runReaderT (mapM_ tryPlan (reverse pl)) env 602 | tryPlan (SomePlan pr) = 603 | do -- liftIO (traceIO "plan!") 604 | ps <- liftIO (deRef pr) 605 | case ps of 606 | Just p -> do eres <- runE (planToEv p) 607 | case eres of 608 | Occ x -> return () 609 | _ -> addPlan pr 610 | Nothing -> return () 611 | 612 | runLazies :: M () 613 | runLazies = ReaderT $ runEm where 614 | runEm env = 615 | readIORef (laziesRef env) >>= \pl -> 616 | if null pl 617 | then return () 618 | else do writeIORef (laziesRef env) [] 619 | runReaderT (mapM_ runLazy (reverse pl)) env 620 | runEm env where 621 | runLazy (Lazy m r) = do e <- m 622 | x <- runE e 623 | case x of 624 | Occ _ -> error "Forced lazy was not lazy!" 625 | e' -> liftIO $ writeIORef r e' 626 | 627 | -- | When using the FRP system in master mode, with 'runNowMaster', this exception is thrown if 628 | -- the FRP system is not doing anything anymore, waiting for 'never'. 629 | 630 | data FRPWaitsForNeverException = FRPWaitsForNeverException deriving (Show, Typeable) 631 | 632 | instance Exception FRPWaitsForNeverException 633 | 634 | -- | Run the FRP system in master mode. 635 | -- 636 | -- 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. 637 | -- 638 | -- 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. 639 | 640 | runNowMaster :: Now (Event a) -> IO a 641 | runNowMaster m = 642 | do chan <- newChan 643 | let enqueue m = writeChan chan m 644 | initNow enqueue m 645 | loop chan where 646 | loop chan = 647 | do m <- catch (readChan chan) 648 | (\e -> do let err = (e :: BlockedIndefinitelyOnMVar) 649 | throw FRPWaitsForNeverException) 650 | mr <- m 651 | case mr of 652 | Just x -> return x 653 | Nothing -> loop chan 654 | 655 | 656 | 657 | instance Functor Behavior where 658 | fmap = liftM 659 | 660 | instance Applicative Behavior where 661 | pure = return 662 | (<*>) = ap 663 | 664 | instance Functor Event where 665 | fmap = liftM 666 | 667 | instance Applicative Event where 668 | pure = return 669 | (<*>) = ap 670 | 671 | -------------------------------------------------------------------------------- /Control/FRPNow/EvStream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables,TypeOperators,MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} 2 | 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Control.FRPNow.EvStream 7 | -- Copyright : (c) Atze van der Ploeg 2015 8 | -- License : BSD-style 9 | -- Maintainer : atzeus@gmail.org 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- Event streams for FRPNow 14 | 15 | module Control.FRPNow.EvStream( 16 | EvStream, 17 | -- * Observe 18 | next, nextAll, 19 | -- * Construction 20 | emptyEs, 21 | merge, 22 | collapseSimul, 23 | dropEv, 24 | toChanges, 25 | edges, 26 | joinEs, 27 | -- * Folds and scans 28 | scanlEv, 29 | foldrEv, 30 | foldriEv, 31 | fromChanges, 32 | foldrSwitch, 33 | foldEs, 34 | foldBs, 35 | -- * Filter and scan 36 | catMaybesEs,filterEs,filterMapEs,filterMapEsB, filterB, during, beforeEs, 37 | -- * Combine behavior and eventstream 38 | (<@@>) , snapshots, delay, 39 | -- * IO interface 40 | callbackStream,callStream, callIOStream, 41 | -- * Debug 42 | traceEs) 43 | 44 | where 45 | 46 | import Data.Maybe 47 | import Control.Monad hiding (when) 48 | import Control.Applicative hiding (empty) 49 | import Data.IORef 50 | import qualified Data.Sequence as Seq 51 | import Prelude hiding (until,length) 52 | import qualified Prelude as P 53 | import Debug.Trace 54 | import Data.Monoid 55 | 56 | import Control.FRPNow.Core 57 | import Control.FRPNow.Lib 58 | import Debug.Trace 59 | 60 | -- | The (abstract) type of event streams. 61 | -- 62 | -- Denotationally, one can think of an eventstream as a value 63 | -- of type 64 | -- 65 | -- > [(Time,a)] 66 | -- 67 | -- where the points in time are non-strictly increasing. 68 | -- There can be multiple simultaneous events in an event stream. 69 | 70 | newtype EvStream a = S { getEs :: Behavior (Event [a]) } 71 | 72 | instance Functor EvStream where 73 | fmap f (S b) = S $ (fmap f <$>) <$> b 74 | 75 | instance Monoid (EvStream a) where 76 | mempty = emptyEs 77 | mappend = merge 78 | 79 | -- | The empty event stream 80 | emptyEs :: EvStream a 81 | emptyEs = S $ pure never 82 | 83 | -- | Merge two event stream. 84 | -- 85 | -- In case of simultaneity, the left elements come first 86 | merge :: EvStream a -> EvStream a -> EvStream a 87 | merge l r = loop where 88 | loop = S $ 89 | do l' <- getEs l 90 | r' <- getEs r 91 | e <- fmap nxt <$> cmpTime l' r' 92 | let again = getEs loop 93 | pure e `switch` fmap (const again) e 94 | nxt (Simul l r) = l ++ r 95 | nxt (LeftEarlier l) = l 96 | nxt (RightEarlier r) = r 97 | 98 | -- | Collapses each set of simultaneous events into a single event carrying the list of occurrences. 99 | collapseSimul :: EvStream a -> EvStream [a] 100 | collapseSimul (S s) = S $ ((\x -> [x]) <$>) <$> s 101 | 102 | -- | Obtain the next element of the event stream. The obtained event is guaranteed to lie in the future. 103 | next :: EvStream a -> Behavior (Event a) 104 | next s = (head <$>) <$> (nextAll s) 105 | 106 | -- | Obtain all simultaneous next elements of the event stream. The obtained event is guaranteed to lie in the future. 107 | nextAll :: EvStream a -> Behavior (Event [a]) 108 | nextAll e = futuristic $ getEs e 109 | 110 | -- | Sample the behavior each time an event in the stream 111 | -- occurs, and combine the outcomes. 112 | (<@@>) :: Behavior (a -> b) -> EvStream a -> EvStream b 113 | (<@@>) f es = S $ loop where 114 | loop = do e <- getEs es 115 | plan (nxt <$> e) 116 | nxt l = (<$> l) <$> f 117 | 118 | -- | Sample the behavior each time an event in the stream 119 | -- occurs. 120 | snapshots :: Behavior a -> EvStream () -> EvStream a 121 | snapshots b s = S $ 122 | do e <- getEs s 123 | ((\x -> [x]) <$>) <$> snapshot b (head <$> e) 124 | 125 | -- | Get the event stream of changes to the input behavior. 126 | toChanges :: Eq a => Behavior a -> EvStream a 127 | toChanges = repeatEv . change 128 | 129 | -- | Get the events that the behavior changes from @False@ to @True@ 130 | edges :: Behavior Bool -> EvStream () 131 | edges = repeatEv . edge 132 | 133 | 134 | 135 | repeatEv :: Behavior (Event a) -> EvStream a 136 | repeatEv b = S $ loop where 137 | loop = do e <- b 138 | return $ (\x -> [x]) <$> e 139 | 140 | 141 | -- | Create a behavior from an initial value and 142 | -- an event stream of updates. 143 | -- 144 | fromChanges :: a -> EvStream a -> Behavior (Behavior a) 145 | fromChanges i s = loop i where 146 | loop i = do e <- nextAll s 147 | e' <- plan (loop . last <$> e) 148 | return (i `step` e') 149 | 150 | 151 | 152 | dropEv :: Int -> EvStream a -> EvStream a 153 | dropEv i (S s) = S $ loop i where 154 | loop 0 = s 155 | loop i = do e <- s 156 | join <$> plan (loop (i-1) <$ e) 157 | 158 | 159 | -- | Filter the 'Just' values from an event stream. 160 | -- 161 | catMaybesEs :: EvStream (Maybe a) -> EvStream a 162 | catMaybesEs s = S $ loop where 163 | -- loop :: Behavior (Event [a]) 164 | loop = do e <- getEs s 165 | join <$> plan (nxt <$> e) 166 | nxt l = case catMaybes l of 167 | [] -> loop 168 | l -> return (return l) 169 | 170 | -- | Filter events from an event stream 171 | -- 172 | filterEs :: (a -> Bool) -> EvStream a -> EvStream a 173 | filterEs f s = catMaybesEs (toMaybef <$> s) 174 | where toMaybef x | f x = Just x 175 | | otherwise = Nothing 176 | 177 | -- | Shorthand for 178 | -- 179 | -- > filterMapEs f e = catMaybesEs $ f <$> e 180 | filterMapEs :: (a -> Maybe b) -> EvStream a -> EvStream b 181 | filterMapEs f e = catMaybesEs $ f <$> e 182 | 183 | -- | Shorthand for 184 | -- 185 | -- > filterMapEs b e = catMaybesEs $ b <@@> e 186 | -- 187 | filterMapEsB :: Behavior (a -> Maybe b) -> EvStream a -> EvStream b 188 | filterMapEsB f e = catMaybesEs $ f <@@> e 189 | 190 | 191 | -- | Filter events from an eventstream based on a function that 192 | -- changes over time 193 | -- 194 | filterB :: Behavior (a -> Bool) -> EvStream a -> EvStream a 195 | filterB f = filterMapEsB (toMaybe <$> f) 196 | where toMaybe f = \a -> if f a then Just a else Nothing 197 | 198 | -- | Obtain only the events from input stream that occur while 199 | -- the input behavior is 'True' 200 | -- 201 | during :: EvStream a -> Behavior Bool -> EvStream a 202 | e `during` b = filterB (const <$> b) e 203 | 204 | 205 | -- | A left scan over an event stream 206 | scanlEv :: (a -> b -> a) -> a -> EvStream b -> Behavior (EvStream a) 207 | scanlEv f i es = S <$> loop i where 208 | loop i = 209 | do e <- nextAll es 210 | let e' = (\(h : t) -> tail $ scanl f i (h : t)) <$> e 211 | ev <- plan (loop . last <$> e') 212 | return (pure e' `switch` ev) 213 | 214 | -- | Turns an event of an event stream into an event stream. 215 | joinEs :: Event (EvStream b) -> EvStream b 216 | joinEs e = S $ before `switch` after where 217 | before = join <$> plan (getEs <$> e) 218 | after = getEs <$> e 219 | 220 | 221 | 222 | -- | Left fold over an eventstream to create a behavior (behavior depends on when 223 | -- the fold started). 224 | foldEs :: (a -> b -> a) -> a -> EvStream b -> Behavior (Behavior a) 225 | foldEs f i s = loop i where 226 | loop i = do e <- nextAll s 227 | let e' = foldl f i <$> e 228 | ev <- plan (loop <$> e') 229 | return (i `step` ev) 230 | 231 | -- | Right fold over an eventstream 232 | -- 233 | -- The result of folding over the rest of the event stream is in an event, 234 | -- since it can be only known in the future. 235 | -- 236 | -- No initial value needs to be given, since the initial value is 'Control.FRPNow.Core.never' 237 | foldrEv :: (a -> Event b -> b) -> EvStream a -> Behavior (Event b) 238 | foldrEv f es = loop where 239 | loop = 240 | do e <- nextAll es 241 | plan (nxt <$> e) 242 | nxt [h] = f h <$> loop 243 | nxt (h : t) = f h . return <$> nxt t 244 | 245 | 246 | -- | Right fold over an eventstream with a left initial value 247 | -- 248 | -- Defined as: 249 | -- 250 | -- > foldriEv i f ev = f i <$> foldrEv f es 251 | foldriEv :: a -> (a -> Event b -> b) -> EvStream a -> Behavior b 252 | foldriEv i f es = f i <$> foldrEv f es 253 | 254 | 255 | 256 | -- | Start with the argument behavior, and switch to a new behavior each time 257 | -- an event in the event stream occurs. 258 | -- 259 | -- Defined as: 260 | -- 261 | -- > foldrSwitch b = foldriEv b switch 262 | -- 263 | foldrSwitch :: Behavior a -> EvStream (Behavior a) -> Behavior (Behavior a) 264 | foldrSwitch b = foldriEv b switch 265 | 266 | -- | Yet another type of fold. 267 | -- 268 | -- Defined as: 269 | -- 270 | -- > foldBs b f es = scanlEv f b es >>= foldrSwitch b 271 | foldBs :: Behavior a -> (Behavior a -> b -> Behavior a) -> EvStream b -> Behavior (Behavior a) 272 | foldBs b f es = scanlEv f b es >>= foldrSwitch b 273 | 274 | -- | An event stream with only elements that occur before the argument event. 275 | beforeEs :: EvStream a -> Event () -> EvStream a 276 | beforeEs s e = S $ beforeEv `switch` en 277 | where en = pure never <$ e 278 | beforeEv = do se <- getEs s 279 | ev <- first (Left <$> e) (Right <$> se) 280 | return (ev >>= choose) 281 | choose (Left _) = never 282 | choose (Right x) = return x 283 | 284 | 285 | -- | Delay a behavior by one tick of the ``clock''. 286 | -- 287 | -- The event stream functions as the ``clock'': the input behavior is sampled on each 288 | -- event, and the current value of the output behavior is always the previous sample. 289 | -- 290 | -- Occasionally useful to prevent immediate feedback loops. 291 | delay :: EvStream x -- ^ The event stream that functions as the ``clock'' 292 | -> a -- ^ The inital value of the output behavior 293 | -> Behavior a -- ^ The input behavior 294 | -> Behavior (Behavior a) 295 | delay s i b = loop i where 296 | loop i = 297 | do e <- futuristic $ 298 | do cur <- b 299 | e <- getEs s 300 | return (cur <$ e) 301 | e' <- plan ( loop <$> e) 302 | return (i `step` e') 303 | 304 | -- | Create an event stream that has an event each time the 305 | -- returned function is called. The function can be called from any thread. 306 | callbackStream :: forall a. Now (EvStream a, a -> IO ()) 307 | callbackStream = do mv <- sync $ newIORef ([], Nothing) 308 | (_,s) <- loop mv 309 | return (S s, func mv) where 310 | loop :: IORef ( [a], Maybe (() -> IO ()) ) -> Now ([a], Behavior (Event [a])) 311 | loop mv = 312 | do (l, Nothing) <- sync $ readIORef mv 313 | (e,cb) <- callback 314 | sync $ writeIORef mv ([], Just cb) 315 | es <- planNow $ loop mv <$ e 316 | let h = fst <$> es 317 | let t = snd <$> es 318 | return (reverse l, h `step` t) 319 | 320 | func mv x = 321 | do (l,mcb) <- readIORef mv 322 | writeIORef mv (x:l, Nothing) 323 | case mcb of 324 | Just x -> x () 325 | Nothing -> return () 326 | 327 | 328 | 329 | -- | Call the given function each time an event occurs, and execute the resulting Now computation 330 | 331 | callStream :: ([a] -> Now ()) -> EvStream a -> Now () 332 | callStream f evs = do e2 <- sample (nextAll evs) 333 | planNow (again <$> e2) 334 | return () where 335 | again a = do f a 336 | e <- sample (nextAll evs) 337 | planNow (again <$> e) 338 | return () 339 | 340 | 341 | -- | 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. 342 | callIOStream :: (a -> IO ()) -> EvStream a -> Now () 343 | callIOStream f = callStream (\x -> sync (mapM_ f x) >> return ()) 344 | 345 | -- | Debug function, print all values in the event stream to stderr, prepended with the given string. 346 | traceEs :: (Show a, Eq a) => String -> EvStream a -> Now () 347 | traceEs s es = callIOStream (\x -> traceIO (s ++ show x)) es 348 | 349 | 350 | -------------------------------------------------------------------------------- /Control/FRPNow/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DoAndIfThenElse, FlexibleInstances , MultiParamTypeClasses,GADTs, TypeOperators, TupleSections, ScopedTypeVariables,ConstraintKinds,FlexibleContexts,UndecidableInstances #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Control.FRPNow.Lib 5 | -- Copyright : (c) Atze van der Ploeg 2015 6 | -- License : BSD-style 7 | -- Maintainer : atzeus@gmail.org 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- Utility FRPNow functions 12 | module Control.FRPNow.Lib( 13 | -- * Behavior construction 14 | step, 15 | cstep, 16 | -- * Getting events from behaviors 17 | when, 18 | change, 19 | edge, 20 | -- * Events and their ordering 21 | tryGetEv, 22 | hasOccurred, 23 | first, 24 | cmpTime, 25 | EvOrd(..), 26 | -- * Fold and state 27 | prev, 28 | foldB, 29 | sampleUntil, 30 | -- * Sample behaviors on events 31 | planB, 32 | snapshot, 33 | (<@>), 34 | -- * Type classes for uniform interface 35 | Plan(..), 36 | Sample(..), 37 | -- * Debugging 38 | traceChanges ) 39 | 40 | where 41 | 42 | 43 | import Control.FRPNow.Core 44 | import Control.Applicative 45 | import Control.Monad hiding (when) 46 | import Prelude hiding (until) 47 | import Debug.Trace 48 | 49 | 50 | -- | Start with a constant and then switch 51 | -- 52 | -- Defined as: 53 | -- 54 | -- > step a s = pure a `switch` s 55 | step :: a -> Event (Behavior a) -> Behavior a 56 | step a s = pure a `switch` s 57 | 58 | 59 | -- | Start with a constant, and switch to another constant when the event arrives. 60 | -- 61 | -- Defined as: 62 | -- 63 | -- > cstep x e y = pure x `switch` (pure y <$ e) 64 | cstep :: a -> Event x -> a -> Behavior a 65 | cstep x e y = pure x `switch` (pure y <$ e) 66 | 67 | -- | Like 'Control.FRPNow.whenJust' but on behaviors of type @Bool@ instead of @Maybe@. 68 | -- 69 | -- Gives the event that the input behavior is @True@ 70 | when :: Behavior Bool -> Behavior (Event ()) 71 | when b = whenJust (boolToMaybe <$> b) where 72 | boolToMaybe True = Just () 73 | boolToMaybe False = Nothing 74 | 75 | 76 | -- | Gives the previous value of the behavior, starting with given value. 77 | -- 78 | -- This /cannot/ be used to prevent immediate feedback loop! Use 'Control.FRPNow.EvStream.delay' instead! 79 | prev :: Eq a => a -> Behavior a -> Behavior (Behavior a) 80 | prev i b = loop i where 81 | loop i = do e <- nxtCur 82 | return (i `step` e) 83 | nxtCur = futuristic $ 84 | do cur <- b 85 | e <- change b 86 | planB (loop cur <$ e) 87 | 88 | -- | Gives at any point in time the event that the input behavior changes, and the new value of the input behavior. 89 | change :: Eq a => Behavior a -> Behavior (Event a) 90 | change b = futuristic $ 91 | do v <- b ; 92 | whenJust (notSame v <$> b) where 93 | notSame v v' | v /= v' = Just v' 94 | | otherwise = Nothing 95 | 96 | 97 | 98 | -- | The resulting behavior gives at any point in time, the event that the input 99 | -- 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 100 | -- time that it is True again, after first being False for a period of time. 101 | edge :: Behavior Bool -> Behavior (Event ()) 102 | edge b = futuristic $ 103 | b >>= \v -> 104 | if v then (do e <- when (not <$> b) 105 | join <$> plan (when b <$ e)) 106 | else when b 107 | 108 | -- | A (left) fold over a behavior. 109 | -- 110 | -- The inital value of the resulting behavior is @f i x@ where @i@ is the initial value given, and @x@ is the current value of the behavior. 111 | -- 112 | foldB :: Eq a => (b -> a -> b) -> b -> Behavior a -> Behavior (Behavior b) 113 | foldB f i b = loop i where 114 | loop i = do c <- b 115 | let i' = f i c 116 | e <- change b 117 | e' <- snapshot (loop i') (() <$ e) 118 | return (pure i' `switch` e') 119 | 120 | -- | When sampled at a point in time t, the behavior gives an event with 121 | -- the list of all values of the input behavior between time t and the 122 | -- time that the argument event occurs (including the value when the event occurs). 123 | sampleUntil :: Eq a => Behavior a -> Event () -> Behavior (Event [a]) 124 | sampleUntil b end = loop [] where 125 | loop ss = do s <- b 126 | let ss' = s : ss 127 | e <- hasOccurred end 128 | if e then return (pure (reverse ss')) 129 | else do c <- change b 130 | join <$> plan (loop ss' <$ c) 131 | 132 | 133 | -- | Convert an event into a behavior that gives 134 | -- @Nothing@ if the event has not occurred yet, and @Just@ the value of the event if the event has already occurred. 135 | tryGetEv :: Event a -> Behavior (Maybe a) 136 | tryGetEv e = pure Nothing `switch` ((pure . Just) <$> e) 137 | 138 | -- | The resulting behavior states whether the input event has already occurred. 139 | hasOccurred :: Event x -> Behavior Bool 140 | hasOccurred e = False `step` (pure True <$ e) 141 | 142 | -- | Gives the first of two events. 143 | -- 144 | -- If either of the events lies in the future, then the result will be the first of these events. 145 | -- If both events have already occurred, the left event is returned. 146 | first :: Event a -> Event a -> Behavior (Event a) 147 | first l r = whenJust (tryGetEv r `switch` ((pure . Just) <$> l)) 148 | 149 | -- | Compare the time of two events. 150 | -- 151 | -- The resulting behavior gives an event, occurring at the same time 152 | -- as the earliest input event, of which the value indicates if the event where 153 | -- simultaneous, or if one was earlier. 154 | -- 155 | -- If at the time of sampling both events lie in the past, then 156 | -- the result is that they are simultaneous. 157 | cmpTime :: Event a -> Event b -> Behavior (Event (EvOrd a b)) 158 | cmpTime l r = whenJust (outcome <$> tryGetEv l <*> tryGetEv r) where 159 | outcome Nothing Nothing = Nothing 160 | outcome (Just x) Nothing = Just (LeftEarlier x) 161 | outcome Nothing (Just y) = Just (RightEarlier y) 162 | outcome (Just x) (Just y) = Just (Simul x y) 163 | 164 | -- | The outcome of a 'cmpTime': the events occur simultaneous, left is earlier or right is earlier. 165 | data EvOrd l r = Simul l r 166 | | LeftEarlier l 167 | | RightEarlier r 168 | 169 | 170 | -- | Plan to sample the behavior carried by the event as soon as possible. 171 | -- 172 | -- If the resulting behavior is sampled after the event occurs, 173 | -- then the behavior carried by the event will be sampled now. 174 | planB :: Event (Behavior a) -> Behavior (Event a) 175 | planB e = whenJust 176 | (pure Nothing `switch` ((Just <$>) <$> e)) 177 | 178 | 179 | -- | Obtain the value of the behavior at the time the event occurs 180 | -- 181 | -- If the event has already occurred when sampling the resulting behavior, 182 | -- we sample not the past, but the current value of the input behavior. 183 | snapshot :: Behavior a -> Event () -> Behavior (Event a) 184 | snapshot b e = let e' = (Just <$> b) <$ e 185 | in whenJust (pure Nothing `switch` e') 186 | 187 | -- | Like 'snapshot', but feeds the result of the event to the 188 | -- value of the given behavior at that time. 189 | (<@>) :: Behavior (a -> b) -> Event a -> Behavior (Event b) 190 | b <@> e = plan $ fmap (\x -> b <*> pure x) e 191 | 192 | 193 | 194 | 195 | 196 | 197 | -- | A type class to unify 'planNow' and 'planB' 198 | class Monad b => Plan b where 199 | plan :: Event (b a) -> b (Event a) 200 | 201 | instance Plan Now where plan = planNow 202 | instance Plan Behavior where plan = planB 203 | 204 | -- | A type class for behavior-like monads, such 'Now' and the monads from "Control.FRPNow.BehaviorEnd" 205 | class Monad n => Sample n where 206 | sample :: Behavior a -> n a 207 | 208 | instance Sample Behavior where sample = id 209 | instance Sample Now where sample = sampleNow 210 | 211 | 212 | 213 | 214 | -- | A debug function, prints all values of the behavior to stderr, prepended with the given string. 215 | traceChanges :: (Eq a, Show a) => String -> Behavior a -> Now () 216 | traceChanges s b = loop where 217 | loop = do v <- sample b 218 | sync $ traceIO (s ++ show v) 219 | e <- sample $ change b 220 | planNow (loop <$ e) 221 | return () 222 | -------------------------------------------------------------------------------- /Control/FRPNow/Private/PrimEv.hs: -------------------------------------------------------------------------------- 1 | module Control.FRPNow.Private.PrimEv(Round, Clock, PrimEv, newClock , callbackp, spawn, spawnOS, curRound, newRound ,observeAt ) where 2 | 3 | import Control.Applicative 4 | import System.IO.Unsafe 5 | import Data.IORef 6 | import Data.Unique 7 | import Control.Concurrent 8 | import Debug.Trace 9 | 10 | data Clock = Clock { 11 | identClock :: Unique, 12 | scheduleRound :: IO (), 13 | roundRef :: IORef Integer, 14 | changedRef :: IORef Bool } 15 | 16 | data Round = Round Unique Integer 17 | data PrimEv a = PrimEv Unique (IORef (Maybe (Round, a))) 18 | 19 | instance Show Round where 20 | show (Round _ i) = show i 21 | 22 | 23 | 24 | -- when given a IO action that schedules a round, create a new clock 25 | newClock :: IO () -> IO Clock 26 | newClock schedule = Clock <$> newUnique <*> pure schedule <*> newIORef 0 <*> newIORef False 27 | 28 | callbackp :: Clock -> IO (PrimEv a, a -> IO ()) 29 | callbackp c = 30 | do mv <- newIORef Nothing 31 | return (PrimEv (identClock c) mv, setValue mv) 32 | where setValue mv x = 33 | do i <- readIORef (roundRef c) 34 | v <- readIORef mv 35 | case v of 36 | Just _ -> error "Already called callback!" 37 | _ -> return () 38 | writeIORef mv (Just (Round (identClock c) (i + 1), x)) 39 | writeIORef (changedRef c) True 40 | scheduleRound c 41 | 42 | spawn :: Clock -> IO a -> IO (PrimEv a) 43 | spawn c m = 44 | do (pe,setVal) <- callbackp c 45 | forkIO $ m >>= setVal 46 | return pe 47 | 48 | spawnOS :: Clock -> IO a -> IO (PrimEv a) 49 | spawnOS c m = 50 | do (pe,setVal) <- callbackp c 51 | forkOS $ m >>= setVal 52 | return pe 53 | 54 | curRound :: Clock -> IO Round 55 | curRound c = Round (identClock c) <$> readIORef (roundRef c) 56 | 57 | newRound :: Clock -> IO Bool 58 | newRound c = 59 | readIORef (changedRef c) >>= \change -> 60 | if change 61 | then do writeIORef (changedRef c) False 62 | modifyIORef (roundRef c) (+1) 63 | return True 64 | else return False 65 | 66 | 67 | 68 | 69 | observeAt :: PrimEv a -> Round -> Maybe a 70 | observeAt (PrimEv uv m) (Round ur t) 71 | | uv /= ur = error "Observation of TIVar from another context!" 72 | | otherwise = unsafePerformIO $ 73 | do v <- readIORef m 74 | return $ case v of 75 | Just (Round _ t',a) | t' <= t -> Just a 76 | _ -> Nothing 77 | 78 | instance Eq Round where 79 | (Round lu lt) == (Round ru rt) | lu == ru = lt == rt 80 | | otherwise = error "Rounds not from same clock!" 81 | 82 | instance Ord Round where 83 | compare (Round lu lt) (Round ru rt) 84 | | lu == ru = compare lt rt 85 | | otherwise = error "Rounds not from same clock!" 86 | -------------------------------------------------------------------------------- /Control/FRPNow/Private/Ref.hs: -------------------------------------------------------------------------------- 1 | module Control.FRPNow.Private.Ref where 2 | 3 | import System.Mem.Weak 4 | import Control.Applicative 5 | import Data.IORef 6 | import Debug.Trace 7 | 8 | data Ref a = W (Weak a) 9 | | S a 10 | 11 | 12 | makeWeakIORef :: IORef a -> IO (Ref (IORef a)) 13 | makeWeakIORef v = W <$> mkWeakIORef v (return ()) 14 | {- 15 | makeWeakRef :: k -> v -> IO (Ref v) 16 | makeWeakRef k v = W <$> mkWeak k v Nothing 17 | -} 18 | makeStrongRef :: v -> IO (Ref v) 19 | makeStrongRef v = return $ S v 20 | 21 | 22 | deRef :: Ref a -> IO (Maybe a) 23 | deRef (S a) = return (Just a) 24 | deRef (W a) = deRefWeak a 25 | -------------------------------------------------------------------------------- /Control/FRPNow/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections,TypeOperators,MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Control.FRPNow.Time 6 | -- Copyright : (c) Atze van der Ploeg 2015 7 | -- License : BSD-style 8 | -- Maintainer : atzeus@gmail.org 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- Various utility functions for FRPNow related to the passing of time. 13 | -- All take a "clock" as an argument, i.e. a behavior that 14 | -- gives the seconds since the program started. 15 | -- 16 | -- The clock itself is created by a function specialized to the 17 | -- GUI library you are using FRP with such as 'Control.FRPNow.GTK.getClock' 18 | 19 | module Control.FRPNow.Time(localTime,timeFrac, lastInputs, bufferBehavior,delayBy, delayByN, delayTime, integrate, VectorSpace(..)) where 20 | 21 | import Control.FRPNow.Core 22 | import Control.FRPNow.Lib 23 | import Control.FRPNow.EvStream 24 | import Data.Sequence 25 | import Control.Applicative hiding (empty) 26 | import Data.Foldable 27 | import Debug.Trace 28 | 29 | 30 | 31 | 32 | -- | When sampled at time t, gives the time since time t 33 | localTime :: (Floating time, Ord time) => Behavior time -> Behavior (Behavior time) 34 | localTime t = do n <- t 35 | return ((\x -> x - n) <$> t) 36 | 37 | -- | Gives a behavior that linearly increases from 0 to 1 in the specified duration 38 | timeFrac :: (Floating time, Ord time) => Behavior time -> time -> Behavior (Behavior time) 39 | timeFrac t d = do t' <- localTime t 40 | e <- when $ (>= d) <$> t' 41 | let frac = (\x -> min 1.0 (x / d)) <$> t' 42 | return (frac `switch` (pure 1.0 <$ e)) 43 | 44 | 45 | -- | Tag the events in a stream with their time 46 | tagTime :: (Floating time, Ord time) => Behavior time -> EvStream a -> EvStream (time,a) 47 | tagTime c s = ((,) <$> c) <@@> s 48 | 49 | -- | Gives a behavior containing the values of the events in the stream that occurred in the last n seconds 50 | lastInputs :: (Floating time, Ord time) => 51 | Behavior time -- ^ The "clock" behavior, the behavior monotonically increases with time 52 | -> time -- ^ The duration of the history to be kept 53 | -> EvStream a -- ^ The input stream 54 | -> Behavior (Behavior [a]) 55 | lastInputs clock dur s = do s' <- bufferStream clock dur s 56 | bs <- fromChanges [] s' 57 | let dropIt cur s = dropWhile (\(t,_) -> t + dur < cur) s 58 | return $ (fmap snd) <$> (dropIt <$> clock <*> bs) 59 | 60 | bufferStream :: (Floating time, Ord time) => Behavior time -> time -> EvStream a -> Behavior (EvStream [(time,a)]) 61 | bufferStream clock dur s = do s' <- scanlEv addDrop empty $ tagTime clock s 62 | return $ toList <$> s' where 63 | addDrop ss s@(last,v) = dropWhileL (\(tn,_) -> tn + dur < last) (ss |> s) 64 | 65 | 66 | data TimeTag t a = TimeTag t a 67 | 68 | instance Eq t => Eq (TimeTag t a) where 69 | (TimeTag t1 _) == (TimeTag t2 _) = t1 == t2 70 | 71 | 72 | 73 | -- | Gives a behavior containing the values of the behavior during the last n seconds, with time stamps 74 | bufferBehavior :: (Floating time, Ord time) => 75 | Behavior time -- ^ The "clock" behavior, the behavior monotonically increases with time 76 | -> time -- ^ The duration of the history to be kept 77 | -> Behavior a -- ^ The input behavior 78 | -> Behavior (Behavior [(time,a)]) 79 | bufferBehavior clock dur b = fmap toList <$> foldB update empty (TimeTag <$> clock <*> b) 80 | where update l (TimeTag now x) = trimList (l |> (now,x)) (now - dur) 81 | trimList l after = loop l where 82 | loop l = 83 | case viewl l of 84 | EmptyL -> empty 85 | (t1,v1) :< tail1 86 | | after <= t1 -> l 87 | | otherwise -> 88 | case viewl tail1 of 89 | (t2,v2) :< tail2 90 | | t2 <= after -> loop tail2 91 | | otherwise -> l 92 | 93 | 94 | -- | Give a version of the behavior delayed by n seconds 95 | delayBy :: (Floating time, Ord time) => 96 | Behavior time -- ^ The "clock" behavior, the behavior monotonically increases with time 97 | -> time -- ^ The duration of the delay 98 | -> Behavior a -- ^ The input behavior 99 | -> Behavior (Behavior a) 100 | delayBy time d b = fmap (snd . head) <$> bufferBehavior time d b 101 | 102 | 103 | -- | Give n delayed versions of the behavior, each with the given duration in delay between them. 104 | delayByN :: (Floating time, Ord time) => 105 | Behavior time -- ^ The "clock" behavior, the behavior monotonically increases with time 106 | -> time -- ^ The duration _between_ delayed versions 107 | -> Integer -- ^ The number of delayed versions 108 | -> Behavior a -- ^ The input behavior 109 | -> Behavior (Behavior [a]) 110 | delayByN clock dur n b = 111 | let durN = (fromIntegral n) * dur 112 | in do samples <- bufferBehavior clock durN b 113 | return $ interpolateFromList <$> clock <*> samples where 114 | interpolateFromList now l= loop (n - 1) l where 115 | loop n l = 116 | if n < 0 then [] 117 | else let sampleTime = now - (fromIntegral n * dur) 118 | in case l of 119 | [] -> [] 120 | [(_,v)] -> v : loop (n-1) l 121 | ((t1,v1) : (t2,v2) : rest) 122 | | sampleTime >= t2 -> loop n ((t2,v2) : rest) 123 | | otherwise -> v1 : loop (n-1) l 124 | 125 | 126 | 127 | -- | Integration using rectangle rule approximation. Integration depends on when we start integrating so the result is @Behavior (Behavior v)@. 128 | integrate :: (VectorSpace v time) => 129 | Behavior time -> Behavior v -> Behavior (Behavior v) 130 | integrate time v = do t <- time 131 | vp <- delayTime time (t,zeroVector) ((,) <$> time <*> v) 132 | foldB add zeroVector $ (,) <$> vp <*> time 133 | where add total ((t1,v),t2) = total ^+^ ((t2 - t1) *^ v) 134 | 135 | 136 | -- | Delay a behavior by one tick of the clock. Occasionally useful to prevent immediate feedback loops. Like 'Control.FRPNow.EvStream.delay', but uses the changes of the clock as an event stream. 137 | delayTime :: Eq time => Behavior time -> a -> Behavior a -> Behavior (Behavior a) 138 | delayTime time i b = loop i where 139 | loop i = 140 | do e <- futuristic $ 141 | do (t,cur) <- (,) <$> time <*> b 142 | e <- when ((/= t) <$> time) 143 | return (cur <$ e) 144 | e' <- plan ( loop <$> e) 145 | return (i `step` e') 146 | 147 | infixr *^ 148 | infixl ^/ 149 | infix 7 `dot` 150 | infixl 6 ^+^, ^-^ 151 | 152 | -- | A type class for vector spaces. Stolen from Yampa. Thanks Henrik :) 153 | 154 | -- Minimal instance: zeroVector, (*^), (^+^), dot 155 | class (Eq a, Eq v, Ord v, Ord a, Floating a) => VectorSpace v a | v -> a where 156 | zeroVector :: v 157 | (*^) :: a -> v -> v 158 | (^/) :: v -> a -> v 159 | negateVector :: v -> v 160 | (^+^) :: v -> v -> v 161 | (^-^) :: v -> v -> v 162 | dot :: v -> v -> a 163 | norm :: v -> a 164 | normalize :: v -> v 165 | 166 | v ^/ a = (1/a) *^ v 167 | 168 | negateVector v = (-1) *^ v 169 | 170 | v1 ^-^ v2 = v1 ^+^ negateVector v2 171 | 172 | norm v = sqrt (v `dot` v) 173 | 174 | normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector" 175 | where nv = norm v 176 | 177 | ------------------------------------------------------------------------------ 178 | -- Vector space instances for Float and Double 179 | ------------------------------------------------------------------------------ 180 | 181 | instance VectorSpace Float Float where 182 | zeroVector = 0 183 | 184 | a *^ x = a * x 185 | 186 | x ^/ a = x / a 187 | 188 | negateVector x = (-x) 189 | 190 | x1 ^+^ x2 = x1 + x2 191 | 192 | x1 ^-^ x2 = x1 - x2 193 | 194 | x1 `dot` x2 = x1 * x2 195 | 196 | 197 | instance VectorSpace Double Double where 198 | zeroVector = 0 199 | 200 | a *^ x = a * x 201 | 202 | x ^/ a = x / a 203 | 204 | negateVector x = (-x) 205 | 206 | x1 ^+^ x2 = x1 + x2 207 | 208 | x1 ^-^ x2 = x1 - x2 209 | 210 | x1 `dot` x2 = x1 * x2 211 | 212 | 213 | ------------------------------------------------------------------------------ 214 | -- Vector space instances for small tuples of Floating 215 | ------------------------------------------------------------------------------ 216 | 217 | instance (Eq a, Floating a, Ord a) => VectorSpace (a,a) a where 218 | zeroVector = (0,0) 219 | 220 | a *^ (x,y) = (a * x, a * y) 221 | 222 | (x,y) ^/ a = (x / a, y / a) 223 | 224 | negateVector (x,y) = (-x, -y) 225 | 226 | (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2) 227 | 228 | (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2) 229 | 230 | (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2 231 | 232 | 233 | instance (Eq a, Floating a, Ord a) => VectorSpace (a,a,a) a where 234 | zeroVector = (0,0,0) 235 | 236 | a *^ (x,y,z) = (a * x, a * y, a * z) 237 | 238 | (x,y,z) ^/ a = (x / a, y / a, z / a) 239 | 240 | negateVector (x,y,z) = (-x, -y, -z) 241 | 242 | (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2) 243 | 244 | (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2) 245 | 246 | (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2 247 | 248 | 249 | instance (Eq a, Floating a, Ord a) => VectorSpace (a,a,a,a) a where 250 | zeroVector = (0,0,0,0) 251 | 252 | a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u) 253 | 254 | (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a) 255 | 256 | negateVector (x,y,z,u) = (-x, -y, -z, -u) 257 | 258 | (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2) 259 | 260 | (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2) 261 | 262 | (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 263 | 264 | 265 | instance (Eq a, Floating a, Ord a) => VectorSpace (a,a,a,a,a) a where 266 | zeroVector = (0,0,0,0,0) 267 | 268 | a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v) 269 | 270 | (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a) 271 | 272 | negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v) 273 | 274 | (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2) 275 | 276 | (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2) 277 | 278 | (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) = 279 | x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2 280 | 281 | -------------------------------------------------------------------------------- /Examples/GTK/CountClicks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, ViewPatterns, RecursiveDo, ScopedTypeVariables #-} 2 | 3 | import Graphics.UI.Gtk 4 | import Control.FRPNow 5 | import Control.FRPNow.GTK 6 | import Control.Applicative 7 | import Control.Concurrent 8 | import Control.Monad.Trans 9 | 10 | -- Shows simple usage of FRPNow with GTK 11 | 12 | main :: IO () 13 | main = runNowGTK $ do 14 | 15 | -- initialization code 16 | window <- sync $ windowNew 17 | sync $ set window [ containerBorderWidth := 10 ] 18 | hbuttonbox <- sync $ hButtonBoxNew 19 | sync $ set window [ containerChild := hbuttonbox ] 20 | sync $ window `on` deleteEvent $ liftIO mainQuit >> return False 21 | 22 | 23 | -- create buttons 24 | button1 <- clickMeButton 25 | button2 <- clickMeButton 26 | button3 <- clickMeButton 27 | 28 | 29 | 30 | -- layout and more initialization 31 | sync $ set hbuttonbox [ containerChild := button 32 | | button <- [button1, button2, button3] ] 33 | sync $ set hbuttonbox [ buttonBoxLayoutStyle := ButtonboxStart ] 34 | sync $ widgetShowAll window 35 | 36 | 37 | 38 | clickMeButton :: Now Button 39 | clickMeButton = mdo count <- sample $ foldEs (\c _ -> c + 1) 0 clicks 40 | enoughEv <- sample $ when ((> 10) <$> count) 41 | let clickMessage i = "You've clicked : " ++ show i ++ " times, click more!" 42 | let message = (clickMessage <$> count) `switch` (pure "You've clicked enough!" <$ enoughEv) 43 | (button, clicks) <- createButton message 44 | return button 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /Examples/GTK/EnterCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, ViewPatterns, RecursiveDo, ScopedTypeVariables #-} 2 | 3 | import Graphics.UI.Gtk 4 | import Control.FRPNow 5 | import Control.FRPNow.GTK 6 | import Control.FRPNow.Time 7 | import Control.Applicative 8 | import Control.Concurrent 9 | import Control.Monad.Trans 10 | import Data.List 11 | 12 | -- Shows usage of FRPNow with GTK and time 13 | 14 | main :: IO () 15 | main = runNowGTK $ mdo 16 | 17 | -- initialization code 18 | window <- sync $ windowNew 19 | sync $ set window [ containerBorderWidth := 10 ] 20 | vbox <- sync $ vBoxNew False 20 21 | hbox <- sync $ hBoxNew False 20 22 | sync $ set window [ containerChild := vbox ] 23 | sync $ window `on` deleteEvent $ liftIO mainQuit >> return False 24 | 25 | 26 | 27 | (ba,aclicks) <- createButton (pure "a") 28 | (bb,bclicks) <- createButton (pure "b") 29 | clock <- getClock 0.2 30 | 31 | -- logic 32 | let abclicks = ('a' <$ aclicks) `merge` ('b' <$ bclicks) 33 | -- get letters in last 2.5 seconds 34 | input <- sample $ lastInputs clock 2.5 abclicks 35 | -- get the event the code is correct 36 | correctEv <- sample $ when $ ("abbab" `isSuffixOf`) <$> input 37 | 38 | -- display current buffer 39 | let buffer = ("Current buffer: " ++) <$> input 40 | let text = buffer `switch` (pure "correct!" <$ correctEv) 41 | 42 | label <- createLabel text 43 | 44 | -- layout and more initialization 45 | expl <- sync $ labelNew (Just "Type abbab within 2.5 seconds!") 46 | sync $ boxPackStart vbox expl PackNatural 0 47 | sync $ boxPackStart hbox ba PackNatural 0 48 | sync $ boxPackStart hbox bb PackNatural 0 49 | sync $ boxPackStart vbox hbox PackNatural 0 50 | sync $ boxPackStart vbox label PackNatural 0 51 | sync $ widgetShowAll window 52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /Examples/GTK/Sliders.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, ViewPatterns, RecursiveDo, ScopedTypeVariables #-} 2 | 3 | import Graphics.UI.Gtk 4 | import Control.FRPNow 5 | import Control.FRPNow.GTK 6 | import Control.Applicative 7 | import Control.Concurrent 8 | import Control.Monad.Trans 9 | 10 | main :: IO () 11 | main = runNowGTK $ mdo 12 | 13 | -- initialization code 14 | window <- sync $ windowNew 15 | sync $ set window [ containerBorderWidth := 10 ] 16 | hbuttonbox <- sync $ hButtonBoxNew 17 | sync $ set window [ containerChild := hbuttonbox ] 18 | sync $ window `on` deleteEvent $ liftIO mainQuit >> return False 19 | 20 | 21 | -- logic with recursive do 22 | d <- sample $ fromChanges 0 (e1 `merge` fmap (1 - ) e2) 23 | (slider1,e1) <- createSlider 0 1 0.1 d 24 | (slider2,e2) <- createSlider 0 1 0.1 ((1 -) <$> d) 25 | 26 | 27 | -- layout and more initialization 28 | sync $ set hbuttonbox [ containerChild := button 29 | | button <- [slider1, slider2] ] 30 | sync $ set hbuttonbox [ buttonBoxLayoutStyle := ButtonboxStart ] 31 | sync $ widgetShowAll window 32 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /Examples/Gloss/Draw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, ViewPatterns, RecursiveDo, ScopedTypeVariables #-} 2 | 3 | 4 | import Control.Monad.Fix 5 | import Control.Applicative hiding (empty) 6 | import Control.Monad hiding (when) 7 | import Control.FRPNow 8 | 9 | import Control.FRPNow.Gloss 10 | import Graphics.Gloss.Data.Point 11 | import Graphics.Gloss.Interface.IO.Game hiding (Event) 12 | import Graphics.Gloss 13 | import Debug.Trace 14 | import Data.Maybe 15 | import qualified Data.Set as Set 16 | import Data.Set hiding (filter,fold, foldl,map) 17 | import Prelude hiding (until) 18 | 19 | {- Very simple drawing program showing off some advanced FRP constructions, namely BehaviorEnd and parlist 20 | 21 | hold down the left mouse button to draw a box 22 | delete a box by clicking on it with the right mouse button 23 | drag a box with the middle mouse button 24 | -} 25 | 26 | 27 | main = runNowGloss (InWindow "FRPNow Gloss!" (800,600) (10,10)) white 60 mainFRP 28 | 29 | lerpColor :: Float -> Color -> Color -> Color 30 | lerpColor d ca cb = mixColors d (1-d) ca cb 31 | 32 | mainFRP :: Behavior Float -> EvStream GEvent -> Now (Behavior Picture) 33 | mainFRP time evs = 34 | do mousePos <- sample $ toMousePos evs 35 | buttons <- filterMouseButtons <$> sample (toKeysDown evs) 36 | --traceChanges "mouse: " mousePos 37 | sample (boxes mousePos buttons) 38 | 39 | 40 | (.+) :: Point -> Point -> Point 41 | (x,y) .+ (x',y') = (x + x', y + y') 42 | 43 | (.-) :: Point -> Point -> Point 44 | (x,y) .- (x',y') = (x - x', y - y') 45 | 46 | 47 | 48 | data Rect = Rect { leftup :: Point , rightdown :: Point } 49 | 50 | isInside p (Rect c1 c2) = pointInBox p c1 c2 51 | 52 | moveRect (Rect p1 p2) m = Rect (p1 .+ m) (p2 .+ m) 53 | 54 | drawRect :: Rect -> Picture 55 | drawRect (Rect (xl,yu) (xr,yd)) = Polygon [(xl,yu),(xr,yu),(xr,yd),(xl,yd)] 56 | 57 | boxes :: Behavior Point -> Behavior (Set MouseButton) -> Behavior (Behavior Picture) 58 | boxes mousePos buttons = do boxes <- parList ( box `snapshots` clicks LeftButton ) 59 | return (Pictures . reverse <$> boxes) where 60 | box :: Behavior (BehaviorEnd Picture ()) 61 | box = open $ 62 | do p1 <- sample mousePos 63 | let defineRect = Rect p1 <$> mousePos 64 | let defineBox = Color <$> pure red <*> (drawRect <$> defineRect) 65 | defineBox `till` next (releases LeftButton) 66 | r <- sample $ defineRect 67 | r <- sample $ movableRect r 68 | let mo = mouseOver r 69 | let toColor True = green 70 | toColor False = red 71 | let color = toColor <$> mo 72 | (Color <$> color <*> (drawRect <$> r)) `till` clickOn r RightButton 73 | 74 | 75 | movableRect :: Rect -> Behavior (Behavior Rect) 76 | movableRect r = behavior <$> open (loop r) where 77 | loop :: Rect -> (Behavior :. BehaviorEnd Rect) () 78 | loop r = do let rb = pure r 79 | rb `till` next (clicks MiddleButton `during` mouseOver rb) 80 | off <- sample mouseOffset 81 | let r' = (r `moveRect`) <$> off 82 | r' `till` release MiddleButton 83 | sample r' >>= loop 84 | 85 | mouseOffset :: Behavior (Behavior Point) 86 | mouseOffset = do p <- mousePos 87 | return ((.- p) <$> mousePos) 88 | 89 | clickOn :: Behavior Rect -> MouseButton -> Behavior (Event ()) 90 | clickOn r b = next $ clicks b `during` mouseOver r 91 | 92 | mouseOver :: Behavior Rect -> Behavior Bool 93 | mouseOver r = isInside <$> mousePos <*> r 94 | 95 | clicks :: MouseButton -> EvStream () 96 | clicks m = edges $ (m `Set.member`) <$> buttons 97 | releases m = edges $ not . (m `Set.member`) <$> buttons 98 | release m = next (releases m) 99 | 100 | 101 | -------------------------------------------------------------------------------- /Examples/Gloss/FollowMouse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, ViewPatterns, RecursiveDo, ScopedTypeVariables #-} 2 | 3 | 4 | import Control.Monad.Fix 5 | import Control.Applicative hiding (empty) 6 | import Control.Monad hiding (when) 7 | import Control.FRPNow 8 | import Control.FRPNow.Gloss 9 | import Graphics.Gloss 10 | import Debug.Trace 11 | import Data.Maybe 12 | import Data.Set hiding (filter,fold, foldl,map) 13 | import Prelude hiding (until) 14 | 15 | -- Example from the original FRP paper ("Functional Reactive Animation", Elliot and Hudak) 16 | -- 17 | 18 | main = runNowGlossPure (InWindow "FRPNow Gloss!" (800,600) (10,10)) white 60 mainFRP 19 | 20 | lerpColor :: Float -> Color -> Color -> Color 21 | lerpColor d ca cb = mixColors d (1-d) cb ca 22 | 23 | mainFRP :: Behavior Float -> EvStream GEvent -> Behavior (Behavior Picture) 24 | mainFRP time evs = 25 | let pict speed (x,y) = Color (lerpColor (speed / 1000) green red) $ 26 | Translate x y $ ThickCircle 25 (50) 27 | in do mousePos <- toMousePos evs 28 | (followPos, followSpeed) <- followMouse time mousePos 29 | return (pict <$> followSpeed <*> followPos) 30 | 31 | 32 | followMouse :: Behavior Float -> -- The time 33 | Behavior Point -> -- The mouse 34 | Behavior (Behavior Point, Behavior Float) -- the result 35 | followMouse time mouse = 36 | mdo let dragfactor = 0.1 37 | let speedup = 10.0 38 | let accelfunc m p r = speedup *^ ((m ^-^ p) ^-^ (dragfactor *^ r)) 39 | let accel = accelfunc <$> mouse <*> pos <*> speed 40 | speed <- integrate time accel 41 | pos <- integrate time speed 42 | return (pos,norm <$> speed) 43 | -------------------------------------------------------------------------------- /Examples/Gloss/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, ViewPatterns, RecursiveDo, ScopedTypeVariables #-} 2 | 3 | 4 | import Control.Monad.Fix 5 | import Control.Applicative hiding (empty) 6 | import Control.Monad hiding (when) 7 | import Control.FRPNow 8 | import Control.FRPNow.Gloss 9 | import Graphics.Gloss.Interface.Pure.Game 10 | import Graphics.Gloss 11 | import Debug.Trace 12 | import Data.Maybe 13 | import Data.Set hiding (filter,fold, foldl,map) 14 | import Prelude hiding (until) 15 | 16 | main = runNowGloss (InWindow "FRPNow Gloss!" (800,600) (10,10)) white 60 mainFRP 17 | 18 | lerpColor :: Float -> Color -> Color -> Color 19 | lerpColor d ca cb = mixColors d (1-d) ca cb 20 | 21 | mainFRP :: Behavior Float -> EvStream GEvent -> Now (Behavior Picture) 22 | mainFRP time evs = 23 | let posSin x = (sin x + 1) / 2.0 24 | pict b time (x,y) = Color (if b then red else green) $ 25 | Translate x y $ 26 | ThickCircle 25 ((posSin time) * 50 + 10) 27 | done = Translate (-300) 0 $ Scale 0.4 0.4 $ Text "I'm done with it" 28 | in do mousePos <- sample (toMousePos evs) 29 | keys <- sample (toKeysDown evs) 30 | let spaceDown = (SpecialKey KeySpace `member`) <$> keys 31 | 32 | e <- sample $ when ((>= 30.0) <$> time) 33 | plan (sync (putStrLn "You've done this for half a minute!") <$ e) 34 | 35 | let init = pict <$> spaceDown <*> time <*> mousePos 36 | let b = init `switch` (pure done <$ e) 37 | return b 38 | 39 | -------------------------------------------------------------------------------- /Examples/Gloss/TimeFlows.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, ViewPatterns, RecursiveDo, ScopedTypeVariables #-} 2 | 3 | 4 | import Control.Monad.Fix 5 | import Control.Applicative hiding (empty) 6 | import Control.Monad hiding (when) 7 | import Control.FRPNow 8 | import Control.FRPNow.Gloss 9 | import Graphics.Gloss 10 | import Debug.Trace 11 | import Data.Maybe 12 | import Data.Set hiding (filter,fold, foldl,map) 13 | import Prelude hiding (until) 14 | 15 | -- Shows of delayByN 16 | 17 | nrBoxes = 20 18 | timeDelay = 0.3 -- seconds 19 | 20 | width = 800 21 | height = 600 22 | 23 | main = runNowGloss (InWindow "FRPNow Gloss!" (width,height) (10,10)) white 120 (\t e -> sample $ mainFRP t e) 24 | 25 | mainFRP :: Behavior Float -> EvStream GEvent -> Behavior (Behavior Picture) 26 | mainFRP clock evs = 27 | do mouse <- toMousePos evs 28 | mouseHist <- delayByN clock timeDelay nrBoxes mouse 29 | let pict (x,y) = Color red $ Translate x y (ThickCircle 10 5) 30 | return (Pictures . map pict <$> mouseHist) 31 | 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /Examples/Test.hs: -------------------------------------------------------------------------------- 1 | import Control.FRPNow 2 | import Control.Applicative 3 | 4 | n = 11000 5 | 6 | main = runNowMaster (test n) 7 | 8 | test :: Int -> Now (Event ()) 9 | test n = do b <- count 10 | e <- sample (when ((n ==) <$> b)) 11 | return e 12 | 13 | count :: Now (Behavior Int) 14 | count = loop 0 where 15 | loop i = do e <- async (return ()) 16 | e'<- planNow (loop (i+1) <$ e) 17 | return (pure i `switch` e') 18 | -------------------------------------------------------------------------------- /FRPNow-GTK/ChangeLog: -------------------------------------------------------------------------------- 1 | 0.11 Import applicative 2 | 0.1 Initial version 3 | -------------------------------------------------------------------------------- /FRPNow-GTK/Control/FRPNow/GTK.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.FRPNow.GTK 4 | -- Copyright : (c) Atze van der Ploeg 2015 5 | -- License : BSD-style 6 | -- Maintainer : atzeus@gmail.org 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- This module provides interoperability of FRPNow and the GTK system. 11 | 12 | module Control.FRPNow.GTK( 13 | -- * General interface 14 | runNowGTK, setAttr, getSignal, getUnitSignal, getSimpleSignal, getClock, 15 | -- * Utility functions 16 | createLabel, createButton, createProgressBar,createSlider 17 | ) where 18 | 19 | import Graphics.UI.Gtk 20 | import Control.Applicative 21 | import Control.FRPNow 22 | import Data.Maybe 23 | import Data.IORef 24 | import Debug.Trace 25 | import System.Mem.Weak 26 | import System.Glib.GDateTime 27 | 28 | -- | Run a Now computation which can interact with GTK. Also starts the GTK system. 29 | -- Call only once, or GTK will freak out. 30 | runNowGTK :: Now () -> IO () 31 | runNowGTK n = do initGUI 32 | doneRef <- newIORef Nothing 33 | initNow (schedule doneRef) (n >> return never) 34 | mainGUI 35 | 36 | 37 | 38 | schedule :: IORef (Maybe a) -> IO (Maybe a) -> IO () 39 | schedule ref m = postGUIAsync $ 40 | m >>= \x -> 41 | case x of 42 | Just _ -> writeIORef ref x 43 | Nothing -> return () 44 | 45 | -- | Set a GTK attribute to a behavior. Each time the behavior changes the 46 | -- attribute is updated. 47 | setAttr :: (WidgetClass w, Eq a) => Attr w a -> w -> Behavior a -> Now () 48 | setAttr a w b = 49 | do i <- sample b 50 | sync $ set w [a := i] 51 | (e,cb) <- callback 52 | sync $ on w unrealize ( cb ()) 53 | let updates = toChanges b `beforeEs` e 54 | callIOStream setEm updates 55 | where setEm i = set w [a := i] >> widgetQueueDraw w 56 | 57 | 58 | -- | Obtain an event stream from a unit GTK signal, i.e. a signal with handler type: 59 | -- 60 | -- > IO () 61 | getUnitSignal :: GObjectClass widget => Signal widget (IO ()) -> widget -> Now (EvStream ()) 62 | getUnitSignal s w = getSignal s w (\f -> f ()) 63 | 64 | 65 | -- | Obtain an event stream from a GTK signal giving a single value. 66 | getSimpleSignal :: GObjectClass widget => Signal widget (value -> IO ()) -> widget -> Now (EvStream value) 67 | getSimpleSignal s w = getSignal s w id 68 | 69 | 70 | -- | General interface to convert an GTK signal to an event stream. 71 | -- 72 | -- The signal has type @callback@, for example @(ScrollType -> Double -> IO Bool)@ 73 | -- and the eventstream gives elements of type @value@, for instance @(ScrollType,Double)@ 74 | -- The conversion function (3rd argument) takes a function to call for producing the value 75 | -- in our example, a function of type @(ScollType,Double) -> IO ()@ and produces 76 | -- a function of the form @callback@, in our example @(ScrollType -> Double -> IO Bool)@. 77 | -- 78 | -- In this example we can convert a signal with handler @(ScrollType -> Double -> IO Bool)@ 79 | -- to an eventstream giving elements of type @(ScrollType,Double)@ by letting the handler return @False@ 80 | -- as follows: 81 | -- 82 | -- > scrollToEvStream :: Signal widget (ScrollType -> Double -> IO Bool) -> widget -> Now (EvStream (ScrollType,Double)) 83 | -- > scrollToEvStream s w = getSignal s w convert where 84 | -- > convert call scrolltype double = do call (scrolltype, double) 85 | -- > return False 86 | -- 87 | -- The signal is automatically disconnected, when the event stream is garbage collected. 88 | getSignal :: GObjectClass widget => Signal widget callback -> widget -> ((value -> IO ()) -> callback) -> Now (EvStream value) 89 | getSignal s w conv = 90 | do (res,f) <- callbackStream 91 | conn <- sync $ on w s (conv f) 92 | --sync $ addFinalizer res (putStrLn "Run final" >> signalDisconnect conn) 93 | return res 94 | 95 | 96 | -- | Get a clock that gives the time since the creation of the clock in seconds, and updates maximally even given number of seconds. 97 | -- 98 | -- The clock is automatically destroyed and all resources associated with the clock are freed 99 | -- when the behavior is garbage collected. 100 | getClock :: Double -> Now (Behavior Double) 101 | getClock precision = 102 | do start <- sync $ gGetCurrentTime 103 | (res,cb) <- callbackStream 104 | wres<- sync $ mkWeakPtr res Nothing 105 | let getDiff = do now <- gGetCurrentTime 106 | let seconds = gTimeValSec now - gTimeValSec start 107 | let microsec = gTimeValUSec now - gTimeValUSec start 108 | return $ (fromIntegral seconds) + (fromIntegral microsec) * 0.000001 109 | let onTimeOut = 110 | deRefWeak wres >>= \x -> 111 | case x of 112 | Just _ -> getDiff >>= cb >> return True 113 | Nothing -> return False 114 | sync $ timeoutAdd onTimeOut (round (precision * 1000)) 115 | sample $ fromChanges 0 res 116 | 117 | 118 | 119 | createLabel :: Behavior String -> Now Label 120 | createLabel s = 121 | do l <- sync $ labelNew (Nothing :: Maybe String) 122 | setAttr labelLabel l s 123 | return l 124 | 125 | 126 | createButton :: Behavior String -> Now (Button,EvStream ()) 127 | createButton s = 128 | do button <- sync $ buttonNew 129 | setAttr buttonLabel button s 130 | stream <- getUnitSignal buttonActivated button 131 | return (button,stream) 132 | 133 | 134 | createProgressBar :: Now (ProgressBar, Double -> IO ()) 135 | createProgressBar = 136 | do (evs, cb) <- callbackStream 137 | progress <- sample $ fromChanges 0 evs 138 | bar <- sync $ progressBarNew 139 | setAttr progressBarFraction bar progress 140 | return (bar,cb) 141 | 142 | createSlider :: Double -> Double -> Double -> Behavior Double -> Now (HScale,EvStream Double) 143 | createSlider min max step b = 144 | do i <- sample b 145 | slider <- sync $ hScaleNewWithRange min max step 146 | setAttr rangeValue slider b 147 | stream <- getSignal changeValue slider (\f _ d -> f d >> return True) 148 | return (slider,stream) 149 | 150 | 151 | 152 | -------------------------------------------------------------------------------- /FRPNow-GTK/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Atze van der Ploeg 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 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. 9 | 10 | 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. 11 | -------------------------------------------------------------------------------- /FRPNow-GTK/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /FRPNow-GTK/frpnow-gtk.cabal: -------------------------------------------------------------------------------- 1 | Name: frpnow-gtk 2 | Version: 0.11 3 | Synopsis: Program GUIs with GTK and frpnow! 4 | Description: Program GUIs with GTK and frpnow! 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: Atze van der Ploeg 8 | Maintainer: atzeus@gmail.com 9 | Homepage: https://github.com/atzeus/FRPNow 10 | Build-Type: Simple 11 | Cabal-Version: >=1.6 12 | Data-files: ChangeLog 13 | Category: Control 14 | Tested-With: GHC==7.10.1 15 | Library 16 | Build-Depends: base >= 2 && <= 6, mtl >= 1.0, containers, transformers, frpnow, glib, gtk 17 | Exposed-modules: Control.FRPNow.GTK 18 | Extensions: RankNTypes, GADTs, CPP, EmptyDataDecls 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/atzeus/FRPNow/FRPNow-GTK 23 | -------------------------------------------------------------------------------- /FRPNow-GTK/frpnow-gtk.cabal~: -------------------------------------------------------------------------------- 1 | Name: frpnow-gtk 2 | Version: 0.1 3 | Synopsis: Program GUIs with GTK and frpnow! 4 | Description: Program GUIs with GTK and frpnow! 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: Atze van der Ploeg 8 | Maintainer: atzeus@gmail.com 9 | Homepage: https://github.com/atzeus/FRPNow 10 | Build-Type: Simple 11 | Cabal-Version: >=1.6 12 | Data-files: ChangeLog 13 | Category: Control 14 | Tested-With: GHC==7.10.1 15 | Library 16 | Build-Depends: base >= 2 && <= 6, mtl >= 1.0, containers, transformers, frpnow, glib, gtk 17 | Exposed-modules: Control.FRPNow.GTK 18 | Extensions: RankNTypes, GADTs, CPP, EmptyDataDecls 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/atzeus/FRPNow/FRPNow-GTK 23 | -------------------------------------------------------------------------------- /FRPNow-Gloss/ChangeLog: -------------------------------------------------------------------------------- 1 | 0.12 Import applicative 2 | 0.11 Bump version to force rebuild docs 3 | 0.1 Initial version 4 | -------------------------------------------------------------------------------- /FRPNow-Gloss/Control/FRPNow/Gloss.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.FRPNow.Gloss 4 | -- Copyright : (c) Atze van der Ploeg 2015 5 | -- License : BSD-style 6 | -- Maintainer : atzeus@gmail.org 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- This module provides interoperability of FRPNow and the gloss system. 11 | 12 | module Control.FRPNow.Gloss(GEvent,Time,runNowGloss, runNowGlossPure, toMouseMoves, toMousePos, toKeysDown, filterMouseButtons) where 13 | 14 | import Graphics.Gloss.Interface.IO.Game hiding (Event) 15 | import Control.FRPNow 16 | import Data.Sequence 17 | import Control.Applicative 18 | import qualified Data.Sequence as Seq 19 | import Data.Maybe 20 | import Data.IORef 21 | import Debug.Trace 22 | import GHC.Float 23 | import qualified Data.Foldable as Fold 24 | import Data.Set 25 | import qualified Data.Set as Set 26 | import qualified Graphics.Gloss.Interface.IO.Game as Gloss 27 | import Debug.Trace 28 | 29 | -- | Alias for 'Gloss.Event' to prevent name clash with 'Event'. 30 | type GEvent = Gloss.Event 31 | -- | The gloss type for time. 32 | type Time = Float 33 | 34 | -- | Run a Now computation which produced a behavior of type Picture, and draw that on screen. 35 | runNowGloss :: 36 | Display -- ^ Display mode. 37 | -> Color -- ^ Background color. 38 | -> Int -- ^ Maximum number of frames per second 39 | -> (Behavior Time -> EvStream GEvent -> Now (Behavior Picture)) -- ^ A now computation giving the picture to be displayed on the screen, taking the behavior of time and the eventstream of gloss events. 40 | -> IO () 41 | runNowGloss disp bg fps m = 42 | do scheduleRef <- newIORef Seq.empty 43 | callbackRef <- newIORef undefined 44 | pictureRef <- newIORef Blank 45 | initNow (schedule scheduleRef) (initM callbackRef pictureRef) 46 | (cbTime, cbgEv) <- readIORef callbackRef 47 | playIO disp bg fps () 48 | (\_ -> readIORef pictureRef) 49 | (\ev _ -> cbgEv ev) 50 | (\deltaTime _ -> do cbTime deltaTime 51 | rounds <- readIORef scheduleRef 52 | writeIORef scheduleRef Seq.empty 53 | mapM_ id (Fold.toList rounds) 54 | return () 55 | ) 56 | 57 | 58 | where 59 | initM callbackRef pictureRef = 60 | do (timeEvs,cbtime) <- callbackStream 61 | (gevEvs,cbgEv) <- callbackStream 62 | sync $ writeIORef callbackRef (cbtime,cbgEv) 63 | clock <- sample $ foldEs (+) 0 timeEvs 64 | pict <- m clock gevEvs 65 | curPict <- sample pict 66 | sync $ writeIORef pictureRef curPict 67 | callIOStream (writeIORef pictureRef) (toChanges pict) 68 | return never 69 | 70 | schedule ref m = atomicModifyIORef ref (\s -> (s |> m, ())) 71 | 72 | -- | Like 'runNowGloss', but does not allow IO. 73 | runNowGlossPure :: 74 | Display -- ^ Display mode. 75 | -> Color -- ^ Background color. 76 | -> Int -- ^ Maximum number of frames per second 77 | -> (Behavior Time -> EvStream GEvent -> Behavior (Behavior Picture)) -- ^ A behavior giving the picture to be displayed on the screen, taking the behavior of time and the eventstream of gloss events. 78 | -> IO () 79 | runNowGlossPure disp bg fps b = runNowGloss disp bg fps (\t e -> sample $ b t e) 80 | 81 | -- | Filter the mouse moves from an event stream of gloss events 82 | toMouseMoves :: EvStream GEvent -> EvStream (Float,Float) 83 | toMouseMoves evs = filterMapEs getMouseMove evs 84 | where getMouseMove (EventMotion p) = Just p 85 | getMouseMove _ = Nothing 86 | 87 | -- | Get a behavior of the mouse position from an event stream of gloss events 88 | toMousePos :: EvStream GEvent -> Behavior (Behavior (Float, Float)) 89 | toMousePos evs = fromChanges (0,0) (toMouseMoves evs) 90 | 91 | -- | Get a behavior of the set of currently pressed keys from an event stream of gloss events 92 | toKeysDown :: EvStream GEvent -> Behavior (Behavior (Set Key)) 93 | toKeysDown evs = foldEs updateSet Set.empty evs where 94 | updateSet :: Set Key -> GEvent -> Set Key 95 | updateSet s (EventKey k i _ _) = action i k s 96 | where action Up = delete 97 | action Down = insert 98 | updateSet s _ = s 99 | 100 | filterMouseButtons :: Behavior (Set Key) -> Behavior (Set MouseButton) 101 | filterMouseButtons b = 102 | let isMouseButton (MouseButton _) = True 103 | isMouseButton _ = False 104 | in Set.map (\(MouseButton x) -> x) . Set.filter isMouseButton <$> b 105 | -------------------------------------------------------------------------------- /FRPNow-Gloss/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Atze van der Ploeg 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 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. 9 | 10 | 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. 11 | -------------------------------------------------------------------------------- /FRPNow-Gloss/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /FRPNow-Gloss/frpnow-gloss.cabal: -------------------------------------------------------------------------------- 1 | Name: frpnow-gloss 2 | Version: 0.12 3 | Synopsis: Program awesome stuff with Gloss and frpnow! 4 | Description: Program awesome stuff with Gloss and frpnow! 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: Atze van der Ploeg 8 | Maintainer: atzeus@gmail.com 9 | Homepage: https://github.com/atzeus/FRPNow 10 | Build-Type: Simple 11 | Cabal-Version: >=1.6 12 | Data-files: ChangeLog 13 | Category: Control 14 | Tested-With: GHC==7.10.1 15 | Library 16 | Build-Depends: base >= 2 && <= 6, mtl >= 1.0, containers, transformers, frpnow, gloss 17 | Exposed-modules: Control.FRPNow.Gloss 18 | Extensions: RankNTypes, GADTs, CPP, EmptyDataDecls 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/atzeus/FRPNow/FRPNow-Gloss 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Atze van der Ploeg 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 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. 9 | 10 | 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. 11 | -------------------------------------------------------------------------------- /PaperImpl/ConcFlag.hs: -------------------------------------------------------------------------------- 1 | module ConcFlag where 2 | 3 | import Control.Concurrent.MVar 4 | 5 | type Flag = MVar () 6 | 7 | {- A concurrent flag signaling if an update should take place, 8 | designed for one reader and multiple writers 9 | if the flag is set, the reader has not seen the flag yet, 10 | and setting the flag is idempotent. -} 11 | 12 | newFlag :: IO Flag 13 | newFlag = newEmptyMVar 14 | 15 | waitForSignal :: Flag -> IO () 16 | waitForSignal m = takeMVar m 17 | 18 | signal :: Flag -> IO () 19 | signal v = do b <- tryPutMVar v (); return () 20 | -------------------------------------------------------------------------------- /PaperImpl/EventStream.hs: -------------------------------------------------------------------------------- 1 | module EventStream where 2 | import FRPNow 3 | import Lib 4 | import Control.Applicative 5 | import Control.Monad 6 | 7 | newtype Stream a = S { next :: B (E a) } 8 | 9 | repeatIO :: IO a -> Now (Stream a) 10 | repeatIO m = S <$> loop where 11 | loop = do h <- async m 12 | t <- planNow (loop <$ h) 13 | return (pure h `switch` t) 14 | 15 | snapshots :: B a -> Stream () -> Stream a 16 | snapshots b (S s) = S $ do e <- s 17 | snapshot b e 18 | 19 | catMaybesStream :: Stream (Maybe a) -> Stream a 20 | catMaybesStream (S s) = S loop where 21 | loop = do e <- s 22 | join <$> plan (nxt <$> e) 23 | -- nxt :: Maybe a -> B (E a) 24 | nxt (Just a) = return (return a) 25 | nxt Nothing = loop 26 | 27 | -------------------------------------------------------------------------------- /PaperImpl/FRPNow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ExistentialQuantification, Rank2Types,GeneralizedNewtypeDeriving #-} 2 | module FRPNow(E,B,Now, never, switch, whenJust, async, sample, planNow, runNow) where 3 | import Control.Applicative 4 | import Control.Monad hiding (mapM_) 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Reader hiding (mapM_) 7 | import Control.Monad.Writer hiding (mapM_) 8 | import Data.IORef 9 | import Ref 10 | import Data.Sequence 11 | import System.IO.Unsafe 12 | import Data.Foldable 13 | import PrimEv 14 | 15 | import Prelude hiding (mapM_) 16 | 17 | -- Section 6.1 18 | data E a = E { runE :: M (Either (E a) a) } 19 | 20 | never = E $ return (Left never) 21 | 22 | instance Monad E where 23 | return x = E $ return (Right x) 24 | m >>= f = memoE (m `bindLeakE` f) -- this in section 6.2 25 | 26 | m `bindLeakE` f = E $ 27 | runE m >>= \r -> case r of 28 | Right x -> runE (f x) 29 | Left e' -> return (Left (e' `bindLeakE` f)) 30 | 31 | minTime :: E x -> E y -> E () 32 | minTime l r = E (merge <$> runE l <*> runE r) where 33 | merge (Right _) _ = Right () 34 | merge _ (Right _ ) = Right () 35 | merge (Left l') (Left r' ) = Left (minTime l' r') 36 | 37 | -- Section 6.2 38 | 39 | unrunE :: Either (E a) a -> E a 40 | unrunE (Left e) = e 41 | unrunE (Right a) = pure a 42 | 43 | memoEIO :: E a -> IO (E a) 44 | memoEIO einit = 45 | do r <- newIORef einit 46 | return (usePrevE r) 47 | 48 | usePrevE :: IORef (E a) -> E a 49 | usePrevE r = E $ 50 | do e <- liftIO (readIORef r) 51 | res <- runE e 52 | liftIO (writeIORef r (unrunE res)) 53 | return res 54 | 55 | memoE :: E a -> E a 56 | memoE e = e 57 | --memoE e = unsafePerformIO $ memoEIO e 58 | 59 | -- Section 6.3 60 | 61 | data B a = B { runB :: M (a, E (B a)) } 62 | 63 | switchLeak :: B a -> E (B a) -> B a 64 | switchLeak b e = B $ 65 | runE e >>= \r -> case r of 66 | Right x -> runB x 67 | Left e' -> do (h,t) <- runB b 68 | return (h, switchE t e') 69 | 70 | switchE :: E (B a) -> E (B a) -> E (B a) 71 | switchE l r = ((pure undefined `switchLeak` l) `switchLeak` r) <$ 72 | minTime l r 73 | 74 | joinBLeak :: B (B a) -> B a 75 | joinBLeak m = B $ 76 | do (h,t) <- runB m 77 | runB $ h `switchLeak` (joinBLeak <$> t) 78 | 79 | fmapLeak f (B b) = B $ 80 | do (h,t) <- b 81 | return (f h, fmap (fmap f) t) 82 | 83 | bindLeakB :: B a -> (a -> B b) -> B b 84 | m `bindLeakB` f = joinBLeak (fmap f m) 85 | 86 | whenJustLeak :: B (Maybe a) -> B (E a) 87 | whenJustLeak b = B $ 88 | do (h, t) <- runB b 89 | case h of 90 | Just x -> return (return x, whenJustLeak <$> t) 91 | Nothing -> 92 | do en <- planM (runB . whenJustLeak <$> t) 93 | return (en >>= fst, en >>= snd) 94 | 95 | instance Functor B where 96 | fmap f b = memoB (fmapLeak f b) 97 | 98 | instance Monad B where 99 | return x = B $ return (x, never) 100 | m >>= f = memoB (m `bindLeakB` f) 101 | 102 | 103 | whenJust :: B (Maybe a) -> B (E a) 104 | whenJust b = memoB (whenJustLeak b) 105 | 106 | switch :: B a -> E (B a) -> B a 107 | switch b e = memoB (switchLeak b e) 108 | 109 | -- Section 6.4 110 | 111 | unrunB :: (a,E (B a)) -> B a 112 | unrunB (h,t) = B $ 113 | runE t >>= \x -> case x of 114 | Right b -> runB b 115 | Left t' -> return (h,t') 116 | 117 | memoBIO :: B a -> IO (B a) 118 | memoBIO einit = 119 | do r <- newIORef einit 120 | return (usePrevB r) 121 | 122 | usePrevB :: IORef (B a) -> B a 123 | usePrevB r = B $ 124 | do b <- liftIO (readIORef r) 125 | res <- runB b 126 | liftIO (writeIORef r (unrunB res)) 127 | return res 128 | 129 | memoB :: B a -> B a 130 | memoB b = b 131 | --memoB b = unsafePerformIO $ memoBIO b 132 | 133 | -- Section 6.7 134 | 135 | 136 | 137 | 138 | type M = WriterT Plans (ReaderT Clock IO) 139 | 140 | newtype Now a = Now { getNow :: M a } deriving (Functor,Applicative,Monad) 141 | 142 | sample :: B a -> Now a 143 | sample (B m) = Now $ fst <$> m 144 | 145 | async :: IO a -> Now (E a) 146 | async m = Now $ do c <- ask 147 | toE <$> liftIO (spawn c m) 148 | 149 | toE :: PrimEv a -> E a 150 | toE p = E (toEither . (p `observeAt`) <$> getRound) 151 | where toEither Nothing = Left (toE p) 152 | toEither (Just x) = Right x 153 | getRound :: (MonadReader Clock m, MonadIO m) => m Round 154 | getRound = ask >>= liftIO . curRound 155 | 156 | data Plan a = Plan (E (M a)) (IORef (Maybe a)) 157 | 158 | planToEv :: Plan a -> E a 159 | planToEv (Plan ev ref) = E $ 160 | liftIO (readIORef ref) >>= \pstate -> 161 | case pstate of 162 | Just x -> return (Right x) 163 | Nothing -> runE ev >>= \estate -> 164 | case estate of 165 | Left ev' -> 166 | return $ Left $ planToEv (Plan ev' ref) 167 | Right m -> do v <- m 168 | liftIO $ writeIORef ref (Just v) 169 | return $ Right v 170 | 171 | data SomePlan = forall a. SomePlan (Ref (Plan a)) 172 | type Plans = Seq SomePlan 173 | 174 | planM :: E (M a) -> M (E a) 175 | planM e = plan makeWeakRef e 176 | 177 | planNow :: E (Now a) -> Now (E a) 178 | planNow e = Now $ plan makeStrongRef (getNow <$> e) 179 | 180 | plan :: (forall x. x -> IO (Ref x)) -> E (M a) -> M (E a) 181 | plan makeRef e = 182 | do p <- Plan e <$> liftIO (newIORef Nothing) 183 | pr <- liftIO (makeRef p) 184 | addPlan pr 185 | return (planToEv p) 186 | 187 | addPlan :: Ref (Plan a) -> M () 188 | addPlan = tell . singleton . SomePlan 189 | 190 | runNow :: Now (E a) -> IO a 191 | runNow (Now m) = do c <- newClock 192 | runReaderT (runWriterT m >>= mainLoop) c 193 | 194 | mainLoop :: (E a, Plans) -> ReaderT Clock IO a 195 | mainLoop (ev,pl) = loop pl where 196 | loop pli = 197 | do (er,ple) <- runWriterT (runE ev) 198 | let pl = pli >< ple 199 | case er of 200 | Right x -> return x 201 | Left _ -> do endRound 202 | pl' <- tryPlans pl 203 | loop pl' 204 | 205 | endRound :: ReaderT Clock IO () 206 | endRound = ask >>= liftIO . waitEndRound 207 | 208 | tryPlans :: Plans -> ReaderT Clock IO Plans 209 | tryPlans pl =snd <$> runWriterT 210 | (mapM_ tryPlan pl) where 211 | tryPlan (SomePlan pr) = 212 | do ps <- liftIO (deRef pr) 213 | case ps of 214 | Just p -> do eres <- runE (planToEv p) 215 | case eres of 216 | Right x -> return () 217 | Left _ -> addPlan pr 218 | Nothing -> return () 219 | 220 | instance Applicative B where 221 | pure = return 222 | (<*>) = ap 223 | 224 | instance Functor E where 225 | fmap = liftM 226 | 227 | instance Applicative E where 228 | pure = return 229 | (<*>) = ap 230 | -------------------------------------------------------------------------------- /PaperImpl/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib where 2 | 3 | import FRPNow 4 | import Control.Applicative 5 | -- Code from paper that is not implementation code 6 | 7 | 8 | -- Section 3.1 9 | 10 | change :: Eq a => B a -> B (E ()) 11 | change b = do cur <- b 12 | when ((cur /=) <$> b) 13 | 14 | when :: B Bool -> B (E ()) 15 | when b = whenJust (boolToMaybe <$> b) 16 | 17 | boolToMaybe True = Just () 18 | boolToMaybe False = Nothing 19 | 20 | snapshot :: B a -> E () -> B (E a) 21 | snapshot b e = let e' = (Just <$> b) <$ e 22 | in whenJust (pure Nothing `switch` e') 23 | 24 | -- section 5, excluding EventStreams (which are in EventStream.hs) 25 | -- section 5.1 26 | 27 | countChanges :: Eq a => B a -> B (B Int) 28 | countChanges b = loop 0 where 29 | loop :: Int -> B (B Int) 30 | loop i = do e <- change b 31 | e' <- snapshot (loop (i+1)) e 32 | return (pure i `switch` e') 33 | 34 | countChanges' :: Eq a => B a -> B (B Integer) 35 | countChanges' = foldB (\x _ -> x + 1) (-1) 36 | 37 | foldB :: Eq a => (b -> a -> b) -> b -> B a -> B (B b) 38 | foldB f i b = loop i where 39 | loop i = do c <- b 40 | let i' = f i c 41 | e <- change b 42 | e' <- snapshot (loop i') e 43 | return (pure i' `switch` e') 44 | 45 | -- section 5.2 46 | 47 | prev :: Eq a => a -> B a -> B (B a) 48 | prev i b = (fst <$>) <$> foldB (\(_,p) c -> (p,c)) (undefined,i) b 49 | 50 | buffer :: Eq a => Int -> B a -> B (B [a]) 51 | buffer n b = foldB (\l e -> take n (e : l)) [] b 52 | 53 | -- section 5. 54 | plan :: E (B a) -> B (E a) 55 | plan e = whenJust 56 | (pure Nothing `switch` ((Just <$>) <$> e)) 57 | 58 | 59 | occ :: E a -> B (Maybe a) 60 | occ e = pure Nothing `switch` ((pure . Just) <$> e) 61 | 62 | 63 | first :: E a -> E a -> B (E a) 64 | first l r = whenJust (occ r `switch` ((pure . Just) <$> l)) 65 | -------------------------------------------------------------------------------- /PaperImpl/PrimEv.hs: -------------------------------------------------------------------------------- 1 | module PrimEv(Round, Clock, PrimEv, newClock , spawn, curRound, waitEndRound ,observeAt ) where 2 | 3 | import ConcFlag 4 | import Control.Concurrent.MVar 5 | import Control.Applicative 6 | import System.IO.Unsafe 7 | import Data.Unique 8 | import Control.Concurrent 9 | import Debug.Trace 10 | 11 | data Clock = Clock Unique Flag (MVar Integer) 12 | data Round = Round Unique Integer 13 | data PrimEv a = PrimEv Unique (MVar (Maybe (Round, a))) 14 | 15 | instance Show Round where 16 | show (Round _ i) = show i 17 | 18 | newClock :: IO Clock 19 | newClock = Clock <$> newUnique <*> newFlag <*> newMVar 0 20 | 21 | 22 | spawn :: Clock -> IO a -> IO (PrimEv a) 23 | spawn (Clock u flag round) m = 24 | do mv <- newMVar Nothing 25 | forkIO $ m >>= setValue mv 26 | return (PrimEv u mv) 27 | where setValue mv x = 28 | do i <- takeMVar round 29 | v <- takeMVar mv 30 | putMVar mv (Just (Round u (i + 1), x)) 31 | putMVar round i 32 | signal flag 33 | 34 | 35 | curRound :: Clock -> IO Round 36 | curRound (Clock u _ c) = Round u <$> readMVar c 37 | 38 | waitEndRound :: Clock -> IO () 39 | waitEndRound (Clock u f c) = 40 | do yield 41 | waitForSignal f 42 | yield 43 | i <- takeMVar c 44 | putMVar c (i+1) 45 | 46 | 47 | 48 | observeAt :: PrimEv a -> Round -> Maybe a 49 | observeAt (PrimEv uv m) (Round ur t) 50 | | uv /= ur = error "Observation of TIVar from another context!" 51 | | otherwise = unsafePerformIO $ 52 | do v <- readMVar m 53 | return $ case v of 54 | Just (Round _ t',a) | t' <= t -> Just a 55 | _ -> Nothing 56 | 57 | instance Eq Round where 58 | (Round lu lt) == (Round ru rt) | lu == ru = lt == rt 59 | | otherwise = error "Rounds not from same clock!" 60 | 61 | instance Ord Round where 62 | compare (Round lu lt) (Round ru rt) 63 | | lu == ru = compare lt rt 64 | | otherwise = error "Rounds not from same clock!" 65 | -------------------------------------------------------------------------------- /PaperImpl/Ref.hs: -------------------------------------------------------------------------------- 1 | module Ref where 2 | 3 | import System.Mem.Weak 4 | import Control.Applicative 5 | import Data.IORef 6 | 7 | data Ref a = W (Weak a) 8 | | S a 9 | 10 | makeWeakRef :: a -> IO (Ref a) 11 | makeWeakRef v = W <$> mkWeakPtr v Nothing 12 | 13 | makeStrongRef :: a -> IO (Ref a) 14 | makeStrongRef v = return $ S v 15 | 16 | 17 | deRef :: Ref a -> IO (Maybe a) 18 | deRef (S a) = return (Just a) 19 | deRef (W a) = deRefWeak a 20 | -------------------------------------------------------------------------------- /PaperImpl/Test.hs: -------------------------------------------------------------------------------- 1 | import FRPNow 2 | import Lib 3 | import Control.Applicative 4 | 5 | n = 11000 6 | 7 | main = runNow (test n) 8 | 9 | test :: Int -> Now (E ()) 10 | test n = do b <- count 11 | sample (when ((n ==) <$> b)) 12 | 13 | count :: Now (B Int) 14 | count = loop 0 where 15 | loop i = do e <- async (return ()) 16 | e'<- planNow (loop (i+1) <$ e) 17 | return (pure i `switch` e') 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Principled Practical FRP 2 | 3 | The code from the paper is in PaperImpl 4 | 5 | Control/FRPNow contains current implementation 6 | and FRPNow-GTK and FRPNow-Gloss contain hookups to GTK and Gloss 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /extra.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atzeus/FRPNow/58073b88dfd725eab6851a75b4c9f01f9d3f97d2/extra.pdf -------------------------------------------------------------------------------- /frpnow.cabal: -------------------------------------------------------------------------------- 1 | Name: frpnow 2 | Version: 0.18 3 | Synopsis: Principled practical FRP 4 | Description: FRP with first-class behaviors and interalized IO, without space leaks 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: Atze van der Ploeg 8 | Maintainer: atzeus@gmail.com 9 | Homepage: https://github.com/atzeus/FRPNow 10 | Build-Type: Simple 11 | Cabal-Version: >=1.6 12 | Data-files: ChangeLog 13 | Category: Control 14 | Tested-With: GHC==7.10.1 15 | Library 16 | Build-Depends: base >= 2 && <= 6, mtl >= 1.0, containers, transformers 17 | Exposed-modules: Control.FRPNow,Control.FRPNow.Core, Control.FRPNow.Lib, Control.FRPNow.EvStream, Control.FRPNow.Time, Control.FRPNow.BehaviorEnd 18 | other-modules: Control.FRPNow.Private.PrimEv, Control.FRPNow.Private.Ref 19 | Extensions: RankNTypes, GADTs, CPP, EmptyDataDecls 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/atzeus/FRPNow 24 | --------------------------------------------------------------------------------