-- 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
  , renderValuesList
  , renderSome
  , renderNone
  , renderLeft
  , renderRight
  , renderPair
  , renderElt'
  ) where

import Prelude hiding (group)

import Data.Aeson (FromJSON(..), ToJSON(..), withText)
import Data.Aeson.Types (genericParseJSON, genericToEncoding, genericToJSON)
import Data.Data (Data(..))
import Fmt (Doc, build, hexF, (<+>))
import Fmt qualified as PP ((<$>))
import Prettyprinter
  (align, dquotes, encloseSep, group, hang, lbrace, rbrace, semi, sep, softline, space)
import Text.Hex (decodeHex, encodeHex)

import Morley.Michelson.Printer.Util
import Morley.Michelson.Text
import Morley.Michelson.Untyped.HoistInstr
import Morley.Util.Aeson

data Value' f op =
    ValueInt     Integer
  | ValueString  MText
  | ValueBytes   InternalByteString
  | ValueUnit
  | ValueTrue
  | ValueFalse
  | ValuePair    (Value' f op) (Value' f op)
  | ValueLeft    (Value' f op)
  | ValueRight   (Value' f op)
  | ValueSome    (Value' f op)
  | ValueNone
  | ValueNil
  | ValueSeq     (NonEmpty $ Value' f 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 f op)
  | ValueLambda  (f op)
  -- ^ Invariant: contains non-empty list of instructions. For an empty list,
  -- use 'ValueNil'.
  | ValueLamRec  (f op)
  deriving stock (Eq, Show, Functor, Data, Generic)

instance HoistInstr Value' where
  hoistInstr f = \case
    ValueInt n -> ValueInt n
    ValueString t -> ValueString t
    ValueBytes bs -> ValueBytes bs
    ValueUnit -> ValueUnit
    ValueTrue -> ValueTrue
    ValueFalse -> ValueFalse
    ValueNone -> ValueNone
    ValueNil -> ValueNil
    ValuePair l r -> ValuePair (hoistInstr f l) (hoistInstr f r)
    ValueLeft l -> ValueLeft $ hoistInstr f l
    ValueRight l -> ValueRight $ hoistInstr f l
    ValueSome l -> ValueSome $ hoistInstr f l
    ValueSeq vs -> ValueSeq $ hoistInstr f <$> vs
    ValueMap els -> ValueMap $ hoistInstr f <$> els
    ValueLambda ops -> ValueLambda $ f ops
    ValueLamRec ops -> ValueLamRec $ f ops

instance NFData (f op) => NFData (Value' f op)

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

instance HoistInstr Elt where
  hoistInstr f (Elt l r) = Elt (hoistInstr f l) (hoistInstr f r)

instance NFData (f op) => NFData (Elt f 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 (Foldable f, RenderDoc op) => RenderDoc (Value' f op) where
  renderDoc pn =
    \case
      ValueNil       -> "{ }"
      ValueInt x     -> build x
      ValueString x  -> dquotes (build $ writeMText x)
      ValueBytes xs  -> "0x" <> (hexF . unInternalByteString $ xs)
      ValueUnit      -> "Unit"
      ValueTrue      -> "True"
      ValueFalse     -> "False"
      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 -> renderOpsList False xs
      ValueLamRec xs -> "Lambda_rec" <+> align (renderOpsList 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 = renderContainer pn $ "Some" PP.<$> render needsParens
renderLeft  pn render = renderContainer pn $ "Left" PP.<$> render needsParens
renderRight pn render = renderContainer pn $ "Right" PP.<$> render needsParens

-- | Helper function to format container values such as @Some@ and @Right@.
renderContainer :: RenderContext -> Doc -> Doc
renderContainer pn doc = addParensMultiline pn $ group $ hang 2 $ doc

-- | Helper function to render @Pair@ @Value@
renderPair :: RenderContext -> (RenderContext -> Doc) -> (RenderContext -> Doc) -> Doc
renderPair pn l r = addParensMultiline pn $ hang 2 $
  sep ["Pair", l needsParens, r needsParens]

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

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

instance (Foldable f, RenderDoc op) => RenderDoc (Elt f 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) =
  align $ encloseSep (lbrace <> space) (softline <> rbrace) (semi <> space) $
    renderElem <$> es

----------------------------------------------------------------------------
-- 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)


instance FromJSON (f op) => FromJSON (Value' f op) where
    parseJSON = genericParseJSON morleyAesonOptions
instance ToJSON (f op) => ToJSON (Value' f op) where
    toJSON     = genericToJSON morleyAesonOptions
    toEncoding = genericToEncoding morleyAesonOptions

instance FromJSON (f op) => FromJSON (Elt f op) where
    parseJSON = genericParseJSON morleyAesonOptions
instance ToJSON (f op) => ToJSON (Elt f op) where
    toJSON     = genericToJSON morleyAesonOptions
    toEncoding = genericToEncoding morleyAesonOptions