{-# 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 Capnp.Classes (Parse (encode, parse))
import qualified Capnp.Message as M
import Capnp.Mutability (Mutability (..), freeze)
import qualified Capnp.Repr as R
import qualified Capnp.Untyped as U
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

{- 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 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 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 :: forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
bsToMsg = 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 :: forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
lbsToMsg = forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
bsToMsg 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 :: forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, IsStruct a) =>
Message mut -> m (Raw a mut)
msgToRaw = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a (m :: * -> *) pa.
(ReadCtx m 'Const, IsStruct a, Parse a pa) =>
Message 'Const -> m pa
msgToParsed Message 'Const
msg = forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, IsStruct a) =>
Message mut -> m (Raw a mut)
msgToRaw Message 'Const
msg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall a (m :: * -> *).
(ReadCtx m 'Const, IsStruct a) =>
ByteString -> m (Raw a 'Const)
bsToRaw ByteString
bs = forall (m :: * -> *).
MonadThrow m =>
ByteString -> m (Message 'Const)
bsToMsg ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall a pa (m :: * -> *).
(ReadCtx m 'Const, IsStruct a, Parse a pa) =>
ByteString -> m pa
bsToParsed ByteString
bs = forall a (m :: * -> *).
(ReadCtx m 'Const, IsStruct a) =>
ByteString -> m (Raw a 'Const)
bsToRaw ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall a (m :: * -> *).
(ReadCtx m 'Const, IsStruct a) =>
ByteString -> m (Raw a 'Const)
lbsToRaw = forall a (m :: * -> *).
(ReadCtx m 'Const, IsStruct a) =>
ByteString -> m (Raw a 'Const)
bsToRaw 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 :: forall a pa (m :: * -> *).
(ReadCtx m 'Const, IsStruct a, Parse a pa) =>
ByteString -> m pa
lbsToParsed = forall a pa (m :: * -> *).
(ReadCtx m 'Const, IsStruct a, Parse a pa) =>
ByteString -> m pa
bsToParsed 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 :: forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Raw a ('Mut s))
parsedToRaw pa
p = do
  Message ('Mut s)
msg <- forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
M.newMessage forall a. Maybe a
Nothing
  value :: Raw a ('Mut s)
value@(R.Raw Unwrapped (Untyped (ReprFor a) ('Mut s))
struct) <- 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
  forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
U.setRoot Unwrapped (Untyped (ReprFor a) ('Mut s))
struct
  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 :: forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Message ('Mut s))
parsedToMsg pa
p = do
  Raw a ('Mut s)
root <- forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Raw a ('Mut s))
parsedToRaw pa
p
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
U.message @(R.Raw a) 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 :: forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m Builder
parsedToBuilder pa
p = Message 'Const -> Builder
msgToBuilder forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Message ('Mut s))
parsedToMsg pa
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m ByteString
parsedToLBS = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> ByteString
BB.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m ByteString
parsedToBS = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
LBS.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m ByteString
parsedToLBS