Value.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Untyped Michelson values (i. e. type of a value is not statically known).

module Michelson.Untyped.Value
  ( Value' (..)
  , Elt (..)
  -- Internal types to avoid orphan instances
  , InternalByteString(..)
  , unInternalByteString
  ) where

import Data.Aeson (FromJSON(..), ToJSON(..), withText)
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Fmt (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
import Util.Aeson

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)
  -- ^ A sequence of elements: can be a list or a set.
  -- We can't distinguish lists and sets during parsing.
  | ValueMap     (NonEmpty $ Elt op)
  | ValueLambda  (NonEmpty op)
  deriving stock (Eq, Show, Functor, Data, Generic)

instance NFData op => NFData (Value' op)

data Elt op = Elt (Value' op) (Value' op)
  deriving stock (Eq, Show, Functor, Data, Generic)

instance NFData op => NFData (Elt op)

-- | ByteString does not have an instance for ToJSON and FromJSON, to
-- avoid orphan type class instances, make a new type wrapper around it.
newtype InternalByteString = InternalByteString ByteString
  deriving stock (Data, Eq, Show, Generic)

instance NFData InternalByteString

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

----------------------------------------------------------------------------
-- JSON serialization
----------------------------------------------------------------------------

-- it is not possible to derives these automatically because
-- ByteString does not have a ToJSON or FromJSON instance

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 morleyAesonOptions ''Value'
deriveJSON morleyAesonOptions ''Elt