{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module PlutusCore.Pretty.PrettyConst where

import PlutusCore.Data

import Codec.Serialise (serialise)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Coerce
import Data.Foldable (fold)
import Data.Proxy
import Data.Text qualified as T
import Data.Word (Word8)
import Numeric (showHex)
import Prettyprinter
import Prettyprinter.Internal (Doc (Text))
import Text.PrettyBy
import Text.PrettyBy.Internal (DefaultPrettyBy (..))
import Universe

{- Note [Prettyprinting built-in constants]
When we're printing PLC
code, the prettyprinter has to render built-in constants.
Unfortunately the instance of `Data.Text.Pretyprint.Doc.Pretty` for
`Char` and `String` (via `Char` and `[]`) does the wrong thing if
control characters are involved.  For example, the string
['a', 'b', 'c', '\n', 'x', '\t', 'y', 'z'] renders as

abc
x    yz

which the PLC parser can't deal with.  However, `show` renders the
string as "abc\nx\tyz" (including the quotes), which can be
successfuly parsed using `read`.  This class provides a
`prettyConst` method which should be used whenever it's necessary
to render a built-in constant: see for example
`PlutusCore.Core.Instance.Pretty.Classic`.  The constraint
`uni `Everywhere` PrettyConst` occurs in many places in the
codebase to make sure that we know how to print a constant from any
type appearing in a universe of built-in types.

Setting up our own machinery for overloading pretty-printing behavior would be laborious,
but fortunately the @prettyprinter-configurable@ library already provides us with all the tools
for doing that and so we define a dummy config for pretty-printing constants, implement a bunch of
instances and derive pretty-printing behavior for non-polymorphic types (including how lists of
such types are pretty-printed) via 'Show'. However always pretty-printing the spine of, say, a list
via 'Show' while pretty-printing its contents via 'PrettyConst' is not something that can be easily
done with the present-day @prettyprinter-configurable@, so we opt for pretty-printing the spine of
a value of a compound type (list of lists, list of tuples, tuple of lists etc) via 'Pretty'.
In practice this means that we have some additional spaces printed after punctuation symbols
that 'show' alone would have omitted, for example:

>>> putStrLn $ displayConst ("abc\nx\tyz∀" :: String, [((), False), ((), True)])
("abc\nx\tyz\8704", [((), False), ((), True)])
>>> putStrLn $ show         ("abc\nx\tyz∀" :: String, [((), False), ((), True)])
("abc\nx\tyz\8704",[((),False),((),True)])

Not a big deal, since 'read' can see through these spaces perfectly fine.
-}

data ConstConfig = ConstConfig
type instance HasPrettyDefaults ConstConfig = 'False

type PrettyConst = PrettyBy ConstConfig

-- These two can be generalized to any @config@, but that breaks some use cases of 'PrettyAny'
-- then. Perhaps we should split the functionality and have two separate @newtype@ wrappers
-- in @prettyprinter-configurable@ instead of a single 'PrettyAny'.
-- For that we'll also need to ensure that it's alright when @HasPrettyDefaults config ~ 'True@.
instance DefaultPrettyBy ConstConfig (PrettyAny a) => NonDefaultPrettyBy ConstConfig (PrettyAny a)
instance DefaultPrettyBy ConstConfig (PrettyAny a) => PrettyBy ConstConfig (PrettyAny a) where
    prettyBy :: ConstConfig -> PrettyAny a -> Doc ann
prettyBy     = ConstConfig -> PrettyAny a -> Doc ann
forall config a ann.
DefaultPrettyBy config a =>
config -> a -> Doc ann
defaultPrettyBy
    prettyListBy :: ConstConfig -> [PrettyAny a] -> Doc ann
prettyListBy = ConstConfig -> [PrettyAny a] -> Doc ann
forall config a ann.
DefaultPrettyBy config a =>
config -> [a] -> Doc ann
defaultPrettyListBy

instance Show a => DefaultPrettyBy ConstConfig (PrettyAny a) where
    defaultPrettyBy :: ConstConfig -> PrettyAny a -> Doc ann
defaultPrettyBy     ConstConfig
_ = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> (PrettyAny a -> String) -> PrettyAny a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Show a => a -> String
forall a. Show a => a -> String
show @a   (a -> String) -> (PrettyAny a -> a) -> PrettyAny a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyAny a -> a
coerce
    defaultPrettyListBy :: ConstConfig -> [PrettyAny a] -> Doc ann
defaultPrettyListBy ConstConfig
_ = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> ([PrettyAny a] -> String) -> [PrettyAny a] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Show [a] => [a] -> String
forall a. Show a => a -> String
show @[a] ([a] -> String)
-> ([PrettyAny a] -> [a]) -> [PrettyAny a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PrettyAny a] -> [a]
coerce

prettyConst :: PrettyConst a => a -> Doc ann
prettyConst :: a -> Doc ann
prettyConst = ConstConfig -> a -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy ConstConfig
ConstConfig

displayConst :: forall str a. (PrettyConst a, Render str) => a -> str
displayConst :: a -> str
displayConst = Doc Any -> str
forall str ann. Render str => Doc ann -> str
render (Doc Any -> str) -> (a -> Doc Any) -> a -> str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyConst a => a -> Doc ann
prettyConst

-- This instance for String quotes control characters (which is what we want)
-- but also Unicode characters (\8704 and so on).
deriving via PrettyAny T.Text  instance NonDefaultPrettyBy ConstConfig T.Text
deriving via PrettyAny ()      instance NonDefaultPrettyBy ConstConfig ()
deriving via PrettyAny Bool    instance NonDefaultPrettyBy ConstConfig Bool
deriving via PrettyAny Integer instance NonDefaultPrettyBy ConstConfig Integer

instance PrettyConst a => NonDefaultPrettyBy ConstConfig [a]
instance (PrettyConst a, PrettyConst b) => NonDefaultPrettyBy ConstConfig (a, b)

instance PrettyBy ConstConfig BS.ByteString where
    prettyBy :: ConstConfig -> ByteString -> Doc ann
prettyBy ConstConfig
_ ByteString
b = Doc ann
"#" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Word8 -> Doc ann
forall ann. Word8 -> Doc ann
asBytes (Word8 -> Doc ann) -> [Word8] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [Word8]
BS.unpack ByteString
b)

-- Special instance for bytestrings
asBytes :: Word8 -> Doc ann
asBytes :: Word8 -> Doc ann
asBytes Word8
x = Int -> Text -> Doc ann
forall ann. Int -> Text -> Doc ann
Text Int
2 (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
addLeadingZero (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Word8 -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex Word8
x String
forall a. Monoid a => a
mempty
    where addLeadingZero :: String -> String
          addLeadingZero :: String -> String
addLeadingZero
              | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
16    = (Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
:)
              | Bool
otherwise = String -> String
forall a. a -> a
id

instance PrettyBy ConstConfig Data where
    prettyBy :: ConstConfig -> Data -> Doc ann
prettyBy ConstConfig
c Data
d = ConstConfig -> ByteString -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy ConstConfig
c (ByteString -> Doc ann) -> ByteString -> Doc ann
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Data -> ByteString
forall a. Serialise a => a -> ByteString
serialise Data
d

instance GShow uni => Pretty (SomeTypeIn uni) where
    pretty :: SomeTypeIn uni -> Doc ann
pretty (SomeTypeIn uni (Esc a)
uni) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ uni (Esc a) -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow uni (Esc a)
uni

-- | Special treatment for built-in constants: see the Note in PlutusCore.Pretty.PrettyConst.
instance (Closed uni, uni `Everywhere` PrettyConst) => Pretty (ValueOf uni a) where
    pretty :: ValueOf uni a -> Doc ann
pretty (ValueOf uni (Esc a)
uni a
x) = Proxy PrettyConst
-> uni (Esc a) -> (PrettyConst a => Doc ann) -> Doc ann
forall (uni :: * -> *) (constr :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a r.
(Closed uni, Everywhere uni constr) =>
proxy constr -> uni (Esc a) -> (constr a => r) -> r
bring (Proxy PrettyConst
forall k (t :: k). Proxy t
Proxy @PrettyConst) uni (Esc a)
uni ((PrettyConst a => Doc ann) -> Doc ann)
-> (PrettyConst a => Doc ann) -> Doc ann
forall a b. (a -> b) -> a -> b
$ a -> Doc ann
forall a ann. PrettyConst a => a -> Doc ann
prettyConst a
x

-- Note that the call to `pretty` here is to the instance for `ValueOf uni a`, which calls prettyConst.
instance (Closed uni, uni `Everywhere` PrettyConst) => Pretty (Some (ValueOf uni)) where
    pretty :: Some (ValueOf uni) -> Doc ann
pretty (Some ValueOf uni a
s) = ValueOf uni a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValueOf uni a
s