bearriver 0.10.4 → 0.10.4.1
raw patch · 3 files changed
+52/−47 lines, 3 filesnew-uploader
Files
- bearriver.cabal +5/−1
- src/FRP/BearRiver.hs +46/−45
- src/FRP/Yampa.hs +1/−1
bearriver.cabal view
@@ -1,5 +1,5 @@ name: bearriver-version: 0.10.4+version: 0.10.4.1 synopsis: A replacement of Yampa based on Monadic Stream Functions. description: A Yampa replacement built using Dunai. homepage: keera.co.uk@@ -26,3 +26,7 @@ build-depends: base >=4.7 && <5, transformers >=0.3, mtl, dunai hs-source-dirs: src/ default-language: Haskell2010++source-repository head+ type: git+ location: git@github.com:ivanperez-keera/dunai.git
src/FRP/BearRiver.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} module FRP.BearRiver (module FRP.BearRiver, module X)@@ -12,14 +13,15 @@ import Control.Applicative import Control.Arrow as X+import qualified Control.Category as Category import Control.Monad (mapM)-import Control.Monad.Reader+--import Control.Monad.Reader import Control.Monad.Trans.Maybe-import Control.Monad.Trans.MStreamF+import Control.Monad.Trans.MSF import Data.Traversable as T import Data.Functor.Identity import Data.Maybe-import Data.MonadicStreamFunction as X hiding (iPre, reactimate, switch, sum, trace)+import Data.MonadicStreamFunction as X hiding (reactimate, switch, sum, trace) import qualified Data.MonadicStreamFunction as MSF import Data.MonadicStreamFunction.ArrowLoop import FRP.Yampa.VectorSpace as X@@ -27,17 +29,15 @@ type Time = Double type DTime = Double -type SF m = MStreamF (ClockInfo m)+type SF m = MSF (ClockInfo m) type ClockInfo m = ReaderT DTime m identity :: Monad m => SF m a a-identity = arr id+identity = Category.id constant :: Monad m => b -> SF m a b constant = arr . const -iPre :: Monad m => a -> SF m a a-iPre i = MStreamF $ \i' -> return (i, iPre i') -- * Continuous time @@ -48,19 +48,18 @@ integral = integralFrom zeroVector integralFrom :: (Monad m, VectorSpace a s) => a -> SF m a a-integralFrom n0 = MStreamF $ \n -> do- dt <- ask- let acc = n0 ^+^ realToFrac dt *^ n- acc `seq` return (acc, integralFrom acc)+integralFrom a0 = proc a -> do+ dt <- arrM_ ask -< ()+ accumulateWith (^+^) a0 -< realToFrac dt *^ a derivative :: (Monad m, VectorSpace a s) => SF m a a derivative = derivativeFrom zeroVector derivativeFrom :: (Monad m, VectorSpace a s) => a -> SF m a a-derivativeFrom n0 = MStreamF $ \n -> do- dt <- ask- let res = (n ^-^ n0) ^/ realToFrac dt- res `seq` return (res, derivativeFrom n)+derivativeFrom a0 = proc a -> do+ dt <- arrM_ ask -< ()+ aOld <- MSF.iPre a0 -< a+ returnA -< (a ^-^ aOld) ^/ realToFrac dt -- * Events @@ -101,7 +100,7 @@ mergeBy resolve (Event l) (Event r) = Event (resolve l r) lMerge :: Event a -> Event a -> Event a-lMerge = mergeBy (\e1 _e2 -> e1)+lMerge = mergeBy (\e1 _ -> e1) -- ** Relation to other types @@ -118,12 +117,14 @@ edge = edgeFrom True edgeBy :: Monad m => (a -> a -> Maybe b) -> a -> SF m a (Event b)-edgeBy isEdge a_prev = MStreamF $ \a ->+edgeBy isEdge a_prev = MSF $ \a -> return (maybeToEvent (isEdge a_prev a), edgeBy isEdge a) edgeFrom :: Monad m => Bool -> SF m Bool (Event())-edgeFrom prev = MStreamF $ \a -> do- let res = if prev then NoEvent else if a then Event () else NoEvent+edgeFrom prev = MSF $ \a -> do+ let res | prev = NoEvent+ | a = Event ()+ | otherwise = NoEvent ct = edgeFrom a return (res, ct) @@ -144,8 +145,8 @@ => Time -- ^ The time /q/ after which the event should be produced -> b -- ^ Value to produce at that time -> SF m a (Event b)-after q x = feedback q $ go- where go = MStreamF $ \(_, t) -> do+after q x = feedback q go+ where go = MSF $ \(_, t) -> do dt <- ask let t' = t - dt e = if t > 0 && t' < 0 then Event x else NoEvent@@ -153,8 +154,8 @@ return ((e, t'), ct) (-->) :: Monad m => b -> SF m a b -> SF m a b-b0 --> sf = MStreamF $ \a -> do - (_, ct) <- unMStreamF sf a+b0 --> sf = MSF $ \a -> do+ (_, ct) <- unMSF sf a return (b0, ct) accumHoldBy :: Monad m => (b -> a -> b) -> b -> SF m (Event a) b@@ -165,37 +166,37 @@ dpSwitchB :: (Monad m , Traversable col) => col (SF m a b) -> SF m (a, col b) (Event c) -> (col (SF m a b) -> c -> SF m a (col b)) -> SF m a (col b)-dpSwitchB sfs sfF sfCs = MStreamF $ \a -> do- res <- T.mapM (`unMStreamF` a) sfs+dpSwitchB sfs sfF sfCs = MSF $ \a -> do+ res <- T.mapM (`unMSF` a) sfs let bs = fmap fst res sfs' = fmap snd res- (e,sfF') <- unMStreamF sfF (a, bs)+ (e,sfF') <- unMSF sfF (a, bs) let ct = case e of Event c -> sfCs sfs' c- NoEvent -> dpSwitchB sfs' sfF' sfCs + NoEvent -> dpSwitchB sfs' sfF' sfCs return (bs, ct) dSwitch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b-dSwitch sf sfC = MStreamF $ \a -> do- (o, ct) <- unMStreamF sf a+dSwitch sf sfC = MSF $ \a -> do+ (o, ct) <- unMSF sf a case o of- (b, Event c) -> do (_,ct') <- unMStreamF (sfC c) a+ (b, Event c) -> do (_,ct') <- unMSF (sfC c) a return (b, ct') (b, NoEvent) -> return (b, dSwitch ct sfC) switch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b-switch sf sfC = MStreamF $ \a -> do- (o, ct) <- unMStreamF sf a+switch sf sfC = MSF $ \a -> do+ (o, ct) <- unMSF sf a case o of- (_, Event c) -> unMStreamF (sfC c) a+ (_, Event c) -> unMSF (sfC c) a (b, NoEvent) -> return (b, switch ct sfC) parC :: Monad m => SF m a b -> SF m [a] [b] parC sf = parC' [sf] parC' :: Monad m => [SF m a b] -> SF m [a] [b]-parC' sfs = MStreamF $ \as -> do- os <- T.mapM (\(a,sf) -> unMStreamF sf a) $ zip as sfs+parC' sfs = MSF $ \as -> do+ os <- T.mapM (\(a,sf) -> unMSF sf a) $ zip as sfs let bs = fmap fst os cts = fmap snd os return (bs, parC' cts)@@ -203,30 +204,30 @@ -- NOTE: BUG in this function, it needs two a's but we -- can only provide one iterFrom :: Monad m => (a -> a -> DTime -> b -> b) -> b -> SF m a b-iterFrom f b = MStreamF $ \a -> do+iterFrom f b = MSF $ \a -> do dt <- ask let b' = f a a dt b return (b, iterFrom f b') reactimate :: IO a -> (Bool -> IO (DTime, Maybe a)) -> (Bool -> b -> IO Bool) -> SF Identity a b -> IO () reactimate senseI sense actuate sf = do- -- runMaybeT $ MSF.reactimate $ liftMStreamFTrans (senseSF >>> sfIO) >>> actuateSF+ -- runMaybeT $ MSF.reactimate $ liftMSFTrans (senseSF >>> sfIO) >>> actuateSF MSF.reactimateB $ senseSF >>> sfIO >>> actuateSF return ()- where sfIO = liftMStreamFPurer (return.runIdentity) (runReaderS sf)+ where sfIO = liftMSFPurer (return.runIdentity) (runReaderS sf) -- Sense senseSF = switch senseFirst senseRest- senseFirst = liftMStreamF_ senseI >>> (arr $ \x -> ((0, x), Event x))- senseRest a = liftMStreamF_ (sense True) >>> (arr id *** keepLast a)+ senseFirst = arrM_ senseI >>> (arr $ \x -> ((0, x), Event x))+ senseRest a = arrM_ (sense True) >>> (arr id *** keepLast a) - keepLast :: Monad m => a -> MStreamF m (Maybe a) a- keepLast a = MStreamF $ \ma -> let a' = fromMaybe a ma in return (a', keepLast a')+ keepLast :: Monad m => a -> MSF m (Maybe a) a+ keepLast a = MSF $ \ma -> let a' = fromMaybe a ma in return (a', keepLast a') -- Consume/render- -- actuateSF :: MStreamF IO b ()- -- actuateSF = arr (\x -> (True, x)) >>> liftMStreamF (lift . uncurry actuate) >>> exitIf- actuateSF = arr (\x -> (True, x)) >>> liftMStreamF (uncurry actuate)+ -- actuateSF :: MSF IO b ()+ -- actuateSF = arr (\x -> (True, x)) >>> liftMSF (lift . uncurry actuate) >>> exitIf+ actuateSF = arr (\x -> (True, x)) >>> arrM (uncurry actuate) switch sf sfC = MSF.switch (sf >>> second (arr eventToMaybe)) sfC
src/FRP/Yampa.hs view
@@ -1,4 +1,4 @@-module FRP.Yampa (module X) where+module FRP.Yampa (module X, SF) where import FRP.BearRiver as X hiding (andThen, SF) import FRP.Yampa.AffineSpace as X