-- 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 Morley.Micheline.Expression
import 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. (Integral a, Num b) => a -> b
fromIntegral Integer
ab Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
signBit)
    else Word8 -> Builder
Bi.singleton (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 :: (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
$ a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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. (Integral a, Num b) => a -> b
fromIntegral (((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 (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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. (Integral a, Num b) => a -> b
fromIntegral 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. (Num a, Bits a) => Int -> a -> Get a
readZ Int
6 (Word8 -> Integer
forall a b. (Integral a, Num 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, Num 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

readZ :: (Num 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. (Integral a, Num b) => a -> b
fromIntegral (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. (Num 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 <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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, Num b) => 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)