Dev hoist rhines

rhine/src/FRP/Rhine/Clock.hs

@@ -8,6 +8,7 @@ and certain general constructions of 'Clock's,
 such as clocks lifted along monad morphisms or time rescalings.
 -}
 {-# LANGUAGE Arrows #-}
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -225,7 +226,7 @@ rescaledClockToS = rescaledClockMToS . rescaledClockToM
 
 -- | Applying a monad morphism yields a new clock.
 data HoistClock m1 m2 cl = HoistClock
-  { unhoistedClock :: cl
+  { unhoistClock :: cl
   , monadMorphism  :: forall a . m1 a -> m2 a
   }
 
@@ -242,6 +243,48 @@ instance (Monad m1, Monad m2, Clock m1 cl)
       , initialTime
       )
 
+{- |
+A general type class to hoist a clock @cl@
+along a monad morphism from @m1@ to @m2@.
+
+'HoistClock' is the default implementation
+and can be instantiated for any user-defined clock type
+by the following one line of boiler plate:
+
+@
+instance HoistableClock m1 m2 MyClock where
+@
+
+In some cases (for example, composite clocks), 
+a different instance is desirable,
+and this type class allows to override it.
+So in general, it is advisable to use 'hoistClock'
+instead of 'HoistClock'.
+-}
+class HoistableClock m1 m2 cl where
+  type HoistedClock m1 m2 cl
+  type HoistedClock m1 m2 cl = HoistClock m1 m2 cl
+
+  -- | Hoist a clock along a monad morphism
+  hoistedClock
+    :: cl -- ^ The unhoisted clock
+    -> (forall a . m1 a -> m2 a) -- ^ The monad morphism
+    -> HoistedClock m1 m2 cl
+  default hoistedClock
+    :: HoistedClock m1 m2 cl ~ HoistClock m1 m2 cl
+    => cl -> (forall a . m1 a -> m2 a)
+    -> HoistedClock m1 m2 cl
+  hoistedClock = HoistClock
+
+	-- | Recover the original clock
+  unhoistedClock
+    :: HoistedClock m1 m2 cl
+    -> cl
+  default unhoistedClock
+    :: HoistedClock m1 m2 cl ~ HoistClock m1 m2 cl
+    => HoistedClock m1 m2 cl
+    -> cl
+  unhoistedClock = unhoistClock
 
 -- | Lift a clock type into a monad transformer.
 type LiftClock m t cl = HoistClock m (t m) cl

rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs

@@ -5,6 +5,7 @@ Provides a clock that ticks at every multiple of a fixed number of milliseconds.
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -46,6 +47,7 @@ instance Clock IO (Millisecond n) where
   type Tag  (Millisecond n) = Bool
   initClock (Millisecond cl) = initClock cl
 
+instance HoistableClock IO m (Millisecond n) where
 
 -- | This implementation measures the time after each tick,
 --   and waits for the remaining time until the next tick.

rhine/src/FRP/Rhine/Reactimation.hs

@@ -5,9 +5,14 @@ as main loops.
 
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
+
 module FRP.Rhine.Reactimation where
 
 
+-- transformers
+import Control.Monad.Trans.Class
+
 -- dunai
 import Data.MonadicStreamFunction
 

rhine/src/FRP/Rhine/ResamplingBuffer.hs

@@ -68,3 +68,14 @@ hoistResamplingBuffer hoist ResamplingBuffer {..} = ResamplingBuffer
   { put = (((hoistResamplingBuffer hoist <$>) . hoist) .) . put
   , get = (second (hoistResamplingBuffer hoist) <$>) . hoist . get
   }
+
+-- | Hoist a 'ResamplingBuffer' along a monad morphism.
+hoistResamplingBufferAndClocks
+  :: (Monad m1, Monad m2)
+  => (forall c. m1 c -> m2 c)
+  -> ResamplingBuffer m1 cla clb a b
+  -> ResamplingBuffer m2 (HoistClock m1 m2 cla) (HoistClock m1 m2 clb) a b
+hoistResamplingBufferAndClocks hoist ResamplingBuffer {..} = ResamplingBuffer
+  { put = (((hoistResamplingBufferAndClocks hoist <$>) . hoist) .) . put . retag id
+  , get = (second (hoistResamplingBufferAndClocks hoist) <$>) . hoist . get . retag id
+  }

rhine/src/FRP/Rhine/SF.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE GADTs      #-}
+{-# LANGUAGE RankNTypes #-}
+module FRP.Rhine.SF where
+
+
+-- rhine
+import FRP.Rhine.Clock
+import FRP.Rhine.ResamplingBuffer
+import FRP.Rhine.Schedule
+import FRP.Rhine.SyncSF
+
+
+{- | 'SF' is an abbreviation for "signal function".
+It represents a side-effectful asynchronous /__s__ignal __f__unction/, or signal network,
+where input, data processing (including side effects) and output
+need not happen at the same time.
+
+The type parameters are:
+
+* 'm': The monad in which side effects take place.
+* 'cl': The clock of the whole signal network.
+        It may be sequentially or parallely composed from other clocks.
+* 'a': The input type. Input arrives at the rate @Leftmost cl@.
+* 'b': The output type. Output arrives at the rate @Rightmost cl@.
+-}
+data SF m cl a b where
+  -- | A synchronous monadic stream function is the basic building block.
+  --   For such an 'SF', data enters and leaves the system at the same rate as it is processed.
+  Synchronous
+    :: ( cl ~ Leftmost cl, cl ~ Rightmost cl)
+    => SyncSF m cl a b
+    -> SF     m cl a b
+  -- | Two 'SF's may be sequentially composed if there is a matching 'ResamplingBuffer' between them.
+  Sequential
+    :: ( Clock m clab, Clock m clcd
+       , TimeDomainOf clab ~ TimeDomainOf clcd
+       , TimeDomainOf clab ~ TimeDomainOf (Rightmost clab)
+       , TimeDomainOf clcd ~ TimeDomainOf (Leftmost  clcd)
+       )
+    => SF               m            clab                  a b
+    -> ResamplingBuffer m (Rightmost clab) (Leftmost clcd)   b c
+    -> SF               m                            clcd      c d
+    -> SF m (SequentialClock m       clab            clcd) a     d
+  -- | Two 'SF's with the same input and output data may be parallely composed.
+  Parallel
+    :: ( Clock m cl1, Clock m cl2
+       , TimeDomainOf cl1 ~ TimeDomainOf (Rightmost cl1)
+       , TimeDomainOf cl2 ~ TimeDomainOf (Rightmost cl2)
+       , TimeDomainOf cl1 ~ TimeDomainOf cl2
+       , TimeDomainOf cl1 ~ TimeDomainOf (Leftmost cl1)
+       , TimeDomainOf cl2 ~ TimeDomainOf (Leftmost cl2)
+       )
+    => SF m cl1 a b
+    -> SF m cl2 a b
+    -> SF m (ParallelClock m cl1 cl2) a b
+
+-- * Hoist 'SF's along monad morphisms
+hoistSeqSF
+  :: ( Monad m, Monad m'
+     , cl1 ~ Leftmost cl1, cl1 ~ Rightmost cl1
+     , cl2 ~ Leftmost cl2, cl2 ~ Rightmost cl2
+     )
+  => (forall x . m x -> m' x)
+  -> SF m (SequentialClock m cl1 cl2) a b
+  -> SF m' (SequentialClock m' (HoistClock m m' cl1)  (HoistClock m m' cl2)) a b
+hoistSeqSF monadMorphism (Sequential (Synchronous syncsf1) rb (Synchronous syncsf2)) =
+  Sequential
+    (Synchronous $ hoistSyncSFAndClock monadMorphism syncsf1)
+    (hoistResamplingBufferAndClocks monadMorphism rb)
+    (Synchronous $ hoistSyncSFAndClock monadMorphism syncsf2)

rhine/src/FRP/Rhine/SN.hs

@@ -61,3 +61,19 @@ data SN m cl a b where
     => SN m                  cl1      a b
     -> SN m                      cl2  a b
     -> SN m (ParallelClock m cl1 cl2) a b
+
+
+-- * Hoist 'SN's along monad morphisms
+hoistSeqSN
+  :: ( Monad m, Monad m'
+     , cl1 ~ In cl1, cl1 ~ Out cl1
+     , cl2 ~ In cl2, cl2 ~ Out cl2
+     )
+  => (forall x . m x -> m' x)
+  -> SN m (SequentialClock m cl1 cl2) a b
+  -> SN m' (SequentialClock m' (HoistClock m m' cl1)  (HoistClock m m' cl2)) a b
+hoistSeqSN monadMorphism (Sequential (Synchronous clsf1) rb (Synchronous clsf2)) =
+  Sequential
+    (Synchronous $ hoistClSFAndClock monadMorphism clsf1)
+    (hoistResamplingBufferAndClocks monadMorphism rb)
+    (Synchronous $ hoistClSFAndClock monadMorphism clsf2)

rhine/src/FRP/Rhine/Schedule.hs

@@ -55,18 +55,41 @@ data Schedule m cl1 cl2
 -- * Utilities to create new schedules from existing ones
 
 -- | Lift a schedule along a monad morphism.
+--   This is useful when @cl1@ and @cl2@ are polymorphic in their monads.
 hoistSchedule
-  :: (Monad m1, Monad m2)
-  => (forall a . m1 a -> m2 a)
-  -> Schedule m1 cl1 cl2
-  -> Schedule m2 cl1 cl2
-hoistSchedule hoist Schedule {..} = Schedule initSchedule'
+  :: (Monad m, Monad m')
+  => Schedule m  cl1 cl2
+  -> (forall a . m a -> m' a)
+  -> Schedule m' cl1 cl2
+hoistSchedule Schedule {..} morph = Schedule initSchedule'
   where
-    initSchedule' cl1 cl2 = hoist
-      $ first (hoistMSF hoist) <$> initSchedule cl1 cl2
+    initSchedule' cl1 cl2 = morph
+      $ first (hoistMSF morph) <$> initSchedule cl1 cl2
     hoistMSF = liftMSFPurer
     -- TODO This should be a dunai issue
 
+
+-- | Lifts a schedule and the scheduled clocks along a given monad morphism.
+--   (Disregards the monad morphisms along which
+--    the constituent clocks are lifted.
+--   )
+--   This is useful when @cl1@ or @cl2@ are not polymorphic in their monads.
+hoistedClockSchedule
+  :: ( Monad m, Monad m'
+     , HoistableClock m m' cl2
+     , HoistableClock m m' cl2
+     )
+  => Schedule m cl1 cl2
+  -> (forall a . m a -> m' a)
+  -> Schedule m' (HoistedClock m m' cl1) (HoistedClock m m' cl2)
+hoistedClockSchedule schedule@(Schedule {}) morph = Schedule initSchedule'
+  where
+    initSchedule' hoistedCl1 hoistdCl2
+      = initSchedule
+          (hoistSchedule schedule morph)
+          (unhoistedClock hoistedCl1)
+          (unhoistedClock hoistedCl2)
+
 -- | Swaps the clocks for a given schedule.
 flipSchedule
   :: Monad m
@@ -178,6 +201,36 @@ schedSeq2 = Schedule $ \SequentialClock { sequentialSchedule = Schedule {..}, ..
 -- ** Parallelly combined clocks
 
 
+-- | Hoist a sequential clock, preserving its decomposition.
+--   Hoists the individual clocks and the schedule.
+hoistedSeqClock
+  :: (Monad m, Monad m')
+  => (forall a . m a -> m' a)
+  -> SequentialClock m cl1 cl2
+  -> SequentialClock m' (HoistClock m m' cl1)  (HoistClock m m' cl2)
+hoistedSeqClock morph (SequentialClock {..}) = SequentialClock
+  { sequentialCl1      = HoistClock sequentialCl1 morph
+  , sequentialCl2      = HoistClock sequentialCl2 morph
+  , sequentialSchedule = hoistClockSchedule morph sequentialSchedule
+  }
+
+instance (HoistableClock m m' cl1, HoistableClock m m' cl2)
+      => HoistableClock m m' (SequentialClock m cl1 cl2)
+  type HoistedClock m m' (SequentialClock m cl1 cl2)
+    = SequentialClock m' (HoistedClock m m' cl1) (HoistedClock m m' cl2)
+  hoistedClock SequentialClock {..} morph = SequentialClock
+    { sequentialCl1      = hoistedClock sequentialCl1 morph
+    , sequentialCl2      = hoistedClock sequentialCl2 morph
+    , sequentialSchedule = hoistedClockSchedule sequentialSchedule morph
+    }
+	unhoistedClock SequentialClock {..} = SequentialClock
+    { sequentialCl1      = unhoistedClock sequentialCl1
+    , sequentialCl2      = unhoistedClock sequentialCl2
+    , sequentialSchedule = unhoistedClock sequentialCl1
+    }
+
+-- ** Parallelly composed 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
@@ -198,6 +251,19 @@ instance (Monad m, Clock m cl1, Clock m cl2)
   initClock ParallelClock {..}
     = initSchedule parallelSchedule parallelCl1 parallelCl2
 
+-- | Hoist a parallel clock, preserving its decomposition.
+--   Hoists the individual clocks and the schedule.
+hoistedParClock
+  :: (Monad m, Monad m')
+  => (forall a . m a -> m' a)
+  -> ParallelClock m cl1 cl2
+  -> ParallelClock m' (HoistClock m m' cl1)  (HoistClock m m' cl2)
+hoistedParClock morph (ParallelClock {..}) = ParallelClock
+  { parallelCl1      = HoistClock parallelCl1 morph
+  , parallelCl2      = HoistClock parallelCl2 morph
+  , parallelSchedule = hoistClockSchedule morph parallelSchedule
+  }
+
 
 -- | Like 'schedSeq1', but for parallel clocks.
 --   The left subclock of the combined clock always ticks instantly after @cl1@.
@@ -283,3 +349,18 @@ parClockTagInclusion :: ParClockInclusion clS cl -> Tag clS -> Tag cl
 parClockTagInclusion (ParClockInL parClockInL) tag = parClockTagInclusion parClockInL $ Left  tag
 parClockTagInclusion (ParClockInR parClockInR) tag = parClockTagInclusion parClockInR $ Right tag
 parClockTagInclusion ParClockRefl              tag = tag
+
+-- * Hoist composite clocks along monad morphisms
+
+type family HoistedClock m m' cl where
+  HoistedClock m m' (SequentialClock m cl1 cl2) = SequentialClock m' (HoistedClock m m' cl1)  (HoistedClock m m' cl2)
+  HoistedClock m m' (ParallelClock   m cl1 cl2) = ParallelClock   m' (HoistedClock m m' cl1)  (HoistedClock m m' cl2)
+  HoistedClock m m' cl = HoistClock m m' cl
+
+hoistedClock :: (forall a . m a -> m' a) -> cl -> HoistedClock m m' cl
+hoistedClock morph (SequentialClock {..}) = SequentialClock
+  { sequentialCl1      = hoistedClock  morph sequentialCl1
+  , sequentialCl2      = hoistedClock  morph sequentialCl1
+  , sequentialSchedule = hoistSchedule morph sequentialSchedule
+  }
+-}

rhine/src/FRP/Rhine/Type.hs

@@ -3,8 +3,18 @@ The type of a complete Rhine program:
 A signal network together with a matching clock value.
 -}
 
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
 module FRP.Rhine.Type where
 
+-- transformers
+import Control.Monad.Trans.Class
+
+-- rhine
+import FRP.Rhine.Clock
+import FRP.Rhine.Schedule
 import FRP.Rhine.SN
 
 {- |
@@ -19,3 +29,27 @@ data Rhine m cl a b = Rhine
   { sn    :: SN m cl a b
   , clock :: cl
   }
+
+-- * Hoist 'Rhine's along monad morphisms
+
+hoistSeqRhine
+  :: ( Monad m, Monad m'
+     , cl1 ~ In cl1, cl1 ~ Out cl1
+     , cl2 ~ In cl2, cl2 ~ Out cl2
+     )
+  => (forall x . m x -> m' x)
+  -> Rhine m (SequentialClock m cl1 cl2) a b
+  -> Rhine m' (SequentialClock m' (HoistClock m m' cl1) (HoistClock m m' cl2)) a b
+hoistSeqRhine monadMorphism Rhine {..} = Rhine
+  { sn    = hoistSeqSN monadMorphism sn
+  , clock = hoistedSeqClock monadMorphism clock
+  }
+
+liftSeqRhine
+  :: ( Monad m, MonadTrans t, Monad (t m)
+     , cl1 ~ In cl1, cl1 ~ Out cl1
+     , cl2 ~ In cl2, cl2 ~ Out cl2
+     )
+  => Rhine m (SequentialClock m cl1 cl2) a b
+  -> Rhine (t m) (SequentialClock (t m) (LiftClock m t cl1) (LiftClock m t cl2)) a b
+liftSeqRhine = hoistSeqRhine lift