{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
-- | Reactive Values are typed mutable variables with a change notification
-- mechanism.
--
-- They are defined by providing a way to read the value, a way to change it,
-- and a way to install an event listener when the value has changed.
--
-- RVs are pruposely defined in an abstract way, as a type class. GUI toolkits,
-- for instance, can use existing event-handling installing mechanisms to
-- enclose widget attributes as Reactive Values, without the need for an
-- extra layer.
--
-- RVs are complemented with Relation-building functions, which
-- enable pairing RVs during execution so that they are kept in
-- sync for the duration of the program.
--
-- This module only defines RVs and operations on them. For connections
-- to existing backends (GUIs, devices, files, network, FRP), see
-- https://github.com/keera-studios/keera-hails
--
module Data.ReactiveValue where
import Control.Monad
import Control.GFunctor -- Functors parameterised over the morphisms
-- in the source category
import Data.Functor.Contravariant
-- * Reactive values: common interface for all RVs
-- | Readable reactive values
class ReactiveValueRead a b m | a -> b, a -> m where
reactiveValueOnCanRead :: a -> m () -> m ()
reactiveValueRead :: a -> m b
-- | Writable reactive values
class ReactiveValueWrite a b m | a -> b, a -> m where
reactiveValueWrite :: a -> b -> m ()
-- | Read-write reactive values
class (ReactiveValueRead a b m, ReactiveValueWrite a b m) => ReactiveValueReadWrite a b m
-- * Reactive rules (data dependency/passing building combinators)
-- | Priorities so that we can write them infix without parenthesising
infix 9 =:=
infix 9 =:>
infix 9 <:=
-- | Left to right RV synchronisation function. If the value on the left
-- changes, the one on the right is updated accordingly.
(=:>) :: Monad m => (ReactiveValueRead a b m, ReactiveValueWrite c b m) => a -> c -> m ()
(=:>) v1 v2 = reactiveValueOnCanRead v1 sync1
where sync1 = reactiveValueRead v1 >>= reactiveValueWrite v2
-- | Right-to-left RV synchronisation function. If the value on the right
-- changes, the one on the left is updated accordingly.
(<:=) :: Monad m => (ReactiveValueRead a b m, ReactiveValueWrite c b m) => c -> a -> m ()
(<:=) v2 v1 = reactiveValueOnCanRead v1 sync1
where sync1 = reactiveValueRead v1 >>= reactiveValueWrite v2
-- | Bidirectional synchronisation. When either value changes, the other
-- is updated accordingly.
(=:=) :: Monad m => (ReactiveValueReadWrite a b m, ReactiveValueReadWrite c b m) => a -> c -> m ()
(=:=) v1 v2 = do
-- This is often async, so the fact that one comes before the other does not guarantee
-- that they will be refreshed in that order.
v1 =:> v2
v1 <:= v2
-- reactiveValueOnCanRead v1 sync1
-- reactiveValueOnCanRead v2 sync2
-- where sync1 = reactiveValueRead v1 >>= reactiveValueWrite v2
-- sync2 = reactiveValueRead v2 >>= reactiveValueWrite v1
-- * Purely functional implementation of RVs.
--
-- These are used internally for combinators that need to return RV instances. They can
-- also be used to write new backends and library extensions, but they are not
-- recommended to enclose application models. For that purpose, see light models and
-- protected models instead.
-- ** Setters, getters and notifiers
type FieldGetter m a = m a
type FieldSetter m a = a -> m ()
type FieldNotifier m a = m () -> m () -- FIXME: why does fieldnotifier have an argument
-- ** Concrete types implementing the above interface
data ReactiveFieldRead m a = ReactiveFieldRead (FieldGetter m a) (FieldNotifier m a)
data ReactiveFieldWrite m a = ReactiveFieldWrite (FieldSetter m a)
data ReactiveFieldReadWrite m a = ReactiveFieldReadWrite (FieldSetter m a) (FieldGetter m a) (FieldNotifier m a)
instance ReactiveValueRead (ReactiveFieldRead m a) a m where
reactiveValueOnCanRead (ReactiveFieldRead _ notifier) = notifier
reactiveValueRead (ReactiveFieldRead getter _) = getter
instance ReactiveValueWrite (ReactiveFieldWrite m a) a m where
reactiveValueWrite (ReactiveFieldWrite setter) = setter
instance ReactiveValueRead (ReactiveFieldReadWrite m a) a m where
reactiveValueOnCanRead (ReactiveFieldReadWrite _ _ notifier) = notifier
reactiveValueRead (ReactiveFieldReadWrite _ getter _) = getter
instance ReactiveValueWrite (ReactiveFieldReadWrite m a) a m where
reactiveValueWrite (ReactiveFieldReadWrite setter _ _) = setter
instance ReactiveValueReadWrite (ReactiveFieldReadWrite m a) a m
-- ** Activatable reactive values (producing units)
type ReactiveFieldActivatable m = ReactiveFieldRead m ()
mkActivatable :: Monad m => (m () -> m ()) -> ReactiveFieldActivatable m
mkActivatable f = ReactiveFieldRead getter notifier
where getter = return ()
notifier = f
class ReactiveValueActivatable m a where
defaultActivation :: a -> ReactiveFieldActivatable m
-- instance (ReactiveValueWrite a b) => ReactiveValueWrite (TypedReactiveValue a b) b where
-- reactiveValueWrite (TypedReactiveValue x _) v = reactiveValueWrite x v
--
-- instance (ReactiveValueRead a b) => ReactiveValueRead (TypedReactiveValue a b) b where
-- reactiveValueOnCanRead (TypedReactiveValue x _) v op = (reactiveValueOnCanRead x) v op
-- reactiveValueRead (TypedReactiveValue x _) = reactiveValueRead x
-- * Creating RVs based on other RVs
-- ** Lifting onto readable values
constR :: Monad m => a -> ReactiveFieldRead m a
constR e = ReactiveFieldRead getter notifier
where notifier _ = return ()
getter = return e
-- | TODO: Bad name. Should be eliminated or extended with a setter.
initRW :: Monad m => a -> ReactiveFieldRead m a
initRW e = ReactiveFieldRead getter notifier
where notifier _ = return ()
getter = return e
-- ** Lifting onto readable values
-- | Lift a transformation onto a RV. Note that this creates a new
-- RV, it does not modify the existing RV.
liftR :: (Monad m, ReactiveValueRead a b m) => (b -> c) -> a -> ReactiveFieldRead m c
liftR f e = ReactiveFieldRead getter notifier
where notifier = reactiveValueOnCanRead e
getter = liftM f (reactiveValueRead e)
-- | Shorter name for 'liftR'
(<^>) :: (Monad m, ReactiveValueRead a b m) => (b -> c) -> a -> ReactiveFieldRead m c
(<^>) = liftR
-- | Lift a transformation onto two RVs. Note that this creates a new
-- RV, it does not modify the existing RVs. When either RV changes,
-- the new one triggers a change.
liftR2 :: (Monad m, ReactiveValueRead a b m, ReactiveValueRead c d m)
=> (b -> d -> e) -> a -> c -> ReactiveFieldRead m e
liftR2 f e1 e2 = ReactiveFieldRead getter notifier
where getter = do v1 <- reactiveValueRead e1
v2 <- reactiveValueRead e2
return (f v1 v2)
notifier p = do reactiveValueOnCanRead e1 p
reactiveValueOnCanRead e2 p
-- | Lift a transformation onto three RVs. Note that this creates a new
-- RV, it does not modify the existing RVs. When either RV changes,
-- the new one triggers a change.
liftR3 :: ( Monad m, ReactiveValueRead a b m, ReactiveValueRead c d m
, ReactiveValueRead e f m)
=> (b -> d -> f -> g) -> a -> c -> e -> ReactiveFieldRead m g
liftR3 f e1 e2 e3 = ReactiveFieldRead getter notifier
where getter = do v1 <- reactiveValueRead e1
v2 <- reactiveValueRead e2
v3 <- reactiveValueRead e3
return (f v1 v2 v3)
notifier p = do reactiveValueOnCanRead e1 p
reactiveValueOnCanRead e2 p
reactiveValueOnCanRead e3 p
-- | Lift a parameterised monadic transformation onto an RV.
--
-- Same as lifting join . f?
liftMR :: (Monad m, ReactiveValueRead a b m) => (b -> m c) -> a -> ReactiveFieldRead m c
liftMR f e = ReactiveFieldRead getter notifier
where notifier = reactiveValueOnCanRead e
getter = f =<< reactiveValueRead e
-- ** Lifting onto writeable values
-- | Create a constant writable RV.
--
constW :: (Monad m, ReactiveValueWrite v a m) => a -> v -> ReactiveFieldWrite m b
constW c v = ReactiveFieldWrite $ \_ -> reactiveValueWrite v c
-- | Lift a transformation onto an RV. This creates a new RV, it does
-- not actually modify the old RV (when this one is written to, so will
-- be the old one, but both will keep existing somewhat independently).
liftW :: (Monad m, ReactiveValueWrite a b m)
=> (c -> b) -> a -> ReactiveFieldWrite m c
liftW f e = ReactiveFieldWrite setter
where setter = reactiveValueWrite e . f
-- | Lift a transformation onto two RVs. This creates a new RV, it does
-- not actually modify the old RVs (when this one is written to, so will
-- be the old ones, but both will keep existing somewhat independently).
liftW2 :: (Monad m, ReactiveValueWrite a b m, ReactiveValueWrite d e m)
=> (c -> (b,e)) -> a -> d -> ReactiveFieldWrite m c
liftW2 f e1 e2 = ReactiveFieldWrite setter
where setter x = do let (v1,v2) = f x
reactiveValueWrite e1 v1
reactiveValueWrite e2 v2
-- | Binary writable replicator.
--
-- r1 &.& r2 = liftW2 (\x -> (x,x)) r1 r2
--
(&.&) :: (Monad m, ReactiveValueWrite a b m, ReactiveValueWrite c b m)
=> a -> c -> ReactiveFieldWrite m b
(&.&) v1 v2 = ReactiveFieldWrite $ \x -> do
reactiveValueWrite v1 x
reactiveValueWrite v2 x
-- | Lift a parameterised monadic transformation onto an RV.
liftMW :: (Monad m, ReactiveValueWrite a b m)
=> (c -> m b) -> a -> ReactiveFieldWrite m c
liftMW f e = ReactiveFieldWrite setter
where setter x = reactiveValueWrite e =<< f x
-- | Make a RW RV read only
readOnly :: ReactiveValueRead r a m => r -> ReactiveFieldRead m a
readOnly r = ReactiveFieldRead (reactiveValueRead r) (reactiveValueOnCanRead r)
-- | Make a RW RV write only
writeOnly :: ReactiveValueWrite r a m => r -> ReactiveFieldWrite m a
writeOnly r = ReactiveFieldWrite (reactiveValueWrite r)
-- ** Lift monadic actions/sinks (setters) and sources (getters)
-- *** Lifting (sink) computations into writable RVs.
-- | Wrap a monadic computation in a writable reactive value.
wrapMW :: (a -> m ()) -> ReactiveFieldWrite m a
wrapMW f = ReactiveFieldWrite f
-- | Wrap a monadic computation in a writable reactive value.
-- It discards the written value and executes the operation.
--
-- Note: Because the value is discarded, the resulting RV is
-- polymorphic in the value that may be written to it. Using
-- 'wrapDo_' may save you some extra type signatures.
wrapDo :: m () -> ReactiveFieldWrite m a
wrapDo f = wrapMW (const f)
-- | Wrap a monadic computation in a writable reactive value of type
-- unit. It discards the written value and executes the operation.
wrapDo_ :: m () -> ReactiveFieldWrite m ()
wrapDo_ f = wrapMW (\() -> f)
-- *** Lifting (source) computations into readable RVs.
-- | Wrap an reading operation and an notification installer in
-- a readable reactive value.
wrapMR :: m a -> (m () -> m ()) -> ReactiveFieldRead m a
wrapMR f p = ReactiveFieldRead f p
-- | Wrap an reading operation into an RV. Because there is
-- no way to detect changes, the resulting RV is passive (does
-- not push updates).
wrapMRPassive :: Monad m => m a -> ReactiveFieldRead m a
wrapMRPassive f = ReactiveFieldRead f (const (return ()))
-- | Wrap event-handler installers in RVs
eventR :: Monad m => (m () -> m ()) -> ReactiveFieldRead m ()
eventR notifInstaller = ReactiveFieldRead (return ()) notifInstaller
-- ** Lifting onto read-write values
-- *** Bijections
newtype BijectiveFunc a b = BijectiveFunc
{ unBijectiveFunc :: (a -> b, b -> a) }
bijection :: (a -> b, b -> a) -> BijectiveFunc a b
bijection = BijectiveFunc
direct :: BijectiveFunc a b -> (a -> b)
direct = fst . unBijectiveFunc
inverse :: BijectiveFunc a b -> (b -> a)
inverse = snd . unBijectiveFunc
type Involution a = BijectiveFunc a a
involution :: (a -> a) -> Involution a
involution f = BijectiveFunc (f, f)
-- *** Actual lifting
liftRW :: (Monad m, ReactiveValueReadWrite a b m)
=> BijectiveFunc b c -> a -> ReactiveFieldReadWrite m c
liftRW (BijectiveFunc (f1, f2)) e = ReactiveFieldReadWrite setter getter notifier
where ReactiveFieldRead getter notifier = liftR f1 e
ReactiveFieldWrite setter = liftW f2 e
liftRW2 :: (Monad m, ReactiveValueReadWrite a b m, ReactiveValueReadWrite c d m)
=> BijectiveFunc e (b,d) -> a -> c -> ReactiveFieldReadWrite m e
liftRW2 (BijectiveFunc (f1, f2)) e1 e2 = ReactiveFieldReadWrite setter getter notifier
where ReactiveFieldRead getter notifier = liftR2 (curry f2) e1 e2
ReactiveFieldWrite setter = liftW2 f1 e1 e2
pairRW :: (Monad m,
ReactiveValueReadWrite a b m,
ReactiveValueReadWrite c d m)
=> a -> c -> ReactiveFieldReadWrite m (b, d)
pairRW a b = liftRW2 (bijection (id, id)) a b
{-# INLINE eqCheck #-}
eqCheck :: (Eq v, Monad m) => ReactiveFieldReadWrite m v -> ReactiveFieldReadWrite m v
eqCheck (ReactiveFieldReadWrite setter getter notifier) = ReactiveFieldReadWrite setter' getter notifier
where setter' v = do o <- getter
when (o /= v) $ setter v
-- ** Modifying reactive values (applying modification transformations)
-- | Lifting modification functions
modRW :: (Monad m, ReactiveValueReadWrite a b m)
=> (b -> c -> b) -> a -> ReactiveFieldWrite m c
modRW f rv = ReactiveFieldWrite setter
where setter c = do b <- reactiveValueRead rv
let b' = f b c
reactiveValueWrite rv b'
reactiveValueModify :: (Monad m, ReactiveValueReadWrite a b m) => a -> (b -> b) -> m ()
reactiveValueModify r f = reactiveValueWrite r . f =<< reactiveValueRead r
-- * Merging
-- | Left merge (give priority to the value on the left)
lMerge :: (Monad m, ReactiveValueRead a v m, ReactiveValueRead b v m)
=> a -> b -> ReactiveFieldRead m v
lMerge = liftR2 (\a _ -> a)
-- | Right merge (give priority to the value on the left)
rMerge :: (Monad m, ReactiveValueRead a v m, ReactiveValueRead b v m)
=> a -> b -> ReactiveFieldRead m v
rMerge = liftR2 (\_ b -> b)
-- * Deactivating reactive values
-- | Turning an active RV into a passive one (does not propagate changes)
-- Note that this does not really affect the RV itself, only produces a new
-- RV that will not propagate changes. So, if used in a reactive relation,
-- values will not get propagated when they change. It is useful in combination
-- with lifts, to achieve things similar to Yampa's tagging, but this might
-- be more general.
passivelyR :: (Monad m, ReactiveValueRead a b m)
=> a -> ReactiveFieldRead m b
passivelyR rv =
ReactiveFieldRead (reactiveValueRead rv) (\_ -> return ())
passivelyRW :: (Monad m, ReactiveValueReadWrite a b m)
=> a -> ReactiveFieldReadWrite m b
passivelyRW rv =
ReactiveFieldReadWrite (reactiveValueWrite rv) (reactiveValueRead rv) (\_ -> return ())
-- | A form of binary readable lifting that passifies the second RV but reads
-- exclusively from it.
--
-- governingR r1 r2 = rMerge r1 (passively r2)
governingR :: (ReactiveValueRead a b m, ReactiveValueRead c d m)
=> a -> c -> ReactiveFieldRead m d
governingR r c = ReactiveFieldRead getter notifier
where getter = reactiveValueRead c
notifier = reactiveValueOnCanRead r
-- * Conditionals
-- Check condition and notify only when holds
ifRW_ :: (Monad m, ReactiveValueRead c Bool m, ReactiveValueReadWrite v a m)
=> c -> v
-> ReactiveFieldReadWrite m a
ifRW_ c r = ReactiveFieldReadWrite setter getter notifier
where setter x = reactiveValueWrite r x
getter = reactiveValueRead r
-- If either changes, the value *may* be propagated
notifier p = do reactiveValueOnCanRead c (when' p)
reactiveValueOnCanRead r (when' p)
-- Propagate only if the condition holds
where when' m = do x <- reactiveValueRead c
when x m
-- Check condition, and write or notify only when it holds
ifRW :: (Monad m, ReactiveValueRead c Bool m, ReactiveValueReadWrite v a m)
=> c -> v
-> ReactiveFieldReadWrite m a
ifRW c r = ReactiveFieldReadWrite setter getter notifier
where setter x = do b <- reactiveValueRead c
when b $
reactiveValueWrite r x
getter = reactiveValueRead r
-- If either changes, the value *may* be propagated
notifier p = do reactiveValueOnCanRead c (when' p)
reactiveValueOnCanRead r (when' p)
-- Propagate only if the condition holds
where when' m = do b <- reactiveValueRead c
when b m
-- Check condition and notify only when holds
guardRO :: (Monad m, ReactiveValueRead c Bool m)
=> c
-> ReactiveFieldRead m Bool
guardRO c = ReactiveFieldRead getter notifier
where getter = reactiveValueRead c
-- If either changes, the value *may* be propagated
notifier p = reactiveValueOnCanRead c (when' p)
-- Propagate only if the condition holds
where when' m = do x <- reactiveValueRead c
when x m
-- Check condition and notify only when holds
guardRO' :: (Monad m, ReactiveValueRead c a m)
=> c
-> (a -> Bool)
-> ReactiveFieldRead m a
guardRO' c p = ReactiveFieldRead getter notifier
where getter = reactiveValueRead c
-- If either changes, the value *may* be propagated
notifier = reactiveValueOnCanRead c . when'
-- Propagate only if the condition holds
where when' m = do x <- reactiveValueRead c
when (p x) m
-- Category theoretic definitions
-- Functor definitions
instance (Functor m, Monad m) => Functor (ReactiveFieldRead m) where
fmap = liftR
-- FIXME: I might not want to provide this: the contravariant library
-- depends on transformers.
-- (ReactiveFieldRead getter notifier) = ReactiveFieldRead (fmap f getter) notifier
instance (Monad m) => Contravariant (ReactiveFieldWrite m) where
contramap = liftW
instance Monad m => GFunctor (ReactiveFieldReadWrite m) BijectiveFunc where
gmap = liftRW