{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
{- |
Module: Capnp.Basics.Pure
Description: Handling of "basic" capnp datatypes (high-level API).

Analogous to 'Capnp.Basics' in the low-level API, this module deals
with capnproto's @Text@ and @Data@ types. These are simply aliases for
'BS.ByteString' and the text package's 'T.Text'; mostly this module provides
helper functions and type class instances.

Unlike with the low-level API, typed lists do not require special
treatment -- they're just Vectors.
-}
module Capnp.Basics.Pure
    ( Data
    , Text
    ) where

import Prelude hiding (length)

import Control.Monad       (forM_)
import Control.Monad.Catch (MonadThrow(throwM))
import Data.Text.Encoding  (decodeUtf8', encodeUtf8)

import qualified Data.ByteString as BS
import qualified Data.Text       as T
import qualified Data.Vector     as V

import Capnp.Classes

import Capnp.Errors  (Error(InvalidUtf8Error))
import Capnp.Untyped (rawBytes)

import qualified Capnp.Basics  as Basics
import qualified Capnp.Message as M
import qualified Capnp.Untyped as Untyped

-- | A capnproto @Data@ value. This is just an alias for 'BS.ByteString'.
type Data = BS.ByteString

-- | A capnproto @Text@. This  is just an alias for the text package's 'T.Text'.
type Text = T.Text

instance Decerialize Data where
    type Cerial msg Data = Basics.Data msg
    decerialize :: Cerial ConstMsg Data -> m Data
decerialize (Basics.Data list) = ListOf ConstMsg Word8 -> m Data
forall (m :: * -> *) msg.
ReadCtx m msg =>
ListOf msg Word8 -> m Data
rawBytes ListOf ConstMsg Word8
list

instance Marshal s Data where
    marshalInto :: Cerial (MutMsg s) Data -> Data -> m ()
marshalInto (Basics.Data list) Data
bytes =
        [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Data -> Int
BS.length Data
bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
            Word8 -> Int -> ListOf (MutMsg s) Word8 -> m ()
forall (m :: * -> *) s a.
RWCtx m s =>
a -> Int -> ListOf (MutMsg s) a -> m ()
Untyped.setIndex (Data -> Int -> Word8
BS.index Data
bytes Int
i) Int
i ListOf (MutMsg s) Word8
list

instance Cerialize s Data where
    cerialize :: MutMsg s -> Data -> m (Cerial (MutMsg s) Data)
cerialize MutMsg s
msg Data
bytes = do
        Data (MutMsg s)
dest <- MutMsg s -> Int -> m (Data (MutMsg s))
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> Int -> m (Data (MutMsg s))
Basics.newData MutMsg s
msg (Data -> Int
BS.length Data
bytes)
        Cerial (MutMsg s) Data -> Data -> m ()
forall s a (m :: * -> *).
(Marshal s a, RWCtx m s) =>
Cerial (MutMsg s) a -> a -> m ()
marshalInto Cerial (MutMsg s) Data
Data (MutMsg s)
dest Data
bytes
        Data (MutMsg s) -> m (Data (MutMsg s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Data (MutMsg s)
dest

instance Decerialize Text where
    type Cerial msg Text = Basics.Text msg
    decerialize :: Cerial ConstMsg Text -> m Text
decerialize Cerial ConstMsg Text
text = do
            Data
bytes <- Text ConstMsg -> m Data
forall (m :: * -> *) msg. ReadCtx m msg => Text msg -> m Data
Basics.textBytes Cerial ConstMsg Text
Text ConstMsg
text
            case Data -> Either UnicodeException Text
decodeUtf8' Data
bytes of
                Left UnicodeException
e    -> Error -> m Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Error -> m Text) -> Error -> m Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> Error
InvalidUtf8Error UnicodeException
e
                Right Text
txt -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
txt

instance Marshal s Text where
    marshalInto :: Cerial (MutMsg s) Text -> Text -> m ()
marshalInto Cerial (MutMsg s) Text
dest Text
text = Data -> Text (MutMsg s) -> m ()
forall (m :: * -> *) s.
RWCtx m s =>
Data -> Text (MutMsg s) -> m ()
marshalTextBytes (Text -> Data
encodeUtf8 Text
text) Cerial (MutMsg s) Text
Text (MutMsg s)
dest

instance Cerialize s Text where
    cerialize :: MutMsg s -> Text -> m (Cerial (MutMsg s) Text)
cerialize MutMsg s
msg Text
text = do
        let bytes :: Data
bytes = Text -> Data
encodeUtf8 Text
text
        Text (MutMsg s)
ret <- MutMsg s -> Int -> m (Text (MutMsg s))
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> Int -> m (Text (MutMsg s))
Basics.newText MutMsg s
msg (Data -> Int
BS.length Data
bytes)
        Data -> Text (MutMsg s) -> m ()
forall (m :: * -> *) s.
RWCtx m s =>
Data -> Text (MutMsg s) -> m ()
marshalTextBytes Data
bytes Text (MutMsg s)
ret
        Text (MutMsg s) -> m (Text (MutMsg s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text (MutMsg s)
ret

marshalTextBytes :: Untyped.RWCtx m s => BS.ByteString -> Basics.Text (M.MutMsg s) -> m ()
marshalTextBytes :: Data -> Text (MutMsg s) -> m ()
marshalTextBytes Data
bytes Text (MutMsg s)
text = do
    ListOf (MutMsg s) Word8
buffer <- Text (MutMsg s) -> m (ListOf (MutMsg s) Word8)
forall (m :: * -> *) msg.
ReadCtx m msg =>
Text msg -> m (ListOf msg Word8)
Basics.textBuffer Text (MutMsg s)
text
    Cerial (MutMsg s) Data -> Data -> m ()
forall s a (m :: * -> *).
(Marshal s a, RWCtx m s) =>
Cerial (MutMsg s) a -> a -> m ()
marshalInto (ListOf (MutMsg s) Word8 -> Data (MutMsg s)
forall msg. ListOf msg Word8 -> Data msg
Basics.Data ListOf (MutMsg s) Word8
buffer) Data
bytes

instance Cerialize s (V.Vector Text) where cerialize :: MutMsg s -> Vector Text -> m (Cerial (MutMsg s) (Vector Text))
cerialize = MutMsg s -> Vector Text -> m (Cerial (MutMsg s) (Vector Text))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector Data) where cerialize :: MutMsg s -> Vector Data -> m (Cerial (MutMsg s) (Vector Data))
cerialize = MutMsg s -> Vector Data -> m (Cerial (MutMsg s) (Vector Data))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector (V.Vector Text)) where cerialize :: MutMsg s
-> Vector (Vector Text)
-> m (Cerial (MutMsg s) (Vector (Vector Text)))
cerialize = MutMsg s
-> Vector (Vector Text)
-> m (Cerial (MutMsg s) (Vector (Vector Text)))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector (V.Vector Data)) where cerialize :: MutMsg s
-> Vector (Vector Data)
-> m (Cerial (MutMsg s) (Vector (Vector Data)))
cerialize = MutMsg s
-> Vector (Vector Data)
-> m (Cerial (MutMsg s) (Vector (Vector Data)))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector (V.Vector (V.Vector Text))) where cerialize :: MutMsg s
-> Vector (Vector (Vector Text))
-> m (Cerial (MutMsg s) (Vector (Vector (Vector Text))))
cerialize = MutMsg s
-> Vector (Vector (Vector Text))
-> m (Cerial (MutMsg s) (Vector (Vector (Vector Text))))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector (V.Vector (V.Vector Data))) where cerialize :: MutMsg s
-> Vector (Vector (Vector Data))
-> m (Cerial (MutMsg s) (Vector (Vector (Vector Data))))
cerialize = MutMsg s
-> Vector (Vector (Vector Data))
-> m (Cerial (MutMsg s) (Vector (Vector (Vector Data))))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector (V.Vector (V.Vector (V.Vector Text)))) where cerialize :: MutMsg s
-> Vector (Vector (Vector (Vector Text)))
-> m (Cerial (MutMsg s) (Vector (Vector (Vector (Vector Text)))))
cerialize = MutMsg s
-> Vector (Vector (Vector (Vector Text)))
-> m (Cerial (MutMsg s) (Vector (Vector (Vector (Vector Text)))))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector (V.Vector (V.Vector (V.Vector Data)))) where cerialize :: MutMsg s
-> Vector (Vector (Vector (Vector Data)))
-> m (Cerial (MutMsg s) (Vector (Vector (Vector (Vector Data)))))
cerialize = MutMsg s
-> Vector (Vector (Vector (Vector Data)))
-> m (Cerial (MutMsg s) (Vector (Vector (Vector (Vector Data)))))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector (V.Vector (V.Vector (V.Vector (V.Vector Text))))) where cerialize :: MutMsg s
-> Vector (Vector (Vector (Vector (Vector Text))))
-> m (Cerial
        (MutMsg s) (Vector (Vector (Vector (Vector (Vector Text))))))
cerialize = MutMsg s
-> Vector (Vector (Vector (Vector (Vector Text))))
-> m (Cerial
        (MutMsg s) (Vector (Vector (Vector (Vector (Vector Text))))))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec
instance Cerialize s (V.Vector (V.Vector (V.Vector (V.Vector (V.Vector Data))))) where cerialize :: MutMsg s
-> Vector (Vector (Vector (Vector (Vector Data))))
-> m (Cerial
        (MutMsg s) (Vector (Vector (Vector (Vector (Vector Data))))))
cerialize = MutMsg s
-> Vector (Vector (Vector (Vector (Vector Data))))
-> m (Cerial
        (MutMsg s) (Vector (Vector (Vector (Vector (Vector Data))))))
forall (m :: * -> *) s a.
(RWCtx m s, MutListElem s (Cerial (MutMsg s) a), Cerialize s a) =>
MutMsg s -> Vector a -> m (List (MutMsg s) (Cerial (MutMsg s) a))
cerializeBasicVec