{-# LANGUAGE OverloadedStrings #-}

module Binrep.Types.Strings where

import Binrep.Codec
import Binrep.ByteLen
import Binrep.Types.Ints
import Binrep.Util
import Refined
import Refined.WithRefine
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Builder qualified as B
import Data.Serialize
import Data.Word
import Data.Typeable ( Typeable, typeRep )
import Control.Monad ( replicateM )

-- | TODO
data StrRep = C | Pascal ISize Endianness

-- | TODO
--
-- We also use this as a predicate, because the 'Pascal' constructor looks
-- identical to what we would want for a @LengthPrefixed@ predicate.
newtype Str (rep :: StrRep)
  = Str { forall (rep :: StrRep). Str rep -> ByteString
getStr :: BS.ByteString }

fromBinCString :: Get BS.ByteString
fromBinCString :: Get ByteString
fromBinCString = Builder -> Get ByteString
go Builder
forall a. Monoid a => a
mempty
  where go :: Builder -> Get ByteString
go Builder
buf = do
            Get Word8
getWord8 Get Word8 -> (Word8 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Word8
0x00    -> ByteString -> Get ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Get ByteString) -> ByteString -> Get ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
B.toLazyByteString Builder
buf
              Word8
nonNull -> Builder -> Get ByteString
go (Builder -> Get ByteString) -> Builder -> Get ByteString
forall a b. (a -> b) -> a -> b
$ Builder
buf Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
B.word8 Word8
nonNull

instance ByteLen (Str 'C) where
    blen :: Str 'C -> Natural
blen Str 'C
cstr = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (Str 'C -> ByteString
forall (rep :: StrRep). Str rep -> ByteString
getStr Str 'C
cstr) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

instance ByteLen (I 'U size e) => ByteLen (Str ('Pascal size e )) where
    blen :: Str ('Pascal size e) -> Natural
blen Str ('Pascal size e)
pstr = Natural -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. ByteLen a => a -> Natural
blen @(I 'U size e) I 'U size e
forall a. HasCallStack => a
undefined) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length (Str ('Pascal size e) -> ByteString
forall (rep :: StrRep). Str rep -> ByteString
getStr Str ('Pascal size e)
pstr))

-- | Total shite parsing efficiency. But, to be fair, that's why we don't
--   serialize arbitrary-length C strings!
instance BinaryCodec (Str 'C) where
    toBin :: Putter (Str 'C)
toBin Str 'C
cstr = do
        Putter ByteString
putByteString Putter ByteString -> Putter ByteString
forall a b. (a -> b) -> a -> b
$ Str 'C -> ByteString
forall (rep :: StrRep). Str rep -> ByteString
getStr Str 'C
cstr
        Putter Word8
putWord8 Word8
0x00
    fromBin :: Get (Str 'C)
fromBin = ByteString -> Str 'C
forall (rep :: StrRep). ByteString -> Str rep
Str (ByteString -> Str 'C) -> Get ByteString -> Get (Str 'C)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
fromBinCString

instance BinaryCodecWith _r (Str 'C)

-- TODO yeah I gotta do this because now the size info is actually in the
-- newtype -- which makes the most sense, because I want to do similar on the
-- value level! looks a tiny bit jank but ✓
data WellSized

-- | TODO explain why safe
instance BinaryCodec (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))) where
    toBin :: Putter (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e)))
toBin WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))
wrepstr = do
        forall a. BinaryCodec a => Putter a
toBin @(I 'U 'I1 e) Putter (I 'U 'I1 e) -> Putter (I 'U 'I1 e)
forall a b. (a -> b) -> a -> b
$ Int -> I 'U 'I1 e
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> I 'U 'I1 e) -> Int -> I 'U 'I1 e
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs
        Putter ByteString
putByteString ByteString
bs
      where bs :: ByteString
bs = Str ('Pascal 'I1 e) -> ByteString
forall (rep :: StrRep). Str rep -> ByteString
getStr (Str ('Pascal 'I1 e) -> ByteString)
-> Str ('Pascal 'I1 e) -> ByteString
forall a b. (a -> b) -> a -> b
$ WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))
-> Str ('Pascal 'I1 e)
forall {k} (ps :: PredicateStatus) (p :: k) a.
WithRefine ps p a -> a
unWithRefine WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))
wrepstr
    fromBin :: Get (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e)))
fromBin = do
        I 'U 'I1 e
len <- forall a. BinaryCodec a => Get a
fromBin @(I 'U 'I1 e)
        ByteString
bs <- Int -> Get ByteString
getByteString (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ I 'U 'I1 e -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral I 'U 'I1 e
len
        WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))
-> Get (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e)))
forall (m :: * -> *) a. Monad m => a -> m a
return (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))
 -> Get (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))))
-> WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))
-> Get (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e)))
forall a b. (a -> b) -> a -> b
$ Str ('Pascal 'I1 e)
-> WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))
forall {k} a (p :: k). a -> WithRefine 'Enforced p a
reallyUnsafeEnforce (Str ('Pascal 'I1 e)
 -> WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e)))
-> Str ('Pascal 'I1 e)
-> WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))
forall a b. (a -> b) -> a -> b
$ ByteString -> Str ('Pascal 'I1 e)
forall (rep :: StrRep). ByteString -> Str rep
Str ByteString
bs

instance BinaryCodecWith StrRep BS.ByteString where
    toBinWith :: StrRep -> ByteString -> Either String Builder
toBinWith StrRep
strRep ByteString
bs =
        case StrRep
strRep of
          StrRep
C -> Any -> Str 'C -> Either String Builder
forall r a. BinaryCodecWith r a => r -> a -> Either String Builder
toBinWith Any
forall a. HasCallStack => a
undefined (Str 'C -> Either String Builder)
-> Str 'C -> Either String Builder
forall a b. (a -> b) -> a -> b
$ forall (rep :: StrRep). ByteString -> Str rep
Str @'C ByteString
bs
          Pascal ISize
size Endianness
_e -> do
            case ISize
size of
              ISize
I1 -> do
                if   Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word8)
                then String -> Either String Builder
forall a b. a -> Either a b
Left String
"bytestring too long for configured static-size length prefix"
                else Builder -> Either String Builder
forall a b. b -> Either a b
Right (Builder -> Either String Builder)
-> Builder -> Either String Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.byteString ByteString
bs
              ISize
_ -> Either String Builder
forall a. HasCallStack => a
undefined
      where len :: Int
len = ByteString -> Int
BS.length ByteString
bs
    fromBinWith :: StrRep -> Get ByteString
fromBinWith = \case StrRep
C -> Get ByteString
fromBinCString
                        Pascal ISize
_size Endianness
_e -> Get ByteString
forall a. HasCallStack => a
undefined

-- Fun and correct, but it does give us an orphan instance lol
type LenPfx size e = Str ('Pascal size e)

-- | TODO why safe
instance (ByteLen a, itype ~ I 'U size e, ByteLen itype)
      => ByteLen (WithRefine 'Enforced (LenPfx size e) a) where
    blen :: WithRefine 'Enforced (LenPfx size e) a -> Natural
blen WithRefine 'Enforced (LenPfx size e) a
wrelpa = forall a. ByteLen a => a -> Natural
blen @itype itype
forall a. HasCallStack => a
undefined Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ a -> Natural
forall a. ByteLen a => a -> Natural
blen (WithRefine 'Enforced (LenPfx size e) a -> a
forall {k} (ps :: PredicateStatus) (p :: k) a.
WithRefine ps p a -> a
unWithRefine WithRefine 'Enforced (LenPfx size e) a
wrelpa)

instance (Foldable f, Typeable f, Typeable e) => Predicate (LenPfx 'I4 e) (f a) where
    validate :: Proxy (LenPfx 'I4 e) -> f a -> Maybe RefineException
validate Proxy (LenPfx 'I4 e)
p f a
a
      | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
max'
          = TypeRep -> Text -> Maybe RefineException
throwRefineOtherException (Proxy (LenPfx 'I4 e) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (LenPfx 'I4 e)
p) (Text -> Maybe RefineException) -> Text -> Maybe RefineException
forall a b. (a -> b) -> a -> b
$
              Text
"too long for given length prefix type: "Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Int -> Text
forall a. Show a => a -> Text
tshow Int
lenText -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
" > "Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Word32 -> Text
forall a. Show a => a -> Text
tshow Word32
max'
      | Bool
otherwise = Maybe RefineException
success
      where
        len :: Int
len = f a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length f a
a
        max' :: IRep 'U 'I4
max' = forall a. Bounded a => a
maxBound @(IRep 'U 'I4)

-- | TODO why safe
instance (BinaryCodec a, irep ~ IRep 'U size, itype ~ I 'U size e, Num irep, Integral irep, BinaryCodec itype)
      => BinaryCodec (WithRefine 'Enforced (LenPfx size e) [a]) where
    fromBin :: Get (WithRefine 'Enforced (LenPfx size e) [a])
fromBin = do
        itype
len <- forall a. BinaryCodec a => Get a
fromBin @itype
        [a]
as <- Int -> Get a -> Get [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (itype -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral itype
len) (forall a. BinaryCodec a => Get a
fromBin @a)
        WithRefine 'Enforced (LenPfx size e) [a]
-> Get (WithRefine 'Enforced (LenPfx size e) [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (WithRefine 'Enforced (LenPfx size e) [a]
 -> Get (WithRefine 'Enforced (LenPfx size e) [a]))
-> WithRefine 'Enforced (LenPfx size e) [a]
-> Get (WithRefine 'Enforced (LenPfx size e) [a])
forall a b. (a -> b) -> a -> b
$ [a] -> WithRefine 'Enforced (LenPfx size e) [a]
forall {k} a (p :: k). a -> WithRefine 'Enforced p a
reallyUnsafeEnforce [a]
as
    toBin :: Putter (WithRefine 'Enforced (LenPfx size e) [a])
toBin WithRefine 'Enforced (LenPfx size e) [a]
wreas = do
        forall a. BinaryCodec a => Putter a
toBin @itype Putter itype -> Putter itype
forall a b. (a -> b) -> a -> b
$ Int -> itype
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> itype) -> Int -> itype
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as
        (a -> Put) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. BinaryCodec a => Putter a
toBin @a) [a]
as
      where as :: [a]
as = WithRefine 'Enforced (LenPfx size e) [a] -> [a]
forall {k} (ps :: PredicateStatus) (p :: k) a.
WithRefine ps p a -> a
unWithRefine WithRefine 'Enforced (LenPfx size e) [a]
wreas