{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE TypeFamilies               #-}
{- |
Module: Internal.BuildPure
Description: Helpers for building capnproto messages in pure code.

This module provides some helpers for building capnproto messages and values
in pure code, using the low-level API.
-}
module Internal.BuildPure
    ( PureBuilder
    , createPure
    ) where

import Control.Monad.Catch      (Exception, MonadThrow (..), SomeException)
import Control.Monad.Catch.Pure (CatchT, runCatchT)
import Control.Monad.Primitive  (PrimMonad (..))
import Control.Monad.ST         (ST)
import Control.Monad.Trans      (MonadTrans (..))

import Capnp.Bits           (WordCount)
import Capnp.TraversalLimit (LimitT, MonadLimit, evalLimitT)
import Data.Mutable         (Thaw (..), createT)

-- | 'PureBuilder' is a monad transformer stack with the instnaces needed
-- manipulate mutable messages. @'PureBuilder' s a@ is morally equivalent
-- to @'LimitT' ('CatchT' ('ST' s)) a@
newtype PureBuilder s a = PureBuilder (LimitT (PrimCatchT (ST s)) a)
    deriving(a -> PureBuilder s b -> PureBuilder s a
(a -> b) -> PureBuilder s a -> PureBuilder s b
(forall a b. (a -> b) -> PureBuilder s a -> PureBuilder s b)
-> (forall a b. a -> PureBuilder s b -> PureBuilder s a)
-> Functor (PureBuilder s)
forall a b. a -> PureBuilder s b -> PureBuilder s a
forall a b. (a -> b) -> PureBuilder s a -> PureBuilder s b
forall s a b. a -> PureBuilder s b -> PureBuilder s a
forall s a b. (a -> b) -> PureBuilder s a -> PureBuilder s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PureBuilder s b -> PureBuilder s a
$c<$ :: forall s a b. a -> PureBuilder s b -> PureBuilder s a
fmap :: (a -> b) -> PureBuilder s a -> PureBuilder s b
$cfmap :: forall s a b. (a -> b) -> PureBuilder s a -> PureBuilder s b
Functor, Functor (PureBuilder s)
a -> PureBuilder s a
Functor (PureBuilder s)
-> (forall a. a -> PureBuilder s a)
-> (forall a b.
    PureBuilder s (a -> b) -> PureBuilder s a -> PureBuilder s b)
-> (forall a b c.
    (a -> b -> c)
    -> PureBuilder s a -> PureBuilder s b -> PureBuilder s c)
-> (forall a b.
    PureBuilder s a -> PureBuilder s b -> PureBuilder s b)
-> (forall a b.
    PureBuilder s a -> PureBuilder s b -> PureBuilder s a)
-> Applicative (PureBuilder s)
PureBuilder s a -> PureBuilder s b -> PureBuilder s b
PureBuilder s a -> PureBuilder s b -> PureBuilder s a
PureBuilder s (a -> b) -> PureBuilder s a -> PureBuilder s b
(a -> b -> c)
-> PureBuilder s a -> PureBuilder s b -> PureBuilder s c
forall s. Functor (PureBuilder s)
forall a. a -> PureBuilder s a
forall s a. a -> PureBuilder s a
forall a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s a
forall a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s b
forall a b.
PureBuilder s (a -> b) -> PureBuilder s a -> PureBuilder s b
forall s a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s a
forall s a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s b
forall s a b.
PureBuilder s (a -> b) -> PureBuilder s a -> PureBuilder s b
forall a b c.
(a -> b -> c)
-> PureBuilder s a -> PureBuilder s b -> PureBuilder s c
forall s a b c.
(a -> b -> c)
-> PureBuilder s a -> PureBuilder s b -> PureBuilder s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: PureBuilder s a -> PureBuilder s b -> PureBuilder s a
$c<* :: forall s a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s a
*> :: PureBuilder s a -> PureBuilder s b -> PureBuilder s b
$c*> :: forall s a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s b
liftA2 :: (a -> b -> c)
-> PureBuilder s a -> PureBuilder s b -> PureBuilder s c
$cliftA2 :: forall s a b c.
(a -> b -> c)
-> PureBuilder s a -> PureBuilder s b -> PureBuilder s c
<*> :: PureBuilder s (a -> b) -> PureBuilder s a -> PureBuilder s b
$c<*> :: forall s a b.
PureBuilder s (a -> b) -> PureBuilder s a -> PureBuilder s b
pure :: a -> PureBuilder s a
$cpure :: forall s a. a -> PureBuilder s a
$cp1Applicative :: forall s. Functor (PureBuilder s)
Applicative, Applicative (PureBuilder s)
a -> PureBuilder s a
Applicative (PureBuilder s)
-> (forall a b.
    PureBuilder s a -> (a -> PureBuilder s b) -> PureBuilder s b)
-> (forall a b.
    PureBuilder s a -> PureBuilder s b -> PureBuilder s b)
-> (forall a. a -> PureBuilder s a)
-> Monad (PureBuilder s)
PureBuilder s a -> (a -> PureBuilder s b) -> PureBuilder s b
PureBuilder s a -> PureBuilder s b -> PureBuilder s b
forall s. Applicative (PureBuilder s)
forall a. a -> PureBuilder s a
forall s a. a -> PureBuilder s a
forall a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s b
forall a b.
PureBuilder s a -> (a -> PureBuilder s b) -> PureBuilder s b
forall s a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s b
forall s a b.
PureBuilder s a -> (a -> PureBuilder s b) -> PureBuilder s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> PureBuilder s a
$creturn :: forall s a. a -> PureBuilder s a
>> :: PureBuilder s a -> PureBuilder s b -> PureBuilder s b
$c>> :: forall s a b. PureBuilder s a -> PureBuilder s b -> PureBuilder s b
>>= :: PureBuilder s a -> (a -> PureBuilder s b) -> PureBuilder s b
$c>>= :: forall s a b.
PureBuilder s a -> (a -> PureBuilder s b) -> PureBuilder s b
$cp1Monad :: forall s. Applicative (PureBuilder s)
Monad, Monad (PureBuilder s)
e -> PureBuilder s a
Monad (PureBuilder s)
-> (forall e a. Exception e => e -> PureBuilder s a)
-> MonadThrow (PureBuilder s)
forall s. Monad (PureBuilder s)
forall e a. Exception e => e -> PureBuilder s a
forall s e a. Exception e => e -> PureBuilder s a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> PureBuilder s a
$cthrowM :: forall s e a. Exception e => e -> PureBuilder s a
$cp1MonadThrow :: forall s. Monad (PureBuilder s)
MonadThrow, Monad (PureBuilder s)
Monad (PureBuilder s)
-> (WordCount -> PureBuilder s ()) -> MonadLimit (PureBuilder s)
WordCount -> PureBuilder s ()
forall s. Monad (PureBuilder s)
forall s. WordCount -> PureBuilder s ()
forall (m :: * -> *).
Monad m -> (WordCount -> m ()) -> MonadLimit m
invoice :: WordCount -> PureBuilder s ()
$cinvoice :: forall s. WordCount -> PureBuilder s ()
$cp1MonadLimit :: forall s. Monad (PureBuilder s)
MonadLimit)

instance PrimMonad (PureBuilder s) where
    type PrimState (PureBuilder s) = s
    primitive :: (State# (PrimState (PureBuilder s))
 -> (# State# (PrimState (PureBuilder s)), a #))
-> PureBuilder s a
primitive = LimitT (PrimCatchT (ST s)) a -> PureBuilder s a
forall s a. LimitT (PrimCatchT (ST s)) a -> PureBuilder s a
PureBuilder (LimitT (PrimCatchT (ST s)) a -> PureBuilder s a)
-> ((State# s -> (# State# s, a #))
    -> LimitT (PrimCatchT (ST s)) a)
-> (State# s -> (# State# s, a #))
-> PureBuilder s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# s -> (# State# s, a #)) -> LimitT (PrimCatchT (ST s)) a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive

runPureBuilder :: WordCount -> PureBuilder s a -> ST s (Either SomeException a)
runPureBuilder :: WordCount -> PureBuilder s a -> ST s (Either SomeException a)
runPureBuilder WordCount
limit (PureBuilder LimitT (PrimCatchT (ST s)) a
m) = PrimCatchT (ST s) a -> ST s (Either SomeException a)
forall (m :: * -> *) a.
Monad m =>
PrimCatchT m a -> m (Either SomeException a)
runPrimCatchT (PrimCatchT (ST s) a -> ST s (Either SomeException a))
-> PrimCatchT (ST s) a -> ST s (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ WordCount -> LimitT (PrimCatchT (ST s)) a -> PrimCatchT (ST s) a
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
limit LimitT (PrimCatchT (ST s)) a
m

-- | @'createPure' limit m@ creates a capnproto value in pure code according
-- to @m@, then freezes it without copying. If @m@ calls 'throwM' then
-- 'createPure' rethrows the exception in the specified monad.
createPure :: (MonadThrow m, Thaw a) => WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure :: WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure WordCount
limit forall s. PureBuilder s (Mutable s a)
m = Either SomeException a -> m a
forall e (m :: * -> *) a.
(Exception e, MonadThrow m) =>
Either e a -> m a
throwLeft (Either SomeException a -> m a) -> Either SomeException a -> m a
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either SomeException (Mutable s a)))
-> Either SomeException a
forall (f :: * -> *) a.
(Traversable f, Thaw a) =>
(forall s. ST s (f (Mutable s a))) -> f a
createT (WordCount
-> PureBuilder s (Mutable s a)
-> ST s (Either SomeException (Mutable s a))
forall s a.
WordCount -> PureBuilder s a -> ST s (Either SomeException a)
runPureBuilder WordCount
limit PureBuilder s (Mutable s a)
forall s. PureBuilder s (Mutable s a)
m)
  where
    -- I(zenhack) am surprised not to have found this in one of the various
    -- exception packages:
    throwLeft :: (Exception e, MonadThrow m) => Either e a -> m a
    throwLeft :: Either e a -> m a
throwLeft (Left e
e)  = e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e
    throwLeft (Right a
a) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | 'PrimCatchT' is a trivial wrapper around 'CatchT', which implements
-- 'PrimMonad'. This is a temporary workaround for:
--
-- https://github.com/ekmett/exceptions/issues/65
--
-- If we can get that issue fixed, we can delete this and just bump the
-- min bound on the exceptions package.
newtype PrimCatchT m a = PrimCatchT (CatchT m a)
    deriving(a -> PrimCatchT m b -> PrimCatchT m a
(a -> b) -> PrimCatchT m a -> PrimCatchT m b
(forall a b. (a -> b) -> PrimCatchT m a -> PrimCatchT m b)
-> (forall a b. a -> PrimCatchT m b -> PrimCatchT m a)
-> Functor (PrimCatchT m)
forall a b. a -> PrimCatchT m b -> PrimCatchT m a
forall a b. (a -> b) -> PrimCatchT m a -> PrimCatchT m b
forall (m :: * -> *) a b.
Monad m =>
a -> PrimCatchT m b -> PrimCatchT m a
forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> PrimCatchT m a -> PrimCatchT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PrimCatchT m b -> PrimCatchT m a
$c<$ :: forall (m :: * -> *) a b.
Monad m =>
a -> PrimCatchT m b -> PrimCatchT m a
fmap :: (a -> b) -> PrimCatchT m a -> PrimCatchT m b
$cfmap :: forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> PrimCatchT m a -> PrimCatchT m b
Functor, Functor (PrimCatchT m)
a -> PrimCatchT m a
Functor (PrimCatchT m)
-> (forall a. a -> PrimCatchT m a)
-> (forall a b.
    PrimCatchT m (a -> b) -> PrimCatchT m a -> PrimCatchT m b)
-> (forall a b c.
    (a -> b -> c)
    -> PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m c)
-> (forall a b. PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b)
-> (forall a b. PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m a)
-> Applicative (PrimCatchT m)
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m a
PrimCatchT m (a -> b) -> PrimCatchT m a -> PrimCatchT m b
(a -> b -> c) -> PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m c
forall a. a -> PrimCatchT m a
forall a b. PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m a
forall a b. PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
forall a b.
PrimCatchT m (a -> b) -> PrimCatchT m a -> PrimCatchT m b
forall a b c.
(a -> b -> c) -> PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m c
forall (m :: * -> *). Monad m => Functor (PrimCatchT m)
forall (m :: * -> *) a. Monad m => a -> PrimCatchT m a
forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m a
forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m (a -> b) -> PrimCatchT m a -> PrimCatchT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m a
*> :: PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
liftA2 :: (a -> b -> c) -> PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m c
<*> :: PrimCatchT m (a -> b) -> PrimCatchT m a -> PrimCatchT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m (a -> b) -> PrimCatchT m a -> PrimCatchT m b
pure :: a -> PrimCatchT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> PrimCatchT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (PrimCatchT m)
Applicative, Applicative (PrimCatchT m)
a -> PrimCatchT m a
Applicative (PrimCatchT m)
-> (forall a b.
    PrimCatchT m a -> (a -> PrimCatchT m b) -> PrimCatchT m b)
-> (forall a b. PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b)
-> (forall a. a -> PrimCatchT m a)
-> Monad (PrimCatchT m)
PrimCatchT m a -> (a -> PrimCatchT m b) -> PrimCatchT m b
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
forall a. a -> PrimCatchT m a
forall a b. PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
forall a b.
PrimCatchT m a -> (a -> PrimCatchT m b) -> PrimCatchT m b
forall (m :: * -> *). Monad m => Applicative (PrimCatchT m)
forall (m :: * -> *) a. Monad m => a -> PrimCatchT m a
forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m a -> (a -> PrimCatchT m b) -> PrimCatchT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> PrimCatchT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> PrimCatchT m a
>> :: PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m a -> PrimCatchT m b -> PrimCatchT m b
>>= :: PrimCatchT m a -> (a -> PrimCatchT m b) -> PrimCatchT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
PrimCatchT m a -> (a -> PrimCatchT m b) -> PrimCatchT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (PrimCatchT m)
Monad, Monad (PrimCatchT m)
e -> PrimCatchT m a
Monad (PrimCatchT m)
-> (forall e a. Exception e => e -> PrimCatchT m a)
-> MonadThrow (PrimCatchT m)
forall e a. Exception e => e -> PrimCatchT m a
forall (m :: * -> *). Monad m => Monad (PrimCatchT m)
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall (m :: * -> *) e a.
(Monad m, Exception e) =>
e -> PrimCatchT m a
throwM :: e -> PrimCatchT m a
$cthrowM :: forall (m :: * -> *) e a.
(Monad m, Exception e) =>
e -> PrimCatchT m a
$cp1MonadThrow :: forall (m :: * -> *). Monad m => Monad (PrimCatchT m)
MonadThrow)

runPrimCatchT :: Monad m => PrimCatchT m a -> m (Either SomeException a)
runPrimCatchT :: PrimCatchT m a -> m (Either SomeException a)
runPrimCatchT (PrimCatchT CatchT m a
m) = CatchT m a -> m (Either SomeException a)
forall (m :: * -> *) a. CatchT m a -> m (Either SomeException a)
runCatchT CatchT m a
m

instance MonadTrans PrimCatchT where
    lift :: m a -> PrimCatchT m a
lift = CatchT m a -> PrimCatchT m a
forall (m :: * -> *) a. CatchT m a -> PrimCatchT m a
PrimCatchT (CatchT m a -> PrimCatchT m a)
-> (m a -> CatchT m a) -> m a -> PrimCatchT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> CatchT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance PrimMonad m => PrimMonad (PrimCatchT m) where
    type PrimState (PrimCatchT m) = PrimState m
    primitive :: (State# (PrimState (PrimCatchT m))
 -> (# State# (PrimState (PrimCatchT m)), a #))
-> PrimCatchT m a
primitive = m a -> PrimCatchT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> PrimCatchT m a)
-> ((State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> (State# (PrimState m) -> (# State# (PrimState m), a #))
-> PrimCatchT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive