packages feed

rhine 0.9 → 1.0

raw patch · 26 files changed

+468/−839 lines, 26 filesdep +monad-scheduledep +rhinedep +tasty

Dependencies added: monad-schedule, rhine, tasty, tasty-hunit

Files

ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for rhine +## 1.0++* Removed schedules. See the [page about changes in version 1](/version1.md).+ ## 0.9  * dunai-0.9 compatibility
rhine.cabal view
@@ -1,6 +1,8 @@+cabal-version:       2.2+ name:                rhine -version:             0.9+version:             1.0  synopsis: Functional Reactive Programming with type-level clocks @@ -21,7 +23,7 @@   @flow $ constMCl (putStrLn "Hello World!") \@\@ (waitClock :: Millisecond 100)@  -license:             BSD3+license:             BSD-3-Clause  license-file:        LICENSE @@ -37,8 +39,6 @@  extra-doc-files:     README.md -cabal-version:       2.0- tested-with:   GHC == 8.10.7   GHC == 9.0.2@@ -52,11 +52,37 @@ source-repository this   type:     git   location: https://github.com/turion/rhine.git-  tag:      v0.9+  tag:      v1.0 +common opts+  build-depends:+    , base         >= 4.14 && < 4.18+    , vector-sized >= 1.4++  if flag(dev)+    ghc-options: -Werror++  ghc-options:  -W+                -Wno-unticked-promoted-constructors++  default-extensions:+      DataKinds+    , FlexibleContexts+    , FlexibleInstances+    , MultiParamTypeClasses+    , NamedFieldPuns+    , NoStarIsType+    , TupleSections+    , TypeApplications+    , TypeFamilies+    , TypeOperators++  -- Base language which the package is written in.+  default-language:    Haskell2010+ library+  import: opts   exposed-modules:-    Control.Monad.Schedule     FRP.Rhine     FRP.Rhine.Clock     FRP.Rhine.Clock.FixedStep@@ -68,6 +94,7 @@     FRP.Rhine.Clock.Realtime.Millisecond     FRP.Rhine.Clock.Realtime.Stdin     FRP.Rhine.Clock.Select+    FRP.Rhine.Clock.Unschedule     FRP.Rhine.Clock.Util     FRP.Rhine.ClSF     FRP.Rhine.ClSF.Core@@ -89,8 +116,6 @@     FRP.Rhine.ResamplingBuffer.Timeless     FRP.Rhine.ResamplingBuffer.Util     FRP.Rhine.Schedule-    FRP.Rhine.Schedule.Concurrently-    FRP.Rhine.Schedule.Trans     FRP.Rhine.SN     FRP.Rhine.SN.Combinators     FRP.Rhine.Type@@ -98,41 +123,44 @@   other-modules:     FRP.Rhine.ClSF.Random.Util     FRP.Rhine.ClSF.Except.Util-    FRP.Rhine.Schedule.Util    -- LANGUAGE extensions used by modules in this package.   -- other-extensions:    -- Other library packages from which modules are imported.-  build-depends:       base         >= 4.14 && < 4.18+  build-depends:                      , dunai        ^>= 0.9                      , transformers >= 0.5                      , time         >= 1.8                      , free         >= 5.1                      , containers   >= 0.5-                     , vector-sized >= 1.4                      , deepseq      >= 1.4                      , random       >= 1.1                      , MonadRandom  >= 0.5                      -- Remove version pin when https://github.com/ivanperez-keera/dunai/issues/298 is resolved:                      , simple-affine-space == 0.1.1                      , time-domain+                     , monad-schedule >= 0.1.2    -- Directories containing source files.   hs-source-dirs:      src -  ghc-options:  -W-                -Wno-unticked-promoted-constructors--  if flag(dev)-    ghc-options: -Werror--  default-extensions:-      NoStarIsType-    , TypeOperators--  -- Base language which the package is written in.-  default-language:    Haskell2010+test-suite test+  import: opts+  hs-source-dirs:     test+  type:               exitcode-stdio-1.0+  main-is:            Main.hs+  other-modules:+    Clock+    Clock.FixedStep+    Clock.Millisecond+    Schedule+    Util+  build-depends:+    , rhine+    , monad-schedule+    , tasty ^>= 1.4+    , tasty-hunit ^>= 0.10  flag dev   description: Enable warnings as errors. Active on ci.
− src/Control/Monad/Schedule.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}--{- |-This module supplies a general purpose monad transformer-that adds a syntactical "delay", or "waiting" side effect.--This allows for universal and deterministic scheduling of clocks-that implement their waiting actions in 'ScheduleT'.-See 'FRP.Rhine.Schedule.Trans' for more details.--}-module Control.Monad.Schedule where---- base-import Control.Concurrent---- transformers-import Control.Monad.IO.Class---- free-import Control.Monad.Trans.Free---- TODO Implement Time via StateT--{- |-A functor implementing a syntactical "waiting" action.--* 'diff' represents the duration to wait.-* 'a' is the encapsulated value.--}-data Wait diff a = Wait diff a-  deriving (Functor)--{- |-Values in @ScheduleT diff m@ are delayed computations with side effects in 'm'.-Delays can occur between any two side effects, with lengths specified by a 'diff' value.-These delays don't have any semantics, it can be given to them with 'runScheduleT'.--}-type ScheduleT diff = FreeT (Wait diff)---- | The side effect that waits for a specified amount.-wait :: Monad m => diff -> ScheduleT diff m ()-wait diff = FreeT $ return $ Free $ Wait diff $ return ()--{- | Supply a semantic meaning to 'Wait'.-   For every occurrence of @Wait diff@ in the @ScheduleT diff m a@ value,-   a waiting action is executed, depending on 'diff'.--}-runScheduleT :: Monad m => (diff -> m ()) -> ScheduleT diff m a -> m a-runScheduleT waitAction = iterT $ \(Wait n ma) -> waitAction n >> ma--{- | Run a 'ScheduleT' value in a 'MonadIO',-   interpreting the times as milliseconds.--}-runScheduleIO ::-  (MonadIO m, Integral n) =>-  ScheduleT n m a ->-  m a-runScheduleIO = runScheduleT $ liftIO . threadDelay . (* 1000) . fromIntegral---- TODO The definition and type signature are both a mouthful. Is there a simpler concept?--{- | Runs two values in 'ScheduleT' concurrently-   and returns the first one that yields a value-   (defaulting to the first argument),-   and a continuation for the other value.--}-race ::-  (Ord diff, Num diff, Monad m) =>-  ScheduleT diff m a ->-  ScheduleT diff m b ->-  ScheduleT-    diff-    m-    ( Either-        (a, ScheduleT diff m b)-        (ScheduleT diff m a, b)-    )-race (FreeT ma) (FreeT mb) = FreeT $ do-  -- Perform the side effects to find out how long each 'ScheduleT' values need to wait.-  aWait <- ma-  bWait <- mb-  case aWait of-    -- 'a' doesn't need to wait. Return immediately and leave the continuation for 'b'.-    Pure a -> return $ Pure $ Left (a, FreeT $ return bWait)-    -- 'a' needs to wait, so we need to inspect 'b' as well and see which one needs to wait longer.-    Free (Wait aDiff aCont) -> case bWait of-      -- 'b' doesn't need to wait. Return immediately and leave the continuation for 'a'.-      Pure b -> return $ Pure $ Right (wait aDiff >> aCont, b)-      -- Both need to wait. Which one needs to wait longer?-      Free (Wait bDiff bCont) ->-        if aDiff <= bDiff-          then -- 'a' yields first, or both are done simultaneously.-          runFreeT $ do-            -- Perform the wait action that we've deconstructed-            wait aDiff-            -- Recurse, since more wait actions might be hidden in 'a' and 'b'. 'b' doesn't need to wait as long, since we've already waited for 'aDiff'.-            race aCont $ wait (bDiff - aDiff) >> bCont-          else -- 'b' yields first. Analogously.-          runFreeT $ do-            wait bDiff-            race (wait (aDiff - bDiff) >> aCont) bCont---- | Runs both schedules concurrently and returns their results at the end.-async ::-  (Ord diff, Num diff, Monad m) =>-  ScheduleT diff m a ->-  ScheduleT diff m b ->-  ScheduleT diff m (a, b)-async aSched bSched = do-  ab <- race aSched bSched-  case ab of-    Left (a, bCont) -> do-      b <- bCont-      return (a, b)-    Right (aCont, b) -> do-      a <- aCont-      return (a, b)
src/FRP/Rhine.hs view
@@ -1,11 +1,10 @@ {- | This module reexports most common names and combinators you will need to work with Rhine.-It does not export specific clocks, resampling buffers or schedules,-so you will have to import those yourself, e.g. like this:+It also exports most specific clocks and resampling buffers,+so you can import everything in one line:  @ import FRP.Rhine-import FRP.Rhine.Clock.Realtime.Millisecond  main :: IO () main = flow \$ constMCl (putStrLn \"Hello World!\") \@\@ (waitClock :: Millisecond 100)@@ -41,6 +40,7 @@ import FRP.Rhine.Clock.Realtime.Millisecond as X import FRP.Rhine.Clock.Realtime.Stdin as X import FRP.Rhine.Clock.Select as X+import FRP.Rhine.Clock.Unschedule as X  import FRP.Rhine.ResamplingBuffer.Collect as X import FRP.Rhine.ResamplingBuffer.FIFO as X@@ -49,7 +49,3 @@ import FRP.Rhine.ResamplingBuffer.LIFO as X import FRP.Rhine.ResamplingBuffer.MSF as X import FRP.Rhine.ResamplingBuffer.Timeless as X--import FRP.Rhine.Schedule.Concurrently as X-import FRP.Rhine.Schedule.Trans as X-import FRP.Rhine.Schedule.Util as X
src/FRP/Rhine/ClSF/Upsample.hs view
@@ -36,7 +36,7 @@   (Monad m, Time clL ~ Time clR) =>   b ->   ClSF m clR a b ->-  ClSF m (ParallelClock m clL clR) a b+  ClSF m (ParallelClock clL clR) a b upsampleR b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)   where     remap (TimeInfo {tag = Left tag}, _) = Left tag@@ -51,7 +51,7 @@   (Monad m, Time clL ~ Time clR) =>   b ->   ClSF m clL a b ->-  ClSF m (ParallelClock m clL clR) a b+  ClSF m (ParallelClock clL clR) a b upsampleL b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)   where     remap (TimeInfo {tag = Right tag}, _) = Left tag
src/FRP/Rhine/ClSF/Util.hs view
@@ -101,7 +101,7 @@ {- | Alias for 'Control.Category.>>>' (sequential composition) with higher operator precedence, designed to work with the other operators, e.g.: -> clsf1 >-> clsf2 @@ clA ||@ sched @|| clsf3 >-> clsf4 @@ clB+> clsf1 >-> clsf2 @@ clA |@| clsf3 >-> clsf4 @@ clB  The type signature specialises e.g. to
src/FRP/Rhine/Clock/FixedStep.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE Arrows #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -13,14 +12,16 @@ module FRP.Rhine.Clock.FixedStep where  -- base+import Data.Functor (($>)) import Data.Maybe (fromMaybe) import GHC.TypeLits  -- vector-sized import Data.Vector.Sized (Vector, fromList) --- dunai-import Data.MonadicStreamFunction.Async (concatS)+-- monad-schedule+import Control.Monad.Schedule.Class+import Control.Monad.Schedule.Trans (ScheduleT, wait)  -- rhine import FRP.Rhine.Clock@@ -28,7 +29,6 @@ import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Collect import FRP.Rhine.ResamplingBuffer.Util-import FRP.Rhine.Schedule  {- | A pure (side effect free) clock with fixed step size,    i.e. ticking at multiples of 'n'.@@ -42,53 +42,29 @@ stepsize :: FixedStep n -> Integer stepsize fixedStep@FixedStep = natVal fixedStep -instance Monad m => Clock m (FixedStep n) where+instance (MonadSchedule m, Monad m) => Clock (ScheduleT Integer m) (FixedStep n) where   type Time (FixedStep n) = Integer   type Tag (FixedStep n) = ()   initClock cl =-    return-      ( count-          >>> arr (* stepsize cl)-            &&& arr (const ())-      , 0-      )+    let step = stepsize cl+     in return+          ( arr (const step)+              >>> accumulateWith (+) 0+              >>> arrM (\time -> wait step $> (time, ()))+          , 0+          )  instance GetClockProxy (FixedStep n)  -- | A singleton clock that counts the ticks. type Count = FixedStep 1 --- | Two 'FixedStep' clocks can always be scheduled without side effects.-scheduleFixedStep ::-  Monad m =>-  Schedule m (FixedStep n1) (FixedStep n2)-scheduleFixedStep = Schedule f-  where-    f cl1 cl2 = return (msf, 0)-      where-        n1 = stepsize cl1-        n2 = stepsize cl2-        msf = concatS $ proc _ -> do-          k <- arr (+ 1) <<< count -< ()-          returnA-            -<-              [(k, Left ()) | k `mod` n1 == 0]-                ++ [(k, Right ()) | k `mod` n2 == 0]---- TODO The problem is that the schedule doesn't give a guarantee where in the n ticks of the first clock the second clock will tick.--- For this to work, it has to be the last.--- With scheduleFixedStep, this works,--- but the user might implement an incorrect schedule.+{- | Resample into a 'FixedStep' clock that ticks @n@ times slower,+  by collecting all values into a vector.+-} downsampleFixedStep ::   (KnownNat n, Monad m) =>   ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a (Vector n a) downsampleFixedStep = collect >>-^ arr (fromList >>> assumeSize)   where-    assumeSize =-      fromMaybe $-        error $-          unwords-            [ "You are using an incorrectly implemented schedule"-            , "for two FixedStep clocks."-            , "Use a correct schedule like downsampleFixedStep."-            ]+    assumeSize = fromMaybe $ error "downsampleFixedStep: Internal error. Please report this as a bug: https://github.com/turion/rhine/issues"
src/FRP/Rhine/Clock/Periodic.hs view
@@ -22,8 +22,10 @@ -- dunai import Data.MonadicStreamFunction +-- monad-schedule+import Control.Monad.Schedule.Trans+ -- rhine-import Control.Monad.Schedule import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy
src/FRP/Rhine/Clock/Proxy.hs view
@@ -22,11 +22,11 @@   SequentialProxy ::     ClockProxy cl1 ->     ClockProxy cl2 ->-    ClockProxy (SequentialClock m cl1 cl2)+    ClockProxy (SequentialClock cl1 cl2)   ParallelProxy ::     ClockProxy clL ->     ClockProxy clR ->-    ClockProxy (ParallelClock m clL clR)+    ClockProxy (ParallelClock clL clR)  inProxy :: ClockProxy cl -> ClockProxy (In cl) inProxy LeafProxy = LeafProxy@@ -69,10 +69,10 @@     ClockProxy cl   getClockProxy = LeafProxy -instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (SequentialClock m cl1 cl2) where+instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (SequentialClock cl1 cl2) where   getClockProxy = SequentialProxy getClockProxy getClockProxy -instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (ParallelClock m cl1 cl2) where+instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (ParallelClock cl1 cl2) where   getClockProxy = ParallelProxy getClockProxy getClockProxy  instance GetClockProxy cl => GetClockProxy (HoistClock m1 m2 cl)
src/FRP/Rhine/Clock/Realtime/Event.hs view
@@ -46,8 +46,6 @@ import FRP.Rhine.ClSF import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.Schedule-import FRP.Rhine.Schedule.Concurrently  -- * Monads allowing for event emission and handling @@ -135,7 +133,7 @@   ClSF (EventChanT event m) cl (Maybe event) () emitSMaybe' = mapMaybe emitS' >>> arr (const ()) --- * Event clocks and schedules+-- * Event clocks  {- | A clock that ticks whenever an @event@ is emitted.    It is not yet bound to a specific channel,@@ -178,24 +176,3 @@     { unhoistedClock = EventClock     , monadMorphism = withChan chan     }--{- |-Given two clocks with an 'EventChanT' layer directly atop the 'IO' monad,-you can schedule them using concurrent GHC threads,-and share the event channel.--Typical use cases:--* Different subevent selection clocks-  (implemented i.e. with 'FRP.Rhine.Clock.Select')-  on top of the same main event source.-* An event clock and other event-unaware clocks in the 'IO' monad,-  which are lifted using 'liftClock'.--}-concurrentlyWithEvents ::-  ( Time cl1 ~ Time cl2-  , Clock (EventChanT event IO) cl1-  , Clock (EventChanT event IO) cl2-  ) =>-  Schedule (EventChanT event IO) cl1 cl2-concurrentlyWithEvents = readerSchedule concurrently
src/FRP/Rhine/Clock/Realtime/Millisecond.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -9,6 +10,7 @@  -- base import Control.Concurrent (threadDelay)+import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Data.Time.Clock import GHC.TypeLits@@ -20,10 +22,10 @@ import FRP.Rhine.Clock import FRP.Rhine.Clock.FixedStep import FRP.Rhine.Clock.Proxy+import FRP.Rhine.Clock.Unschedule import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Collect import FRP.Rhine.ResamplingBuffer.Util-import FRP.Rhine.Schedule  {- | A clock ticking every 'n' milliseconds,@@ -36,7 +38,7 @@ where 'True' represents successful realtime, and 'False' a lag. -}-newtype Millisecond (n :: Nat) = Millisecond (RescaledClockS IO (FixedStep n) UTCTime Bool)+newtype Millisecond (n :: Nat) = Millisecond (RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool)  -- TODO Consider changing the tag to Maybe Double @@ -63,10 +65,10 @@    the wait time, up to no wait time at all, to catch up when a tick is missed. -} waitClock :: KnownNat n => Millisecond n-waitClock = Millisecond $ RescaledClockS FixedStep $ \_ -> do-  initTime <- getCurrentTime+waitClock = Millisecond $ RescaledClockS (unyieldClock FixedStep) $ \_ -> do+  initTime <- liftIO getCurrentTime   let-    runningClock = arrM $ \(n, ()) -> do+    runningClock = arrM $ \(n, ()) -> liftIO $ do       beforeSleep <- getCurrentTime       let         diff :: Double@@ -85,16 +87,4 @@   where     assumeSize =       fromMaybe $-        error $-          unwords-            [ "You are using an incorrectly implemented schedule"-            , "for two Millisecond clocks."-            , "Use a correct schedule like downsampleMillisecond."-            ]---- | Two 'Millisecond' clocks can always be scheduled deterministically.-scheduleMillisecond :: Schedule IO (Millisecond n1) (Millisecond n2)-scheduleMillisecond = Schedule initSchedule'-  where-    initSchedule' (Millisecond cl1) (Millisecond cl2) =-      initSchedule (rescaledScheduleS scheduleFixedStep) cl1 cl2+        error "downsampleMillisecond: Internal error. Please report this as a bug: https://github.com/turion/rhine/issues"
src/FRP/Rhine/Clock/Select.hs view
@@ -17,13 +17,12 @@ -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.Schedule  -- dunai import Data.MonadicStreamFunction.Async (concatS)  -- base-import Data.Maybe (catMaybes, maybeToList)+import Data.Maybe (maybeToList)  {- | A clock that selects certain subevents of type 'a',    from the tag of a main clock.@@ -66,50 +65,6 @@     return (runningSelectClock, initialTime)  instance GetClockProxy (SelectClock cl a)--{- | A universal schedule for two subclocks of the same main clock.-   The main clock must be a 'Semigroup' (e.g. a singleton).--}-schedSelectClocks ::-  (Monad m, Semigroup cl, Clock m cl) =>-  Schedule m (SelectClock cl a) (SelectClock cl b)-schedSelectClocks = Schedule {..}-  where-    initSchedule subClock1 subClock2 = do-      (runningClock, initialTime) <--        initClock $-          mainClock subClock1 <> mainClock subClock2-      let-        runningSelectClocks = concatS $ proc _ -> do-          (time, tag) <- runningClock -< ()-          returnA-            -<-              catMaybes-                [ (time,) . Left <$> select subClock1 tag-                , (time,) . Right <$> select subClock2 tag-                ]-      return (runningSelectClocks, initialTime)---- | A universal schedule for a subclock and its main clock.-schedSelectClockAndMain ::-  (Monad m, Semigroup cl, Clock m cl) =>-  Schedule m cl (SelectClock cl a)-schedSelectClockAndMain = Schedule {..}-  where-    initSchedule mainClock' SelectClock {..} = do-      (runningClock, initialTime) <--        initClock $-          mainClock' <> mainClock-      let-        runningSelectClock = concatS $ proc _ -> do-          (time, tag) <- runningClock -< ()-          returnA-            -<-              catMaybes-                [ Just (time, Left tag)-                , (time,) . Right <$> select tag-                ]-      return (runningSelectClock, initialTime)  {- | Helper function that runs an 'MSF' with 'Maybe' output    until it returns a value.
+ src/FRP/Rhine/Clock/Unschedule.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++-- | A clock that removes the 'ScheduleT' transformer from the stack by interpreting its actions in a monad+module FRP.Rhine.Clock.Unschedule where++-- base+import qualified Control.Concurrent as Concurrent (yield)+import Control.Monad.IO.Class++-- monad-schedule+import Control.Monad.Schedule.Trans++-- rhine+import FRP.Rhine.Clock++{- | If @cl@ is a 'Clock' in 'ScheduleT diff m', apply 'UnscheduleClock'+  to get a clock in 'm'.+-}+data UnscheduleClock m cl = UnscheduleClock+  { scheduleClock :: cl+  , scheduleWait :: Diff (Time cl) -> m ()+  }++-- The 'yield' action is interpreted as thread yielding in 'IO'.+unyieldClock :: cl -> UnscheduleClock IO cl+unyieldClock cl = UnscheduleClock cl $ const $ liftIO Concurrent.yield++instance (Clock (ScheduleT (Diff (Time cl)) m) cl, Monad m) => Clock m (UnscheduleClock m cl) where+  type Tag (UnscheduleClock _ cl) = Tag cl+  type Time (UnscheduleClock _ cl) = Time cl+  initClock UnscheduleClock {scheduleClock, scheduleWait} = run $ first (morphS run) <$> initClock scheduleClock+    where+      run :: ScheduleT (Diff (Time cl)) m a -> m a+      run = runScheduleT scheduleWait
src/FRP/Rhine/Reactimation/Combinators.hs view
@@ -45,44 +45,21 @@   Rhine m cl a b (@@) = Rhine . Synchronous -{- | A point at which sequential asynchronous composition-   ("resampling") of signal networks can happen.--}-data ResamplingPoint m cla clb a b-  = ResamplingPoint-      (ResamplingBuffer m (Out cla) (In clb) a b)-      (Schedule m cla clb)---- TODO Make a record out of it?--- TODO This is aesthetically displeasing.---      For the buffer, the associativity doesn't matter, but for the Schedule,---      we sometimes need to specify particular brackets in order for it to work.---      This is confusing.---      There would be a workaround if there were pullbacks of schedules...---- | Syntactic sugar for 'ResamplingPoint'.-infix 8 -@--(-@-) ::-  ResamplingBuffer m (Out cl1) (In cl2) a b ->-  Schedule         m      cl1      cl2      ->-  ResamplingPoint  m      cl1      cl2  a b-(-@-) = ResamplingPoint- {- | A purely syntactical convenience construction    enabling quadruple syntax for sequential composition, as described below. -} infix 2 >-- -data RhineAndResamplingPoint m cl1 cl2 a c+data RhineAndResamplingBuffer m cl1 inCl2 a c   = forall b.-    RhineAndResamplingPoint (Rhine m cl1 a b) (ResamplingPoint m cl1 cl2 b c)+    RhineAndResamplingBuffer (Rhine m cl1 a b) (ResamplingBuffer m (Out cl1) inCl2 b c) --- | Syntactic sugar for 'RhineAndResamplingPoint'.+-- | Syntactic sugar for 'RhineAndResamplingBuffer'. (>--) ::-  Rhine                   m cl1     a b   ->-  ResamplingPoint         m cl1 cl2   b c ->-  RhineAndResamplingPoint m cl1 cl2 a   c-(>--) = RhineAndResamplingPoint+  Rhine                    m      cl1        a b   ->+  ResamplingBuffer         m (Out cl1) inCl2   b c ->+  RhineAndResamplingBuffer m      cl1  inCl2 a   c+(>--) = RhineAndResamplingBuffer  {- | The combinators for sequential composition allow for the following syntax: @@ -96,11 +73,8 @@ rb    :: ResamplingBuffer m (Out cl1) (In cl2)   b c rb    =  ... -sched :: Schedule         m      cl1      cl2-sched =  ...--rh    :: Rhine m (SequentialClock m cl1   cl2) a     d-rh    =  rh1 >-- rb -@- sched --> rh2+rh    :: Rhine m (SequentialClock cl1 cl2) a d+rh    =  rh1 >-- rb --> rh2 @ -} infixr 1 -->@@ -112,45 +86,30 @@   , Time (In  cl2) ~ Time cl2   , Clock m (Out cl1), Clock m (Out cl2)   , Clock m (In  cl1), Clock m (In  cl2)+  , In cl2 ~ inCl2   , GetClockProxy cl1, GetClockProxy cl2   ) =>-  RhineAndResamplingPoint   m cl1 cl2  a b ->-  Rhine m                         cl2    b c ->-  Rhine m  (SequentialClock m cl1 cl2) a   c-RhineAndResamplingPoint (Rhine sn1 cl1) (ResamplingPoint rb cc) --> (Rhine sn2 cl2)- = Rhine (Sequential sn1 rb sn2) (SequentialClock cl1 cl2 cc)---- | A purely syntactical convenience construction---   allowing for ternary syntax for parallel composition, described below.-data RhineParallelAndSchedule m clL clR a b-  = RhineParallelAndSchedule (Rhine m clL a b) (Schedule m clL clR)---- | Syntactic sugar for 'RhineParallelAndSchedule'.-infix 4 ++@-(++@) ::-  Rhine                    m clL     a b ->-  Schedule                 m clL clR     ->-  RhineParallelAndSchedule m clL clR a b-(++@) = RhineParallelAndSchedule+  RhineAndResamplingBuffer m cl1 inCl2 a b ->+  Rhine m cl2 b c ->+  Rhine m (SequentialClock cl1 cl2) a c+RhineAndResamplingBuffer (Rhine sn1 cl1) rb --> (Rhine sn2 cl2) =+  Rhine (Sequential sn1 rb sn2) (SequentialClock cl1 cl2)  {- | The combinators for parallel composition allow for the following syntax:  @-rh1   :: Rhine    m                clL      a         b+rh1   :: Rhine m                clL      a         b rh1   =  ... -rh2   :: Rhine    m                    clR  a           c+rh2   :: Rhine m                    clR  a           c rh2   =  ... -sched :: Schedule m                clL clR-sched =  ...--rh    :: Rhine    m (ParallelClock clL clR) a (Either b c)-rh    =  rh1 ++\@ sched \@++ rh2+rh    :: Rhine m (ParallelClock clL clR) a (Either b c)+rh    =  rh1 +\@+ rh2 @ -}-infix 3 @++-(@++) ::+infix 3 +@++(+@+) ::   ( Monad m, Clock m clL, Clock m clR   , Clock m (Out clL), Clock m (Out clR)   , GetClockProxy clL, GetClockProxy clR@@ -158,51 +117,46 @@   , Time clL ~ Time (In  clL), Time clR ~ Time (In  clR)   , Time clL ~ Time clR   ) =>-  RhineParallelAndSchedule m clL clR  a         b    ->-  Rhine                    m     clR  a            c ->-  Rhine m (ParallelClock   m clL clR) a (Either b c)-RhineParallelAndSchedule (Rhine sn1 clL) schedule @++ (Rhine sn2 clR)-  = Rhine (sn1 ++++ sn2) (ParallelClock clL clR schedule)---- | Further syntactic sugar for 'RhineParallelAndSchedule'.-infix 4 ||@-(||@) ::-  Rhine                    m clL     a b ->-  Schedule                 m clL clR     ->-  RhineParallelAndSchedule m clL clR a b-(||@) = RhineParallelAndSchedule+  Rhine m                clL      a         b ->+  Rhine m                    clR  a           c ->+  Rhine m (ParallelClock clL clR) a (Either b c)+Rhine sn1 clL +@+ Rhine sn2 clR =+  Rhine (sn1 ++++ sn2) (ParallelClock clL clR)  {- | The combinators for parallel composition allow for the following syntax:  @-rh1   :: Rhine    m                clL      a b+rh1   :: Rhine m                clL      a b rh1   =  ... -rh2   :: Rhine    m                    clR  a b+rh2   :: Rhine m                    clR  a b rh2   =  ... -sched :: Schedule m                clL clR-sched =  ...--rh    :: Rhine    m (ParallelClock clL clR) a b-rh    =  rh1 ||\@ sched \@|| rh2+rh    :: Rhine m (ParallelClock clL clR) a b+rh    =  rh1 |\@| rh2 @ -}-infix 3 @||-(@||) ::-  ( Monad m, Clock m clL, Clock m clR-  , Clock m (Out clL), Clock m (Out clR)-  , GetClockProxy clL, GetClockProxy clR-  , Time clL ~ Time (Out clL), Time clR ~ Time (Out clR)-  , Time clL ~ Time (In  clL), Time clR ~ Time (In  clR)+infix 3 |@|++(|@|) ::+  ( Monad m+  , Clock m clL+  , Clock m clR+  , Clock m (Out clL)+  , Clock m (Out clR)+  , GetClockProxy clL+  , GetClockProxy clR+  , Time clL ~ Time (Out clL)+  , Time clR ~ Time (Out clR)+  , Time clL ~ Time (In clL)+  , Time clR ~ Time (In clR)   , Time clL ~ Time clR   ) =>-  RhineParallelAndSchedule m clL clR  a b ->-  Rhine                    m     clR  a b ->-  Rhine m (ParallelClock   m clL clR) a b-RhineParallelAndSchedule (Rhine sn1 clL) schedule @|| (Rhine sn2 clR)-  = Rhine (sn1 |||| sn2) (ParallelClock clL clR schedule)-+  Rhine m                clL      a b ->+  Rhine m                    clR  a b ->+  Rhine m (ParallelClock clL clR) a b+Rhine sn1 clL |@| Rhine sn2 clR =+  Rhine (sn1 |||| sn2) (ParallelClock clL clR)  -- | Postcompose a 'Rhine' with a pure function. (@>>^) ::
src/FRP/Rhine/SN.hs view
@@ -55,7 +55,7 @@     SN               m      clab            a b     ->     ResamplingBuffer m (Out clab) (In clcd)   b c   ->     SN               m                clcd      c d ->-    SN m (SequentialClock m clab      clcd) a     d+    SN m (SequentialClock   clab      clcd) a     d    -- | Two 'SN's with the same input and output data may be parallely composed.   Parallel ::@@ -70,7 +70,7 @@     ) =>     SN m                  cl1      a b ->     SN m                      cl2  a b ->-    SN m (ParallelClock m cl1 cl2) a b+    SN m (ParallelClock   cl1 cl2) a b    -- | Bypass the signal network by forwarding data in parallel through a 'ResamplingBuffer'.   FirstResampling ::
src/FRP/Rhine/SN/Combinators.hs view
@@ -94,7 +94,7 @@ Sequential {} **** Synchronous _ = error "Impossible pattern: Sequential {} **** Synchronous _"  -- | Compose two signal networks on different clocks in clock-parallel.---   At one tick of @ParClock m cl1 cl2@, one of the networks is stepped,+--   At one tick of @ParClock cl1 cl2@, one of the networks is stepped, --   dependent on which constituent clock has ticked. -- --   Note: This is essentially an infix synonym of 'Parallel'@@ -108,11 +108,11 @@      )   => SN m             clL      a b   -> SN m                 clR  a b-  -> SN m (ParClock m clL clR) a b+  -> SN m (ParClock clL clR) a b (||||) = Parallel  -- | Compose two signal networks on different clocks in clock-parallel.---   At one tick of @ParClock m cl1 cl2@, one of the networks is stepped,+--   At one tick of @ParClock cl1 cl2@, one of the networks is stepped, --   dependent on which constituent clock has ticked. (++++)   :: ( Monad m, Clock m clL, Clock m clR@@ -124,5 +124,5 @@      )   => SN m             clL      a         b   -> SN m                 clR  a           c-  -> SN m (ParClock m clL clR) a (Either b c)+  -> SN m (ParClock clL clR) a (Either b c) snL ++++ snR = (snL >>>^ Left) |||| (snR >>>^ Right)
src/FRP/Rhine/Schedule.hs view
@@ -1,137 +1,87 @@-{-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}  {- |-'Schedule's are the compatibility mechanism between two different clocks.-A schedule' implements the the universal clocks such that those two given clocks-are its subclocks.--This module defines the 'Schedule' type and certain general constructions of schedules,-such as lifting along monad morphisms or time domain morphisms.-It also supplies (sequential and parallel) compositions of clocks.--Specific implementations of schedules are found in submodules.+The 'MonadSchedule' class from the @monad-schedule@ package is the compatibility mechanism between two different clocks.+It implements a concurrency abstraction that allows the clocks to run at the same time, independently.+Several such clocks running together form composite clocks, such as 'ParallelClock' and 'SequentialClock'.+This module defines these composite clocks,+and utilities to work with them. -} module FRP.Rhine.Schedule where --- transformers-import Control.Monad.Trans.Reader+-- base+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N  -- dunai import Data.MonadicStreamFunction+import Data.MonadicStreamFunction.Async (concatS)+import Data.MonadicStreamFunction.InternalCore +-- monad-schedule+import Control.Monad.Schedule.Class+ -- rhine import FRP.Rhine.Clock-import FRP.Rhine.Schedule.Util --- * The schedule type--{- | A schedule implements a combination of two clocks.-   It outputs a time stamp and an 'Either' value,-   which specifies which of the two subclocks has ticked.--}-data Schedule m cl1 cl2 = (Time cl1 ~ Time cl2) =>-  Schedule-  { initSchedule ::-      cl1 ->-      cl2 ->-      RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))-  }---- The type constraint in the constructor is actually useful when pattern matching on 'Schedule',--- which is interesting since a constraint like 'Monad m' is useful.--- When reformulating as a GADT, it might get used,--- but that would mean that we can't use record syntax.---- * Utilities to create new schedules from existing ones---- | Lift a schedule along a monad morphism.-hoistSchedule ::-  (Monad m1, Monad m2) =>-  (forall a. m1 a -> m2 a) ->-  Schedule m1 cl1 cl2 ->-  Schedule m2 cl1 cl2-hoistSchedule hoist Schedule {..} = Schedule initSchedule'-  where-    initSchedule' cl1 cl2 =-      hoist $-        first (hoistMSF hoist) <$> initSchedule cl1 cl2-    -- TODO This should be a dunai issue-    hoistMSF = morphS---- | Swaps the clocks for a given schedule.-flipSchedule ::-  Monad m =>-  Schedule m cl1 cl2 ->-  Schedule m cl2 cl1-flipSchedule Schedule {..} = Schedule initSchedule_-  where-    initSchedule_ cl2 cl1 = first (arr (second swapEither) <<<) <$> initSchedule cl1 cl2---- TODO I originally wanted to rescale a schedule and its clocks at the same time.--- That's rescaleSequentialClock.--{- | If a schedule works for two clocks, a rescaling of the clocks-   also applies to the schedule.--}-rescaledSchedule ::-  Monad m =>-  Schedule m cl1 cl2 ->-  Schedule m (RescaledClock cl1 time) (RescaledClock cl2 time)-rescaledSchedule schedule = Schedule initSchedule'-  where-    initSchedule' cl1 cl2 = initSchedule (rescaledScheduleS schedule) (rescaledClockToS cl1) (rescaledClockToS cl2)+-- * Scheduling --- | As 'rescaledSchedule', with a stateful rescaling-rescaledScheduleS ::-  Monad m =>-  Schedule m cl1 cl2 ->-  Schedule m (RescaledClockS m cl1 time tag1) (RescaledClockS m cl2 time tag2)-rescaledScheduleS Schedule {..} = Schedule initSchedule'+scheduleList :: (Monad m, MonadSchedule m) => NonEmpty (MSF m a b) -> MSF m a (NonEmpty b)+scheduleList msfs = scheduleList' msfs []   where-    initSchedule' (RescaledClockS cl1 rescaleS1) (RescaledClockS cl2 rescaleS2) = do-      (runningSchedule, initTime) <- initSchedule cl1 cl2-      (rescaling1, initTime') <- rescaleS1 initTime-      (rescaling2, _) <- rescaleS2 initTime-      let runningSchedule' =-            runningSchedule >>> proc (time, tag12) -> case tag12 of-              Left tag1 -> do-                (time', tag1') <- rescaling1 -< (time, tag1)-                returnA -< (time', Left tag1')-              Right tag2 -> do-                (time', tag2') <- rescaling2 -< (time, tag2)-                returnA -< (time', Right tag2')-      return (runningSchedule', initTime')---- TODO What's the most general way we can lift a schedule this way?+    scheduleList' msfs running = MSF $ \a -> do+      let bsAndConts = flip unMSF a <$> msfs+      (done, running) <- schedule (N.head bsAndConts :| N.tail bsAndConts ++ running)+      let (bs, dones) = N.unzip done+      return (bs, scheduleList' dones running) -{- | Lifts a schedule into the 'ReaderT' transformer,-   supplying the same environment to its scheduled clocks.+{- | Two clocks in the 'ScheduleT' monad transformer+  can always be canonically scheduled.+  Indeed, this is the purpose for which 'ScheduleT' was defined. -}-readerSchedule ::+runningSchedule ::   ( Monad m-  , Clock (ReaderT r m) cl1-  , Clock (ReaderT r m) cl2+  , MonadSchedule m+  , Clock m cl1+  , Clock m cl2   , Time cl1 ~ Time cl2   ) =>-  Schedule-    m-    (HoistClock (ReaderT r m) m cl1)-    (HoistClock (ReaderT r m) m cl2) ->-  Schedule (ReaderT r m) cl1 cl2-readerSchedule Schedule {..} =-  Schedule $ \cl1 cl2 -> ReaderT $ \r ->-    first liftTransS-      <$> initSchedule-        (HoistClock cl1 $ flip runReaderT r)-        (HoistClock cl2 $ flip runReaderT r)+  cl1 ->+  cl2 ->+  RunningClock m (Time cl1) (Tag cl1) ->+  RunningClock m (Time cl2) (Tag cl2) ->+  RunningClock m (Time cl1) (Either (Tag cl1) (Tag cl2))+runningSchedule _ _ rc1 rc2 = concatS $ scheduleList [rc1 >>> arr (second Left), rc2 >>> arr (second Right)] >>> arr N.toList +{- | A schedule implements a combination of two clocks.+   It outputs a time stamp and an 'Either' value,+   which specifies which of the two subclocks has ticked.+-}+initSchedule ::+  ( Time cl1 ~ Time cl2+  , Monad m+  , MonadSchedule m+  , Clock m cl1+  , Clock m cl2+  ) =>+  cl1 ->+  cl2 ->+  RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))+initSchedule cl1 cl2 = do+  (runningClock1, initTime) <- initClock cl1+  (runningClock2, _) <- initClock cl2+  return+    ( runningSchedule cl1 cl2 runningClock1 runningClock2+    , initTime+    )+ -- * Composite clocks  -- ** Sequentially combined clocks@@ -139,129 +89,59 @@ {- | Two clocks can be combined with a schedule as a clock    for an asynchronous sequential composition of signal networks. -}-data SequentialClock m cl1 cl2 = Time cl1 ~ Time cl2 =>+data SequentialClock cl1 cl2 = Time cl1 ~ Time cl2 =>   SequentialClock   { sequentialCl1 :: cl1   , sequentialCl2 :: cl2-  , sequentialSchedule :: Schedule m cl1 cl2   }  -- | Abbrevation synonym.-type SeqClock m cl1 cl2 = SequentialClock m cl1 cl2+type SeqClock cl1 cl2 = SequentialClock cl1 cl2  instance-  (Monad m, Clock m cl1, Clock m cl2) =>-  Clock m (SequentialClock m cl1 cl2)+  (Monad m, MonadSchedule m, Clock m cl1, Clock m cl2) =>+  Clock m (SequentialClock cl1 cl2)   where-  type Time (SequentialClock m cl1 cl2) = Time cl1-  type Tag (SequentialClock m cl1 cl2) = Either (Tag cl1) (Tag cl2)+  type Time (SequentialClock cl1 cl2) = Time cl1+  type Tag (SequentialClock cl1 cl2) = Either (Tag cl1) (Tag cl2)   initClock SequentialClock {..} =-    initSchedule sequentialSchedule sequentialCl1 sequentialCl2--{- | @cl1@ is a subclock of @SequentialClock m cl1 cl2@,-   therefore it is always possible to schedule these two clocks deterministically.-   The left subclock of the combined clock always ticks instantly after @cl1@.--}-schedSeq1 :: (Monad m, Semigroup cl1) => Schedule m cl1 (SequentialClock m cl1 cl2)-schedSeq1 = Schedule $ \cl1 SequentialClock {sequentialSchedule = Schedule {..}, ..} -> do-  (runningClock, initTime) <- initSchedule (cl1 <> sequentialCl1) sequentialCl2-  return (duplicateSubtick runningClock, initTime)--{- | As 'schedSeq1', but for the right subclock.-   The right subclock of the combined clock always ticks instantly before @cl2@.--}-schedSeq2 :: (Monad m, Semigroup cl2, Time cl1 ~ Time cl2) => Schedule m (SequentialClock m cl1 cl2) cl2-schedSeq2 = Schedule $ \SequentialClock {sequentialSchedule = Schedule {..}, ..} cl2 -> do-  (runningClock, initTime) <- initSchedule sequentialCl1 (sequentialCl2 <> cl2)-  return (duplicateSubtick (runningClock >>> second (arr swapEither)) >>> second (arr remap), initTime)-  where-    remap (Left tag2) = Left $ Right tag2-    remap (Right (Left tag2)) = Right tag2-    remap (Right (Right tag1)) = Left $ Left tag1---- TODO Why did I need the constraint on the time domains here, but not in schedSeq1?---      Same for schedPar2+    initSchedule sequentialCl1 sequentialCl2  -- ** Parallelly combined clocks  {- | Two clocks can be combined with a schedule as a clock    for an asynchronous parallel composition of signal networks. -}-data ParallelClock m cl1 cl2 = Time cl1 ~ Time cl2 =>+data ParallelClock cl1 cl2 = Time cl1 ~ Time cl2 =>   ParallelClock   { parallelCl1 :: cl1   , parallelCl2 :: cl2-  , parallelSchedule :: Schedule m cl1 cl2   }  -- | Abbrevation synonym.-type ParClock m cl1 cl2 = ParallelClock m cl1 cl2+type ParClock cl1 cl2 = ParallelClock cl1 cl2  instance-  (Monad m, Clock m cl1, Clock m cl2) =>-  Clock m (ParallelClock m cl1 cl2)+  (Monad m, MonadSchedule m, Clock m cl1, Clock m cl2) =>+  Clock m (ParallelClock cl1 cl2)   where-  type Time (ParallelClock m cl1 cl2) = Time cl1-  type Tag (ParallelClock m cl1 cl2) = Either (Tag cl1) (Tag cl2)+  type Time (ParallelClock cl1 cl2) = Time cl1+  type Tag (ParallelClock cl1 cl2) = Either (Tag cl1) (Tag cl2)   initClock ParallelClock {..} =-    initSchedule parallelSchedule parallelCl1 parallelCl2--{- | Like 'schedSeq1', but for parallel clocks.-   The left subclock of the combined clock always ticks instantly after @cl1@.--}-schedPar1 :: (Monad m, Semigroup cl1) => Schedule m cl1 (ParallelClock m cl1 cl2)-schedPar1 = Schedule $ \cl1 ParallelClock {parallelSchedule = Schedule {..}, ..} -> do-  (runningClock, initTime) <- initSchedule (cl1 <> parallelCl1) parallelCl2-  return (duplicateSubtick runningClock, initTime)--{- | Like 'schedPar1',-   but the left subclock of the combined clock always ticks instantly /before/ @cl1@.--}-schedPar1' :: (Monad m, Semigroup cl1) => Schedule m cl1 (ParallelClock m cl1 cl2)-schedPar1' = Schedule $ \cl1 ParallelClock {parallelSchedule = Schedule {..}, ..} -> do-  (runningClock, initTime) <- initSchedule (parallelCl1 <> cl1) parallelCl2-  return (duplicateSubtick runningClock >>> arr (second remap), initTime)-  where-    remap (Left tag1) = Right $ Left tag1-    remap (Right (Left tag1)) = Left tag1-    remap tag = tag--{- | Like 'schedPar1', but for the right subclock.-   The right subclock of the combined clock always ticks instantly before @cl2@.--}-schedPar2 :: (Monad m, Semigroup cl2, Time cl1 ~ Time cl2) => Schedule m (ParallelClock m cl1 cl2) cl2-schedPar2 = Schedule $ \ParallelClock {parallelSchedule = Schedule {..}, ..} cl2 -> do-  (runningClock, initTime) <- initSchedule parallelCl1 (parallelCl2 <> cl2)-  return (duplicateSubtick (runningClock >>> second (arr swapEither)) >>> second (arr remap), initTime)-  where-    remap (Left tag2) = Left $ Right tag2-    remap (Right (Left tag2)) = Right tag2-    remap (Right (Right tag1)) = Left $ Left tag1--{- | Like 'schedPar1',-   but the right subclock of the combined clock always ticks instantly /after/ @cl2@.--}-schedPar2' :: (Monad m, Semigroup cl2, Time cl1 ~ Time cl2) => Schedule m (ParallelClock m cl1 cl2) cl2-schedPar2' = Schedule $ \ParallelClock {parallelSchedule = Schedule {..}, ..} cl2 -> do-  (runningClock, initTime) <- initSchedule parallelCl1 (parallelCl2 <> cl2)-  return (duplicateSubtick (runningClock >>> second (arr swapEither)) >>> second (arr remap), initTime)-  where-    remap (Left tag2) = Right tag2-    remap (Right (Left tag2)) = Left $ Right tag2-    remap (Right (Right tag1)) = Left $ Left tag1+    initSchedule parallelCl1 parallelCl2  -- * Navigating the clock tree  -- | The clock that represents the rate at which data enters the system. type family In cl where-  In (SequentialClock m cl1 cl2) = In cl1-  In (ParallelClock m cl1 cl2) = ParallelClock m (In cl1) (In cl2)+  In (SequentialClock cl1 cl2) = In cl1+  In (ParallelClock cl1 cl2) = ParallelClock (In cl1) (In cl2)   In cl = cl  -- | The clock that represents the rate at which data leaves the system. type family Out cl where-  Out (SequentialClock m cl1 cl2) = Out cl2-  Out (ParallelClock m cl1 cl2) = ParallelClock m (Out cl1) (Out cl2)+  Out (SequentialClock cl1 cl2) = Out cl2+  Out (ParallelClock cl1 cl2) = ParallelClock (Out cl1) (Out cl2)   Out cl = cl  {- | A tree representing possible last times to which@@ -271,20 +151,20 @@   SequentialLastTime ::     LastTime cl1 ->     LastTime cl2 ->-    LastTime (SequentialClock m cl1 cl2)+    LastTime (SequentialClock cl1 cl2)   ParallelLastTime ::     LastTime cl1 ->     LastTime cl2 ->-    LastTime (ParallelClock m cl1 cl2)+    LastTime (ParallelClock cl1 cl2)   LeafLastTime :: Time cl -> LastTime cl  -- | An inclusion of a clock into a tree of parallel compositions of clocks. data ParClockInclusion clS cl where   ParClockInL ::-    ParClockInclusion (ParallelClock m clL clR) cl ->+    ParClockInclusion (ParallelClock clL clR) cl ->     ParClockInclusion clL cl   ParClockInR ::-    ParClockInclusion (ParallelClock m clL clR) cl ->+    ParClockInclusion (ParallelClock clL clR) cl ->     ParClockInclusion clR cl   ParClockRefl :: ParClockInclusion cl cl
− src/FRP/Rhine/Schedule/Concurrently.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--{- |-Many clocks tick at nondeterministic times-(such as event sources),-and it is thus impossible to schedule them deterministically-with most other clocks.-Using concurrency, they can still be scheduled with all clocks in 'IO',-by running the clocks in separate threads.--}-module FRP.Rhine.Schedule.Concurrently where---- base-import Control.Concurrent-import Control.Monad (void)-import Data.IORef---- transformers-import Control.Monad.Trans.Class---- dunai-import Control.Monad.Trans.MSF.Except-import Control.Monad.Trans.MSF.Maybe-import Control.Monad.Trans.MSF.Writer---- rhine-import FRP.Rhine.Clock-import FRP.Rhine.Schedule--{- | Runs two clocks in separate GHC threads-   and collects the results in the foreground thread.-   Caution: The data processing will still happen in the same thread-   (since data processing and scheduling are separated concerns).--}-concurrently ::-  ( Clock IO cl1-  , Clock IO cl2-  , Time cl1 ~ Time cl2-  ) =>-  Schedule IO cl1 cl2-concurrently = Schedule $ \cl1 cl2 -> do-  iMVar <- newEmptyMVar-  mvar <- newEmptyMVar-  _ <- launchSubthread cl1 Left iMVar mvar-  _ <- launchSubthread cl2 Right iMVar mvar-  initTime <- takeMVar iMVar -- The first clock to be initialised sets the first time stamp-  _ <- takeMVar iMVar -- Initialise the second clock-  return (constM $ takeMVar mvar, initTime)-  where-    launchSubthread cl leftright iMVar mvar = forkIO $ do-      (runningClock, initTime) <- initClock cl-      putMVar iMVar initTime-      reactimate $ runningClock >>> second (arr leftright) >>> arrM (putMVar mvar)---- TODO These threads can't be killed from outside easily since we've lost their ids--- => make a MaybeT or ExceptT variant---- TODO Test whether signal networks also share the writer and except effects correctly with these schedules--{- | As 'concurrently', but in the @WriterT w IO@ monad.-   Both background threads share a joint variable with the foreground-   to which the writer effect writes.--}-concurrentlyWriter ::-  ( Monoid w-  , Clock (WriterT w IO) cl1-  , Clock (WriterT w IO) cl2-  , Time cl1 ~ Time cl2-  ) =>-  Schedule (WriterT w IO) cl1 cl2-concurrentlyWriter = Schedule $ \cl1 cl2 -> do-  iMVar <- lift newEmptyMVar-  mvar <- lift newEmptyMVar-  _ <- launchSubthread cl1 Left iMVar mvar-  _ <- launchSubthread cl2 Right iMVar mvar-  -- The first clock to be initialised sets the first time stamp-  (initTime, w1) <- lift $ takeMVar iMVar-  -- Initialise the second clock-  (_, w2) <- lift $ takeMVar iMVar-  tell w1-  tell w2-  return (constM (WriterT $ takeMVar mvar), initTime)-  where-    launchSubthread cl leftright iMVar mvar = lift $ forkIO $ do-      ((runningClock, initTime), w) <- runWriterT $ initClock cl-      putMVar iMVar (initTime, w)-      reactimate $-        runWriterS runningClock >>> proc (w', (time, tag_)) ->-          arrM (putMVar mvar) -< ((time, leftright tag_), w')--{- | Schedule in the @ExceptT e IO@ monad.-   Whenever one clock encounters an exception in 'ExceptT',-   this exception is thrown in the other clock's 'ExceptT' layer as well,-   and in the schedule's (i.e. in the main clock's) thread.--}-concurrentlyExcept ::-  ( Clock (ExceptT e IO) cl1-  , Clock (ExceptT e IO) cl2-  , Time cl1 ~ Time cl2-  ) =>-  Schedule (ExceptT e IO) cl1 cl2-concurrentlyExcept = Schedule $ \cl1 cl2 -> do-  (iMVar, mvar, errorref) <- lift $ do-    iMVar <- newEmptyMVar -- The initialisation time is transferred over this variable. It's written to twice.-    mvar <- newEmptyMVar -- The ticks and exceptions are transferred over this variable. It receives two 'Left' values in total.-    errorref <- newIORef Nothing -- Used to broadcast the exception to both clocks-    _ <- launchSubThread cl1 Left iMVar mvar errorref-    _ <- launchSubThread cl2 Right iMVar mvar errorref-    return (iMVar, mvar, errorref)-  catchAndDrain mvar $ do-    initTime <- ExceptT $ takeMVar iMVar -- The first clock to be initialised sets the first time stamp-    _ <- ExceptT $ takeMVar iMVar -- Initialise the second clock-    let runningSchedule = constM $ do-          eTick <- lift $ takeMVar mvar-          case eTick of-            Right tick -> return tick-            Left e -> do-              lift $ writeIORef errorref $ Just e -- Broadcast the exception to both clocks-              throwE e-    return (runningSchedule, initTime)-  where-    launchSubThread cl leftright iMVar mvar errorref = forkIO $ do-      initialised <- runExceptT $ initClock cl-      case initialised of-        Right (runningClock, initTime) -> do-          putMVar iMVar $ Right initTime-          Left e <--            runExceptT $-              reactimate $-                runningClock >>> proc (td, tag2) -> do-                  arrM (lift . putMVar mvar) -< Right (td, leftright tag2)-                  me <- constM (lift $ readIORef errorref) -< ()-                  _ <- throwMaybe -< me-                  returnA -< ()-          putMVar mvar $ Left e -- Either throw own exception or acknowledge the exception from the other clock-        Left e -> void $ putMVar iMVar $ Left e-    catchAndDrain mvar initScheduleAction = catchE initScheduleAction $ \e -> do-      _ <- reactimate $ constM (ExceptT $ takeMVar mvar) >>> arr (const ()) -- Drain the mvar until the other clock acknowledges the exception-      throwE e---- | As 'concurrentlyExcept', with a single possible exception value.-concurrentlyMaybe ::-  ( Clock (MaybeT IO) cl1-  , Clock (MaybeT IO) cl2-  , Time cl1 ~ Time cl2-  ) =>-  Schedule (MaybeT IO) cl1 cl2-concurrentlyMaybe = Schedule $ \cl1 cl2 ->-  initSchedule-    (hoistSchedule exceptTIOToMaybeTIO concurrentlyExcept)-    (HoistClock cl1 maybeTIOToExceptTIO)-    (HoistClock cl2 maybeTIOToExceptTIO)-  where-    exceptTIOToMaybeTIO :: ExceptT () IO a -> MaybeT IO a-    exceptTIOToMaybeTIO = exceptToMaybeT-    maybeTIOToExceptTIO :: MaybeT IO a -> ExceptT () IO a-    maybeTIOToExceptTIO = maybeToExceptT ()
− src/FRP/Rhine/Schedule/Trans.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}--{- |-Clocks implemented in the 'ScheduleT' monad transformer-can always be scheduled (by construction).--}-module FRP.Rhine.Schedule.Trans where---- dunai-import Data.MonadicStreamFunction.InternalCore---- rhine-import Control.Monad.Schedule-import FRP.Rhine.Clock-import FRP.Rhine.Schedule---- * Universal schedule for the 'ScheduleT' monad transformer--{- | Two clocks in the 'ScheduleT' monad transformer-   can always be canonically scheduled.-   Indeed, this is the purpose for which 'ScheduleT' was defined.--}-schedule ::-  ( Monad m-  , Clock (ScheduleT (Diff (Time cl1)) m) cl1-  , Clock (ScheduleT (Diff (Time cl1)) m) cl2-  , Time cl1 ~ Time cl2-  , Ord (Diff (Time cl1))-  , Num (Diff (Time cl1))-  ) =>-  Schedule (ScheduleT (Diff (Time cl1)) m) cl1 cl2-schedule = Schedule {..}-  where-    initSchedule cl1 cl2 = do-      (runningClock1, initTime) <- initClock cl1-      (runningClock2, _) <- initClock cl2-      return-        ( runningSchedule cl1 cl2 runningClock1 runningClock2-        , initTime-        )--    -- Combines the two individual running clocks to one running clock.-    runningSchedule ::-      ( Monad m-      , Clock (ScheduleT (Diff (Time cl1)) m) cl1-      , Clock (ScheduleT (Diff (Time cl2)) m) cl2-      , Time cl1 ~ Time cl2-      , Ord (Diff (Time cl1))-      , Num (Diff (Time cl1))-      ) =>-      cl1 ->-      cl2 ->-      MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1) ->-      MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2) ->-      MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Either (Tag cl1) (Tag cl2))-    runningSchedule cl1 cl2 rc1 rc2 = MSF $ \_ -> do-      -- Race both clocks against each other-      raceResult <- race (unMSF rc1 ()) (unMSF rc2 ())-      case raceResult of-        -- The first clock ticks first...-        Left (((time, tag1), rc1'), cont2) ->-          return-            -- so we can emit its time stamp...-            ( (time, Left tag1)-            , -- and continue.-              runningSchedule cl1 cl2 rc1' (MSF $ const cont2)-            )-        -- The second clock ticks first...-        Right (cont1, ((time, tag2), rc2')) ->-          return-            -- so we can emit its time stamp...-            ( (time, Right tag2)-            , -- and continue.-              runningSchedule cl1 cl2 (MSF $ const cont1) rc2'-            )
− src/FRP/Rhine/Schedule/Util.hs 
@@ -1,20 +0,0 @@--- | Utility to define certain deterministic schedules.-module FRP.Rhine.Schedule.Util where---- dunai-import Data.MonadicStreamFunction-import Data.MonadicStreamFunction.Async--{- | In a composite running clock,-   duplicate the tick of one subclock.--}-duplicateSubtick :: Monad m => MSF m () (time, Either a b) -> MSF m () (time, Either a (Either a b))-duplicateSubtick runningClock = concatS $ runningClock >>> arr duplicateLeft-  where-    duplicateLeft (time, Left a) = [(time, Left a), (time, Right $ Left a)]-    duplicateLeft (time, Right b) = [(time, Right $ Right b)]---- TODO Why is stuff like this not in base? Maybe send pull request...-swapEither :: Either a b -> Either b a-swapEither (Left a) = Right a-swapEither (Right b) = Left b
+ test/Clock.hs view
@@ -0,0 +1,15 @@+module Clock where++-- tasty+import Test.Tasty++-- rhine+import Clock.FixedStep+import Clock.Millisecond++tests =+  testGroup+    "Clock"+    [ Clock.FixedStep.tests+    , Clock.Millisecond.tests+    ]
+ test/Clock/FixedStep.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Clock.FixedStep where++-- vector-sized+import Data.Vector.Sized (toList)++-- tasty+import Test.Tasty (testGroup)++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?=))++-- rhine+import FRP.Rhine+import Util++tests =+  testGroup+    "Clock.FixedStep"+    [ testCase "Outputs linearly increasing ticks" $+        let+          output = runScheduleRhinePure (absoluteS @@ (FixedStep @5)) $ replicate 4 ()+         in+          output @?= Just <$> [5, 10, 15, 20]+    , testCase "Outputs scheduled ticks in order" $+        let+          output = runScheduleRhinePure ((absoluteS @@ (FixedStep @5)) |@| (absoluteS @@ (FixedStep @3))) $ replicate 6 ()+         in+          output @?= Just <$> [3, 5, 6, 9, 10, 12]+    , testCase "Outputs scheduled ticks in order (mirrored)" $+        let+          output = runScheduleRhinePure ((absoluteS @@ (FixedStep @3)) |@| (absoluteS @@ (FixedStep @5))) $ replicate 6 ()+         in+          output @?= Just <$> [3, 5, 6, 9, 10, 12]+    , testCase "Resamples correctly" $+        let+          output = fmap (fmap (first toList)) $ runScheduleRhinePure ((absoluteS @@ (FixedStep @3)) >-- downsampleFixedStep --> ((clId &&& absoluteS) @@ (FixedStep @12))) $ replicate 10 ()+         in+          output+            @?= [ Nothing+                , Nothing+                , Nothing+                , Nothing+                , Just ([12, 9, 6, 3], 12)+                , Nothing+                , Nothing+                , Nothing+                , Nothing+                , Just ([24, 21, 18, 15], 24)+                ]+    ]
+ test/Clock/Millisecond.hs view
@@ -0,0 +1,31 @@+module Clock.Millisecond where++-- tasty+import Test.Tasty (testGroup)++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?=))++-- rhine+import FRP.Rhine+import Util (runRhine)++secondsSinceInit :: Monad m => ClSF m (Millisecond n) a Int+secondsSinceInit = sinceInitS >>> arr round++tests =+  testGroup+    "Millisecond"+    [ testCase "Runs to second precision" $ do+        output <- runRhine (secondsSinceInit @@ (waitClock @1000)) $ replicate 5 ()+        output @?= Just <$> [1, 2, 3, 4, 5]+    , testCase "Schedules chronologically" $ do+        output <- runRhine (secondsSinceInit @@ (waitClock @3000) >-- collect --> (clId &&& secondsSinceInit) @@ (waitClock @5000)) $ replicate 5 ()+        output+          @?= [ Nothing+              , Just ([3], 5)+              , Nothing+              , Nothing+              , Just ([9, 6], 10)+              ]+    ]
+ test/Main.hs view
@@ -0,0 +1,16 @@+module Main where++-- tasty+import Test.Tasty++-- rhine+import Clock+import Schedule++main =+  defaultMain $+    testGroup+      "Main"+      [ Clock.tests+      , Schedule.tests+      ]
+ test/Schedule.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedLists #-}++module Schedule where++-- base+import Control.Arrow ((>>>))+import Data.Functor (($>))+import Data.Functor.Identity++-- tasty+import Test.Tasty++-- tasty-hunit+import Test.Tasty.HUnit++-- monad-schedule+import Control.Monad.Schedule.Trans (Schedule, runScheduleT, wait)++-- rhine+import FRP.Rhine.Clock (Clock (initClock), RunningClockInit, accumulateWith, constM, embed)+import FRP.Rhine.Clock.FixedStep (FixedStep (FixedStep))+import FRP.Rhine.Schedule+import Util++tests =+  testGroup+    "Schedule"+    [ testGroup+        "scheduleList"+        [ testCase "schedule waits chronologically" $ do+            let output = runIdentity $ runScheduleT (const (pure ())) $ embed (scheduleList $ (\n -> constM (wait n $> n) >>> accumulateWith (+) 0) <$> [3 :: Integer, 5]) $ replicate 6 ()+            output @?= pure <$> [3, 5, 6, 9, 10, 12]+        , testCase "schedule waits chronologically (mirrored)" $ do+            let output = runSchedule $ embed (scheduleList $ (\n -> constM (wait n $> n) >>> accumulateWith (+) 0) <$> [5 :: Integer, 3]) $ replicate 6 ()+            output @?= pure <$> [3, 5, 6, 9, 10, 12]+        ]+    , testGroup+        "runningSchedule"+        [ testCase "chronological ticks" $ do+            let clA = FixedStep @5+                clB = FixedStep @3+                (runningClockA, _) = runSchedule (initClock clA :: RunningClockInit (Schedule Integer) Integer ())+                (runningClockB, _) = runSchedule (initClock clB :: RunningClockInit (Schedule Integer) Integer ())+                output = runSchedule $ embed (runningSchedule clA clB runningClockA runningClockB) $ replicate 6 ()+            output+              @?= [ (3, Right ())+                  , (5, Left ())+                  , (6, Right ())+                  , (9, Right ())+                  , (10, Left ())+                  , (12, Right ())+                  ]+        ]+    , testGroup+        "ParallelClock"+        [ testCase "chronological ticks" $ do+            let+              (runningClock, _time) = runSchedule (initClock $ ParallelClock (FixedStep @5) (FixedStep @3) :: RunningClockInit (Schedule Integer) Integer (Either () ()))+              output = runSchedule $ embed runningClock $ replicate 6 ()+            output+              @?= [ (3, Right ())+                  , (5, Left ())+                  , (6, Right ())+                  , (9, Right ())+                  , (10, Left ())+                  , (12, Right ())+                  ]+        ]+    ]
+ test/Util.hs view
@@ -0,0 +1,21 @@+module Util where++-- monad-schedule+import Control.Monad.Schedule.Trans (Schedule, runScheduleT)++-- rhine++import Data.Functor.Identity (Identity (runIdentity))+import FRP.Rhine++runScheduleRhinePure :: (Clock (Schedule (Diff (Time cl))) cl, GetClockProxy cl) => Rhine (Schedule (Diff (Time cl))) cl a b -> [a] -> [Maybe b]+runScheduleRhinePure rhine = runSchedule . runRhine rhine++runRhine :: (Clock m cl, GetClockProxy cl, Monad m) => Rhine m cl a b -> [a] -> m [Maybe b]+runRhine rhine input = do+  msf <- eraseClock rhine+  embed msf input++-- FIXME Move to monad-schedule+runSchedule :: Schedule diff a -> a+runSchedule = runIdentity . runScheduleT (const (pure ()))