{-# OPTIONS_GHC -Wno-orphans #-}

-- |
-- Module: M.Pack.Internal.Etc
-- Description: Additional serialization instances
-- Copyright: (c) axionbuster, 2025
-- License: BSD-3-Clause
--
-- Implements Pack and Unpack instances for various types including Text,
-- ByteString, Maybe, Vector, and UUID.
module M.Pack.Internal.Etc () where

import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Builder
import Data.Text (Text)
import Data.Text.Encoding qualified as TE
import Data.UUID.Types
import Data.Vector qualified as V
import Data.Vector.Unboxed qualified as VU
import Data.Word
import FlatParse.Stateful qualified as F
import M.Pack.Internal.Num
import M.Pack.Internal.Types

instance Pack Text where
  pack :: Text -> Builder
pack = ByteString -> Builder
forall a. Pack a => a -> Builder
pack (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8
  {-# INLINEABLE pack #-}

instance Unpack Text where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Text
unpack =
    ByteString -> Either UnicodeException Text
TE.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ParserT st r ParseError ByteString
-> ParserT st r ParseError (Either UnicodeException Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack @ByteString ParserT st r ParseError (Either UnicodeException Text)
-> (Either UnicodeException Text -> ParserT st r ParseError Text)
-> ParserT st r ParseError Text
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left UnicodeException
err -> ParseError -> ParserT st r ParseError Text
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
F.err (String -> ParseError
ParseError (UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err))
      Right Text
t -> Text -> ParserT st r ParseError Text
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
  {-# INLINEABLE unpack #-}

instance Pack ByteString where
  pack :: ByteString -> Builder
pack ByteString
b = Int -> Builder
forall a. Integral a => a -> Builder
packleb32 (ByteString -> Int
B.length ByteString
b) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
b
  {-# INLINEABLE pack #-}

instance Unpack ByteString where
  unpack :: forall (st :: ZeroBitType) r. Parser st r ByteString
unpack = Parser st r Int
forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32 Parser st r Int -> (Int -> Parser st r Int) -> Parser st r Int
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Int -> Parser st r Int
forall a (st :: ZeroBitType) r.
(Num a, Ord a, Show a) =>
String -> a -> Parser st r a
guardnat String
"ByteString length" Parser st r Int
-> (Int -> ParserT st r ParseError ByteString)
-> ParserT st r ParseError ByteString
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ParserT st r ParseError ByteString
forall (st :: ZeroBitType) r e. Int -> ParserT st r e ByteString
F.take
  {-# INLINE unpack #-}

instance (Pack a) => Pack (Maybe a) where
  pack :: Maybe a -> Builder
pack = \case
    Maybe a
Nothing -> forall a. Pack a => a -> Builder
pack @Word8 Word8
0
    Just a
x -> forall a. Pack a => a -> Builder
pack @Word8 Word8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. Pack a => a -> Builder
pack a
x
  {-# INLINEABLE pack #-}

instance (Unpack a) => Unpack (Maybe a) where
  unpack :: forall (st :: ZeroBitType) r. Parser st r (Maybe a)
unpack =
    ParserT st r ParseError Word8
forall (st :: ZeroBitType) r e. ParserT st r e Word8
F.anyWord8 ParserT st r ParseError Word8
-> (Word8 -> ParserT st r ParseError (Maybe a))
-> ParserT st r ParseError (Maybe a)
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Word8
0 -> Maybe a -> ParserT st r ParseError (Maybe a)
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      Word8
1 -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> ParserT st r ParseError a -> ParserT st r ParseError (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r ParseError a
forall (st :: ZeroBitType) r. Parser st r a
forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack
      Word8
n -> ParseError -> ParserT st r ParseError (Maybe a)
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
F.err (ParseError -> ParserT st r ParseError (Maybe a))
-> ParseError -> ParserT st r ParseError (Maybe a)
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError (String -> ParseError) -> String -> ParseError
forall a b. (a -> b) -> a -> b
$ String
"Maybe: invalid tag: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
n
  {-# INLINEABLE unpack #-}

-- vector

instance (Pack a) => Pack (V.Vector a) where
  pack :: Vector a -> Builder
pack = Int -> Builder
forall a. Integral a => a -> Builder
packleb32 (Int -> Builder) -> (Vector a -> Int) -> Vector a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> Int
forall a. Vector a -> Int
V.length (Vector a -> Builder)
-> (Vector a -> Builder) -> Vector a -> Builder
forall a. Semigroup a => a -> a -> a
<> (a -> Builder) -> Vector a -> Builder
forall m a. Monoid m => (a -> m) -> Vector a -> m
V.foldMap' a -> Builder
forall a. Pack a => a -> Builder
pack
  {-# INLINEABLE pack #-}

instance (Unpack a) => Unpack (V.Vector a) where
  unpack :: forall (st :: ZeroBitType) r. Parser st r (Vector a)
unpack =
    Parser st r Int
forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32
      Parser st r Int -> (Int -> Parser st r Int) -> Parser st r Int
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Int -> Parser st r Int
forall a (st :: ZeroBitType) r.
(Num a, Ord a, Show a) =>
String -> a -> Parser st r a
guardnat String
"V.Vector length"
      Parser st r Int
-> (Int -> ParserT st r ParseError (Vector a))
-> ParserT st r ParseError (Vector a)
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int
 -> ParserT st r ParseError a -> ParserT st r ParseError (Vector a))
-> ParserT st r ParseError a
-> Int
-> ParserT st r ParseError (Vector a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int
-> ParserT st r ParseError a -> ParserT st r ParseError (Vector a)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM ParserT st r ParseError a
forall (st :: ZeroBitType) r. Parser st r a
forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack
  {-# INLINEABLE unpack #-}

instance (VU.Unbox a, Pack a) => Pack (VU.Vector a) where
  pack :: Vector a -> Builder
pack = Int -> Builder
forall a. Integral a => a -> Builder
packleb32 (Int -> Builder) -> (Vector a -> Int) -> Vector a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> Int
forall a. Unbox a => Vector a -> Int
VU.length (Vector a -> Builder)
-> (Vector a -> Builder) -> Vector a -> Builder
forall a. Semigroup a => a -> a -> a
<> (a -> Builder) -> Vector a -> Builder
forall m a. (Monoid m, Unbox a) => (a -> m) -> Vector a -> m
VU.foldMap' a -> Builder
forall a. Pack a => a -> Builder
pack
  {-# INLINEABLE pack #-}

instance (VU.Unbox a, Unpack a) => Unpack (VU.Vector a) where
  unpack :: forall (st :: ZeroBitType) r. Parser st r (Vector a)
unpack =
    Parser st r Int
forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32
      Parser st r Int -> (Int -> Parser st r Int) -> Parser st r Int
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Int -> Parser st r Int
forall a (st :: ZeroBitType) r.
(Num a, Ord a, Show a) =>
String -> a -> Parser st r a
guardnat String
"VU.Vector length"
      Parser st r Int
-> (Int -> ParserT st r ParseError (Vector a))
-> ParserT st r ParseError (Vector a)
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int
 -> ParserT st r ParseError a -> ParserT st r ParseError (Vector a))
-> ParserT st r ParseError a
-> Int
-> ParserT st r ParseError (Vector a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int
-> ParserT st r ParseError a -> ParserT st r ParseError (Vector a)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
VU.replicateM ParserT st r ParseError a
forall (st :: ZeroBitType) r. Parser st r a
forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack
  {-# INLINEABLE unpack #-}

-- UUID

instance Pack UUID where
  pack :: UUID -> Builder
pack = (Word64, Word64) -> Builder
forall a. Pack a => a -> Builder
pack ((Word64, Word64) -> Builder)
-> (UUID -> (Word64, Word64)) -> UUID -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> (Word64, Word64)
toWords64
  {-# INLINE pack #-}

instance Unpack UUID where
  unpack :: forall (st :: ZeroBitType) r. Parser st r UUID
unpack = Word64 -> Word64 -> UUID
fromWords64 (Word64 -> Word64 -> UUID)
-> ParserT st r ParseError Word64
-> ParserT st r ParseError (Word64 -> UUID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r ParseError Word64
forall (st :: ZeroBitType) r. Parser st r Word64
forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack ParserT st r ParseError (Word64 -> UUID)
-> ParserT st r ParseError Word64 -> ParserT st r ParseError UUID
forall a b.
ParserT st r ParseError (a -> b)
-> ParserT st r ParseError a -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParserT st r ParseError Word64
forall (st :: ZeroBitType) r. Parser st r Word64
forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack
  {-# INLINE unpack #-}