{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE ExplicitForAll   #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies     #-}
{-|
Module: Capnp.Convert
Description: Convert between messages, typed capnproto values, and (lazy)bytestring(builders).

This module provides various helper functions to convert between messages, types defined
in capnproto schema (called "values" in the rest of this module's documentation),
bytestrings (both lazy and strict), and bytestring builders.

Note that most of the functions which decode messages or raw bytes do *not* need to be
run inside of an instance of 'MonadLimit'; they choose an appropriate limit based on the
size of the input.

Note that not all conversions exist or necessarily make sense.
-}
module Capnp.Convert
    ( msgToBuilder
    , msgToLBS
    , msgToBS
    , msgToValue
    , bsToMsg
    , bsToValue
    , lbsToMsg
    , lbsToValue
    , valueToBuilder
    , valueToBS
    , valueToLBS
    , valueToMsg

    -- new API
    , msgToRaw
    , msgToParsed
    , bsToRaw
    , bsToParsed
    , lbsToRaw
    , lbsToParsed
    , parsedToRaw
    , parsedToMsg
    , parsedToBuilder
    , parsedToBS
    , parsedToLBS
    ) where

import Control.Monad       ((>=>))
import Control.Monad.Catch (MonadThrow)
import Data.Foldable       (foldlM)

import qualified Data.ByteString         as BS
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy    as LBS

import Capnp.Classes

import Capnp.Bits           (WordCount)
import Capnp.Message        (Mutability(..))
import Capnp.New.Classes    (Parse(encode, parse))
import Capnp.TraversalLimit (LimitT, MonadLimit, evalLimitT)
import Codec.Capnp          (getRoot, setRoot)
import Data.Mutable         (freeze)

import qualified Capnp.Message as M
import qualified Capnp.Repr    as R
import qualified Capnp.Untyped as U

-- | Compute a reasonable limit based on the size of a message. The limit
-- is the total number of words in all of the message's segments, multiplied
-- by 10 to provide some slack for decoding default values.
limitFromMsg :: (MonadThrow m, M.MonadReadMessage mut m) => M.Message mut -> m WordCount
limitFromMsg :: Message mut -> m WordCount
limitFromMsg Message mut
msg = do
    WordCount
messageWords <- m WordCount
countMessageWords
    WordCount -> m WordCount
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WordCount
messageWords WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
* WordCount
10)
  where
    countMessageWords :: m WordCount
countMessageWords = do
        Int
segCount <- Message mut -> m Int
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m Int
M.numSegs Message mut
msg
        (WordCount -> Int -> m WordCount)
-> WordCount -> [Int] -> m WordCount
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
            (\WordCount
total Int
i -> do
                WordCount
words <- Message mut -> Int -> m (Segment mut)
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> Int -> m (Segment mut)
M.getSegment Message mut
msg Int
i m (Segment mut) -> (Segment mut -> m WordCount) -> m WordCount
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Segment mut -> m WordCount
forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Segment mut -> m WordCount
M.numWords
                WordCount -> m WordCount
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WordCount
words WordCount -> WordCount -> WordCount
forall a. Num a => a -> a -> a
+ WordCount
total)
            )
            WordCount
0
            [Int
0..Int
segCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

-- | Convert an immutable message to a bytestring 'BB.Builder'.
-- To convert a mutable message, 'freeze' it first.
msgToBuilder :: M.Message 'Const -> BB.Builder
msgToBuilder :: Message 'Const -> Builder
msgToBuilder = Message 'Const -> Builder
M.encode

-- | Convert an immutable message to a lazy 'LBS.ByteString'.
-- To convert a mutable message, 'freeze' it first.
msgToLBS :: M.Message 'Const -> LBS.ByteString
msgToLBS :: Message 'Const -> ByteString
msgToLBS = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString)
-> (Message 'Const -> Builder) -> Message 'Const -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message 'Const -> Builder
msgToBuilder

-- | Convert an immutable message to a strict 'BS.ByteString'.
-- To convert a mutable message, 'freeze' it first.
msgToBS :: M.Message 'Const -> BS.ByteString
msgToBS :: Message 'Const -> ByteString
msgToBS = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Message 'Const -> ByteString) -> Message 'Const -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message 'Const -> ByteString
msgToLBS

-- | Convert a message to a value.
msgToValue :: (MonadThrow m, M.MonadReadMessage mut (LimitT m), M.MonadReadMessage mut m, FromStruct mut a) => M.Message mut -> m a
msgToValue :: Message mut -> m a
msgToValue Message mut
msg = do
    WordCount
limit <- Message mut -> m WordCount
forall (m :: * -> *) (mut :: Mutability).
(MonadThrow m, MonadReadMessage mut m) =>
Message mut -> m WordCount
limitFromMsg Message mut
msg
    WordCount -> LimitT m a -> m a
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
limit (Message mut -> LimitT m a
forall (mut :: Mutability) a (m :: * -> *).
(FromStruct mut a, ReadCtx m mut) =>
Message mut -> m a
getRoot Message mut
msg)

-- | Convert a strict 'BS.ByteString' to a message.
bsToMsg :: MonadThrow m => BS.ByteString -> m (M.Message 'Const)
bsToMsg :: ByteString -> m (Message 'Const)
bsToMsg = ByteString -> m (Message 'Const)
forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
M.decode

-- | Convert a strict 'BS.ByteString' to a value.
bsToValue :: (MonadThrow m, FromStruct 'Const a) => BS.ByteString -> m a
bsToValue :: ByteString -> m a
bsToValue = ByteString -> m (Message 'Const)
forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
bsToMsg (ByteString -> m (Message 'Const))
-> (Message 'Const -> m a) -> ByteString -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Message 'Const -> m a
forall (m :: * -> *) (mut :: Mutability) a.
(MonadThrow m, MonadReadMessage mut (LimitT m),
 MonadReadMessage mut m, FromStruct mut a) =>
Message mut -> m a
msgToValue

-- | Convert a lazy 'LBS.ByteString' to a message.
lbsToMsg :: MonadThrow m => LBS.ByteString -> m (M.Message 'Const)
lbsToMsg :: ByteString -> m (Message 'Const)
lbsToMsg = ByteString -> m (Message 'Const)
forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
bsToMsg (ByteString -> m (Message 'Const))
-> (ByteString -> ByteString) -> ByteString -> m (Message 'Const)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict

-- | Convert a lazy 'LBS.ByteString' to a value.
lbsToValue :: (MonadThrow m, FromStruct 'Const a) => LBS.ByteString -> m a
lbsToValue :: ByteString -> m a
lbsToValue = ByteString -> m a
forall (m :: * -> *) a.
(MonadThrow m, FromStruct 'Const a) =>
ByteString -> m a
bsToValue (ByteString -> m a)
-> (ByteString -> ByteString) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict

-- | Convert a value to a 'BS.Builder'.
valueToBuilder :: (MonadLimit m, M.WriteCtx m s, Cerialize s a, ToStruct ('Mut s) (Cerial ('Mut s) a)) => a -> m BB.Builder
valueToBuilder :: a -> m Builder
valueToBuilder a
val = Message 'Const -> Builder
msgToBuilder (Message 'Const -> Builder) -> m (Message 'Const) -> m Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m (Message ('Mut s))
forall (m :: * -> *) s a.
(MonadLimit m, WriteCtx m s, Cerialize s a,
 ToStruct ('Mut s) (Cerial ('Mut s) a)) =>
a -> m (Message ('Mut s))
valueToMsg a
val m (Message ('Mut s))
-> (Message ('Mut s) -> m (Message 'Const)) -> m (Message 'Const)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message ('Mut s) -> m (Message 'Const)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze)

-- | Convert a value to a strict 'BS.ByteString'.
valueToBS :: (MonadLimit m, M.WriteCtx m s, Cerialize s a, ToStruct ('Mut s) (Cerial ('Mut s) a)) => a -> m BS.ByteString
valueToBS :: a -> m ByteString
valueToBS = (ByteString -> ByteString) -> m ByteString -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
LBS.toStrict (m ByteString -> m ByteString)
-> (a -> m ByteString) -> a -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m ByteString
forall (m :: * -> *) s a.
(MonadLimit m, WriteCtx m s, Cerialize s a,
 ToStruct ('Mut s) (Cerial ('Mut s) a)) =>
a -> m ByteString
valueToLBS

-- | Convert a value to a lazy 'LBS.ByteString'.
valueToLBS :: (MonadLimit m, M.WriteCtx m s, Cerialize s a, ToStruct ('Mut s) (Cerial ('Mut s) a)) => a -> m LBS.ByteString
valueToLBS :: a -> m ByteString
valueToLBS = (Builder -> ByteString) -> m Builder -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> ByteString
BB.toLazyByteString (m Builder -> m ByteString)
-> (a -> m Builder) -> a -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Builder
forall (m :: * -> *) s a.
(MonadLimit m, WriteCtx m s, Cerialize s a,
 ToStruct ('Mut s) (Cerial ('Mut s) a)) =>
a -> m Builder
valueToBuilder

-- | Convert a value to a message.
valueToMsg :: (MonadLimit m, M.WriteCtx m s, Cerialize s a, ToStruct ('Mut s) (Cerial ('Mut s) a)) => a -> m (M.Message ('Mut s))
valueToMsg :: a -> m (Message ('Mut s))
valueToMsg a
val = do
    Message ('Mut s)
msg <- Maybe WordCount -> m (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
M.newMessage Maybe WordCount
forall a. Maybe a
Nothing
    Cerial ('Mut s) a
ret <- Message ('Mut s) -> a -> m (Cerial ('Mut s) a)
forall s a (m :: * -> *).
(Cerialize s a, RWCtx m s) =>
Message ('Mut s) -> a -> m (Cerial ('Mut s) a)
cerialize Message ('Mut s)
msg a
val
    Cerial ('Mut s) a -> m ()
forall s a (m :: * -> *).
(ToStruct ('Mut s) a, WriteCtx m s) =>
a -> m ()
setRoot Cerial ('Mut s) a
ret
    Message ('Mut s) -> m (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message ('Mut s)
msg

-- | Get the root pointer of a message, wrapped as a 'R.Raw'.
msgToRaw :: forall a m mut. (U.ReadCtx m mut, R.IsStruct a) => M.Message mut -> m (R.Raw mut a)
msgToRaw :: Message mut -> m (Raw mut a)
msgToRaw = (Struct mut -> Raw mut a) -> m (Struct mut) -> m (Raw mut a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Struct mut -> Raw mut a
forall (mut :: Mutability) a. Untyped mut (ReprFor a) -> Raw mut a
R.Raw (m (Struct mut) -> m (Raw mut a))
-> (Message mut -> m (Struct mut)) -> Message mut -> m (Raw mut a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message mut -> m (Struct mut)
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m (Struct mut)
U.rootPtr

-- | Get the root pointer of a message, as a parsed ADT.
msgToParsed :: forall a m pa. (U.ReadCtx m 'Const, R.IsStruct a, Parse a pa) => M.Message 'Const -> m pa
msgToParsed :: Message 'Const -> m pa
msgToParsed Message 'Const
msg = Message 'Const -> m (Raw 'Const a)
forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, IsStruct a) =>
Message mut -> m (Raw mut a)
msgToRaw Message 'Const
msg m (Raw 'Const a) -> (Raw 'Const a -> m pa) -> m pa
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Raw 'Const a -> m pa
forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw 'Const t -> m p
parse

-- | Like 'msgToRaw', but takes a (strict) bytestring.
bsToRaw :: (U.ReadCtx m 'Const, R.IsStruct a) => BS.ByteString -> m (R.Raw 'Const a)
bsToRaw :: ByteString -> m (Raw 'Const a)
bsToRaw ByteString
bs = ByteString -> m (Message 'Const)
forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
bsToMsg ByteString
bs m (Message 'Const)
-> (Message 'Const -> m (Raw 'Const a)) -> m (Raw 'Const a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message 'Const -> m (Raw 'Const a)
forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, IsStruct a) =>
Message mut -> m (Raw mut a)
msgToRaw

-- | Like 'msgToParsed', but takes a (strict) bytestring.
bsToParsed :: (U.ReadCtx m 'Const, R.IsStruct a, Parse a pa) => BS.ByteString -> m pa
bsToParsed :: ByteString -> m pa
bsToParsed ByteString
bs = ByteString -> m (Raw 'Const a)
forall (m :: * -> *) a.
(ReadCtx m 'Const, IsStruct a) =>
ByteString -> m (Raw 'Const a)
bsToRaw ByteString
bs m (Raw 'Const a) -> (Raw 'Const a -> m pa) -> m pa
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Raw 'Const a -> m pa
forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw 'Const t -> m p
parse

-- | Like 'msgToRaw', but takes a (lazy) bytestring.
lbsToRaw :: (U.ReadCtx m 'Const, R.IsStruct a) => LBS.ByteString -> m (R.Raw 'Const a)
lbsToRaw :: ByteString -> m (Raw 'Const a)
lbsToRaw = ByteString -> m (Raw 'Const a)
forall (m :: * -> *) a.
(ReadCtx m 'Const, IsStruct a) =>
ByteString -> m (Raw 'Const a)
bsToRaw (ByteString -> m (Raw 'Const a))
-> (ByteString -> ByteString) -> ByteString -> m (Raw 'Const a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict

-- | Like 'msgToParsed', but takes a (lazzy) bytestring.
lbsToParsed :: (U.ReadCtx m 'Const, R.IsStruct a, Parse a pa) => LBS.ByteString -> m pa
lbsToParsed :: ByteString -> m pa
lbsToParsed = ByteString -> m pa
forall (m :: * -> *) a pa.
(ReadCtx m 'Const, IsStruct a, Parse a pa) =>
ByteString -> m pa
bsToParsed (ByteString -> m pa)
-> (ByteString -> ByteString) -> ByteString -> m pa
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict

-- | Serialize the parsed form of a struct into its 'R.Raw' form, and make it the root
-- of its message.
parsedToRaw :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m (R.Raw ('Mut s) a)
parsedToRaw :: pa -> m (Raw ('Mut s) a)
parsedToRaw pa
p = do
    Message ('Mut s)
msg <- Maybe WordCount -> m (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
M.newMessage Maybe WordCount
forall a. Maybe a
Nothing
    value :: Raw ('Mut s) a
value@(R.Raw Untyped ('Mut s) (ReprFor a)
struct) <- Message ('Mut s) -> pa -> m (Raw ('Mut s) a)
forall t p (m :: * -> *) s.
(Parse t p, RWCtx m s) =>
Message ('Mut s) -> p -> m (Raw ('Mut s) t)
encode Message ('Mut s)
msg pa
p
    Struct ('Mut s) -> m ()
forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
U.setRoot Struct ('Mut s)
Untyped ('Mut s) (ReprFor a)
struct
    Raw ('Mut s) a -> m (Raw ('Mut s) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raw ('Mut s) a
value

-- | Serialize the parsed form of a struct into a message with that value as its
-- root, returning the message.
parsedToMsg :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m (M.Message ('Mut s))
parsedToMsg :: pa -> m (Message ('Mut s))
parsedToMsg pa
p = do
    Raw ('Mut s) a
root <- pa -> m (Raw ('Mut s) a)
forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Raw ('Mut s) a)
parsedToRaw pa
p
    Message ('Mut s) -> m (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message ('Mut s) -> m (Message ('Mut s)))
-> Message ('Mut s) -> m (Message ('Mut s))
forall a b. (a -> b) -> a -> b
$ Raw ('Mut s) a -> Message ('Mut s)
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
U.message Raw ('Mut s) a
root

-- | Serialize the parsed form of a struct and return it as a 'BB.Builder'
parsedToBuilder :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m BB.Builder
parsedToBuilder :: pa -> m Builder
parsedToBuilder pa
p = Message 'Const -> Builder
msgToBuilder (Message 'Const -> Builder) -> m (Message 'Const) -> m Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (pa -> m (Message ('Mut s))
forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Message ('Mut s))
parsedToMsg pa
p m (Message ('Mut s))
-> (Message ('Mut s) -> m (Message 'Const)) -> m (Message 'Const)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message ('Mut s) -> m (Message 'Const)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze)

-- | Serialize the parsed form of a struct and return it as a lazy 'LBS.ByteString'
parsedToLBS :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m LBS.ByteString
parsedToLBS :: pa -> m ByteString
parsedToLBS = (Builder -> ByteString) -> m Builder -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> ByteString
BB.toLazyByteString (m Builder -> m ByteString)
-> (pa -> m Builder) -> pa -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. pa -> m Builder
forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m Builder
parsedToBuilder

-- | Serialize the parsed form of a struct and return it as a strict 'BS.ByteString'
parsedToBS :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m BS.ByteString
parsedToBS :: pa -> m ByteString
parsedToBS = (ByteString -> ByteString) -> m ByteString -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
LBS.toStrict (m ByteString -> m ByteString)
-> (pa -> m ByteString) -> pa -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. pa -> m ByteString
forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m ByteString
parsedToLBS