{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ExplicitForAll      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# 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
    , bsToMsg
    , lbsToMsg

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

import Control.Monad.Catch (MonadThrow)

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

import Capnp.Mutability  (Mutability(..), freeze)
import Capnp.New.Classes (Parse(encode, parse))

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

{- TODO: unused currently, but we should put it back into service for things like
   msgToParsed.

-- | 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 msg = do
    messageWords <- countMessageWords
    pure (messageWords * 10)
  where
    countMessageWords = do
        segCount <- M.numSegs msg
        foldlM
            (\total i -> do
                words <- M.getSegment msg i >>= M.numWords
                pure (words + total)
            )
            0
            [0..segCount - 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 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 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

-- | 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 a mut)
msgToRaw :: Message mut -> m (Raw a mut)
msgToRaw = (Struct mut -> Raw a mut) -> m (Struct mut) -> m (Raw a mut)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Struct mut -> Raw a mut
forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw (m (Struct mut) -> m (Raw a mut))
-> (Message mut -> m (Struct mut)) -> Message mut -> m (Raw a mut)
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 a 'Const)
forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, IsStruct a) =>
Message mut -> m (Raw a mut)
msgToRaw Message 'Const
msg m (Raw a 'Const) -> (Raw a 'Const -> m pa) -> m pa
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Raw a 'Const -> m pa
forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse

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

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

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

-- | Like 'msgToParsed', but takes a (lazzy) bytestring.
lbsToParsed :: forall a pa m. (U.ReadCtx m 'Const, R.IsStruct a, Parse a pa) => LBS.ByteString -> m pa
lbsToParsed :: ByteString -> m pa
lbsToParsed = ByteString -> m pa
forall a pa (m :: * -> *).
(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 a ('Mut s))
parsedToRaw :: pa -> m (Raw a ('Mut s))
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 a ('Mut s)
value@(R.Raw Unwrapped (Untyped (ReprFor a) ('Mut s))
struct) <- Message ('Mut s) -> pa -> m (Raw a ('Mut s))
forall t p (m :: * -> *) s.
(Parse t p, RWCtx m s) =>
Message ('Mut s) -> p -> m (Raw t ('Mut s))
encode Message ('Mut s)
msg pa
p
    Struct ('Mut s) -> m ()
forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
U.setRoot Unwrapped (Untyped (ReprFor a) ('Mut s))
Struct ('Mut s)
struct
    Raw a ('Mut s) -> m (Raw a ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Raw a ('Mut s)
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 a ('Mut s)
root <- pa -> m (Raw a ('Mut s))
forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Raw a ('Mut s))
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
$ Unwrapped (Raw a ('Mut s)) -> Message ('Mut s)
forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
U.message @(R.Raw a) Unwrapped (Raw a ('Mut s))
Raw a ('Mut s)
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 (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f ('Mut s) -> m (f 'Const)
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