temp temp temp

with2.hs

{-# LANGUAGE ScopedTypeVariables #-}

-- Based off of: https://github.com/ajnsit/concur/issues/17#issuecomment-516804859
module Lib where

import Control.Applicative
import Concur.Core
import Concur.Replica (HTML)
import Control.Concurrent.STM
import Prelude

data Delta a
  = Delta (TVar a) (TChan a)
  deriving Eq

with2
  :: forall a b r
   . Delta a
  -> Delta b
  -> ((a, b) -> Widget HTML (Either (a, b) r))
  -> Widget HTML r
with2 (Delta ref1 bcast1) (Delta ref2 bcast2) w = do
  (a, b, readA, readB) <-
    liftUnsafeBlockingIO
      $ atomically
      $ liftA4 (,,,) (readTVar ref1) (readTVar ref2) (dupTChan bcast1) (dupTChan bcast2)
  go readA readB (a, b)
  where
    go :: TChan a -> TChan b -> (a, b) -> Widget HTML r
    go readA readB (a, b) = do
      res <- fmap One2 (w (a, b)) <|> fmap Two2 (get readA readB (a, b))
      case res of
        One2 (Left (a', b')) -> do
          _ <- write readA readB (a', b')
          go readA readB (a', b')

        One2 (Right r) ->
          pure r

        Two2 (a', b') ->
          go readA readB (a', b')

    get :: forall. TChan a -> TChan b -> (a, b) -> Widget HTML (a, b)
    get readA readB (a, b) =
      liftSafeBlockingIO $ atomically $ do
        resA <- tryReadTChan readA
        resB <- tryReadTChan readB
        case (resA, resB) of
          (Nothing, Nothing) ->
            retry

          (Just a', Nothing) ->
            pure (a', b)

          (Nothing, Just b') ->
            pure (a, b')

          (Just a', Just b') ->
            pure (a', b')

    write :: TChan a -> TChan b -> (a, b) -> Widget HTML ()
    write readA readB (a, b) =
      liftUnsafeBlockingIO $ atomically $ do
        writeTVar ref1 a
        writeTVar ref2 b
        writeTChan bcast1 a
        writeTChan bcast2 b
        _ <- readTChan readA -- don't react to the values we just wrote
        _ <- readTChan readB
        pure ()

data OneOf2 a b = One2 a | Two2 b

liftA4
  :: Applicative m
  => (a -> b -> c -> d -> r)
  -> m a
  -> m b
  -> m c
  -> m d
  -> m r
liftA4 fn a b c d =
  fn <$> a <*> b <*> c <*> d