236 lines
6.9 KiB
Idris
236 lines
6.9 KiB
Idris
module Tests.PrettyTerm
|
||
|
||
import TAP
|
||
import Quox.Syntax
|
||
import PrettyExtra
|
||
|
||
|
||
parameters (ds : NContext d) (ns : NContext 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}
|
||
|
||
testPrettyT1 : Term d n -> (str : String) ->
|
||
{default str label : String} -> Test
|
||
testPrettyT1 t str {label} = testPrettyT t str str {label}
|
||
|
||
testPrettyE : Elim d n -> (uni, asc : String) ->
|
||
{default uni label : String} -> Test
|
||
testPrettyE e uni asc {label} = testPrettyT (E e) uni asc {label}
|
||
|
||
testPrettyE1 : Elim d n -> (str : String) ->
|
||
{default str label : String} -> Test
|
||
testPrettyE1 e str {label} = testPrettyT1 (E e) str {label}
|
||
|
||
|
||
prefix 9 ^
|
||
(^) : (Loc -> a) -> a
|
||
(^) a = a noLoc
|
||
|
||
FromString BindName where fromString str = BN (fromString str) noLoc
|
||
|
||
|
||
export
|
||
tests : Test
|
||
tests = "pretty printing terms" :- [
|
||
"free vars" :- [
|
||
testPrettyE1 [<] [<] (^F "x") "x",
|
||
testPrettyE1 [<] [<] (^F (MakeName [< "A", "B", "C"] "x")) "A.B.C.x"
|
||
],
|
||
|
||
"bound vars" :- [
|
||
testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (^BV 0) "y",
|
||
testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (^BV 1) "x",
|
||
testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"]
|
||
(^DApp (^F "eq") (^BV 1))
|
||
"eq @𝑖",
|
||
testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"]
|
||
(^DApp (^DApp (^F "eq") (^BV 1)) (^BV 0))
|
||
"eq @𝑖 @𝑗"
|
||
],
|
||
|
||
"applications" :- [
|
||
testPrettyE1 [<] [<]
|
||
(^App (^F "f") (^FT "x"))
|
||
"f x",
|
||
testPrettyE1 [<] [<]
|
||
(^App (^App (^F "f") (^FT "x")) (^FT "y"))
|
||
"f x y",
|
||
testPrettyE1 [<] [<]
|
||
(^DApp (^F "f") (^K Zero))
|
||
"f @0",
|
||
testPrettyE1 [<] [<]
|
||
(^DApp (^App (^F "f") (^FT "x")) (^K Zero))
|
||
"f x @0",
|
||
testPrettyE1 [<] [<]
|
||
(^App (^DApp (^F "g") (^K One)) (^FT "y"))
|
||
"g @1 y"
|
||
],
|
||
|
||
"lambda" :- [
|
||
testPrettyT [<] [<]
|
||
(^LamY "x" (^BVT 0))
|
||
"λ x ⇒ x"
|
||
"fun x => x",
|
||
testPrettyT [<] [<]
|
||
(^LamN (^FT "a"))
|
||
"λ _ ⇒ a"
|
||
"fun _ => a",
|
||
testPrettyT [<] [< "y"]
|
||
(^LamY "x" (^BVT 1))
|
||
"λ x ⇒ y"
|
||
"fun x => y",
|
||
testPrettyT [<] [<]
|
||
(^LamY "x" (^LamY "y" (^LamY "f"
|
||
(E $ ^App (^App (^BV 0) (^BVT 2)) (^BVT 1)))))
|
||
"λ x y f ⇒ f x y"
|
||
"fun x y f => f x y",
|
||
testPrettyT [<] [<]
|
||
(^DLam (SN (^FT "a")))
|
||
"δ _ ⇒ a"
|
||
"dfun _ => a",
|
||
testPrettyT [<] [<]
|
||
(^DLamY "i" (^FT "x"))
|
||
"δ i ⇒ x"
|
||
"dfun i => x",
|
||
testPrettyT [<] [<]
|
||
(^LamY "x" (^DLamY "i" (E $ ^DApp (^BV 0) (^BV 0))))
|
||
"λ x ⇒ δ i ⇒ x @i"
|
||
"fun x => dfun i => x @i"
|
||
],
|
||
|
||
"type universes" :- [
|
||
testPrettyT [<] [<] (^TYPE 0) "★₀" "Type0",
|
||
testPrettyT [<] [<] (^TYPE 100) "★₁₀₀" "Type100"
|
||
],
|
||
|
||
"function types" :- [
|
||
testPrettyT [<] [<]
|
||
(^Arr One (^FT "A") (^FT "B"))
|
||
"1.A → B"
|
||
"1.A -> B",
|
||
testPrettyT [<] [<]
|
||
(^PiY One "x" (^FT "A") (E $ ^App (^F "B") (^BVT 0)))
|
||
"1.(x : A) → B x"
|
||
"1.(x : A) -> B x",
|
||
testPrettyT [<] [<]
|
||
(^PiY Zero "A" (^TYPE 0) (^Arr Any (^BVT 0) (^BVT 0)))
|
||
"0.(A : ★₀) → ω.A → A"
|
||
"0.(A : Type0) -> #.A -> A",
|
||
testPrettyT [<] [<]
|
||
(^Arr Any (^Arr Any (^FT "A") (^FT "A")) (^FT "A"))
|
||
"ω.(ω.A → A) → A"
|
||
"#.(#.A -> A) -> A",
|
||
testPrettyT [<] [<]
|
||
(^Arr Any (^FT "A") (^Arr Any (^FT "A") (^FT "A")))
|
||
"ω.A → ω.A → A"
|
||
"#.A -> #.A -> A",
|
||
testPrettyT [<] [<]
|
||
(^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"
|
||
],
|
||
|
||
"pair types" :- [
|
||
testPrettyT [<] [<]
|
||
(^And (^FT "A") (^FT "B"))
|
||
"A × B"
|
||
"A ** B",
|
||
testPrettyT [<] [<]
|
||
(^SigY "x" (^FT "A") (E $ ^App (^F "B") (^BVT 0)))
|
||
"(x : A) × B x"
|
||
"(x : A) ** B x",
|
||
testPrettyT [<] [<]
|
||
(^SigY "x" (^FT "A")
|
||
(^SigY "y" (E $ ^App (^F "B") (^BVT 0))
|
||
(E $ ^App (^App (^F "C") (^BVT 1)) (^BVT 0))))
|
||
"(x : A) × (y : B x) × C x y"
|
||
"(x : A) ** (y : B x) ** C x y",
|
||
todo "non-dependent, left and right nested"
|
||
],
|
||
|
||
"pairs" :- [
|
||
testPrettyT1 [<] [<]
|
||
(^Pair (^FT "A") (^FT "B"))
|
||
"(A, B)",
|
||
testPrettyT1 [<] [<]
|
||
(^Pair (^FT "A") (^Pair (^FT "B") (^FT "C")))
|
||
"(A, B, C)",
|
||
testPrettyT1 [<] [<]
|
||
(^Pair (^Pair (^FT "A") (^FT "B")) (^FT "C"))
|
||
"((A, B), C)",
|
||
testPrettyT [<] [<]
|
||
(^Pair (^LamY "x" (^BVT 0)) (^Arr One (^FT "B₁") (^FT "B₂")))
|
||
"(λ x ⇒ x, 1.B₁ → B₂)"
|
||
"(fun x => x, 1.B₁ -> B₂)"
|
||
],
|
||
|
||
"enum types" :- [
|
||
testPrettyT1 [<] [<] (^enum []) "{}",
|
||
testPrettyT1 [<] [<] (^enum ["a"]) "{a}",
|
||
testPrettyT1 [<] [<] (^enum ["aa", "bb", "cc"]) "{aa, bb, cc}",
|
||
testPrettyT1 [<] [<] (^enum ["a b c"]) #"{"a b c"}"#,
|
||
testPrettyT1 [<] [<] (^enum ["\"", ",", "\\"]) #" {"\"", ",", \} "#
|
||
{label = #"{"\"", ",", \} # ｢\｣ is an identifier"#}
|
||
],
|
||
|
||
"tags" :- [
|
||
testPrettyT1 [<] [<] (^Tag "a") "'a",
|
||
testPrettyT1 [<] [<] (^Tag "hello") "'hello",
|
||
testPrettyT1 [<] [<] (^Tag "qualified.tag") "'qualified.tag",
|
||
testPrettyT1 [<] [<] (^Tag "non-identifier tag") #"'"non-identifier tag""#,
|
||
testPrettyT1 [<] [<] (^Tag #"""#) #" '"\"" "#
|
||
],
|
||
|
||
todo "equality types",
|
||
|
||
"case" :- [
|
||
testPrettyE [<] [<]
|
||
(^CasePair One (^F "a") (SN $ ^TYPE 1) (SN $ ^TYPE 0))
|
||
"case1 a return ★₁ of { (_, _) ⇒ ★₀ }"
|
||
"case1 a return Type1 of { (_, _) => Type0 }",
|
||
testPrettyT [<] [<]
|
||
(^LamY "u" (E $
|
||
^CaseEnum One (^F "u")
|
||
(SY [< "x"] $ ^Eq0 (^enum ["tt"]) (^BVT 0) (^Tag "tt"))
|
||
(fromList [("tt", ^DLamN (^Tag "tt"))])))
|
||
"λ u ⇒ case1 u return x ⇒ x ≡ 'tt : {tt} of { 'tt ⇒ δ _ ⇒ 'tt }"
|
||
"""
|
||
fun u =>
|
||
case1 u return x => x == 'tt : {tt} of { 'tt => dfun _ => 'tt }
|
||
"""
|
||
],
|
||
|
||
"type-case" :- [
|
||
testPrettyE [<] [<]
|
||
{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 }"
|
||
],
|
||
|
||
"annotations" :- [
|
||
testPrettyE [<] [<]
|
||
(^Ann (^FT "a") (^FT "A"))
|
||
"a ∷ A"
|
||
"a :: A",
|
||
testPrettyE [<] [<]
|
||
(^Ann (^FT "a") (E $ ^Ann (^FT "A") (^FT "𝐀")))
|
||
"a ∷ A ∷ 𝐀"
|
||
"a :: A :: 𝐀",
|
||
testPrettyE [<] [<]
|
||
(^Ann (E $ ^Ann (^FT "α") (^FT "a")) (^FT "A"))
|
||
"(α ∷ a) ∷ A"
|
||
"(α :: a) :: A",
|
||
testPrettyE [<] [<]
|
||
(^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A")))
|
||
"(λ x ⇒ x) ∷ 1.A → A"
|
||
"(fun x => x) :: 1.A -> A",
|
||
testPrettyE [<] [<]
|
||
(^Ann (^Arr One (^FT "A") (^FT "A")) (^TYPE 7))
|
||
"(1.A → A) ∷ ★₇"
|
||
"(1.A -> A) :: Type7"
|
||
]
|
||
]
|