-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

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

module Morley.Michelson.Untyped.Value
  ( Value' (..)
  , Elt (..)
  -- Internal types to avoid orphan instances
  , InternalByteString(..)
  , unInternalByteString
  , linearizeRightCombValuePair
  , renderValuesList
  , renderSome
  , renderNone
  , renderLeft
  , renderRight
  , renderPair
  , renderElt'
  ) where

import Data.Aeson (FromJSON(..), ToJSON(..), withText)
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Data.List.NonEmpty ((<|))
import Fmt (Buildable(build))
import Text.Hex (decodeHex, encodeHex)
import Text.PrettyPrint.Leijen.Text
  (Doc, braces, dquotes, enclose, semi, space, text, textStrict, (<+>))

import Morley.Michelson.Printer.Util
  (RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens,
  renderOps)
import Morley.Michelson.Text
import Morley.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, a set or a pair.
  -- 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"
      p@(ValuePair _ (ValuePair _ _))  ->
        let encodedValues = linearizeRightCombValuePair p
        in renderValuesList (renderDoc doesntNeedParens) encodedValues
      ValuePair l r  -> renderPair  pn (flip renderDoc l) (flip renderDoc r)
      ValueLeft l    -> renderLeft  pn $ flip renderDoc l
      ValueRight r   -> renderRight pn $ flip renderDoc r
      ValueSome x    -> renderSome  pn $ flip renderDoc x
      ValueNone      -> renderNone
      ValueSeq xs    -> renderValuesList (renderDoc doesntNeedParens) xs
      ValueMap xs    -> renderValuesList renderElt xs
      ValueLambda xs -> renderOps False xs

-- | Helper function to render @None@ @Value@
renderNone :: Doc
renderNone = "None"

-- | Helper functions to render @Value@s
renderSome, renderLeft, renderRight :: RenderContext -> (RenderContext -> Doc) -> Doc
renderSome  pn render = addParens pn $ "Some"  <+> render needsParens
renderLeft  pn render = addParens pn $ "Left"  <+> render needsParens
renderRight pn render = addParens pn $ "Right" <+> render needsParens

-- | Helper function to render @Pair@ @Value@
renderPair :: RenderContext -> (RenderContext -> Doc) -> (RenderContext -> Doc) -> Doc
renderPair pn l r = addParens pn $ "Pair" <+> l needsParens <+> r needsParens

-- | Helper function to render @Elt@
renderElt' :: (RenderContext -> Doc) -> (RenderContext -> Doc) -> Doc
renderElt' l r = "Elt" <+> l needsParens <+> r needsParens

-- | Converts @Pair a (Pair b c)@ to @[a, b, c]@.
linearizeRightCombValuePair :: (Value' op) -> NonEmpty (Value' op)
linearizeRightCombValuePair (ValuePair l r) = l <| linearizeRightCombValuePair r
linearizeRightCombValuePair v = v :| []

renderElt :: RenderDoc op => Elt op -> Doc
renderElt (Elt k v) = renderElt' (flip renderDoc k) (flip renderDoc v)

instance RenderDoc op => RenderDoc (Elt op) where
  renderDoc _ = renderElt

-- | A helper function that renders a 'NonEmpty' list of items in Michelson-readable format,
-- given a rendering function for a single item.
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)

$(mconcat
  [ deriveJSON morleyAesonOptions ''Value'
  , deriveJSON morleyAesonOptions ''Elt
  ])