{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Shpadoinkle.Continuation (
Continuation (..)
, runContinuation
, done, pur, impur, kleisli, causes, contIso
, Continuous (..)
, hoist
, voidC', voidC, forgetC
, liftC', liftCMay', liftC, liftCMay
, leftC', leftC, rightC', rightC
, eitherC', eitherC
, maybeC', maybeC, comaybe, comaybeC', comaybeC
, writeUpdate, shouldUpdate, constUpdate
, ContinuationT (..), voidRunContinuationT, kleisliT, commit
) where
import Control.Arrow (first)
import qualified Control.Categorical.Functor as F
import Control.Monad (liftM2, void)
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.PseudoInverseCategory (EndoIso (..))
import Data.Maybe (fromMaybe)
import GHC.Conc (retry)
import UnliftIO (MonadUnliftIO, TVar, atomically,
newTVarIO, readTVar, readTVarIO,
writeTVar)
import UnliftIO.Concurrent (forkIO)
data Continuation m a = Continuation (a -> a, a -> m (Continuation m a))
| Rollback (Continuation m a)
| Pure (a -> a)
pur :: (a -> a) -> Continuation m a
pur = Pure
done :: Continuation m a
done = pur id
impur :: Monad m => m (a -> a) -> Continuation m a
impur m = Continuation . (id,) . const $ do
f <- m
return $ Continuation (f, const (return done))
kleisli :: (a -> m (Continuation m a)) -> Continuation m a
kleisli = Continuation . (id,)
causes :: Monad m => m () -> Continuation m a
causes m = impur (m >> return id)
runContinuation :: Monad m => Continuation m a -> a -> m (a -> a)
runContinuation = runContinuation' id
runContinuation' :: Monad m => (a -> a) -> Continuation m a -> a -> m (a -> a)
runContinuation' f (Continuation (g, h)) x = do
i <- h (f x)
runContinuation' (g.f) i x
runContinuation' _ (Rollback f) x = runContinuation' id f x
runContinuation' f (Pure g) _ = return (g.f)
class Continuous f where
mapC :: (Continuation m a -> Continuation m b) -> f m a -> f m b
instance Continuous Continuation where
mapC = id
hoist :: Functor m => (forall b. m b -> n b) -> Continuation m a -> Continuation n a
hoist _ (Pure f) = Pure f
hoist f (Rollback r) = Rollback (hoist f r)
hoist f (Continuation (g, h)) = Continuation . (g,) $ \x -> f $ hoist f <$> h x
liftC' :: Functor m => (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b
liftC' f g (Pure h) = Pure (\x -> f (h (g x)) x)
liftC' f g (Rollback r) = Rollback (liftC' f g r)
liftC' f g (Continuation (h, i)) = Continuation (\x -> f (h (g x)) x, \x -> liftC' f g <$> i (g x))
liftCMay' :: Applicative m => (a -> b -> b) -> (b -> Maybe a) -> Continuation m a -> Continuation m b
liftCMay' f g (Pure h) = Pure $ \x -> maybe x (flip f x . h) $ g x
liftCMay' f g (Rollback r) = Rollback (liftCMay' f g r)
liftCMay' f g (Continuation (h, i)) =
Continuation (\x -> maybe x (flip f x . h) $ g x, maybe (pure done) (fmap (liftCMay' f g) . i) . g)
liftC :: Functor m => Continuous f => (a -> b -> b) -> (b -> a) -> f m a -> f m b
liftC f g = mapC (liftC' f g)
liftCMay :: Applicative m => Continuous f => (a -> b -> b) -> (b -> Maybe a) -> f m a -> f m b
liftCMay f g = mapC (liftCMay' f g)
voidC' :: Monad m => Continuation m () -> Continuation m a
voidC' f = Continuation . (id,) $ \_ -> do
_ <- runContinuation f ()
return done
voidC :: Monad m => Continuous f => f m () -> f m a
voidC = mapC voidC'
forgetC :: Continuous f => f m a -> f m b
forgetC = mapC (const done)
leftC' :: Functor m => Continuation m a -> Continuation m (a,b)
leftC' = liftC' (\x (_,y) -> (x,y)) fst
leftC :: Functor m => Continuous f => f m a -> f m (a,b)
leftC = mapC leftC'
rightC' :: Functor m => Continuation m b -> Continuation m (a,b)
rightC' = liftC' (\y (x,_) -> (x,y)) snd
rightC :: Functor m => Continuous f => f m b -> f m (a,b)
rightC = mapC rightC'
maybeC' :: Applicative m => Continuation m a -> Continuation m (Maybe a)
maybeC' (Pure f) = Pure (fmap f)
maybeC' (Rollback r) = Rollback (maybeC' r)
maybeC' (Continuation (f, g)) = Continuation . (fmap f,) $
\case
Just x -> maybeC' <$> g x
Nothing -> pure (Rollback done)
maybeC :: Applicative m => Continuous f => f m a -> f m (Maybe a)
maybeC = mapC maybeC'
comaybe :: (Maybe a -> Maybe a) -> (a -> a)
comaybe f x = fromMaybe x . f $ Just x
comaybeC' :: Functor m => Continuation m (Maybe a) -> Continuation m a
comaybeC' (Pure f) = Pure (comaybe f)
comaybeC' (Rollback r) = Rollback (comaybeC' r)
comaybeC' (Continuation (f,g)) = Continuation (comaybe f, fmap comaybeC' . g . Just)
comaybeC :: Functor m => Continuous f => f m (Maybe a) -> f m a
comaybeC = mapC comaybeC'
mapLeft :: (a -> b) -> Either a c -> Either b c
mapLeft f (Left x) = Left (f x)
mapLeft _ (Right x) = Right x
mapRight :: (b -> c) -> Either a b -> Either a c
mapRight _ (Left x) = Left x
mapRight f (Right x) = Right (f x)
eitherC' :: Monad m => Continuation m a -> Continuation m b -> Continuation m (Either a b)
eitherC' f g = Continuation . (id,) $ \case
Left x -> case f of
Pure h -> return (Pure (mapLeft h))
Rollback r -> return . Rollback $ eitherC' r done
Continuation (h, i) -> do
j <- i x
return $ Continuation (mapLeft h, const . return $ eitherC' j (Rollback done))
Right x -> case g of
Pure h -> return (Pure (mapRight h))
Rollback r -> return . Rollback $ eitherC' done r
Continuation (h, i) -> do
j <- i x
return $ Continuation (mapRight h, const . return $ eitherC' (Rollback done) j)
eitherC :: Monad m => Continuous f => (a -> f m a) -> (b -> f m b) -> Either a b -> f m (Either a b)
eitherC l _ (Left x) = mapC (\c -> eitherC' c (pur id)) (l x)
eitherC _ r (Right x) = mapC (eitherC' (pur id)) (r x)
contIso :: Functor m => (a -> b) -> (b -> a) -> Continuation m a -> Continuation m b
contIso f g (Continuation (h, i)) = Continuation (f.h.g, fmap (contIso f g) . i . g)
contIso f g (Rollback h) = Rollback (contIso f g h)
contIso f g (Pure h) = Pure (f.h.g)
instance Applicative m => F.Functor EndoIso EndoIso (Continuation m) where
map (EndoIso f g h) =
EndoIso (Continuation . (f,) . const . pure) (contIso g h) (contIso h g)
instance Monad m => Semigroup (Continuation m a) where
(Continuation (f, g)) <> (Continuation (h, i)) =
Continuation (f.h, \x -> liftM2 (<>) (g x) (i x))
(Continuation (f, g)) <> (Rollback h) =
Rollback (Continuation (f, \x -> liftM2 (<>) (g x) (return h)))
(Rollback h) <> (Continuation (_, g)) =
Rollback (Continuation (id, fmap (h <>) . g))
(Rollback f) <> (Rollback g) = Rollback (f <> g)
(Pure f) <> (Pure g) = Pure (f.g)
(Pure f) <> (Continuation (g,h)) = Continuation (f.g,h)
(Continuation (f,g)) <> (Pure h) = Continuation (f.h,g)
(Pure f) <> (Rollback g) = Continuation (f, const (return (Rollback g)))
(Rollback f) <> (Pure _) = Rollback f
instance Monad m => Monoid (Continuation m a) where
mempty = done
writeUpdate' :: MonadUnliftIO m => (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()
writeUpdate' h model f = do
i <- readTVarIO model
m <- f (h i)
case m of
Continuation (g,gs) -> writeUpdate' (g.h) model gs
Pure g -> atomically (writeTVar model . g . h =<< readTVar model)
Rollback gs -> writeUpdate' id model (const (return gs))
writeUpdate :: MonadUnliftIO m => TVar a -> Continuation m a -> m ()
writeUpdate model = \case
Continuation (f,g) -> void . forkIO $ writeUpdate' f model g
Pure f -> atomically (writeTVar model . f =<< readTVar model)
Rollback f -> writeUpdate model f
shouldUpdate :: MonadUnliftIO m => Eq a => (b -> a -> m b) -> b -> TVar a -> m ()
shouldUpdate sun prev model = do
i' <- readTVarIO model
p <- newTVarIO i'
() <$ forkIO (go prev p)
where
go x p = do
a <- atomically $ do
new' <- readTVar model
old <- readTVar p
if new' == old then retry else new' <$ writeTVar p new'
y <- sun x a
go y p
newtype ContinuationT model m a = ContinuationT
{ runContinuationT :: m (a, Continuation m model) }
commit :: Monad m => Continuation m model -> ContinuationT model m ()
commit = ContinuationT . return . ((),)
voidRunContinuationT :: Monad m => ContinuationT model m a -> Continuation m model
voidRunContinuationT m = Continuation . (id,) . const $ snd <$> runContinuationT m
kleisliT :: Monad m => (model -> ContinuationT model m a) -> Continuation m model
kleisliT f = kleisli $ \x -> return . voidRunContinuationT $ f x
instance Functor m => Functor (ContinuationT model m) where
fmap f = ContinuationT . fmap (first f) . runContinuationT
instance Monad m => Applicative (ContinuationT model m) where
pure = ContinuationT . pure . (, done)
ft <*> xt = ContinuationT $ do
(f, fc) <- runContinuationT ft
(x, xc) <- runContinuationT xt
return (f x, fc <> xc)
instance Monad m => Monad (ContinuationT model m) where
return = ContinuationT . return . (, done)
m >>= f = ContinuationT $ do
(x, g) <- runContinuationT m
(y, h) <- runContinuationT (f x)
return (y, g <> h)
instance MonadTrans (ContinuationT model) where
lift = ContinuationT . fmap (, done)
constUpdate :: a -> Continuation m a
constUpdate = pur . const
{-# INLINE constUpdate #-}