dyna (empty) → 0.1.0.0

raw patch · 8 files changed

+1688/−0 lines, 8 filesdep +Booleandep +MonadRandomdep +asyncsetup-changed

Dependencies added: Boolean, MonadRandom, async, base, dyna, lifted-async, lifted-base, monad-control, mtl, random, stm, temporal-media, time, unagi-chan, unbounded-delays, vector, vector-space

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +20/−0
Setup.hs +2/−0
dyna.cabal +73/−0
src/Dyna.hs +1532/−0
src/Dyna/Ref.hs +26/−0
test/Spec.hs +2/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for try-evt++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,20 @@+# dyna - FRP library++The `dyna` is functional reactive programming (FRP) library for Haskell.+It implements classical FRP and probvides easy to use +interface to write call-back heavy interactive applications.++## Tutorial++* [Introduction](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/00-intro.md)+* [Event streams](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/01-event-streams.md)+* [Console game example](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/03-event-game-example.md)+* [Dynamic values](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/04-dynamics.md)+* [Backbone FRP monad](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/05-backbone-monad.md)+* [Control flow. Sharing event streams and recursion](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/06-control-flow.md)+* [How to make bindings to imperative libraries](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/07-make-bindings.md)+* [Parsers of event streams](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/08-parser.md)+* [Conclusion](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/09-conclusion.md)+* [Quick reference](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/101-reference.md)+* [Resources](https://github.com/anton-k/dyna-frp/blob/main/dyna/tutorial/102-resuorces.md)+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ dyna.cabal view

@@ -0,0 +1,73 @@+cabal-version: 1.12++name:           dyna+version:        0.1.0.0+synopsis:       Minimal FRP library+description:    Defines minimal FRP library (classical FRP)+homepage:       https://github.com/anton-k/dyna-frp#readme+bug-reports:    https://github.com/anton-k/dyna-frp/issues+author:         Anton Kholomiov+maintainer:     anton.kholomiov@gmail.com+copyright:      2022 Anton Kholomiov+category:       FRP+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/anton-k/dyna-frp/dyna++library+  exposed-modules:+      Dyna+      Dyna.Ref+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , async+    , Boolean+    , mtl+    , stm+    , random+    , unagi-chan+    , unbounded-delays+    , lifted-base+    , lifted-async+    , monad-control+    , MonadRandom+    , vector+    , vector-space+    , temporal-media+    , time+  default-language: Haskell2010+  default-extensions:+    DeriveFunctor+    RankNTypes+    LambdaCase+    FlexibleContexts+    FlexibleInstances+    ExistentialQuantification+    TypeApplications+    TypeFamilies+    TupleSections+    GeneralizedNewtypeDeriving+    UndecidableInstances+    ImportQualifiedPost++test-suite dyna-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_dyna+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , dyna+  default-language: Haskell2010

+ src/Dyna.hs view

@@ -0,0 +1,1532 @@+-- | Dyna is functional reactive programming library.+-- It describes event streams that are based on callbacks.+-- The event stream can produce something useful with callback that it consumes.+-- Also we have continous signals called @Dyn@ (short for dynamic).+-- The Dyn is sort of observance process of an event stream. For any+-- event that happen on event stream we remember that value and produce it+-- at any time until the next event will happen.+--+-- # Events+--+-- The event stream is just callback consumer funtion:+--+-- > newtype Evt m a = Evt {+-- >   runEvt :: (a -> m ()) -> m ()+-- > }+--+-- So it tells us: If you give me some callback @(a -> m ())@ I will apply it to the event+-- when event will occur. But when it will occur we don't know until we run the event.+-- All events happen at the same time. Every event triggers a callback.+-- This has some special nuance to it. That can differ from other FRP libraries.+-- For example monoidal append of two event streams:+--+--  > evtA <> evtB+--+-- In many FRP libraries we choose which element will happen or should we also append the events+-- if they happen "at the same time". For this library we spawn two concurrent processes+-- on background so if two events will happen at the same time callback will be called twice.+--+-- # Dynamics+--+-- The assumption is that dynamic is a process that evolves in time.+-- And as a human beings we can only ask for current values while process happens.+-- So we assemble the dynamics with combinators an after that we can run it's process:+--+-- > ref <-runDyn dynamicValue+--+-- It produces reference to the process which we can use to sample the current value in real time:+--+-- > readDyn ref+-- >  10+-- > readDyn ref  -- 5 seconds later+-- >  10+-- > readDyn ref  -- 5 seconds later+-- >  3+--+-- This reminds us of the notion of present moment. Take for example a weather temperature.+-- We can claim to build a model of weather and have an assumption of which value will happen tomorrow+-- but the exact value for it we can only measure at the moment when it will actually happen.+--+-- So the library is based on simple assumptions:+--+-- * Event stream is a callback processor+--+-- * Event stream happen at the same time as concurrent process+--+-- * Dynamic is a process and we can only query the current value for it+--+-- * Dynamics are based on event streams. The dynamic is an observation of some underlying event streams.+--    We just remember the last event and keep producing it until the next one wil arrive.+module Dyna(+  -- * Pipe+  (|>),+  -- * Class+  Frp(..),+  -- * Events+  Evt(..),+  once,+  never,+  -- * Dynamics+  Dyn(..),+  constDyn,+  runDyn,+  DynRef(..),+  readDyn,+  cancelDyn,++  -- * Control+  newEvt,+  newDyn,+  withDyn,++  -- * API+  -- * Event API+  scan,+  scanMay,+  mapMay,+  accum,+  accumB,+  accumMay,+  filters,+  filterJust,+  whens,+  splits,+  lefts,+  rights,+  iterates,+  withIterates,++  fix1,+  fix2,+  fix3,+  fix4,+  switch,+  joins,++  delay,+  delayFork,++  sums,+  sumD,+  integrate,+  integrate2,+  products,+  count,+  withCount,+  appends,+  foldMaps,+  takes,+  drops,+  takesWhile,+  dropsWhile,+  cycles,+  listAt,+  toToggle,++  forevers,+  races,+  forks,+  -- * Render streams+  heads,+  prints,+  putStrLns,+  folds,+  foldls,+  foldls',+  foldrs,+  foldrs',+  Parser,+  runParser,+  takeP,+  cycleP,+  headP,+  maybeP,+  -- * Event/Dynamic interaction+  hold,+  unhold,+  scanD,+  scanMayD,+  switchD,+  switchDyn,+  apply,+  applyMay,+  snap,+  attach,+  attachWith,+  attachWithMay,+  (<@>),+  (<@),+  -- * Effectful API+  FunctorM(..),+  foreach,+  posteach,+  iterates',+  scan',+  scanMay',+  accum',+  accumMay',+  filters',+  mapMay',+  apply',+  applyMay',+  -- * Utilities++  -- **  Channels (interaction with the world)+  mchanEvt,+  tchanEvt,+  uchanEvt,+  UChan,+  newTriggerEvt,+  -- ** IO+  getLines,++  -- ** Clock+  clock,+  pulse,+  ticks,+  timer,+  timerD,+  -- ** Random+  toRandom,+  toRandomR,+  withRandom,+  withRandomR,+  oneOf,+  withOneOf,+  freqOf,+  withFreqOf,+  randSkip,+  randSkipBy,++  -- * Re-exports+  liftA2,+  liftA3,+  BasisArity(..),+  module X,+) where++import Prelude hiding ((<*))+import Data.IORef+import Control.Applicative (liftA2, liftA3)+import Control.Monad+import Control.Monad.IO.Class+import System.Environment+import Data.Functor+import Data.Bifunctor+import Data.Function+import Data.Maybe (fromJust)+import Data.Vector qualified as V+import Data.AdditiveGroup as X+import Data.AffineSpace as X+import Data.Basis+import Data.Cross as X+import Data.VectorSpace as X+import Data.String+import Control.Concurrent.Lifted+import Control.Concurrent.Thread.Delay qualified as D+import Control.Concurrent.Async.Lifted+import Control.Concurrent.STM+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan+import Control.Concurrent.Chan.Unagi (InChan)+import Control.Concurrent.Chan.Unagi qualified as U+import Control.Concurrent.Chan qualified as M++import Control.Monad.Trans.Control+import Dyna.Ref+import Data.Time+import System.Random (Random, newStdGen, randomR, random)+import Control.Exception.Lifted+import Control.Monad.Random.Class qualified as R+import Temporal.Class as X++import Data.Boolean++infixl 4 <@>+infixl 4 <@+infixl 0  |>++{-# inline (|>) #-}+-- | Pipe operator. We often write processors of event streams+-- It makes it convenient write them from first to the last:+--+-- > evt = proc1 |> proc2 |> ... |> procN+--+-- Instead of reversed order with @($)@:+--+-- > evt = procN $ ... $ proc2 $ proc1+(|>) :: a -> (a -> b) -> b+a |> f = f a+++class (IsRef (Ref m), MonadBaseControl IO m, MonadIO m) => Frp m where+  type Ref m :: * -> *++instance Frp IO where+  type Ref IO = TVar++-- | Dynamics are step-wise constant effectful functions+-- each step transition is driven by underlying stream of events.+--+-- Meaning of the Dyn is a process that evolves in time.+-- We can start the process by running @runDyn@. It produces a reference to the+-- process that runs in background.+--+-- > runDyn :: Frp m => Dyn m a -> DynRef m a+--+-- When reference is initialized we can query current  value of it:+--+-- > readDyn :: DynRef m a -> m a+--+-- When we are done with observations we should shut down the background process with:+--+-- > cancelDyn :: DynRef m a -> m ()+--+-- It kills the background process and triggers the release function of underlying event stream.+data Dyn m a+  = forall s . Dyn+      { dyn'get     :: s -> m a   -- ^ get the value from internal state+      , dyn'evt     :: Evt m s    -- ^ stream of state updates+      , dyn'init    :: m s        -- ^ initial state+      , dyn'release :: m ()       -- ^ release resources for dynamic+      }+    -- ^ event based dynamic+  | ConstDyn a+    -- ^ Constant value++-- | Reference to running dynamic process by which we can query values (@readDyn@).+-- Also note that we no longer need the reference we should release the resources+-- by calling @cancelDyn@.+data DynRef m a+  = forall s . DynRef (s -> m a) (Ref m s) ThreadId (m ())+  | ConstRef a++-- | Runs dynamic within the scope of the function.+-- It provides a callback with dyn getter as argument and after+-- callback finishes it shutdowns the dyn process.+withDyn :: Frp m => Dyn m a -> (m a -> m b) -> m b+withDyn dyn f = bracket (runDyn dyn) cancelDyn (\ref -> f (readDyn ref))++-- | Dyn that is constructed from effectful callback.+constDyn :: Frp m => m a -> Dyn m a+constDyn act = Dyn (const act) never (pure ()) (pure ())++instance Functor m => Functor (Dyn m) where+  fmap f (ConstDyn a)                = ConstDyn (f a)+  fmap f (Dyn extract evt s release) = Dyn (fmap f . extract) evt s release++instance Frp m => Applicative (Dyn m) where+  pure a = ConstDyn a+  (ConstDyn f) <*> (ConstDyn a) = ConstDyn (f a)+  (ConstDyn f) <*> (Dyn aget aevt as release) = Dyn (\s -> f <$> aget s) aevt as release+  (Dyn fget fevt fs release) <*> (ConstDyn a) = Dyn (\s -> ($ a) <$> fget s) fevt fs release+  (Dyn fget fevt fs releaseF) <*> (Dyn aget aevt as releaseA) =+    Dyn (\(f, a) -> (fget f) <*> (aget a)) evt (liftA2 (,) fs as) (releaseF >> releaseA)+    where+      evt = Evt $ \go -> do+        tv <- proxyNewRef evt =<< liftA2 (,) fs as+        void $ fork $ runEvt joint $ \case+          Left  s -> do+            liftIO $ modifyRef tv (first $ const s)+            go =<< liftIO (readRef tv)+          Right s -> do+            liftIO $ modifyRef tv (second $ const s)+            go =<< liftIO (readRef tv)++      joint = fmap Left fevt <> fmap Right aevt++-- | Event stream. The meaning of an event is a callback consumer function.+-- If we give callback to it it will do something useful based on it.+--+-- The main function is runEvt:+--+-- > runEvt :: Evt m a -> (a -> m ()) -> m ()+-- > runEvt events callback = ...+--+-- Let's look at simple examples of the event streams:+--+-- Event that never produce anything:+--+-- > never = Evt {+-- >    runEvt _ = pure ()+-- >  }+--+-- So it just ignores the callback and returns right away.+--+-- Event that happens only once:+--+-- > once :: m a -> Evt m a+-- > once get = Evt {+-- >     runEvt go = go =<< get+-- >  }+--+-- It just gets the value right away and applies callback to it.+-- We can try it out in the interpreter:+--+-- > putStrLns $ fmap ("Your message: " <> ) $ once getLine+--+-- We have useful functions to print out the events: @putStrLns@ and @prints@.+--+-- Also we have event streams that happen periodically:+--+-- > prints $ clock 1  -- prints time every second+--+-- ## Duplication of the events.+--+-- Note that event streams are functions that do side-effects within some monad.+-- We use them as values but it means that two values with the same event stream definition+-- can produce different results. For example:+--+-- > a = toRandomR (0, 10) $ clock 1+-- > b = a+--+-- Note that a and b will each have their own copy of underlying random event stream.+-- So if you use it in the code don't expect values to be the same.+--+-- But if we want them to be the same we can copy event from it's definition with function:+--+-- > newEvt :: Evt m a -> m (Evt m a)+--+-- It starts the underying event stream process n background and sends all events+-- to the result by channel. With nice property of when we shut down the result event the+-- background process also shuts down.+--+-- > a <- newEvt toRandomR (0, 10) $ clock 1+-- > b = a+--+-- In this example event streams @a@ and @b@ will have the same events during execution.+newtype Evt m a = Evt { runEvt :: (a -> m ()) -> m () }++-- | Event that happens only once and happens right away.+once :: Frp m => m a -> Evt m a+once ask = Evt $ \go -> go =<< ask++-- | Event that never happens. Callback function is ignored.+never :: Frp m => Evt m a+never = Evt (const $ pure ())++-- | Runs the argument event stream as background process+-- and produces event stream that is fed with events over channel (unagi-channel package).+-- When result event stream shuts down the background process also shuts down.+newEvt :: Frp m => Evt m a -> m (Evt m a)+newEvt evt = do+  ch <- liftIO $ U.newChan+  tid <- fork $ runEvt evt $ liftIO . U.writeChan (fst ch)+  pure $ uchanEvtFinally tid (pure $ fst ch)++uchanEvtFinally :: (Frp m) => ThreadId -> m (InChan a) -> Evt m a+uchanEvtFinally tid mchan = Evt $ \go -> do+  chan <- liftIO . U.dupChan =<< mchan+  loop chan go `finally` (killThread tid)+  where+    loop chan go = do+      a <- liftIO $ U.readChan chan+      go a+      loop chan go++-- | Runs the dynamic process in background and returns dynamic+-- that just samples the background proces with @readDyn@.+newDyn :: Frp m => Dyn m a -> m (Dyn m a)+newDyn dyn = do+  ref <- runDyn dyn+  pure $ Dyn readDyn never (pure ref) (cancelDyn ref)++instance Functor (Evt m) where+  fmap f (Evt evt) = Evt $ \proc -> evt (proc . f)++instance Frp m => Semigroup (Evt m a) where+  (<>) (Evt a) (Evt b) = Evt $ \proc ->+    concurrently_ (a proc) (b proc)++-- | Shutdown the remaining event if one of the events close up early.+races :: Frp m => Evt m a -> Evt m a -> Evt m a+races (Evt a) (Evt b) = Evt $ \go ->+  race_ (a go) (b go)++-- | Execute each callback in separate thread+forks :: Frp m => Evt m a -> Evt m a+forks evt =+  Evt $ \go -> runEvt evt $ void . fork . go++instance Frp m => Monoid (Evt m a) where+  mempty = never++instance Frp m => Applicative (Evt m) where+  pure a = once (pure a)+  f <*> a = a >>= (\x -> fmap ( $ x) f)++instance Frp m => Monad (Evt m) where+  (>>=) a f = switch (fmap f a)++-- | Accumulate over event stream.+accum :: Frp m => (a -> s -> (b, s)) -> s -> Evt m a -> Evt m b+accum f s evt = Evt $ \go -> do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> do+    (b, s) <- f x <$> liftIO (readRef ref)+    go b+    liftIO $ writeRef ref s++-- | Accumulate over event stream.+accum' :: Frp m => (a -> s -> m (b, s)) -> s -> Evt m a -> Evt m b+accum' f s evt = Evt $ \go -> do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> do+    (b, s) <- f x =<< liftIO (readRef ref)+    go b+    liftIO $ writeRef ref s++-- | Accumulate over event stream.+accumMay :: Frp m => (a -> s -> Maybe (b, s)) -> s -> Evt m a -> Evt m b+accumMay f s evt = Evt $ \go -> do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> do+    mRes <- f x <$> liftIO (readRef ref)+    forM_ mRes $ \(b, s) -> do+      go b+      liftIO $ writeRef ref s++-- | Accumulate over event stream.+accumMay' :: Frp m => (a -> s -> m (Maybe (b, s))) -> s -> Evt m a -> Evt m b+accumMay' f s evt = Evt $ \go -> do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> do+    mRes <- f x =<< liftIO (readRef ref)+    forM_ mRes $ \(b, s) -> do+      go b+      liftIO $ writeRef ref s++-- | scan over event stream. Example:+--+-- > naturals = scan (+) 0 pulse+scan :: Frp m => (a -> b -> b) -> b -> Evt m a -> Evt m b+scan f s evt = Evt $ \go -> do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> do+    s <- f x <$> liftIO (readRef ref)+    go s+    liftIO $ writeRef ref s++-- | scan over event stream with effectful function.+scan' :: Frp m => (a -> b -> m b) -> b -> Evt m a -> Evt m b+scan' f s evt = Evt $ \go -> do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> do+    s <- f x =<< liftIO (readRef ref)+    go s+    liftIO $ writeRef ref s++-- | scan combined with filter. If accumulator function produces @Nothing@ on event then+-- that event is ignored and state is kept to previous state.+scanMay :: Frp m => (a -> b -> Maybe b) -> b -> Evt m a -> Evt m b+scanMay f s evt = Evt $ \go -> do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> do+    ms <- f x <$> liftIO (readRef ref)+    forM_ ms $ \s -> do+      go s+      liftIO $ writeRef ref s++-- | scan combined with filter for effectful function. See @scanMay@ for details.+scanMay' :: Frp m => (a -> b -> m (Maybe b)) -> b -> Evt m a -> Evt m b+scanMay' f s evt = Evt $ \go -> do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> do+    ms <- f x =<< liftIO (readRef ref)+    forM_ ms $ \s -> do+      go s+      liftIO $ writeRef ref s++-- | Iterates over event stream. It's like scan but it ignores the values of underying stream+-- and starts with initial value as first element.+iterates :: Frp m => (a -> a) -> a -> Evt m b -> Evt m a+iterates f val evt = Evt $ \go -> do+  ref <- proxyNewRef evt val+  runEvt evt $ \_ -> do+    s <- liftIO (readRef ref)+    go s+    liftIO $ writeRef ref (f s)++withIterates :: Frp m => (a -> a) -> a -> Evt m b -> Evt m (a, b)+withIterates f val evt = Evt $ \go -> do+  ref <- proxyNewRef evt val+  runEvt evt $ \x -> do+    s <- liftIO (readRef ref)+    go (s, x)+    liftIO $ writeRef ref (f s)+++-- | Effectful version for @iterates@.+iterates' :: Frp m => (a -> m a) -> a -> Evt m b -> Evt m a+iterates' f val evt = Evt $ \go -> do+  ref <- proxyNewRef evt val+  runEvt evt $ \_ -> do+    s <- liftIO (readRef ref)+    go s+    liftIO . writeRef ref =<< f s++instance (Frp m, Num a) => Num (Dyn m a) where+  fromInteger = pure . fromInteger+  (+) = liftA2 (+)+  (*) = liftA2 (*)+  (-) = liftA2 (-)+  negate = fmap negate+  abs = fmap abs+  signum = fmap signum++instance (Frp m, Fractional a) => Fractional (Dyn m a) where+  fromRational = pure . fromRational+  recip = fmap recip++instance (Frp m, Semigroup a) => Semigroup (Dyn m a) where+  (<>) = liftA2 (<>)++instance (Frp m, Monoid a) => Monoid (Dyn m a) where+  mempty = pure mempty++instance (Frp m, IsString a) => IsString (Dyn m a) where+  fromString = pure . fromString++-- | Reads current dynamic value.+readDyn :: Frp m => DynRef m a -> m a+readDyn (ConstRef val) = pure val+readDyn (DynRef extract ref _ _) = do+  s <- liftIO (readRef ref)+  extract s++-- | Shuts down the background process for dynamic and releases resulrces for+-- event stream that drives the dynamic.+cancelDyn :: Frp m => DynRef m a -> m ()+cancelDyn (ConstRef _) = pure ()+cancelDyn (DynRef _ _ tid release) = killThread tid >> release++-- | Executes dynamic for observation. The dynamic is step-wise constant+-- function that is driven by some event stream. The function runs the event stream+-- process in background and samples the updated state.+--+-- We can observe the value with @readDyn@. We need to shut down the stream when+-- we no longer need it with @cancelDyn@ function.+runDyn :: Frp m => Dyn m a -> m (DynRef m a)+runDyn (ConstDyn val) = pure (ConstRef val)+runDyn dyn@(Dyn extract evt init release) = do+  ref <- proxyNewRefDyn dyn =<< init+  tid <- fork $ runEvt evt $ \s -> do+    liftIO $ writeRef ref s+  pure (DynRef extract ref tid release)++-- | Turns event stream to dynamic. It holds the values of+-- events until the next event happen. It starts with initial value.+--+-- > hold initVal events = ...+hold :: Frp m => a -> Evt m a -> Dyn m a+hold s evt = Dyn pure evt (pure s) (pure ())++-- | Counts how many events accured so far on the stream.+count :: Frp m => Evt m a -> Evt m Int+count = scan (const succ) 0++withCount :: Frp m => Evt m a -> Evt m (Int, a)+withCount = accum (\a b -> ((b, a), succ b)) 1++-- | Turns dynamic into event stream of underlying events+-- that trigger dynamic updates.+unhold :: Frp m => Dyn m a -> Evt m a+unhold (ConstDyn val) = Evt $ \go -> go val+unhold (Dyn extract evts init release) = Evt $ \go -> do+  go =<< extract =<< init+  runEvt evts (go <=< extract) `finally` release++-- | scans over event stream and converts it to dynamic.+scanD :: Frp m => (a -> b -> b) -> b -> Evt m a -> Dyn m b+scanD f s evt = hold s (scan f s evt)++-- | Accumulates the values with event stream that produce functions.+accumB :: Frp m => a -> Evt m (a -> a) -> Dyn m a+accumB a evt = scanD ($) a evt++-- | Dynamic scan that can also filter out events. If Nothing is produced then the event is skipped.+scanMayD :: Frp m => (a -> b -> Maybe b) -> b -> Evt m a -> Dyn m b+scanMayD f s evt = hold s (scanMay f s evt)++-- | Adds some procedure to callback. Procedure is called prior to callback execution.+foreach :: Frp m => (a -> m ()) -> Evt m a -> Evt m a+foreach call evt = Evt $ \go ->+  runEvt evt $ \x -> do+    call x+    go x++-- | Adds some procedure to callback. Procedure is called after callback execution.+posteach :: Frp m => (a -> m ()) -> Evt m a -> Evt m a+posteach call evt = Evt $ \go ->+  runEvt evt $ \x -> do+    go x+    call x++--------------------------------------------------------------------------------+-- applications++-- | Applies a function to event stream value. The function is sampled+-- from dynamic process.+apply :: Frp m => Dyn m (a -> b) -> Evt m a -> Evt m b+apply dyn evt = Evt $ \go -> do+  ref <- runDyn dyn+  runEvt evt (\b -> do+      go . ($ b) =<< readDyn ref+    )+    `finally` cancelDyn ref++-- | Effectful variant of @apply@.+apply' :: Frp m => Dyn m (a -> m b) -> Evt m a -> Evt m b+apply' dyn evt = Evt $ \go -> do+  ref <- runDyn dyn+  runEvt evt (\b -> do+    (\f -> go =<< f b) =<< readDyn ref)+    `finally` cancelDyn ref++-- | Infix variant of @apply@+(<@>) :: Frp m => Dyn m (a -> b) -> Evt m a -> Evt m b+(<@>) = apply++-- | Infix variant of @snap@.+(<@) :: Frp m => Dyn m a -> Evt m b -> Evt m a+(<@) = snap++-- | Apply combined with filter.+applyMay :: Frp m => Dyn m (a -> Maybe b) -> Evt m a -> Evt m b+applyMay dyn evt = Evt $ \go -> do+  ref <- runDyn dyn+  runEvt evt (\b -> do+    mapM_ go . ($ b) =<< readDyn ref)+    `finally` cancelDyn ref++-- | Effectful @applyMay@.+applyMay' :: Frp m => Dyn m (a -> m (Maybe b)) -> Evt m a -> Evt m b+applyMay' dyn evt = Evt $ \go -> do+  ref <- runDyn dyn+  runEvt evt (\b -> do+    (\f -> mapM_ go =<< f b) =<< readDyn ref)+    `finally` cancelDyn ref++-- | Snapshot of dynamic process with event stream. All values+-- in the event stream are substituted with current value of dynamic.+snap :: Frp m => Dyn m a -> Evt m b -> Evt m a+snap dyn evt = apply (const <$> dyn) evt++-- | Attach element from dyn to event stream.+attach :: Frp m => Dyn m a-> Evt m b -> Evt m (a, b)+attach dyn evt = attachWith (,) dyn evt++-- | Kind of @zipWith@ function for dynamics and event streams.+attachWith :: Frp m => (a -> b -> c) -> Dyn m a -> Evt m b -> Evt m c+attachWith f dyn evt = apply (f <$> dyn) evt++-- | Attach with filtering. When @Nothing@ is produced event is omitted from the stream.+attachWithMay :: Frp m => (a -> b -> Maybe c) -> Dyn m a -> Evt m b -> Evt m c+attachWithMay f dyn evt = applyMay (f <$> dyn) evt++--------------------------------------------------------------------------------+-- filters++-- | Map with filtering. When @Nothing@ is produced event is omitted from the stream.+mapMay :: Frp m => (a -> Maybe b) -> Evt m a -> Evt m b+mapMay f evt = Evt $ \go -> runEvt evt (mapM_ go . f)++-- | Effectful @mapMay@+mapMay' :: Frp m => (a -> m (Maybe b)) -> Evt m a -> Evt m b+mapMay' f evt = Evt $ \go -> runEvt evt (mapM_ go <=< f)++-- | Filtering of the event strewams. Only events that produce True remain in the stream.+filters :: Frp m => (a -> Bool) -> Evt m a -> Evt m a+filters f evt = Evt $ \go -> runEvt evt (\x -> when (f x) (go x))++-- | Effectful filtering for event streams.+filters' :: Frp m => (a -> m Bool) -> Evt m a -> Evt m a+filters' f evt = Evt $ \go -> runEvt evt (\x -> (\cond -> when cond (go x)) =<< f x)++-- | Filters based on Maybe. If @Nothing@ is produced forthe event it is omitted from the stream.+filterJust :: Frp m => Evt m (Maybe a) -> Evt m a+filterJust evt = Evt $ \go -> runEvt evt (mapM_ go)++-- | Filters with dynamic. When dynamic is true events pass through and when it's false+-- events are omitted.+whens :: Frp m => Dyn m Bool -> Evt m a -> Evt m a+whens dyn evt = Evt $ \go -> do+  ref <- runDyn dyn+  runEvt evt $ \b -> do+    a <- readDyn ref+    when a (go b)++-- | Splits the either event stream.+splits :: Frp m => Evt m (Either a b) -> (Evt m a, Evt m b)+splits evt = (lefts evt, rights evt)++-- | Gets all left events from the stream+lefts :: Frp m => Evt m (Either a b) -> Evt m a+lefts evt = mapMay (either Just (const Nothing)) evt++-- | Gets all right events from the stream+rights :: Frp m => Evt m (Either a b) -> Evt m b+rights evt = mapMay (either (const Nothing) Just) evt++-- | Takes only so many events from the stream+takes :: Frp m => Int -> Evt m a -> Evt m a+takes n evt = Evt $ \go -> do+  ref <- proxyNewRef evt 0+  waitAsync $ do+    runEvt evt $ \x -> do+      cur <- liftIO (readRef ref)+      when (cur < n) $ do+        go x+        when (cur == n - 1) stopSelf+        liftIO $ writeRef ref (cur + 1)++-- | Drops first so many events from the stream+drops :: Frp m => Int -> Evt m a -> Evt m a+drops n evt = Evt $ \go -> do+  tv <- proxyNewRef evt n+  runEvt evt $ \x -> do+    cur <- liftIO (readRef tv)+    if (cur <= 0)+      then go x+      else liftIO (modifyRef tv pred)++stopSelf :: Frp m => m ()+stopSelf = killThread =<< myThreadId++waitStop :: Frp m => Async a -> m ()+waitStop x = void $ liftIO $ waitCatch x++waitAsync :: Frp m => m () -> m ()+waitAsync act = do+  tid <- async act+  waitStop tid++-- | Takes events only while predicate is true.+takesWhile :: Frp m => (a -> Bool) -> Evt m a -> Evt m a+takesWhile pred evt = Evt $ \go -> do+  waitAsync $ do+    runEvt evt $ \x -> do+      if (pred x)+        then go x+        else stopSelf++-- | Drops events while predicate is true.+dropsWhile :: Frp m => (a -> Bool) -> Evt m a -> Evt m a+dropsWhile pred evt = Evt $ \go -> do+  tv <- proxyNewRef evt True+  runEvt evt $ \x -> do+    cur <- liftIO (readRef tv)+    if cur+      then+        unless (pred x) $ do+          liftIO $ writeRef tv False+          go x+      else go x++-- | Takes elements from the list by index. If index is out of bounds the event is omitted.+listAt :: Frp m => [a] -> Evt m Int -> Evt m a+listAt vals evt = mapMay (vec V.!?) evt+  where+    vec = V.fromList vals++-- | Turns event stream to toggle stream. It produce cyclic sequence of [True, False]+toToggle :: Frp m => Evt m a -> Evt m Bool+toToggle = iterates not True++-- | Cycles the values in the list over event sream.+cycles :: Frp m => [a] -> Evt m b -> Evt m a+cycles vals evt = fmap (vec V.!) $ iterates ((`mod` len) . succ) 0 evt+  where+    vec = V.fromList vals+    len = V.length vec++-- | Sums all the elements in the event stream+sums :: (Frp m, Num a) => Evt m a -> Evt m a+sums = scan (+) 0++-- | Integrates signal of vectors with given time step+integrate :: (Frp m, VectorSpace v, Real (Scalar v), Fractional (Scalar v)) => (Scalar v) -> Dyn m v -> Dyn m v+integrate dt dyn =+  hold zeroV $ scan (^+^) zeroV (attachWith (\v k -> realToFrac k *^ v) dyn (ticks (realToFrac dt)))++-- | More accurate integration of signal of vectors with given time step+integrate2 :: (Frp m, VectorSpace v, Real (Scalar v), Fractional (Scalar v)) => (Scalar v) -> Dyn m v -> Dyn m v+integrate2 dt dyn =+  hold zeroV $ fmap snd $ scan go (Nothing, zeroV) (attach dyn (ticks (realToFrac dt)))+  where+    go (v, h) (mPrev, res) = ((Just (v, h), ) . (res ^+^ )) $ case mPrev of+      Nothing       -> realToFrac h *^ v+      Just (v0, h0) -> (realToFrac h * 0.5) *^ (v0 ^+^ v)++-- | Sums all points in the signal with given time step+sumD :: (Frp m, Num a) => NominalDiffTime -> Dyn m a -> Dyn m a+sumD dt dyn = hold 0 $ sums (snap dyn (pulse dt))+++-- | Finds the product of all elements in the event stream.+products :: (Frp m, Num a) => Evt m a -> Evt m a+products = scan (*) 1++-- | Monoidal append of all elements in the stream+appends :: (Frp m, Monoid a) => Evt m a -> Evt m a+appends = scan (flip (<>)) mempty++-- | Same as foldMap only for streams.+foldMaps :: (Frp m, Monoid b) => (a -> b) -> Evt m a -> Evt m b+foldMaps f = appends . fmap f++-- | Monoidal fold for event streams, note that stream have to be finite for+-- the function to complete+folds :: (Frp m, Monoid a) => Evt m a -> m a+folds = foldls (<>) mempty++-- | Left fold for event streams, note that stream have to be finite for+-- the function to complete+foldls :: (Frp m) => (b -> a -> b) -> b -> Evt m a -> m b+foldls f s evt = do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> liftIO $ modifyRef ref $ flip f x+  liftIO $ readRef ref++-- | Effectful left fold+foldls' :: (Frp m) => (b -> a -> m b) -> b -> Evt m a -> m b+foldls' f s evt = do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> liftIO . writeRef ref =<< flip f x =<< liftIO (readRef ref)+  liftIO $ readRef ref++-- | Right fold for event streams, note that stream have to be finite for+-- the function to complete+foldrs :: (Frp m) => (a -> b -> b) -> b -> Evt m a -> m b+foldrs f s evt = do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> liftIO $ modifyRef ref $ f x+  liftIO $ readRef ref++-- | Effectful right fold+foldrs' :: (Frp m) => (a -> b -> m b) -> b -> Evt m a -> m b+foldrs' f s evt = do+  ref <- proxyNewRef evt s+  runEvt evt $ \x -> liftIO . writeRef ref =<< f x =<< liftIO (readRef ref)+  liftIO $ readRef ref++-- | Starts event stream process and as callback prints it values.+prints :: (Frp m, Show a) => Evt m a -> m ()+prints evt = runEvt evt (liftIO . print)++-- | Starts event stream process and as callback prints it values.+putStrLns :: (Frp m) => Evt m String -> m ()+putStrLns evt = runEvt evt (liftIO . putStrLn)++-- | Stream of user inputs+getLines :: Frp m => Evt m String+getLines = once (liftIO getLine)++-- | Queries the event stream form dynamic and runs it all next event streams are ignored.+switchDyn :: Frp m => Dyn m (Evt m a) -> Evt m a+switchDyn dyn = Evt $ \go -> do+  ref <- runDyn dyn+  evt <- readDyn ref+  runEvt evt go++-- | Joins event stream of streams. If stream is started it runs until the end.+joins :: Frp m => Evt m (Evt m a) -> Evt m a+joins evt = Evt $ \go ->+  runEvt evt $ \e -> void $ fork $ runEvt e go++-- | Recursion on event streams. As event streams are functions we can not use+-- normal recursion that haskell provides. It will stuck the execution.+-- But we can use @fix1@ to create event stream that feeds back the events to itself.+--+-- Note that any sort of recursion can be implemented with @fix1@.+-- For example if we need 3-recursive event stream:+--+--  > fix3 ::+--  >      (Evt m a -> Evt m b -> Evt m c -> m (Evt m a, Evt m b, Evt m c))+--  >   -> (Evt m a, Evt m b, Evt m c)+--+-- we can use sum tpye tags+-- to join it to single stream:+--+-- > data Tag a b c = TagA a | TagB b | TagC c+--+-- > fix3 f = unwrap $ fix1 g+-- >   where+-- >      g x = wrap <$> f (unwrapA x) (unwrapB x) (unwrapC x)+-- >+-- >      wrap a b c = mconcat [TagA <$> a, TagB <$> b, TagC <$> c]+-- >      unwrap evt = (unwrapA evt, unwrapB evt, unwrapC evt)+-- >+-- >      unwrapA = flip mapMay $ \x -> case x of+-- >                                  TagA a -> Just a+-- >                                  _      -> Nothing+--+-- We can use this trck with any number of streams. There are helper functions: @fix2@, @fix3@, @fix4@+fix1 :: Frp m => (Evt m a -> m (Evt m a)) -> Evt m a+fix1 f = Evt $ \go -> do+  chan <- liftIO U.newChan+  let evt = uchanEvt (fst chan)+  evt' <- f evt+  runEvt evt' $ \x -> do+    liftIO $ U.writeChan (fst chan) x+    go x++-- | Recursion for binary functions+fix2 :: Frp m => (Evt m a -> Evt m b -> m (Evt m a, Evt m b)) -> (Evt m a, Evt m b)+fix2 f = splits $ fix1 g+  where+    g x = wrap <$> f (lefts x) (rights x)+    wrap (a, b) = (Left <$> )a <> (Right <$> b)++data Tag3 a b c = TagA3 a | TagB3 b | TagC3 c++-- | Recursion for ternary functions+fix3 :: Frp m+  => (Evt m a -> Evt m b -> Evt m c -> m (Evt m a, Evt m b, Evt m c))+  -> (Evt m a, Evt m b, Evt m c)+fix3 f = unwrap $ fix1 g+  where+    g x = wrap <$> f (unwrapA x) (unwrapB x) (unwrapC x)+    wrap (a, b, c) = (TagA3 <$> a) <> (TagB3 <$> b) <> (TagC3 <$> c)++    unwrap x = (unwrapA x, unwrapB x, unwrapC x)++    unwrapA = mapMay $ \case+                TagA3 a -> Just a+                _       -> Nothing++    unwrapB = mapMay $ \case+                TagB3 a -> Just a+                _       -> Nothing++    unwrapC = mapMay $ \case+                TagC3 a -> Just a+                _       -> Nothing+++data Tag4 a b c d = TagA4 a | TagB4 b | TagC4 c | TagD4 d++-- | Recursion for functions of four arguments+fix4 :: Frp m =>+     (Evt m a -> Evt m b -> Evt m c -> Evt m d -> m (Evt m a, Evt m b, Evt m c, Evt m d))+  -> (Evt m a, Evt m b, Evt m c, Evt m d)+fix4 f = unwrap $ fix1 g+  where+    g x = wrap <$> f (unwrapA x) (unwrapB x) (unwrapC x) (unwrapD x)+    wrap (a, b, c, d) = (TagA4 <$> a) <> (TagB4 <$> b) <> (TagC4 <$> c) <> (TagD4 <$> d)++    unwrap x = (unwrapA x, unwrapB x, unwrapC x, unwrapD x)++    unwrapA = mapMay $ \case+                TagA4 a -> Just a+                _       -> Nothing++    unwrapB = mapMay $ \case+                TagB4 a -> Just a+                _       -> Nothing++    unwrapC = mapMay $ \case+                TagC4 a -> Just a+                _       -> Nothing++    unwrapD = mapMay $ \case+                TagD4 a -> Just a+                _       -> Nothing++-- | Flattens event stream producer by switching between event streams.+-- When next event stream happens it shuts down the previous one.+switch :: Frp m => Evt m (Evt m a) -> Evt m a+switch evts = Evt $ \go -> do+  tidRef <- proxyNewRef evts Nothing+  let stop = mapM_ killThread =<< liftIO (readRef tidRef)+  lock <- newEmptyMVar  -- we use this lock to make sure that next process+                        -- does not start before we saved it's threadId for stopping.+  runEvt evts (\evt -> do+    stop+    tid <- fork (takeMVar lock >> runEvt evt go)  -- delay until threadId is saved+    liftIO $ writeRef tidRef (Just tid)           -- save tid (for stopping)+    putMVar lock ()                               -- start the event process+    ) `finally` stop++-- | Switches between dynamic producers.+switchD :: Frp m => Dyn m a -> Evt m (Dyn m a) -> Dyn m a+switchD d evts = Dyn extract resEvt init (pure ())+  where+    init    = runDyn d+    extract = readDyn++    resEvt = Evt $ \go -> do+      runEvt evts $ \dyn -> do+        ref <- runDyn dyn+        go ref `finally` cancelDyn ref++---------------------------------------------------------+-- channels++-- | Creates the event stream that listens to MVar based channel.+-- If any value is put chan the event stream fires the callback.+mchanEvt :: (Frp m) => M.Chan a -> Evt m a+mchanEvt chan = Evt $ \go -> do+  chan <- liftIO $ M.dupChan chan+  loop chan go+  where+    loop chan go = do+      a <- liftIO $ M.readChan chan+      go a+      loop chan go++-- | Creates the event stream that listens to @TChan@ based channel.+-- If any value is put chan the event stream fires the callback.+tchanEvt :: (Frp m) => TChan a -> Evt m a+tchanEvt chan = Evt $ \go -> do+  chan <- liftIO $ atomically $ dupTChan chan+  loop chan go+  where+    loop chan go = do+      a <- liftIO $ atomically $ readTChan chan+      go a+      loop chan go++-- | Creates the event stream that listens to unagi channel (package @unagi-chan@).+-- If any value is put chan the event stream fires the callback.+uchanEvt :: (Frp m) => InChan a -> Evt m a+uchanEvt chan = Evt $ \go -> do+  chan <- liftIO $ U.dupChan chan+  loop chan go+  where+    loop chan go = do+      a <- liftIO $ U.readChan chan+      go a+      loop chan go++type UChan a = (U.InChan a, U.OutChan a)++--------------------------------------------------------------------------------++proxyNewRef :: Frp m => Evt m a -> b -> m (Ref m b)+proxyNewRef _ v = liftIO $ newRef v++proxyNewRefDyn :: Frp m => Dyn m a -> b -> m (Ref m b)+proxyNewRefDyn _ v = liftIO $ newRef v++proxyFunRes :: (a -> b) -> b+proxyFunRes _ = undefined++---------------------------------------------------------------------------+-- utilities++-- | Queries current time periodically with given period in seconds.+clock :: Frp m => NominalDiffTime -> Evt m UTCTime+clock t = Evt $ \go -> periodic t $ go =<< liftIO getCurrentTime++-- | Produces pulse events with given period in seconds.+pulse :: Frp m => NominalDiffTime -> Evt m ()+pulse t = Evt $ \go -> periodic t (go ())++-- | Produces pulse events with given period in seconds+-- and also tells how many seconds exactly has passed.+-- It can be useful for simulations of models that are based on differential equations.+-- As event streams carries how much time has passed between simulation steps.+ticks :: Frp m => NominalDiffTime -> Evt m NominalDiffTime+ticks t = Evt $ \go -> do+  startRef <- liftIO $ newIORef =<< getCurrentTime+  periodic t $ do+    dt <- liftIO $ do+      cur   <- getCurrentTime+      start <- readIORef startRef+      writeIORef startRef cur+      pure $ cur `diffUTCTime` start+    go dt++-- | Timer behaves like tocks only it produces accumulated time since beginning+-- of the process. It calculates them by querying current time and suntracting start time from it.+--+-- It can be though of as:+--+-- > sums ticks+timer :: Frp m => NominalDiffTime -> Evt m NominalDiffTime+timer t = Evt $ \go -> do+  start <- liftIO getCurrentTime+  periodic t $ go =<< liftIO ((`diffUTCTime` start) <$> getCurrentTime)++-- | Timer as dynamic signal.+timerD :: Frp m => NominalDiffTime -> Dyn m NominalDiffTime+timerD t = hold 0 $ timer t++{-# NOINLINE periodic #-}+-- | Periodically triggers callback.+periodic :: MonadIO m => NominalDiffTime -> m () -> m ()+periodic dur proc = do+  startRef <- liftIO $ newIORef =<< getCurrentTime+  fix $ \next -> do+    proc+    time <- liftIO $ do+      last <- readIORef startRef+      cur  <- getCurrentTime+      let dt = max 0 $ dur - (cur `diffUTCTime` last)+      writeIORef startRef (addUTCTime dt cur)+      pure dt+    sleep time+    next++-- | Stop the thread for some time in seconds.+sleep :: MonadIO m => NominalDiffTime -> m ()+sleep dt = liftIO . D.delay $ toMicroseconds dt++-- | Convert time to microseconds+toMicroseconds :: NominalDiffTime -> Integer+toMicroseconds t = ceiling $ toRational t * 1000000++--------------------------------------------------------------------------------++-- | Substitutes values in event stream with random values.+toRandom :: forall m a b . (Frp m, Random b) => Evt m a -> Evt m b+toRandom evt = Evt $ \go -> do+  tv <- proxyNewRef evt =<< liftIO newStdGen+  runEvt evt $ \_ -> do+    (a, g) <- liftIO $ random <$> readRef tv+    go a+    liftIO $ writeRef tv g++-- | Substitutes values in event stream with random values from the given range.+toRandomR :: forall m a b . (Frp m, Random b) => (b, b) -> Evt m a -> Evt m b+toRandomR range evt = Evt $ \go -> do+  tv <- proxyNewRef evt =<< liftIO newStdGen+  runEvt evt $ \_ -> do+    (a, g) <- liftIO $ randomR range <$> readRef tv+    go a+    liftIO $ writeRef tv g++-- | Substitutes values in event stream with random values.+withRandom :: forall m a b . (Frp m, Random b) => Evt m a -> Evt m (b, a)+withRandom evt = Evt $ \go -> do+  tv <- proxyNewRef evt =<< liftIO newStdGen+  runEvt evt $ \x -> do+    (a, g) <- liftIO $ random <$> readRef tv+    go (a, x)+    liftIO $ writeRef tv g++-- | Substitutes values in event stream with random values from the given range.+withRandomR :: forall m a b . (Frp m, Random b) => (b, b) -> Evt m a -> Evt m (b, a)+withRandomR range evt = Evt $ \go -> do+  tv <- proxyNewRef evt =<< liftIO newStdGen+  runEvt evt $ \x -> do+    (a, g) <- liftIO $ randomR range <$> readRef tv+    go (a, x)+    liftIO $ writeRef tv g++-- | Picks at random one element from the list+oneOf :: Frp m => [a] -> Evt m b -> Evt m a+oneOf xs evt = listAt xs $ toRandomR (0, len - 1) evt+  where+    len = length xs++-- | Picks at random one element from the list+withOneOf :: Frp m => [a] -> Evt m b -> Evt m (a, b)+withOneOf xs evt = first (vec V.! ) <$> withRandomR (0, len - 1) evt+  where+    len = V.length vec+    vec = V.fromList xs++-- | Picks at random one element from the list. We also provide distribution of events.+-- Probability to pick up the element. Sum of probabilities should equal to 1.+freqOf :: (R.MonadRandom m, Frp m) => Dyn m [(a, Rational)] -> Evt m b -> Evt m a+freqOf dynVals evts = applyMay' ((\vals -> const (go vals)) <$> dynVals) evts+  where+    go vals = R.fromListMay vals++-- | Picks at random one element from the list. We also provide distribution of events.+-- Probability to pick up the element. Sum of probabilities should equal to 1.+withFreqOf :: (R.MonadRandom m, Frp m) => Dyn m [(a, Rational)] -> Evt m b -> Evt m (a, b)+withFreqOf dynVals evts = applyMay' (go <$> dynVals) evts+  where+    go vals x = fmap (fmap ((, x))) $ R.fromListMay vals++-- | Skips at random elements from the list. We provide frequency to skip events with dynamic first argument.+randSkip :: Frp m => Dyn m Double -> Evt m a -> Evt m a+randSkip prob evt = randSkipBy (const <$> prob) evt++-- | Skips elements at random. The probability to skip element depends on the element itself.+randSkipBy :: Frp m => Dyn m (a -> Double) -> Evt m a -> Evt m a+randSkipBy  prob evt = attachWithMay f prob $ withRandomR (0, 1 :: Double) evt+  where+    f getProb (curProb, a)+      | curProb < getProb a  = Nothing+      | otherwise            = Just a++--------------------------------------------------------------------------------++-- | Delays in the thread of execution. Note that it can interfere+-- and screw up functions like clock, timer, pulse, ticks+delay :: Frp m => NominalDiffTime -> Evt m a -> Evt m a+delay dt evt = Evt $ \go ->+  runEvt evt $ \x -> sleep dt >> go x++-- | Delays in background by forking on each event.+-- Note tht if delayed event was put into background prior+-- to stopping of the main event stream it will fire anyway.+-- There is no way to stop it.+delayFork :: Frp m => NominalDiffTime -> Evt m a -> Evt m a+delayFork dt evt = Evt $ \go ->+  runEvt evt $ \x -> void $ fork $ sleep dt >> go x++--------------------------------------------------------------------------------+-- effectful functor++class FunctorM f where+  fmap' :: Frp m => (a -> m b) -> f m a -> f m b++instance FunctorM Evt where+  fmap' f evt = Evt $ \go -> runEvt evt $ \x -> go =<< f x++instance FunctorM Dyn where+  fmap' f (ConstDyn a)                = Dyn f never (pure a) (pure ())+  fmap' f (Dyn extract evt s release) = Dyn (f <=< extract) evt s release++--------------------------------------------------------------------------------+-- Boolean instances++instance (Boolean b, Frp m) => Boolean (Dyn m b) where+  true = pure true+  false = pure false+  notB = fmap notB+  (&&*) = liftA2 (&&*)+  (||*) = liftA2 (||*)++type instance BooleanOf (Dyn m a) = Dyn m (BooleanOf a)++instance (Frp m, IfB a) => IfB (Dyn m a) where+  ifB = liftA3 ifB++instance (EqB a, Frp m) => EqB (Dyn m a) where+  (==*) = liftA2 (==*)++instance (OrdB a, Frp m) => OrdB (Dyn m a) where+  (<*) = liftA2 (<*)+  (>*) = liftA2 (>*)+  (<=*) = liftA2 (<=*)+  (>=*) = liftA2 (>=*)++--------------------------------------------------------------------------------+-- Vector Space instances++instance (AdditiveGroup a, Frp m) => AdditiveGroup (Dyn m a) where+  zeroV = pure zeroV+  (^+^) = liftA2 (^+^)+  (^-^) = liftA2 (^-^)+  negateV = fmap negateV++instance (VectorSpace a, Frp m) => VectorSpace (Dyn m a) where+  type Scalar (Dyn m a) = Dyn m (Scalar a)+  (*^) = liftA2 (*^)++instance (AffineSpace p, Frp m) => AffineSpace (Dyn m p) where+  type Diff (Dyn m p) = Dyn m (Diff p)+  (.-.) = liftA2 (.-.)+  (.+^) = liftA2 (.+^)++class BasisArity v where+  basisArity :: v -> Int++instance BasisArity Float where+  basisArity _ = 1++instance BasisArity Double where+  basisArity _ = 1++instance (BasisArity a, BasisArity b) =>  BasisArity (a, b) where+  basisArity v = basisArity (proxyA v) + basisArity (proxyB v)+    where+      proxyA :: (a, b) -> a+      proxyA _ = undefined++      proxyB :: (a, b) -> b+      proxyB _ = undefined++instance (BasisArity a, BasisArity b, BasisArity c) =>  BasisArity (a, b, c) where+  basisArity v = basisArity (proxyA v) + basisArity (proxyB v) + basisArity (proxyC v)+    where+      proxyA :: (a, b, c) -> a+      proxyA _ = undefined++      proxyB :: (a, b, c) -> b+      proxyB _ = undefined++      proxyC :: (a, b, c) -> c+      proxyC _ = undefined++instance (Frp m, BasisArity v) => BasisArity (Dyn m v) where+  basisArity v = basisArity (proxy v)+    where+      proxy :: Dyn m v -> v+      proxy _ = undefined++instance (BasisArity v, HasBasis v, Frp m) => HasBasis (Dyn m v) where+  type Basis (Dyn m v) = Dyn m (Basis v)+  basisValue = fmap basisValue+  decompose v = fmap unTupleD $ unListD (basisArity v) $ fmap decompose v++  decompose' = liftA2 decompose'++unTupleD :: Frp m => Dyn m (a, b) -> (Dyn m a, Dyn m b)+unTupleD x = (fmap fst x, fmap snd x)++unListD :: Frp m => Int -> Dyn m [a] -> [Dyn m a]+unListD n ds = fmap (\a -> fmap ( !! a) ds) [0.. pred n]++instance (HasNormal v, Frp m) => HasNormal (Dyn m v) where+  normalVec = fmap normalVec++instance (HasCross2 v, Frp m) => HasCross2 (Dyn m v) where+  cross2 = fmap cross2++instance (HasCross3 v, Frp m) => HasCross3 (Dyn m v) where+  cross3 = liftA2 cross3++--------------------------------------------------------------------------------+-- Temporal media instances++instance Frp m => Melody (Evt m a) where+  (+:+) evtA evtB = Evt $ \go -> do+      runEvt evtA go+      runEvt evtB go++instance Frp m => Harmony (Evt m a) where+  (=:=) = (<>)++instance Frp m => Compose (Evt m a) where++instance Frp m => Loop (Evt m a) where+  loop evt = Evt $ \go -> forever (runEvt evt go)++-- | Takes an event and repeats it all the time.+forevers :: Frp m => Evt m a -> Evt m a+forevers evt = Evt $ \go -> forever (runEvt evt go)++type instance DurOf (Evt m a) = NominalDiffTime++instance Frp m => Limit (Evt m a) where+  lim t evt = Evt $ \go ->+    race_ (runEvt evt go) (sleep t)++--------------------------------------------------------------------------------+-- Parser++data St a = Final a | Cont a+  deriving (Functor)++data Parser m a b = forall s . Parser+  { parser'init   :: s+  , parser'modify :: (a -> s -> m (Maybe (St s)))+  , parser'get    :: s -> m (Maybe b)+  }++runParser :: Frp m => Parser m a b -> Evt m a -> m (Maybe b)+runParser (Parser init modify get) evt = do+  ref <- proxyNewRef evt (Cont init)++  waitAsync $ do+    runEvt evt $ \x -> do+      st <- liftIO $ readRef ref+      case st of+        Final s -> stopSelf+        Cont s  -> do+          mS' <- modify x s+          forM_ mS' $ \case+            Cont s  -> liftIO $ writeRef ref (Cont s)+            Final s -> liftIO $ do+              writeRef ref (Final s)+              stopSelf++  st <- liftIO (readRef ref)+  case st of+    Final s -> get s+    _       -> pure Nothing++heads :: Frp m => Evt m a -> m a+heads evt = do+  ref <- proxyNewRef evt Nothing+  waitAsync $ do+    runEvt evt $ \x -> do+      liftIO $ writeRef ref (Just x)+      stopSelf+  fromJust <$> liftIO (readRef ref)++-- | Reads single event+takeP :: Frp m => Parser m a b -> Evt m a -> Evt m b+takeP (Parser init modify get) evt = Evt $ \go -> do+  ref <- proxyNewRef evt init+  waitAsync $ do+    runEvt evt $ \x -> do+      s <- liftIO $ readRef ref+      mS' <- modify x s+      forM_ mS' $ \case+        Cont s'  -> liftIO $ writeRef ref s'+        Final s' -> do+          mapM_ go =<< get s'+          stopSelf++cycleP :: Frp m => Parser m a b -> Evt m a -> Evt m b+cycleP (Parser init modify get) evt = Evt $ \go -> do+  ref <- proxyNewRef evt init+  waitAsync $ do+    runEvt evt $ \x -> do+      s <- liftIO $ readRef ref+      mS' <- modify x s+      forM_ mS' $ \case+        Cont s'  -> liftIO $ writeRef ref s'+        Final s' -> do+          mapM_ go =<< get s'+          liftIO $ writeRef ref init++-- | Takes first element of the event stream and shuts the stream down.+headP :: Frp m => Parser m a a+headP = Parser init modify get+  where+    init = Nothing+    modify a _ = pure $ Just (Final (Just a))+    get = pure++maybeP :: Frp m => (a -> Maybe b) -> Parser m a b+maybeP f = Parser init modify get+  where+    init = Nothing+    modify a _ = pure $ fmap (Final . Just) $ f a+    get = pure++instance Frp m => Functor (Parser m a) where+  fmap f (Parser init modify get) = Parser init modify (fmap (fmap f) . get)++instance Frp m => Applicative (Parser m a) where+  pure a = Parser () (\_ _ -> pure (Just (Final ()))) (const $ pure $ Just a)+  (Parser initF modifyF getF) <*> (Parser initA modifyA getA) = Parser initRes modifyRes getRes+    where+      initRes = (Cont initF, Cont initA)++      modifyRes inp (sf, sa) = case sf of+        Cont f -> do+          mF' <- modifyF inp f+          pure $ fmap (Cont . (, sa)) mF'+        Final f ->+          case sa of+            Cont a -> do+              mA' <- modifyA inp a+              pure $ flip fmap mA' $ \case+                  Cont a'  -> Cont (Final f, Cont a')+                  Final a' -> Final (Final f, Final a')+            Final a -> pure (Just (Final (sf, sa)))++      getRes = \case+        (Final f, Final a) -> do+          mf <- getF f+          ma <- getA a+          pure (mf <*> ma)+        _                  -> pure Nothing+++-- | Create a new Event and a function that will cause the Event to fire+newTriggerEvt :: (Frp m, MonadIO io) => m (Evt m a, a -> io ())+newTriggerEvt = do+  chan <- liftIO U.newChan+  pure (uchanEvt (fst chan), liftIO . U.writeChan (fst chan))+

+ src/Dyna/Ref.hs view

@@ -0,0 +1,26 @@+module Dyna.Ref(+  IsRef(..),+) where++import Data.IORef+import Control.Concurrent.STM+import Control.Concurrent.STM.TVar++class IsRef ref where+  newRef    :: a -> IO (ref a)+  readRef   :: ref a -> IO a+  writeRef  :: ref a -> a -> IO ()+  modifyRef :: ref a -> (a -> a) -> IO ()++instance IsRef IORef where+  newRef = newIORef+  readRef = readIORef+  writeRef = writeIORef+  modifyRef = modifyIORef'++instance IsRef TVar where+  newRef = newTVarIO+  readRef = readTVarIO+  writeRef ref v = atomically $ writeTVar ref v+  modifyRef ref f = atomically $ modifyTVar' ref f+

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"