Change Event and Behavior to have a representational role

reactive-banana/src/Reactive/Banana/Combinators.hs

@@ -78,7 +78,7 @@ which is necessary for the higher-order combinators.
 -- I'm really sorry about the extra 'IO', but it can't be helped.
 -- See source code for the sordid details.
 interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> IO [Maybe b]
-interpret f xs = Prim.interpret (fmap unE . unM . f . E) xs
+interpret f xs = Prim.interpret (fmap unE . unM . f . mkE) xs
 -- FIXME: I would love to remove the 'IO' from the type signature,
 -- but unfortunately, it is possible that the argument to interpret
 -- returns an Event that was created in the context of an existing network, e.g.
@@ -99,7 +99,7 @@ interpret f xs = Prim.interpret (fmap unE . unM . f . E) xs
 --
 -- > never = []
 never    :: Event a
-never = E Prim.never
+never = mkE Prim.never
 
 -- | Merge two event streams of the same type.
 -- The function argument specifies how event values are to be combined
@@ -123,12 +123,12 @@ mergeWith
   -> Event a
   -> Event b
   -> Event c
-mergeWith f g h e1 e2 = E $ Prim.mergeWith f g h (unE e1) (unE e2)
+mergeWith f g h e1 e2 = mkE $ Prim.mergeWith f g h (unE e1) (unE e2)
 
 -- | Allow all event occurrences that are 'Just' values, discard the rest.
 -- Variant of 'filterE'.
 filterJust :: Event (Maybe a) -> Event a
-filterJust = E . Prim.filterJust . unE
+filterJust = mkE . Prim.filterJust . unE
 
 -- | Allow all events that fulfill the predicate, discard the rest.
 -- Semantically,
@@ -144,7 +144,7 @@ filterE p = filterJust . fmap (\x -> if p x then Just x else Nothing)
 --
 -- This function is generally used in its infix variant '<@>'.
 apply :: Behavior (a -> b) -> Event a -> Event b
-apply bf ex = E $ Prim.applyE (unB bf) (unE ex)
+apply bf ex = mkE $ Prim.applyE (unB bf) (unE ex)
 
 -- | Construct a time-varying function from an initial value and
 -- a stream of new values. The result will be a step function.
@@ -165,7 +165,7 @@ apply bf ex = E $ Prim.applyE (unB bf) (unE ex)
 -- This allows for recursive definitions.
 -- See the discussion below for more on recursion.
 stepper :: MonadMoment m => a -> Event a -> m (Behavior a)
-stepper a = liftMoment . M . fmap B . Prim.stepperB a . unE
+stepper a = liftMoment . M . fmap mkB . Prim.stepperB a . unE
 
 -- | The 'accumE' function accumulates a stream of event values,
 -- similar to a /strict/ left scan, 'scanl''.
@@ -181,7 +181,7 @@ stepper a = liftMoment . M . fmap B . Prim.stepperB a . unE
 -- >     where
 -- >     trimE e start = [(time,x) | (time,x) <- e, start <= time]
 accumE :: MonadMoment m => a -> Event (a -> a) -> m (Event a)
-accumE acc = liftMoment . M . fmap E . Prim.accumE acc . unE
+accumE acc = liftMoment . M . fmap mkE . Prim.accumE acc . unE
 
 {-$recursion
 
@@ -266,7 +266,7 @@ valueBLater = liftMoment . M . Prim.initialBLater . unB
 --
 -- > observeE e = [(time, m time) | (time, m) <- e]
 observeE :: Event (Moment a) -> Event a
-observeE = E . Prim.observeE . Prim.mapE unM . unE
+observeE = mkE . Prim.observeE . Prim.mapE unM . unE
 
 -- | Dynamically switch between 'Event'.
 -- Semantically,
@@ -276,15 +276,15 @@ observeE = E . Prim.observeE . Prim.mapE unM . unE
 -- >     intervals e        = [(time1, time2, x) | ((time1,x),(time2,_)) <- zip e (tail e)]
 -- >     trim time1 time2 e = [x | (timex,x) <- e, time1 < timex, timex <= time2]
 switchE :: MonadMoment m => Event (Event a) -> m (Event a)
-switchE = liftMoment . M . fmap E . Prim.switchE . Prim.mapE (unE) . unE
+switchE = liftMoment . M . fmap mkE . Prim.switchE . Prim.mapE (unE) . unE
 
 -- | Dynamically switch between 'Behavior'.
 -- Semantically,
 --
 -- >  switchB b0 eb = \time0 -> \time1 ->
 -- >     last (b0 : [b | (timeb,b) <- eb, time0 <= timeb, timeb < time1]) time1
 switchB :: MonadMoment m => Behavior a -> Event (Behavior a) -> m (Behavior a)
-switchB b = liftMoment . M . fmap B . Prim.switchB (unB b) . Prim.mapE (unB) . unE
+switchB b = liftMoment . M . fmap mkB . Prim.switchB (unB b) . Prim.mapE (unB) . unE
 
 {-----------------------------------------------------------------------------
     Derived Combinators

reactive-banana/src/Reactive/Banana/Frameworks.hs

@@ -168,7 +168,7 @@ reactimate' = MIO . Prim.addReactimate . Prim.mapE unF . unE
 -- this will register a callback function such that
 -- an event will occur whenever the callback function is called.
 fromAddHandler ::AddHandler a -> MomentIO (Event a)
-fromAddHandler = MIO . fmap E . Prim.fromAddHandler
+fromAddHandler = MIO . fmap mkE . Prim.fromAddHandler
 
 -- | Input,
 -- obtain a 'Behavior' by frequently polling mutable data, like the current time.
@@ -183,7 +183,7 @@ fromAddHandler = MIO . fmap E . Prim.fromAddHandler
 -- it should not perform expensive computations.
 -- Neither should its side effects affect the event network significantly.
 fromPoll :: IO a -> MomentIO (Behavior a)
-fromPoll = MIO . fmap B . Prim.fromPoll
+fromPoll = MIO . fmap mkB . Prim.fromPoll
 
 -- | Input,
 -- obtain a 'Behavior' from an 'AddHandler' that notifies changes.
@@ -226,7 +226,7 @@ fromChanges initial changes = do
 -- this is indicated by the type 'Future'.
 -- It can be used only in the context of 'reactimate''.
 changes :: Behavior a -> MomentIO (Event (Future a))
-changes = return . E . Prim.mapE F . Prim.changesB . unB
+changes = return . mkE . Prim.mapE F . Prim.changesB . unB
 
 {- $changes
 
@@ -256,7 +256,7 @@ in this context. Still, it is useful in some cases.
 --
 -- Note: This function is useful only in very specific circumstances.
 imposeChanges :: Behavior a -> Event () -> Behavior a
-imposeChanges b e = B $ Prim.imposeChanges (unB b) (Prim.mapE (const ()) (unE e))
+imposeChanges b e = mkB $ Prim.imposeChanges (unB b) (Prim.mapE (const ()) (unE e))
 
 {- | Dynamically add input and output to an existing event network.
 
@@ -284,7 +284,7 @@ If your main goal is to reliably turn events into 'IO' actions,
 use the 'reactimate' and 'reactimate'' functions instead.
 -}
 execute :: Event (MomentIO a) -> MomentIO (Event a)
-execute = MIO . fmap E . Prim.executeE . Prim.mapE unMIO . unE
+execute = MIO . fmap mkE . Prim.executeE . Prim.mapE unMIO . unE
 
 -- $liftIO
 --

reactive-banana/src/Reactive/Banana/Types.hs

@@ -1,13 +1,19 @@
+{-# language GADTs #-}
+{-# language RankNTypes #-}
+{-# language RoleAnnotations #-}
+
 {-----------------------------------------------------------------------------
     reactive-banana
 ------------------------------------------------------------------------------}
 module Reactive.Banana.Types (
     -- | Primitive types.
-    Event(..), Behavior(..),
+    Event, mkE, unE,
+    Behavior, mkB, unB,
     Moment(..), MomentIO(..), MonadMoment(..),
     Future(..),
     ) where
 
+import Data.Bifunctor
 import Data.Semigroup
 import Control.Applicative
 import Control.Monad
@@ -33,16 +39,29 @@ no two event occurrences may happen at the same time.
 
 <<doc/frp-event.png>>
 -}
-newtype Event a = E { unE :: Prim.Event a }
+type role Event representational
+
+-- This strange definition allows us to make the @a@ parameter
+-- @representational@ which allows users to use @coerce@ on @Event@.
+newtype Event a = E (forall x. (a -> x) -> Prim.Event x)
 -- Invariant: The empty list `[]` never occurs as event value.
 
+
+unE :: Event a -> Prim.Event a
+unE (E f) = f id
+
+
+mkE :: Prim.Event a -> Event a
+mkE prim = E $ \out -> Prim.mapE out prim
+
+
 -- | The function 'fmap' applies a function @f@ to every value.
 -- Semantically,
 --
 -- > fmap :: (a -> b) -> Event a -> Event b
 -- > fmap f e = [(time, f a) | (time, a) <- e]
 instance Functor Event where
-    fmap f = E . Prim.mapE f . unE
+    fmap f = mkE . Prim.mapE f . unE
 
 -- | The combinator '<>' merges two event streams of the same type.
 -- In case of simultaneous occurrences,
@@ -52,15 +71,15 @@ instance Functor Event where
 -- > (<>) :: Event a -> Event a -> Event a
 -- > (<>) ex ey = unionWith (<>) ex ey
 instance Semigroup a => Semigroup (Event a) where
-    x <> y = E $ Prim.mergeWith Just Just (\a b -> Just (a <> b)) (unE x) (unE y)
+    x <> y = mkE $ Prim.mergeWith Just Just (\a b -> Just (a <> b)) (unE x) (unE y)
 
 -- | The combinator 'mempty' represents an event that never occurs.
 -- It is a synonym,
 --
 -- > mempty :: Event a
 -- > mempty = never
 instance Semigroup a => Monoid (Event a) where
-    mempty  = E $ Prim.never
+    mempty  = mkE $ Prim.never
     mappend = (<>)
 
 
@@ -71,7 +90,17 @@ Semantically, you can think of it as a function
 
 <<doc/frp-behavior.png>>
 -}
-newtype Behavior a = B { unB :: Prim.Behavior a }
+type role Behavior representational
+newtype Behavior a = B (forall x. (a -> x) -> Prim.Behavior x)
+
+
+mkB :: Prim.Behavior a -> Behavior a
+mkB prim = B $ \out -> Prim.mapB out prim
+
+
+unB :: Behavior a -> Prim.Behavior a
+unB (B f) = f id
+
 
 -- | The function 'pure' returns a value that is constant in time. Semantically,
 --
@@ -83,8 +112,8 @@ newtype Behavior a = B { unB :: Prim.Behavior a }
 -- > (<*>)    :: Behavior (a -> b) -> Behavior a -> Behavior b
 -- > fx <*> bx = \time -> fx time $ bx time
 instance Applicative Behavior where
-    pure x    = B $ Prim.pureB x
-    bf <*> bx = B $ Prim.applyB (unB bf) (unB bx)
+    pure x    = mkB $ Prim.pureB x
+    bf <*> bx = mkB $ Prim.applyB (unB bf) (unB bx)
 
 -- | The function 'fmap' applies a function @f@ at every point in time.
 -- Semantically,