quox/tests/Tests/PrettyTerm.idr

module Tests.PrettyTerm

import TAP
import Quox.Syntax
import PrettyExtra


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 (prettyTerm ds 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" 0) "x",
    testPrettyE  [<] [<] (^F "x" 1) "x¹" "x^1",
    testPrettyE1 [<] [<] (^F (MkName [< "A", "B", "C"] "x") 0) "A.B.C.x",
    testPrettyE  [<] [<] (^F (MkName [< "A", "B", "C"] "x") 2)
      "A.B.C.x²"
      "A.B.C.x^2"
  ],

  "bound vars" :- [
    testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (^BV 0) "y",
    testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (^BV 1) "x",
    testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"]
      (^DApp (^F "eq" 0) (^BV 1))
      "eq @𝑖",
    testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"]
      (^DApp (^DApp (^F "eq" 0) (^BV 1)) (^BV 0))
      "eq @𝑖 @𝑗"
  ],

  "applications" :- [
    testPrettyE1 [<] [<]
      (^App (^F "f" 0) (^FT "x" 0))
      "f x",
    testPrettyE1 [<] [<]
      (^App (^App (^F "f" 0) (^FT "x" 0)) (^FT "y" 0))
      "f x y",
    testPrettyE1 [<] [<]
      (^DApp (^F "f" 0) (^K Zero))
      "f @0",
    testPrettyE1 [<] [<]
      (^DApp (^App (^F "f" 0) (^FT "x" 0)) (^K Zero))
      "f x @0",
    testPrettyE1 [<] [<]
      (^App (^DApp (^F "g" 0) (^K One)) (^FT "y" 0))
      "g @1 y"
  ],

  "lambda" :- [
    testPrettyT [<] [<]
      (^LamY "x" (^BVT 0))
      "λ x ⇒ x"
      "fun x => x",
    testPrettyT [<] [<]
      (^LamN (^FT "a" 0))
      "λ _ ⇒ 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" 0)))
      "δ _ ⇒ a"
      "dfun _ => a",
    testPrettyT [<] [<]
      (^DLamY "i" (^FT "x" 0))
      "δ 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) "★" "Type",
    testPrettyT [<] [<] (^TYPE 100) "★¹⁰⁰" "Type^100"
  ],

  "function types" :- [
    testPrettyT [<] [<]
      (^Arr One (^FT "A" 0) (^FT "B" 0))
      "1.A → B"
      "1.A -> B",
    testPrettyT [<] [<]
      (^PiY One "x" (^FT "A" 0) (E $ ^App (^F "B" 0) (^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 : Type) -> #.A -> A",
    testPrettyT [<] [<]
      (^Arr Any (^Arr Any (^FT "A" 0) (^FT "A" 0)) (^FT "A" 0))
      "ω.(ω.A → A) → A"
      "#.(#.A -> A) -> A",
    testPrettyT [<] [<]
      (^Arr Any (^FT "A" 0) (^Arr Any (^FT "A" 0) (^FT "A" 0)))
      "ω.A → ω.A → A"
      "#.A -> #.A -> A",
    testPrettyT [<] [<]
      (^PiY Zero "P" (^Arr Zero (^FT "A" 0) (^TYPE 0))
        (E $ ^App (^BV 0) (^FT "a" 0)))
      "0.(P : 0.A → ★) → P a"
      "0.(P : 0.A -> Type) -> P a"
  ],

  "pair types" :- [
    testPrettyT [<] [<]
      (^And (^FT "A" 0) (^FT "B" 0))
      "A × B"
      "A ** B",
    testPrettyT [<] [<]
      (^SigY "x" (^FT "A" 0) (E $ ^App (^F "B" 0) (^BVT 0)))
      "(x : A) × B x"
      "(x : A) ** B x",
    testPrettyT [<] [<]
      (^SigY "x" (^FT "A" 0)
        (^SigY "y" (E $ ^App (^F "B" 0) (^BVT 0))
          (E $ ^App (^App (^F "C" 0) (^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" 0) (^FT "B" 0))
      "(A, B)",
    testPrettyT1 [<] [<]
      (^Pair (^FT "A" 0) (^Pair (^FT "B" 0) (^FT "C" 0)))
      "(A, B, C)",
    testPrettyT1 [<] [<]
      (^Pair (^Pair (^FT "A" 0) (^FT "B" 0)) (^FT "C" 0))
      "((A, B), C)",
    testPrettyT [<] [<]
      (^Pair (^LamY "x" (^BVT 0)) (^Arr One (^FT "B₁" 0) (^FT "B₂" 0)))
      "(λ 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" 0) (SN $ ^TYPE 1) (SN $ ^TYPE 0))
      "case1 a return ★¹ of { (_, _) ⇒ ★ }"
      "case1 a return Type^1 of { (_, _) => Type }",
    testPrettyT [<] [<]
      (^LamY "u" (E $
        ^CaseEnum One (^F "u" 0)
          (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 :: Type return Type of { _ => Nat }"
  ],

  skipWith "(todo: print user-written redundant annotations)" $
  "annotations" :- [
    testPrettyE [<] [<]
      (^Ann (^FT "a" 0) (^FT "A" 0))
      "a ∷ A"
      "a :: A",
    testPrettyE [<] [<]
      (^Ann (^FT "a" 0) (E $ ^Ann (^FT "A" 0) (^FT "𝐀" 0)))
      "a ∷ A ∷ 𝐀"
      "a :: A :: 𝐀",
    testPrettyE [<] [<]
      (^Ann (E $ ^Ann (^FT "α" 0) (^FT "a" 0)) (^FT "A" 0))
      "(α ∷ a) ∷ A"
      "(α :: a) :: A",
    testPrettyE [<] [<]
      (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A" 0) (^FT "A" 0)))
      "(λ x ⇒ x) ∷ 1.A → A"
      "(fun x => x) :: 1.A -> A",
    testPrettyE [<] [<]
      (^Ann (^Arr One (^FT "A" 0) (^FT "A" 0)) (^TYPE 7))
      "(1.A → A) ∷ ★⁷"
      "(1.A -> A) :: Type^7"
  ]
]