module Morley.Micheline.Binary.Internal
( DynamicSize(..)
, buildWord8
, buildText
, buildInteger
, buildNatural
, buildDynamic
, buildByteString
, getText
, getNatural
, getInteger
, getDynamic
, getByteString
) where
import Control.Exception (assert)
import Data.Binary.Builder qualified as Bi
import Data.Binary.Get qualified as Bi
import Data.Bits (Bits, bit, setBit, shift, testBit, zeroBits, (.&.), (.|.))
import Data.ByteString.Lazy qualified as LBS
import Data.Text.Encoding qualified as TE
import Unsafe qualified (fromIntegral)
newtype DynamicSize a = DynamicSize { forall a. DynamicSize a -> a
unDynamicSize :: a }
buildWord8 :: Word8 -> Bi.Builder
buildWord8 :: Word8 -> Builder
buildWord8 = Word8 -> Builder
Bi.singleton
buildByteString :: ByteString -> Bi.Builder
buildByteString :: ByteString -> Builder
buildByteString = ByteString -> Builder
Bi.fromByteString
buildInteger :: Integer -> Bi.Builder
buildInteger :: Integer -> Builder
buildInteger Integer
n =
let signBit :: Word8
signBit = if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Int -> Word8
forall a. Bits a => Int -> a
bit Int
6 else Word8
forall a. Bits a => a
zeroBits
ab :: Integer
ab = Integer -> Integer
forall a. Num a => a -> a
abs Integer
n
in
if Integer
ab Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0x40 then Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Integer @Word8 Integer
ab Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
signBit)
else Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Integer @Word8 (Integer
ab Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0x3f) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
signBit Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Int -> Word8
forall a. Bits a => Int -> a
bit Int
7) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Integer -> Builder
forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ (Int
-6) Integer
ab
writeZ :: forall a. (Integral a, Bits a) => Int -> a -> Bi.Builder
writeZ :: forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ Int
offset a
n =
if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> a
forall a. Bits a => Int -> a
bit (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset) then Word8 -> Builder
Bi.singleton (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @a @Word8 (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` Int
offset
else Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @a @Word8 (((a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` Int
offset) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x7f) a -> Int -> a
forall a. Bits a => a -> Int -> a
`setBit` Int
7)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> a -> Builder
forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
7) a
n
buildNatural :: Integer -> Bi.Builder
buildNatural :: Integer -> Builder
buildNatural Integer
n = Bool -> Builder -> Builder
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0x80 then Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Integer @Word8 Integer
n)
else Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Integer @Word8 (Integer
n Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xff) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Int -> Word8
forall a. Bits a => Int -> a
bit Int
7) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Integer -> Builder
forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ (Int
-7) Integer
n
buildDynamic :: (a -> Bi.Builder) -> (DynamicSize a) -> Bi.Builder
buildDynamic :: forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic a -> Builder
build (DynamicSize a
x) =
let b :: Builder
b = a -> Builder
build a
x
in Word32 -> Builder
Bi.putWord32be (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Int64 @Word32 (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Bi.toLazyByteString Builder
b) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b
buildText :: Text -> Bi.Builder
buildText :: Text -> Builder
buildText Text
n =
ByteString -> Builder
buildByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
n
getInteger :: Bi.Get Integer
getInteger :: Get Integer
getInteger = do
Word8
b <- Get Word8
Bi.getWord8
Integer
n <- if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 then Int -> Integer -> Get Integer
forall a. (Integral a, Bits a) => Int -> a -> Get a
readZ Int
6 (Word8 -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f) else Integer -> Get Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f)
pure $ if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
6 then Integer -> Integer
forall a. Num a => a -> a
negate Integer
n else Integer
n
getNatural :: Bi.Get Integer
getNatural :: Get Integer
getNatural = do
Word8
b <- Get Word8
Bi.getWord8
if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 then Int -> Integer -> Get Integer
forall a. (Integral a, Bits a) => Int -> a -> Get a
readZ Int
7 (Word8 -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f) else Integer -> Get Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f)
readZ :: forall a. (Integral a, Bits a) => Int -> a -> Bi.Get a
readZ :: forall a. (Integral a, Bits a) => Int -> a -> Get a
readZ Int
offset a
n = do
Word8
b <- Get Word8
Bi.getWord8
if (Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& (Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) then String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"trailing zero" else () -> Get ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let n' :: a
n' = (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Word8 @a (Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f) a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` Int
offset) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
n
if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 then Int -> a -> Get a
forall a. (Integral a, Bits a) => Int -> a -> Get a
readZ (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) a
n' else a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
n'
getDynamic :: (Bi.Get a) -> (Bi.Get (DynamicSize a))
getDynamic :: forall a. Get a -> Get (DynamicSize a)
getDynamic Get a
getter = do
Int
len <- forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Word32 @Int (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
Bi.getWord32be
a -> DynamicSize a
forall a. a -> DynamicSize a
DynamicSize (a -> DynamicSize a) -> Get a -> Get (DynamicSize a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get a -> Get a
forall a. Int -> Get a -> Get a
Bi.isolate Int
len Get a
getter
{-# ANN getText ("HLint: ignore Redundant fmap" :: Text) #-}
getText :: Bi.Get Text
getText :: Get Text
getText =
(ByteString -> Either UnicodeException Text)
-> Get ByteString -> Get (Either UnicodeException Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either UnicodeException Text
decodeUtf8' Get ByteString
getByteString Get (Either UnicodeException Text)
-> (Either UnicodeException Text -> Get Text) -> Get Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left UnicodeException
err -> String -> Get Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Text) -> String -> Get Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show UnicodeException
err
Right Text
answer -> Text -> Get Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
answer
getByteString :: Bi.Get ByteString
getByteString :: Get ByteString
getByteString =
ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
Bi.getRemainingLazyByteString