with* Concur shared state combinators

ConcurState.hs

data Δ a = Value (TVar a) (TChan a) deriving Eq

data Lens s t

mapValue :: Lens s t -> Δ t -> Δ s
mapValue = undefined

pairValues :: Lens a t -> Lens b t -> Δ a -> Δ b -> Δ t
pairValues = undefined

localIO :: a -> IO (Δ a)
localIO a = atomically $ liftA2 Value (newTVar a) newBroadcastTChan

local :: a -> (Δ a -> Widget HTML b) -> Widget HTML b
local a f = do
  v <- liftUnsafeBlockingIO
    $ atomically
    $ liftA2 Value (newTVar a) newBroadcastTChan
  f v

put :: Δ a -> a -> Widget HTML ()
put (Value ref bcast) a = liftUnsafeBlockingIO $ atomically $ do
  writeTVar ref a
  writeTChan bcast a

observe :: Δ a -> (a -> Widget HTML r) -> Widget HTML r
observe (Value ref bcast) w = do
  (a, read) <- liftUnsafeBlockingIO
    $ atomically
    $ liftA2 (,) (readTVar ref) (dupTChan bcast)
  go read a
  where
    go read a = do
      r <- fmap Left (w a) <|> fmap Right (get read)
      case r of
        Right a' -> go read a'
        Left r   -> pure r

    get read = liftSafeBlockingIO $ atomically $ readTChan read

with :: Δ a -> ((a -> Widget HTML r) -> a -> Widget HTML r) -> Widget HTML r
with (Value ref bcast) w = do
  (a, read) <- liftUnsafeBlockingIO
    $ atomically
    $ liftA2 (,) (readTVar ref) (dupTChan bcast)
  go read a
  where
    recur read a = w (\a' -> write read a' >>= recur read) a

    go read a = do
      r <- fmap Left (recur read a) <|> fmap Right (get read)
      case r of
        Right a' -> go read a'
        Left r'  -> pure r'

    get read = liftSafeBlockingIO $ atomically $ readTChan read

    write read a = liftUnsafeBlockingIO $ atomically $ do
      writeTVar ref a
      writeTChan bcast a
      readTChan read

data Step a b = Recur a | Done b

recur :: a -> Step a b
recur  = Recur

done :: b -> Step a b
done  = Done

withE :: Δ a -> (a -> Widget HTML (Step a r)) -> Widget HTML r
withE (Value ref bcast) w = do
  (a, read) <- liftUnsafeBlockingIO
    $ atomically
    $ liftA2 (,) (readTVar ref) (dupTChan bcast)
  go read a
  where
    go read a = do
      r <- fmap Left (w a) <|> fmap Right (get read)
      case r of
        Right a' -> go read a'
        Left (Recur a') -> do
          write read a'
          go read a'
        Left (Done b) -> pure b

    get read = liftSafeBlockingIO $ atomically $ readTChan read

    write read a = liftUnsafeBlockingIO $ atomically $ do
      writeTVar ref a
      writeTChan bcast a
      readTChan read

withE2 :: Δ a -> Δ b -> (a -> b -> Widget HTML (Step (a, b) r)) -> Widget HTML r
withE2 (Value refa bcasta) (Value refb bcastb) w = do
  (a, reada, b, readb) <- liftUnsafeBlockingIO
    $ atomically
    $ (,,,) <$> readTVar refa <*> dupTChan bcasta <*> readTVar refb <*> dupTChan bcastb
  go reada a readb b
  where
    go reada a readb b = do
      r <- fmap Left (w a b) <|> fmap Right (get reada a readb b)
      case r of
        Right (a', b') -> go reada a' readb b'
        Left (Recur (a', b')) -> do
          liftUnsafeBlockingIO $ atomically $ do
            write refa bcasta reada a'
            write refb bcastb readb b'
          go reada a' readb b'
        Left (Done r) -> pure r

    get reada a readb b = liftSafeBlockingIO $ atomically $ do
      r <- fmap Left (readTChan reada) <|> fmap Right (readTChan readb)
      case r of
        Left a'  -> (a',) . fromMaybe b <$> tryReadTChan readb
        Right b' -> (,b') . fromMaybe a <$> tryReadTChan reada

    write ref bcast read a = do
      writeTVar ref a
      writeTChan bcast a
      readTChan read