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

87 lines
2.5 KiB
Idris
Raw Normal View History

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) =
prettyM e
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)]]]