-- | A "classic" (i.e. as seen in the specification) way to pretty-print Untyped Plutus Core terms.

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

{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module UntypedPlutusCore.Core.Instance.Pretty.Classic () where

import PlutusPrelude

import UntypedPlutusCore.Core.Type

import PlutusCore.Pretty.Classic
import PlutusCore.Pretty.PrettyConst

import Prettyprinter
import Prettyprinter.Custom
import Universe (Some (..), SomeTypeIn (SomeTypeIn), ValueOf (..))

instance (PrettyClassicBy configName name, PrettyUni uni, Pretty fun, Pretty ann) =>
        PrettyBy (PrettyConfigClassic configName) (Term name uni fun ann) where
    prettyBy :: forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
prettyBy PrettyConfigClassic configName
config = \case
        Var ann
ann name
n ->
            [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann [PrettyConfigClassic configName -> name -> Doc ann
forall ann. PrettyConfigClassic configName -> name -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config name
n])
        LamAbs ann
ann name
n Term name uni fun ann
t ->
            Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"lam" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann
                [PrettyConfigClassic configName -> name -> Doc ann
forall ann. PrettyConfigClassic configName -> name -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config name
n, PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config Term name uni fun ann
t])
        Apply ann
ann Term name uni fun ann
t1 Term name uni fun ann
t2 ->
            Doc ann -> Doc ann
forall a. Doc a -> Doc a
brackets' ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann
                [PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config Term name uni fun ann
t1, PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config Term name uni fun ann
t2]))
        Constant ann
ann Some (ValueOf uni)
c ->
            Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"con" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann [Some (ValueOf uni) -> Doc ann
forall dann. Some (ValueOf uni) -> Doc dann
prettyTypeOf Some (ValueOf uni)
c, Some (ValueOf uni) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall dann. Some (ValueOf uni) -> Doc dann
pretty Some (ValueOf uni)
c])
        Builtin ann
ann fun
bi ->
            Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"builtin" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann
                [fun -> Doc ann
forall ann. fun -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty fun
bi])
        Error ann
ann ->
            Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"error" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann [])
        Delay ann
ann Term name uni fun ann
term ->
            Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"delay" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann
                [PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config Term name uni fun ann
term])
        Force ann
ann Term name uni fun ann
term ->
            Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"force" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann
                [PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config Term name uni fun ann
term])
        Constr ann
ann Word64
i [Term name uni fun ann]
es ->
            Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"constr" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann (Word64 -> Doc ann
forall ann. Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
i Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Term name uni fun ann -> Doc ann)
-> [Term name uni fun ann] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config) [Term name uni fun ann]
es))
        Case ann
ann Term name uni fun ann
arg Vector (Term name uni fun ann)
cs ->
            Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"case" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann
                (PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config Term name uni fun ann
arg Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Term name uni fun ann -> Doc ann)
-> [Term name uni fun ann] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config) (Vector (Term name uni fun ann) -> [Term name uni fun ann]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector (Term name uni fun ann)
cs)))
      where
        prettyTypeOf :: Some (ValueOf uni) -> Doc dann
        prettyTypeOf :: forall dann. Some (ValueOf uni) -> Doc dann
prettyTypeOf (Some (ValueOf uni (Esc a)
uni a
_ )) = RenderContext -> SomeTypeIn uni -> Doc dann
forall ann. RenderContext -> SomeTypeIn uni -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy RenderContext
juxtRenderContext (SomeTypeIn uni -> Doc dann) -> SomeTypeIn uni -> Doc dann
forall a b. (a -> b) -> a -> b
$ uni (Esc a) -> SomeTypeIn uni
forall (uni :: * -> *) k (a :: k). uni (Esc a) -> SomeTypeIn uni
SomeTypeIn uni (Esc a)
uni

instance (PrettyClassicBy configName (Term name uni fun ann), Pretty ann) =>
        PrettyBy (PrettyConfigClassic configName) (Program name uni fun ann) where
    prettyBy :: forall ann.
PrettyConfigClassic configName
-> Program name uni fun ann -> Doc ann
prettyBy PrettyConfigClassic configName
config (Program ann
ann Version
version Term name uni fun ann
term) =
        Doc ann -> [Doc ann] -> Doc ann
forall a. Doc a -> [Doc a] -> Doc a
sexp Doc ann
"program" (PrettyConfigClassic configName -> ann -> [Doc ann] -> [Doc ann]
forall ann configName dann.
Pretty ann =>
PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann]
consAnnIf PrettyConfigClassic configName
config ann
ann [Version -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Version -> Doc ann
pretty Version
version, PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall ann.
PrettyConfigClassic configName -> Term name uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic configName
config Term name uni fun ann
term])