varying 0.4.0.0 → 0.5.0.0
raw patch · 10 files changed
+534/−431 lines, 10 filesdep +criteriondep ~basedep ~transformers
Dependencies added: criterion
Dependency ranges changed: base, transformers
Files
- app/Main.hs +18/−13
- bench/Main.hs +24/−0
- changelog.md +4/−1
- src/Control/Varying/Core.hs +57/−114
- src/Control/Varying/Event.hs +28/−6
- src/Control/Varying/Spline.hs +165/−165
- src/Control/Varying/Time.hs +6/−31
- src/Control/Varying/Tween.hs +11/−7
- test/Main.hs +200/−93
- varying.cabal +21/−1
app/Main.hs view
@@ -4,17 +4,20 @@ import Control.Applicative import Text.Printf import Data.Functor.Identity+import Data.Time.Clock -- | A simple 2d point type. data Point = Point { px :: Float , py :: Float } deriving (Show, Eq) +newtype Delta = Delta { unDelta :: Float }+ -- An exponential tween back and forth from 0 to 100 over 2 seconds that -- loops forever. This spline takes float values of delta time as input, -- outputs the current x value at every step and would result in () if it -- terminated.-tweenx :: (Applicative m, Monad m) => SplineT Float Float m ()+tweenx :: (Applicative m, Monad m) => SplineT Float Float m Float tweenx = do -- Tween from 0 to 100 over 1 second x <- tween easeOutExpo 0 100 1@@ -25,24 +28,24 @@ -- A quadratic tween back and forth from 0 to 100 over 2 seconds that never -- ends.-tweeny :: (Applicative m, Monad m) => SplineT Float Float m ()+tweeny :: (Applicative m, Monad m) => SplineT Float Float m Float tweeny = do y <- tween easeOutQuad 0 100 1 _ <- tween easeOutQuad y 0 1 tweeny --- Our time signal that provides delta time samples.-time :: VarT IO a Float-time = deltaUTC+-- Our time signal counts input delta time samples.+time :: Monad m => VarT m Delta Float+time = var unDelta -- | Our Point value that varies over time continuously in x and y.-backAndForth :: VarT IO a Point+backAndForth :: Monad m => VarT m Delta Point backAndForth = -- Turn our splines into continuous output streams. We must provide -- a starting value since splines are not guaranteed to be defined at -- their edges.- let x = outputStream 0 tweenx- y = outputStream 0 tweeny+ let x = outputStream tweenx 0+ y = outputStream tweeny 0 in -- Construct a varying Point that takes time as an input. (Point <$> x <*> y)@@ -57,10 +60,12 @@ putStrLn "An example of value streams using the varying library." putStrLn "Enter a newline to continue, quit with ctrl+c" _ <- getLine+ utc0 <- getCurrentTime - loop backAndForth- where loop :: VarT IO () Point -> IO ()- loop v = do (point, vNext) <- runVarT v ()- printf "\nPoint %03.1f %03.1f" (px point) (py point)- loop vNext+ loop backAndForth utc0+ where loop v utc1 = do utc2 <- getCurrentTime+ let dt = realToFrac $ diffUTCTime utc2 utc1+ (point, vNext) <- runVarT v $ Delta dt+ printf "\nPoint %03.1f %03.1f" (px point) (py point)+ loop vNext utc2
+ bench/Main.hs view
@@ -0,0 +1,24 @@+import Control.Varying+import Criterion.Main+import Debug.Trace++main :: IO ()+main = do+ let v :: Var Int Int+ v = var (+1)+ run v a = fst <$> runVarT v a+ defaultMain $ [ bgroup "runVarT" [ bench "1" $ nf (run $ chain 1) 0+ , bench "2" $ nf (run $ chain 2) 0+ , bench "4" $ nf (run $ chain 4) 0+ , bench "8" $ nf (run $ chain 8) 0+ , bench "16" $ nf (run $ chain 16) 0+ , bench "32" $ nf (run $ chain 32) 0+ , bench "64" $ nf (run $ chain 64) 0+ , bench "128" $ nf (run $ chain 128) 0+ ]+ ]+ return ()++chain :: Int -> Var Int Int+chain n = seq x x+ where x = foldl (~>) (var (+1)) $ take (n - 1) $ cycle [var (+1)]
changelog.md view
@@ -11,4 +11,7 @@ 0.3.1.0 - added stepMany, eitherE 0.4.0.0 - Var and Spline are now parameterized with Identity, removed mix, changed- the behavior of race, added untilEvent variants, added tests.+ the behavior of race, added untilEvent variants, added tests++0.5.0.0 - changed stepMany to remove Monoid requirement, added raceMany, added + anyE, more tests and SplineT obeys Applicative and Monad laws
src/Control/Varying/Core.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} -- | -- Module: Control.Varying.Core -- Copyright: (c) 2015 Schell Scivally@@ -16,6 +17,7 @@ VarT(..), -- * Creating value streams -- $creation+ done, var, varM, mkState,@@ -23,23 +25,17 @@ -- $composition (<~), (~>),+ (<<<),+ (>>>), -- * Adjusting and accumulating delay, accumulate, -- * Sampling value streams (running and other entry points) -- $running- evalVar,- execVar,- loopVar,- loopVar_,- whileVar,- whileVar_,+ runVarT, scanVar, stepMany,- -- * Testing value streams- testVar,- testVar_,- testWhile_,+ -- * Tracing value streams in flight vtrace, vstrace, vftrace,@@ -48,7 +44,7 @@ import Prelude hiding (id, (.)) import Control.Arrow import Control.Category-import Control.Monad +import Control.Monad import Control.Applicative import Data.Monoid import Data.Functor.Identity@@ -89,6 +85,10 @@ var :: Applicative m => (a -> b) -> VarT m a b var f = VarT $ \a -> pure (f a, var f) +-- | Lift a constant value into a stream.+done :: Applicative m => b -> VarT m a b+done = Done+ -- | Lift a monadic computation into a stream. varM :: Monad m => (a -> m b) -> VarT m a b varM f = VarT $ \a -> do@@ -105,57 +105,25 @@ return (b', mkState f s') -------------------------------------------------------------------------------- -- $running--- The easiest way to sample a stream is to run it in the desired monad with+-- To sample a stream simply run it in the desired monad with -- 'runVarT'. This will produce a sample value and a new stream. -- -- > do (sample, v') <- runVarT v inputValue------ Much like Control.Monad.State there are other entry points for running--- value streams like 'evalVar', 'execVar'. There are also extra control--- structures such as 'loopVar' and 'whileVar'.------------------------------------------------------------------------------------ | Iterate a stream once and return the sample value.-evalVar :: Functor m => VarT m a b -> a -> m b-evalVar v a = fst <$> runVarT v a --- | Iterate a stream once and return the next stream.-execVar :: Functor m => VarT m a b -> a -> m (VarT m a b)-execVar v a = snd <$> runVarT v a---- | Loop over a stream that takes no input value.-loopVar_ :: (Functor m, Monad m) => VarT m () a -> m ()-loopVar_ v = execVar v () >>= loopVar_---- | Loop over a stream that produces its own next input value.-loopVar :: Monad m => a -> VarT m a a -> m a-loopVar a v = runVarT v a >>= uncurry loopVar---- | Iterate a stream that requires no input until the given predicate fails.-whileVar_ :: Monad m => (a -> Bool) -> VarT m () a -> m a-whileVar_ f v = do- (a, v') <- runVarT v ()- if f a then whileVar_ f v' else return a---- | Iterate a stream that produces its own next input value until the given--- predicate fails.-whileVar :: Monad m- => (a -> Bool) -- ^ The predicate to evaluate samples.- -> a -- ^ The initial input/sample value.- -> VarT m a a -- ^ The stream to iterate- -> m a -- ^ The last sample-whileVar f a v = if f a- then runVarT v a >>= uncurry (whileVar f)- else return a+--------------------------------------------------------------------------------+runVarT :: Monad m => VarT m a b -> a -> m (b, VarT m a b)+runVarT (Done b) _ = return (b, Done b)+runVarT (VarT v) a = v a --- | Iterate a stream using a list of input until all input is consumed and--- output the result.-stepMany :: (Monad m, Functor m, Monoid a) => [a] -> VarT m a b -> m (b, VarT m a b)-stepMany ([e]) y = runVarT y e-stepMany (e:es) y = execVar y e >>= stepMany es-stepMany [] y = runVarT y mempty+-- | Iterate a stream over a list of input until all input is consumed,+-- then iterate the stream using one single input. Returns the resulting+-- output value and the new stream.+stepMany :: (Monad m, Functor m) => VarT m a b -> [a] -> a -> m (b, VarT m a b)+stepMany v [] e = runVarT v e+stepMany v (e:es) x = snd <$> runVarT v e >>= \v1 -> stepMany v1 es x --- | Run the stream over the input values, gathering the output values in a --- list. +-- | Run the stream over the input values, gathering the output values in a+-- list. scanVar :: (Applicative m, Monad m) => VarT m a b -> [a] -> m [b] scanVar v = liftM snd . foldM f (v,[]) where f (v', outs) a = do (b, v'') <- runVarT v' a@@ -177,28 +145,6 @@ -- This is very useful for debugging graphs of streams. vftrace :: Applicative a => (b -> String) -> VarT a b b vftrace f = var $ \b -> trace (f b) b---- | A utility function for testing streams that don't require input. Runs--- a stream printing each sample until the given predicate fails.-testWhile_ :: Show a => (a -> Bool) -> VarT IO () a -> IO ()-testWhile_ f v = do- (a, v') <- runVarT v ()- when (f a) $ print a >> testWhile_ f v'---- | A utility function for testing streams that require input. The input--- must have a 'Read' instance. Use this in GHCI to step through your streams--- by typing the input and hitting `return`.-testVar :: (Read a, Show b) => VarT IO a b -> IO ()-testVar v = loopVar_ $ varM (const $ putStrLn "input: ")- ~> varM (const getLine)- ~> var read- ~> v- ~> varM print---- | A utility function for testing streams that don't require input. Use--- this in GHCI to step through your streams using the `return` key.-testVar_ :: Show b => VarT IO () b -> IO ()-testVar_ v = loopVar_ $ pure () ~> v ~> varM print ~> varM (const getLine) -------------------------------------------------------------------------------- -- Adjusting and accumulating --------------------------------------------------------------------------------@@ -220,26 +166,18 @@ return (b', go a' v'') -------------------------------------------------------------------------------- -- $composition--- You can compose value streams together using '~>' and '<~'. The "right plug"--- ('~>') takes the output from a value stream on the left and "plugs" it--- into the input of the value stream on the right. The "left plug" does--- the same thing in the opposite direction. This allows you to write value--- streams that read naturally.+-- You can compose value streams together using Arrow's '>>>' and '<<<' or the+-- synonyms '~>' and '<~'. The "right plug" ('>>>' and '~>') takes the output+-- from a value stream on the left and "plugs" it into the input of the value+-- stream on the right.+-- The "left plug" does the same thing in the opposite direction. This allows+-- you to write value streams that read naturally. ----------------------------------------------------------------------------------- | Same as '~>' with flipped parameters.-(<~) :: Monad m => VarT m b c -> VarT m a b -> VarT m a c-(<~) = flip (~>)-infixl 1 <~---- | Connects two streams by chaining the first's output into the input of the--- second. This is the defacto stream composition method and in fact '.' is an--- alias of '<~', which is just '~>' flipped. (~>) :: Monad m => VarT m a b -> VarT m b c -> VarT m a c-(~>) v1 v2 = VarT $ \a -> do- (b, v1') <- runVarT v1 a- (c, v2') <- runVarT v2 b- return (c, v1' ~> v2')-infixr 1 ~>+(~>) = (>>>)++(<~) :: Monad m => VarT m b c -> VarT m a b -> VarT m a c+(<~) = (<<<) -------------------------------------------------------------------------------- -- Typeclass instances --------------------------------------------------------------------------------@@ -248,29 +186,32 @@ -- > fmap (*3) $ accumulate (+) 0 -- Will sum input values and then multiply the sum by 3. instance (Applicative m, Monad m) => Functor (VarT m b) where- fmap f' v = v ~> var f'+ fmap f (Done x) = Done $ f x+ fmap f v = v >>> var f -- | A very simple category instance. -- -- @ -- id = var id--- f . g = g ~> f+-- f . g = g >>> f -- @ -- or ----- > f . g = f <~ g+-- > f . g = f <<< g ----- It is preferable for consistency (and readability) to use 'plug left' ('<~')--- and 'plug right' ('~>') instead of ('.') where possible.+-- It is preferable for consistency (and readability) to use 'plug left' ('<<<')+-- and 'plug right' ('>>>') instead of ('.') where possible. instance (Applicative m, Monad m) => Category (VarT m) where id = var id- f . g = g ~> f+ f0 . g0 = VarT $ \a -> do (b, g) <- runVarT g0 a+ (c, f) <- runVarT f0 b+ return (c, f . g) -- | Streams are applicative. -- -- > (,) <$> pure True <*> var "Applicative" instance (Applicative m, Monad m) => Applicative (VarT m a) where- pure = var . const+ pure = done vf <*> va = VarT $ \a -> do (f, vf') <- runVarT vf a (b, va') <- runVarT va a return (f b, vf' <*> va')@@ -300,7 +241,7 @@ -- | Streams can be written as numbers. ----- > let v = 1 ~> accumulate (+) 0+-- > let v = 1 >>> accumulate (+) 0 -- which will sum the natural numbers. instance (Applicative m, Monad m, Num b) => Num (VarT m a b) where (+) = liftA2 (+)@@ -312,7 +253,7 @@ -- | Streams can be written as floats. ----- > let v = pi ~> accumulate (*) 0.0+-- > let v = pi >>> accumulate (*) 0.0 -- which will attempt (and succeed) to multiply pi by zero every step. instance (Applicative m, Monad m, Floating b) => Floating (VarT m a b) where pi = pure pi@@ -324,7 +265,7 @@ -- | Streams can be written as fractionals. ----- > let v = 2.5 ~> accumulate (+) 0+-- > let v = 2.5 >>> accumulate (+) 0 -- which will add 2.5 each step. instance (Applicative m, Monad m, Fractional b) => Fractional (VarT m a b) where (/) = liftA2 (/)@@ -337,13 +278,15 @@ -- 'VarT'. type Var a b = VarT Identity a b --- | A value stream is a structure that contains a value that changes over some +-- | A value stream is a structure that contains a value that changes over some -- input. It's a kind of Mealy machine (an automaton) with effects. Using--- 'runVarT' with an input value of type 'a' yields a "step", which is a value +-- 'runVarT' with an input value of type 'a' yields a "step", which is a value -- of type 'b' and a new 'VarT' for yielding the next value.-data VarT m a b =- VarT { runVarT :: a -> m (b, VarT m a b)- -- ^ Given an input value, return a computation that effectfully - -- produces an output value and a new stream for producing the next - -- sample.- }+data VarT m a b where+ Done :: b -> VarT m a b+ -- ^ Given a value, return a computation that yields a constant value+ -- forever. You can also do this with the function 'done'.+ VarT :: (a -> m (b, VarT m a b)) -> VarT m a b+ -- ^ Given an input value, return a computation that effectfully+ -- produces an output value and a new stream for producing the next+ -- sample.
src/Control/Varying/Event.hs view
@@ -29,6 +29,7 @@ startingWith, startWith, -- * Using multiple streams eitherE,+ anyE, -- * List-like operations on event streams filterE, takeE,@@ -38,6 +39,7 @@ always, never, -- * Switching+ andThenWith, switchByMode, -- * Bubbling onlyWhen,@@ -49,6 +51,7 @@ import Control.Applicative import Control.Monad import Data.Monoid+import Data.Foldable (foldl') -------------------------------------------------------------------------------- -- Transforming event values into usable values --------------------------------------------------------------------------------@@ -122,7 +125,7 @@ -- produce that value until a new input event produces. This always holds -- the last produced value, starting with the given value. -- @--- time ~> after 3 ~> startingWith 0+-- time >>> after 3 >>> startingWith 0 -- @ startingWith, startWith :: (Applicative m, Monad m) => a -> VarT m (Event a) a startingWith = startWith@@ -151,7 +154,7 @@ -- | Inhibit all events that don't pass the predicate. filterE :: (Applicative m, Monad m) => (b -> Bool) -> VarT m a (Event b) -> VarT m a (Event b)-filterE p v = v ~> var check+filterE p v = v >>> var check where check (Event b) = if p b then Event b else NoEvent check _ = NoEvent --------------------------------------------------------------------------------@@ -160,13 +163,23 @@ -- | If the left event stream produces a value, wrap the value in 'Left' and -- produce that value, else if the right event stream produces a value, -- wrap the value in 'Right' and produce that value, else inhibit.-eitherE :: (Applicative m, Monad m) - => VarT m a (Event b) -> VarT m a (Event c) +eitherE :: (Applicative m, Monad m)+ => VarT m a (Event b) -> VarT m a (Event c) -> VarT m a (Event (Either b c)) eitherE vb vc = f <$> vb <*> vc where f (Event b) _ = Event $ Left b f _ (Event c) = Event $ Right c f _ _ = NoEvent++-- | Combine two event streams and produce an event any time either stream+-- produces. In the case that both streams produce, this produces the event of+-- the left stream.+anyE :: Monad m => [VarT m a (Event b)] -> VarT m a (Event b)+anyE [] = never+anyE vs = VarT $ \a -> do+ outs <- mapM (`runVarT` a) vs+ let f (eb, vs1) (eb1, v) = (msum [eb, eb1], vs1 ++ [v])+ return (anyE <$> foldl' f (NoEvent, []) outs) -------------------------------------------------------------------------------- -- Primitive event streams --------------------------------------------------------------------------------@@ -192,7 +205,7 @@ switchByMode switch f = VarT $ \a -> do (b, _) <- runVarT switch a (_, v) <- runVarT (f b) a- runVarT (switchOnUnique v $ switch ~> onUnique) a+ runVarT (switchOnUnique v $ switch >>> onUnique) a where switchOnUnique v sv = VarT $ \a -> do (eb, sv') <- runVarT sv a (c', v') <- runVarT (vOf eb) a@@ -200,6 +213,15 @@ where vOf eb = case eb of NoEvent -> v Event b -> f b++andThenWith :: (Applicative m, Monad m)+ => VarT m a (Event b) -> (Event b -> VarT m a (Event b)) -> VarT m a (Event b)+v `andThenWith` f = run v NoEvent+ where run v1 eb = VarT $ \a -> do+ (eb1, v2) <- runVarT v1 a+ case eb1 of+ NoEvent -> runVarT (f eb) a+ _ -> return (eb1, run v2 eb1) -------------------------------------------------------------------------------- -- Bubbling --------------------------------------------------------------------------------@@ -211,7 +233,7 @@ -> (a -> Bool) -- ^ 'f' - The predicate to run on 'v''s input values. -> VarT m a (Event b) onlyWhen v f = v `onlyWhenE` hot- where hot = var id ~> onWhen f+ where hot = var id >>> onWhen f -- | Produce events of a value stream 'v' only when an event stream 'h' -- produces an event.
src/Control/Varying/Spline.hs view
@@ -26,150 +26,117 @@ SplineT(..), runSplineT, scanSpline,- fromEvents, outputStream, resultStream,+ -- * Combinators step,- -- * Combinators + effect,+ fromEvent, untilEvent, untilEvent_, _untilEvent,- pair,+ _untilEvent_, race,+ raceMany,+ merge, capture, mapOutput, adjustInput,- -- * Step- Step(..), ) where import Control.Varying.Core import Control.Varying.Event-import Control.Monad.IO.Class-import Control.Monad.Trans.Class import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.IO.Class import Control.Applicative-import Data.Monoid import Data.Functor.Identity---- | A discrete step in a continuous function. This type discretely describes --- an eventual value on the right and an output value on the left.-data Step b c = Step { stepOutput :: b- , stepResult :: Event c- }---- | Map the output value of a 'Step'.-mapStepOutput :: (a -> b) -> Step a c -> Step b c-mapStepOutput f (Step a b) = Step (f a) b---- | A discrete step is a functor by applying a function to the contained--- event's value.-instance Functor (Step a) where- fmap f (Step a b) = Step a $ fmap f b---- | A discrete spline is a monoid if its left and right types are monoids.-instance (Monoid f, Monoid b) => Monoid (Step f b) where- mempty = Step mempty (Event mempty)- mappend (Step a ea) (Step b eb) = Step (mappend a b) (mappend <$> ea <*> eb)---- | A discrete spline is an applicative if its left datatype is a monoid. It--- replies to 'pure' with an empty left value while the right value is the--- argument wrapped in an event. It means "the argument happens instantly".-instance Monoid f => Applicative (Step f) where- pure a = Step mempty $ Event a- (Step uia f) <*> (Step uib b) = Step (mappend uia uib) (f <*> b)+import Data.Monoid --- | 'SplineT' shares a number of types with 'VarT', specifically its monad,--- input and output types (@m@, @a@ and @b@, respectively). A spline adds--- a result type which represents the monadic computation's result--- value.+-- | 'SplineT' shares all the types of 'VarT' and adds a result value. Its+-- monad, input and output types (@m@, @a@ and @b@, respectively) reflect the+-- underlying 'VarT`. A spline adds a result type which represents the monadic+-- computation's result value. -- Much like the State monad it has an "internal state" and an eventual -- result value, where the internal state is the output value. The result -- value is used only in determining the next spline to sequence.-data SplineT a b m c = SplineT { unSplineT :: VarT m a (Step (Event b) c) }- | SplineTConst c---- | Unwrap a spline into a value stream.-runSplineT :: (Applicative m, Monad m)- => SplineT a b m c -> VarT m a (Step (Event b) c)-runSplineT (SplineT v) = v-runSplineT (SplineTConst x) = pure $ pure x---- | Run the spline over the input values, gathering the output and result --- values in a list. -scanSpline :: (Applicative m, Monad m) - => SplineT a b m c -> [a] -> m [(Event b, Event c)]-scanSpline s as = map f <$> scanVar (runSplineT s) as - where f (Step eb ec) = (eb,ec)+data SplineT a b m c where+ Pass :: c -> SplineT a b m c+ SplineT :: VarT m a (b, Event c) -> SplineT a b m c --- | A SplineT monad parameterized with Identity that takes input of type @a@, --- output of type @b@ and a result value of type @c@. -type Spline a b c = SplineT a b Identity c+-- | Convert a spline into a stream of output value and eventual result value+-- tuples. Requires a default output value in case none are produced.+runSplineT :: Monad m => SplineT a b m c -> b -> VarT m a (b, Event c)+runSplineT (Pass c) b = pure (b, Event c)+runSplineT (SplineT v) _ = VarT $ \a -> do+ (o@(b,ec), v1) <- runVarT v a+ let s = case ec of+ NoEvent -> SplineT v1+ Event c -> Pass c+ return (o, runSplineT s b) -- | A spline is a functor by applying the function to the result.-instance (Applicative m, Monad m) => Functor (SplineT a b m) where- fmap f (SplineTConst c) = SplineTConst $ f c- fmap f (SplineT v) = SplineT $ fmap (fmap f) v+instance Monad m => Functor (SplineT a b m) where+ fmap f (Pass c) = Pass $ f c+ fmap f (SplineT v) = SplineT (((f <$>) <$>) <$> v) --- | A spline is an applicative if its output type is a monoid. It--- responds to 'pure' by returning a spline that immediately returns the--- argument. It responds to '<*>' by applying the left arguments eventual--- value (the function) to the right arguments eventual value. The--- output values will me combined with 'mappend'.-instance (Applicative m, Monad m) => Applicative (SplineT a b m) where- pure = SplineTConst- (SplineTConst f) <*> (SplineTConst x) = SplineTConst $ f x- (SplineT vf) <*> (SplineTConst x) = SplineT $ fmap (fmap ($ x)) vf- (SplineTConst f) <*> (SplineT vx) = SplineT $ fmap (fmap f) vx- (SplineT vf) <*> (SplineT vx) = SplineT $ ((<*>) <$> vf) <*> vx+-- A spline responds to 'pure' by returning a spline that never produces an+-- output value and immediately returns the argument. It responds to '<*>' by+-- applying the left arguments result value (the function) to the right+-- arguments result value (the argument), sequencing them both in serial.+instance Monad m => Applicative (SplineT a b m) where+ pure = Pass+ (Pass f) <*> (Pass x) = Pass $ f x+ (Pass f) <*> (SplineT v) = f <$> SplineT v+ (SplineT vf) <*> (Pass x) = ($ x) <$> SplineT vf+ sf <*> sx = do+ f <- sf+ x <- sx+ return $ f x --- | A spline is monad if its output type is a monoid. A spline responds--- to bind by running until it produces an eventual value, then uses that--- value to run the next spline.-instance (Applicative m, Monad m) => Monad (SplineT a b m) where- return = pure- (SplineTConst x) >>= f = f x- (SplineT v) >>= f = SplineT $ VarT $ \i -> do- (Step b e, v') <- runVarT v i- case e of- NoEvent -> return (Step b NoEvent, runSplineT $ SplineT v' >>= f)- Event x -> runVarT (runSplineT $ f x) i+-- | A spline responds to bind by running until it produces an eventual value,+-- then uses that value to run the next spline.+instance Monad m => Monad (SplineT a b m) where+ return = Pass+ (Pass x) >>= f = f x+ (SplineT v) >>= f = SplineT $ VarT $ \a -> do+ ((b, ec), v1) <- runVarT v a+ case ec of+ NoEvent -> return ((b, NoEvent), runSplineT (SplineT v1 >>= f) b)+ Event c -> runVarT (runSplineT (f c) b) a --- | A spline is a transformer and other monadic computations can be lifted--- int a spline.-instance MonadTrans (SplineT a b) where- lift f = SplineT $ varM $ const $ liftM (Step mempty . Event) f+-- | A spline is a transformer if its output type is a Monoid.+instance Monoid b => MonadTrans (SplineT a b) where+ lift = effect mempty -- | A spline can do IO if its underlying monad has a MonadIO instance. It--- takes the result of the IO action as its immediate return value and--- uses 'mempty' to generate an empty output value.-instance (Functor m, Applicative m, MonadIO m) => MonadIO (SplineT a b m) where- liftIO = lift . liftIO+-- takes the result of the IO action as its immediate return value.+instance (Monoid b, Monad m, MonadIO m) => MonadIO (SplineT a b m) where+ liftIO = lift . liftIO +-- | Run the spline over the input values, gathering the output and result+-- values in a list.+scanSpline :: (Applicative m, Monad m)+ => SplineT a b m c -> b -> [a] -> m [b]+scanSpline s b = scanVar (outputStream s b)++-- | A SplineT monad parameterized with Identity that takes input of type @a@,+-- output of type @b@ and a result value of type @c@.+type Spline a b c = SplineT a b Identity c+ -- | Evaluates a spline into a value stream of its output type.-outputStream :: (Applicative m, Monad m) - => b -> SplineT a b m c -> VarT m a b-outputStream x s = ((stepOutput <$>) $ runSplineT s) ~> foldStream (\_ y -> y) x+outputStream :: (Applicative m, Monad m)+ => SplineT a b m c -> b -> VarT m a b+outputStream s b = fst <$> runSplineT s b --- | Evaluates a spline to an event stream of its result. The resulting--- value stream inhibits until the spline's domain is complete and then it--- produces events of the result type.-resultStream :: (Applicative m, Monad m) => SplineT a b m c -> VarT m a (Event c)-resultStream = (stepResult <$>) . runSplineT+resultStream :: (Applicative m, Monad m)+ => SplineT a b m c -> b -> VarT m a (Event c)+resultStream s b = snd <$> runSplineT s b --- | Create a spline using an event stream. The spline will run until the--- stream inhibits, using the stream's last produced value as the current--- output value. In the case the stream inhibits before producing--- a value the default value is used. The spline's result is the last--- output value.-fromEvents :: (Applicative m, Monad m) => b -> VarT m a (Event b) -> SplineT a b m b-fromEvents x ve = SplineT $ VarT $ \a -> do- (ex, ve') <- runVarT ve a- case ex of- NoEvent -> let n = Step (Event x) (Event x) in return (n, pure n)- Event x' -> return ( Step (Event x') NoEvent- , runSplineT $ fromEvents x' ve'- )+-- | Create a spline from an event stream.+fromEvent :: Monad m => VarT m a (Event b) -> SplineT a (Event b) m b+fromEvent ve = SplineT $ f <$> ve+ where f e = (e,e) -- | Create a spline from a value stream and an event stream. The spline -- uses the value stream as its output value. The spline will run until@@ -179,88 +146,121 @@ untilEvent :: (Applicative m, Monad m) => VarT m a b -> VarT m a (Event c) -> SplineT a b m (b,c)-untilEvent v ve = SplineT $ t ~> var (uncurry f)- where t = (,) <$> v <*> ve- f b ec = case ec of- NoEvent -> Step (Event b) NoEvent- Event c -> Step (Event b) (Event (b, c))+untilEvent v ve = SplineT $ f <$> v <*> ve+ where f b ec = (b, (b,) <$> ec) -- | A variant of 'untilEvent' that only results in the left result, -- discarding the right result. untilEvent_ :: (Applicative m, Monad m) => VarT m a b -> VarT m a (Event c) -> SplineT a b m b-untilEvent_ v ve = fst <$> untilEvent v ve+untilEvent_ v ve = SplineT $ f <$> v <*> ve+ where f b ec = (b, b <$ ec) -- | A variant of 'untilEvent' that only results in the right result, -- discarding the left result. _untilEvent :: (Applicative m, Monad m) => VarT m a b -> VarT m a (Event c)- -> SplineT a b m b-_untilEvent v ve = fst <$> untilEvent v ve+ -> SplineT a b m c+_untilEvent v ve = snd <$> untilEvent v ve --- | Run two splines in parallel, combining their output. Return the result of --- the spline that concludes first. If they conclude at the same time the result +-- | A variant of 'untilEvent' that discards both the right and left results.+_untilEvent_ :: (Applicative m, Monad m)+ => VarT m a b -> VarT m a (Event c)+ -> SplineT a b m ()+_untilEvent_ v ve = void $ _untilEvent v ve++-- | Run two splines in parallel, combining their output. Return the result of+-- the spline that concludes first. If they conclude at the same time the result -- is taken from the left spline.-race :: (Applicative m, Monad m) - => (b -> d -> e) -> SplineT a b m c -> SplineT a d m c -> SplineT a e m c-race f (SplineTConst a) s =- race f (SplineT $ pure $ Step mempty $ Event a) s-race f s (SplineTConst b) =- race f s (SplineT $ pure $ Step mempty $ Event b)+race :: (Applicative m, Monad m)+ => (a -> b -> c) -> SplineT i a m d -> SplineT i b m e+ -> SplineT i c m (Either d e)+race _ (Pass x) _ = Pass $ Left x+race _ _ (Pass x) = Pass $ Right x race f (SplineT va) (SplineT vb) = SplineT $ VarT $ \i -> do- (Step ua ea, va') <- runVarT va i- (Step ub eb, vb') <- runVarT vb i- let s' = runSplineT $ race f (SplineT va') (SplineT vb')- case (ea,eb) of- (Event a,_) -> return (Step (f <$> ua <*> ub) ea, s') - (_,Event b) -> return (Step (f <$> ua <*> ub) eb, s') - (_,_) -> return (Step (f <$> ua <*> ub) NoEvent, s')+ ((a, ed), va1) <- runVarT va i+ ((b, ee), vb1) <- runVarT vb i+ let c = f a b+ case (ed,ee) of+ (Event d,_) -> return ( (c, Event $ Left d), pure (c, Event $ Left d))+ (_,Event e) -> return ( (c, Event $ Right e), pure (c, Event $ Right e))+ (_,_) -> return ( (c, NoEvent)+ , runSplineT (race f (SplineT va1) (SplineT vb1)) c+ ) --- | Run two splines in parallel, combining their output. When both conclude, --- return their result values in a tuple.-pair :: (Monad m) - => (b -> d -> f) -> SplineT a b m c -> SplineT a d m e - -> SplineT a f m (c, e)-pair f (SplineTConst a) s = pair f (SplineT $ pure $ Step mempty $ Event a) s-pair f s (SplineTConst b) = pair f s (SplineT $ pure $ Step mempty $ Event b)-pair f (SplineT va) (SplineT vb) = SplineT $ VarT $ \a -> do- (Step fa ea, va') <- runVarT va a- (Step fb eb, vb') <- runVarT vb a- return ( Step (f <$> fa <*> fb) ((,) <$> ea <*> eb)- , runSplineT $ pair f (SplineT va') (SplineT vb')- )+raceMany :: (Applicative m, Monad m, Monoid b)+ => [SplineT a b m c] -> SplineT a b m c+raceMany [] = pure mempty `_untilEvent` never+--raceMany (Pass c:_) = Pass c+raceMany ss = SplineT $ VarT $ \a -> do+ let f (b, ec, ss1) s = do+ ((b1, ec1), v1) <- runVarT (runSplineT s b) a+ return (b <> b1, msum [ec, ec1], ss1 ++ [SplineT v1])+ (b,ec,ss1) <- foldM f (mempty, NoEvent, []) ss+ return ((b,ec), runSplineT (raceMany ss1) b) +-- | Run two splines in parallel, combining their output. Once both splines+-- have concluded, return the results of each in a tuple.+merge :: (Applicative m, Monad m)+ => (b -> b -> b) -> (c -> d -> e)+ -> SplineT a b m c -> SplineT a b m d -> SplineT a b m e+merge _ g (Pass c) (Pass d) = Pass $ g c d+merge _ g (Pass c) s = g c <$> s+merge _ g s (Pass d) = flip g d <$> s+merge f g (SplineT v1) (SplineT v2) = SplineT $ VarT $ \a -> do+ ((b1,e1), v3) <- runVarT v1 a+ ((b2,e2), v4) <- runVarT v2 a+ let b = f b1 b2+ case (e1,e2) of+ (Event c, Event d) -> let e = (b, Event $ g c d) in return (e, pure e)+ (Event _, _) -> do let s = SplineT $ pure (b1,e1)+ sv4 = SplineT v4+ return ((b, NoEvent), runSplineT (merge f g s sv4) b)+ (_, Event _) -> do let s = SplineT $ pure (b2,e2)+ sv3 = SplineT v3+ return ((b, NoEvent), runSplineT (merge f g sv3 s) b)+ _ -> do let sv3 = SplineT v3+ sv4 = SplineT v4+ return ((b, NoEvent), runSplineT (merge f g sv3 sv4) b)++-- | Run the side effect and use its result as the spline's result. This+-- discards the output argument and switches immediately, but the argument is+-- needed to construct the spline. For this reason spline's can't be an instance+-- of MonadTrans or MonadIO.+effect :: (Applicative m, Monad m) => b -> m x -> SplineT a b m x+effect b f = SplineT $ VarT $ const $ do+ x <- f+ return ((b, Event x), pure (b, Event x))+ -- | Capture the spline's last output value and tuple it with the -- spline's result. This is helpful when you want to sample the last -- output value in order to determine the next spline to sequence.-capture :: (Applicative m, Monad m, Eq b)+capture :: (Applicative m, Monad m) => SplineT a b m c -> SplineT a b m (Maybe b, c)-capture (SplineTConst x) = SplineTConst (Nothing, x)-capture (SplineT v) = capture' Nothing v- where capture' mb v' = SplineT $ VarT $ \a -> do- (Step fb ec, v'') <- runVarT v' a- let mb' = if fb == NoEvent then mb else toMaybe fb- ec' = (mb',) <$> ec- return (Step fb ec', runSplineT $ capture' mb' v'')+capture (Pass x) = Pass (Nothing, x)+capture (SplineT v) = capture' v+ where capture' v' = SplineT $ VarT $ \a -> do+ ((b, ec), v'') <- runVarT v' a+ let mb' = Just b+ return ((b, (mb',) <$> ec), runSplineT (capture' v'') b) -- | Produce the argument as an output value exactly once. step :: (Applicative m, Monad m) => b -> SplineT a b m ()-step b = SplineT $ VarT $ \_ ->- return (Step (pure b) NoEvent, pure $ Step (pure b) $ Event ())+step b = SplineT $ VarT $ \_ -> return ((b, NoEvent), pure (b,Event ())) -- | Map the output value of a spline.-mapOutput :: (Applicative m, Monad m) +mapOutput :: (Applicative m, Monad m) => VarT m a (b -> t) -> SplineT a b m c -> SplineT a t m c-mapOutput _ (SplineTConst c) = SplineTConst c-mapOutput vf (SplineT vx) = SplineT $ mapStepOutput <$> vg <*> vx- where vg = (<$>) <$> vf+mapOutput vf (SplineT vx) = SplineT $ vg <*> vx+ where vg = (\f (b,ec) -> (f b, ec)) <$> vf+mapOutput _ (Pass c) = Pass c -- | Map the input value of a spline. adjustInput :: (Monad m) => VarT m a (a -> r) -> SplineT r b m c -> SplineT a b m c-adjustInput _ (SplineTConst c) = SplineTConst c adjustInput vf (SplineT vx) = SplineT $ VarT $ \a -> do- (f, vf') <- runVarT vf a- (b, vx') <- runVarT vx $ f a- return (b, runSplineT $ adjustInput vf' $ SplineT vx')+ (f, vf1) <- runVarT vf a+ (b, vx1) <- runVarT vx $ f a+ return (b, runSplineT (adjustInput vf1 $ SplineT vx1) $ fst b)+adjustInput _ (Pass c) = Pass c
src/Control/Varying/Time.hs view
@@ -2,47 +2,22 @@ -- Copyright: (c) 2015 Schell Scivally -- License: MIT -- Maintainer: Schell Scivally <schell.scivally@synapsegroup.com>-{-# LANGUAGE TupleSections #-} module Control.Varying.Time where import Control.Varying.Core import Control.Varying.Event import Control.Applicative-import Data.Time.Clock-import Control.Monad.IO.Class (MonadIO,liftIO)---- | Produces time deltas using 'getCurrentTime' and 'diffUTCTime'.-deltaUTC :: (MonadIO m, Fractional t) => VarT m b t-deltaUTC = delta (liftIO getCurrentTime) (\a b -> realToFrac $ diffUTCTime a b)---- | Produces time deltas using a monadic computation and a difference--- function.-delta :: (Num t, Fractional t, Applicative m, Monad m)- => m a -> (a -> a -> t) -> VarT m b t-delta m f = VarT $ \_ -> do- t <- m- return (0, delta' t)- where delta' t = VarT $ \_ -> do- t' <- m- let dt = t' `f` t- return (dt, delta' t') -------------------------------------------------------------------------------- -- Using timed events -------------------------------------------------------------------------------- -- | Emits events before accumulating t of input dt. -- Note that as soon as we have accumulated >= t we stop emitting events--- and there is no guarantee that an event will be emitted at time == t.-before :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event ())-before t = VarT $ \dt -> return $- if t - dt >= 0- then (Event (), before $ t - dt)- else (NoEvent, never)+-- and therefore an event will be never be emitted exactly at time == t.+before :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event t)+before t = accumulate (+) 0 ~> onWhen (< t) -- | Emits events after t input has been accumulated. -- Note that event emission is not guaranteed to begin exactly at t,--- only at some small delta after t.-after :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event ())-after t = VarT $ \dt -> return $- if t - dt <= 0- then (Event (), pure $ Event ())- else (NoEvent, after $ t - dt)+-- since it depends on the input.+after :: (Applicative m, Monad m, Num t, Ord t) => t -> VarT m t (Event t)+after t = accumulate (+) 0 ~> onWhen (>= t)
src/Control/Varying/Tween.hs view
@@ -137,7 +137,7 @@ -- resulting spline will take a time delta as input. For example: -- -- @--- testWhile_ isEvent (deltaUTC ~> v)+-- testWhile_ isEvent (deltaUTC >>> v) -- where v :: VarT IO a (Event Double) -- v = execSpline 0 $ tween easeOutExpo 0 100 5 -- @@@ -147,16 +147,20 @@ -- more than once ;) tween :: (Applicative m, Monad m, Fractional t, Ord t) => Easing t -> t -> t -> t -> SplineT t t m t-tween f start end dur = fromEvents start $ timeAsPercentageOf dur ~> var g- where g t = let c = end - start- b = start- x = f c t b- in if t > 1.0 then NoEvent else Event x+tween f start end dur =+ let c = end - start+ b = start+ vt = h <$> timeAsPercentageOf dur+ h t = if t >= 1.0+ then (end, Event end)+ else (f c t b, NoEvent)+ in SplineT vt + -- | Creates a tween that performs no interpolation over the duration. constant :: (Applicative m, Monad m, Num t, Ord t) => a -> t -> SplineT t a m a-constant value duration = fromEvents value $ use value $ before duration+constant value duration = pure value `untilEvent_` after duration -- | VarTies 0.0 to 1.0 linearly for duration `t` and 1.0 after `t`. timeAsPercentageOf :: (Applicative m, Monad m, Ord t, Num t, Fractional t)
test/Main.hs view
@@ -1,107 +1,214 @@ module Main where -import Test.Hspec hiding (after)+import Test.Hspec hiding (after, before) import Test.QuickCheck import Control.Varying import Data.Functor.Identity+import Data.Time.Clock+import Control.Monad.IO.Class main :: IO ()-main = hspec $ do - describe "timeAsPercentageOf" $ do- it "should run past 1.0" $ do- let Identity scans = scanVar (timeAsPercentageOf 4)- [1,1,1,1,1 :: Float]- last scans `shouldSatisfy` (> 1)- it "should progress by increments of the total" $ do- let Identity scans = scanVar (timeAsPercentageOf 4)- [1,1,1,1,1 :: Float]- scans `shouldBe` [0.25,0.5,0.75,1.0,1.25 :: Float] +main = hspec $ do+ describe "before" $ do+ it "should produce events before a given step" $ do+ let Identity scans = scanVar (1 ~> before 3) $ replicate 4 ()+ scans `shouldBe` [Event 1, Event 2, NoEvent, NoEvent] - describe "tween" $ - it "should step by the dt passed in" $ do- let Identity scans = scanSpline (tween linear 0 4 (4 :: Float)) - [0,1,1,1,1,1] - scans `shouldBe` [(Event 0, NoEvent)- ,(Event 1, NoEvent)- ,(Event 2, NoEvent)- ,(Event 3, NoEvent)- ,(Event 4, NoEvent)- ,(Event 4, Event 4)- ]+ describe "after" $ do+ it "should produce events after a given step" $ do+ let Identity scans = scanVar (1 ~> after 3) $ replicate 4 ()+ scans `shouldBe` [NoEvent, NoEvent, Event 3, Event 4]+ describe "anyE" $ do+ it "should produce on any event" $ do+ let v1 = use 1 (1 ~> before 2)+ v2 = use 2 (1 ~> after 3)+ v3 = always 3+ v = anyE [v1,v2,v3]+ Identity scans = scanVar v $ replicate 4 ()+ scans `shouldBe` [Event 1, Event 3, Event 2, Event 2]+ describe "timeAsPercentageOf" $ do+ it "should run past 1.0" $ do+ let Identity scans = scanVar (timeAsPercentageOf 4)+ [1,1,1,1,1 :: Float]+ last scans `shouldSatisfy` (> 1)+ it "should progress by increments of the total" $ do+ let Identity scans = scanVar (timeAsPercentageOf 4)+ [1,1,1,1,1 :: Float]+ scans `shouldBe` [0.25,0.5,0.75,1.0,1.25 :: Float] - describe "untilEvent" $ do- let Identity scans = scanSpline (3 `untilEvent` (1 ~> after 10))- (replicate 10 ())- it "should produce output from the value stream until event procs" $- head scans `shouldBe` (Event 3, NoEvent)- it "should produce output from the value stream until event procs" $- last scans `shouldBe` (Event 3, Event (3,()))+ describe "tween" $+ it "should step by the dt passed in" $ do+ let Identity scans = scanSpline (tween linear 0 4 (4 :: Float)) 0+ [0,1,1,1,1,1]+ scans `shouldBe` [0,1,2,3,4,4] - describe "pair" $ do- let s1 = 3 `untilEvent_` (1 ~> after 10)- s2 = do 4 `untilEvent_` (1 ~> after 10)- 5 `untilEvent_` (1 ~> after 10)- Identity scans = scanSpline (pair (+) s1 s2) $ replicate 20 () - it "should end" $- length (takeWhile ((== NoEvent) . snd) scans) `shouldBe` 18 - it "should combine output" $- head scans `shouldBe` (Event 7, NoEvent)- it "should progress" $- (scans !! 11) `shouldBe` (Event 8, NoEvent)- it "should pair both results" $- last scans `shouldBe` (Event 8, Event (3,5))+ describe "untilEvent" $ do+ let Identity scans = scanSpline (3 `untilEvent` (1 ~> after 10)) 0+ (replicate 10 ())+ it "should produce output from the value stream until event procs" $+ head scans `shouldBe` 3+ it "should produce output from the value stream until event procs" $+ last scans `shouldBe` 3 - describe "race" $ do- let s1 = pure 'a' `untilEvent_` (1 ~> after 3)- s2 = pure 'x' `untilEvent_` (1 ~> after 4)- r = race (\a x -> [a,x]) s1 s2- Identity scans = scanSpline r $ replicate 20 ()- it "should combine output" $- head scans `shouldBe` (Event "ax", NoEvent) - it "should end" $- length (takeWhile ((== NoEvent) . snd) scans) `shouldBe` 2- it "should show 'a' as winner" $- last scans `shouldBe` (Event "ax", Event 'a')+ describe "step" $ do+ let s = do step "hey"+ step ", "+ step "there"+ step "."+ Identity scans = scanSpline s "" $ replicate 6 ()+ it "should produce output exactly one time per call" $+ concat scans `shouldBe` "hey, there..." - describe "capture" $ do- let fstr str char = str ++ [char]- s = (1 ~> accumulate (+) (fromEnum 'a') - ~> var toEnum - ~> accumulate fstr "") - `untilEvent_` (1 ~> after 3)- Identity scans = scanSpline (capture s) $ replicate 5 ()- it "should end with the last value captured" $ - scans !! 2 `shouldBe` (Event "bcd", Event (Just "bcd", "bcd")) - - describe "step" $ do- let s = step "hey"- Identity scans = scanSpline s $ replicate 3 ()- it "should produce exactly once" $ do- head scans `shouldBe` (Event "hey", NoEvent)- scans !! 1 `shouldBe` (Event "hey", Event ())+ describe "fromEvent" $ do+ let s = fromEvent $ var f ~> onJust+ f 0 = Nothing+ f 1 = Just "YES"+ Identity scans = scanSpline s NoEvent [0,0,0,1,0]+ it "should produce NoEvent until it procs" $+ scans `shouldBe` [NoEvent,NoEvent,NoEvent,Event "YES",Event "YES"] - describe "mapOutput" $ do- let s :: Spline () String String - s = pure "hey" `untilEvent_` never- f :: Int -> Char -> Int- f acc char = acc + fromEnum char- g :: String -> Int- g = foldl f 0- v :: Var () (String -> Int)- v = var $ const g - s' = mapOutput v s - Identity scans = scanSpline s' $ replicate 3 ()- it "should map the output" $ - head scans `shouldBe` (Event 326, NoEvent) + describe "effect" $ do+ let s :: SplineT () String IO ()+ s = do step "Getting the time..."+ utc <- effect "running" $ getCurrentTime+ let t = head $ words $ show utc+ step t+ step "The End"+ it "should step once, get the time and then step with a string of the time"+ $ do utc <- getCurrentTime+ let t = head $ words $ show utc+ scans <- liftIO $ scanSpline s "" [(), (), ()]+ scans `shouldBe` ["Getting the time...", t, "The End"]+ describe "race" $ do+ let s1 = do step "s10"+ step "s11"+ step "s12"+ return (1 :: Int)+ s2 = do step "s20"+ step "s21"+ return True+ r = do step "start"+ eIntBool <- race (\a b -> concat [a,":",b]) s1 s2+ case eIntBool of+ Left i -> step $ "left won with " ++ show i+ Right b -> step $ "right won with " ++ show b+ Identity scans = scanSpline r "" $ replicate 4 ()+ it "should step twice and left should win" $+ unwords scans `shouldBe` "start s10:s20 s11:s21 right won with True" - describe "adjustInput" $ do- let s = var id `untilEvent_` never- v :: Var a (Char -> Int) - v = pure fromEnum - s' = adjustInput v s- Identity scans = scanSpline s' "abcd"- it "should" $ map fst scans `shouldBe` [ Event 97- , Event 98- , Event 99- , Event 100- ]+ describe "raceMany" $ do+ let s1 = do step "t"+ step "c"+ return 0+ s2 = do step "h"+ step "a"+ return 1+ s3 = do step "e"+ step "t"+ return (2 :: Int)+ s = do x <- raceMany [s1,s2,s3]+ step $ show x+ Identity scans = scanSpline s "" $ replicate 3 ()+ it "should output in parallel (mappend) and return the first or leftmost result" $ unwords scans `shouldBe` "the cat 0"++ describe "capture" $ do+ let r :: Spline () String ()+ r = do x <- capture $ do step "a"+ step "b"+ return 2+ case x of+ (Just "b", 2) -> step "True"+ _ -> step "False"+ scans = scanSpline r "" $ replicate 3 ()+ it "should end with the last value captured" $+ unwords (concat scans) `shouldBe` "a b True"++ describe "mapOutput" $ do+ let s :: Spline a Char ()+ s = do step 'a'+ step 'b'+ step 'c'+ let f = pure toEnum+ mapOutput f $ do step 100+ step 101+ step 102+ step 'g'+ Identity scans = scanSpline s 'x' $ replicate 7 ()+ it "should map the output" $+ scans `shouldBe` "abcdefg"++ describe "adjustInput" $ do+ let s = var id `untilEvent_` never+ v :: Var a (Char -> Int)+ v = pure fromEnum+ s' = adjustInput v s+ Identity scans = scanSpline s' 0 "abcd"+ it "should" $ scans `shouldBe` [97,98,99,100]+--------------------------------------------------------------------------------+-- Adherance to typeclass laws+--------------------------------------------------------------------------------+ let inc = 1 ~> accumulate (+) 0+ sinc :: Spline a Int (Int, Int)+ sinc = inc `untilEvent` (1 ~> after 3)+ go a = scanSpline a 0 [0..9]+ equal a b = go a `shouldBe` go b++ describe "spline's functor instance" $ do+ let sincf = fmap id sinc+ it "fmap id = id" $ equal sinc sincf+ let g :: (Int, Int) -> (Int, Int)+ g (x,y) = (x + 1, y)+ f (x,y) = (x - 1, y)+ sdot = fmap (g . f) sinc+ sfdot = fmap g $ fmap f sinc+ it "fmap (g . f) = fmap g . fmap f" $ equal sdot sfdot++ describe "spline's applicative instance" $ do+ let ident = pure id <*> sinc+ it "(identity) pure id <*> v = v" $ equal ident sinc+ let pfpx :: Spline a Int Int+ pfpx = pure (+1) <*> pure 1+ pfx = pure (1+1)+ it "(homomorphism) pure f <*> pure x = pure (f x)" $ equal pfpx pfx+ let u :: Spline a Int (Int -> Int)+ u = pure 66 `_untilEvent` (use (+1) $ 1 ~> after 3)+ upy = u <*> pure 1+ pyu = pure ($ 1) <*> u+ it "(interchange) u <*> pure y = pure ($ y) <*> u" $ equal upy pyu+ let v :: Spline a Int (Int -> Int)+ v = pure 66 `_untilEvent` (use (1-) $ 1 ~> after 4)+ w = pure 72 `_untilEvent` (use 3 $ 1 ~> after 1)+ pduvw = pure (.) <*> u <*> v <*> w+ uvw = u <*> (v <*> w)+ it "(compisition) pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $+ equal pduvw uvw++ describe "spline's monad instance" $ do+ let h = sinc+ hr = h >>= return+ p :: Spline a Int Int+ p = pure 1++ it "(right identity w/ const) m >>= return == m" $ equal (p >>= return) p+ it "(right identity) m >>= return == m" $ equal h hr+ it "(right identity w/ monadic results) m >>= return == m" $+ (scanVar (runSplineT h 0) [0..9])+ `shouldBe` scanVar (runSplineT hr 0) [0..9]+ let f :: Int -> Spline a String Bool+ f x = do mapM_ (step . show) [0..x]+ return True+ it "(left identity) return a >>= f == f a" $+ (scanVar (runSplineT (return 3 >>= f) "") [0..9])+ `shouldBe` scanVar (runSplineT (f 3) "") [0..9]+ let m :: Spline a String Int+ m = do step "hey"+ step "dude"+ return 2+ g :: Bool -> Spline a String ()+ g True = do step "okay"+ step "got it"+ g False = do step "dang"+ step "missed it"+ it "(associativity) (m >>= f) >>= g == m >>= (\\x -> f x >>= g)" $+ (scanVar (runSplineT ((m >>= f) >>= g) "") [0..9])+ `shouldBe` scanVar (runSplineT (m >>= (\x -> f x >>= g)) "") [0..9]
varying.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.4.0.0+version: 0.5.0.0 -- A short (one-line) description of the package. synopsis: FRP through value streams and monadic splines.@@ -118,6 +118,26 @@ -- Directories containing source files. hs-source-dirs: test++ main-is: Main.hs++ -- Base language which the package is written in.+ default-language: Haskell2010++benchmark varying-bench+ type: exitcode-stdio-1.0+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++ -- Other library packages from which modules are imported.+ build-depends: base >=4.7 && <4.9+ , time >=1.5 && <1.6+ , transformers+ , varying+ , criterion+++ -- Directories containing source files.+ hs-source-dirs: bench main-is: Main.hs