rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

pretty printing fixes

Browse source
This commit is contained in:
rhiannon morris 2023-12-21 18:03:57 +01:00
parent 48a050491c
commit b7074720ad
5 changed files with 71 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

40
lib/Quox/Untyped/Syntax.idr
View file

@ -105,25 +105,17 @@ prettyArg : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts)
prettyArg xs arg = withPrec Arg $ prettyTerm xs arg
export covering
prettyAppHead : {opts : LayoutOpts} -> BContext n ->
Term n -> Eff Pretty (Doc opts)
prettyAppHead xs fun = withPrec App $ prettyTerm xs fun
prettyApp_ : {opts : LayoutOpts} -> BContext n ->
Doc opts -> SnocList (Term n) -> Eff Pretty (Doc opts)
prettyApp_ xs fun args =
parensIfM App =<<
prettyAppD fun (toList !(traverse (prettyArg xs) args))
export
prettyApp' : {opts : LayoutOpts} ->
Doc opts -> SnocList (Doc opts) -> Eff Pretty (Doc opts)
prettyApp' fun args = do
d <- askAt INDENT
let args = toList args
parensIfM App $
hsep (fun :: args)
<|> hsep [fun, vsep args]
<|> vsep (fun :: map (indent d) args)
export covering
export covering %inline
prettyApp : {opts : LayoutOpts} -> BContext n ->
Doc opts -> SnocList (Term n) -> Eff Pretty (Doc opts)
prettyApp xs fun args = prettyApp' fun =<< traverse (prettyArg xs) args
Term n -> SnocList (Term n) -> Eff Pretty (Doc opts)
prettyApp xs fun args =
prettyApp_ xs !(prettyArg xs fun) args
public export
record PrettyCaseArm a n where
@ -208,21 +200,21 @@ prettyTerm xs (Lam x body _) =
vars <- hsep . toList' <$> traverse prettyTBind ys
body <- withPrec Outer $ prettyTerm (xs . ys) body
hangDSingle (hsep [!lamD, vars, !darrowD]) body
prettyTerm xs (App fun arg _) =
let (fun, args) = splitApp fun in
prettyApp xs !(prettyAppHead xs fun) (args :< arg)
prettyTerm xs (App fun arg _) = do
let (fun, args) = splitApp fun
prettyApp xs fun (args :< arg)
prettyTerm xs (Pair fst snd _) =
parens . separateTight !commaD =<<
traverse (withPrec Outer . prettyTerm xs) (fst :: splitPair snd)
prettyTerm xs (Fst pair _) = prettyApp xs !fstD [< pair]
prettyTerm xs (Snd pair _) = prettyApp xs !sndD [< pair]
prettyTerm xs (Fst pair _) = prettyApp_ xs !fstD [< pair]
prettyTerm xs (Snd pair _) = prettyApp_ xs !sndD [< pair]
prettyTerm xs (Tag tag _) = prettyTag tag
prettyTerm xs (CaseEnum tag cases _) =
prettyCase xs prettyTag tag $
map (\(t, rhs) => MkPrettyCaseArm t [] rhs) $ toList cases
prettyTerm xs (Absurd _) = hl Syntax "absurd"
prettyTerm xs (Nat n _) = hl Constant $ pshow n
prettyTerm xs (Succ nat _) = prettyApp xs !succD [< nat]
prettyTerm xs (Succ nat _) = prettyApp_ xs !succD [< nat]
prettyTerm xs (CaseNat nat zer suc _) =
prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)]
prettyTerm xs (Str s _) =
@ -235,7 +227,7 @@ prettyTerm xs (Let x rhs body _) =
let lines = toList $ heads :< body
pure $ ifMultiline (hsep lines) (vsep lines)
prettyTerm _ (Erased _) =
hl Syntax =<< ifUnicode "⌷" "[]"
hl Syntax =<< ifUnicode "□" "[]"
export covering
prettyDef : {opts : LayoutOpts} -> Name ->