{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}
module Michelson.Untyped.Value
( Value (..)
, Elt (..)
, InternalByteString(..)
, unInternalByteString
) where
import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Aeson.TH (defaultOptions, deriveJSON)
import Data.Data (Data(..))
import qualified Data.List as L
import Formatting.Buildable (Buildable(build))
import Text.Hex (encodeHex)
import Text.PrettyPrint.Leijen.Text (braces, dquotes, parens, semi, text, textStrict, (<+>))
import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderOps)
data Value op =
ValueInt Integer
| ValueString Text
| 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 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 $ (L.intersperse semi (renderDoc <$> toList xs))
ValueMap xs -> braces $ mconcat $ (L.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 @Text . decodeUtf8 . unInternalByteString
instance FromJSON InternalByteString where
parseJSON = fmap (InternalByteString . encodeUtf8 @Text) . parseJSON
deriveJSON defaultOptions ''Value
deriveJSON defaultOptions ''Elt