src/FRP/Taupo.hs

@@ -6,25 +6,40 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module FRP.Taupo
-  ( Schedule (..),
-    TimeUnit (..),
-    SignalGraph,
+  ( SignalGraph,
     onDemand,
     onSupply,
     fillIn,
+    schedule,
+    scheduleMono,
+    scheduleSemi,
+    scheduleEarliest,
+    scheduleLatest,
     batch,
-    output,
+    batchMono,
+    batchSemi,
+    batchEarliest,
+    batchLatest,
     event,
+    output,
   )
 where
 
-import Control.Foldl (Fold, FoldM (FoldM))
+import Control.Foldl (Fold)
+import qualified Control.Foldl as L
 import Control.Selective (Selective (select))
+import Data.Bifunctor (second)
+import Data.Functor (void, ($>))
 import Data.Kind (Type)
-import GHC.TypeNats (Nat)
-import Prelude hiding (init)
+import Data.Maybe (fromJust)
+import Data.Monoid (Alt (Alt), Dual (Dual), getAlt, getDual)
+import Data.Semialign (Semialign (align, alignWith))
+import Data.These (These)
+import GHC.TypeNats (Nat, type (<=))
 
 -- Separate design from implementation
 
@@ -46,10 +61,6 @@ import Prelude hiding (init)
 --
 -- Based on 'Rhine: FRP with Type-Level Clocks', by Baerenz and Perez.
 
-data TimeUnit = Second | DeciSecond | CentiSecond | MilliSecond
-
-data Schedule = Every Nat TimeUnit
-
 -- Rescheduling can take two forms:
 --
 -- Faster schedule -> slower schedule (batching)
@@ -63,111 +74,183 @@ data Schedule = Every Nat TimeUnit
 
 -- _Structure_ of the signal graph
 -- Generalized from 'The Haskell Layer Cake' by Matt Parsons.
-data SignalGraph (eff :: Type -> Type) (sched :: Schedule) (a :: Type) where
+data SignalGraph (eff :: Type -> Type) (freq :: Maybe Nat) (a :: Type) where
   -- Inputs
-  OnDemand :: eff a -> SignalGraph eff sched a
-  OnSupply :: FoldM eff a b -> SignalGraph eff sched b
+  OnDemand :: eff a -> SignalGraph eff ('Just hz) a
+  OnSupply :: (a -> eff ()) -> (a -> b) -> SignalGraph eff 'Nothing b
   -- Reschedulers
-  FillIn :: (Maybe a -> b) -> SignalGraph eff sched' a -> SignalGraph eff sched b
-  Batch :: Fold a b -> SignalGraph eff sched' a -> SignalGraph eff sched b
-  -- Transformations
-  Transform :: (a -> b) -> SignalGraph eff sched a -> SignalGraph eff sched b
-  TransformEff :: (a -> eff b) -> SignalGraph eff sched a -> SignalGraph eff sched b
+  FillIn :: (Maybe a -> b) -> SignalGraph eff ('Just hz') a -> SignalGraph eff ('Just hz) b
+  Batch :: Fold a b -> SignalGraph eff freq a -> SignalGraph eff ('Just hz) b
+  -- Transformers
+  Transform :: (a -> eff b) -> SignalGraph eff freq a -> SignalGraph eff freq b
   -- Combinations
-  Mux :: (a -> b -> c) -> SignalGraph eff sched a -> SignalGraph eff sched b -> SignalGraph eff sched c
-  Select :: SignalGraph eff sched (Either a b) -> SignalGraph eff sched (a -> b) -> SignalGraph eff sched b
-
-instance Show (SignalGraph eff sched a) where
-  show = \case
-    OnDemand _ -> "[Signal on demand]"
-    OnSupply _ -> "[Signal on supply]"
-    FillIn _ sg -> "(Filling in " <> show sg <> ")"
-    Batch _ sg -> "(Batching " <> show sg <> ")"
-    Transform _ sg -> "(Transform of " <> show sg <> ")"
-    TransformEff _ sg -> "(Effectful transform of " <> show sg <> ")"
-    Mux _ sg1 sg2 -> "(Mux " <> show sg1 <> show sg2 <> ")"
-    Select dat ctrl -> "(Select with data " <> show dat <> " and control " <> show ctrl <> ")"
+  MuxSync :: (a -> b -> c) -> SignalGraph eff ('Just hz) a -> SignalGraph eff ('Just hz) b -> SignalGraph eff ('Just hz) c
+  MuxAsync :: (These a b -> c) -> SignalGraph eff 'Nothing a -> SignalGraph eff 'Nothing b -> SignalGraph eff 'Nothing c
+  Select :: SignalGraph eff ('Just hz) (Either a b) -> SignalGraph eff ('Just hz) (a -> b) -> SignalGraph eff ('Just hz) b
+
+-- TODO: consider SelectAsync :: SignalGraph eff 'Nothing (These a b) ->
+-- SignalGraph eff 'Nothing (a -> b) -> SignalGraph eff 'Nothing c
 
 -- To the person defining the signal graph, this is what they see:
 
 -- | sig | -- f --> | sig' | -- g --> | sig'' |
 -- The reality:
 -- | sig | -- f . g --> | sig '' |
-instance (Functor eff) => Functor (SignalGraph eff sched) where
+instance (Functor eff) => Functor (SignalGraph eff freq) where
   -- fmap id = id
   -- implies
   -- fmap f . fmap g = fmap (f . g)
   fmap ::
     forall a b.
     (a -> b) ->
-    SignalGraph eff sched a ->
-    SignalGraph eff sched b
+    SignalGraph eff freq a ->
+    SignalGraph eff freq b
   fmap f = \case
     OnDemand act -> OnDemand (fmap f act)
-    OnSupply act -> OnSupply (fmap f act)
+    OnSupply act g -> OnSupply act (f . g)
     FillIn g sg -> FillIn (f . g) sg
     Batch fld sg -> Batch (fmap f fld) sg
-    Transform g sg -> Transform (f . g) sg
-    TransformEff g sg -> TransformEff (fmap f . g) sg
-    Mux g sg1 sg2 -> Mux (\x -> f . g x) sg1 sg2
-    sg@Select {} -> Transform f sg
+    Transform g sg -> Transform (fmap f . g) sg
+    MuxSync g sg1 sg2 -> MuxSync (\x -> f . g x) sg1 sg2
+    MuxAsync g sg1 sg2 -> MuxAsync (f . g) sg1 sg2
+    Select datSg ctrlSg -> Select (fmap (second f) datSg) (fmap (f .) ctrlSg)
+  (<$) :: a -> SignalGraph eff freq b -> SignalGraph eff freq a
+  (<$) x = \case
+    OnDemand act -> OnDemand (act $> x)
+    OnSupply act _ -> OnSupply act (const x)
+    FillIn _ sg -> FillIn (const x) sg
+    Batch fld sg -> Batch (x <$ fld) sg
+    Transform g sg -> Transform (($> x) . g) sg
+    MuxSync _ sg sg' -> MuxSync (\_ _ -> x) sg sg'
+    MuxAsync _ sg sg' -> MuxAsync (const x) sg sg'
+    Select datSg ctrlSg ->
+      Select (fmap (second (const x)) datSg) (fmap (\_ _ -> x) ctrlSg)
+
+-- Allows asynchronous product of signals
+instance (Functor eff) => Semialign (SignalGraph eff 'Nothing) where
+  align ::
+    SignalGraph eff 'Nothing a ->
+    SignalGraph eff 'Nothing b ->
+    SignalGraph eff 'Nothing (These a b)
+  align sg1 sg2 = MuxAsync id sg1 sg2
+  alignWith ::
+    (These a b -> c) ->
+    SignalGraph eff 'Nothing a ->
+    SignalGraph eff 'Nothing b ->
+    SignalGraph eff 'Nothing c
+  alignWith = MuxAsync
 
 -- The composition of two Applicatives is an Applicative!
-instance (Applicative eff) => Applicative (SignalGraph eff sched) where
-  pure :: a -> SignalGraph eff sched a
+instance (Applicative eff) => Applicative (SignalGraph eff ('Just hz)) where
+  pure :: a -> SignalGraph eff ('Just hz) a
   pure x = OnDemand . pure $ x
   (<*>) ::
-    SignalGraph eff sched (a -> b) ->
-    SignalGraph eff sched a ->
-    SignalGraph eff sched b
-  sgf <*> sgx = case sgf of
-    OnDemand act -> case sgx of
-      OnDemand act' -> OnDemand (($) <$> act <*> act')
-      OnSupply (FoldM step init extract) ->
-        OnSupply (FoldM step init ((act <*>) . extract))
-      Transform g sg -> Mux (\f x -> f (g x)) sgf sg
-      _ -> Mux ($) sgf sgx
-    _ -> Mux ($) sgf sgx
+    SignalGraph eff ('Just hz) (a -> b) ->
+    SignalGraph eff ('Just hz) a ->
+    SignalGraph eff ('Just hz) b
+  sgf <*> sgx = MuxSync ($) sgf sgx
 
 -- The composition of an Applicative and a Selective is a Selective!
-instance (Selective eff) => Selective (SignalGraph eff sched) where
+instance (Selective eff) => Selective (SignalGraph eff ('Just hz)) where
   select ::
-    SignalGraph eff sched (Either a b) ->
-    SignalGraph eff sched (a -> b) ->
-    SignalGraph eff sched b
+    SignalGraph eff ('Just hz) (Either a b) ->
+    SignalGraph eff ('Just hz) (a -> b) ->
+    SignalGraph eff ('Just hz) b
   select sigDat sigCtrl = case sigDat of
     OnDemand act -> case sigCtrl of
       OnDemand act' -> OnDemand (select act act')
-      OnSupply (FoldM step init extract) ->
-        OnSupply (FoldM step init (select act . extract))
       _ -> Select sigDat sigCtrl
     _ -> Select sigDat sigCtrl
 
-onDemand :: eff a -> SignalGraph eff sched a
+onDemand :: eff a -> SignalGraph eff ('Just hz) a
 onDemand = OnDemand
 
-onSupply :: FoldM eff a b -> SignalGraph eff sched b
-onSupply = OnSupply
+onSupply :: (a -> eff ()) -> SignalGraph eff 'Nothing a
+onSupply f = OnSupply f id
 
-fillIn :: (Maybe a -> b) -> SignalGraph eff sched a -> SignalGraph eff sched' b
+fillIn ::
+  (hz <= hz') =>
+  (Maybe a -> b) ->
+  SignalGraph eff ('Just hz) a ->
+  SignalGraph eff ('Just hz') b
 fillIn = FillIn
 
-batch :: Fold a b -> SignalGraph eff sched a -> SignalGraph eff sched b
+schedule ::
+  Fold a b ->
+  SignalGraph eff 'Nothing a ->
+  SignalGraph eff ('Just hz) b
+schedule = Batch
+
+scheduleMono ::
+  (Monoid m) =>
+  (a -> m) ->
+  SignalGraph eff 'Nothing a ->
+  SignalGraph eff ('Just hz) m
+scheduleMono f = Batch (L.foldMap f id)
+
+scheduleSemi ::
+  (Semigroup s) =>
+  (a -> s) ->
+  SignalGraph eff 'Nothing a ->
+  SignalGraph eff ('Just hz) (Maybe s)
+scheduleSemi f = Batch (L.foldMap (Just . f) id)
+
+scheduleEarliest ::
+  SignalGraph eff 'Nothing a ->
+  SignalGraph eff ('Just hz) (Maybe a)
+scheduleEarliest = Batch (L.foldMap (Alt . Just) getAlt)
+
+scheduleLatest ::
+  SignalGraph eff 'Nothing a ->
+  SignalGraph eff ('Just hz) (Maybe a)
+scheduleLatest = Batch (L.foldMap (Dual . Alt . Just) (getAlt . getDual))
+
+batch ::
+  (hz' <= hz) =>
+  Fold a b ->
+  SignalGraph eff ('Just hz) a ->
+  SignalGraph eff ('Just hz') b
 batch = Batch
 
-event :: (a -> eff ()) -> SignalGraph eff sched a -> SignalGraph eff sched a
-event f sg = Mux (const id) (TransformEff f sg) sg
-
-output :: (a -> eff ()) -> SignalGraph eff sched a -> SignalGraph eff sched ()
-output = TransformEff
-
-{-
-event :: (a -> eff ()) -> SignalGraph eff sched a -> SignalGraph eff sched a
-event = Event
--}
+batchMono ::
+  (Monoid m, hz' <= hz) =>
+  (a -> m) ->
+  SignalGraph eff ('Just hz) a ->
+  SignalGraph eff ('Just hz') m
+batchMono f = Batch (L.foldMap f id)
+
+batchSemi ::
+  (Semigroup s, hz' <= hz) =>
+  (a -> s) ->
+  SignalGraph eff ('Just hz) a ->
+  SignalGraph eff ('Just hz') s
+batchSemi f = Batch (L.foldMap (Just . f) fromJust)
+
+batchEarliest ::
+  (hz' <= hz) =>
+  SignalGraph eff ('Just hz) a ->
+  SignalGraph eff ('Just hz') a
+batchEarliest = Batch (L.foldMap (Alt . Just) (fromJust . getAlt))
+
+batchLatest ::
+  (hz' <= hz) =>
+  SignalGraph eff ('Just hz) a ->
+  SignalGraph eff ('Just hz') a
+batchLatest = Batch (L.foldMap (Dual . Alt . Just) (fromJust . getAlt . getDual))
+
+event ::
+  (Functor eff) =>
+  (a -> eff ()) ->
+  SignalGraph eff freq a ->
+  SignalGraph eff freq a
+event f = Transform (\x -> f x $> x)
+
+output ::
+  (Functor eff) =>
+  (a -> eff b) ->
+  SignalGraph eff freq a ->
+  SignalGraph eff freq ()
+output f = Transform (void . f)
 
 {-
 import Control.Applicative (Applicative (liftA2))

taupo.cabal

@@ -22,6 +22,8 @@ common common-lang
     , base       ^>=4.14
     , foldl
     , selective
+    , semialign
+    , these
     , vector
 
   ghc-options: