src/RMCA/ReactiveValueAtomicUpdate.hs

   1 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 module RMCA.ReactiveValueAtomicUpdate where
   5
   6 import Data.Monoid
   7 import Data.CBRef
   8 import Data.ReactiveValue
   9
  10 reactiveValueNonAtomicUpdate :: (ReactiveValueReadWrite a b m) =>
  11                                 a -> (b -> b) -> m b
  12 reactiveValueNonAtomicUpdate rv f = do
  13   val <- reactiveValueRead rv
  14   reactiveValueWrite rv $ f val
  15   return val
  16
  17 class (ReactiveValueReadWrite a b m) => ReactiveValueAtomicUpdate a b m where
  18   reactiveValueUpdate :: a -> (b -> b) -> m b
  19
  20 reactiveValueUpdate_ :: (ReactiveValueAtomicUpdate a b m) =>
  21                         a -> (b -> b) -> m ()
  22 reactiveValueUpdate_ rv f = reactiveValueUpdate rv f >> return ()
  23
  24 reactiveValueAppend :: (Monoid b, ReactiveValueAtomicUpdate a b m) =>
  25                        a -> b -> m ()
  26 reactiveValueAppend rv val = reactiveValueUpdate_ rv (`mappend` val)
  27
  28 reactiveValueEmpty :: (Monoid b, ReactiveValueAtomicUpdate a b m) =>
  29                       a -> m b
  30 reactiveValueEmpty rv = reactiveValueUpdate rv (const mempty)
  31
  32 instance ReactiveValueRead (CBRef a) a IO where
  33   reactiveValueRead = readCBRef
  34   reactiveValueOnCanRead = installCallbackCBRef
  35
  36 instance ReactiveValueWrite (CBRef a) a IO where
  37   reactiveValueWrite = writeCBRef
  38
  39 instance ReactiveValueReadWrite (CBRef a) a IO where
  40
  41 instance ReactiveValueAtomicUpdate (CBRef a) a IO where
  42   reactiveValueUpdate rv f = atomicModifyCBRef rv (\x -> (f x, x))