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