{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}
module Michelson.Untyped.Value
( Value' (..)
, Elt (..)
, InternalByteString(..)
, unInternalByteString
) where
import Data.Aeson (FromJSON(..), ToJSON(..), withText)
import Data.Aeson.TH (defaultOptions, deriveJSON)
import Data.Data (Data(..))
import Formatting.Buildable (Buildable(build))
import Text.Hex (decodeHex, encodeHex)
import Text.PrettyPrint.Leijen.Text (braces, dquotes, parens, semi, text, textStrict, (<+>))
import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderOps)
import Michelson.Text
data Value' op =
ValueInt Integer
| ValueString MText
| ValueBytes InternalByteString
| ValueUnit
| ValueTrue
| ValueFalse
| ValuePair (Value' op) (Value' op)
| ValueLeft (Value' op)
| ValueRight (Value' op)
| ValueSome (Value' op)
| ValueNone
| ValueNil
| ValueSeq (NonEmpty $ Value' op)
| ValueMap (NonEmpty $ Elt op)
| ValueLambda (NonEmpty op)
deriving stock (Eq, Show, Functor, Data, Generic)
data Elt op = Elt (Value' op) (Value' op)
deriving stock (Eq, Show, Functor, Data, Generic)
newtype InternalByteString = InternalByteString ByteString
deriving stock (Data, Eq, Show)
unInternalByteString :: InternalByteString -> ByteString
unInternalByteString (InternalByteString bs) = bs
instance RenderDoc op => RenderDoc (Value' op) where
renderDoc =
\case
ValueNil -> "{ }"
ValueInt x -> text . show $ x
ValueString x -> dquotes (textStrict $ writeMText x)
ValueBytes xs -> "0x" <> (textStrict . encodeHex . unInternalByteString $ xs)
ValueUnit -> "Unit"
ValueTrue -> "True"
ValueFalse -> "False"
ValuePair l r -> parens $ ("Pair" <+> renderDoc l <+> renderDoc r)
ValueLeft l -> parens $ ("Left" <+> renderDoc l)
ValueRight r -> parens $ ("Right" <+> renderDoc r)
ValueSome x -> parens $ ("Some" <+> renderDoc x)
ValueNone -> "None"
ValueSeq xs -> braces $ mconcat $ (intersperse semi (renderDoc <$> toList xs))
ValueMap xs -> braces $ mconcat $ (intersperse semi (renderDoc <$> toList xs))
ValueLambda xs -> renderOps True xs
instance RenderDoc op => RenderDoc (Elt op) where
renderDoc (Elt k v) = "Elt" <+> renderDoc k <+> renderDoc v
instance (RenderDoc op) => Buildable (Value' op) where
build = buildRenderDoc
instance (RenderDoc op) => Buildable (Elt op) where
build = buildRenderDoc
instance ToJSON InternalByteString where
toJSON = toJSON . encodeHex . unInternalByteString
instance FromJSON InternalByteString where
parseJSON =
withText "Hex-encoded bytestring" $ \t ->
case decodeHex t of
Nothing -> fail "Invalid hex encoding"
Just res -> pure (InternalByteString res)
deriveJSON defaultOptions ''Value'
deriveJSON defaultOptions ''Elt