{-# LANGUAGE PatternSynonyms #-}

module Plutarch.Pretty (prettyTerm, prettyTermAndCost, 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.ByteString.Short qualified as SBS
import Data.Foldable (fold, toList)
import Data.Functor (($>), (<&>))
import Data.Text (Text)
import Data.Text qualified as Txt
import Data.Traversable (for)
import Plutarch.Evaluate (evalTerm)
import Plutarch.Internal.Term (ClosedTerm, Config, compile)
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,
 )
import Plutarch.Script (Script (unScript))
import PlutusCore qualified as PLC
import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (ExBudget))
import PlutusLedgerApi.Common (serialiseUPLC)
import Prettyprinter ((<+>))
import Prettyprinter qualified as PP
import System.Random.Stateful (mkStdGen, newSTGenM)
import UntypedPlutusCore (
  DeBruijn (DeBruijn),
  DefaultFun,
  DefaultUni,
  Program (_progTerm),
  Term (Apply, Builtin, Case, Constant, Constr, Delay, Error, Force, LamAbs, Var),
 )

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

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 = (Text -> Doc ())
-> (Doc () -> Doc ()) -> Either Text (Doc ()) -> Doc ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Doc ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> Doc ()) -> (Text -> [Char]) -> Text -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Txt.unpack) Doc () -> Doc ()
forall a. a -> a
id (Either Text (Doc ()) -> Doc ()) -> Either Text (Doc ()) -> Doc ()
forall a b. (a -> b) -> a -> b
$ Config -> ClosedTerm a -> Either Text (Doc ())
forall (p :: PType). Config -> ClosedTerm p -> Either Text (Doc ())
prettyTerm' Config
conf Term s a
ClosedTerm a
x

{- | Same as `prettyTerm` but also includes the execution budget and script size

@since 1.10.0
-}
prettyTermAndCost :: forall a. Config -> ClosedTerm a -> PP.Doc ()
prettyTermAndCost :: forall (a :: PType). Config -> ClosedTerm a -> Doc ()
prettyTermAndCost Config
conf ClosedTerm a
x =
  let
    pp :: Doc ()
pp = (Text -> Doc ())
-> (Doc () -> Doc ()) -> Either Text (Doc ()) -> Doc ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Doc ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> Doc ()) -> (Text -> [Char]) -> Text -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Txt.unpack) Doc () -> Doc ()
forall a. a -> a
id (Either Text (Doc ()) -> Doc ()) -> Either Text (Doc ()) -> Doc ()
forall a b. (a -> b) -> a -> b
$ Config -> ClosedTerm a -> Either Text (Doc ())
forall (p :: PType). Config -> ClosedTerm p -> Either Text (Doc ())
prettyTerm' Config
conf Term s a
ClosedTerm a
x
    (Either EvalError (ClosedTerm a)
_, ExBudget ExCPU
cpu ExMemory
mem, [Text]
_) = (Text -> (Either EvalError (ClosedTerm a), ExBudget, [Text]))
-> ((Either EvalError (ClosedTerm a), ExBudget, [Text])
    -> (Either EvalError (ClosedTerm a), ExBudget, [Text]))
-> Either Text (Either EvalError (ClosedTerm a), ExBudget, [Text])
-> (Either EvalError (ClosedTerm a), ExBudget, [Text])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> (Either EvalError (ClosedTerm a), ExBudget, [Text])
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Either EvalError (ClosedTerm a), ExBudget, [Text]))
-> (Text -> [Char])
-> Text
-> (Either EvalError (ClosedTerm a), ExBudget, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Txt.unpack) (Either EvalError (ClosedTerm a), ExBudget, [Text])
-> (Either EvalError (ClosedTerm a), ExBudget, [Text])
forall a. a -> a
id (Either Text (Either EvalError (ClosedTerm a), ExBudget, [Text])
 -> (Either EvalError (ClosedTerm a), ExBudget, [Text]))
-> Either Text (Either EvalError (ClosedTerm a), ExBudget, [Text])
-> (Either EvalError (ClosedTerm a), ExBudget, [Text])
forall a b. (a -> b) -> a -> b
$ forall (a :: PType).
Config
-> ClosedTerm a
-> Either Text (Either EvalError (ClosedTerm a), ExBudget, [Text])
evalTerm @a Config
conf Term s a
ClosedTerm a
x
    scriptSize :: Int
scriptSize =
      ShortByteString -> Int
SBS.length (ShortByteString -> Int) -> ShortByteString -> Int
forall a b. (a -> b) -> a -> b
$
        Program DeBruijn DefaultUni DefaultFun () -> ShortByteString
serialiseUPLC (Program DeBruijn DefaultUni DefaultFun () -> ShortByteString)
-> Program DeBruijn DefaultUni DefaultFun () -> ShortByteString
forall a b. (a -> b) -> a -> b
$
          Script -> Program DeBruijn DefaultUni DefaultFun ()
unScript (Script -> Program DeBruijn DefaultUni DefaultFun ())
-> Script -> Program DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$
            (Text -> Script)
-> (Script -> Script) -> Either Text Script -> Script
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Script
forall a. HasCallStack => [Char] -> a
error ([Char] -> Script) -> (Text -> [Char]) -> Text -> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Txt.unpack) Script -> Script
forall a. a -> a
id (Either Text Script -> Script) -> Either Text Script -> Script
forall a b. (a -> b) -> a -> b
$
              Config -> ClosedTerm a -> Either Text Script
forall (a :: PType). Config -> ClosedTerm a -> Either Text Script
compile Config
conf Term s a
ClosedTerm a
x
   in
    Doc ()
pp Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"\n" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"CPU: " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> ExCPU -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. ExCPU -> Doc ann
PP.pretty ExCPU
cpu Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"\nMEM: " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> ExMemory -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. ExMemory -> Doc ann
PP.pretty ExMemory
mem Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"\nSIZE: " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ()
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Int
scriptSize

-- | 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 (Script -> Doc ()) -> Either Text Script -> Either Text (Doc ())
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> ClosedTerm p -> Either Text Script
forall (a :: PType). Config -> ClosedTerm a -> Either Text Script
compile Config
conf Term s p
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 s. ST s (Doc ())) -> Doc ()
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Doc ())) -> Doc ())
-> (forall s. ST s (Doc ())) -> Doc ()
forall a b. (a -> b) -> a -> b
$ do
  STGenM StdGen s
stGen <- StdGen -> ST s (STGenM StdGen s)
forall g s. g -> ST s (STGenM g s)
newSTGenM (StdGen -> ST s (STGenM StdGen s))
-> StdGen -> ST s (STGenM StdGen s)
forall a b. (a -> b) -> a -> b
$ Int -> StdGen
mkStdGen Int
42
  (Doc ()
doc, PrettyState
_) <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> STGenM StdGen s -> StateT PrettyState (ST s) (Doc ())
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
uplc) STGenM StdGen s
stGen StateT PrettyState (ST s) (Doc ())
-> PrettyState -> ST s (Doc (), PrettyState)
forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
`runStateT` Map Index Text -> Set Text -> PrettyCursor -> PrettyState
PrettyState Map Index Text
forall a. Monoid a => a
mempty Set Text
forall a. Monoid a => a
mempty PrettyCursor
Normal
  Doc () -> ST s (Doc ())
forall a. a -> ST s a
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) = Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$ Some @Type (ValueOf DefaultUni) -> Doc ()
prettyConstant Some @Type (ValueOf DefaultUni)
c
    go (Builtin ()
_ DefaultFun
b) = Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$ DefaultFun -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. DefaultFun -> Doc ann
PP.pretty DefaultFun
b
    go (Error ()
_) = Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Doc ()
"ERROR"
    go (Var ()
_ (DeBruijn Index
x)) = do
      PrettyState {Map Index Text
$sel:ps'nameMap:PrettyState :: PrettyState -> Map Index Text
ps'nameMap :: Map Index Text
ps'nameMap} <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) PrettyState
forall s (m :: Type -> Type). MonadState s m => m s
get
      Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
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 -> Text -> Doc ()
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
nm
        Maybe Text
Nothing -> Doc ()
"(impossible: FREE VARIABLE: " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Index -> Doc ()
forall a ann. Pretty a => a -> Doc ann
forall ann. Index -> Doc ann
PP.pretty Index
x Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
")"
    go (IfThenElseLikeAST (Force () (Builtin () DefaultFun
PLC.IfThenElse)) Term DeBruijn DefaultUni DefaultFun ()
cond Term DeBruijn DefaultUni DefaultFun ()
trueBranch Term DeBruijn DefaultUni DefaultFun ()
falseBranch) = (Term DeBruijn DefaultUni DefaultFun ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall t s ann.
(t -> PrettyMonad s (Doc ann))
-> t -> t -> t -> PrettyMonad s (Doc ann)
prettyIfThenElse (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
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
$sel:ps'nameMap:PrettyState :: PrettyState -> Map Index Text
ps'nameMap :: Map Index Text
ps'nameMap} <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) PrettyState
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)) ->
          (Term DeBruijn DefaultUni DefaultFun ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall t s ann.
(t -> PrettyMonad s (Doc ann))
-> t -> t -> t -> PrettyMonad s (Doc ann)
prettyIfThenElse (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
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 {} -> (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify PrettyState -> PrettyState
specializeCursor ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b.
ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
t ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> (Doc () -> Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (Doc ()
"!" <>)
          Term DeBruijn DefaultUni DefaultFun ()
_ -> [Char]
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: IfThenElseLikeAST"
    go (Force ()
_ Term DeBruijn DefaultUni DefaultFun ()
t) = (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify PrettyState -> PrettyState
specializeCursor ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b.
ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
t ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> (Doc () -> Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (Doc ()
"!" <>)
    go (Delay ()
_ Term DeBruijn DefaultUni DefaultFun ()
t) = (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify PrettyState -> PrettyState
specializeCursor ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b.
ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
t ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> (Doc () -> Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
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
$sel:ps'cursor:PrettyState :: PrettyState -> PrettyCursor
ps'cursor :: PrettyCursor
ps'cursor} <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) PrettyState
forall s (m :: Type -> Type). MonadState s m => m s
get
      let (Index
depth, Term DeBruijn DefaultUni DefaultFun ()
bodyTerm) = Index
-> Term DeBruijn DefaultUni DefaultFun ()
-> (Index, Term DeBruijn DefaultUni DefaultFun ())
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 <- (Index
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) Text)
-> [Index]
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Text]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) Text
-> Index
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) Text
forall a b. a -> b -> a
const ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) Text
forall s. PrettyMonad s Text
freshVarName) [Item [Index]
Index
0 .. Item [Index]
Index
depth]
      -- Add all the new names to the nameMap, starting with 0 index.
      PrettyState
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (PrettyState
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ())
-> PrettyState
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Text] -> PrettyState -> PrettyState
insertBindings [Text]
names PrettyState
currState
      (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
normalizeCursor
      Doc ()
funcBody <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$ Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
bodyTerm
      Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> (Doc () -> Doc ())
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyCursor -> Doc () -> Doc ()
forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
ps'cursor (Doc () -> Doc ()) -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
indentWidth (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$
        [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
PP.sep
          [ Doc ()
"\\" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
PP.hsep ([Doc ()] -> [Doc ()]
forall a. [a] -> [a]
reverse ([Doc ()] -> [Doc ()]) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$ (Text -> Doc ()) -> [Text] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc ()
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty [Text]
names) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"->"
          , Item [Doc ()]
Doc ()
funcBody
          ]
    go (Apply ()
_ (LamAbs ()
_ DeBruijn
_ Term DeBruijn DefaultUni DefaultFun ()
t) Term DeBruijn DefaultUni DefaultFun ()
firstArg) = do
      PrettyState {PrettyCursor
$sel:ps'cursor:PrettyState :: PrettyState -> PrettyCursor
ps'cursor :: PrettyCursor
ps'cursor} <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) PrettyState
forall s (m :: Type -> Type). MonadState s m => m s
get
      let ([Term DeBruijn DefaultUni DefaultFun ()]
restArgs, Term DeBruijn DefaultUni DefaultFun ()
coreF) = [Term DeBruijn DefaultUni DefaultFun ()]
-> Term DeBruijn DefaultUni DefaultFun ()
-> ([Term DeBruijn DefaultUni DefaultFun ()],
    Term DeBruijn DefaultUni DefaultFun ())
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
            (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
normalizeCursor
            Doc ()
valueDoc <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$ Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
expr
            Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> (Doc () -> Doc ())
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
indentWidth (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$
              [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
PP.sep
                [ a -> Doc ()
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty a
name Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"="
                , Item [Doc ()]
Doc ()
valueDoc
                ]
      Text
firstName <- Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) Text
forall (uni :: Type -> Type) s.
Term DeBruijn uni DefaultFun () -> PrettyMonad s Text
smartName Term DeBruijn DefaultUni DefaultFun ()
firstArg
      Doc ()
firstBindingDoc <- (Text, Term DeBruijn DefaultUni DefaultFun ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
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)
      (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' ((PrettyState -> PrettyState)
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ())
-> (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall a b. (a -> b) -> a -> b
$ Text -> PrettyState -> PrettyState
insertName Text
firstName
      Doc ()
restBindingDoc <- ([Doc ()] -> Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()]
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b.
(a -> b)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc ()] -> Doc ()
forall m. Monoid m => [m] -> m
forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
fold (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()]
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> ((Term DeBruijn DefaultUni DefaultFun ()
     -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
    -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()])
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term DeBruijn DefaultUni DefaultFun ()]
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Term DeBruijn DefaultUni DefaultFun ()]
-> [Term DeBruijn DefaultUni DefaultFun ()]
forall a. [a] -> [a]
reverse [Term DeBruijn DefaultUni DefaultFun ()]
restArgs) ((Term DeBruijn DefaultUni DefaultFun ()
  -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$ \Term DeBruijn DefaultUni DefaultFun ()
argExpr -> do
        Text
newName <- Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) Text
forall (uni :: Type -> Type) s.
Term DeBruijn uni DefaultFun () -> PrettyMonad s Text
smartName Term DeBruijn DefaultUni DefaultFun ()
argExpr
        Doc ()
bindingDoc <- (Text, Term DeBruijn DefaultUni DefaultFun ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
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)
        (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (Text -> PrettyState -> PrettyState
insertName Text
newName) ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
PP.flatAlt Doc ()
forall ann. Doc ann
PP.hardline Doc ()
"; " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
bindingDoc
      (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
normalizeCursor
      Doc ()
coreExprDoc <- Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
coreF
      Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> (Doc () -> Doc ())
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyCursor -> Doc () -> Doc ()
forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
ps'cursor (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$
        Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
PP.align (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
          [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
PP.vsep
            [ Doc ()
"let" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
PP.align (Doc ()
firstBindingDoc Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
restBindingDoc)
            , Doc ()
"in" Doc () -> Doc () -> Doc ()
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
$sel:ps'cursor:PrettyState :: PrettyState -> PrettyCursor
ps'cursor :: PrettyCursor
ps'cursor} <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) PrettyState
forall s (m :: Type -> Type). MonadState s m => m s
get
      let ([Term DeBruijn DefaultUni DefaultFun ()]
l, Term DeBruijn DefaultUni DefaultFun ()
f) = [Term DeBruijn DefaultUni DefaultFun ()]
-> Term DeBruijn DefaultUni DefaultFun ()
-> ([Term DeBruijn DefaultUni DefaultFun ()],
    Term DeBruijn DefaultUni DefaultFun ())
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 [Term DeBruijn DefaultUni DefaultFun ()]
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> [Term DeBruijn DefaultUni DefaultFun ()]
forall a. Semigroup a => a -> a -> a
<> [Item [Term DeBruijn DefaultUni DefaultFun ()]
Term DeBruijn DefaultUni DefaultFun ()
arg]
      Doc ()
functionDoc <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$ (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
specializeCursor ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b.
ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
f
      [Doc ()]
argsDoc <- (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' PrettyState -> PrettyState
specializeCursor ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()]
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()]
forall a b.
ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> (Term DeBruijn DefaultUni DefaultFun ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s (m :: Type -> Type) b. MonadState s m => m b -> m b
forkState (ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go) [Term DeBruijn DefaultUni DefaultFun ()]
args
      Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> (Doc () -> Doc ())
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyCursor -> Doc () -> Doc ()
forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
ps'cursor (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$
        Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
indentWidth (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
          [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
PP.sep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
            Doc ()
functionDoc Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: [Doc ()]
argsDoc
    go (Constr ()
_ Word64
i [Term DeBruijn DefaultUni DefaultFun ()]
args) = do
      [Doc ()]
vals <- (Term DeBruijn DefaultUni DefaultFun ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go [Term DeBruijn DefaultUni DefaultFun ()]
args
      Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$ Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
PP.parens (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"Constr" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word64 -> Doc ()
forall ann. Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Word64
i Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
PP.parens ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
PP.hsep [Doc ()]
vals)
    go (Case ()
_ Term DeBruijn DefaultUni DefaultFun ()
x Vector (Term DeBruijn DefaultUni DefaultFun ())
handlers) = do
      Doc ()
val <- Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Term DeBruijn DefaultUni DefaultFun ()
x
      [Doc ()]
handlers <- (Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
PP.parens ([Doc ()] -> [Doc ()])
-> (Vector (Doc ()) -> [Doc ()]) -> Vector (Doc ()) -> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Doc ()) -> [Doc ()]
forall a. Vector a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (Vector (Doc ()) -> [Doc ()])
-> ReaderT
     (STGenM StdGen s) (StateT PrettyState (ST s)) (Vector (Doc ()))
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) [Doc ()]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term DeBruijn DefaultUni DefaultFun ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
-> ReaderT
     (STGenM StdGen s) (StateT PrettyState (ST s)) (Vector (Doc ()))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse Term DeBruijn DefaultUni DefaultFun ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall s.
Term DeBruijn DefaultUni DefaultFun () -> PrettyMonad s (Doc ())
go Vector (Term DeBruijn DefaultUni DefaultFun ())
handlers
      Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ()
 -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ()))
-> Doc ()
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) (Doc ())
forall a b. (a -> b) -> a -> b
$ Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
PP.parens (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"Case" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
-3 (Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
PP.parens ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
PP.vsep (Doc ()
val Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: [Doc ()]
handlers)))

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
$sel:ps'cursor:PrettyState :: PrettyState -> PrettyCursor
ps'cursor :: PrettyCursor
ps'cursor} <- ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) PrettyState
forall s (m :: Type -> Type). MonadState s m => m s
get
  (PrettyState -> PrettyState)
-> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) ()
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
  Doc ann -> PrettyMonad s (Doc ann)
forall a.
a -> ReaderT (STGenM StdGen s) (StateT PrettyState (ST s)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Doc ann -> PrettyMonad s (Doc ann))
-> (Doc ann -> Doc ann) -> Doc ann -> PrettyMonad s (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyCursor -> Doc ann -> Doc ann
forall ann. PrettyCursor -> Doc ann -> Doc ann
parensOnCursor PrettyCursor
ps'cursor (Doc ann -> PrettyMonad s (Doc ann))
-> Doc ann -> PrettyMonad s (Doc ann)
forall a b. (a -> b) -> a -> b
$
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
indentWidth (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep [Doc ann
"if" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
condAst, Doc ann
"then" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
trueAst, Doc ann
"else" Doc ann -> Doc ann -> Doc ann
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 = if PrettyCursor
cursor PrettyCursor -> PrettyCursor -> Bool
forall a. Eq a => a -> a -> Bool
== PrettyCursor
Special then Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.parens else Doc ann -> Doc ann
forall a. a -> a
id