diff --git a/keera-hails-reactivevalues.cabal b/keera-hails-reactivevalues.cabal --- a/keera-hails-reactivevalues.cabal +++ b/keera-hails-reactivevalues.cabal @@ -6,7 +6,7 @@ build-type: Simple name: keera-hails-reactivevalues -version: 0.7.0 +version: 0.8.0 author: Ivan Perez maintainer: support@keera.co.uk homepage: http://www.keera.co.uk/blog/community/ @@ -17,8 +17,8 @@ synopsis: Haskell on Rails - Reactive Values description: This package contains a general definition of Reactive Values and several - useful combinators. A reactive value is a /typed mutable value with access - properties and change propagation/. Access property can be read-only, + useful combinators. A reactive value is a /typed mutable value with access/ + /properties and change propagation/. Access property can be read-only, read-write or read-write. . How an RV is actually implemented, and when and how change propagation is @@ -66,7 +66,7 @@ Data.ReactiveValue build-depends: - base >= 4 && < 5 + base >= 4 && < 5 , contravariant default-language: @@ -98,8 +98,8 @@ False else build-depends: - base - , hlint >= 1.7 + base >= 4 && < 5 + , hlint >= 1.7 test-suite haddock-coverage @@ -124,7 +124,7 @@ False else build-depends: - base >= 4 && < 5 + base >= 4 && < 5 , directory , filepath , process @@ -156,10 +156,12 @@ else build-depends: base >= 4 && < 5 + , mtl + + , keera-hails-reactivevalues + , HUnit , QuickCheck - , keera-hails-reactivevalues - , mtl , tasty , tasty-hunit , tasty-quickcheck diff --git a/src/Control/GFunctor.hs b/src/Control/GFunctor.hs --- a/src/Control/GFunctor.hs +++ b/src/Control/GFunctor.hs @@ -1,18 +1,15 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} --- | Functors parameterised over the morphisms in the source category. --- +{-# LANGUAGE MultiParamTypeClasses #-} +-- | -- Copyright : (C) Keera Studios Ltd, 2013 -- License : BSD3 -- Maintainer : support@keera.co.uk +-- +-- Functors parameterised over the morphisms in the source category. module Control.GFunctor where infixl 8 <$$> --- class ContravariantFunctor f where --- cmap :: (b -> a) -> f a -> f b --- - -- | A class for Functors in which the morphisms in the source category do not -- have to be of kind arrow '(->)', but can be anything (see the parameter -- 'm'). @@ -22,13 +19,9 @@ -- | Trivial instance for the arrow morphism '(->)'. Anything -- that is a functor is also a GFunctor in the trivial way. -instance (Functor a) => GFunctor a (->) where +instance Functor a => GFunctor a (->) where gmap = fmap -- | A more readable (ignorable) name for 'gmap'. (<$$>) :: GFunctor f m => m a b -> f a -> f b (<$$>) = gmap - --- class GFunctor f m => GApplicative f m where --- gpure :: a -> f a --- (<**>) :: f (m a b) -> f a -> f b diff --git a/src/Data/ReactiveValue.hs b/src/Data/ReactiveValue.hs --- a/src/Data/ReactiveValue.hs +++ b/src/Data/ReactiveValue.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -- | --- -- Copyright : (C) Keera Studios Ltd, 2013 -- License : BSD3 -- Maintainer : support@keera.co.uk @@ -48,7 +47,8 @@ -- -- -- Turn IORef into active reactive value (RV). -- -- --- -- We use the type of Reactive Fields, which have a trivial RV implementation. +-- -- We use the type of Reactive Fields, which have a trivial RV +-- -- implementation. -- let activeCBRefRV :: ReactiveFieldReadWrite IO Integer -- activeCBRefRV = ReactiveFieldReadWrite -- (writeCBRef passiveCBRef) @@ -59,9 +59,9 @@ -- let printer :: Show a => ReactiveFieldWrite IO a -- printer = wrapMW print -- --- -- Connect them using a reactive rule. In a GUI application, this code would --- -- in the controller, and would define connections between the model and --- -- the view. +-- -- Connect them using a reactive rule. In a GUI application, this code +-- -- would in the controller, and would define connections between the model +-- -- and the view. -- -- -- -- For bi-directional connections, see (=:=). -- activeCBRefRV =:> printer @@ -78,131 +78,132 @@ -- and -- -- in our repository. - module Data.ReactiveValue - ( -- * Reactive Values - -- $rvs + ( -- * Reactive Values + -- $rvs - -- ** Readable Reactive Values - -- $readablervs - ReactiveValueRead(..) + -- ** Readable Reactive Values + -- $readablervs + ReactiveValueRead(..) - -- ** Writable Reactive Values + -- ** Writable Reactive Values - -- $writablervs - , ReactiveValueWrite(..) + -- $writablervs + , ReactiveValueWrite(..) - -- ** Read-Write Reactive Values + -- ** Read-Write Reactive Values - -- $readwritervs - , ReactiveValueReadWrite + -- $readwritervs + , ReactiveValueReadWrite - -- * Reactive Relations or Rules + -- * Reactive Relations or Rules - -- $rules - , (=:>) - , (=:=) - , (<:=) + -- $rules + , (=:>) + , (=:=) + , (<:=) - -- * Reactive Fields (pure RVs) + -- * Reactive Fields (pure RVs) - -- $fields - , ReactiveFieldRead(..) - , ReactiveFieldWrite(..) - , ReactiveFieldReadWrite(..) + -- $fields + , ReactiveFieldRead(..) + , ReactiveFieldWrite(..) + , ReactiveFieldReadWrite(..) - -- $settersgetters - , FieldGetter - , FieldSetter - , FieldNotifier + -- $settersgetters + , FieldGetter + , FieldSetter + , FieldNotifier - -- * RV creation and manipulation + -- * RV creation and manipulation - -- ** Readable RVs + -- ** Readable RVs - -- $readablecombinators - , constR - , initRW - , liftR - , (<^>) - , liftR2 - , liftR3 - , liftMR - , readOnly - , wrapMR - , wrapMRPassive - , eventR - , lMerge - , rMerge + -- $readablecombinators + , constR + , initRW + , liftR + , (<^>) + , liftR2 + , liftR3 + , liftMR + , readOnly + , wrapMR + , wrapMRPassive + , eventR + , lMerge + , rMerge - -- ** Writable RVs + -- ** Writable RVs - -- $writablecombinators - , constW - , liftW - , liftW2 - , (&.&) - , liftMW - , writeOnly - , wrapMW - , wrapDo - , wrapDo_ + -- $writablecombinators + , constW + , liftW + , liftW2 + , (&.&) + , liftMW + , writeOnly + , wrapMW + , wrapDo + , wrapDo_ - -- ** Read-write RVs + -- ** Read-write RVs - -- $readwritecombinators - , liftRW - , liftRW2 - , pairRW - , modRW + -- $readwritecombinators + , liftRW + , liftRW2 + , pairRW + , modRW - -- **** Bijective functions - , BijectiveFunc - , bijection - , direct - , inverse - , Involution - , involution + -- **** Bijective functions + , BijectiveFunc + , bijection + , direct + , inverse + , Involution + , involution - -- **** Low-level operations - , reactiveValueModify + -- **** Low-level operations + , reactiveValueModify - -- * Controlling change + -- * Controlling change - -- $changecontrol + -- $changecontrol - -- ** Stopping change propagation - , eqCheck - , passivelyR - , passivelyRW + -- ** Stopping change propagation + , eqCheck + , passivelyR + , passivelyRW - -- ** Governing - , governingR - , governingRW + -- ** Governing + , governingR + , governingRW - -- ** Guarding - , ifRW - , ifRW_ - , guardRO - , guardRO' + -- ** Guarding + , ifRW + , ifRW_ + , guardRO + , guardRO' - -- * Activatable RVs + -- * Activatable RVs - -- $activatable - , ReactiveValueActivatable(..) - , ReactiveFieldActivatable - , mkActivatable - ) - where + -- $activatable + , ReactiveValueActivatable(..) + , ReactiveFieldActivatable + , mkActivatable + ) + where -import Control.Monad -import Control.GFunctor -- Functors parameterised over the morphisms - -- in the source category -import Data.Functor.Contravariant +-- External imports +import Control.Monad (liftM, void, when) +import Data.Functor.Contravariant (Contravariant (contramap)) +-- Internal imports +import Control.GFunctor (GFunctor (gmap)) + -- $rvs -- -- Reactive Values are an abstraction over values that change over the execution @@ -259,8 +260,8 @@ {-# MINIMAL reactiveValueRead #-} --- | Monadic actions are readable, but they do not provide any --- change notification. +-- | Monadic actions are readable, but they do not provide any change +-- notification. instance ReactiveValueRead (IO a) a IO where -- | Executes the monadic action and provides a value. reactiveValueRead = id @@ -271,19 +272,17 @@ -- $writablervs -- --- Writable reactive values are those that we can write to. --- They behave like sinks: there are no guarantees that anything happens, --- or result codes. +-- Writable reactive values are those that we can write to. They behave like +-- sinks: there are no guarantees that anything happens, or result codes. -- --- You are responsible of installing any potential thread-safety --- mechanisms when you implement instances, and to ensure that operations --- are executed in the right thread (some GUI toolkits may require that). --- It is important that the way that ensured that monadic actions are --- executed in the right thread can be nested; otherwise, some propagation can --- block. +-- You are responsible of installing any potential thread-safety mechanisms +-- when you implement instances, and to ensure that operations are executed in +-- the right thread (some GUI toolkits may require that). It is important that +-- the way that ensured that monadic actions are executed in the right thread +-- can be nested; otherwise, some propagation can block. --- | A minimal type class for all mutable values. Use a monad with error --- if changing the value can fail. +-- | A minimal type class for all mutable values. Use a monad with error if +-- changing the value can fail. class ReactiveValueWrite a b m | a -> b, a -> m where reactiveValueWrite :: a -> b -> m () @@ -301,8 +300,10 @@ -- | To facilitate creating RW reactive values from monadic actions, pairs -- of a getter and a setter are also RVs. -instance ReactiveValueWrite (a -> m b) a m => ReactiveValueWrite (m a, a -> m b) a m where - reactiveValueWrite (_, f) = reactiveValueWrite f +instance ReactiveValueWrite (a -> m b) a m + => ReactiveValueWrite (m a, a -> m b) a m + where + reactiveValueWrite (_, f) = reactiveValueWrite f -- $readwritervs -- @@ -311,9 +312,10 @@ -- -- | Read-write Reactive Values are trivially defined. This class only captures --- the constraints of both the other classes. There is no need to implement --- any methods. -class (ReactiveValueRead a b m, ReactiveValueWrite a b m) => ReactiveValueReadWrite a b m +-- the constraints of both the other classes. There is no need to implement any +-- methods. +class (ReactiveValueRead a b m, ReactiveValueWrite a b m) + => ReactiveValueReadWrite a b m -- | Pairs of a monadic action and a parametric monadic action are also RVs instance (Functor m, Monad m) => ReactiveValueReadWrite (m a, a -> m b) a m @@ -323,15 +325,15 @@ -- Activatable RVs are values that never hold any data, but whose change (or -- activation, or some sort of internal event) we need to be aware of). --- | A class for things with a trivial field that carries unit. Buttons --- (in any GUI library), for instance, could be a member of this class. +-- | A class for things with a trivial field that carries unit. Buttons (in any +-- GUI library), for instance, could be a member of this class. class ReactiveValueActivatable m a where defaultActivation :: a -> ReactiveFieldActivatable m -- $rules -- --- Reactive Rules are data dependency (data-passing) building combinators. --- By executing them, you install the right event handlers on the right RVs, so +-- Reactive Rules are data dependency (data-passing) building combinators. By +-- executing them, you install the right event handlers on the right RVs, so -- that values pass to the other RV. -- -- Reactive Relations cannot be independently removed. If the event-dispatching @@ -345,31 +347,42 @@ -- | 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 () +(=:>) :: Monad m + => (ReactiveValueRead a b m, ReactiveValueWrite c b m) + => a + -> c + -> m () (=:>) v1 v2 = reactiveValueOnCanRead v1 sync1 - where sync1 = reactiveValueRead v1 >>= reactiveValueWrite v2 + 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 () +(<:=) :: Monad m + => (ReactiveValueRead a b m, ReactiveValueWrite c b m) + => c + -> a + -> m () (<:=) v2 v1 = reactiveValueOnCanRead v1 sync1 - where sync1 = reactiveValueRead v1 >>= reactiveValueWrite v2 + 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 () +(=:=) :: 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. + -- 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 -- $fields --- This is a specific implementation of RVs that does not have a custom event queue. +-- This is a specific implementation of RVs that does not have a custom event +-- queue. -- -- It can be used to return RVs in the combinators, by relying on the underlying -- change detection and event notification system (underlying meaning or the RV @@ -409,10 +422,10 @@ -- $settersgetters -- --- 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. +-- 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. -- | The type of a monadic value producer (a getter, a source). type FieldGetter m a = m a @@ -421,89 +434,108 @@ type FieldSetter m a = a -> m () -- | The type of an event handler installer -type FieldNotifier m a = m () -> m () -- FIXME: why does fieldnotifier have an argument +type FieldNotifier m a = m () -> m () -- | Create an activatable RV from a handler installer. mkActivatable :: Monad m => (m () -> m ()) -> ReactiveFieldActivatable m mkActivatable f = ReactiveFieldRead getter notifier - where getter = return () - notifier = f + where + getter = return () + notifier = f -- $readablecombinators --- | A trivial RV builder with a constant value. We need this because --- we cannot have overlapping instances with a default case, and because --- the interpretation of lifting with RVs could be very confusing unless --- values are lifted into RVs explicitly. +-- | A trivial RV builder with a constant value. We need this because we cannot +-- have overlapping instances with a default case, and because the +-- interpretation of lifting with RVs could be very confusing unless values are +-- lifted into RVs explicitly. constR :: Monad m => a -> ReactiveFieldRead m a constR e = ReactiveFieldRead getter notifier - where notifier _ = return () - getter = return e + where + notifier _ = return () + getter = return e --- | TODO: Bad name. Should be eliminated or extended with a setter. +{-# DEPRECATED initRW "Deprecated in keera-hails-reactivevalues 0.8.0, use constR instead" #-} +-- | A trivial RV builder with a constant value (i.e., initialized). We need +-- this because we cannot have overlapping instances with a default case, and +-- because the interpretation of lifting with RVs could be very confusing +-- unless values are lifted into RVs explicitly. initRW :: Monad m => a -> ReactiveFieldRead m a initRW e = ReactiveFieldRead getter notifier - where notifier _ = return () - getter = return e + where + notifier _ = return () + getter = return e {-# ANN liftR "HLint: ignore Use fmap" #-} -- | 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 :: (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) + 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 +(<^>) :: (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. +-- | 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 + 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. +-- | 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 + 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 :: (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 + where + notifier = reactiveValueOnCanRead e + getter = f =<< reactiveValueRead e -- *** Lifting (source) computations into readable RVs. {-# ANN wrapMR "HLint: ignore Eta reduce" #-} --- | Wrap an reading operation and an notification installer in --- a readable reactive value. +-- | 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). +-- | 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 ())) @@ -520,30 +552,35 @@ -- | Create a constant writable RV. -- -constW :: (Monad m, ReactiveValueWrite v a m) => a -> v -> ReactiveFieldWrite m b +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). +-- | 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 + 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). +-- | 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 + => (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 + 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 +-- r1 &.& r2 = liftW2 (\x -> (x, x)) r1 r2 -- (&.&) :: (Monad m, ReactiveValueWrite a b m, ReactiveValueWrite c b m) => a -> c -> ReactiveFieldWrite m b @@ -556,7 +593,8 @@ 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 + where + setter x = reactiveValueWrite e =<< f x -- | Make a RW RV write only writeOnly :: ReactiveValueWrite r a m => r -> ReactiveFieldWrite m a @@ -568,21 +606,20 @@ wrapMW :: (a -> m ()) -> ReactiveFieldWrite m a wrapMW = ReactiveFieldWrite --- | Wrap a monadic computation in a writable reactive value. --- It discards the written value and executes the operation. +-- | 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. +-- 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. -- --- NOTE: this should be unnecessary since the introduction --- of a default 'ReactiveValueWrite' instance for monadic --- actions. +-- NOTE: this should be unnecessary since the introduction of a default +-- 'ReactiveValueWrite' instance for monadic actions. wrapDo :: m () -> ReactiveFieldWrite m a wrapDo = wrapMW . const --- | Wrap a monadic computation in a writable reactive value of type --- unit. It discards the written value and executes the operation. +-- | 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_ = wrapDo @@ -616,16 +653,20 @@ -- | Lift a bijection onto a read-write RV 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 +liftRW (BijectiveFunc (f1, f2)) e = + ReactiveFieldReadWrite setter getter notifier + where + ReactiveFieldRead getter notifier = liftR f1 e + ReactiveFieldWrite setter = liftW f2 e -- | Lift a bijection onto two read-write RVs 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 + => 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 -- | Pair two read-write RVs pairRW :: (Monad m, @@ -635,13 +676,18 @@ -> ReactiveFieldReadWrite m (b, d) pairRW = liftRW2 (bijection (id, id)) --- | Add an equality check to the setter of a Read-Write RV, effectively stopping --- all unnecessary change (the RV is not modified if it has not changed). +-- | Add an equality check to the setter of a Read-Write RV, effectively +-- stopping all unnecessary change (the RV is not modified if it has not +-- changed). {-# 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 +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 -- | Lift a function that takes an old value and a new input and creates a new @@ -650,14 +696,18 @@ 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' + where + setter c = do b <- reactiveValueRead rv + let b' = f b c + reactiveValueWrite rv b' --- | Apply a modification to an RV. This modification is not attached to --- the RV, and there are no guarantees that it will be atomic (if you need +-- | Apply a modification to an RV. This modification is not attached to the +-- RV, and there are no guarantees that it will be atomic (if you need -- atomicity, check out STM). -reactiveValueModify :: (Monad m, ReactiveValueReadWrite a b m) => a -> (b -> b) -> m () +reactiveValueModify :: (Monad m, ReactiveValueReadWrite a b m) + => a + -> (b -> b) + -> m () reactiveValueModify r f = reactiveValueWrite r . f =<< reactiveValueRead r {-# ANN lMerge "HLint: ignore Use const" #-} @@ -673,19 +723,18 @@ -- $changecontrol -- --- Sometimes you need to create complex liftings between RVs in which --- only changes to one of them should provoke change propagation. --- These combinators allow you to stop propagation (making RVs passive), --- make one RV control the change propagation of another (governance), --- filter propagation based on some condition (guards) and have a --- boolean-carrying RV guard another. +-- Sometimes you need to create complex liftings between RVs in which only +-- changes to one of them should provoke change propagation. These combinators +-- allow you to stop propagation (making RVs passive), make one RV control the +-- change propagation of another (governance), filter propagation based on some +-- condition (guards) and have a boolean-carrying RV guard another. --- 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. +-- 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. -- | Create a passive RO RV backed by another Readable RV by disabling change -- propagation. @@ -699,7 +748,10 @@ passivelyRW :: (Monad m, ReactiveValueReadWrite a b m) => a -> ReactiveFieldReadWrite m b passivelyRW rv = - ReactiveFieldReadWrite (reactiveValueWrite rv) (reactiveValueRead rv) (\_ -> return ()) + ReactiveFieldReadWrite + (reactiveValueWrite rv) + (reactiveValueRead rv) + (\_ -> return ()) -- | A form of binary readable lifting that passifies the second RV but reads -- exclusively from it. @@ -709,34 +761,37 @@ 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 + where + getter = reactiveValueRead c + notifier = reactiveValueOnCanRead r --- | A form of binary read-writable lifting that passifies the second RV but reads --- exclusively from it. +-- | A form of binary read-writable lifting that passifies the second RV but +-- reads exclusively from it. governingRW :: (ReactiveValueRead a b m, ReactiveValueReadWrite c d m) => a -> c -> ReactiveFieldReadWrite m d governingRW r c = ReactiveFieldReadWrite setter getter notifier - where getter = reactiveValueRead c - setter = reactiveValueWrite c - notifier = reactiveValueOnCanRead r + where + getter = reactiveValueRead c + setter = reactiveValueWrite c + notifier = reactiveValueOnCanRead r -- | 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) - + 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) + where -- Propagate only if the condition holds - where when' m = do b <- reactiveValueRead c - when b m + when' m = do b <- reactiveValueRead c + when b m -- | Check condition and notify only when holds (but writing occurs -- regardless). @@ -744,15 +799,16 @@ => c -> v -> ReactiveFieldReadWrite m a ifRW_ c r = ReactiveFieldReadWrite setter getter notifier - where setter = reactiveValueWrite r - getter = reactiveValueRead r - -- If either changes, the value *may* be propagated - notifier p = do reactiveValueOnCanRead c (when' p) - reactiveValueOnCanRead r (when' p) - + where + setter = reactiveValueWrite r + getter = reactiveValueRead r + -- If either changes, the value *may* be propagated + notifier p = do reactiveValueOnCanRead c (when' p) + reactiveValueOnCanRead r (when' p) + where -- Propagate only if the condition holds - where when' m = do x <- reactiveValueRead c - when x m + when' m = do x <- reactiveValueRead c + when x m -- | Check RV carrying a 'Bool', and notify only when it changes and it is -- 'True'. @@ -760,29 +816,31 @@ => c -> ReactiveFieldRead m Bool guardRO c = ReactiveFieldRead getter notifier - where getter = reactiveValueRead c - -- If either changes, the value *may* be propagated - notifier = reactiveValueOnCanRead c . when' - + where + getter = reactiveValueRead c + -- If either changes, the value *may* be propagated + notifier = reactiveValueOnCanRead c . when' + where -- Propagate only if the condition holds - where when' m = do x <- reactiveValueRead c - when x m + when' m = do x <- reactiveValueRead c + when x m --- | Check RV and notify only when condition on the value holds. --- --- (stops propagation by filtering on the new value). +-- | Check RV and notify only when condition on the value holds (stops +-- propagation by filtering on the new value). 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' + 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 + -- Propagate only if the condition holds + where + when' m = do x <- reactiveValueRead c + when (p x) m -- Category theoretic definitions @@ -790,9 +848,6 @@ 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 diff --git a/tests/Tasty.hs b/tests/Tasty.hs --- a/tests/Tasty.hs +++ b/tests/Tasty.hs @@ -1,4 +1,3 @@ ------------------------------------------------------------------------------ -- | -- Module : Main (Tasty) -- Copyright : (C) 2015 Ivan Perez @@ -12,7 +11,6 @@ -- See the following links for instructions and documentation: -- https://github.com/feuerbach/tasty -- https://ocharles.org.uk/blog/posts/2013-12-03-24-days-of-hackage-tasty.html ------------------------------------------------------------------------------ -- Testing libraries import Test.Tasty