rewrite pretty printer
This commit is contained in:
parent
f6abf084b3
commit
7b93a913c7
26 changed files with 1193 additions and 1360 deletions
|
|
@ -10,22 +10,36 @@ squash = pack . squash' . unpack . trim where
|
|||
squash' : List Char -> List Char
|
||||
squash' [] = []
|
||||
squash' (c :: cs) =
|
||||
if isSpace c then
|
||||
' ' :: squash' (dropWhile isSpace cs)
|
||||
else
|
||||
c :: squash' cs
|
||||
if isSpace c then ' ' :: squash' (dropWhile isSpace cs)
|
||||
else c :: squash' cs
|
||||
|
||||
public export
|
||||
Printer : Type -> Type
|
||||
Printer a = {opts : _} -> a -> Eff Pretty (Doc opts)
|
||||
|
||||
export
|
||||
renderSquash : Doc HL -> String
|
||||
renderSquash doc = squash $ renderShow (layoutCompact doc) ""
|
||||
renderSquash : ({opts : _} -> Doc opts) -> String
|
||||
renderSquash doc = squash $ render (Opts 10000) doc
|
||||
|
||||
export
|
||||
testPretty : PrettyHL a => (dnames, tnames : SnocList BaseName) ->
|
||||
a -> (uni, asc : String) ->
|
||||
prettySquash : Printer a -> Flavor -> a -> String
|
||||
prettySquash pr f x =
|
||||
renderSquash $ runPrettyWith Outer f noHighlight 0 (pr x)
|
||||
|
||||
export
|
||||
testPretty : Printer a -> a -> (uni, asc : String) ->
|
||||
{default uni label : String} -> Test
|
||||
testPretty dnames tnames t uni asc {label} = test {e = Info} label $ do
|
||||
testPretty pr t uni asc {label} = test {e = Info} label $ do
|
||||
let uni = squash uni; asc = squash asc
|
||||
uni' = renderSquash $ pretty0With True dnames tnames t
|
||||
asc' = renderSquash $ pretty0With False dnames tnames t
|
||||
uni' = prettySquash pr Unicode t
|
||||
asc' = prettySquash pr Ascii t
|
||||
unless (uni == uni') $ Left [("exp", uni), ("got", uni')]
|
||||
unless (asc == asc') $ Left [("exp", asc), ("got", asc')]
|
||||
|
||||
export
|
||||
runPrettyDef : Eff Pretty a -> a
|
||||
runPrettyDef = runPrettyWith Outer Unicode noHighlight 0
|
||||
|
||||
export
|
||||
prettyStr : ({opts : _} -> Eff Pretty (Doc opts)) -> String
|
||||
prettyStr doc = render (Opts 60) $ runPrettyDef doc
|
||||
|
|
|
|||
|
|
@ -16,62 +16,65 @@ import Data.So
|
|||
-- [todo] 'set' never breaks existing equalities
|
||||
|
||||
private
|
||||
prettyDimEq' : {default Arg prec : PPrec} -> NContext d -> DimEq d -> Doc HL
|
||||
prettyDimEq' [<] (C _) = "·"
|
||||
prettyDimEq' ds eqs =
|
||||
runPrettyWith False (toSnocList' ds) [<] $ withPrec prec $ prettyM eqs
|
||||
prettyDimEq_ : {opts : _} -> {default Arg prec : PPrec} ->
|
||||
BContext d -> DimEq d -> Eff Pretty (Doc opts)
|
||||
prettyDimEq_ [<] (C _) = pure "·"
|
||||
prettyDimEq_ ds eqs = prettyDimEq ds eqs
|
||||
|
||||
private
|
||||
testPrettyD : NContext d -> DimEq d -> (str : String) ->
|
||||
testPrettyD : BContext d -> DimEq d -> (str : String) ->
|
||||
{default str label : String} -> Test
|
||||
testPrettyD ds eqs str {label} =
|
||||
testPretty (toSnocList' ds) [<] eqs str str {label}
|
||||
testPretty (prettyDimEq ds) eqs str str {label}
|
||||
|
||||
private
|
||||
testWf : NContext d -> DimEq d -> Test
|
||||
testWf : BContext d -> DimEq d -> Test
|
||||
testWf ds eqs =
|
||||
test (renderSquash $ sep [prettyDimEq' {prec = Outer} ds eqs, "⊢", "✓"]) $
|
||||
test (prettySquash (prettyDimEq_ ds) Unicode eqs ++ "⊢ ✓") $
|
||||
unless (wf eqs) $ Left ()
|
||||
|
||||
private
|
||||
testNwf : NContext d -> DimEq d -> Test
|
||||
testNwf : BContext d -> DimEq d -> Test
|
||||
testNwf ds eqs =
|
||||
test (renderSquash $ sep [prettyDimEq' {prec = Outer} ds eqs, "⊬", "✓"]) $
|
||||
test (prettySquash (prettyDimEq_ ds) Unicode eqs ++ "⊢ ✗") $
|
||||
when (wf eqs) $ Left ()
|
||||
|
||||
|
||||
private
|
||||
testEqLabel : String -> (ds : NContext d) -> (exp, got : DimEq d) -> String
|
||||
testEqLabel op ds exp got = renderSquash $
|
||||
sep [prettyDimEq' ds exp, fromString op, prettyDimEq' ds got]
|
||||
testEqLabel : String -> (ds : BContext d) -> (exp, got : DimEq d) -> String
|
||||
testEqLabel op ds exp got =
|
||||
renderSquash $ runPrettyDef $ do
|
||||
pure $ sep [!(prettyDimEq_ ds exp), text op, !(prettyDimEq_ ds got)]
|
||||
|
||||
private
|
||||
testNeq : (ds : NContext d) -> (exp, got : DimEq d) ->
|
||||
testNeq : (ds : BContext d) -> (exp, got : DimEq d) ->
|
||||
{default (testEqLabel "≠" ds exp got) label : String} -> Test
|
||||
testNeq {label} ds exp got =
|
||||
test label $ unless (exp /= got) $ Left ()
|
||||
|
||||
private
|
||||
testEq : (ds : NContext d) -> (exp, got : DimEq d) ->
|
||||
testEq : (ds : BContext d) -> (exp, got : DimEq d) ->
|
||||
{default (testEqLabel "=" ds exp got) label : String} -> Test
|
||||
testEq {label} ds exp got =
|
||||
test label $ unless (exp == got) $
|
||||
Left [("exp", renderSquash $ prettyDimEq' ds exp),
|
||||
("got", renderSquash $ prettyDimEq' ds got)]
|
||||
Left [("exp", prettySquash (prettyDimEq_ ds) Unicode exp),
|
||||
("got", prettySquash (prettyDimEq_ ds) Unicode got)]
|
||||
|
||||
private
|
||||
testSetLabel : String -> NContext d -> DimEq d ->
|
||||
testSetLabel : String -> BContext d -> DimEq d ->
|
||||
DimEq d -> List (Dim d, Dim d) -> String
|
||||
testSetLabel op ds exp start sets = renderSquash $
|
||||
sep [parens $ sep $ intersperse "/" $
|
||||
prettyDimEq' {prec = Outer} ds start :: map prettySet sets,
|
||||
fromString op, prettyDimEq' ds exp]
|
||||
testSetLabel op ds exp start sets = renderSquash $ runPrettyDef $ do
|
||||
pure $ sep
|
||||
[parens $ sep $ intersperse "/" $
|
||||
!(prettyDimEq_ {prec = Outer} ds start) :: !(traverse prettySet sets),
|
||||
text op, !(prettyDimEq_ ds exp)]
|
||||
where
|
||||
prettySet : (Dim d, Dim d) -> Doc HL
|
||||
prettySet (p, q) = hsep [prettyDim ds p, "≔", prettyDim ds q]
|
||||
prettySet : {opts : _} -> (Dim d, Dim d) -> Eff Pretty (Doc opts)
|
||||
prettySet (p, q) = pure $
|
||||
hsep [!(prettyDim ds p), "≔", !(prettyDim ds q)]
|
||||
|
||||
private
|
||||
testSet : (ds : NContext d) -> (exp, start : DimEq d) ->
|
||||
testSet : (ds : BContext d) -> (exp, start : DimEq d) ->
|
||||
(sets : List (Dim d, Dim d)) ->
|
||||
(0 _ : (So (wf start), So (wf exp))) =>
|
||||
Test
|
||||
|
|
@ -80,7 +83,7 @@ testSet ds exp start sets =
|
|||
foldl (\eqs, (p, q) => set p q eqs) start sets
|
||||
|
||||
private
|
||||
ii, iijj, iijjkk, iijjkkll : NContext ?
|
||||
ii, iijj, iijjkk, iijjkkll : BContext ?
|
||||
ii = [< "𝑖"]
|
||||
iijj = [< "𝑖", "𝑗"]
|
||||
iijjkk = [< "𝑖", "𝑗", "𝑘"]
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ import Tests.Parser as TParser
|
|||
import Quox.EffExtra
|
||||
import TAP
|
||||
import AstExtra
|
||||
import PrettyExtra
|
||||
|
||||
import System.File
|
||||
import Derive.Prelude
|
||||
|
|
@ -29,7 +30,7 @@ ToInfo Failure where
|
|||
toInfo (ParseError err) = toInfo err
|
||||
toInfo (FromParser err) =
|
||||
[("type", "FromParserError"),
|
||||
("got", show $ prettyError True True err)]
|
||||
("got", prettyStr $ prettyError True err)]
|
||||
toInfo (WrongResult got) =
|
||||
[("type", "WrongResult"), ("got", got)]
|
||||
toInfo (ExpectedFail got) =
|
||||
|
|
|
|||
|
|
@ -5,11 +5,11 @@ import Quox.Syntax
|
|||
import PrettyExtra
|
||||
|
||||
|
||||
parameters (ds : NContext d) (ns : NContext n)
|
||||
parameters (ds : BContext d) (ns : BContext n)
|
||||
testPrettyT : Term d n -> (uni, asc : String) ->
|
||||
{default uni label : String} -> Test
|
||||
testPrettyT t uni asc {label} =
|
||||
testPretty (toSnocList' ds) (toSnocList' ns) t uni asc {label}
|
||||
testPretty (prettyTerm ds ns) t uni asc {label}
|
||||
|
||||
testPrettyT1 : Term d n -> (str : String) ->
|
||||
{default str label : String} -> Test
|
||||
|
|
@ -101,8 +101,8 @@ tests = "pretty printing terms" :- [
|
|||
],
|
||||
|
||||
"type universes" :- [
|
||||
testPrettyT [<] [<] (^TYPE 0) "★₀" "Type0",
|
||||
testPrettyT [<] [<] (^TYPE 100) "★₁₀₀" "Type100"
|
||||
testPrettyT [<] [<] (^TYPE 0) "★₀" "Type 0",
|
||||
testPrettyT [<] [<] (^TYPE 100) "★₁₀₀" "Type 100"
|
||||
],
|
||||
|
||||
"function types" :- [
|
||||
|
|
@ -117,7 +117,7 @@ tests = "pretty printing terms" :- [
|
|||
testPrettyT [<] [<]
|
||||
(^PiY Zero "A" (^TYPE 0) (^Arr Any (^BVT 0) (^BVT 0)))
|
||||
"0.(A : ★₀) → ω.A → A"
|
||||
"0.(A : Type0) -> #.A -> A",
|
||||
"0.(A : Type 0) -> #.A -> A",
|
||||
testPrettyT [<] [<]
|
||||
(^Arr Any (^Arr Any (^FT "A") (^FT "A")) (^FT "A"))
|
||||
"ω.(ω.A → A) → A"
|
||||
|
|
@ -130,7 +130,7 @@ tests = "pretty printing terms" :- [
|
|||
(^PiY Zero "P" (^Arr Zero (^FT "A") (^TYPE 0))
|
||||
(E $ ^App (^BV 0) (^FT "a")))
|
||||
"0.(P : 0.A → ★₀) → P a"
|
||||
"0.(P : 0.A -> Type0) -> P a"
|
||||
"0.(P : 0.A -> Type 0) -> P a"
|
||||
],
|
||||
|
||||
"pair types" :- [
|
||||
|
|
@ -190,7 +190,7 @@ tests = "pretty printing terms" :- [
|
|||
testPrettyE [<] [<]
|
||||
(^CasePair One (^F "a") (SN $ ^TYPE 1) (SN $ ^TYPE 0))
|
||||
"case1 a return ★₁ of { (_, _) ⇒ ★₀ }"
|
||||
"case1 a return Type1 of { (_, _) => Type0 }",
|
||||
"case1 a return Type 1 of { (_, _) => Type 0 }",
|
||||
testPrettyT [<] [<]
|
||||
(^LamY "u" (E $
|
||||
^CaseEnum One (^F "u")
|
||||
|
|
@ -208,7 +208,7 @@ tests = "pretty printing terms" :- [
|
|||
{label = "type-case ℕ ∷ ★₀ return ★₀ of { ⋯ }"}
|
||||
(^TypeCase (^Ann (^Nat) (^TYPE 0)) (^TYPE 0) empty (^Nat))
|
||||
"type-case ℕ ∷ ★₀ return ★₀ of { _ ⇒ ℕ }"
|
||||
"type-case Nat :: Type0 return Type0 of { _ => Nat }"
|
||||
"type-case Nat :: Type 0 return Type 0 of { _ => Nat }"
|
||||
],
|
||||
|
||||
"annotations" :- [
|
||||
|
|
@ -231,6 +231,6 @@ tests = "pretty printing terms" :- [
|
|||
testPrettyE [<] [<]
|
||||
(^Ann (^Arr One (^FT "A") (^FT "A")) (^TYPE 7))
|
||||
"(1.A → A) ∷ ★₇"
|
||||
"(1.A -> A) :: Type7"
|
||||
"(1.A -> A) :: Type 7"
|
||||
]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ import public TypingImpls
|
|||
import TAP
|
||||
import Quox.EffExtra
|
||||
import AstExtra
|
||||
import PrettyExtra
|
||||
|
||||
|
||||
%hide Prelude.App
|
||||
|
|
@ -14,20 +15,20 @@ import AstExtra
|
|||
|
||||
data Error'
|
||||
= TCError Typing.Error
|
||||
| WrongInfer (Term d n) (Term d n)
|
||||
| WrongInfer (BContext d) (BContext n) (Term d n) (Term d n)
|
||||
| WrongQOut (QOutput n) (QOutput n)
|
||||
|
||||
export
|
||||
ToInfo Error' where
|
||||
toInfo (TCError e) = toInfo e
|
||||
toInfo (WrongInfer good bad) =
|
||||
toInfo (WrongInfer dnames tnames good bad) =
|
||||
[("type", "WrongInfer"),
|
||||
("wanted", prettyStr True good),
|
||||
("got", prettyStr True bad)]
|
||||
("wanted", prettyStr $ prettyTerm dnames tnames good),
|
||||
("got", prettyStr $ prettyTerm dnames tnames bad)]
|
||||
toInfo (WrongQOut good bad) =
|
||||
[("type", "WrongQOut"),
|
||||
("wanted", prettyStr True good),
|
||||
("wanted", prettyStr True bad)]
|
||||
("wanted", show good),
|
||||
("wanted", show bad)]
|
||||
|
||||
0 M : Type -> Type
|
||||
M = Eff [Except Error', DefsReader]
|
||||
|
|
@ -116,7 +117,7 @@ parameters (label : String) (act : Lazy (M ()))
|
|||
|
||||
inferredTypeEq : TyContext d n -> (exp, got : Term d n) -> M ()
|
||||
inferredTypeEq ctx exp got =
|
||||
wrapErr (const $ WrongInfer exp got) $ inj $ lift $
|
||||
wrapErr (const $ WrongInfer ctx.dnames ctx.tnames exp got) $ inj $ lift $
|
||||
equalType noLoc ctx exp got
|
||||
|
||||
qoutEq : (exp, got : QOutput n) -> M ()
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ module TypingImpls
|
|||
import TAP
|
||||
import public Quox.Typing
|
||||
import public Quox.Pretty
|
||||
import PrettyExtra
|
||||
|
||||
import Derive.Prelude
|
||||
%language ElabReflection
|
||||
|
|
@ -14,4 +15,7 @@ import Derive.Prelude
|
|||
%runElab derive "Error" [Show]
|
||||
|
||||
export
|
||||
ToInfo Error where toInfo err = [("err", show $ prettyError True True err)]
|
||||
ToInfo Error where
|
||||
toInfo err =
|
||||
let str = render (Opts 60) $ runPrettyDef $ prettyError True err in
|
||||
[("err", str)]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue