-- 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
  ) 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 Data.Sequence (Seq((:<|)))
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 -> BS.ByteString
encodeExpression :: Expression -> ByteString
encodeExpression = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Expression -> ByteString) -> Expression -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Bi.toLazyByteString (Builder -> ByteString)
-> (Expression -> Builder) -> Expression -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> Builder
buildExpr

buildExpr :: Expression -> Bi.Builder
buildExpr :: Expression -> Builder
buildExpr = \case
  ExpressionSeq xs :: Seq Expression
xs -> Word8 -> Builder
buildWord8 2 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Seq Expression -> Builder)
-> DynamicSize (Seq Expression) -> Builder
forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic Seq Expression -> Builder
buildSeq (Seq Expression -> DynamicSize (Seq Expression)
forall a. a -> DynamicSize a
DynamicSize Seq Expression
xs)
  ExpressionPrim (MichelinePrimAp prim :: MichelinePrimitive
prim args :: Seq Expression
args annots :: Seq Annotation
annots) -> case (Seq Expression
args, Seq Annotation
annots) of
    (Seq.Empty, Seq.Empty) -> Word8 -> Builder
buildWord8 3 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MichelinePrimitive -> Builder
buildPrim MichelinePrimitive
prim
    (Seq.Empty, _) -> Word8 -> Builder
buildWord8 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
<> Seq Annotation -> Builder
buildAnnotationSeq Seq Annotation
annots
    (arg1 :: Expression
arg1 :<| Seq.Empty, Seq.Empty) -> Word8 -> Builder
buildWord8 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
    (arg1 :: Expression
arg1 :<| Seq.Empty, _) -> Word8 -> Builder
buildWord8 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
<> Seq Annotation -> Builder
buildAnnotationSeq Seq Annotation
annots
    (arg1 :: Expression
arg1 :<| (arg2 :: Expression
arg2 :<| Seq.Empty), Seq.Empty) -> Word8 -> Builder
buildWord8 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
    (arg1 :: Expression
arg1 :<| (arg2 :: Expression
arg2 :<| Seq.Empty), _) -> Word8 -> Builder
buildWord8 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
<> Seq Annotation -> Builder
buildAnnotationSeq Seq Annotation
annots
    _ -> Word8 -> Builder
buildWord8 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
<> (Seq Expression -> Builder)
-> DynamicSize (Seq Expression) -> Builder
forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic Seq Expression -> Builder
buildSeq (Seq Expression -> DynamicSize (Seq Expression)
forall a. a -> DynamicSize a
DynamicSize Seq Expression
args) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Annotation -> Builder
buildAnnotationSeq Seq Annotation
annots
  ExpressionString x :: Text
x -> Word8 -> Builder
buildWord8 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 x :: Integer
x -> Word8 -> Builder
buildWord8 0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
buildInteger Integer
x
  ExpressionBytes x :: ByteString
x -> Word8 -> Builder
buildWord8 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 n :: Integer
n =
  let signBit :: Word8
signBit = if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then Int -> Word8
forall a. Bits a => Int -> a
bit 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
< 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
.&. 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 7) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Integer -> Builder
forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ (-6) Integer
ab

writeZ :: (Integral a, Bits a) => Int -> a -> Bi.Builder
writeZ :: Int -> a -> Builder
writeZ offset :: Int
offset n :: a
n =
  if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> a
forall a. Bits a => Int -> a
bit (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
.&. 0x7f) a -> Int -> a
forall a. Bits a => a -> Int -> a
`setBit` 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
- 7) a
n

buildDynamic :: (a -> Bi.Builder) -> (DynamicSize a) -> Bi.Builder
buildDynamic :: (a -> Builder) -> DynamicSize a -> Builder
buildDynamic build :: a -> Builder
build (DynamicSize x :: 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
$ 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 n :: Text
n =
  ByteString -> Builder
buildByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
n

buildSeq :: Seq Expression -> Bi.Builder
buildSeq :: Seq Expression -> Builder
buildSeq xs :: Seq Expression
xs = (Element (Seq Expression) -> Builder) -> Seq Expression -> Builder
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap Element (Seq Expression) -> Builder
Expression -> Builder
buildExpr Seq Expression
xs

buildPrim :: MichelinePrimitive -> Bi.Builder
buildPrim :: MichelinePrimitive -> Builder
buildPrim (MichelinePrimitive p :: 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
  Nothing -> Text -> Builder
forall a. HasCallStack => Text -> a
error "unknown Michelson/Micheline primitive"
  Just ix :: Int
ix -> Word8 -> Builder
buildWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix)

buildAnnotationSeq :: Seq Annotation -> Bi.Builder
buildAnnotationSeq :: Seq Annotation -> Builder
buildAnnotationSeq seqAnn :: Seq Annotation
seqAnn = (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)
-> (Seq Annotation -> [Text]) -> Seq Annotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Text -> [Text]
forall t. Container t => t -> [Element t]
toList (Seq Text -> [Text])
-> (Seq Annotation -> Seq Text) -> Seq Annotation -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotation -> Text) -> Seq Annotation -> Seq Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotation -> Text
annotToText (Seq Annotation -> Text) -> Seq Annotation -> Text
forall a b. (a -> b) -> a -> b
$ Seq Annotation
seqAnn)

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

-- | Decode 'Expression' from 'ByteString'.
eitherDecodeExpression :: BS.ByteString -> Either UnpackError Expression
eitherDecodeExpression :: ByteString -> Either UnpackError Expression
eitherDecodeExpression x :: ByteString
x = Get Expression -> ByteString -> Either UnpackError Expression
forall a. Get a -> ByteString -> 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) (ByteString -> Either UnpackError Expression)
-> ByteString -> Either UnpackError Expression
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
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
  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
  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)
  2 -> Seq Expression -> Expression
ExpressionSeq (Seq Expression -> Expression)
-> (DynamicSize (Seq Expression) -> Seq Expression)
-> DynamicSize (Seq Expression)
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicSize (Seq Expression) -> Seq Expression
forall a. DynamicSize a -> a
unDynamicSize (DynamicSize (Seq Expression) -> Expression)
-> Get (DynamicSize (Seq Expression)) -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get (Seq Expression) -> Get (DynamicSize (Seq Expression))
forall a. Get a -> Get (DynamicSize a)
getDynamic Get (Seq Expression)
getSeq)
  3 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> (MichelinePrimitive -> MichelinePrimAp)
-> MichelinePrimitive
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\pn :: MichelinePrimitive
pn -> MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp MichelinePrimitive
pn Seq Expression
forall a. Seq a
Seq.Empty Seq Annotation
forall a. Seq a
Seq.Empty) (MichelinePrimitive -> Expression)
-> Get MichelinePrimitive -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim
  4 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((MichelinePrimitive
 -> Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Seq Expression
-> MichelinePrimitive
-> Seq Annotation
-> MichelinePrimAp
forall a b c. (a -> b -> c) -> b -> a -> c
flip MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp Seq Expression
forall a. Seq a
Seq.Empty (MichelinePrimitive -> Seq Annotation -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get (Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get (Seq Annotation -> MichelinePrimAp)
-> Get (Seq Annotation) -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Seq Annotation)
getAnnotationSeq)
  5 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get (Seq Expression -> Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get (Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Get (Seq Expression) -> Get (Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expression -> Seq Expression
forall a. a -> Seq a
Seq.singleton (Expression -> Seq Expression)
-> Get Expression -> Get (Seq Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Expression
getExpr) Get (Seq Annotation -> MichelinePrimAp)
-> Get (Seq Annotation) -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Seq Annotation -> Get (Seq Annotation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Annotation
forall a. Seq a
Seq.empty)
  6 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get (Seq Expression -> Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get (Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Get (Seq Expression) -> Get (Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expression -> Seq Expression
forall a. a -> Seq a
Seq.singleton (Expression -> Seq Expression)
-> Get Expression -> Get (Seq Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Expression
getExpr) Get (Seq Annotation -> MichelinePrimAp)
-> Get (Seq Annotation) -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Seq Annotation)
getAnnotationSeq)
  7 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\n :: MichelinePrimitive
n a :: Seq Expression
a -> MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp MichelinePrimitive
n Seq Expression
a Seq Annotation
forall a. Seq a
Seq.empty) (MichelinePrimitive -> Seq Expression -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get (Seq Expression -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get (Seq Expression -> MichelinePrimAp)
-> Get (Seq Expression) -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Get Expression -> Get (Seq Expression)
forall (f :: * -> *) a. Applicative f => Int -> f a -> f (Seq a)
Seq.replicateA 2 Get Expression
getExpr)
  8 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get (Seq Expression -> Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get (Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Get (Seq Expression) -> Get (Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Get Expression -> Get (Seq Expression)
forall (f :: * -> *) a. Applicative f => Int -> f a -> f (Seq a)
Seq.replicateA 2 Get Expression
getExpr Get (Seq Annotation -> MichelinePrimAp)
-> Get (Seq Annotation) -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Seq Annotation)
getAnnotationSeq)
  9 -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Get MichelinePrimAp -> Get Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Get MichelinePrimitive
-> Get (Seq Expression -> Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MichelinePrimitive
getPrim Get (Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Get (Seq Expression) -> Get (Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DynamicSize (Seq Expression) -> Seq Expression
forall a. DynamicSize a -> a
unDynamicSize (DynamicSize (Seq Expression) -> Seq Expression)
-> Get (DynamicSize (Seq Expression)) -> Get (Seq Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get (Seq Expression) -> Get (DynamicSize (Seq Expression))
forall a. Get a -> Get (DynamicSize a)
getDynamic Get (Seq Expression)
getSeq)) Get (Seq Annotation -> MichelinePrimAp)
-> Get (Seq Annotation) -> Get MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Seq Annotation)
getAnnotationSeq)
  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)
  _ -> String -> Get Expression
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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` 7 then Int -> Integer -> Get Integer
forall a. (Num a, Bits a) => Int -> a -> Get a
readZ 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
.&. 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
.&. 0x3f)
  pure $ if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` 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 offset :: Int
offset n :: a
n = do
  Word8
b <- Get Word8
Bi.getWord8
  if (Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) Bool -> Bool -> Bool
&& (Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) then String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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
.&. 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` 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
+ 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 getter :: 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 err :: 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 answer :: 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

getSeq :: Bi.Get (Seq Expression)
getSeq :: Get (Seq Expression)
getSeq =
   [Expression] -> Seq Expression
forall a. [a] -> Seq a
Seq.fromList ([Expression] -> Seq Expression)
-> Get [Expression] -> Get (Seq Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
>>= \ix :: 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
    Nothing -> String -> Get MichelinePrimitive
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "unknown Michelson/Micheline opcode"
    Just str :: 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

getAnnotationSeq :: Bi.Get (Seq Annotation)
getAnnotationSeq :: Get (Seq Annotation)
getAnnotationSeq = (Text -> Get Annotation) -> Seq Text -> Get (Seq 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 (Seq Text -> Get (Seq Annotation))
-> (DynamicSize Text -> Seq Text)
-> DynamicSize Text
-> Get (Seq Annotation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Seq Text
forall a. [a] -> Seq a
Seq.fromList ([Text] -> Seq Text)
-> (DynamicSize Text -> [Text]) -> DynamicSize Text -> Seq Text
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 (Seq Annotation))
-> Get (DynamicSize Text) -> Get (Seq 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)