2022-04-23 18:21:30 -04:00
|
|
|
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
|
|
|
|
|
|
2022-05-02 16:38:37 -04:00
|
|
|
%default total
|
2022-04-23 18:21:30 -04:00
|
|
|
|
|
|
|
|
|
|
|
|
|
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)
|
2022-04-27 15:58:09 -04:00
|
|
|
prettyM (Pi qty x s t) =
|
2022-04-23 18:21:30 -04:00
|
|
|
parensIfM Outer $ hang 2 $
|
2022-04-27 15:58:09 -04:00
|
|
|
!(prettyBinder [qty] x s) <++> !arrowD
|
2022-04-23 18:21:30 -04:00
|
|
|
<//> !(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) =
|
2022-08-22 04:08:18 -04:00
|
|
|
pure $ hl Delim "[" <+> !(prettyM e) <+> hl Delim "]"
|
2022-04-23 18:21:30 -04:00
|
|
|
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)]]]
|
