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

module Quox.Syntax.Term.Pretty

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

import Data.Vect

%default total


export %inline
typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD :
  Pretty.HasEnv m => m (Doc HL)
typeD   = hlF Syntax $ ifUnicode "★" "Type"
arrowD  = hlF Delim  $ ifUnicode "→" "->"
darrowD = hlF Delim  $ ifUnicode "⇒" "=>"
timesD  = hlF Delim  $ ifUnicode "×" "**"
lamD    = hlF Syntax $ ifUnicode "λ" "fun"
eqndD   = hlF Delim  $ ifUnicode "≡" "=="
dlamD   = hlF Syntax $ ifUnicode "δ" "dfun"
annD    = hlF Delim  $ ifUnicode "∷" "::"
natD    = hlF Syntax $ ifUnicode "ℕ" "Nat"

export %inline
eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
ofD, dotD, zeroD, succD, coeD, compD : Doc HL
eqD       = hl Syntax "Eq"
colonD    = hl Delim  ":"
commaD    = hl Delim  ","
semiD     = hl Delim  ";"
caseD     = hl Syntax "case"
typecaseD = hl Syntax "type-case"
ofD       = hl Syntax "of"
returnD   = hl Syntax "return"
dotD      = hl Delim "."
zeroD     = hl Syntax "zero"
succD     = hl Syntax "succ"
coeD      = hl Syntax "coe"
compD     = hl Syntax "compD"


export
prettyUnivSuffix : Pretty.HasEnv m => Universe -> m (Doc HL)
prettyUnivSuffix l =
  ifUnicode (pretty $ pack $ map sub $ unpack $ show l) (pretty l)
 where
  sub : Char -> Char
  sub c = case c of
    '0' => '₀'; '1' => '₁'; '2' => '₂'; '3' => '₃'; '4' => '₄'
    '5' => '₅'; '6' => '₆'; '7' => '₇'; '8' => '₈'; '9' => '₉'; _ => c

export
prettyUniverse : Universe -> Doc HL
prettyUniverse = hl Syntax . pretty


public export
data WithQty a = MkWithQty Qty a

export
PrettyHL a => PrettyHL (WithQty a) where
  prettyM (MkWithQty q x) = do
    q <- pretty0M q
    x <- withPrec Arg $ prettyM x
    pure $ hcat [q, dotD, x]


public export
data Binder a = MkBinder BaseName a

export
PrettyHL a => PrettyHL (Binder a) where
  prettyM (MkBinder x ty) = do
    x  <- pretty0M $ TV x
    ty <- align <$> pretty0M ty
    pure $ parens $ sep [hsep [x, colonD], ty]


export
prettyBindType : PrettyHL a => PrettyHL b =>
                 Pretty.HasEnv m =>
                 Maybe Qty -> BindName -> a -> Doc HL -> b -> m (Doc HL)
prettyBindType q (BN x _) s arr t = do
  bind <- case q of
    Nothing => pretty0M $ MkBinder x s
    Just q  => pretty0M $ MkWithQty q $ MkBinder x s
  t <- withPrec AnnR $ under T x $ prettyM t
  parensIfM AnnR $ hang 2 $ bind <++> arr <%%> t

export
prettyArm : PrettyHL a => Pretty.HasEnv m =>
            BinderSort -> SnocList BindName -> Doc HL -> a -> m (Doc HL)
prettyArm sort xs pat body = do
  let xs = map name xs
  body <- withPrec Outer $ unders sort xs $ prettyM body
  pure $ hang 2 $ sep [pat <++> !darrowD, body]

export
prettyLams : PrettyHL a => Pretty.HasEnv m =>
             Maybe (Doc HL) -> BinderSort -> SnocList BindName -> a ->
             m (Doc HL)
prettyLams lam sort names body = do
  let var = case sort of T => TVar; D => DVar
  header <- sequence $ [hlF var $ prettyM x | x <- toList names]
  let header = sep $ maybe header (:: header) lam
  parensIfM Outer =<< prettyArm sort names header body


public export
data TypeLine a = MkTypeLine BindName a

export
PrettyHL a => PrettyHL (TypeLine a) where
  prettyM (MkTypeLine i ty) =
    if i.name == Unused then
      bracks <$> pretty0M ty
    else
      map bracks $ withPrec Outer $ prettyLams Nothing D [< i] ty


export
prettyApps' : PrettyHL f => PrettyHL a => Pretty.HasEnv m =>
              f -> List (Maybe (Doc HL), a) -> m (Doc HL)
prettyApps' fun args = do
  fun  <- withPrec App $ prettyM fun
  args <- traverse prettyArg args
  parensIfM App $ hang 2 $ sep $ fun :: args
 where
  prettyArg : (Maybe (Doc HL), a) -> m (Doc HL)
  prettyArg (Nothing,  arg) = withPrec Arg (prettyM arg)
  prettyArg (Just pfx, arg) = (hl Delim pfx <+>) <$> withPrec Arg (prettyM arg)

export
prettyApps : PrettyHL f => PrettyHL a => Pretty.HasEnv m =>
             Maybe (Doc HL) -> f -> List a -> m (Doc HL)
prettyApps pfx f args = prettyApps' f (map (pfx,) args)

export
prettyTuple : PrettyHL a => Pretty.HasEnv m => List a -> m (Doc HL)
prettyTuple = map (parens . align . separate commaD) . traverse prettyM

export
prettyArms : PrettyHL a => Pretty.HasEnv m =>
             BinderSort -> List (SnocList BindName, Doc HL, a) -> m (Doc HL)
prettyArms s =
  map (braces . aseparate semiD) .
  traverse (\(xs, l, r) => prettyArm s xs l r)

export
prettyCase' : (PrettyHL a, PrettyHL b, PrettyHL c, Pretty.HasEnv m) =>
              Doc HL -> a -> BindName -> b ->
              List (SnocList BindName, Doc HL, c) ->
              m (Doc HL)
prettyCase' intro elim r ret arms = do
  elim  <- pretty0M elim
  ret   <- case r.name of
    Unused => under T r.name $ pretty0M ret
    _      => prettyLams Nothing T [< r] ret
  arms  <- prettyArms T arms
  pure $ asep [intro <++> elim, returnD <++> ret, ofD <++> arms]

export
prettyCase : (PrettyHL a, PrettyHL b, PrettyHL c, Pretty.HasEnv m) =>
             Qty -> a -> BindName -> b ->
             List (SnocList BindName, Doc HL, c) ->
             m (Doc HL)
prettyCase pi elim r ret arms = do
  caseq <- (caseD <+>) <$> prettySuffix pi
  prettyCase' caseq elim r ret arms

export
escapeString : String -> String
escapeString = concatMap esc1 . unpack where
  esc1 : Char -> String
  esc1 '"'  = #"\""#
  esc1 '\\' = #"\\"#
  esc1 '\n' = #"\n"#
  esc1 c    = singleton c

export
quoteTag : TagVal -> Doc HL
quoteTag tag =
  if isName tag then fromString tag else
  hcat ["\"", fromString $ escapeString tag, "\""]

export
prettyTag : TagVal -> Doc HL
prettyTag t = hl Tag $ "'" <+> quoteTag t

export
prettyTagBare : TagVal -> Doc HL
prettyTagBare t = hl Tag $ quoteTag t

export
prettyBoxVal : PrettyHL a => Pretty.HasEnv m => a -> m (Doc HL)
prettyBoxVal val = bracks <$> pretty0M val

export
prettyCompPat : Pretty.HasEnv m => DimConst -> BindName -> m (Doc HL)
prettyCompPat e j = hsep <$> sequence [pretty0M e, pretty0M $ DV j.name]

export
toNatLit : Term d n -> Maybe Nat
toNatLit (Zero _)   = Just 0
toNatLit (Succ n _) = [|S $ toNatLit n|]
toNatLit _          = Nothing

private
eterm : Term d n -> Exists (Term d)
eterm = Evidence n


parameters (showSubsts : Bool)
 mutual
  export covering
  [TermSubst] PrettyHL (Term d n) using ElimSubst
  where
    prettyM (TYPE l _) =
      pure $ !typeD <+> hl Syntax !(prettyUnivSuffix l)

    prettyM (Pi qty s (S _ (N t)) _) = do
      dom <- pretty0M $ MkWithQty qty s
      cod <- withPrec AnnR $ prettyM t
      parensIfM AnnR $ asep [dom <++> !arrowD, cod]

    prettyM (Pi qty s (S [< x] (Y t)) _) =
      prettyBindType (Just qty) x s !arrowD t

    prettyM (Lam (S x t) _) =
      let GotLams {names, body, _} = getLams' x t.term Refl in
      prettyLams (Just !lamD) T (toSnocList' names) body

    prettyM (Sig s (S _ (N t)) _) = do
      s <- withPrec InTimes $ prettyM s
      t <- withPrec Times   $ prettyM t
      parensIfM Times $ asep [s <++> !timesD, t]

    prettyM (Sig s (S [< x] (Y t)) _) =
      prettyBindType Nothing x s !timesD t

    prettyM (Pair s t _) =
      let GotPairs {init, last, _} = getPairs' [< s] t in
      prettyTuple $ toList $ init :< last

    prettyM (Enum tags _) =
      pure $ delims "{" "}" . aseparate comma $ map prettyTagBare $
        Prelude.toList tags

    prettyM (Tag t _) =
      pure $ prettyTag t

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

    prettyM (Eq (S [< i] (Y ty)) l r _) = do
      prettyApps Nothing (L eqD)
        [epretty $ MkTypeLine i ty, epretty l, epretty r]

    prettyM (DLam (S i t) _) =
      let GotDLams {names, body, _} = getDLams' i t.term Refl in
      prettyLams (Just !dlamD) D (toSnocList' names) body

    prettyM (Nat _) = natD

    prettyM (Zero _) = pure $ hl Syntax "0"

    prettyM (Succ n _) =
      case toNatLit n of
        Just n  => pure $ hl Syntax $ pretty $ S n
        Nothing => prettyApps Nothing (L succD) [n]

    prettyM (BOX pi ty _) = do
      pi <- pretty0M pi
      ty <- pretty0M ty
      pure $ bracks $ hcat [pi, dotD, align ty]

    prettyM (Box val _) = prettyBoxVal val

    prettyM (E e) = prettyM e

    prettyM (CloT (Sub s th)) =
      if showSubsts then
        parensIfM SApp . hang 2 =<<
          [|withPrec SApp (prettyM s) <%> prettyTSubst th|]
      else
        prettyM $ pushSubstsWith' id th s

    prettyM (DCloT (Sub s th)) =
      if showSubsts then
        parensIfM SApp . hang 2 =<<
          [|withPrec SApp (prettyM s) <%> prettyDSubst th|]
      else
        prettyM $ pushSubstsWith' th id s

  export covering
  [ElimSubst] PrettyHL (Elim d n) using TermSubst
  where
    prettyM (F x _) =
      hl' Free <$> prettyM x

    prettyM (B i _) =
      prettyVar TVar TVarErr (!ask).tnames i

    prettyM (App e s _) =
      let GotArgs {fun, args, _} = getArgs' e [s] in
      prettyApps Nothing fun args

    prettyM (CasePair pi p (S [< r] ret) (S [< x, y] body) _) = do
      pat <- parens . separate commaD <$> traverse (hlF TVar . prettyM) [x, y]
      prettyCase pi p r ret.term [([< x, y], pat, body.term)]

    prettyM (CaseEnum pi t (S [< r] ret) arms _) =
      prettyCase pi t r ret.term
        [([<], prettyTag t, b) | (t, b) <- SortedMap.toList arms]

    prettyM (CaseNat pi pi' nat (S [< r] ret) zer (S [< s, ih] suc) _) =
      prettyCase pi nat r ret.term
        [([<],       zeroD,    eterm zer),
         ([< s, ih], !succPat, eterm suc.term)]
    where
      succPat : m (Doc HL)
      succPat = case (ih, pi') of
        (BN Unused _, Zero) => pure $ succD <++> !(pretty0M s)
        _ => pure $ asep [succD <++> !(pretty0M s) <+> comma,
                          !(pretty0M $ MkWithQty pi' ih)]

    prettyM (CaseBox pi box (S [< r] ret) (S [< u] body) _) =
      prettyCase pi box r ret.term
        [([< u], !(prettyBoxVal $ TV u.name), body.term)]

    prettyM (DApp e d _) =
      let GotDArgs {fun, args, _} = getDArgs' e [d] in
      prettyApps (Just "@") fun args

    prettyM (Ann s a _) = do
      s <- withPrec AnnL $ prettyM s
      a <- withPrec AnnR $ prettyM a
      parensIfM AnnR $ hang 2 $ s <++> !annD <%%> a

    prettyM (Coe (S [< i] ty) p q val _) =
      let ty = case ty of
            Y ty => epretty $ MkTypeLine i ty
            N ty => epretty ty
      in
      prettyApps' (L coeD)
        [(Nothing,  ty),
         (Just "@", epretty p),
         (Just "@", epretty q),
         (Nothing,  epretty val)]

    prettyM (Comp ty p q val r (S [< z] zero) (S [< o] one) _) = do
      apps <- prettyApps' (L compD)
        [(Nothing,  epretty $ MkTypeLine (BN Unused noLoc) ty),
         (Just "@", epretty p),
         (Just "@", epretty q),
         (Nothing,  epretty val),
         (Just "@", epretty r)]
      arms <- prettyArms D
        [([< z], !(prettyCompPat Zero z), zero.term),
         ([< o], !(prettyCompPat One  o), one.term)]
      pure $ apps <++> arms

    prettyM (TypeCase ty ret arms def _) = do
      arms <- traverse fromArm (toList arms)
      prettyCase' typecaseD ty (BN Unused noLoc) ret $
        arms ++ [([<], hl Syntax "_", eterm def)]
    where
      v : BindName -> Doc HL
      v = pretty0 True . TV . name

      tyCasePat : (k : TyConKind) -> BContext (arity k) -> m (Doc HL)
      tyCasePat KTYPE [<] = typeD
      tyCasePat KPi   [< a, b] = pure $ parens $ hsep [v a, !arrowD, v b]
      tyCasePat KSig  [< a, b] = pure $ parens $ hsep [v a, !arrowD, v b]
      tyCasePat KEnum [<]   = pure $ hl Syntax "{}"
      tyCasePat KNat  [<]   = natD
      tyCasePat KBOX  [< a] = pure $ bracks $ v a
      tyCasePat KEq   vars  =
        prettyApps Nothing (L eqD) $ map (TV . name) $ toList' vars

      fromArm : TypeCaseArm d n ->
                m (SnocList BindName, Doc HL, Exists (Term d))
      fromArm (k ** S ns t) =
        pure (toSnocList' ns, !(tyCasePat k ns), eterm t.term)

    prettyM (CloE (Sub e th)) =
      if showSubsts then
        parensIfM SApp . hang 2 =<<
          [|withPrec SApp (prettyM e) <%> prettyTSubst th|]
      else
        prettyM $ pushSubstsWith' id th e

    prettyM (DCloE (Sub e th)) =
      if showSubsts then
        parensIfM SApp . hang 2 =<<
          [|withPrec SApp (prettyM e) <%> prettyDSubst th|]
      else
        prettyM $ pushSubstsWith' th id e

  export covering
  prettyTSubst : Pretty.HasEnv m => TSubst d from to -> m (Doc HL)
  prettyTSubst s =
    prettySubstM (prettyM @{ElimSubst}) (!ask).tnames TVar "[" "]" s

export covering %inline
PrettyHL (Term d n) where prettyM = prettyM @{TermSubst False}

export covering %inline
PrettyHL (Elim d n) where prettyM = prettyM @{ElimSubst False}


export covering
prettyTerm : (unicode : Bool) ->
             (dnames : BContext d) -> (tnames : BContext n) ->
             Term d n -> Doc HL
prettyTerm unicode dnames tnames term =
  pretty0With unicode (toNames dnames) (toNames tnames) term