quox/lib/Quox/Syntax/Term/Pretty.idr

module Quox.Syntax.Term.Pretty

import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
import Quox.Context
import Quox.Pretty

import Quox.SingletonExtra
import Data.Vect
import Derive.Prelude

%default total
%language ElabReflection


export
prettyUniverse : {opts : LayoutOpts} -> Universe -> Eff Pretty (Doc opts)
prettyUniverse = hl Universe . text . show


export
prettyTerm : {opts : LayoutOpts} ->
             NameContexts q d n -> Term q d n -> Eff Pretty (Doc opts)

export
prettyElim : {opts : LayoutOpts} ->
             NameContexts q d n -> Elim q d n -> Eff Pretty (Doc opts)


export
prettyQty : {opts : LayoutOpts} ->
            NameContexts q d n -> Qty q -> Eff Pretty (Doc opts)
prettyQty names pi = let Val q = names.qtyLen in prettyQty names.qnames pi


private
superscript : String -> String
superscript = pack . map sup . unpack where
  sup : Char -> Char
  sup c = case c of
    '0' => '⁰'; '1' => '¹'; '2' => '²'; '3' => '³'; '4' => '⁴'
    '5' => '⁵'; '6' => '⁶'; '7' => '⁷'; '8' => '⁸'; '9' => '⁹'; _ => c


private
PiBind : TermLike
PiBind q d n = (Qty q, BindName, Term q d n)

private
pbname : PiBind q d n -> BindName
pbname (_, x, _) = x

private
record SplitPi q d n where
  constructor MkSplitPi
  {0 inner : Nat}
  binds : Telescope (PiBind q d) n inner
  cod   : Term q d inner

private
splitPi : {q : Nat} ->
          Telescope (PiBind q d) n n' -> Term q d n' -> SplitPi q d n
splitPi binds cod@(Pi qty arg res _) =
  splitPi (binds :< (qty, res.name, arg)) $
    assert_smaller cod $ pushSubsts' res.term
splitPi binds cod = MkSplitPi {binds, cod}

private
prettyPiBind1 : {opts : LayoutOpts} ->
                NameContexts q d n -> Qty q -> BindName -> Term q d n ->
                Eff Pretty (Doc opts)
prettyPiBind1 names pi (BN Unused _) s =
  hcat <$> sequence
    [prettyQty names pi, dotD,
     withPrec Arg $ assert_total prettyTerm names s]
prettyPiBind1 names pi x s =
  hcat <$> sequence
    [prettyQty names pi, dotD,
     hl Delim $ text "(",
     hsep <$> sequence
       [prettyTBind x, hl Delim $ text ":",
        withPrec Outer $ assert_total prettyTerm names s],
     hl Delim $ text ")"]

private
prettyPiBinds : {opts : LayoutOpts} ->
                NameContexts q d n ->
                Telescope (PiBind q d) n n' ->
                Eff Pretty (SnocList (Doc opts))
prettyPiBinds _ [<] = pure [<]
prettyPiBinds names (binds :< (q, x, t)) =
  let names' = extendTermN' (map pbname binds) names in
  [|prettyPiBinds names binds :<
    prettyPiBind1 names' q x t|]


private
SigBind : TermLike
SigBind q d n = (BindName, Term q d n)

private
record SplitSig q d n where
  constructor MkSplitSig
  {0 inner : Nat}
  binds : Telescope (SigBind q d) n inner
  last  : Term q d inner

private
splitSig : {q : Nat} ->
           Telescope (SigBind q d) n n' -> Term q d n' -> SplitSig q d n
splitSig binds (Sig fst snd _) =
  splitSig (binds :< (snd.name, fst)) $
    assert_smaller snd $ pushSubsts' snd.term
splitSig binds last = MkSplitSig {binds, last}

private
prettySigBind1 : {opts : LayoutOpts} ->
                 NameContexts q d n -> BindName -> Term q d n ->
                 Eff Pretty (Doc opts)
prettySigBind1 names (BN Unused _) s =
  withPrec InTimes $ assert_total prettyTerm names s
prettySigBind1 names x s = hcat <$> sequence
  [hl Delim $ text "(",
   hsep <$> sequence
     [prettyTBind x, hl Delim $ text ":",
      withPrec Outer $ assert_total prettyTerm names s],
   hl Delim $ text ")"]

private
prettySigBinds : {opts : LayoutOpts} ->
                 NameContexts q d n -> Telescope (SigBind q d) n n' ->
                 Eff Pretty (SnocList (Doc opts))
prettySigBinds _ [<] = pure [<]
prettySigBinds names (binds :< (x, t)) =
  let names' = extendTermN' (map fst binds) names in
  [|prettySigBinds names binds :<
    prettySigBind1 names' x t|]


private
prettyTypeLine : {opts : LayoutOpts} ->
                 NameContexts q d n -> DScopeTerm q d n ->
                 Eff Pretty (Doc opts)
prettyTypeLine names (S _ (N body)) =
  withPrec Arg (prettyTerm names body)
prettyTypeLine names (S [< i] (Y body)) =
  parens =<< do
    let names' = extendDim i names
    i'  <- prettyDBind i
    ty' <- withPrec Outer $ prettyTerm names' body
    pure $ sep [hsep [i', !darrowD], ty']


private
data NameSort = T | D
%runElab derive "NameSort" [Eq]

private
NameChunks : Type
NameChunks = SnocList (NameSort, SnocList BindName)

private
record SplitLams q d n where
  constructor MkSplitLams
  {0 dinner, ninner : Nat}
  dnames : BTelescope d dinner
  tnames : BTelescope n ninner
  chunks : NameChunks
  body   : Term q dinner ninner

private
splitLams : {q : Nat} -> Term q d n -> SplitLams q d n
splitLams s = go [<] [<] [<] (pushSubsts' s)
where
  push : NameSort -> BindName -> NameChunks -> NameChunks
  push s y [<] = [< (s, [< y])]
  push s y (xss :< (s', xs)) =
    if s == s' then xss :< (s', xs :< y)
    else xss :< (s', xs) :< (s, [< y])

  go : BTelescope d d' -> BTelescope n n' ->
       SnocList (NameSort, SnocList BindName) ->
       Term q d' n' -> SplitLams q d n
  go dnames tnames chunks (Lam b _) =
    go dnames (tnames :< b.name) (push T b.name chunks) $
       assert_smaller b $ pushSubsts' b.term
  go dnames tnames chunks (DLam b _) =
    go (dnames :< b.name) tnames (push D b.name chunks) $
       assert_smaller b $ pushSubsts' b.term
  go dnames tnames chunks s =
    MkSplitLams dnames tnames chunks s


private
splitTuple : {q : Nat} ->
             SnocList (Term q d n) -> Term q d n -> SnocList (Term q d n)
splitTuple ss p@(Pair t1 t2 _) =
  splitTuple (ss :< t1) $ assert_smaller p $ pushSubsts' t2
splitTuple ss t = ss :< t


private
prettyTArg : {opts : LayoutOpts} ->
             NameContexts q d n -> Term q d n -> Eff Pretty (Doc opts)
prettyTArg names s =
  withPrec Arg $ assert_total prettyTerm names s

private
prettyDArg : {opts : LayoutOpts} ->
             NameContexts _ d _ -> Dim d -> Eff Pretty (Doc opts)
prettyDArg names p = [|atD <+> withPrec Arg (prettyDim names.dnames p)|]

private
splitApps : {q : Nat} ->
            Elim q d n -> (Elim q d n, List (Either (Dim d) (Term q d n)))
splitApps e = go [] (pushSubsts' e)
where
  go : List (Either (Dim d) (Term q d n)) -> Elim q d n ->
       (Elim q d n, List (Either (Dim d) (Term q d n)))
  go xs e@(App  f s _) =
    go (Right s :: xs) $ assert_smaller e $ pushSubsts' f
  go xs e@(DApp f p _) =
    go (Left  p :: xs) $ assert_smaller e $ pushSubsts' f
  go xs s = (s, xs)

private
prettyDTApps : {opts : LayoutOpts} ->
               NameContexts q d n ->
               Elim q d n -> List (Either (Dim d) (Term q d n)) ->
               Eff Pretty (Doc opts)
prettyDTApps names f xs = do
  f  <- withPrec Arg $ assert_total prettyElim names f
  xs <- for xs $ either (prettyDArg names) (prettyTArg names)
  prettyAppD f xs


private
record CaseArm opts q d n where
  constructor MkCaseArm
  pat    : Doc opts
  dbinds : BTelescope d dinner -- 🍴
  tbinds : BTelescope n ninner
  body   : Term q dinner ninner

private
prettyCaseArm : {opts : LayoutOpts} ->
                NameContexts q d n -> CaseArm opts q d n ->
                Eff Pretty (Doc opts)
prettyCaseArm names (MkCaseArm pat dbinds tbinds body) = do
  let names' = extendDimN' dbinds $ extendTermN' tbinds names
  body <- withPrec Outer $ assert_total prettyTerm names' body
  header <- (pat <++>) <$> darrowD
  pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])

private
prettyCaseBody : {opts : LayoutOpts} ->
                 NameContexts q d n -> List (CaseArm opts q d n) ->
                 Eff Pretty (List (Doc opts))
prettyCaseBody names xs = traverse (prettyCaseArm names) xs

private
prettyCompPat : {opts : LayoutOpts} ->
                DimConst -> BindName -> Eff Pretty (Doc opts)
prettyCompPat e x = [|prettyDimConst e <++> prettyDBind x|]

private
prettyCompArm : {opts : LayoutOpts} -> NameContexts q d n ->
                DimConst -> DScopeTerm q d n -> Eff Pretty (Doc opts)
prettyCompArm names e s = prettyCaseArm names $
  MkCaseArm !(prettyCompPat e s.name) [< s.name] [<] s.term

private
layoutComp : {opts : LayoutOpts} ->
             (typq : List (Doc opts)) -> (val, r : Doc opts) ->
             (arms : List (Doc opts)) -> Eff Pretty (Doc opts)
layoutComp typq val r arms = do
  comp <- compD; lb <- hl Delim "{"; rb <- hl Delim "}"
  ind  <- askAt INDENT
  pure $ ifMultiline
    (hsep $ concat {t = List} [[comp], typq, [val, r, lb], arms, [rb]]) $
    (comp <++>
      vsep [sep typq, val, r <++> lb, indent ind $ vsep arms, rb]) <|>
    (vsep $ (comp ::) $ map (indent ind) $ concat {t = List}
      [typq, [val, r <++> lb], map (indent ind) arms, [rb]])


export
prettyEnum : {opts : LayoutOpts} -> List String -> Eff Pretty (Doc opts)
prettyEnum cases =
  tightBraces =<<
  fillSeparateTight !commaD <$>
  traverse (hl Constant . Doc.text . quoteTag) cases

private
prettyCaseRet : {opts : LayoutOpts} ->
                NameContexts q d n -> ScopeTerm q d n -> Eff Pretty (Doc opts)
prettyCaseRet names body = withPrec Outer $ case body of
  S _     (N tm) => assert_total prettyTerm names tm
  S [< x] (Y tm) => do
    let names' = extendTerm x names
    header <- [|prettyTBind x <++> darrowD|]
    body   <- assert_total prettyTerm names' tm
    hangDSingle header body

private
prettyCase_ : {opts : LayoutOpts} ->
              NameContexts q d n ->
              Doc opts -> Elim q d n -> ScopeTerm q d n ->
              List (CaseArm opts q d n) ->
              Eff Pretty (Doc opts)
prettyCase_ names intro head ret body = do
  head   <- withPrec Outer $ assert_total prettyElim names head
  ret    <- prettyCaseRet names ret
  bodys  <- prettyCaseBody names body
  return <- returnD; of_ <- ofD
  lb     <- hl Delim "{"; rb <- hl Delim "}"; semi <- semiD
  ind    <- askAt INDENT
  parensIfM Outer $ ifMultiline
    (hsep [intro, head, return, ret, of_, lb, hseparateTight semi bodys, rb])
    (vsep [intro <++> head, return <++> ret, of_ <++> lb,
           indent ind $ vseparateTight semi bodys, rb])

private
prettyCase : {opts : LayoutOpts} ->
             NameContexts q d n ->
             Qty q -> Elim q d n -> ScopeTerm q d n ->
             List (CaseArm opts q d n) ->
             Eff Pretty (Doc opts)
prettyCase names qty head ret body =
  prettyCase_ names ![|caseD <+> prettyQty names qty|] head ret body


private
LetBinder : TermLike
LetBinder q d n = (Qty q, BindName, Elim q d n)

private
LetExpr : (q, d, n, n' : Nat) -> Type
LetExpr q d n n' = (Telescope (LetBinder q d) n n', Term q d n')

-- [todo] factor out this and the untyped version somehow
export
splitLet : Telescope (LetBinder q d) n n' -> Term q d n' ->
           Exists (LetExpr q d n)
splitLet ys t@(Let qty rhs body _) =
  splitLet (ys :< (qty, body.name, rhs)) (assert_smaller t body.term)
splitLet ys t =
  Evidence _ (ys, t)

private covering
prettyLets : {opts : LayoutOpts} ->
             NameContexts q d a -> Telescope (LetBinder q d) a b ->
             Eff Pretty (SnocList (Doc opts))
prettyLets (MkNameContexts qnames dnames tnames) lets = snd <$> go lets where
  peelAnn : forall d, n. Elim q d n -> Maybe (Term q d n, Term q d n)
  peelAnn (Ann tm ty _) = Just (tm, ty)
  peelAnn e             = Nothing

  letHeader : Qty q -> BindName -> Eff Pretty (Doc opts)
  letHeader qty x = do
    lett <- [|letD <+> prettyQty qnames qty|]
    x    <- prettyTBind x
    pure $ lett <++> x

  letBody : forall n. BContext n ->
            Doc opts -> Elim q d n -> Eff Pretty (Doc opts)
  letBody tnames hdr e =
    let names = MkNameContexts' qnames dnames tnames in
    case peelAnn e of
      Just (tm, ty) => do
        ty <- withPrec Outer $ assert_total prettyTerm names ty
        tm <- withPrec Outer $ assert_total prettyTerm names tm
        colon <- colonD; eq <- cstD; d <- askAt INDENT
        pure $ hangSingle d (hangSingle d hdr (colon <++> ty)) (eq <++> tm)
      Nothing => do
        e <- withPrec Outer $ assert_total prettyElim names e
        eq <- cstD; d <- askAt INDENT
        inn <- inD
        pure $ ifMultiline
          (hsep [hdr, eq, e, inn])
          (vsep [hdr, indent d $ hsep [eq, e, inn]])

  go : forall b. Telescope (LetBinder q d) a b ->
       Eff Pretty (BContext b, SnocList (Doc opts))
  go [<] = pure (tnames, [<])
  go (lets :< (qty, x, rhs)) = do
    (ys, docs) <- go lets
    doc        <- letBody ys !(letHeader qty x) rhs
    pure (ys :< x, docs :< doc)


private
isDefaultDir : Dim d -> Dim d -> Bool
isDefaultDir (K Zero _) (K One _) = True
isDefaultDir _ _ = False


-- [fixme] use telescopes in Scoped
private
toTel : BContext s -> BTelescope n (s + n)
toTel [<]        = [<]
toTel (ctx :< x) = toTel ctx :< x

private
prettyTyCasePat : {opts : LayoutOpts} ->
                  (k : TyConKind) -> BContext (arity k) ->
                  Eff Pretty (Doc opts)
prettyTyCasePat KTYPE [<] = typeD
prettyTyCasePat KIOState [<] = ioStateD
prettyTyCasePat KPi [< a, b] =
  parens . hsep =<< sequence [prettyTBind a, arrowD, prettyTBind b]
prettyTyCasePat KSig [< a, b] =
  parens . hsep =<< sequence [prettyTBind a, timesD, prettyTBind b]
prettyTyCasePat KEnum [<] = hl Syntax $ text "{}"
prettyTyCasePat KEq [< a0, a1, a, l, r] =
  hsep <$> sequence (eqD :: map prettyTBind [a0, a1, a, l, r])
prettyTyCasePat KNat [<] = natD
prettyTyCasePat KString [<] = stringD
prettyTyCasePat KBOX [< a] = bracks =<< prettyTBind a


prettyLambda : {opts : LayoutOpts} ->
               NameContexts q d n -> Term q d n -> Eff Pretty (Doc opts)
prettyLambda names s =
  let Val q = names.qtyLen
      MkSplitLams {dnames = ds, tnames = ts, chunks, body} = splitLams s
      names' = extendDimN' ds $ extendTermN' ts names in
  parensIfM Outer =<<
  hangDSingle !(header chunks) !(assert_total prettyTerm names' body)
where
  introChar : NameSort -> Eff Pretty (Doc opts)
  introChar T = lamD
  introChar D = dlamD

  prettyBind : NameSort -> BindName -> Eff Pretty (Doc opts)
  prettyBind T = prettyTBind
  prettyBind D = prettyDBind

  header1 : NameSort -> List BindName -> Eff Pretty (Doc opts)
  header1 s xs = hsep <$> sequence
    [introChar s, sep <$> traverse (prettyBind s) xs, darrowD]

  header : NameChunks -> Eff Pretty (Doc opts)
  header cs = sep <$> traverse (\(s, xs) => header1 s (toList xs)) (toList cs)


prettyDisp : {opts : LayoutOpts} -> Universe -> Eff Pretty (Maybe (Doc opts))
prettyDisp 0 = pure Nothing
prettyDisp u = map Just $ hl Universe =<<
  ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)


prettyTerm names (TYPE l _) = do
  type  <- hl Syntax . text =<< ifUnicode "★" "Type"
  level <- prettyDisp l
  pure $ maybe type (type <+>) level

prettyTerm _ (IOState _) =
  ioStateD

prettyTerm names (Pi qty arg res _) = do
  let Val q = names.qtyLen
      MkSplitPi {binds, cod} = splitPi [< (qty, res.name, arg)] res.term
  arr   <- arrowD
  lines <- map (<++> arr) <$> prettyPiBinds names binds
  let names' = extendTermN' (map pbname binds) names
  cod <- withPrec Outer $ prettyTerm names' (assert_smaller res cod)
  parensIfM Outer $ sepSingle $ toList $ lines :< cod

prettyTerm names s@(Lam {}) =
  prettyLambda names s

prettyTerm names (Sig tfst tsnd _) = do
  let Val q = names.qtyLen
      MkSplitSig {binds, last} = splitSig [< (tsnd.name, tfst)] tsnd.term
  times <- timesD
  lines <- map (<++> times) <$> prettySigBinds names binds
  let names' = extendTermN' (map fst binds) names
  last <- withPrec InTimes $ prettyTerm names' (assert_smaller tsnd last)
  parensIfM Times $ sepSingle $ toList $ lines :< last

prettyTerm names p@(Pair s t _) = do
  let Val q = names.qtyLen
      elems = splitTuple [< s] t
  lines <- for elems $ \t =>
    withPrec Outer $ prettyTerm names $ assert_smaller p t
  parens $ separateTight !commaD lines

prettyTerm _ (Enum cases _) =
  prettyEnum $ SortedSet.toList cases

prettyTerm _ (Tag tag _) =
  prettyTag tag

prettyTerm names (Eq (S _ (N ty)) l r _) = do
  l  <- withPrec InEq $ prettyTerm names l
  r  <- withPrec InEq $ prettyTerm names r
  ty <- withPrec InEq $ prettyTerm names ty
  parensIfM Eq $ sep [l <++> !eqndD, r <++> !colonD, ty]

prettyTerm names (Eq ty l r _) = do
  ty <- prettyTypeLine names ty
  l  <- withPrec Arg $ prettyTerm names l
  r  <- withPrec Arg $ prettyTerm names r
  prettyAppD !eqD [ty, l, r]

prettyTerm names s@(DLam {}) =
  prettyLambda names s

prettyTerm _ (NAT _) = natD
prettyTerm _ (Nat n _) = hl Syntax $ pshow n
prettyTerm names (Succ p _) =
  prettyAppD !succD [!(withPrec Arg $ prettyTerm names p)]

prettyTerm _ (STRING _) = stringD
prettyTerm _ (Str s _) = prettyStrLit s

prettyTerm names (BOX qty ty _) =
  bracks . hcat =<<
  sequence [prettyQty names qty, dotD,
            withPrec Outer $ prettyTerm names ty]

prettyTerm names (Box val _) =
  bracks =<< withPrec Outer (prettyTerm names val)

prettyTerm names (Let qty rhs body _) = do
  let Evidence _ (lets, body) = splitLet [< (qty, body.name, rhs)] body.term
  heads <- prettyLets names lets
  let names' = extendTermN' (map (fst . snd) lets) names
  body <- withPrec Outer $ assert_total prettyTerm names' body
  let lines = toList $ heads :< body
  pure $ ifMultiline (hsep lines) (vsep lines)

prettyTerm names (E e) = do
  -- [fixme] do this stuff somewhere else!!!
  let Val q = names.qtyLen
  case pushSubsts' e {tm = Elim} of
    Ann tm _ _ => assert_total prettyTerm names tm
    _          => assert_total prettyElim names e

prettyTerm names t0@(CloT (Sub t ph)) = do
  let Val q = names.qtyLen
  prettyTerm names $ assert_smaller t0 $ pushSubstsWith' id id ph t

prettyTerm names t0@(DCloT (Sub t ph)) = do
  let Val q = names.qtyLen
  prettyTerm names $ assert_smaller t0 $ pushSubstsWith' id ph id t

prettyTerm names t0@(QCloT (SubR t ph)) = do
  let Val q = names.qtyLen
  prettyTerm names $ assert_smaller t0 $ pushSubstsWith' ph id id t

prettyElim names (F x u _) = do
  x <- prettyFree x
  u <- prettyDisp u
  pure $ maybe x (x <+>) u

prettyElim names (B i _) =
  prettyTBind $ names.tnames !!! i

prettyElim names e@(App {}) = do
  let Val q = names.qtyLen
      (f, xs) = splitApps e
  prettyDTApps names f xs

prettyElim names (CasePair qty pair ret body _) = do
  let [< x, y] = body.names
  pat <- parens $ !(prettyTBind x) <+> !commaD <++> !(prettyTBind y)
  prettyCase names qty pair ret
    [MkCaseArm pat [<] [< x, y] body.term]

prettyElim names (Fst pair _) = do
  pair <- prettyTArg names (E pair)
  prettyAppD !fstD [pair]

prettyElim names (Snd pair _) = do
  pair <- prettyTArg names (E pair)
  prettyAppD !sndD [pair]

prettyElim names (CaseEnum qty tag ret arms _) = do
  arms <- for (SortedMap.toList arms) $ \(tag, body) =>
    pure $ MkCaseArm !(prettyTag tag) [<] [<] body
  prettyCase names qty tag ret arms

prettyElim names (CaseNat qty qtyIH nat ret zero succ _) = do
  let zarm = MkCaseArm !zeroD [<] [<] zero
      [< p, ih] = succ.names
  spat0 <- [|succD <++> prettyTBind p|]
  ihpat0 <- map hcat $ sequence [prettyQty names qtyIH, dotD, prettyTBind ih]
  spat <- if ih.val == Unused
          then pure spat0
          else pure $ spat0 <+> !commaD <++> ihpat0
  let sarm = MkCaseArm spat [<] [< p, ih] succ.term
  prettyCase names qty nat ret [zarm, sarm]

prettyElim names (CaseBox qty box ret body _) = do
  pat <- bracks =<< prettyTBind body.name
  let arm = MkCaseArm pat [<] [< body.name] body.term
  prettyCase names qty box ret [arm]

prettyElim names e@(DApp {}) = do
  let Val q = names.qtyLen
      (f, xs) = splitApps e
  prettyDTApps names f xs

prettyElim names (Ann tm ty _) = do
  -- [fixme] do this stuff somewhere else!!!
  let Val q = names.qtyLen
  case pushSubsts' tm {tm = Term} of
    E e => assert_total prettyElim names e
    _   => do
      tm <- withPrec AnnL  $ assert_total prettyTerm names tm
      ty <- withPrec Outer $ assert_total prettyTerm names ty
      parensIfM Outer =<< hangDSingle (tm <++> !annD) ty

prettyElim names (Coe ty p p' val _) = do
  ty  <- prettyTypeLine names ty
  p   <- prettyDArg names p
  p'  <- prettyDArg names p'
  val <- prettyTArg names val
  prettyAppD !coeD [ty, p <++> p', val]

prettyElim names e@(Comp ty p p' val r zero one _) = do
  ty   <- assert_total $ prettyTypeLine names $ SN ty
  pp   <- [|prettyDArg names p <++> prettyDArg names p'|]
  val  <- prettyTArg names val
  r    <- prettyDArg names r
  arm0 <- [|prettyCompArm names Zero zero <+> semiD|]
  arm1 <- prettyCompArm names One one
  ind  <- askAt INDENT
  parensIfM App =<< layoutComp [ty, pp] val r [arm0, arm1]

prettyElim names (TypeCase ty ret arms def _) = do
  arms <- for (toList arms) $ \(k ** body) => do
    pat <- prettyTyCasePat k body.names
    pure $ MkCaseArm pat [<] (toTel body.names) body.term
  let darm = MkCaseArm !undD [<] [<] def
  prettyCase_ names !typecaseD ty (SN ret) $ arms ++ [darm]

prettyElim names e0@(CloE (Sub e ph)) = do
  let Val q = names.qtyLen
  prettyElim names $ assert_smaller e0 $ pushSubstsWith' id id ph e

prettyElim names e0@(DCloE (Sub e ph)) = do
  let Val q = names.qtyLen
  prettyElim names $ assert_smaller e0 $ pushSubstsWith' id ph id e

prettyElim names e0@(QCloE (SubR e ph)) = do
  let Val q = names.qtyLen
  prettyElim names $ assert_smaller e0 $ pushSubstsWith' ph id id e