-- editorconfig-checker-disable-file
{-# OPTIONS_GHC -fno-warn-orphans #-}

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

module PlutusCore.Pretty.PrettyConst where

import PlutusCore.Data
import PlutusCore.Pretty.Readable

import Control.Lens hiding (List)
import Data.ByteString qualified as BS
import Data.Coerce
import Data.Foldable (fold)
import Data.List.NonEmpty
import Data.Proxy
import Data.Text qualified as T
import Data.Typeable
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 'Text' does the wrong thing if control characters
are involved. For example, the 'Text' "abc\nx\tyz" 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).

This module 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:

>>> let whateverList = ("abc\nx\tyz∀" :: Text, [((), False), ((), True)])
>>> print $ prettyConst botRenderContext whateverList
("abc\nx\tyz\8704", [((), False), ((), True)])
>>> putStrLn $ show whateverList
("abc\nx\tyz\8704",[((),False),((),True)])

Not a big deal, since our parser isn't whitespace-sensitive.
-}

-- See Note [Prettyprinting built-in constants].
-- | The type of configs used for pretty-printing constants. Has a 'RenderContext' inside, so that
-- we don't add redundant parens to the output.
newtype ConstConfig = ConstConfig
    { ConstConfig -> RenderContext
unConstConfig :: RenderContext
    }
type instance HasPrettyDefaults ConstConfig = 'False

instance HasRenderContext ConstConfig where
    renderContext :: Lens' ConstConfig RenderContext
renderContext = (RenderContext -> f RenderContext) -> ConstConfig -> f ConstConfig
forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b
Iso ConstConfig ConstConfig RenderContext RenderContext
coerced

type PrettyConst = PrettyBy ConstConfig

-- | The set of constraints we need to be able to print built-in types and their values.
type PrettyUni uni = (PrettyParens (SomeTypeIn uni), Closed uni, uni `Everywhere` PrettyConst)

-- | The set of constraints we need to be able to throw exceptions with things with built-in types
-- and functions in them.
type ThrowableBuiltins uni fun = (PrettyUni uni, Pretty fun, Typeable uni, Typeable fun)

-- 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 :: forall ann. ConstConfig -> PrettyAny a -> Doc ann
prettyBy     = ConstConfig -> PrettyAny a -> Doc ann
forall ann. ConstConfig -> PrettyAny a -> Doc ann
forall config a ann.
DefaultPrettyBy config a =>
config -> a -> Doc ann
defaultPrettyBy
    prettyListBy :: forall ann. ConstConfig -> [PrettyAny a] -> Doc ann
prettyListBy = ConstConfig -> [PrettyAny a] -> Doc ann
forall ann. 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 :: forall ann. ConstConfig -> PrettyAny a -> Doc ann
defaultPrettyBy     ConstConfig
_ = String -> Doc ann
forall ann. 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
. 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
forall a b. Coercible a b => a -> b
coerce
    defaultPrettyListBy :: forall ann. ConstConfig -> [PrettyAny a] -> Doc ann
defaultPrettyListBy ConstConfig
_ = String -> Doc ann
forall ann. 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
. 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]
forall a b. Coercible a b => a -> b
coerce

prettyConst :: PrettyConst a => RenderContext -> a -> Doc ann
prettyConst :: forall a ann. PrettyConst a => RenderContext -> a -> Doc ann
prettyConst = ConstConfig -> a -> Doc ann
forall ann. ConstConfig -> a -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy (ConstConfig -> a -> Doc ann)
-> (RenderContext -> ConstConfig) -> RenderContext -> a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderContext -> ConstConfig
ConstConfig

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

-- | For rendering values without parens, i.e. in 'botRenderContext'.
newtype NoParens a = NoParens
    { forall a. NoParens a -> a
unNoParens :: a
    }

instance PrettyConst a => PrettyBy ConstConfig (NoParens a) where
    prettyBy :: forall ann. ConstConfig -> NoParens a -> Doc ann
prettyBy     ConstConfig
config = forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy     @_ @a (ConstConfig
config ConstConfig -> (ConstConfig -> ConstConfig) -> ConstConfig
forall a b. a -> (a -> b) -> b
& (RenderContext -> Identity RenderContext)
-> ConstConfig -> Identity ConstConfig
forall config.
HasRenderContext config =>
Lens' config RenderContext
Lens' ConstConfig RenderContext
renderContext ((RenderContext -> Identity RenderContext)
 -> ConstConfig -> Identity ConstConfig)
-> RenderContext -> ConstConfig -> ConstConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ RenderContext
botRenderContext) (a -> Doc ann) -> (NoParens a -> a) -> NoParens a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoParens a -> a
forall a b. Coercible a b => a -> b
coerce
    prettyListBy :: forall ann. ConstConfig -> [NoParens a] -> Doc ann
prettyListBy ConstConfig
config = forall config a ann. PrettyBy config a => config -> [a] -> Doc ann
prettyListBy @_ @a (ConstConfig
config ConstConfig -> (ConstConfig -> ConstConfig) -> ConstConfig
forall a b. a -> (a -> b) -> b
& (RenderContext -> Identity RenderContext)
-> ConstConfig -> Identity ConstConfig
forall config.
HasRenderContext config =>
Lens' config RenderContext
Lens' ConstConfig RenderContext
renderContext ((RenderContext -> Identity RenderContext)
 -> ConstConfig -> Identity ConstConfig)
-> RenderContext -> ConstConfig -> ConstConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ RenderContext
botRenderContext) ([a] -> Doc ann)
-> ([NoParens a] -> [a]) -> [NoParens a] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NoParens a] -> [a]
forall a b. Coercible a b => a -> b
coerce

instance PrettyConst a => NonDefaultPrettyBy ConstConfig [a] where
    nonDefaultPrettyBy :: forall ann. ConstConfig -> [a] -> Doc ann
nonDefaultPrettyBy ConstConfig
config = forall config a ann.
DefaultPrettyBy config a =>
config -> a -> Doc ann
defaultPrettyBy @_ @[NoParens a] ConstConfig
config ([NoParens a] -> Doc ann)
-> ([a] -> [NoParens a]) -> [a] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [NoParens a]
forall a b. Coercible a b => a -> b
coerce
instance (PrettyConst a, PrettyConst b) => NonDefaultPrettyBy ConstConfig (a, b) where
    nonDefaultPrettyBy :: forall ann. ConstConfig -> (a, b) -> Doc ann
nonDefaultPrettyBy ConstConfig
config = forall config a ann.
DefaultPrettyBy config a =>
config -> a -> Doc ann
defaultPrettyBy @_ @(NoParens a, NoParens b) ConstConfig
config ((NoParens a, NoParens b) -> Doc ann)
-> ((a, b) -> (NoParens a, NoParens b)) -> (a, b) -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> (NoParens a, NoParens b)
forall a b. Coercible a b => a -> b
coerce

-- Special instance for bytestrings
asBytes :: Word8 -> Doc ann
asBytes :: forall ann. 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 => 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

toBytes :: BS.ByteString -> Doc ann
toBytes :: forall ann. ByteString -> Doc ann
toBytes ByteString
b = [Doc ann] -> Doc ann
forall m. Monoid m => [m] -> m
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)

instance PrettyBy ConstConfig Data where
    prettyBy :: forall ann. ConstConfig -> Data -> Doc ann
prettyBy = (Data -> InContextM ConstConfig (Doc ann))
-> ConstConfig -> Data -> Doc ann
forall a config ann.
(a -> InContextM config (Doc ann)) -> config -> a -> Doc ann
inContextM ((Data -> InContextM ConstConfig (Doc ann))
 -> ConstConfig -> Data -> Doc ann)
-> (Data -> InContextM ConstConfig (Doc ann))
-> ConstConfig
-> Data
-> Doc ann
forall a b. (a -> b) -> a -> b
$ \Data
d0 -> (AnyToDoc ConstConfig ann
 -> AnyToDoc ConstConfig ann -> NonEmpty (Doc ann))
-> InContextM ConstConfig (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
(AnyToDoc config ann -> AnyToDoc config ann -> NonEmpty (Doc ann))
-> m (Doc ann)
iterAppDocM ((AnyToDoc ConstConfig ann
  -> AnyToDoc ConstConfig ann -> NonEmpty (Doc ann))
 -> InContextM ConstConfig (Doc ann))
-> (AnyToDoc ConstConfig ann
    -> AnyToDoc ConstConfig ann -> NonEmpty (Doc ann))
-> InContextM ConstConfig (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc ConstConfig ann
_ AnyToDoc ConstConfig ann
prettyArg -> case Data
d0 of
        Constr Integer
i [Data]
ds ->  (Doc ann
"Constr" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
AnyToDoc ConstConfig ann
prettyArg Integer
i) Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [[Data] -> Doc ann
AnyToDoc ConstConfig ann
prettyArg [Data]
ds]
        Map [(Data, Data)]
ps      ->  Doc ann
"Map" Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [[(Data, Data)] -> Doc ann
AnyToDoc ConstConfig ann
prettyArg [(Data, Data)]
ps]
        List [Data]
ds     ->  Doc ann
"List" Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [[Data] -> Doc ann
AnyToDoc ConstConfig ann
prettyArg [Data]
ds]
        I Integer
i         ->  (Doc ann
"I" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
AnyToDoc ConstConfig ann
prettyArg Integer
i) Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| []
        B ByteString
b         ->  (Doc ann
"B" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ByteString -> Doc ann
AnyToDoc ConstConfig ann
prettyArg ByteString
b) Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| []

instance PrettyBy ConstConfig BS.ByteString where
    prettyBy :: forall ann. ConstConfig -> ByteString -> Doc ann
prettyBy ConstConfig
_ ByteString
b = Doc ann
"#" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc ann
forall ann. ByteString -> Doc ann
toBytes ByteString
b

instance Pretty (SomeTypeIn uni) => Pretty (SomeTypeIn (Kinded uni)) where
    pretty :: forall ann. SomeTypeIn (Kinded uni) -> Doc ann
pretty (SomeTypeIn (Kinded uni (Esc a)
uni)) = SomeTypeIn uni -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SomeTypeIn uni -> Doc ann
pretty (uni (Esc a) -> SomeTypeIn uni
forall (uni :: * -> *) k (a :: k). uni (Esc a) -> SomeTypeIn uni
SomeTypeIn uni (Esc a)
uni)

-- See Note [Prettyprinting built-in constants].
instance (Closed uni, uni `Everywhere` PrettyConst) => PrettyBy ConstConfig (ValueOf uni a) where
    prettyBy :: forall ann. ConstConfig -> ValueOf uni a -> Doc ann
prettyBy ConstConfig
config (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
forall (constr :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a r.
Everywhere uni constr =>
proxy constr -> uni (Esc a) -> (constr a => r) -> r
bring (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). 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
$ ConstConfig -> a -> Doc ann
forall ann. ConstConfig -> a -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy ConstConfig
config a
x

-- See Note [Prettyprinting built-in constants].
instance (Closed uni, uni `Everywhere` PrettyConst) =>
        PrettyBy ConstConfig (Some (ValueOf uni)) where
    prettyBy :: forall ann. ConstConfig -> Some (ValueOf uni) -> Doc ann
prettyBy ConstConfig
config (Some ValueOf uni a
s) = ConstConfig -> ValueOf uni a -> Doc ann
forall ann. ConstConfig -> ValueOf uni a -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy ConstConfig
config ValueOf uni a
s

-- See Note [Prettyprinting built-in constants].
instance (Closed uni, uni `Everywhere` PrettyConst) => Pretty (ValueOf uni a) where
    pretty :: forall ann. ValueOf uni a -> Doc ann
pretty = RenderContext -> ValueOf uni a -> Doc ann
forall a ann. PrettyConst a => RenderContext -> a -> Doc ann
prettyConst RenderContext
juxtRenderContext

-- See Note [Prettyprinting built-in constants].
instance (Closed uni, uni `Everywhere` PrettyConst) => Pretty (Some (ValueOf uni)) where
    pretty :: forall ann. Some (ValueOf uni) -> Doc ann
pretty = RenderContext -> Some (ValueOf uni) -> Doc ann
forall a ann. PrettyConst a => RenderContext -> a -> Doc ann
prettyConst RenderContext
juxtRenderContext