-- | A "readable" Agda-like 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.Readable () where

import PlutusPrelude

import UntypedPlutusCore.Core.Type

import PlutusCore.Core.Instance.Pretty.Common ()
import PlutusCore.Pretty.PrettyConst
import PlutusCore.Pretty.Readable

import Prettyprinter
import Universe

instance
        ( PrettyReadableBy configName name
        , GShow uni, Closed uni, uni `Everywhere` PrettyConst, Pretty fun
        ) => PrettyBy (PrettyConfigReadable configName) (Term name uni fun a) where
    prettyBy :: PrettyConfigReadable configName -> Term name uni fun a -> Doc ann
prettyBy = (Term name uni fun a
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> PrettyConfigReadable configName
-> Term name uni fun a
-> Doc ann
forall a config ann.
(a -> InContextM config (Doc ann)) -> config -> a -> Doc ann
inContextM ((Term name uni fun a
  -> InContextM (PrettyConfigReadable configName) (Doc ann))
 -> PrettyConfigReadable configName
 -> Term name uni fun a
 -> Doc ann)
-> (Term name uni fun a
    -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> PrettyConfigReadable configName
-> Term name uni fun a
-> Doc ann
forall a b. (a -> b) -> a -> b
$ \case
        Constant a
_ Some (ValueOf uni)
val -> Doc ann -> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
Doc ann -> m (Doc ann)
unitDocM (Doc ann -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> Doc ann
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ Some (ValueOf uni) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Some (ValueOf uni)
val
        Builtin a
_ fun
bi -> Doc ann -> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
Doc ann -> m (Doc ann)
unitDocM (Doc ann -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> Doc ann
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ fun -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty fun
bi
        Var a
_ name
name -> name -> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) a ann.
(MonadPretty config env m, PrettyBy config a) =>
a -> m (Doc ann)
prettyM name
name
        LamAbs a
_ name
name Term name uni fun a
body ->
            Fixity
-> ((forall a.
     PrettyBy (PrettyConfigReadable configName) a =>
     Direction -> Fixity -> a -> Doc ann)
    -> Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
Fixity
-> ((forall a.
     PrettyBy config a =>
     Direction -> Fixity -> a -> Doc ann)
    -> Doc ann)
-> m (Doc ann)
compoundDocM Fixity
binderFixity (((forall a.
   PrettyBy (PrettyConfigReadable configName) a =>
   Direction -> Fixity -> a -> Doc ann)
  -> Doc ann)
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> ((forall a.
     PrettyBy (PrettyConfigReadable configName) a =>
     Direction -> Fixity -> a -> Doc ann)
    -> Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \forall a.
PrettyBy (PrettyConfigReadable configName) a =>
Direction -> Fixity -> a -> Doc ann
prettyIn ->
                let prettyBot :: a -> Doc ann
prettyBot a
x = Direction -> Fixity -> a -> Doc ann
forall a.
PrettyBy (PrettyConfigReadable configName) a =>
Direction -> Fixity -> a -> Doc ann
prettyIn Direction
ToTheRight Fixity
botFixity a
x
                in Doc ann
"\\" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> name -> Doc ann
forall a.
PrettyBy (PrettyConfigReadable configName) a =>
a -> Doc ann
prettyBot name
name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"->" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term name uni fun a -> Doc ann
forall a.
PrettyBy (PrettyConfigReadable configName) a =>
a -> Doc ann
prettyBot Term name uni fun a
body
        Apply a
_ Term name uni fun a
fun Term name uni fun a
arg -> Term name uni fun a
fun Term name uni fun a
-> Term name uni fun a
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) a b ann.
(MonadPrettyContext config env m, PrettyBy config a,
 PrettyBy config b) =>
a -> b -> m (Doc ann)
`juxtPrettyM` Term name uni fun a
arg
        Delay a
_ Term name uni fun a
term ->
            Direction
-> Fixity
-> ((forall a.
     PrettyBy (PrettyConfigReadable configName) a =>
     a -> Doc ann)
    -> Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
Direction
-> Fixity -> (AnyToDoc config ann -> Doc ann) -> m (Doc ann)
sequenceDocM Direction
ToTheRight Fixity
juxtFixity (((forall a.
   PrettyBy (PrettyConfigReadable configName) a =>
   a -> Doc ann)
  -> Doc ann)
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> ((forall a.
     PrettyBy (PrettyConfigReadable configName) a =>
     a -> Doc ann)
    -> Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \forall a.
PrettyBy (PrettyConfigReadable configName) a =>
a -> Doc ann
prettyEl ->
                Doc ann
"delay" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term name uni fun a -> Doc ann
forall a.
PrettyBy (PrettyConfigReadable configName) a =>
a -> Doc ann
prettyEl Term name uni fun a
term
        Force a
_ Term name uni fun a
term ->
            Direction
-> Fixity
-> ((forall a.
     PrettyBy (PrettyConfigReadable configName) a =>
     a -> Doc ann)
    -> Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
Direction
-> Fixity -> (AnyToDoc config ann -> Doc ann) -> m (Doc ann)
sequenceDocM Direction
ToTheRight Fixity
juxtFixity (((forall a.
   PrettyBy (PrettyConfigReadable configName) a =>
   a -> Doc ann)
  -> Doc ann)
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> ((forall a.
     PrettyBy (PrettyConfigReadable configName) a =>
     a -> Doc ann)
    -> Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \forall a.
PrettyBy (PrettyConfigReadable configName) a =>
a -> Doc ann
prettyEl ->
                Doc ann
"force" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term name uni fun a -> Doc ann
forall a.
PrettyBy (PrettyConfigReadable configName) a =>
a -> Doc ann
prettyEl Term name uni fun a
term
        Error a
_ -> Doc ann -> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
Doc ann -> m (Doc ann)
unitDocM Doc ann
"error"

instance PrettyReadableBy configName (Term name uni fun a) =>
        PrettyBy (PrettyConfigReadable configName) (Program name uni fun a) where
    prettyBy :: PrettyConfigReadable configName
-> Program name uni fun a -> Doc ann
prettyBy = (Program name uni fun a
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> PrettyConfigReadable configName
-> Program name uni fun a
-> Doc ann
forall a config ann.
(a -> InContextM config (Doc ann)) -> config -> a -> Doc ann
inContextM ((Program name uni fun a
  -> InContextM (PrettyConfigReadable configName) (Doc ann))
 -> PrettyConfigReadable configName
 -> Program name uni fun a
 -> Doc ann)
-> (Program name uni fun a
    -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> PrettyConfigReadable configName
-> Program name uni fun a
-> Doc ann
forall a b. (a -> b) -> a -> b
$ \(Program a
_ Version a
version Term name uni fun a
term) ->
        Direction
-> Fixity
-> (AnyToDoc (PrettyConfigReadable configName) ann -> Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
Direction
-> Fixity -> (AnyToDoc config ann -> Doc ann) -> m (Doc ann)
sequenceDocM Direction
ToTheRight Fixity
juxtFixity ((AnyToDoc (PrettyConfigReadable configName) ann -> Doc ann)
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> (AnyToDoc (PrettyConfigReadable configName) ann -> Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc (PrettyConfigReadable configName) ann
prettyEl ->
            Doc ann
"program" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Version a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Version a
version Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term name uni fun a -> Doc ann
AnyToDoc (PrettyConfigReadable configName) ann
prettyEl Term name uni fun a
term