{-# LANGUAGE DataKinds        #-}
{-# 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
    ) 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.TraversalLimit (LimitT, MonadLimit, evalLimitT)
import Codec.Capnp          (getRoot, setRoot)
import Data.Mutable         (freeze)

import qualified Capnp.Message as M

-- | 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