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

159 lines
5.4 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
2023-01-20 20:34:28 -05:00
private %inline
2023-01-26 13:54:46 -05:00
arrowD, timesD, darrowD, lamD, eqndD, dlamD, annD :
Pretty.HasEnv m => m (Doc HL)
arrowD = hlF Syntax $ ifUnicode "" "->"
timesD = hlF Syntax $ ifUnicode "×" "**"
darrowD = hlF Syntax $ ifUnicode "" "=>"
lamD = hlF Syntax $ ifUnicode "λ" "fun"
eqndD = hlF Syntax $ ifUnicode "" "=="
dlamD = hlF Syntax $ ifUnicode "λᴰ" "dfun"
annD = hlF Syntax $ ifUnicode "" "::"
2022-04-23 18:21:30 -04:00
2023-01-20 20:34:28 -05:00
private %inline
2023-01-26 13:54:46 -05:00
typeD, eqD, colonD, commaD, caseD, returnD, ofD : Doc HL
typeD = hl Syntax "Type"
eqD = hl Syntax "Eq"
colonD = hl Syntax ":"
commaD = hl Syntax ","
caseD = hl Syntax "case"
ofD = hl Syntax "of"
returnD = hl Syntax "return"
2022-04-23 18:21:30 -04:00
2022-04-23 18:21:30 -04:00
mutual
export covering
2023-01-08 14:44:25 -05:00
PrettyHL q => PrettyHL (Term q d n) where
2022-04-23 18:21:30 -04:00
prettyM (TYPE l) =
parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l)
2022-04-27 15:58:09 -04:00
prettyM (Pi qty x s t) =
2023-01-26 13:54:46 -05:00
prettyBindType [qty] x s !arrowD t
2022-04-23 18:21:30 -04:00
prettyM (Lam x t) =
2023-01-20 20:34:28 -05:00
let GotLams {names, body, _} = getLams' [x] t.term Refl in
prettyLams T (toList names) body
2023-01-26 13:54:46 -05:00
prettyM (Sig x s t) =
prettyBindType [] x s !timesD t
prettyM (Pair s t) =
let GotPairs {init, last, _} = getPairs t in
prettyTuple $ s :: init ++ [last]
2023-01-20 20:34:28 -05:00
prettyM (Eq _ (DUnused ty) l r) =
parensIfM Eq !(withPrec InEq $ pure $
sep [!(prettyM l) <++> !eqndD, !(prettyM r) <++> colonD, !(prettyM ty)])
prettyM (Eq i (DUsed ty) l r) =
parensIfM App $
eqD <++>
sep [bracks !(withPrec Outer $ pure $ hang 2 $
2023-01-26 13:54:46 -05:00
sep [hl DVar !(prettyM i) <++> !darrowD,
2023-01-20 20:34:28 -05:00
!(under D i $ prettyM ty)]),
!(withPrec Arg $ prettyM l),
!(withPrec Arg $ prettyM r)]
prettyM (DLam i t) =
let GotDLams {names, body, _} = getDLams' [i] t.term Refl in
prettyLams D (toList names) body
prettyM (E e) = bracks <$> prettyM e
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
2023-01-08 14:44:25 -05:00
PrettyHL q => PrettyHL (Elim q d n) where
2022-04-23 18:21:30 -04:00
prettyM (F x) =
hl' Free <$> prettyM x
prettyM (B i) =
prettyVar TVar TVarErr (!ask).tnames i
prettyM (e :@ s) =
2023-01-20 20:34:28 -05:00
let GotArgs {fun, args, _} = getArgs' e [s] in
prettyApps fun args
2023-01-26 13:54:46 -05:00
prettyM (CasePair pi p r ret x y body) = do
pat <- (parens . separate commaD . map (hl TVar)) <$>
traverse prettyM [x, y]
prettyCase pi p r ret [([x, y], pat, body)]
2023-01-20 20:34:28 -05:00
prettyM (e :% d) =
let GotDArgs {fun, args, _} = getDArgs' e [d] in
prettyApps fun args
2022-04-23 18:21:30 -04:00
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
2023-01-22 21:22:50 -05:00
{s : Nat} -> PrettyHL q => PrettyHL (ScopeTermN s q d n) where
2023-01-20 20:34:28 -05:00
prettyM body = prettyM body.term
2022-04-23 18:21:30 -04:00
export covering
2023-01-08 14:44:25 -05:00
prettyTSubst : Pretty.HasEnv m => PrettyHL q =>
TSubst q d from to -> m (Doc HL)
2022-04-23 18:21:30 -04:00
prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s
2023-01-26 13:54:46 -05:00
export covering
prettyBindType : Pretty.HasEnv m => PrettyHL q =>
List q -> Name -> Term q d n -> Doc HL ->
ScopeTerm q d n -> m (Doc HL)
prettyBindType qtys x s arr t =
parensIfM Outer $ hang 2 $
parens !(prettyQtyBinds qtys $ TV x) <++> arr
2023-01-26 13:54:46 -05:00
<//> !(under T x $ prettyM t)
2023-01-20 20:34:28 -05:00
export covering
prettyLams : Pretty.HasEnv m => PrettyHL q =>
BinderSort -> List Name -> Term q _ _ -> m (Doc HL)
prettyLams sort names body = do
lam <- case sort of T => lamD; D => dlamD
2023-01-26 13:54:46 -05:00
header <- sequence $ [hl TVar <$> prettyM x | x <- names] ++ [darrowD]
2023-01-20 20:34:28 -05:00
body <- unders sort names $ prettyM body
parensIfM Outer $ sep (lam :: header) <//> body
export covering
prettyApps : Pretty.HasEnv m => PrettyHL f => PrettyHL a =>
f -> List a -> m (Doc HL)
prettyApps fun args =
parensIfM App =<< withPrec Arg
[|prettyM fun <//> (align . sep <$> traverse prettyM args)|]
2023-01-26 13:54:46 -05:00
export covering
prettyTuple : Pretty.HasEnv m => PrettyHL a => List a -> m (Doc HL)
prettyTuple = map (parens . align . separate commaD) . traverse prettyM
export covering
prettyArm : Pretty.HasEnv m => PrettyHL a =>
(List Name, Doc HL, a) -> m (Doc HL)
prettyArm (xs, pat, body) =
pure $ hang 2 $ sep
[hsep [pat, !darrowD],
!(withPrec Outer $ unders T xs $ prettyM body)]
export covering
prettyArms : Pretty.HasEnv m => PrettyHL a =>
List (List Name, Doc HL, a) -> m (Doc HL)
prettyArms = map (braces . align . sep) . traverse prettyArm
export covering
prettyCase : Pretty.HasEnv m =>
PrettyHL q => PrettyHL a => PrettyHL b => PrettyHL c =>
q -> a -> Name -> b -> List (List Name, Doc HL, c) -> m (Doc HL)
prettyCase pi elim r ret arms =
pure $ align $ sep $
[hsep [caseD, !(prettyQtyBinds [pi] elim)],
2023-01-26 13:54:46 -05:00
hsep [returnD, !(prettyM r), !darrowD, !(under T r $ prettyM ret)],
hsep [ofD, !(prettyArms arms)]]