{-# LANGUAGE PatternSynonyms #-}

module Plutarch.Pretty (prettyTerm, prettyTerm', prettyScript) where

import Control.Monad.Reader (ReaderT (runReaderT))
import Control.Monad.ST (runST)
import Control.Monad.State (MonadState (get, put), StateT (runStateT), modify, modify')
import Data.Foldable (fold)
import Data.Functor (($>), (<&>))
import Data.Text (Text)
import Data.Text qualified as Txt
import Data.Traversable (for)

import System.Random.Stateful (mkStdGen, newSTGenM)

import Prettyprinter ((<+>))
import Prettyprinter qualified as PP

import Plutarch.Internal (ClosedTerm, Config, compile)
import Plutarch.Script (Script (unScript))
import PlutusCore qualified as PLC
import UntypedPlutusCore (
  DeBruijn (DeBruijn),
  DefaultFun,
  DefaultUni,
  Program (_progTerm),
  Term (Apply, Builtin, Constant, Delay, Error, Force, LamAbs, Var),
 )

import Plutarch.Pretty.Internal.BuiltinConstant (prettyConstant)
import Plutarch.Pretty.Internal.Config (indentWidth)
import Plutarch.Pretty.Internal.Name (freshVarName, smartName)
import Plutarch.Pretty.Internal.TermUtils (
  unwrapApply,
  unwrapBindings,
  unwrapLamAbs,
  pattern IfThenElseLikeAST,
 )
import Plutarch.Pretty.Internal.Types (
  PrettyCursor (Normal, Special),
  PrettyMonad,
  PrettyState (PrettyState, ps'cursor, ps'nameMap),
  builtinFunAtRef,
  forkState,
  insertBindings,
  insertName,
  nameOfRef,
  normalizeCursor,
  specializeCursor,
 )

-- | 'prettyTerm' for pre-compiled 'Script's.
prettyScript :: Script -> PP.Doc ()
prettyScript :: Script -> Doc ()
prettyScript = Term DeBruijn DefaultUni DefaultFun () -> Doc ()
prettyUPLC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (uni :: Type -> Type) fun ann.
Program name uni fun ann -> Term name uni fun ann
_progTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> Program DeBruijn DefaultUni DefaultFun ()
unScript

{- | Prettify a Plutarch term.

This will call 'error' if there's a compilation failure. Use 'prettyTerm'' for a non-partial version.

== Example ==

@
import Plutarch.Prelude
import Plutarch.Api.V1
import Plutarch.Extra.TermCont

checkSignatory :: Term s (PPubKeyHash :--> PScriptContext :--> PUnit)
checkSignatory = plam $ \ph ctx' -> unTermCont $ do
  ctx <- pletFieldsC @["txInfo", "purpose"] ctx'
  purph <- pmatchC ctx.purpose
  pure $ case purph of
    PSpending _ ->
      let signatories = pfield @"signatories" # ctx.txInfo
      in pif
          (pelem # pdata ph # pfromData signatories)
          -- Success!
          (pconstant ())
          -- Signature not present.
          perror
    _ -> ptraceError "checkSignatoryCont: not a spending tx"
@

Prettification result:

@
let frSndPair = !!sndPair
    unDataSum = (\xF -> frSndPair (unConstrData xF))
    frTailList = !tailList
    frHeadList = !headList
    frIfThenElse = !ifThenElse
in (\oP4ECBT qsrxlF0Y7 ->
      let cjlB6yrGk = unDataSum qsrxlF0Y7
          cRFO = unConstrData (frHeadList (frTailList cjlB6yrGk))
          cs9iR = !!fstPair cRFO
          w4 = frSndPair cRFO
      in if equalsInteger 1 cs9iR
           then if (\vModHwqYB ->
                      let blM6d67 =
                            (\x5sad ePDSInSEC ->
                               !(!!chooseList
                                   ePDSInSEC
                                   ~False
                                   ~(if equalsData
                                          (frHeadList ePDSInSEC)
                                          vModHwqYB
                                       then True
                                       else x5sad (frTailList ePDSInSEC))))
                          mC = (\jfZs -> blM6d67 (\itzT -> jfZs jfZs itzT))
                      in blM6d67 (\ispwp_oeT -> mC mC ispwp_oeT))
                     (bData oP4ECBT)
                     (unListData
                        let q6X3 = frHeadList cjlB6yrGk
                        in frHeadList
                             let olbZ = unDataSum q6X3
                             in frTailList
                                  (frTailList
                                     (frTailList
                                        (frTailList
                                           (frTailList
                                              (frTailList
                                                 (frTailList olbZ)))))))
                  then ()
                  else ERROR
           else !(!trace "checkSignatoryCont: not a spending tx" ~ERROR))
@

== Semantics ==

=== Constants ===

- Builtin integers are printed as regular integers. [0-9]+
- Builtin bytestrings are printed in hex notation, prefixed by `0x`. 0x[0-9a-f]+/i
- Builtin strings are printed as is.
- Builtin unit is printed as the unit literal. ()
- Builtin booleans are printed as the literal `True` or `False`.
- Builtin lists are prettified as list literals, i.e delimited with `[` and `]`.
- Builtin pairs are prettified as 2-ary tuple literals, e.g. `(a, b)`.
- `I` data (i.e data encoded integers) are prettified like builtin integers with a `#` prefix. #[0-9]+
- `B` data (i.e data encoded bytestrings) are prettified like builtin bytestrings with a `#` prefix. #0x[0-9a-f]+/i
- `List` data (i.e data encoded lists) are prettified like builtin lists with a `#` prefix.
- `Map` data is printed like record literals. Delimited by `{` and `}`.

  Each key value pair is prettified like <key> = <value> and multiple pairs are joined with `,`.

  For example, `Map [(I 42, I 0), (I 100, I 1)]` is prettified as `{ #42 = #0, #100 = #1 }`
- Constr data has two core elements in its prettified form:

  - The constructor index, prettified as an integer prefixed with `Σ` (sigma).
  - Its fields, prettified as a list.

  These two elements are then joined with a `.` (period).

  For example, `Constr 1 [I 42]` is prettified as "Σ1.[#42]".

=== Builtin functions ===

Builtin functions are prettified into their name, in title case.

=== Forced term ===

Forced terms are prefixed with a `!`. The unary operator `!` has higher fixity than function application.

=== Delayed term ===

Delayed terms are prefixed with a `~`. The unary operator `~` has higher fixity than function application.

=== Var ===

Random names are generated for all variable bindings, and these names are used to refer to them.

Names are always unique, between 1 and 8 characters in length, and begin with a lowercase letter.

Names may consist of alphanumeric characters, underscore, or single quotes.

=== LamAbs ===

Lambdas are prettified similar to haskell lambdas, i.e `\x -> ...`.

Lambdas with multiple arguments are detected and simplified: `\x y z -> ...`.

=== Apply ===

Application is, simply, a space - just like haskell. `f x`.

Multi arg applications to the same function are detected and simplified: `f x y`.

=== Error term ===

`perror` is represented by the literal `ERROR`.

=== Special handling ===

To achieve better prettification, certain AST structures are given special handling logic.

- The AST structure produced by `plet` (Single `Apply` + `LamAbs` pair) is prettified into Haskell-like let bindings.
- Lazy if/then/else (`pif` in particular, not `pif'`) is detected and prettified into Haskell-like syntax:
  `if cond then expr1 else expr2`.

  Chains of if/then/else are nested:

  @
  if cond
    then expr1
    else if cond
      then expr2
      else expr3
  @
- When generating names for bindings, well known structures are identified and given special names.

  This machinery is made to be extensible in the future.

  For example, the structure of the `pfix` function is well known and constant - so it is simply called `fix` in the output.

  Bindings to forced builtin functions inherit the builtin function name, prefixed with a `fr`.
-}
prettyTerm :: Config -> ClosedTerm a -> PP.Doc ()
prettyTerm :: forall (a :: PType). Config -> ClosedTerm a -> Doc ()
prettyTerm Config
conf ClosedTerm a
x = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Txt.unpack) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (p :: PType). Config -> ClosedTerm p -> Either Text (Doc ())
prettyTerm' Config
conf ClosedTerm a
x

-- | Non-partial 'prettyTerm'.
prettyTerm' :: Config -> ClosedTerm p -> Either Text (PP.Doc ())
prettyTerm' :: forall (p :: PType). Config -> ClosedTerm p -> Either Text (Doc ())
prettyTerm' Config
conf ClosedTerm p
x = Script -> Doc ()
prettyScript forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: PType). Config -> ClosedTerm a -> Either Text Script
compile Config
conf ClosedTerm p
x

{- This isn't suitable for pretty printing UPLC from any source. It's primarily suited for Plutarch output.
Practically speaking though, it should work with any _idiomatic_ UPLC.
-}
prettyUPLC :: Term DeBruijn DefaultUni DefaultFun () -> PP.Doc ()
prettyUPLC :: Term DeBruijn DefaultUni DefaultFun () -> Doc ()
prettyUPLC Term DeBruijn DefaultUni DefaultFun ()
uplc = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
  STGenM StdGen s
stGen <- forall g s. g -> ST s (STGenM g s)
newSTGenM forall a b. (a -> b) -> a -> b
$ Int -> StdGen
mkStdGen Int
42
  (Doc ()
doc, PrettyState
_) <- forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
uplc) STGenM StdGen s
stGen forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
`runStateT` Map Index Text -> Set Text -> PrettyCursor -> PrettyState
PrettyState forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty PrettyCursor
Normal
  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Doc ()
doc
  where
    go :: Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (PP.Doc ())
    go :: forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go (Constant ()
_ Some @Type (ValueOf DefaultUni)
c) = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Some @Type (ValueOf DefaultUni) -> Doc ()
prettyConstant Some @Type (ValueOf DefaultUni)
c
    go (Builtin ()
_ DefaultFun
b) = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
PP.pretty DefaultFun
b
    go (Error ()
_) = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Doc ()
"ERROR"
    go (Var ()
_ (DeBruijn Index
x)) = do
      PrettyState {Map Index Text
ps'nameMap :: Map Index Text
$sel:ps'nameMap:PrettyState :: PrettyState -> Map Index Text
ps'nameMap} <- forall s (m :: Type -> Type). MonadState s m => m s
get
      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Index -> Map Index Text -> Maybe Text
nameOfRef Index
x Map Index Text
ps'nameMap of
        Just Text
nm -> forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
nm
        Maybe Text
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: free variable"
    go (IfThenElseLikeAST (Force () (Builtin () DefaultFun
PLC.IfThenElse)) Term DeBruijn DefaultUni DefaultFun ()
cond Term DeBruijn DefaultUni DefaultFun ()
trueBranch Term DeBruijn DefaultUni DefaultFun ()
falseBranch) = do
      forall t s ann.
(t -> PrettyMonad s (Doc ann))
-> t -> t -> t -> PrettyMonad s (Doc ann)
prettyIfThenElse (forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go) Term DeBruijn DefaultUni DefaultFun ()
cond Term DeBruijn DefaultUni DefaultFun ()
trueBranch Term DeBruijn DefaultUni DefaultFun ()
falseBranch
    go ast :: Term DeBruijn DefaultUni DefaultFun ()
ast@(IfThenElseLikeAST Term DeBruijn DefaultUni DefaultFun ()
scrutinee Term DeBruijn DefaultUni DefaultFun ()
cond Term DeBruijn DefaultUni DefaultFun ()
trueBranch Term DeBruijn DefaultUni DefaultFun ()
falseBranch) = do
      PrettyState {Map Index Text
ps'nameMap :: Map Index Text
$sel:ps'nameMap:PrettyState :: PrettyState -> Map Index Text
ps'nameMap} <- forall s (m :: Type -> Type). MonadState s m => m s
get
      case Term DeBruijn DefaultUni DefaultFun ()
scrutinee of
        Var () (DeBruijn (Map Index Text -> Index -> Maybe DefaultFun
builtinFunAtRef Map Index Text
ps'nameMap -> Just DefaultFun
PLC.IfThenElse)) ->
          forall t s ann.
(t -> PrettyMonad s (Doc ann))
-> t -> t -> t -> PrettyMonad s (Doc ann)
prettyIfThenElse (forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go) Term DeBruijn DefaultUni DefaultFun ()
cond Term DeBruijn DefaultUni DefaultFun ()
trueBranch Term DeBruijn DefaultUni DefaultFun ()
falseBranch
        Term DeBruijn DefaultUni DefaultFun ()
_ -> case Term DeBruijn DefaultUni DefaultFun ()
ast of
          Force ()
_ t :: Term DeBruijn DefaultUni DefaultFun ()
t@Apply {} -> forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify PrettyState -> PrettyState
specializeCursor forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
t forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (Doc ()
"!" <>)
          Term DeBruijn DefaultUni DefaultFun ()
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: IfThenElseLikeAST"
    go (Force ()
_ Term DeBruijn DefaultUni DefaultFun ()
t) = forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify PrettyState -> PrettyState
specializeCursor forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
t forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (Doc ()
"!" <>)
    go (Delay ()
_ Term DeBruijn DefaultUni DefaultFun ()
t) = forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify PrettyState -> PrettyState
specializeCursor forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
t forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (Doc ()
"~" <>)
    go (LamAbs ()
_ DeBruijn
_ Term DeBruijn DefaultUni DefaultFun ()
t') = do
      currState :: PrettyState
currState@PrettyState {PrettyCursor
ps'cursor :: PrettyCursor
$sel:ps'cursor:PrettyState :: PrettyState -> PrettyCursor
ps'cursor} <- forall s (m :: Type -> Type). MonadState s m => m s
get
      let (Index
depth, Term DeBruijn DefaultUni DefaultFun ()
bodyTerm) = forall name (uni :: Type -> Type) fun ann.
Index -> Term name uni fun ann -> (Index, Term name uni fun ann)
unwrapLamAbs Index
0 Term DeBruijn DefaultUni DefaultFun ()
t'
      [Text]
names <- forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b. a -> b -> a
const forall s. PrettyMonad s Text
freshVarName) [Index
0 .. Index
depth]
      -- Add all the new names to the nameMap, starting with 0 index.
      forall s (m :: Type -> Type). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ [Text] -> PrettyState -> PrettyState
insertBindings [Text]
names PrettyState
currState
      forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
normalizeCursor
      Doc ()
funcBody <- forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState forall a b. (a -> b) -> a -> b
$ forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
bodyTerm
      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
ps'cursor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
indentWidth forall a b. (a -> b) -> a -> b
$
        forall ann. [Doc ann] -> Doc ann
PP.sep
          [ Doc ()
"\\" forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
PP.hsep (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a ann. Pretty a => a -> Doc ann
PP.pretty [Text]
names) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"->"
          , Doc ()
funcBody
          ]
    go (Apply ()
_ (LamAbs ()
_ DeBruijn
_ Term DeBruijn DefaultUni DefaultFun ()
t) Term DeBruijn DefaultUni DefaultFun ()
firstArg) = do
      PrettyState {PrettyCursor
ps'cursor :: PrettyCursor
$sel:ps'cursor:PrettyState :: PrettyState -> PrettyCursor
ps'cursor} <- forall s (m :: Type -> Type). MonadState s m => m s
get
      let ([Term DeBruijn DefaultUni DefaultFun ()]
restArgs, Term DeBruijn DefaultUni DefaultFun ()
coreF) = forall name (uni :: Type -> Type) fun ann.
[Term name uni fun ann]
-> Term name uni fun ann
-> ([Term name uni fun ann], Term name uni fun ann)
unwrapBindings [] Term DeBruijn DefaultUni DefaultFun ()
t
          helper :: (a, Term DeBruijn DefaultUni DefaultFun ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
helper (a
name, Term DeBruijn DefaultUni DefaultFun ()
expr) = do
            forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
normalizeCursor
            Doc ()
valueDoc <- forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState forall a b. (a -> b) -> a -> b
$ forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
expr
            forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
indentWidth forall a b. (a -> b) -> a -> b
$
              forall ann. [Doc ann] -> Doc ann
PP.sep
                [ forall a ann. Pretty a => a -> Doc ann
PP.pretty a
name forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"="
                , Doc ()
valueDoc
                ]
      Text
firstName <- forall (uni :: Type -> Type) s.
Term DeBruijn uni DefaultFun () -> PrettyMonad s Text
smartName Term DeBruijn DefaultUni DefaultFun ()
firstArg
      Doc ()
firstBindingDoc <- forall {a} {s}.
Pretty a =>
(a, Term DeBruijn DefaultUni DefaultFun ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
helper (Text
firstName, Term DeBruijn DefaultUni DefaultFun ()
firstArg)
      forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ Text -> PrettyState -> PrettyState
insertName Text
firstName
      Doc ()
restBindingDoc <- forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a. [a] -> [a]
reverse [Term DeBruijn DefaultUni DefaultFun ()]
restArgs) forall a b. (a -> b) -> a -> b
$ \Term DeBruijn DefaultUni DefaultFun ()
argExpr -> do
        Text
newName <- forall (uni :: Type -> Type) s.
Term DeBruijn uni DefaultFun () -> PrettyMonad s Text
smartName Term DeBruijn DefaultUni DefaultFun ()
argExpr
        Doc ()
bindingDoc <- forall {a} {s}.
Pretty a =>
(a, Term DeBruijn DefaultUni DefaultFun ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
helper (Text
newName, Term DeBruijn DefaultUni DefaultFun ()
argExpr)
        forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (Text -> PrettyState -> PrettyState
insertName Text
newName) forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> forall ann. Doc ann -> Doc ann -> Doc ann
PP.flatAlt forall ann. Doc ann
PP.hardline Doc ()
"; " forall a. Semigroup a => a -> a -> a
<> Doc ()
bindingDoc
      forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
normalizeCursor
      Doc ()
coreExprDoc <- forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
coreF
      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
ps'cursor forall a b. (a -> b) -> a -> b
$
        forall ann. Doc ann -> Doc ann
PP.align forall a b. (a -> b) -> a -> b
$
          forall ann. [Doc ann] -> Doc ann
PP.vsep
            [ Doc ()
"let" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
PP.align (Doc ()
firstBindingDoc forall a. Semigroup a => a -> a -> a
<> Doc ()
restBindingDoc)
            , Doc ()
"in" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
coreExprDoc
            ]
    go (Apply ()
_ Term DeBruijn DefaultUni DefaultFun ()
t Term DeBruijn DefaultUni DefaultFun ()
arg) = do
      PrettyState {PrettyCursor
ps'cursor :: PrettyCursor
$sel:ps'cursor:PrettyState :: PrettyState -> PrettyCursor
ps'cursor} <- forall s (m :: Type -> Type). MonadState s m => m s
get
      let ([Term DeBruijn DefaultUni DefaultFun ()]
l, Term DeBruijn DefaultUni DefaultFun ()
f) = forall name (uni :: Type -> Type) fun ann.
[Term name uni fun ann]
-> Term name uni fun ann
-> ([Term name uni fun ann], Term name uni fun ann)
unwrapApply [] Term DeBruijn DefaultUni DefaultFun ()
t
          args :: [Term DeBruijn DefaultUni DefaultFun ()]
args = [Term DeBruijn DefaultUni DefaultFun ()]
l forall a. Semigroup a => a -> a -> a
<> [Term DeBruijn DefaultUni DefaultFun ()
arg]
      Doc ()
functionDoc <- forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState forall a b. (a -> b) -> a -> b
$ forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
specializeCursor forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
f
      [Doc ()]
argsDoc <- forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
specializeCursor forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go) [Term DeBruijn DefaultUni DefaultFun ()]
args
      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
ps'cursor forall a b. (a -> b) -> a -> b
$
        forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
indentWidth forall a b. (a -> b) -> a -> b
$
          forall ann. [Doc ann] -> Doc ann
PP.sep forall a b. (a -> b) -> a -> b
$
            Doc ()
functionDoc forall a. a -> [a] -> [a]
: [Doc ()]
argsDoc

prettyIfThenElse ::
  (t -> PrettyMonad s (PP.Doc ann)) ->
  t ->
  t ->
  t ->
  PrettyMonad s (PP.Doc ann)
prettyIfThenElse :: forall t s ann.
(t -> PrettyMonad s (Doc ann))
-> t -> t -> t -> PrettyMonad s (Doc ann)
prettyIfThenElse t -> PrettyMonad s (Doc ann)
cont t
cond t
trueBranch t
falseBranch = do
  PrettyState {PrettyCursor
ps'cursor :: PrettyCursor
$sel:ps'cursor:PrettyState :: PrettyState -> PrettyCursor
ps'cursor} <- forall s (m :: Type -> Type). MonadState s m => m s
get
  forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
normalizeCursor
  Doc ann
condAst <- t -> PrettyMonad s (Doc ann)
cont t
cond
  Doc ann
trueAst <- t -> PrettyMonad s (Doc ann)
cont t
trueBranch
  Doc ann
falseAst <- t -> PrettyMonad s (Doc ann)
cont t
falseBranch
  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
ps'cursor forall a b. (a -> b) -> a -> b
$
    forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
indentWidth forall a b. (a -> b) -> a -> b
$
      forall ann. [Doc ann] -> Doc ann
PP.vsep [Doc ann
"if" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
condAst, Doc ann
"then" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
trueAst, Doc ann
"else" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
falseAst]

-- | Wrap prettification result parens depending on cursor state.
parensOnCursor :: PrettyCursor -> PP.Doc ann -> PP.Doc ann
parensOnCursor :: forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
cursor = do
  if PrettyCursor
cursor forall a. Eq a => a -> a -> Bool
== PrettyCursor
Special then forall ann. Doc ann -> Doc ann
PP.parens else forall a. a -> a
id