{-# OPTIONS_GHC -Wno-orphans #-}

-- |
-- Module: M.Pack.Internal.Num
-- Description: Numeric type serialization
-- Copyright: (c) axionbuster, 2025
-- License: BSD-3-Clause
--
-- Implements Pack and Unpack instances for numeric types and Bool,
-- including integral types, floating point numbers, and LEB128 encoding.
module M.Pack.Internal.Num
  ( packleb32,
    unpackleb32,
    packfi,
    unpackfi,
    guardnat,
  )
where

import Data.Bits
import Data.ByteString.Builder
import Data.Coerce
import Data.Int
import Data.Word
import FlatParse.Stateful qualified as F
import GHC.Float
import M.LEB
import M.Pack.Internal.FromIntegral
import M.Pack.Internal.Types

instance Pack Int8 where
  pack :: Int8 -> Builder
pack = Int8 -> Builder
int8
  {-# INLINE pack #-}

instance Unpack Int8 where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Int8
unpack = ParserT st r ParseError Int8
forall (st :: ZeroBitType) r e. ParserT st r e Int8
F.anyInt8
  {-# INLINE unpack #-}

instance Pack Word8 where
  pack :: Word8 -> Builder
pack = Word8 -> Builder
word8
  {-# INLINE pack #-}

instance Unpack Word8 where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Word8
unpack = ParserT st r ParseError Word8
forall (st :: ZeroBitType) r e. ParserT st r e Word8
F.anyWord8
  {-# INLINE unpack #-}

instance Pack Int16 where
  pack :: Int16 -> Builder
pack = Int16 -> Builder
int16BE
  {-# INLINE pack #-}

instance Unpack Int16 where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Int16
unpack = ParserT st r ParseError Int16
forall (st :: ZeroBitType) r e. ParserT st r e Int16
F.anyInt16be
  {-# INLINE unpack #-}

instance Pack Word16 where
  pack :: Word16 -> Builder
pack = Word16 -> Builder
word16BE
  {-# INLINE pack #-}

instance Unpack Word16 where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Word16
unpack = ParserT st r ParseError Word16
forall (st :: ZeroBitType) r e. ParserT st r e Word16
F.anyWord16be
  {-# INLINE unpack #-}

instance Pack Int32 where
  pack :: Int32 -> Builder
pack = Int32 -> Builder
int32BE
  {-# INLINE pack #-}

instance Unpack Int32 where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Int32
unpack = ParserT st r ParseError Int32
forall (st :: ZeroBitType) r e. ParserT st r e Int32
F.anyInt32be
  {-# INLINE unpack #-}

instance Pack Word32 where
  pack :: Word32 -> Builder
pack = Word32 -> Builder
word32BE
  {-# INLINE pack #-}

instance Unpack Word32 where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Word32
unpack = ParserT st r ParseError Word32
forall (st :: ZeroBitType) r e. ParserT st r e Word32
F.anyWord32be
  {-# INLINE unpack #-}

instance Pack Int64 where
  pack :: Int64 -> Builder
pack = Int64 -> Builder
int64BE
  {-# INLINE pack #-}

instance Unpack Int64 where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Int64
unpack = ParserT st r ParseError Int64
forall (st :: ZeroBitType) r e. ParserT st r e Int64
F.anyInt64be
  {-# INLINE unpack #-}

instance Pack Word64 where
  pack :: Word64 -> Builder
pack = Word64 -> Builder
word64BE
  {-# INLINE pack #-}

instance Unpack Word64 where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Word64
unpack = ParserT st r ParseError Word64
forall (st :: ZeroBitType) r e. ParserT st r e Word64
F.anyWord64be
  {-# INLINE unpack #-}

instance Pack Float where
  pack :: Float -> Builder
pack = Float -> Builder
floatBE
  {-# INLINE pack #-}

instance Unpack Float where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Float
unpack = Word32 -> Float
castWord32ToFloat (Word32 -> Float)
-> ParserT st r ParseError Word32 -> ParserT st r ParseError Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r ParseError Word32
forall (st :: ZeroBitType) r e. ParserT st r e Word32
F.anyWord32be
  {-# INLINE unpack #-}

instance Pack Double where
  pack :: Double -> Builder
pack = Double -> Builder
doubleBE
  {-# INLINE pack #-}

instance Unpack Double where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Double
unpack = Word64 -> Double
castWord64ToDouble (Word64 -> Double)
-> ParserT st r ParseError Word64 -> ParserT st r ParseError Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r ParseError Word64
forall (st :: ZeroBitType) r e. ParserT st r e Word64
F.anyWord64be
  {-# INLINE unpack #-}

instance Pack Bool where
  pack :: Bool -> Builder
pack = Word8 -> Builder
word8 (Word8 -> Builder) -> (Bool -> Word8) -> Bool -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Word8) -> (Bool -> Int) -> Bool -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum
  {-# INLINEABLE pack #-}

instance Unpack Bool where
  unpack :: forall (st :: ZeroBitType) r. Parser st r Bool
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 Bool)
-> ParserT st r ParseError Bool
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 -> Bool -> ParserT st r ParseError Bool
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Word8
1 -> Bool -> ParserT st r ParseError Bool
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Word8
n -> ParseError -> ParserT st r ParseError Bool
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
F.err (ParseError -> ParserT st r ParseError Bool)
-> ParseError -> ParserT st r ParseError Bool
forall a b. (a -> b) -> a -> b
$ String -> ParseError
forall a b. Coercible a b => a -> b
coerce (String -> ParseError) -> String -> ParseError
forall a b. (a -> b) -> a -> b
$ String
"illegal Bool representation: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
n
  {-# INLINEABLE unpack #-}

instance (FiniteBits a, Integral a) => Pack (LEB a) where
  pack :: LEB a -> Builder
pack = LEB a -> Builder
forall a. (FiniteBits a, Integral a) => LEB a -> Builder
encodeleb
  {-# INLINE pack #-}

instance (FiniteBits a, Num a) => Unpack (LEB a) where
  unpack :: forall (st :: ZeroBitType) r. Parser st r (LEB a)
unpack = ParserT st r ParseError Word8 -> ParserT st r ParseError (LEB a)
forall (m :: * -> *) a.
(Monad m, FiniteBits a, Num a) =>
m Word8 -> m (LEB a)
decodeleb ParserT st r ParseError Word8
forall (st :: ZeroBitType) r e. ParserT st r e Word8
F.anyWord8
  {-# INLINE unpack #-}

-- pack as leb encoded integers

-- | pack as an LEB128-encoded 'Int32'
packleb32 :: (Integral a) => a -> Builder
packleb32 :: forall a. Integral a => a -> Builder
packleb32 = forall a. Pack a => a -> Builder
pack @(LEB Int32) (LEB Int32 -> Builder) -> (a -> LEB Int32) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LEB Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE packleb32 #-}

-- | unpack from an LEB128-encoded 'Int32'
unpackleb32 :: (Integral a) => Parser st r a
unpackleb32 :: forall a (st :: ZeroBitType) r. Integral a => Parser st r a
unpackleb32 = LEB Int32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LEB Int32 -> a)
-> ParserT st r ParseError (LEB Int32) -> ParserT st r ParseError a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack @(LEB Int32)
{-# INLINE unpackleb32 #-}

-- pack with fromIntegral

-- | pack @b@ in the format of @a@
packfi :: forall a b. (Integral a, Pack a, Integral b) => b -> Builder
packfi :: forall a b. (Integral a, Pack a, Integral b) => b -> Builder
packfi = forall a. Pack a => a -> Builder
pack @a (a -> Builder) -> (b -> a) -> b -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | unpack @b@ from a number in the format of @a@
unpackfi :: forall a b st r. (Integral a, Unpack a, Integral b) => Parser st r b
unpackfi :: forall a b (st :: ZeroBitType) r.
(Integral a, Unpack a, Integral b) =>
Parser st r b
unpackfi = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> b) -> ParserT st r ParseError a -> ParserT st r ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (st :: ZeroBitType) r. Unpack a => Parser st r a
unpack @a

-- | ensure the number is non-negative
guardnat :: (Num a, Ord a, Show a) => String -> a -> Parser st r a
guardnat :: forall a (st :: ZeroBitType) r.
(Num a, Ord a, Show a) =>
String -> a -> Parser st r a
guardnat String
na a
nu
  | a
nu a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = ParseError -> ParserT st r ParseError a
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
F.err (ParseError -> ParserT st r ParseError a)
-> ParseError -> ParserT st r ParseError a
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError (String -> ParseError) -> String -> ParseError
forall a b. (a -> b) -> a -> b
$ String
na String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": negative: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
nu
  | Bool
otherwise = a -> ParserT st r ParseError a
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
nu