module Quox.Syntax.Term.Pretty

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

import Data.Vect

%default total


parameters {auto _ : Pretty.HasEnv m}
  private %inline arrowD : m (Doc HL)
  arrowD = hlF Syntax $ ifUnicode "→" "->"

  private %inline lamD : m (Doc HL)
  lamD = hlF Syntax $ ifUnicode "λ" "fun"

  private %inline annD : m (Doc HL)
  annD = hlF Syntax $ ifUnicode "⦂" "::"

private %inline typeD : Doc HL
typeD = hl Syntax "Type"

private %inline colonD : Doc HL
colonD = hl Syntax ":"

mutual
  export covering
  PrettyHL (Term d n) where
    prettyM (TYPE l) =
      parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l)
    prettyM (Pi qty x s t) =
      parensIfM Outer $ hang 2 $
        !(prettyBinder [qty] x s) <++> !arrowD
          <//> !(under T x $ prettyM t)
    prettyM (Lam x t) =
      parensIfM Outer $
        sep [!lamD, hl TVar !(prettyM x), !arrowD]
          <//> !(under T x $ prettyM t)
    prettyM (E e) =
      pure $ hl Delim "[" <+> !(prettyM e) <+> hl Delim "]"
    prettyM (CloT s th) =
      parensIfM SApp . hang 2 =<<
        [|withPrec SApp (prettyM s) </> prettyTSubst th|]
    prettyM (DCloT s th) =
      parensIfM SApp . hang 2 =<<
        [|withPrec SApp (prettyM s) </> prettyDSubst th|]

  export covering
  PrettyHL (Elim d n) where
    prettyM (F x) =
      hl' Free <$> prettyM x
    prettyM (B i) =
      prettyVar TVar TVarErr (!ask).tnames i
    prettyM (e :@ s) =
      let GotArgs f args _ = getArgs' e [s] in
      parensIfM App =<< withPrec Arg
        [|prettyM f <//> (align . sep <$> traverse prettyM args)|]
    prettyM (s :# a) =
      parensIfM Ann $ hang 2 $
        !(withPrec AnnL $ prettyM s) <++> !annD
          <//> !(withPrec Ann $ prettyM a)
    prettyM (CloE e th)  =
      parensIfM SApp . hang 2 =<<
        [|withPrec SApp (prettyM e) </> prettyTSubst th|]
    prettyM (DCloE e th) =
      parensIfM SApp . hang 2 =<<
        [|withPrec SApp (prettyM e) </> prettyDSubst th|]

  export covering
  PrettyHL (ScopeTerm d n) where
    prettyM body = prettyM $ fromScopeTerm body

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

  export covering
  prettyBinder : Pretty.HasEnv m => List Qty -> Name -> Term d n -> m (Doc HL)
  prettyBinder pis x a =
    pure $ parens $ hang 2 $
      hsep [hl TVar !(prettyM x),
            sep [!(prettyQtyBinds pis),
                 hsep [colonD, !(withPrec Outer $ prettyM a)]]]