-- 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 defines Expression type, its related types
-- and its JSON instance.
module Morley.Micheline.Expression
  ( Annotation(..)
  , Expression(..)
  , MichelinePrimAp(..)
  , MichelinePrimitive(..)
  , michelsonPrimitive
  , annotToText
  , annotFromText
  , genExpression
  , genExpressionSeq
  , genMichelinePrimAp
  , genExprAnnotation
  ) where

import Data.Aeson (FromJSON, ToJSON, parseJSON, toEncoding, toJSON, withObject, withText, (.!=), (.:), (.:?))
import Data.Aeson.Casing (aesonPrefix, snakeCase)
import qualified Data.Aeson.Encoding.Internal as Aeson
import Data.Aeson.TH (deriveToJSON)
import qualified Data.Aeson.Types as Aeson
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Sequence as Seq
import qualified Data.Text as T (uncons)
import Fmt (pretty)
import Hedgehog (MonadGen(GenBase))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import qualified Michelson.Untyped.Annotation as MUA (Annotation)
import Michelson.Untyped.Annotation
  (KnownAnnTag(..), FieldAnn, TypeAnn, VarAnn, TypeTag, FieldTag, VarTag, ann, annPrefix)
import Morley.Micheline.Json
import Util.ByteString (HexJSONByteString(..))
import Util.Test.Gen (genAnnotation)

newtype MichelinePrimitive = MichelinePrimitive Text
  deriving newtype (MichelinePrimitive -> MichelinePrimitive -> Bool
(MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> Eq MichelinePrimitive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c/= :: MichelinePrimitive -> MichelinePrimitive -> Bool
== :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c== :: MichelinePrimitive -> MichelinePrimitive -> Bool
Eq, Eq MichelinePrimitive
Eq MichelinePrimitive =>
(MichelinePrimitive -> MichelinePrimitive -> Ordering)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive)
-> (MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive)
-> Ord MichelinePrimitive
MichelinePrimitive -> MichelinePrimitive -> Bool
MichelinePrimitive -> MichelinePrimitive -> Ordering
MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
$cmin :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
max :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
$cmax :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
>= :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c>= :: MichelinePrimitive -> MichelinePrimitive -> Bool
> :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c> :: MichelinePrimitive -> MichelinePrimitive -> Bool
<= :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c<= :: MichelinePrimitive -> MichelinePrimitive -> Bool
< :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c< :: MichelinePrimitive -> MichelinePrimitive -> Bool
compare :: MichelinePrimitive -> MichelinePrimitive -> Ordering
$ccompare :: MichelinePrimitive -> MichelinePrimitive -> Ordering
$cp1Ord :: Eq MichelinePrimitive
Ord, [MichelinePrimitive] -> Encoding
[MichelinePrimitive] -> Value
MichelinePrimitive -> Encoding
MichelinePrimitive -> Value
(MichelinePrimitive -> Value)
-> (MichelinePrimitive -> Encoding)
-> ([MichelinePrimitive] -> Value)
-> ([MichelinePrimitive] -> Encoding)
-> ToJSON MichelinePrimitive
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MichelinePrimitive] -> Encoding
$ctoEncodingList :: [MichelinePrimitive] -> Encoding
toJSONList :: [MichelinePrimitive] -> Value
$ctoJSONList :: [MichelinePrimitive] -> Value
toEncoding :: MichelinePrimitive -> Encoding
$ctoEncoding :: MichelinePrimitive -> Encoding
toJSON :: MichelinePrimitive -> Value
$ctoJSON :: MichelinePrimitive -> Value
ToJSON, Value -> Parser [MichelinePrimitive]
Value -> Parser MichelinePrimitive
(Value -> Parser MichelinePrimitive)
-> (Value -> Parser [MichelinePrimitive])
-> FromJSON MichelinePrimitive
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MichelinePrimitive]
$cparseJSONList :: Value -> Parser [MichelinePrimitive]
parseJSON :: Value -> Parser MichelinePrimitive
$cparseJSON :: Value -> Parser MichelinePrimitive
FromJSON)
  deriving stock (Int -> MichelinePrimitive -> ShowS
[MichelinePrimitive] -> ShowS
MichelinePrimitive -> String
(Int -> MichelinePrimitive -> ShowS)
-> (MichelinePrimitive -> String)
-> ([MichelinePrimitive] -> ShowS)
-> Show MichelinePrimitive
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MichelinePrimitive] -> ShowS
$cshowList :: [MichelinePrimitive] -> ShowS
show :: MichelinePrimitive -> String
$cshow :: MichelinePrimitive -> String
showsPrec :: Int -> MichelinePrimitive -> ShowS
$cshowsPrec :: Int -> MichelinePrimitive -> ShowS
Show)

michelsonPrimitive :: Seq Text
michelsonPrimitive :: Seq Text
michelsonPrimitive = [Text] -> Seq Text
forall a. [a] -> Seq a
Seq.fromList [
  "parameter", "storage", "code", "False", "Elt", "Left", "None", "Pair",
  "Right", "Some", "True", "Unit", "PACK", "UNPACK", "BLAKE2B", "SHA256",
  "SHA512", "ABS", "ADD", "AMOUNT", "AND", "BALANCE", "CAR", "CDR",
  "CHECK_SIGNATURE", "COMPARE", "CONCAT", "CONS", "CREATE_ACCOUNT",
  "CREATE_CONTRACT", "IMPLICIT_ACCOUNT", "DIP", "DROP", "DUP", "EDIV",
  "EMPTY_MAP", "EMPTY_SET", "EQ", "EXEC", "FAILWITH", "GE", "GET", "GT",
  "HASH_KEY", "IF", "IF_CONS", "IF_LEFT", "IF_NONE", "INT", "LAMBDA",
  "LE", "LEFT", "LOOP", "LSL", "LSR", "LT", "MAP", "MEM", "MUL", "NEG",
  "NEQ", "NIL", "NONE", "NOT", "NOW", "OR", "PAIR", "PUSH", "RIGHT",
  "SIZE", "SOME", "SOURCE", "SENDER", "SELF", "STEPS_TO_QUOTA", "SUB",
  "SWAP", "TRANSFER_TOKENS", "SET_DELEGATE", "UNIT", "UPDATE", "XOR",
  "ITER", "LOOP_LEFT", "ADDRESS", "CONTRACT", "ISNAT", "CAST", "RENAME",
  "bool", "contract", "int", "key", "key_hash", "lambda", "list", "map",
  "big_map", "nat", "option", "or", "pair", "set", "signature", "string",
  "bytes", "mutez", "timestamp", "unit", "operation", "address", "SLICE",
  "DIG", "DUG", "EMPTY_BIG_MAP", "APPLY", "chain_id", "CHAIN_ID"
  ]

-- | Type for Micheline Expression
data Expression
  = ExpressionInt Integer
    -- ^ Micheline represents both nats and ints using the same decimal format.
    -- The Haskell Integer type spans all possible values that the final
    -- (Michelson) type could end up being, and then some, so we use
    -- (StringEncode Integer) to represent all integral values here for easy
    -- JSON encoding compatibility.
  | ExpressionString Text
  | ExpressionBytes ByteString
  | ExpressionSeq (Seq Expression)
  | ExpressionPrim MichelinePrimAp
  deriving stock (Expression -> Expression -> Bool
(Expression -> Expression -> Bool)
-> (Expression -> Expression -> Bool) -> Eq Expression
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expression -> Expression -> Bool
$c/= :: Expression -> Expression -> Bool
== :: Expression -> Expression -> Bool
$c== :: Expression -> Expression -> Bool
Eq, Int -> Expression -> ShowS
[Expression] -> ShowS
Expression -> String
(Int -> Expression -> ShowS)
-> (Expression -> String)
-> ([Expression] -> ShowS)
-> Show Expression
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expression] -> ShowS
$cshowList :: [Expression] -> ShowS
show :: Expression -> String
$cshow :: Expression -> String
showsPrec :: Int -> Expression -> ShowS
$cshowsPrec :: Int -> Expression -> ShowS
Show)

data Annotation
  = AnnotationType TypeAnn
  | AnnotationVariable VarAnn
  | AnnotationField FieldAnn
  deriving stock (Annotation -> Annotation -> Bool
(Annotation -> Annotation -> Bool)
-> (Annotation -> Annotation -> Bool) -> Eq Annotation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Annotation -> Annotation -> Bool
$c/= :: Annotation -> Annotation -> Bool
== :: Annotation -> Annotation -> Bool
$c== :: Annotation -> Annotation -> Bool
Eq, Int -> Annotation -> ShowS
[Annotation] -> ShowS
Annotation -> String
(Int -> Annotation -> ShowS)
-> (Annotation -> String)
-> ([Annotation] -> ShowS)
-> Show Annotation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Annotation] -> ShowS
$cshowList :: [Annotation] -> ShowS
show :: Annotation -> String
$cshow :: Annotation -> String
showsPrec :: Int -> Annotation -> ShowS
$cshowsPrec :: Int -> Annotation -> ShowS
Show)

data MichelinePrimAp = MichelinePrimAp
  { MichelinePrimAp -> MichelinePrimitive
mpaPrim :: MichelinePrimitive
  , MichelinePrimAp -> Seq Expression
mpaArgs :: Seq Expression
  , MichelinePrimAp -> Seq Annotation
mpaAnnots :: Seq Annotation
  } deriving stock (MichelinePrimAp -> MichelinePrimAp -> Bool
(MichelinePrimAp -> MichelinePrimAp -> Bool)
-> (MichelinePrimAp -> MichelinePrimAp -> Bool)
-> Eq MichelinePrimAp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MichelinePrimAp -> MichelinePrimAp -> Bool
$c/= :: MichelinePrimAp -> MichelinePrimAp -> Bool
== :: MichelinePrimAp -> MichelinePrimAp -> Bool
$c== :: MichelinePrimAp -> MichelinePrimAp -> Bool
Eq, Int -> MichelinePrimAp -> ShowS
[MichelinePrimAp] -> ShowS
MichelinePrimAp -> String
(Int -> MichelinePrimAp -> ShowS)
-> (MichelinePrimAp -> String)
-> ([MichelinePrimAp] -> ShowS)
-> Show MichelinePrimAp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MichelinePrimAp] -> ShowS
$cshowList :: [MichelinePrimAp] -> ShowS
show :: MichelinePrimAp -> String
$cshow :: MichelinePrimAp -> String
showsPrec :: Int -> MichelinePrimAp -> ShowS
$cshowsPrec :: Int -> MichelinePrimAp -> ShowS
Show)

instance FromJSON MichelinePrimAp where
  parseJSON :: Value -> Parser MichelinePrimAp
parseJSON = String
-> (Object -> Parser MichelinePrimAp)
-> Value
-> Parser MichelinePrimAp
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "Prim" ((Object -> Parser MichelinePrimAp)
 -> Value -> Parser MichelinePrimAp)
-> (Object -> Parser MichelinePrimAp)
-> Value
-> Parser MichelinePrimAp
forall a b. (a -> b) -> a -> b
$ \v :: Object
v -> MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp
    (MichelinePrimitive
 -> Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Parser MichelinePrimitive
-> Parser (Seq Expression -> Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser MichelinePrimitive
forall a. FromJSON a => Object -> Text -> Parser a
.: "prim"
    Parser (Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> Parser (Seq Expression)
-> Parser (Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe (Seq Expression))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "args" Parser (Maybe (Seq Expression))
-> Seq Expression -> Parser (Seq Expression)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Seq Expression
forall a. Monoid a => a
mempty
    Parser (Seq Annotation -> MichelinePrimAp)
-> Parser (Seq Annotation) -> Parser MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe (Seq Annotation))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "annots" Parser (Maybe (Seq Annotation))
-> Seq Annotation -> Parser (Seq Annotation)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Seq Annotation
forall a. Monoid a => a
mempty

deriveToJSON (aesonPrefix snakeCase) ''MichelinePrimAp

annotFromText :: MonadFail m => Text -> m Annotation
annotFromText :: Text -> m Annotation
annotFromText txt :: Text
txt = case Maybe Annotation
result of
    Just a :: Annotation
a -> Annotation -> m Annotation
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotation
a
    Nothing -> String -> m Annotation
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unknown annotation type"
  where
    result :: Maybe Annotation
result = (TypeAnn -> Annotation
AnnotationType (TypeAnn -> Annotation) -> Maybe TypeAnn -> Maybe Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe TypeAnn
forall tag. KnownAnnTag tag => Text -> Maybe (Annotation tag)
stripPrefix @TypeTag Text
txt)
         Maybe Annotation -> Maybe Annotation -> Maybe Annotation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (VarAnn -> Annotation
AnnotationVariable (VarAnn -> Annotation) -> Maybe VarAnn -> Maybe Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe VarAnn
forall tag. KnownAnnTag tag => Text -> Maybe (Annotation tag)
stripPrefix @VarTag Text
txt)
         Maybe Annotation -> Maybe Annotation -> Maybe Annotation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (FieldAnn -> Annotation
AnnotationField (FieldAnn -> Annotation) -> Maybe FieldAnn -> Maybe Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe FieldAnn
forall tag. KnownAnnTag tag => Text -> Maybe (Annotation tag)
stripPrefix @FieldTag Text
txt)

stripPrefix :: forall tag . KnownAnnTag tag => Text -> Maybe (MUA.Annotation tag)
stripPrefix :: Text -> Maybe (Annotation tag)
stripPrefix txt :: Text
txt = do
  (n :: Char
n, t :: Text
t) <- Text -> Maybe (Char, Text)
T.uncons Text
txt
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String -> Text
forall a. ToText a => a -> Text
toText [Char
n] Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
prefix)
  Annotation tag -> Maybe (Annotation tag)
forall a. a -> Maybe a
Just (Annotation tag -> Maybe (Annotation tag))
-> Annotation tag -> Maybe (Annotation tag)
forall a b. (a -> b) -> a -> b
$ Text -> Annotation tag
forall k (a :: k). HasCallStack => Text -> Annotation a
ann Text
t
  where
    prefix :: Text
prefix = KnownAnnTag tag => Text
forall tag. KnownAnnTag tag => Text
annPrefix @tag

annotToText :: Annotation -> Text
annotToText :: Annotation -> Text
annotToText = \case
  AnnotationType n :: TypeAnn
n -> TypeAnn -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty TypeAnn
n
  AnnotationVariable n :: VarAnn
n -> VarAnn -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty VarAnn
n
  AnnotationField n :: FieldAnn
n -> FieldAnn -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty FieldAnn
n

instance FromJSON Annotation where
  parseJSON :: Value -> Parser Annotation
parseJSON = String -> (Text -> Parser Annotation) -> Value -> Parser Annotation
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText "Annotation" Text -> Parser Annotation
forall (m :: * -> *). MonadFail m => Text -> m Annotation
annotFromText

instance ToJSON Annotation where
  toJSON :: Annotation -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Annotation -> Text) -> Annotation -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Text
annotToText
  toEncoding :: Annotation -> Encoding
toEncoding = Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Text -> Encoding)
-> (Annotation -> Text) -> Annotation -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Text
annotToText

instance FromJSON Expression where
  parseJSON :: Value -> Parser Expression
parseJSON v :: Value
v = Seq Expression -> Expression
ExpressionSeq (Seq Expression -> Expression)
-> Parser (Seq Expression) -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Seq Expression)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
            Parser Expression -> Parser Expression -> Parser Expression
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> Parser MichelinePrimAp -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser MichelinePrimAp
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
            Parser Expression -> Parser Expression -> Parser Expression
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Expression
ExpressionString (Text -> Expression) -> Parser Text -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Object -> Parser Text) -> Value -> Parser Text
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "ExpressionString" (Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: "string") Value
v
            Parser Expression -> Parser Expression -> Parser Expression
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Expression
ExpressionInt (Integer -> Expression)
-> (StringEncode Integer -> Integer)
-> StringEncode Integer
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringEncode Integer -> Integer
forall a. StringEncode a -> a
unStringEncode (StringEncode Integer -> Expression)
-> Parser (StringEncode Integer) -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> (Object -> Parser (StringEncode Integer))
-> Value
-> Parser (StringEncode Integer)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "ExpressionInt" (Object -> Text -> Parser (StringEncode Integer)
forall a. FromJSON a => Object -> Text -> Parser a
.: "int") Value
v
            Parser Expression -> Parser Expression -> Parser Expression
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Expression
ExpressionBytes (ByteString -> Expression)
-> (HexJSONByteString -> ByteString)
-> HexJSONByteString
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexJSONByteString -> ByteString
unHexJSONByteString (HexJSONByteString -> Expression)
-> Parser HexJSONByteString -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> (Object -> Parser HexJSONByteString)
-> Value
-> Parser HexJSONByteString
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "ExpressionBytes" (Object -> Text -> Parser HexJSONByteString
forall a. FromJSON a => Object -> Text -> Parser a
.: "bytes") Value
v

instance ToJSON Expression where
  toJSON :: Expression -> Value
toJSON (ExpressionSeq xs :: Seq Expression
xs) = Seq Expression -> Value
forall a. ToJSON a => a -> Value
toJSON Seq Expression
xs
  toJSON (ExpressionPrim xs :: MichelinePrimAp
xs) = MichelinePrimAp -> Value
forall a. ToJSON a => a -> Value
toJSON MichelinePrimAp
xs
  toJSON (ExpressionString x :: Text
x) = Object -> Value
Aeson.Object (Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton "string" (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
x)
  toJSON (ExpressionInt x :: Integer
x) = Object -> Value
Aeson.Object (Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton "int" (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ StringEncode Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (StringEncode Integer -> Value) -> StringEncode Integer -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> StringEncode Integer
forall a. a -> StringEncode a
StringEncode Integer
x)
  toJSON (ExpressionBytes x :: ByteString
x) = Object -> Value
Aeson.Object (Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton "bytes" (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ HexJSONByteString -> Value
forall a. ToJSON a => a -> Value
toJSON (HexJSONByteString -> Value) -> HexJSONByteString -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> HexJSONByteString
HexJSONByteString ByteString
x)

  toEncoding :: Expression -> Encoding
toEncoding (ExpressionSeq xs :: Seq Expression
xs) = Seq Expression -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding Seq Expression
xs
  toEncoding (ExpressionPrim xs :: MichelinePrimAp
xs) = MichelinePrimAp -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding MichelinePrimAp
xs
  toEncoding (ExpressionString x :: Text
x) = Series -> Encoding
Aeson.pairs (Text -> Encoding -> Series
Aeson.pair "string" (Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding Text
x))
  toEncoding (ExpressionInt x :: Integer
x) = Series -> Encoding
Aeson.pairs (Text -> Encoding -> Series
Aeson.pair "int" (StringEncode Integer -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (StringEncode Integer -> Encoding)
-> StringEncode Integer -> Encoding
forall a b. (a -> b) -> a -> b
$ Integer -> StringEncode Integer
forall a. a -> StringEncode a
StringEncode Integer
x))
  toEncoding (ExpressionBytes x :: ByteString
x) = Series -> Encoding
Aeson.pairs (Text -> Encoding -> Series
Aeson.pair "bytes" (HexJSONByteString -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (HexJSONByteString -> Encoding) -> HexJSONByteString -> Encoding
forall a b. (a -> b) -> a -> b
$ ByteString -> HexJSONByteString
HexJSONByteString ByteString
x))

-----------------------------------------------------
-- Gen Function for testing
-----------------------------------------------------

genExpression :: forall m. (MonadGen m, GenBase m ~ Identity) => m Expression
genExpression :: m Expression
genExpression = ([m Expression] -> m Expression)
-> [m Expression] -> [m Expression] -> m Expression
forall (m :: * -> *) a.
MonadGen m =>
([m a] -> m a) -> [m a] -> [m a] -> m a
Gen.recursive [m Expression] -> m Expression
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
  [m Expression
genExpressionInt, m Expression
genExpressionString, m Expression
genExpressionBytes]
  [m Expression
genSeq, m Expression
genExpressionPrim]
  where
    genExpressionInt :: m Expression
genExpressionInt = Integer -> Expression
ExpressionInt (Integer -> Expression) -> m Integer -> m Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range Integer -> m Integer
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (Integer -> Integer -> Integer -> Range Integer
forall a. Integral a => a -> a -> a -> Range a
Range.linearFrom 0 -1000 1000))
    genExpressionString :: m Expression
genExpressionString = Text -> Expression
ExpressionString (Text -> Expression) -> m Text -> m Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range Int -> m Char -> m Text
forall (m :: * -> *). MonadGen m => Range Int -> m Char -> m Text
Gen.text (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear 0 10) m Char
forall (m :: * -> *). MonadGen m => m Char
Gen.unicodeAll)
    genExpressionBytes :: m Expression
genExpressionBytes = ByteString -> Expression
ExpressionBytes (ByteString -> Expression) -> m ByteString -> m Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range Int -> m ByteString
forall (m :: * -> *). MonadGen m => Range Int -> m ByteString
Gen.bytes (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear 0 100))
    genSeq :: m Expression
genSeq = Seq Expression -> Expression
ExpressionSeq (Seq Expression -> Expression)
-> m (Seq Expression) -> m Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Seq Expression)
forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m (Seq Expression)
genExpressionSeq
    genExpressionPrim :: m Expression
genExpressionPrim = MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression)
-> m MichelinePrimAp -> m Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m MichelinePrimAp
forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m MichelinePrimAp
genMichelinePrimAp

genExpressionSeq :: forall m. (MonadGen m, GenBase m ~ Identity) => m (Seq Expression)
genExpressionSeq :: m (Seq Expression)
genExpressionSeq = (Range Int -> m Expression -> m (Seq Expression)
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m (Seq a)
Gen.seq (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear 0 10) m Expression
forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m Expression
genExpression)

genMichelinePrimAp :: forall m. (MonadGen m, GenBase m ~ Identity) => m MichelinePrimAp
genMichelinePrimAp :: m MichelinePrimAp
genMichelinePrimAp = MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp (MichelinePrimitive
 -> Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> m MichelinePrimitive
-> m (Seq Expression -> Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m MichelinePrimitive
genMichelinePrimitive m (Seq Expression -> Seq Annotation -> MichelinePrimAp)
-> m (Seq Expression) -> m (Seq Annotation -> MichelinePrimAp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Seq Expression)
forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m (Seq Expression)
genExpressionSeq m (Seq Annotation -> MichelinePrimAp)
-> m (Seq Annotation) -> m MichelinePrimAp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Seq Annotation)
genAnnots
  where
    genMichelinePrimitive :: m MichelinePrimitive
genMichelinePrimitive = Text -> MichelinePrimitive
MichelinePrimitive (Text -> MichelinePrimitive) -> m Text -> m MichelinePrimitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text] -> m Text
forall (m :: * -> *) a. MonadGen m => [a] -> m a
Gen.element ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Seq Text -> [Element (Seq Text)]
forall t. Container t => t -> [Element t]
toList Seq Text
michelsonPrimitive)

    genAnnots :: m (Seq Annotation)
    genAnnots :: m (Seq Annotation)
genAnnots = Range Int -> m Annotation -> m (Seq Annotation)
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m (Seq a)
Gen.seq (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear 0 10) m Annotation
forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m Annotation
genExprAnnotation

genExprAnnotation :: forall m. (MonadGen m, GenBase m ~ Identity) => m Annotation
genExprAnnotation :: m Annotation
genExprAnnotation =  [m Annotation] -> m Annotation
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
  [m Annotation
genAnnotationType, m Annotation
genAnnotationVariable, m Annotation
genAnnotationField]
  where
    genAnnotationType :: m Annotation
genAnnotationType = TypeAnn -> Annotation
AnnotationType (TypeAnn -> Annotation) -> m TypeAnn -> m Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m TypeAnn
forall k (m :: * -> *) (a :: k).
(MonadGen m, GenBase m ~ Identity) =>
m (Annotation a)
genAnnotation
    genAnnotationVariable :: m Annotation
genAnnotationVariable = VarAnn -> Annotation
AnnotationVariable (VarAnn -> Annotation) -> m VarAnn -> m Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VarAnn
forall k (m :: * -> *) (a :: k).
(MonadGen m, GenBase m ~ Identity) =>
m (Annotation a)
genAnnotation
    genAnnotationField :: m Annotation
genAnnotationField = FieldAnn -> Annotation
AnnotationField (FieldAnn -> Annotation) -> m FieldAnn -> m Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FieldAnn
forall k (m :: * -> *) (a :: k).
(MonadGen m, GenBase m ~ Identity) =>
m (Annotation a)
genAnnotation