{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | A "readable" Agda-like way to pretty-print Untyped Plutus Core terms.
module UntypedPlutusCore.Core.Instance.Pretty.Readable () where

import PlutusCore.Pretty.PrettyConst
import PlutusCore.Pretty.Readable
import PlutusPrelude
import UntypedPlutusCore.Core.Type

import Prettyprinter

-- | Split an iterated 'LamAbs' (if any) into a list of variables that it binds and its body.
viewLamAbs :: Term name uni fun ann -> Maybe ([name], Term name uni fun ann)
viewLamAbs :: forall name (uni :: * -> *) fun ann.
Term name uni fun ann -> Maybe ([name], Term name uni fun ann)
viewLamAbs term0 :: Term name uni fun ann
term0@LamAbs{} = ([name], Term name uni fun ann)
-> Maybe ([name], Term name uni fun ann)
forall a. a -> Maybe a
Just (([name], Term name uni fun ann)
 -> Maybe ([name], Term name uni fun ann))
-> ([name], Term name uni fun ann)
-> Maybe ([name], Term name uni fun ann)
forall a b. (a -> b) -> a -> b
$ Term name uni fun ann -> ([name], Term name uni fun ann)
forall {a} {uni :: * -> *} {fun} {ann}.
Term a uni fun ann -> ([a], Term a uni fun ann)
go Term name uni fun ann
term0
  where
    go :: Term a uni fun ann -> ([a], Term a uni fun ann)
go (LamAbs ann
_ a
name Term a uni fun ann
body) = ([a] -> [a])
-> ([a], Term a uni fun ann) -> ([a], Term a uni fun ann)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a
name a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], Term a uni fun ann) -> ([a], Term a uni fun ann))
-> ([a], Term a uni fun ann) -> ([a], Term a uni fun ann)
forall a b. (a -> b) -> a -> b
$ Term a uni fun ann -> ([a], Term a uni fun ann)
go Term a uni fun ann
body
    go Term a uni fun ann
term                 = ([], Term a uni fun ann
term)
viewLamAbs Term name uni fun ann
_ = Maybe ([name], Term name uni fun ann)
forall a. Maybe a
Nothing

-- | Split an iterated 'Apply' (if any) into the head of the application and the spine.
viewApp ::
  Term name uni fun ann ->
  Maybe (Term name uni fun ann, [Term name uni fun ann])
viewApp :: forall name (uni :: * -> *) fun ann.
Term name uni fun ann
-> Maybe (Term name uni fun ann, [Term name uni fun ann])
viewApp Term name uni fun ann
term0 = Term name uni fun ann
-> [Term name uni fun ann]
-> Maybe (Term name uni fun ann, [Term name uni fun ann])
forall {name} {uni :: * -> *} {fun} {ann}.
Term name uni fun ann
-> [Term name uni fun ann]
-> Maybe (Term name uni fun ann, [Term name uni fun ann])
go Term name uni fun ann
term0 [] where
    go :: Term name uni fun ann
-> [Term name uni fun ann]
-> Maybe (Term name uni fun ann, [Term name uni fun ann])
go (Apply ann
_ Term name uni fun ann
fun Term name uni fun ann
arg) [Term name uni fun ann]
args = Term name uni fun ann
-> [Term name uni fun ann]
-> Maybe (Term name uni fun ann, [Term name uni fun ann])
go Term name uni fun ann
fun ([Term name uni fun ann]
 -> Maybe (Term name uni fun ann, [Term name uni fun ann]))
-> [Term name uni fun ann]
-> Maybe (Term name uni fun ann, [Term name uni fun ann])
forall a b. (a -> b) -> a -> b
$ Term name uni fun ann
arg Term name uni fun ann
-> [Term name uni fun ann] -> [Term name uni fun ann]
forall a. a -> [a] -> [a]
: [Term name uni fun ann]
args
    go Term name uni fun ann
_                 []   = Maybe (Term name uni fun ann, [Term name uni fun ann])
forall a. Maybe a
Nothing
    go Term name uni fun ann
fun               [Term name uni fun ann]
args = (Term name uni fun ann, [Term name uni fun ann])
-> Maybe (Term name uni fun ann, [Term name uni fun ann])
forall a. a -> Maybe a
Just (Term name uni fun ann
fun, [Term name uni fun ann]
args)

instance
  (PrettyReadableBy configName name, PrettyUni uni, Pretty fun, Show configName) =>
  PrettyBy (PrettyConfigReadable configName) (Term name uni fun a)
  where
  prettyBy :: forall ann.
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 -> (PrettyConfigReadable configName -> ConstConfig)
-> InContextM ConstConfig (Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b c. (a -> b) -> InContextM b c -> InContextM a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (RenderContext -> ConstConfig
ConstConfig (RenderContext -> ConstConfig)
-> (PrettyConfigReadable configName -> RenderContext)
-> PrettyConfigReadable configName
-> ConstConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyConfigReadable configName -> RenderContext
forall configName. PrettyConfigReadable configName -> RenderContext
_pcrRenderContext) (InContextM ConstConfig (Doc ann)
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> InContextM ConstConfig (Doc ann)
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ Some (ValueOf uni) -> InContextM ConstConfig (Doc ann)
forall config env (m :: * -> *) a ann.
(MonadPretty config env m, PrettyBy config a) =>
a -> m (Doc ann)
prettyM 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 ann. 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
    (Term name uni fun a -> Maybe ([name], Term name uni fun a)
forall name (uni :: * -> *) fun ann.
Term name uni fun ann -> Maybe ([name], Term name uni fun ann)
viewLamAbs -> Just ([name]
args, Term name uni fun a
body)) -> [name]
-> Term name uni fun a
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall configName env (m :: * -> *) arg body ann.
(MonadPrettyReadable configName env m,
 PrettyReadableBy configName arg,
 PrettyReadableBy configName body) =>
[arg] -> body -> m (Doc ann)
iterLamAbsPrettyM [name]
args Term name uni fun a
body
    LamAbs{} -> [Char] -> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a. HasCallStack => [Char] -> a
error [Char]
"Panic: 'LamAbs' is not covered by 'viewLamAbs'"
    (Term name uni fun a
-> Maybe (Term name uni fun a, [Term name uni fun a])
forall name (uni :: * -> *) fun ann.
Term name uni fun ann
-> Maybe (Term name uni fun ann, [Term name uni fun ann])
viewApp -> Just (Term name uni fun a
fun, [Term name uni fun a]
args)) -> Term name uni fun a
-> [Term name uni fun a]
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall config env (m :: * -> *) fun term ann.
(MonadPrettyContext config env m, PrettyBy config fun,
 PrettyBy config term) =>
fun -> [term] -> m (Doc ann)
iterAppPrettyM Term name uni fun a
fun [Term name uni fun a]
args
    Apply{} -> [Char] -> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a. HasCallStack => [Char] -> a
error [Char]
"Panic: 'Apply' is not covered by 'viewApp'"
    Delay a
_ Term name uni fun a
term -> (AnyToDoc (PrettyConfigReadable configName) ann
 -> AnyToDoc (PrettyConfigReadable configName) ann
 -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (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 (PrettyConfigReadable configName) ann
  -> AnyToDoc (PrettyConfigReadable configName) ann
  -> NonEmpty (Doc ann))
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> (AnyToDoc (PrettyConfigReadable configName) ann
    -> AnyToDoc (PrettyConfigReadable configName) ann
    -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc (PrettyConfigReadable configName) ann
_ AnyToDoc (PrettyConfigReadable configName) ann
prettyArg -> Doc ann
"delay" Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [Term name uni fun a -> Doc ann
AnyToDoc (PrettyConfigReadable configName) ann
prettyArg Term name uni fun a
term]
    Force a
_ Term name uni fun a
term -> (AnyToDoc (PrettyConfigReadable configName) ann
 -> AnyToDoc (PrettyConfigReadable configName) ann
 -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (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 (PrettyConfigReadable configName) ann
  -> AnyToDoc (PrettyConfigReadable configName) ann
  -> NonEmpty (Doc ann))
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> (AnyToDoc (PrettyConfigReadable configName) ann
    -> AnyToDoc (PrettyConfigReadable configName) ann
    -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc (PrettyConfigReadable configName) ann
_ AnyToDoc (PrettyConfigReadable configName) ann
prettyArg -> Doc ann
"force" Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [Term name uni fun a -> Doc ann
AnyToDoc (PrettyConfigReadable configName) ann
prettyArg 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"
    -- Always rendering the tag on the same line for more compact output, it's just a tiny integer
    -- anyway.
    Constr a
_ Word64
i [Term name uni fun a]
es -> (AnyToDoc (PrettyConfigReadable configName) ann
 -> AnyToDoc (PrettyConfigReadable configName) ann
 -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (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 (PrettyConfigReadable configName) ann
  -> AnyToDoc (PrettyConfigReadable configName) ann
  -> NonEmpty (Doc ann))
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> (AnyToDoc (PrettyConfigReadable configName) ann
    -> AnyToDoc (PrettyConfigReadable configName) ann
    -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc (PrettyConfigReadable configName) ann
_ AnyToDoc (PrettyConfigReadable configName) ann
prettyArg ->
      (Doc ann
"constr" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word64 -> Doc ann
AnyToDoc (PrettyConfigReadable configName) ann
prettyArg Word64
i) Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [[Term name uni fun a] -> Doc ann
AnyToDoc (PrettyConfigReadable configName) ann
prettyArg [Term name uni fun a]
es]
    Case a
_ Term name uni fun a
arg Vector (Term name uni fun a)
cs -> (AnyToDoc (PrettyConfigReadable configName) ann
 -> AnyToDoc (PrettyConfigReadable configName) ann
 -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (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 (PrettyConfigReadable configName) ann
  -> AnyToDoc (PrettyConfigReadable configName) ann
  -> NonEmpty (Doc ann))
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> (AnyToDoc (PrettyConfigReadable configName) ann
    -> AnyToDoc (PrettyConfigReadable configName) ann
    -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc (PrettyConfigReadable configName) ann
_ AnyToDoc (PrettyConfigReadable configName) ann
prettyArg -> Doc ann
"case" Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [Term name uni fun a -> Doc ann
AnyToDoc (PrettyConfigReadable configName) ann
prettyArg Term name uni fun a
arg, [Term name uni fun a] -> Doc ann
AnyToDoc (PrettyConfigReadable configName) ann
prettyArg (Vector (Term name uni fun a) -> [Term name uni fun a]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector (Term name uni fun a)
cs)]

instance
  (PrettyReadableBy configName (Term name uni fun a)) =>
  PrettyBy (PrettyConfigReadable configName) (Program name uni fun a)
  where
  prettyBy :: forall ann.
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
version Term name uni fun a
term) ->
    (AnyToDoc (PrettyConfigReadable configName) ann
 -> AnyToDoc (PrettyConfigReadable configName) ann
 -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (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 (PrettyConfigReadable configName) ann
  -> AnyToDoc (PrettyConfigReadable configName) ann
  -> NonEmpty (Doc ann))
 -> InContextM (PrettyConfigReadable configName) (Doc ann))
-> (AnyToDoc (PrettyConfigReadable configName) ann
    -> AnyToDoc (PrettyConfigReadable configName) ann
    -> NonEmpty (Doc ann))
-> InContextM (PrettyConfigReadable configName) (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc (PrettyConfigReadable configName) ann
_ AnyToDoc (PrettyConfigReadable configName) ann
prettyArg -> Doc ann
"program" Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [Version -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Version -> Doc ann
pretty Version
version, Term name uni fun a -> Doc ann
AnyToDoc (PrettyConfigReadable configName) ann
prettyArg Term name uni fun a
term]