-- 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
  ) 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 (Buildable(..), pretty, (+|), (|+))

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

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)

instance Buildable Expression where
  build :: Expression -> Builder
build = \case
    ExpressionInt i :: Integer
i -> Integer -> Builder
forall p. Buildable p => p -> Builder
build (Integer -> Builder) -> Integer -> Builder
forall a b. (a -> b) -> a -> b
$ Integer
i
    ExpressionString s :: Text
s -> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
s
    ExpressionBytes b :: ByteString
b ->
      Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeBase58Check ByteString
b
    ExpressionSeq s :: Seq Expression
s -> "(" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| (Element (Seq Expression) -> Builder) -> Seq Expression -> Builder
forall c t.
(Monoid c, IsString c, Container t) =>
(Element t -> c) -> t -> c
buildSeq Element (Seq Expression) -> Builder
forall p. Buildable p => p -> Builder
build Seq Expression
s Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ")"
    ExpressionPrim (MichelinePrimAp (MichelinePrimitive text :: Text
text) s :: Seq Expression
s annots :: Seq Annotation
annots) ->
      Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ "(" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
      (Element (Seq Expression) -> Builder) -> Seq Expression -> Builder
forall c t.
(Monoid c, IsString c, Container t) =>
(Element t -> c) -> t -> c
buildSeq Element (Seq Expression) -> Builder
forall p. Buildable p => p -> Builder
build Seq Expression
s Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ") " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
      (Element (Seq Annotation) -> Builder) -> Seq Annotation -> Builder
forall c t.
(Monoid c, IsString c, Container t) =>
(Element t -> c) -> t -> c
buildSeq (Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> (Annotation -> Text) -> Annotation -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Text
annotToText) Seq Annotation
annots
    where
      buildSeq :: (Element t -> c) -> t -> c
buildSeq buildElem :: Element t -> c
buildElem =
        [c] -> c
forall a. Monoid a => [a] -> a
mconcat ([c] -> c) -> (t -> [c]) -> t -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> [c] -> [c]
forall a. a -> [a] -> [a]
intersperse ", " ([c] -> [c]) -> (t -> [c]) -> t -> [c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element t -> c) -> [Element t] -> [c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map
        Element t -> c
buildElem ([Element t] -> [c]) -> (t -> [Element t]) -> t -> [c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [Element t]
forall t. Container t => t -> [Element t]
toList

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

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))

deriveToJSON (aesonPrefix snakeCase) ''MichelinePrimAp