Created
January 25, 2020 22:30
-
-
Save seagreen/e0c49b63854dbc50f284f8e950448a1b to your computer and use it in GitHub Desktop.
temp temp temp
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment