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
(Doc, braces, dquotes, enclose, semi, space, text, textStrict, (<+>))
import Michelson.Printer.Util
(RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens, 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 pn =
\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 -> addParens pn $
"Pair" <+> renderDoc needsParens l <+> renderDoc needsParens r
ValueLeft l -> addParens pn $
"Left" <+> renderDoc needsParens l
ValueRight r -> addParens pn $
"Right" <+> renderDoc needsParens r
ValueSome x -> addParens pn $
"Some" <+> renderDoc needsParens x
ValueNone -> "None"
ValueSeq xs -> renderValuesList (renderDoc doesntNeedParens) xs
ValueMap xs -> renderValuesList renderElt xs
ValueLambda xs -> renderOps True xs
renderElt :: RenderDoc op => Elt op -> Doc
renderElt (Elt k v) =
"Elt" <+> renderDoc needsParens k <+> renderDoc needsParens v
instance RenderDoc op => RenderDoc (Elt op) where
renderDoc _ = renderElt
renderValuesList :: (e -> Doc) -> NonEmpty e -> Doc
renderValuesList renderElem (toList -> es) =
braces . enclose space space $
mconcat . intersperse (semi <> space) $
renderElem <$> es
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