{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
module Concur.Core.Types
( Widget(..)
, continue
, widget
, display
, mapView
, wrapView
, Suspend(..)
, SuspendF(..)
, Effect
, effect
, awaitViewAction
, MultiAlternative(..)
, loadWithIO
, remoteWidget
, unsafeBlockingIO
) where
import Concur.Core.Notify (Notify, await, newNotify, newNotifyIO, notify)
import Control.Applicative (Alternative, empty, (<|>))
import Control.Concurrent (forkIO)
import Control.Concurrent.STM (STM, atomically, retry)
import Control.Monad (MonadPlus (..))
import Control.Monad.Free (Free (..), hoistFree, liftF)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.MonadSTM (MonadSTM (..))
import Control.MultiAlternative (MultiAlternative, orr, never)
newtype Widget v a = Widget { suspend :: Free (Suspend v) a }
deriving (Functor, Applicative, Monad)
data SuspendF v a = SuspendF { view :: v, cont :: Effect a }
deriving Functor
newtype Suspend v a = Suspend { unSuspend :: IO (SuspendF v a) }
deriving Functor
type Effect a = STM (Maybe a)
continue :: Suspend v a -> Widget v a
continue = Widget . liftF
widget :: v -> Effect a -> Widget v a
widget v r = continue $ Suspend $ return $ SuspendF v r
display :: v -> Widget v a
display v = widget v retry
mapView :: (u -> v) -> Widget u a -> Widget v a
mapView f (Widget w) = Widget $ go w
where
go = hoistFree g
g (Suspend io) = Suspend $ fmap h io
h (SuspendF v c) = SuspendF (f v) c
wrapView :: Applicative f => (u -> v) -> Widget u a -> Widget (f v) a
wrapView f = mapView (pure . f)
effect :: v -> STM a -> Widget v a
effect v m = widget v $ Just <$> m
instance Monoid v => MonadSTM (Widget v) where
liftSTM = effect mempty
unsafeBlockingIO :: Monoid v => IO a -> Widget v a
unsafeBlockingIO io = continue $ Suspend $ fmap (SuspendF mempty . return . Just) io
awaitViewAction :: (Notify a -> v) -> Widget v a
awaitViewAction f = continue $ Suspend $ do
n <- newNotifyIO
return $ SuspendF (f n) (fmap Just (await n))
loadWithIO :: v -> IO a -> Widget v a
loadWithIO v io = continue $ Suspend $ do
n <- newNotifyIO
_ <- forkIO $ io >>= atomically . notify n
return $ SuspendF v (Just <$> await n)
remoteWidget :: (MultiAlternative m, MonadSTM m, Monad m) => m b -> (a -> m b) -> STM (a -> m (), m b)
remoteWidget d f = do
var <- newNotify
return (proxy var, wid var d)
where
proxy var = \a -> liftSTM $ notify var a
wid var ui = orr [Left <$> ui, Right <$> (liftSTM $ await var)] >>= either return (wid var . f)
instance Monoid v => MonadIO (Widget v) where
liftIO = loadWithIO mempty
instance Monoid v => Alternative (Widget v) where
empty = never
f <|> g = orr [f,g]
instance Monoid v => MultiAlternative (Widget v) where
never = display mempty
orr = Widget . comb . map suspend
where
peelAllFree [] = Right []
peelAllFree (Pure a : _) = Left a
peelAllFree (Free s: fs) = fmap (s:) $ peelAllFree fs
comb wfs = case peelAllFree wfs of
Left a -> pure a
Right fsio -> Free $ Suspend $ do
fs <- mapM unSuspend fsio
return $ SuspendF (mconcat $ map view fs) (merge $ map cont fs)
where
merge ws = do
(i, me) <- foldl (\prev (i,w) -> prev <|> fmap (i,) w) retry $ zip [0..] ws
return $ fmap (\e -> comb $ take i wfs ++ [e] ++ drop (i+1) wfs) me
instance Monoid v => MonadPlus (Widget v)