-- SPDX-FileCopyrightText: 2020 Tocqueville Group
-- SPDX-FileCopyrightText: 2018 obsidian.systems
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ
-- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems

-- | Module that define encoding and decoding function from Expression type
-- to binary format.
module Morley.Micheline.Binary
  ( decodeExpression
  , eitherDecodeExpression
  , encodeExpression
  , encodeExpression'
  ) where

import qualified Data.Binary.Builder as Bi
import qualified Data.Binary.Get as Bi
import Data.Bits (Bits, bit, setBit, shift, testBit, zeroBits, (.&.), (.|.))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Sequence as Seq
import qualified Data.Text.Encoding as TE
import qualified Unsafe (fromIntegral)

import Morley.Micheline.Expression
import Morley.Util.Binary (UnpackError(..), ensureEnd, launchGet)

newtype DynamicSize a = DynamicSize { DynamicSize a -> a
unDynamicSize :: a }

-------------------------------------------------
-- Encode
-------------------------------------------------

-- | Encode 'Expression' to 'ByteString'.
encodeExpression :: Expression -> LByteString
encodeExpression :: Expression -> LByteString
encodeExpression = Builder -> LByteString
Bi.toLazyByteString (Builder -> LByteString)
-> (Expression -> Builder) -> Expression -> LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> Builder
buildExpr

-- | Same as 'encodeExpression', for strict bytestring.
encodeExpression' :: Expression -> BS.ByteString
encodeExpression' :: Expression -> ByteString
encodeExpression' = LByteString -> ByteString
LBS.toStrict (LByteString -> ByteString)
-> (Expression -> LByteString) -> Expression -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> LByteString
encodeExpression

buildExpr :: Expression -> Bi.Builder
buildExpr :: Expression -> Builder
buildExpr = \case
  ExpressionSeq [Expression]
xs -> Word8 -> Builder
buildWord8 Word8
2 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ([Expression] -> Builder) -> DynamicSize [Expression] -> Builder
forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic [Expression] -> Builder
buildList ([Expression] -> DynamicSize [Expression]
forall a. a -> DynamicSize a
DynamicSize [Expression]
xs)
  ExpressionPrim (MichelinePrimAp MichelinePrimitive
prim [Expression]
args [Annotation]
annots) -> case ([Expression]
args, [Annotation]
annots) of
    ([], []) -> Word8 -> Builder
buildWord8 Word8
3 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MichelinePrimitive -> Builder
buildPrim MichelinePrimitive
prim
    ([], [Annotation]
_) -> Word8 -> Builder
buildWord8 Word8
4 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MichelinePrimitive -> Builder
buildPrim MichelinePrimitive
prim Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Annotation] -> Builder
buildAnnotationList [Annotation]
annots
    ([Expression
arg1], []) -> Word8 -> Builder
buildWord8 Word8
5 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MichelinePrimitive -> Builder
buildPrim MichelinePrimitive
prim Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
buildExpr Expression
arg1
    ([Expression
arg1], [Annotation]
_) -> Word8 -> Builder
buildWord8 Word8
6 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MichelinePrimitive -> Builder
buildPrim MichelinePrimitive
prim Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
buildExpr Expression
arg1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Annotation] -> Builder
buildAnnotationList [Annotation]
annots
    ([Expression
arg1, Expression
arg2], []) -> Word8 -> Builder
buildWord8 Word8
7 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MichelinePrimitive -> Builder
buildPrim MichelinePrimitive
prim Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
buildExpr Expression
arg1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
buildExpr Expression
arg2
    ([Expression
arg1, Expression
arg2], [Annotation]
_) -> Word8 -> Builder
buildWord8 Word8
8 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MichelinePrimitive -> Builder
buildPrim MichelinePrimitive
prim Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
buildExpr Expression
arg1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
buildExpr Expression
arg2 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Annotation] -> Builder
buildAnnotationList [Annotation]
annots
    ([Expression], [Annotation])
_ -> Word8 -> Builder
buildWord8 Word8
9 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MichelinePrimitive -> Builder
buildPrim MichelinePrimitive
prim Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ([Expression] -> Builder) -> DynamicSize [Expression] -> Builder
forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic [Expression] -> Builder
buildList ([Expression] -> DynamicSize [Expression]
forall a. a -> DynamicSize a
DynamicSize [Expression]
args) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Annotation] -> Builder
buildAnnotationList [Annotation]
annots
  ExpressionString Text
x -> Word8 -> Builder
buildWord8 Word8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder) -> DynamicSize Text -> Builder
forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic Text -> Builder
buildText (Text -> DynamicSize Text
forall a. a -> DynamicSize a
DynamicSize Text
x)
  ExpressionInt Integer
x -> Word8 -> Builder
buildWord8 Word8
0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
buildInteger Integer
x
  ExpressionBytes ByteString
x -> Word8 -> Builder
buildWord8 Word8
10 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (ByteString -> Builder) -> DynamicSize ByteString -> Builder
forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic ByteString -> Builder
buildByteString (ByteString -> DynamicSize ByteString
forall a. a -> DynamicSize a
DynamicSize ByteString
x)

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
    -- Refer to: https://gitlab.com/obsidian.systems/tezos-bake-monitor-lib/-/blob/2cf12e53072bcd966d471430ead25f597db5e23f/tezos-bake-monitor-lib/src/Tezos/Common/Binary.hs#L122
    if Integer
ab Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0x40 then Word8 -> Builder
Bi.singleton (Integer -> Word8
forall a b. (HasCallStack, 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 (Integer -> Word8
forall a b. (HasCallStack, 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 :: 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
$ (HasCallStack, Integral a, Integral Word8) => a -> Word8
forall a b. (HasCallStack, 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 (a -> Word8
forall a b. (HasCallStack, 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

buildDynamic :: (a -> Bi.Builder) -> (DynamicSize a) -> Bi.Builder
buildDynamic :: (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 ((HasCallStack, Integral Int64, Integral Word32) => Int64 -> Word32
forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.fromIntegral @Int64 @Word32 (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ LByteString -> Int64
LBS.length (LByteString -> Int64) -> LByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Builder -> LByteString
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

buildList :: [Expression] -> Bi.Builder
buildList :: [Expression] -> Builder
buildList = (Element [Expression] -> Builder) -> [Expression] -> Builder
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap Element [Expression] -> Builder
Expression -> Builder
buildExpr

buildPrim :: MichelinePrimitive -> Bi.Builder
buildPrim :: MichelinePrimitive -> Builder
buildPrim (MichelinePrimitive Text
p) = case Text -> Seq Text -> Maybe Int
forall a. Eq a => a -> Seq a -> Maybe Int
Seq.elemIndexL Text
p Seq Text
michelsonPrimitive of
  Maybe Int
Nothing -> Text -> Builder
forall a. HasCallStack => Text -> a
error (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Text
"unknown Michelson/Micheline primitive: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p
  Just Int
ix -> Word8 -> Builder
buildWord8 (Int -> Word8
forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.fromIntegral @Int @Word8 Int
ix)

buildAnnotationList :: [Annotation] -> Bi.Builder
buildAnnotationList :: [Annotation] -> Builder
buildAnnotationList [Annotation]
listAnn = (Text -> Builder) -> DynamicSize Text -> Builder
forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic Text -> Builder
buildText (Text -> DynamicSize Text
forall a. a -> DynamicSize a
DynamicSize (Text -> DynamicSize Text) -> Text -> DynamicSize Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
unwords ([Text] -> Text)
-> ([Annotation] -> [Text]) -> [Annotation] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotation -> Text) -> [Annotation] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotation -> Text
annotToText ([Annotation] -> Text) -> [Annotation] -> Text
forall a b. (a -> b) -> a -> b
$ [Annotation]
listAnn)

-------------------------------------------------
-- Decode
-------------------------------------------------

-- | Decode 'Expression' from 'ByteString'.
eitherDecodeExpression :: BS.ByteString -> Either UnpackError Expression
eitherDecodeExpression :: ByteString -> Either UnpackError Expression
eitherDecodeExpression ByteString
x = Get Expression -> LByteString -> Either UnpackError Expression
forall a. Get a -> LByteString -> Either UnpackError a
launchGet (Get Expression
getExpr Get Expression -> Get () -> Get Expression
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Get ()
ensureEnd) (LByteString -> Either UnpackError Expression)
-> LByteString -> Either UnpackError Expression
forall a b. (a -> b) -> a -> b
$ ByteString -> LByteString
LBS.fromStrict ByteString
x

-- | Partial version of 'eitherDecodeExpression'.
decodeExpression :: HasCallStack => BS.ByteString -> Expression
decodeExpression :: ByteString -> Expression
decodeExpression = (UnpackError -> Expression)
-> (Expression -> Expression)
-> Either UnpackError Expression
-> Expression
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Expression
forall a. HasCallStack => Text -> a
error (Text -> Expression)
-> (UnpackError -> Text) -> UnpackError -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnpackError -> Text
unUnpackError) Expression -> Expression
forall a. a -> a
id (Either UnpackError Expression -> Expression)
-> (ByteString -> Either UnpackError Expression)
-> ByteString
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnpackError Expression
eitherDecodeExpression

getExpr :: Bi.Get Expression
getExpr :: Get Expression
getExpr = Get Word8
Bi.getWord8 Get Word8 -> (Word8 -> Get Expression) -> Get Expression
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Word8
0 -> Integer -> Expression
ExpressionInt (Integer -> Expression) -> Get Integer -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Integer
getInteger
  Word8
1 -> Text -> Expression
ExpressionString (Text -> Expression)
-> (DynamicSize Text -> Text) -> DynamicSize Text -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicSize Text -> Text
forall a. DynamicSize a -> a
unDynamicSize (DynamicSize Text -> Expression)
-> Get (DynamicSize Text) -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Text -> Get (DynamicSize Text)
forall a. Get a -> Get (DynamicSize a)
getDynamic Get Text
getText)
  Word8
2 -> [Expression] -> Expression
ExpressionSeq ([Expression] -> Expression)
-> (DynamicSize [Expression] -> [Expression])
-> DynamicSize [Expression]
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicSize [Expression] -> [Expression]
forall a. DynamicSize a -> a
unDynamicSize (DynamicSize [Expression] -> Expression)
-> Get (DynamicSize [Expression]) -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get [Expression] -> Get (DynamicSize [Expression])
forall a. Get a -> Get (DynamicSize a)
getDynamic Get [Expression]
getList)
  Word8
3 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> (MichelinePrimitive -> MichelinePrimAp)
-> MichelinePrimitive
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\MichelinePrimitive
pn -> MichelinePrimitive
-> [Expression] -> [Annotation] -> MichelinePrimAp
MichelinePrimAp MichelinePrimitive
pn [] []) (MichelinePrimitive -> Expression)
-> Get MichelinePrimitive -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim
  Word8
4 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((MichelinePrimitive
 -> [Expression] -> [Annotation] -> MichelinePrimAp)
-> [Expression]
-> MichelinePrimitive
-> [Annotation]
-> MichelinePrimAp
forall a b c. (a -> b -> c) -> b -> a -> c
flip MichelinePrimitive
-> [Expression] -> [Annotation] -> MichelinePrimAp
MichelinePrimAp [] (MichelinePrimitive -> [Annotation] -> MichelinePrimAp)
-> Get MichelinePrimitive -> Get ([Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get ([Annotation] -> MichelinePrimAp)
-> Get [Annotation] -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Annotation]
getAnnotationList)
  Word8
5 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MichelinePrimitive
-> [Expression] -> [Annotation] -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> [Expression] -> [Annotation] -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get ([Expression] -> [Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get ([Expression] -> [Annotation] -> MichelinePrimAp)
-> Get [Expression] -> Get ([Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expression -> [Expression]
forall x. One x => OneItem x -> x
one (Expression -> [Expression]) -> Get Expression -> Get [Expression]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Expression
getExpr) Get ([Annotation] -> MichelinePrimAp)
-> Get [Annotation] -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Annotation] -> Get [Annotation]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
  Word8
6 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MichelinePrimitive
-> [Expression] -> [Annotation] -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> [Expression] -> [Annotation] -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get ([Expression] -> [Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get ([Expression] -> [Annotation] -> MichelinePrimAp)
-> Get [Expression] -> Get ([Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expression -> [Expression]
forall x. One x => OneItem x -> x
one (Expression -> [Expression]) -> Get Expression -> Get [Expression]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Expression
getExpr) Get ([Annotation] -> MichelinePrimAp)
-> Get [Annotation] -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Annotation]
getAnnotationList)
  Word8
7 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\MichelinePrimitive
n [Expression]
a -> MichelinePrimitive
-> [Expression] -> [Annotation] -> MichelinePrimAp
MichelinePrimAp MichelinePrimitive
n [Expression]
a []) (MichelinePrimitive -> [Expression] -> MichelinePrimAp)
-> Get MichelinePrimitive -> Get ([Expression] -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get ([Expression] -> MichelinePrimAp)
-> Get [Expression] -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Get Expression -> Get [Expression]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 Get Expression
getExpr)
  Word8
8 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MichelinePrimitive
-> [Expression] -> [Annotation] -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> [Expression] -> [Annotation] -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get ([Expression] -> [Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get ([Expression] -> [Annotation] -> MichelinePrimAp)
-> Get [Expression] -> Get ([Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Get Expression -> Get [Expression]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 Get Expression
getExpr Get ([Annotation] -> MichelinePrimAp)
-> Get [Annotation] -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Annotation]
getAnnotationList)
  Word8
9 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MichelinePrimitive
-> [Expression] -> [Annotation] -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> [Expression] -> [Annotation] -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get ([Expression] -> [Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get ([Expression] -> [Annotation] -> MichelinePrimAp)
-> Get [Expression] -> Get ([Annotation] -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DynamicSize [Expression] -> [Expression]
forall a. DynamicSize a -> a
unDynamicSize (DynamicSize [Expression] -> [Expression])
-> Get (DynamicSize [Expression]) -> Get [Expression]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get [Expression] -> Get (DynamicSize [Expression])
forall a. Get a -> Get (DynamicSize a)
getDynamic Get [Expression]
getList)) Get ([Annotation] -> MichelinePrimAp)
-> Get [Annotation] -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Annotation]
getAnnotationList)
  Word8
10 -> ByteString -> Expression
ExpressionBytes (ByteString -> Expression)
-> (DynamicSize ByteString -> ByteString)
-> DynamicSize ByteString
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicSize ByteString -> ByteString
forall a. DynamicSize a -> a
unDynamicSize (DynamicSize ByteString -> Expression)
-> Get (DynamicSize ByteString) -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get ByteString -> Get (DynamicSize ByteString)
forall a. Get a -> Get (DynamicSize a)
getDynamic Get ByteString
getByteString)
  Word8
_ -> String -> Get Expression
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid Micheline expression tag"

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, IsIntSubType a b ~ 'True) =>
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, IsIntSubType a b ~ 'True) =>
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

readZ :: forall a. (Integral a, Bits a) => Int -> a -> Bi.Get a
readZ :: 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' = (Word8 -> a
forall a b. (HasCallStack, 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 :: Get a -> Get (DynamicSize a)
getDynamic Get a
getter = do
  Int
len <- (HasCallStack, Integral Word32, Integral Int) => Word32 -> Int
forall a b. (HasCallStack, 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. (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 =
  LByteString -> ByteString
LBS.toStrict (LByteString -> ByteString) -> Get LByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get LByteString
Bi.getRemainingLazyByteString

getList :: Bi.Get [Expression]
getList :: Get [Expression]
getList = Get Expression -> Get [Expression]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get Expression
getExpr

getPrim :: Bi.Get MichelinePrimitive
getPrim :: Get MichelinePrimitive
getPrim =
  Get Word8
Bi.getWord8 Get Word8
-> (Word8 -> Get MichelinePrimitive) -> Get MichelinePrimitive
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word8
ix -> case Int -> Seq Text -> Maybe Text
forall a. Int -> Seq a -> Maybe a
Seq.lookup (Word8 -> Int
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
fromIntegral Word8
ix) Seq Text
michelsonPrimitive of
    Maybe Text
Nothing -> String -> Get MichelinePrimitive
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unknown Michelson/Micheline opcode"
    Just Text
str -> MichelinePrimitive -> Get MichelinePrimitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MichelinePrimitive -> Get MichelinePrimitive)
-> MichelinePrimitive -> Get MichelinePrimitive
forall a b. (a -> b) -> a -> b
$ Text -> MichelinePrimitive
MichelinePrimitive Text
str

getAnnotationList :: Bi.Get [Annotation]
getAnnotationList :: Get [Annotation]
getAnnotationList = (Text -> Get Annotation) -> [Text] -> Get [Annotation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Get Annotation
forall (m :: * -> *). MonadFail m => Text -> m Annotation
annotFromText ([Text] -> Get [Annotation])
-> (DynamicSize Text -> [Text])
-> DynamicSize Text
-> Get [Annotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
words (Text -> [Text])
-> (DynamicSize Text -> Text) -> DynamicSize Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicSize Text -> Text
forall a. DynamicSize a -> a
unDynamicSize (DynamicSize Text -> Get [Annotation])
-> Get (DynamicSize Text) -> Get [Annotation]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Get Text -> Get (DynamicSize Text)
forall a. Get a -> Get (DynamicSize a)
getDynamic Get Text
getText)