clean up subsing η stuff

closes #38, again

.gitignore

@@ -5,3 +5,5 @@ result
 *~
 quox
 quox-tests
+golden-tests/tests/*/output
+golden-tests/tests/*/*.ss

CREDITS.md

@@ -0,0 +1,4 @@
+the "logo" is an edit of [an emoji] made by [khr].
+
+[an emoji]: https://github.com/chr-1x/dragn-emoji
+[khr]: https://dragon.monster

examples/all.quox

@@ -1,6 +1,10 @@
 load "misc.quox"
 load "bool.quox"
 load "either.quox"
+load "maybe.quox"
 load "nat.quox"
 load "pair.quox"
 load "list.quox"
+load "eta.quox"
+load "fail.quox"
+load "qty.quox"

examples/bool.quox

@@ -4,24 +4,35 @@ namespace bool {
 
 def0 Bool : ★ = {true, false};
 
-def boolω : 1.Bool → [ω.Bool] =
-  λ b ⇒ case1 b return [ω.Bool] of { 'true ⇒ ['true]; 'false ⇒ ['false] };
+def if-dep : 0.(P : Bool → ★) → (b : Bool) → ω.(P 'true) → ω.(P 'false) → P b =
+  λ P b t f ⇒ case b return b' ⇒ P b' of { 'true ⇒ t; 'false ⇒ f };
 
-def if : 0.(A : ★) → 1.Bool → ω.A → ω.A → A =
-  λ A b t f ⇒ case1 b return A of { 'true ⇒ t; 'false ⇒ f };
+def if : 0.(A : ★) → (b : Bool) → ω.A → ω.A → A =
+  λ A ⇒ if-dep (λ _ ⇒ A);
 
-def0 If : 1.Bool → 0.★ → 0.★ → ★ =
-  λ b T F ⇒ case1 b return ★ of { 'true ⇒ T; 'false ⇒ F };
+def0 if-same : (A : ★) → (b : Bool) → (x : A) → if A b x x ≡ x : A =
+  λ A b x ⇒ if-dep (λ b' ⇒ if A b' x x ≡ x : A) b (δ _ ⇒ x) (δ _ ⇒ x);
 
-def0 T : ω.Bool → ★ = λ b ⇒ If b True False;
+def if2 : 0.(A B : ★) → (b : Bool) → ω.A → ω.B → if¹ ★ b A B =
+  λ A B ⇒ if-dep (λ b ⇒ if-dep¹ (λ _ ⇒ ★) b A B);
+
+def0 T : Bool → ★ = λ b ⇒ if¹ ★ b True False;
+
+def dup! : (b : Bool) → [ω. Sing Bool b] =
+  λ b ⇒ if-dep (λ b ⇒ [ω. Sing Bool b]) b
+    [('true,  [δ _ ⇒ 'true])]
+    [('false, [δ _ ⇒ 'false])];
+
+def dup : Bool → [ω. Bool] =
+  λ b ⇒ appω (Sing Bool b) Bool (sing.val Bool b) (dup! b);
 
 def true-not-false : Not ('true ≡ 'false : Bool) =
-  λ eq ⇒ coe (i ⇒ T (eq @i)) 'true;
+  λ eq ⇒ coe (𝑖 ⇒ T (eq @𝑖)) 'true;
 
 
 -- [todo] infix
-def and : 1.Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
-def or  : 1.Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
+def and : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
+def or  : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
 
 }
 

examples/either.quox

@@ -5,35 +5,35 @@ namespace either {
 
 def0 Tag : ★ = {left, right};
 
-def0 Payload : 0.★ → 0.★ → 1.Tag → ★ =
-  λ A B tag ⇒ case1 tag return ★ of { 'left ⇒ A; 'right ⇒ B };
+def0 Payload : ★ → ★ → Tag → ★ =
+  λ A B tag ⇒ case tag return ★ of { 'left ⇒ A; 'right ⇒ B };
 
-def0 Either : 0.★ → 0.★ → ★ =
+def0 Either : ★ → ★ → ★ =
   λ A B ⇒ (tag : Tag) × Payload A B tag;
 
-def Left : 0.(A B : ★) → 1.A → Either A B =
+def Left : 0.(A B : ★) → A → Either A B =
   λ A B x ⇒ ('left, x);
 
-def Right : 0.(A B : ★) → 1.B → Either A B =
+def Right : 0.(A B : ★) → B → Either A B =
   λ A B x ⇒ ('right, x);
 
 def elim' :
     0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
-    ω.(1.(x : A) → P (Left  A B x)) →
-    ω.(1.(x : B) → P (Right A B x)) →
-    1.(t : Tag) → 1.(a : Payload A B t) → P (t, a) =
+    ω.((x : A) → P (Left  A B x)) →
+    ω.((x : B) → P (Right A B x)) →
+    (t : Tag) → (a : Payload A B t) → P (t, a) =
   λ A B P f g t ⇒
-    case1 t
-    return t' ⇒ 1.(a : Payload A B t') → P (t', a)
+    case t
+    return t' ⇒ (a : Payload A B t') → P (t', a)
     of { 'left ⇒ f; 'right ⇒ g };
 
 def elim :
     0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
-    ω.(1.(x : A) → P (Left  A B x)) →
-    ω.(1.(x : B) → P (Right A B x)) →
-    1.(x : Either A B) → P x =
+    ω.((x : A) → P (Left  A B x)) →
+    ω.((x : B) → P (Right A B x)) →
+    (x : Either A B) → P x =
   λ A B P f g e ⇒
-    case1 e return e' ⇒ P e' of { (t, a) ⇒ elim' A B P f g t a };
+    case e return e' ⇒ P e' of { (t, a) ⇒ elim' A B P f g t a };
 
 
 }
@@ -45,25 +45,25 @@ def  Right  = either.Right;
 
 namespace dec {
 
-def0 Dec : 0.★ → ★ = λ A ⇒ Either [0.A] [0.Not A];
+def0 Dec : ★ → ★ = λ A ⇒ Either [0.A] [0.Not A];
 
 def Yes : 0.(A : ★) → 0.A       → Dec A = λ A y ⇒ Left  [0.A] [0.Not A] [y];
 def No  : 0.(A : ★) → 0.(Not A) → Dec A = λ A n ⇒ Right [0.A] [0.Not A] [n];
 
-def0 DecEq : 0.★ → ★ =
+def0 DecEq : ★ → ★ =
   λ A ⇒ ω.(x : A) → ω.(y : A) → Dec (x ≡ y : A);
 
 def elim :
     0.(A : ★) → 0.(P : 0.(Dec A) → ★) →
     ω.(0.(y : A)     → P (Yes A y)) →
     ω.(0.(n : Not A) → P (No  A n)) →
-    1.(x : Dec A) → P x =
+    (x : Dec A) → P x =
   λ A P f g ⇒
     either.elim [0.A] [0.Not A] P
       (λ y ⇒ case0 y return y' ⇒ P (Left  [0.A] [0.Not A] y') of {[y'] ⇒ f y'})
       (λ n ⇒ case0 n return n' ⇒ P (Right [0.A] [0.Not A] n') of {[n'] ⇒ g n'});
 
-def bool : 0.(A : ★) → 1.(Dec A) → Bool =
+def bool : 0.(A : ★) → Dec A → Bool =
   λ A ⇒ elim A (λ _ ⇒ Bool) (λ _ ⇒ 'true) (λ _ ⇒ 'false);
 
 }

examples/eta.quox

@@ -0,0 +1,25 @@
+load "misc.quox"
+
+namespace eta {
+
+def0 Π : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) → B x
+def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x
+
+def0 function : (A : ★) → (B : A → Type) → (P : Π A B → ★) → (f : Π A B) →
+                P (λ x ⇒ f x) → P f =
+  λ A B P f p ⇒ p
+
+def0 box : (A : ★) → (P : [ω.A] → ★) → (e : [ω.A]) →
+           P [case1 e return A of {[x] ⇒ x}] → P e =
+  λ A P e p ⇒ p
+
+def0 pair : (A : ★) → (B : A → ★) → (P : Σ A B → ★) → (e : Σ A B) →
+            P (fst e, snd e) → P e =
+  λ A B P e p ⇒ p
+
+-- not exactly η, but kinda related
+def0 from-false : (A : ★) → (P : (0.False → A) → ★) → (f : 0.False → A) →
+                  P (void A) → P f =
+  λ A P f p ⇒ p
+
+}

examples/fail.quox

@@ -0,0 +1,16 @@
+#[fail "but cases for"]
+def missing-b : {a, b} → {a} =
+  λ x ⇒ case x return {a} of { 'a ⇒ 'a }
+
+#[fail "duplicate arms"]
+def repeat-enum-case : {a} → {a} =
+  λ x ⇒ case x return {a} of { 'a ⇒ 'a; 'a ⇒ 'a }
+
+#[fail "duplicate tags"]
+def repeat-enum-type : {a, a} = 'a
+
+#[fail "double-def.X has already been defined"]
+namespace double-def {
+  def0 X : ★ = {a}
+  def0 X : ★ = {a}
+}

examples/hello.quox

@@ -0,0 +1,26 @@
+def0 Unit : ★ = {tt}
+
+def drop-unit : 0.(A : ★) → Unit → A → A =
+  λ A u x ⇒ case u return A of {'tt ⇒ x}
+
+def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
+
+def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B =
+  λ A B m k s0 ⇒
+  case m s0 return B × IOState of { (x, s1) ⇒ k x s1 }
+
+def seq : IO Unit → IO Unit → IO Unit =
+  λ a b ⇒ bind Unit Unit a (λ u ⇒ drop-unit (IO Unit) u b)
+
+#[compile-scheme "(lambda (n) (builtin-io (printf \"~d~n\" n) 'tt))"]
+postulate print-ℕ : ℕ → IO Unit
+
+#[compile-scheme "(lambda (s) (builtin-io (printf \"~s~n\" s) 'tt))"]
+postulate print : String → IO Unit
+
+load "nat.quox"
+
+#[main]
+def main : IO Unit =
+  let1 sixty-nine = nat.plus 60 9 in
+  seq (print-ℕ sixty-nine) (print "(nice)")

examples/io.quox

@@ -0,0 +1,31 @@
+load "misc.quox"
+
+namespace io {
+
+def0 IORes : ★ → ★ = λ A ⇒ A × IOState
+
+def0 IO : ★ → ★ = λ A ⇒ IOState → IORes A
+
+def pure : 0.(A : ★) → A → IO A = λ A x s ⇒ (x, s)
+
+def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B =
+  λ A B m k s0 ⇒
+  case m s0 return IORes B of { (x, s1) ⇒ k x s1 }
+
+def seq : 0.(B : ★) → IO True → IO B → IO B =
+  λ B x y ⇒ bind True B x (λ u ⇒ case u return IO B of { 'true ⇒ y })
+
+def seq' : IO True → IO True → IO True = seq True
+
+#[compile-scheme "(lambda (str) (builtin-io (display str) 'true))"]
+postulate print : String → IO True
+
+def newline = print "\n"
+
+def println : String → IO True =
+  λ str ⇒ seq' (print str) newline
+
+#[compile-scheme "(builtin-io (get-line (current-input-port)))"]
+postulate readln : IO String
+
+}

examples/list.quox

@@ -1,41 +1,91 @@
 load "nat.quox";
 
-namespace list {
+namespace vec {
 
-def0 Vec : 0.ℕ → 0.★ → ★ =
+def0 Vec : ℕ → ★ → ★ =
   λ n A ⇒
   caseω n return ★ of {
     zero           ⇒ {nil};
     succ _, 0.Tail ⇒ A × Tail
   };
 
-def0 List : 0.★ → ★ =
-  λ A ⇒ (len : ℕ) × Vec len A;
+def elim : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
+           P 0 'nil →
+           ω.((x : A) → 0.(n : ℕ) → 0.(xs : Vec n A) →
+                P n xs → P (succ n) (x, xs)) →
+           (n : ℕ) → (xs : Vec n A) → P n xs =
+  λ A P pn pc n ⇒
+    case n return n' ⇒ (xs' : Vec n' A) → P n' xs' of {
+      zero ⇒ λ n ⇒
+        case n return n' ⇒ P 0 n' of { 'nil ⇒ pn };
+      succ n, ih ⇒ λ c ⇒
+        case c return c' ⇒ P (succ n) c' of {
+          (first, rest) ⇒ pc first n rest (ih rest)
+        }
+    };
 
-def nil : 0.(A : ★) → List A =
-  λ A ⇒ (0, 'nil);
-
-def cons : 0.(A : ★) → 1.A → 1.(List A) → List A =
-  λ A x xs ⇒ case1 xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
-
-def foldr' : 0.(A B : ★) →
-             1.B → ω.(1.A → 1.B → B) → 1.(n : ℕ) → 1.(Vec n A) → B =
-  λ A B z c n ⇒
-  case1 n return n' ⇒ 1.(Vec n' A) → B of {
-    zero ⇒
-      λ nil ⇒ case1 nil return B of { 'nil ⇒ z };
-    succ n, 1.ih ⇒
-      λ cons ⇒ case1 cons return B of { (first, rest) ⇒ c first (ih rest) }
-  };
-
-def foldr : 0.(A B : ★) → 1.B → ω.(1.A → 1.B → B) → 1.(List A) → B =
-  λ A B z c xs ⇒
-  case1 xs return B of { (len, elems) ⇒ foldr' A B z c len elems };
-
-def sum : 1.(List ℕ) → ℕ = foldr ℕ ℕ 0 nat.plus;
-
-def numbers : List ℕ = (5, (0, 1, 2, 3, 4, 'nil));
-
-def number-sum : sum numbers ≡ 10 : ℕ = δ _ ⇒ 10;
+#[compile-scheme "(lambda% (n xs) xs)"]
+def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A =
+  λ A n ⇒
+    case n return n' ⇒ Vec n' A → Vec¹ n' A of {
+      zero ⇒ λ xs ⇒
+        case xs return Vec¹ 0 A of { 'nil ⇒ 'nil };
+      succ n', f' ⇒ λ xs ⇒
+        case xs return Vec¹ (succ n') A of {
+          (first, rest) ⇒ (first, f' rest)
+        }
+    }
 
 }
+
+def0 Vec = vec.Vec;
+
+
+namespace list {
+
+def0 List : ★ → ★ =
+  λ A ⇒ (len : ℕ) × Vec len A;
+
+def Nil : 0.(A : ★) → List A =
+  λ A ⇒ (0, 'nil);
+
+def Cons : 0.(A : ★) → A → List A → List A =
+  λ A x xs ⇒ case xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
+
+def elim : 0.(A : ★) → 0.(P : List A → ★) →
+           P (Nil A) →
+           ω.((x : A) → 0.(xs : List A) → P xs → P (Cons A x xs)) →
+           (xs : List A) → P xs =
+  λ A P pn pc xs ⇒
+    case xs return xs' ⇒ P xs' of { (len, elems) ⇒
+      vec.elim A (λ n xs ⇒ P (n, xs))
+        pn (λ x n xs ih ⇒ pc x (n, xs) ih)
+        len elems
+    };
+
+-- [fixme] List A <: List¹ A should be automatic, imo
+#[compile-scheme "(lambda (xs) xs)"]
+def up : 0.(A : ★) → List A → List¹ A =
+  λ A xs ⇒
+  case xs return List¹ A of { (len, elems) ⇒
+    case nat.dup! len return List¹ A of { [p] ⇒
+      caseω p return List¹ A of { (lenω, eq0) ⇒
+        case eq0 return List¹ A of { [eq] ⇒
+          (lenω, vec.up A lenω (coe (𝑖 ⇒ Vec (eq @𝑖) A) @1 @0 elems))
+        }
+      }
+    }
+  };
+
+def foldr : 0.(A B : ★) → B → ω.(A → B → B) → List A → B =
+  λ A B z f xs ⇒ elim A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs;
+
+def map : 0.(A B : ★) → ω.(A → B) → List A → List B =
+  λ A B f ⇒ foldr A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys);
+
+def0 All : (A : ★) → (P : A → ★) → List A → ★ =
+  λ A P xs ⇒ foldr¹ A ★ True (λ x ps ⇒ P x × ps) (up A xs);
+
+}
+
+def0 List = list.List;

examples/maybe.quox

@@ -0,0 +1,68 @@
+load "misc.quox"
+load "either.quox"
+
+namespace maybe {
+
+def0 Tag : ★ = {nothing, just}
+
+def0 Payload : Tag → ★ → ★ =
+  λ tag A ⇒ case tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
+
+def0 Maybe : ★ → ★ =
+  λ A ⇒ (t : Tag) × Payload t A
+
+def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
+  λ _ x ⇒ caseω x return Tag of { (tag, _) ⇒ tag }
+
+def Nothing : 0.(A : ★) → Maybe A =
+  λ _ ⇒ ('nothing, 'true)
+
+def Just : 0.(A : ★) → A → Maybe A =
+  λ _ x ⇒ ('just, x)
+
+def0 IsJustTag : Tag → ★ =
+  λ t ⇒ case t return ★ of { 'just ⇒ True; 'nothing ⇒ False }
+
+def0 IsJust : (A : ★) → Maybe A → ★ =
+  λ A x ⇒ IsJustTag (tag A x)
+
+def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
+  λ A x ⇒
+  caseω tag A x return t ⇒ Dec (IsJustTag t) of {
+    'just    ⇒ Yes True  'true;
+    'nothing ⇒ No  False (λ x ⇒ x)
+  }
+
+def0 nothing-unique :
+    (A : ★) → (x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
+  λ A x ⇒
+  case x return x' ⇒ ('nothing, x') ≡ Nothing A : Maybe A of {
+    'true ⇒ δ _ ⇒ ('nothing, 'true)
+  }
+
+def elim :
+    0.(A : ★) →
+    0.(P : Maybe A → ★) →
+    ω.(P (Nothing A)) →
+    ω.((x : A) → P (Just A x)) →
+    (x : Maybe A) → P x =
+  λ A P n j x ⇒
+  case x return x' ⇒ P x' of { (tag, payload) ⇒
+    (case tag
+     return t ⇒
+       0.(eq : tag ≡ t : Tag) → P (t, coe (i ⇒ Payload (eq @i) A) payload)
+     of {
+       'nothing ⇒
+          λ eq ⇒
+          case coe (i ⇒ Payload (eq @i) A) payload
+          return p ⇒ P ('nothing, p)
+          of { 'true ⇒ n };
+       'just ⇒ λ eq ⇒ j (coe (i ⇒ Payload (eq @i) A) payload)
+     }) (δ _ ⇒ tag)
+  }
+
+}
+
+def0 Maybe   = maybe.Maybe
+def0 Just    = maybe.Just
+def0 Nothing = maybe.Nothing

examples/misc.quox

@@ -1,36 +1,83 @@
-def0 True : ★ = {true};
+def0 True : ★ = {true}
 
-def0 False : ★ = {};
-def0 Not : 0.★ → ★ = λ A ⇒ ω.A → False;
+def0 False : ★ = {}
+def0 Not : ★ → ★ = λ A ⇒ ω.A → False
 
 def void : 0.(A : ★) → 0.False → A =
-  λ A v ⇒ case0 v return A of { };
+  λ A v ⇒ case0 v return A of { }
 
-def0 Pred : 0.★ → ★¹ = λ A ⇒ 0.A → ★;
+def0 All : (A : ★) → (0.A → ★) → ★ =
+  λ A P ⇒ (x : A) → P x
 
-def0 All : 0.(A : ★) → 0.(Pred A) → ★¹ =
-  λ A P ⇒ 1.(x : A) → P x;
+def0 cong :
+    (A : ★) → (P : 0.A → ★) → (p : All A P) →
+    (x y : A) → (xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) =
+  λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖)
+
+def0 cong' :
+    (A B : ★) → (f : A → B) →
+    (x y : A) → (xy : x ≡ y : A) → f x ≡ f y : B =
+  λ A B ⇒ cong A (λ _ ⇒ B)
+
+def0 coherence :
+    (A B : ★) → (AB : A ≡ B : ★) → (x : A) →
+    Eq (𝑖 ⇒ AB @𝑖) x (coe (𝑖 ⇒ AB @𝑖) x) =
+  λ A B AB x ⇒
+    δ 𝑗 ⇒ coe (𝑖 ⇒ AB @𝑖) @0 @𝑗 x
 
-def cong :
-    0.(A : ★) → 0.(P : Pred A) → 1.(p : All A P) →
-    0.(x y : A) → 1.(xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) =
-  λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖);
 
 def0 eq-f :
-    0.(A : ★) → 0.(P : Pred A) →
+    0.(A : ★) → 0.(P : 0.A → ★) →
     0.(p : All A P) → 0.(q : All A P) →
     0.A → ★ =
-  λ A P p q x ⇒ p x ≡ q x : P x;
+  λ A P p q x ⇒ p x ≡ q x : P x
 
 def funext :
-    0.(A : ★) → 0.(P : Pred A) → 0.(p q : All A P) →
-    1.(All A (eq-f A P p q)) → p ≡ q : All A P =
-  λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖;
+    0.(A : ★) → 0.(P : 0.A → ★) → 0.(p q : All A P) →
+    (All A (eq-f A P p q)) → p ≡ q : All A P =
+  λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖
 
-def sym : 0.(A : ★) → 0.(x y : A) → 1.(x ≡ y : A) → y ≡ x : A =
-  λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 };
+def refl : 0.(A : ★) → (x : A) → x ≡ x : A = λ A x ⇒ δ _ ⇒ x
+
+def sym : 0.(A : ★) → 0.(x y : A) → (x ≡ y : A) → y ≡ x : A =
+  λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 }
 
 def trans : 0.(A : ★) → 0.(x y z : A) →
             ω.(x ≡ y : A) → ω.(y ≡ z : A) → x ≡ z : A =
   λ A x y z eq1 eq2 ⇒ δ 𝑖 ⇒
-    comp A (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 };
+    comp A (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 }
+
+def appω : 0.(A B : ★) → ω.(f : A → B) → [ω.A] → [ω.B] =
+  λ A B f x ⇒
+  case x return [ω.B] of { [x'] ⇒ [f x'] }
+
+def0 HEq : (A B : ★) → A → B → ★¹ =
+  λ A B x y ⇒ (AB : A ≡ B : ★) × Eq (𝑖 ⇒ AB @𝑖) x y
+
+
+def0 Sing : (A : ★) → A → ★ =
+  λ A x ⇒ (val : A) × [0. val ≡ x : A]
+
+def sing : 0.(A : ★) → (x : A) → Sing A x =
+  λ A x ⇒ (x, [δ _ ⇒ x])
+
+namespace sing {
+
+def val : 0.(A : ★) → 0.(x : A) → Sing A x → A =
+  λ A _ sg ⇒
+  case sg return A of { (x, eq) ⇒ case eq return A of { [_] ⇒ x } }
+
+def0 proof : (A : ★) → (x : A) → (sg : Sing A x) → val A x sg ≡ x : A =
+  λ A x sg ⇒
+  case sg return sg' ⇒ val A x sg' ≡ x : A of { (x', eq) ⇒
+    case eq return eq' ⇒ val A x (x', eq') ≡ x : A of { [eq'] ⇒ eq' }
+  }
+
+def app : 0.(A B : ★) → 0.(x : A) →
+          (f : A → B) → Sing A x → Sing B (f x) =
+  λ A B x f sg ⇒
+  case sg return Sing B (f x) of { (x_, eq) ⇒
+    case eq return Sing B (f x) of { [eq] ⇒ (f x_, [δ 𝑖 ⇒ f (eq @𝑖)]) }
+  }
+
+}

examples/nat.quox

@@ -4,41 +4,72 @@ load "either.quox";
 
 namespace nat {
 
-def dup : 1.ℕ → [ω.ℕ] =
+def elim-0-1 :
+    0.(P : ℕ → ★) →
+    ω.(P 0) → ω.(P 1) →
+    ω.(0.(n : ℕ) → P n → P (succ n)) →
+    (n : ℕ) → P n =
+  λ P p0 p1 ps n ⇒
+  case n return n' ⇒ P n' of {
+    zero    ⇒ p0;
+    succ n' ⇒
+      case n' return n'' ⇒ P (succ n'') of {
+        zero         ⇒ p1;
+        succ n'', IH ⇒ ps (succ n'') IH
+      }
+  }
+
+#[compile-scheme "(lambda (n) (cons n 'erased))"]
+def dup! : (n : ℕ) → [ω. Sing ℕ n] =
   λ n ⇒
-  case1 n return [ω.ℕ] of {
-    zero        ⇒ [zero];
-    succ _, 1.d ⇒ case1 d return [ω.ℕ] of { [d] ⇒ [succ d] }
+  case n return n' ⇒ [ω. Sing ℕ n'] of {
+    zero ⇒ [(zero, [δ _ ⇒ zero])];
+    succ n, d ⇒
+      appω (Sing ℕ n) (Sing ℕ (succ n))
+        (sing.app ℕ ℕ n (λ n ⇒ succ n)) d
   };
 
-def plus : 1.ℕ → 1.ℕ → ℕ =
+def dup : ℕ → [ω.ℕ] =
+  λ n ⇒ appω (Sing ℕ n) ℕ (sing.val ℕ n) (dup! n);
+
+#[compile-scheme "(lambda% (m n) (+ m n))"]
+def plus : ℕ → ℕ → ℕ =
   λ m n ⇒
-  case1 m return ℕ of {
-    zero        ⇒ n;
-    succ _, 1.p ⇒ succ p
+  case m return ℕ of {
+    zero      ⇒ n;
+    succ _, p ⇒ succ p
   };
 
-def timesω : 1.ℕ → ω.ℕ → ℕ =
+#[compile-scheme "(lambda% (m n) (* m n))"]
+def timesω : ℕ → ω.ℕ → ℕ =
   λ m n ⇒
-  case1 m return ℕ of {
-    zero        ⇒ zero;
-    succ _, 1.t ⇒ plus n t
+  case m return ℕ of {
+    zero      ⇒ zero;
+    succ _, t ⇒ plus n t
   };
 
-def times : 1.ℕ → 1.ℕ → ℕ =
-  λ m n ⇒ case1 dup n return ℕ of { [n] ⇒ timesω m n };
+def times : ℕ → ℕ → ℕ =
+  λ m n ⇒ case dup n return ℕ of { [n] ⇒ timesω m n };
 
-def pred : 1.ℕ → ℕ = λ n ⇒ case1 n return ℕ of { zero ⇒ zero; succ n ⇒ n };
+def pred : ℕ → ℕ = λ n ⇒ case n return ℕ of { zero ⇒ zero; succ n ⇒ n };
 
 def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ =
   λ n ⇒ δ 𝑖 ⇒ n;
 
-def0 succ-inj : 0.(m n : ℕ) → 0.(succ m ≡ succ n : ℕ) → m ≡ n : ℕ =
+def0 succ-inj : (m n : ℕ) → succ m ≡ succ n : ℕ → m ≡ n : ℕ =
   λ m n eq ⇒ δ 𝑖 ⇒ pred (eq @𝑖);
 
+#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"]
+def minus : ℕ → ℕ → ℕ =
+  λ m n ⇒
+  (case n return ℕ → ℕ of {
+    zero      ⇒ λ m ⇒ m;
+    succ _, f ⇒ λ m ⇒ f (pred m)
+  }) m;
 
-def0 IsSucc : 0.ℕ → ★ =
-  λ n ⇒ caseω n return ★ of { zero ⇒ False; succ _ ⇒ True };
+
+def0 IsSucc : ℕ → ★ =
+  λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True };
 
 def isSucc? : ω.(n : ℕ) → Dec (IsSucc n) =
   λ n ⇒
@@ -54,14 +85,15 @@ def succ-not-zero : 0.(m : ℕ) → Not (succ m ≡ zero : ℕ) =
   λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true;
 
 
-def0 not-succ-self : 0.(m : ℕ) → Not (m ≡ succ m : ℕ) =
+def0 not-succ-self : (m : ℕ) → Not (m ≡ succ m : ℕ) =
   λ m ⇒
-  caseω m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
+  case m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
     zero         ⇒ zero-not-succ 0;
     succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq)
   }
 
 
+#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"]
 def eq? : DecEq ℕ =
   λ m ⇒
   caseω m
@@ -86,28 +118,48 @@ def eq? : DecEq ℕ =
 def eqb : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ dec.bool (m ≡ n : ℕ) (eq? m n);
 
 
-def0 plus-zero : 0.(m : ℕ) → m ≡ plus m 0 : ℕ =
+def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ =
   λ m ⇒
-  caseω m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
-    zero         ⇒ δ _ ⇒ zero;
-    succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
+  case m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
+    zero        ⇒ δ _ ⇒ 0;
+    succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
   };
 
-def0 plus-succ : 0.(m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ =
+def0 plus-succ : (m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ =
   λ m n ⇒
-  caseω m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : ℕ of {
-    zero         ⇒ δ _ ⇒ succ n;
-    succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
+  case m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : ℕ of {
+    zero       ⇒ δ _ ⇒ succ n;
+    succ _, ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
   };
 
-def0 plus-comm : 0.(m n : ℕ) → plus m n ≡ plus n m : ℕ =
+def0 plus-comm : (m n : ℕ) → plus m n ≡ plus n m : ℕ =
   λ m n ⇒
-  caseω m return m' ⇒ plus m' n ≡ plus n m' : ℕ of {
+  case m return m' ⇒ plus m' n ≡ plus n m' : ℕ of {
     zero ⇒ plus-zero n;
-    succ m', ω.ih ⇒
+    succ m', ih ⇒
       trans ℕ (succ (plus m' n)) (succ (plus n m')) (plus n (succ m'))
         (δ 𝑖 ⇒ succ (ih @𝑖))
         (plus-succ n m')
   };
 
+def0 times-zero : (m : ℕ) → 0 ≡ timesω m 0 : ℕ =
+  λ m ⇒
+  case m return m' ⇒ 0 ≡ timesω m' 0 : ℕ of {
+    zero        ⇒ δ _ ⇒ zero;
+    succ m', ih ⇒ ih
+  };
+
+{-
+-- unfinished
+def0 times-succ : (m n : ℕ) → plus m (timesω m n) ≡ timesω m (succ n) : ℕ =
+  λ m n ⇒
+  case m
+  return m' ⇒ plus m' (timesω m' n) ≡ timesω m' (succ n) : ℕ
+  of {
+    zero ⇒ δ _ ⇒ 0;
+    succ m', ih ⇒
+      δ 𝑖 ⇒ plus (succ n) (ih @𝑖)
+  };
+-}
+
 }

examples/pair.quox

@@ -1,55 +1,74 @@
 namespace pair {
 
-def0 Σ : 0.(A : ★) → 0.(0.A → ★) → ★ = λ A B ⇒ (x : A) × B x;
+def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x;
 
-def fst : 0.(A : ★) → 0.(B : 0.A → ★) → ω.(Σ A B) → A =
+{-
+-- now builtins
+def fst : 0.(A : ★) → 0.(B : A → ★) → ω.(Σ A B) → A =
   λ A B p ⇒ caseω p return A of { (x, _) ⇒ x };
 
-def snd : 0.(A : ★) → 0.(B : 0.A → ★) → ω.(p : Σ A B) → B (fst A B p) =
+def snd : 0.(A : ★) → 0.(B : A → ★) → ω.(p : Σ A B) → B (fst A B p) =
   λ A B p ⇒ caseω p return p' ⇒ B (fst A B p') of { (_, y) ⇒ y };
+-}
 
 def uncurry :
-    0.(A : ★) → 0.(B : 0.A → ★) → 0.(C : 0.(x : A) → 0.(B x) → ★) →
-    1.(f : 1.(x : A) → 1.(y : B x) → C x y) →
-    1.(p : Σ A B) → C (fst A B p) (snd A B p) =
+    0.(A : ★) → 0.(B : A → ★) → 0.(C : (x : A) → (B x) → ★) →
+    (f : (x : A) → (y : B x) → C x y) →
+    (p : Σ A B) → C (fst p) (snd p) =
   λ A B C f p ⇒
-    case1 p return p' ⇒ C (fst A B p') (snd A B p') of { (x, y) ⇒ f x y };
+    case p return p' ⇒ C (fst p') (snd p') of { (x, y) ⇒ f x y };
 
 def uncurry' :
-    0.(A B C : ★) → 1.(1.A → 1.B → C) → 1.(A × B) → C =
+    0.(A B C : ★) → (A → B → C) → (A × B) → C =
   λ A B C ⇒ uncurry A (λ _ ⇒ B) (λ _ _ ⇒ C);
 
 def curry :
-    0.(A : ★) → 0.(B : 0.A → ★) → 0.(C : 0.(Σ A B) → ★) →
-    1.(f : 1.(p : Σ A B) → C p) → 1.(x : A) → 1.(y : B x) → C (x, y) =
+    0.(A : ★) → 0.(B : A → ★) → 0.(C : (Σ A B) → ★) →
+    (f : (p : Σ A B) → C p) → (x : A) → (y : B x) → C (x, y) =
   λ A B C f x y ⇒ f (x, y);
 
 def curry' :
-    0.(A B C : ★) → 1.(1.(A × B) → C) → 1.A → 1.B → C =
+    0.(A B C : ★) → (A × B → C) → A → B → C =
   λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C);
 
 def0 fst-snd :
-    0.(A : ★) → 0.(B : 0.A → ★) →
-    1.(p : Σ A B) → p ≡ (fst A B p, snd A B p) : Σ A B =
+    (A : ★) → (B : A → ★) →
+    (p : Σ A B) → p ≡ (fst p, snd p) : Σ A B =
   λ A B p ⇒
-    case1 p
-    return p' ⇒ p' ≡ (fst A B p', snd A B p') : Σ A B
+    case p
+    return p' ⇒ p' ≡ (fst p', snd p') : Σ A B
     of { (x, y) ⇒ δ 𝑖 ⇒ (x, y) };
 
+def0 fst-eq :
+    (A : ★) → (B : A → ★) →
+    (p q : Σ A B) → p ≡ q : Σ A B → fst p ≡ fst q : A =
+  λ A B p q eq ⇒ δ 𝑖 ⇒ fst (eq @𝑖);
+
+def0 snd-eq :
+    (A : ★) → (B : A → ★) →
+    (p q : Σ A B) → (eq : p ≡ q : Σ A B) →
+    Eq (𝑖 ⇒ B (fst-eq A B p q eq @𝑖)) (snd p) (snd q) =
+  λ A B p q eq ⇒ δ 𝑖 ⇒ snd (eq @𝑖);
+
 def map :
     0.(A A' : ★) →
-    0.(B : 0.A → ★) → 0.(B' : 0.A' → ★) →
-    1.(f : 1.A → A') → 1.(g : 0.(x : A) → 1.(B x) → B' (f x)) →
-    1.(Σ A B) → Σ A' B' =
+    0.(B : A → ★) → 0.(B' : A' → ★) →
+    (f : A → A') → (g : 0.(x : A) → (B x) → B' (f x)) →
+    Σ A B → Σ A' B' =
   λ A A' B B' f g p ⇒
-    case1 p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
+    case p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
 
-def map' : 0.(A A' B B' : ★) →
-           1.(1.A → A') → 1.(1.B → B') → 1.(A × B) → A' × B' =
+def map' : 0.(A A' B B' : ★) → (A → A') → (B → B') → (A × B) → A' × B' =
   λ A A' B B' f g ⇒ map A A' (λ _ ⇒ B) (λ _ ⇒ B') f (λ _ ⇒ g);
 
+def map-fst : 0.(A A' B : ★) → (A → A') → A × B → A' × B =
+  λ A A' B f ⇒ map' A A' B B f (λ x ⇒ x);
+
+def map-snd : 0.(A B B' : ★) → (B → B') → A × B → A × B' =
+  λ A B B' f ⇒ map' A A B B' (λ x ⇒ x) f;
+
 }
 
 def0 Σ   = pair.Σ;
-def  fst = pair.fst;
-def  snd = pair.snd;
+-- def  fst = pair.fst;
+-- def  snd = pair.snd;

examples/qty.quox

@@ -0,0 +1,77 @@
+def0 Qty : ★ = {"zero", one, any}
+
+def dup : Qty → [ω.Qty] =
+  λ π ⇒ case π return [ω.Qty] of {
+    'zero ⇒ ['zero];
+    'one  ⇒ ['one];
+    'any  ⇒ ['any];
+  }
+
+def drop : 0.(A : ★) → Qty → A → A =
+  λ A π x ⇒ case π return A of {
+    'zero ⇒ x;
+    'one  ⇒ x;
+    'any  ⇒ x;
+  }
+
+def if-zero : 0.(A : ★) → Qty → ω.A → ω.A → A =
+  λ A π z nz ⇒
+  case π return A of { 'zero ⇒ z; 'one ⇒ nz; 'any ⇒ nz }
+
+def plus : Qty → Qty → Qty =
+  λ π ρ ⇒
+  case π return Qty of {
+    'zero ⇒ ρ;
+    'one  ⇒ if-zero Qty ρ 'one 'any;
+    'any  ⇒ drop Qty ρ 'any;
+  }
+
+def times : Qty → Qty → Qty =
+  λ π ρ ⇒
+  case π return Qty of {
+    'zero ⇒ drop Qty ρ 'zero;
+    'one  ⇒ ρ;
+    'any  ⇒ if-zero Qty ρ 'zero 'any;
+  }
+
+def0 FUN : Qty → (A : ★) → (A → ★) → ★ =
+  λ π A B ⇒
+  case π return ★ of {
+    'zero ⇒ 0.(x : A) → B x;
+    'one  ⇒ 1.(x : A) → B x;
+    'any  ⇒ ω.(x : A) → B x;
+  }
+
+def0 Fun : Qty → ★ → ★ → ★ =
+  λ π A B ⇒ FUN π A (λ _ ⇒ B)
+
+def0 Box : Qty → ★ → ★ =
+  λ π A ⇒
+  case π return ★ of {
+    'zero ⇒ [0.A];
+    'one  ⇒ [1.A];
+    'any  ⇒ [ω.A];
+  }
+
+def0 unbox : (π : Qty) → (A : ★) → Box π A → A =
+  λ π A ⇒
+  case π return π' ⇒ Box π' A → A of {
+    'zero ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
+    'one  ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
+    'any  ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
+  }
+
+def0 unbox0 = unbox 'zero
+def0 unbox1 = unbox 'one
+def0 unboxω = unbox 'any
+
+def apply : (π : Qty) → 0.(A : ★) → 0.(B : A → ★) →
+            FUN π A B → (x : Box π A) → B (unbox π A x) =
+  λ π A B ⇒
+  case π
+  return π' ⇒ FUN π' A B → (x : Box π' A) → B (unbox π' A x)
+  of {
+    'zero ⇒ λ f x ⇒ case x return x' ⇒ B (unbox0 A x') of { [x] ⇒ f x };
+    'one  ⇒ λ f x ⇒ case x return x' ⇒ B (unbox1 A x') of { [x] ⇒ f x };
+    'any  ⇒ λ f x ⇒ case x return x' ⇒ B (unboxω A x') of { [x] ⇒ f x };
+  }

exe/CompileMonad.idr

@@ -0,0 +1,164 @@
+module CompileMonad
+
+import Quox.Syntax as Q
+import Quox.Definition as Q
+import Quox.Untyped.Syntax as U
+import Quox.Parser
+import Quox.Untyped.Erase
+import Quox.Untyped.Scheme
+import Quox.Pretty
+import Quox.Log
+import Options
+import Output
+import Error
+
+import System.File
+import Data.IORef
+import Data.Maybe
+import Control.Eff
+
+%default total
+
+%hide Doc.(>>=)
+%hide Core.(>>=)
+
+%hide FromParser.Error
+%hide Erase.Error
+%hide Lexer.Error
+%hide Parser.Error
+
+
+
+public export
+record State where
+  constructor MkState
+  seen : IORef SeenSet
+  defs : IORef Q.Definitions
+  ns   : IORef Mods
+  suf  : IORef NameSuf
+%name CompileMonad.State state
+
+export %inline
+newState : HasIO io => io State
+newState = pure $ MkState {
+  seen = !(newIORef empty),
+  defs = !(newIORef empty),
+  ns   = !(newIORef [<]),
+  suf  = !(newIORef 0)
+}
+
+
+public export
+data CompileTag = OPTS | STATE
+
+public export
+Compile : List (Type -> Type)
+Compile =
+  [Except Error,
+   ReaderL STATE State, ReaderL OPTS Options, Log,
+   LoadFile, IO]
+
+
+export %inline
+handleLog : IORef LevelStack -> OpenFile -> LogL x a -> IOErr Error a
+handleLog ref f l = case f of
+  OConsole ch => handleLogIO (const $ pure ()) ref (consoleHandle ch) l
+  OFile _ h   => handleLogIO (const $ pure ()) ref h l
+  ONone       => do
+    lvls   <- readIORef ref
+    lenRef <- newIORef (length lvls)
+    res    <- handleLogDiscardIO lenRef l
+    writeIORef ref $ fixupDiscardedLog !(readIORef lenRef) lvls
+    pure res
+
+private %inline
+withLogFile : Options ->
+              (IORef LevelStack -> OpenFile -> IO (Either Error a)) ->
+              IO (Either Error a)
+withLogFile opts act = do
+  lvlStack <- newIORef $ singleton opts.logLevels
+  withOutFile CErr opts.logFile fromError $ act lvlStack
+where
+  fromError : String -> FileError -> IO (Either Error a)
+  fromError file err = pure $ Left $ WriteError file err
+
+export covering %inline
+runCompile : Options -> State -> Eff Compile a -> IO (Either Error a)
+runCompile opts state act = do
+  withLogFile opts $ \lvls, logFile =>
+    fromIOErr $ runEff act $ with Union.(::)
+      [handleExcept (\e => ioLeft e),
+       handleReaderConst state,
+       handleReaderConst opts,
+       handleLog lvls logFile,
+       handleLoadFileIOE loadError ParseError state.seen opts.include,
+       liftIO]
+
+private %inline
+rethrowFileC : String -> Either FileError a -> Eff Compile a
+rethrowFileC f = rethrow . mapFst (WriteError f)
+
+
+export %inline
+outputStr : OpenFile -> Lazy String -> Eff Compile ()
+outputStr ONone           _   = pure ()
+outputStr (OConsole COut) str = putStr str
+outputStr (OConsole CErr) str = fPutStr stderr str >>= rethrowFileC "<stderr>"
+outputStr (OFile f h)     str = fPutStr h str >>= rethrowFileC f
+
+export %inline
+outputDocs : OpenFile ->
+             ({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) ->
+             Eff Compile ()
+outputDocs file docs = do
+  opts <- askAt OPTS
+  for_ (runPretty opts (toOutFile file) docs) $ \x =>
+    outputStr file $ render (Opts opts.width) x
+
+export %inline
+outputDoc : OpenFile ->
+            ({opts : LayoutOpts} -> Eff Pretty (Doc opts)) -> Eff Compile ()
+outputDoc file doc = outputDocs file $ singleton <$> doc
+
+
+public export
+data StopTag = STOP
+
+public export
+CompileStop : List (Type -> Type)
+CompileStop = FailL STOP :: Compile
+
+export %inline
+withEarlyStop : Eff CompileStop () -> Eff Compile ()
+withEarlyStop = ignore . runFailAt STOP
+
+export %inline
+stopHere : Has (FailL STOP) fs => Eff fs ()
+stopHere = failAt STOP
+
+
+export %inline
+liftFromParser : Eff FromParserIO a -> Eff Compile a
+liftFromParser act =
+  runEff act $ with Union.(::)
+    [handleExcept $ \err => throw $ FromParserError err,
+     handleStateIORef !(asksAt STATE defs),
+     handleStateIORef !(asksAt STATE ns),
+     handleStateIORef !(asksAt STATE suf),
+     \g => send g,
+     \g => send g]
+
+export %inline
+liftErase : Q.Definitions -> Eff Erase a -> Eff Compile a
+liftErase defs act =
+  runEff act
+    [handleExcept $ \err => throw $ EraseError err,
+     handleStateIORef !(asksAt STATE suf),
+     \g => send g]
+
+export %inline
+liftScheme : Eff Scheme a -> Eff Compile (a, List Id)
+liftScheme act = do
+  runEff [|MkPair act (getAt MAIN)|]
+    [handleStateIORef !(newIORef empty),
+     handleStateIORef !(newIORef [])]

exe/Error.idr

@@ -0,0 +1,49 @@
+module Error
+
+import Quox.Pretty
+import Quox.Parser
+import Quox.Untyped.Erase
+import Quox.Untyped.Scheme
+import Options
+import Output
+
+import System.File
+
+
+public export
+data Error =
+  ParseError String Parser.Error
+| FromParserError FromParser.Error
+| EraseError Erase.Error
+| WriteError FilePath FileError
+| NoMain
+| MultipleMains (List Scheme.Id)
+
+%hide FromParser.Error
+%hide Erase.Error
+%hide Lexer.Error
+%hide Parser.Error
+
+
+export
+loadError : Loc -> FilePath -> FileError -> Error
+loadError loc file err = FromParserError $ LoadError loc file err
+
+export
+prettyError : {opts : LayoutOpts} -> Error -> Eff Pretty (Doc opts)
+prettyError (ParseError file e) = prettyParseError file e
+prettyError (FromParserError e) = FromParser.prettyError True e
+prettyError (EraseError      e) = Erase.prettyError True e
+prettyError NoMain              = pure "no #[main] function given"
+prettyError (MultipleMains xs)  =
+  pure $ sep ["multiple #[main] functions given:",
+              separateLoose "," !(traverse prettyId xs)]
+prettyError (WriteError file e) = pure $
+  hangSingle 2 (text "couldn't write file \{file}:") (pshow e)
+
+export
+dieError : Options -> Error -> IO a
+dieError opts e =
+  die (Opts opts.width) $
+  runPretty ({outFile := Console} opts) Console $
+  prettyError e

exe/Main.idr

@@ -1,46 +1,118 @@
 module Main
 
-import Quox.Syntax
+import Quox.Syntax as Q
+import Quox.Definition as Q
+import Quox.Untyped.Syntax as U
 import Quox.Parser
-import Quox.Definition
+import Quox.Untyped.Erase
+import Quox.Untyped.Scheme
 import Quox.Pretty
+import Quox.Log
+import Options
+import Output
+import Error
+import CompileMonad
 
 import System
+import System.File
 import Data.IORef
-import Data.SortedSet
 import Control.Eff
 
-private
-Opts : LayoutOpts
-Opts = Opts 80
+%default total
+
+%hide Doc.(>>=)
+%hide Core.(>>=)
+
+%hide FromParser.Error
+%hide Erase.Error
+%hide Lexer.Error
+%hide Parser.Error
+
 
 private
-putDoc : Doc Opts -> IO ()
-putDoc = putStr . render Opts
+Step : Type -> Type -> Type
+Step a b = OpenFile -> a -> Eff Compile b
 
 private
-die : Doc Opts -> IO a
-die err = do putDoc err; exitFailure
+step : ConsoleChannel -> Phase -> OutFile -> Step a b -> a -> Eff CompileStop b
+step console phase file act x = do
+  opts <- askAt OPTS
+  res  <- withOutFile console file fromError $ \h => lift $ act h x
+  when (opts.until == Just phase) stopHere
+  pure res
+where
+  fromError : String -> FileError -> Eff CompileStop c
+  fromError file err = throw $ WriteError file err
 
-private
-prettySig : {opts : _} -> Name -> Definition -> Eff Pretty (Doc opts)
-prettySig name def = do
-  qty  <- prettyQty def.qty.fst
-  name <- prettyFree name
-  type <- prettyTerm [<] [<] def.type
-  hangDSingle (hsep [hcat [qty, !dotD, name], !colonD]) type
 
-export
+private covering
+parse : Step String PFile
+parse h file = do
+  Just ast <- loadFile noLoc file
+    | Nothing => pure []
+  outputStr h $ show ast
+  pure ast
+
+private covering
+check : Step PFile (List Q.NDefinition)
+check h decls =
+  map concat $ for decls $ \decl => do
+    defs <- liftFromParser $ fromPTopLevel decl
+    outputDocs h $ traverse (\(x, d) => prettyDef x d) defs
+    pure defs
+
+private covering
+erase : Step (List Q.NDefinition) (List U.NDefinition)
+erase h defList =
+  for defList $ \(x, def) => do
+    def <- liftErase defs $ eraseDef defs x def
+    outputDoc h $ U.prettyDef x def
+    pure (x, def)
+where defs = SortedMap.fromList defList
+
+private covering
+scheme : Step (List U.NDefinition) (List Sexp, List Id)
+scheme h defs = do
+  sexps' <- for defs $ \(x, d) => do
+    (msexp, mains) <- liftScheme $ defToScheme x d
+    outputDoc h $ case msexp of
+      Just s  => prettySexp s
+      Nothing => pure $ hsep [";;", prettyName x, "erased"]
+    pure (msexp, mains)
+  pure $ bimap catMaybes concat $ unzip sexps'
+
+private covering
+output : Step (List Sexp, List Id) ()
+output h (sexps, mains) = do
+  main <- case mains of
+    [m] => pure m
+    []  => throw NoMain
+    _   => throw $ MultipleMains mains
+  lift $ outputDocs h $ do
+    res    <- traverse prettySexp sexps
+    runner <- makeRunMain main
+    pure $ text Scheme.prelude :: res ++ [runner]
+
+private covering
+processFile : String -> Eff Compile ()
+processFile file = withEarlyStop $ pipeline !(askAt OPTS) file where
+  pipeline : Options -> String -> Eff CompileStop ()
+  pipeline opts =
+    step CErr Parse  opts.dump.parse  Main.parse  >=>
+    step CErr Check  opts.dump.check  Main.check  >=>
+    step CErr Erase  opts.dump.erase  Main.erase  >=>
+    step CErr Scheme opts.dump.scheme Main.scheme >=>
+    step COut End    opts.outFile     Main.output
+
+
+export covering
 main : IO ()
 main = do
-  seen <- newIORef SortedSet.empty
-  defs <- newIORef SortedMap.empty
-  suf  <- newIORef $ the Nat 0
-  for_ (drop 1 !getArgs) $ \file => do
-    putStrLn "checking \{file}"
-    Right res <- fromParserIO ["."] seen suf defs $ loadProcessFile noLoc file
-      | Left err => die $ runPrettyColor $ prettyError True err
-    for_ res $ \(name, def) => putDoc $ runPrettyColor $ prettySig name def
+  (_, opts, files) <- options
+  case !(runCompile opts !newState $ traverse_ processFile files) of
+    Right () => pure ()
+    Left  e  => dieError opts e
+
 
 -----------------------------------
 {-
@@ -55,6 +127,13 @@ text _ =
    #" /_/"#,
    ""]
 
+--   ["",
+--    #" __ _ _  _ _____ __"#,
+--    #"/ _` | || / _ \ \ /"#,
+--    #"\__, |\_,_\___/_\_\"#,
+--    #"   |_|"#,
+--    ""]
+
 private
 qtuwu : PrettyOpts -> List String
 qtuwu opts =

exe/Options.idr

@@ -0,0 +1,258 @@
+module Options
+
+import Quox.Pretty
+import Quox.Log
+import Data.DPair
+import Data.SortedMap
+import System
+import System.Console.GetOpt
+import System.File
+import System.Term
+import Derive.Prelude
+
+%default total
+%language ElabReflection
+
+public export
+data OutFile = File String | Console | NoOut
+%name OutFile f
+%runElab derive "OutFile" [Eq, Show]
+
+public export
+data Phase = Parse | Check | Erase | Scheme | End
+%name Phase p
+%runElab derive "Phase" [Eq, Show]
+
+||| a list of all intermediate `Phase`s (excluding `End`)
+public export %inline
+allPhases : List Phase
+allPhases = %runElab do
+  cs <- getCons $ fst !(lookupName "Phase")
+  traverse (check . var) $ fromMaybe [] $ init' cs
+
+||| `Guess` is `Term` for a terminal and `NoHL` for a file
+public export
+data HLType = Guess | NoHL | Term | Html
+%runElab derive "HLType" [Eq, Show]
+
+public export
+record Dump where
+  constructor MkDump
+  parse, check, erase, scheme : OutFile
+%name Dump dump
+%runElab derive "Dump" [Show]
+
+public export
+record Options where
+  constructor MkOpts
+  include   : List String
+  dump      : Dump
+  outFile   : OutFile
+  until     : Maybe Phase
+  hlType    : HLType
+  flavor    : Pretty.Flavor
+  width     : Nat
+  logLevels : LogLevels
+  logFile   : OutFile
+%name Options opts
+%runElab derive "Options" [Show]
+
+export
+defaultWidth : IO Nat
+defaultWidth = do
+  w <- cast {to = Nat} <$> getTermCols
+  pure $ if w == 0 then 80 else w
+
+export
+defaultOpts : IO Options
+defaultOpts = pure $ MkOpts {
+  include   = ["."],
+  dump      = MkDump NoOut NoOut NoOut NoOut,
+  outFile   = Console,
+  until     = Nothing,
+  hlType    = Guess,
+  flavor    = Unicode,
+  width     = !defaultWidth,
+  logLevels = defaultLogLevels,
+  logFile   = Console
+}
+
+private
+data HelpType = Common | All
+
+private
+data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options)
+%name OptAction act
+
+private
+toOutFile : String -> OutFile
+toOutFile ""  = NoOut
+toOutFile "-" = Console
+toOutFile f   = File f
+
+private
+toPhase : String -> OptAction
+toPhase str =
+  let lstr = toLower str in
+  case find (\p => toLower (show p) == lstr) allPhases of
+    Just p  => Ok $ setPhase p
+    Nothing => Err "unknown phase name \{show str}\nphases: \{phaseNames}"
+where
+  phaseNames = joinBy ", " $ map (toLower . show) allPhases
+
+  defConsole : OutFile -> OutFile
+  defConsole NoOut = Console
+  defConsole f     = f
+
+  setPhase : Phase -> Options -> Options
+  setPhase Parse  = {until := Just Parse,  dump.parse  $= defConsole}
+  setPhase Check  = {until := Just Check,  dump.check  $= defConsole}
+  setPhase Erase  = {until := Just Erase,  dump.erase  $= defConsole}
+  setPhase Scheme = {until := Just Scheme, dump.scheme $= defConsole}
+  setPhase End    = id
+
+private
+toWidth : String -> OptAction
+toWidth s = case parsePositive s of
+  Just n  => Ok {width := n}
+  Nothing => Err "invalid width: \{show s}"
+
+private
+toHLType : String -> OptAction
+toHLType str = case toLower str of
+  "none" => Ok {hlType := NoHL}
+  "term" => Ok {hlType := Term}
+  "html" => Ok {hlType := Html}
+  _      => Err "unknown highlighting type \{show str}\ntypes: term, html, none"
+
+||| like ghc, `-i ""` clears the search path;
+||| `-i a:b:c` adds `a`, `b`, `c` to the end
+private
+dirListFlag : String -> List String -> List String
+dirListFlag ""   val = []
+dirListFlag dirs val = val ++ toList (split (== ':') dirs)
+
+private
+splitLogFlag : String -> Either String (List (Maybe LogCategory, LogLevel))
+splitLogFlag = traverse flag1 . toList . split (== ':') where
+  parseLogCategory : String -> Either String LogCategory
+  parseLogCategory cat = do
+    let Just cat = toLogCategory cat
+      | _ => let catList = joinBy ", " logCategories in
+             Left "unknown log category. categories are:\n\{catList}"
+    pure cat
+
+  parseLogLevel : String -> Either String LogLevel
+  parseLogLevel lvl = do
+    let Just lvl = parsePositive lvl
+      | _ => Left "log level \{lvl} not a number"
+    let Just lvl = toLogLevel lvl
+      | _ => Left "log level \{show lvl} out of range 0–\{show maxLogLevel}"
+    pure lvl
+
+  flag1 : String -> Either String (Maybe LogCategory, LogLevel)
+  flag1 str = do
+    let (first, second) = break (== '=') str
+    case strM second of
+      StrCons '=' lvl => do
+        cat <- parseLogCategory first
+        lvl <- parseLogLevel lvl
+        pure (Just cat, lvl)
+      StrNil => (Nothing,) <$> parseLogLevel first
+      _      => Left "invalid log flag \{str}"
+
+private
+setLogFlag : LogLevels -> (Maybe LogCategory, LogLevel) -> LogLevels
+setLogFlag lvls (Nothing,   lvl) = {defLevel := lvl} lvls
+setLogFlag lvls (Just name, lvl) = {levels $= ((name, lvl) ::)} lvls
+
+private
+logFlag : String -> OptAction
+logFlag str = case splitLogFlag str of
+  Left  err   => Err err
+  Right flags => Ok $ \o => {logLevels := foldl setLogFlag o.logLevels flags} o
+
+private
+commonOptDescrs' : List (OptDescr OptAction)
+commonOptDescrs' = [
+  MkOpt ['i'] ["include"]
+    (ReqArg (\is => Ok {include $= dirListFlag is}) "<dir>:<dir>...")
+    "add directories to look for source files",
+  MkOpt ['o'] ["output"] (ReqArg (\s => Ok {outFile := toOutFile s}) "<file>")
+    "output file (\"-\" for stdout, \"\" for no output)",
+  MkOpt ['P'] ["phase"] (ReqArg toPhase "<phase>")
+    "stop after the given phase",
+  MkOpt ['l'] ["log"] (ReqArg logFlag "[<cat>=]<n>:...")
+    "set log level",
+  MkOpt ['L'] ["log-file"] (ReqArg (\s => Ok {logFile := toOutFile s}) "<file>")
+    "set log output file"
+]
+
+private
+extraOptDescrs : List (OptDescr OptAction)
+extraOptDescrs = [
+  MkOpt [] ["unicode"] (NoArg $ Ok {flavor := Unicode})
+    "use unicode syntax when printing (default)",
+  MkOpt [] ["ascii"] (NoArg $ Ok {flavor := Ascii})
+    "use ascii syntax when printing",
+  MkOpt [] ["width"] (ReqArg toWidth "<width>")
+    "max output width (defaults to terminal width)",
+  MkOpt [] ["color", "colour"] (ReqArg toHLType "<type>")
+    "select highlighting type",
+
+  MkOpt [] ["dump-parse"]
+    (ReqArg (\s => Ok {dump.parse := toOutFile s}) "<file>")
+    "dump AST",
+  MkOpt [] ["dump-check"]
+    (ReqArg (\s => Ok {dump.check := toOutFile s}) "<file>")
+    "dump typechecker output",
+  MkOpt [] ["dump-erase"]
+    (ReqArg (\s => Ok {dump.erase := toOutFile s}) "<file>")
+    "dump erasure output",
+  MkOpt [] ["dump-scheme"]
+    (ReqArg (\s => Ok {dump.scheme := toOutFile s}) "<file>")
+    "dump scheme output (without prelude)"
+]
+
+private
+helpOptDescrs : List (OptDescr OptAction)
+helpOptDescrs = [
+  MkOpt ['h'] ["help"]     (NoArg $ ShowHelp Common) "show common options",
+  MkOpt []    ["help-all"] (NoArg $ ShowHelp All)    "show all options"
+]
+
+commonOptDescrs = commonOptDescrs' ++ helpOptDescrs
+allOptDescrs    = commonOptDescrs' ++ extraOptDescrs ++ helpOptDescrs
+
+export
+usageHeader : String
+usageHeader = trim """
+quox [options] [file.quox ...]
+rawr
+"""
+
+export
+usage : List (OptDescr _) -> IO a
+usage ds = do
+  ignore $ fPutStr stderr $ usageInfo usageHeader ds
+  exitSuccess
+
+private
+applyAction : Options -> OptAction -> IO Options
+applyAction opts (ShowHelp Common) = usage commonOptDescrs
+applyAction opts (ShowHelp All)    = usage allOptDescrs
+applyAction opts (Err err)         = die err
+applyAction opts (Ok f)            = pure $ f opts
+
+export
+options : IO (String, Options, List String)
+options = do
+  app :: args <- getArgs
+    | [] => die "couldn't get command line arguments"
+  let res = getOpt Permute allOptDescrs args
+  unless (null res.errors) $
+    die $ trim $ concat res.errors
+  unless (null res.unrecognized) $
+    die "unrecognised options: \{joinBy ", " res.unrecognized}"
+  opts <- foldlM applyAction !defaultOpts res.options
+  pure (app, opts, res.nonOptions)

exe/Output.idr

@@ -0,0 +1,59 @@
+module Output
+
+import Quox.Pretty
+import Options
+
+import System.File
+import System
+
+public export
+data ConsoleChannel = COut | CErr
+
+export
+consoleHandle : ConsoleChannel -> File
+consoleHandle COut = stdout
+consoleHandle CErr = stderr
+
+public export
+data OpenFile = OConsole ConsoleChannel | OFile String File | ONone
+
+export
+toOutFile : OpenFile -> OutFile
+toOutFile (OConsole _) = Console
+toOutFile (OFile f _)  = File f
+toOutFile ONone        = NoOut
+
+export
+withFile : HasIO m => String -> (String -> FileError -> m a) ->
+           (OpenFile -> m a) -> m a
+withFile f catch act = Prelude.do
+  res <- withFile f WriteTruncate pure (Prelude.map Right . act . OFile f)
+  either (catch f) pure res
+
+export
+withOutFile : HasIO m => ConsoleChannel -> OutFile ->
+              (String -> FileError -> m a) -> (OpenFile -> m a) -> m a
+withOutFile _  (File f) catch act = withFile f catch act
+withOutFile ch Console  catch act = act $ OConsole ch
+withOutFile _  NoOut    catch act = act ONone
+
+
+
+private
+hlFor : HLType -> OutFile -> HL -> Highlight
+hlFor Guess Console = highlightSGR
+hlFor Guess _       = noHighlight
+hlFor NoHL  _       = noHighlight
+hlFor Term  _       = highlightSGR
+hlFor Html  _       = highlightHtml
+
+export
+runPretty : Options -> OutFile -> Eff Pretty a -> a
+runPretty opts file act =
+  runPrettyWith Outer opts.flavor (hlFor opts.hlType file) 2 act
+
+export
+die : HasIO io => (opts : LayoutOpts) -> Doc opts -> io a
+die opts err = do
+  ignore $ fPutStr stderr $ render opts err
+  exitFailure

exe/quox.ipkg

@@ -1,7 +1,7 @@
 package quox
 version = 0
 
-depends = base, contrib, elab-util, sop, quox-lib
+depends = base, contrib, elab-util, pretty-show, quox-lib
 
 executable = quox
 main = Main

golden-tests/Tests.idr

@@ -0,0 +1,15 @@
+module Tests
+
+import Test.Golden
+import Language.Reflection
+import System
+import System.Path
+
+%language ElabReflection
+
+projDir = %runElab idrisDir ProjectDir
+testDir = projDir </> "tests"
+
+tests = testsInDir { poolName = "quox golden tests", dirName = testDir }
+
+main = runner [!tests]

golden-tests/quox-golden-tests.ipkg

@@ -0,0 +1,4 @@
+package quox-golden-tests
+depends = quox, contrib, test
+executable = quox-golden-tests
+main = Tests

golden-tests/run-tests.sh

@@ -0,0 +1,10 @@
+#!/bin/bash
+
+set -e
+
+quox="$PWD/../exe/build/exec/quox"
+run_tests="$PWD/build/exec/quox-golden-tests"
+test -f "$quox"      || pack build quox
+test -f "$run_tests" || pack build quox-golden-tests
+
+"$run_tests" "$quox" "$@"

golden-tests/tests/empty/run

@@ -0,0 +1,2 @@
+. ../lib.sh
+scheme "$1" empty.quox

golden-tests/tests/eta-singleton/eta-sing.quox

@@ -0,0 +1,33 @@
+-- inspired by https://github.com/agda/agda/issues/2556
+
+postulate0 A : ★
+
+def0 ZZ : ★ = 0 ≡ 0 : ℕ
+
+def reflZ : ZZ = δ _ ⇒ 0
+
+
+namespace erased {
+  def0 ZZA : ★ = 0.ZZ → A
+
+  def propeq : (x : ZZA) → x ≡ (λ _ ⇒ x reflZ) : ZZA =
+    λ x ⇒ δ _ ⇒ x
+
+  def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
+    λ P x p ⇒ p
+}
+
+namespace unrestricted {
+  def0 ZZA : ★ = ω.ZZ → A
+
+  def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
+    λ P x p ⇒ p
+}
+
+namespace linear {
+  def0 ZZA : ★ = 1.ZZ → A
+
+  #[fail "λ _ ⇒ x reflZ is not equal to x"]
+  def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
+    λ P x p ⇒ p
+}

golden-tests/tests/eta-singleton/expected

@@ -0,0 +1,9 @@
+0.A : ★
+0.ZZ : ★
+ω.reflZ : ZZ
+0.erased.ZZA : ★
+ω.erased.propeq : 1.(x : erased.ZZA) → x ≡ (λ _ ⇒ x reflZ) : erased.ZZA
+ω.erased.defeq : 0.(P : 1.erased.ZZA → ★) → 0.(x : erased.ZZA) → 1.(P (λ _ ⇒ (x reflZ))) → P x
+0.unrestricted.ZZA : ★
+ω.unrestricted.defeq : 0.(P : 1.unrestricted.ZZA → ★) → 0.(x : unrestricted.ZZA) → 1.(P (λ _ ⇒ (x reflZ))) → P x
+0.linear.ZZA : ★

golden-tests/tests/eta-singleton/run

@@ -0,0 +1,2 @@
+. ../lib.sh
+check "$1" eta-sing.quox

golden-tests/tests/file-not-found/expected

@@ -0,0 +1,3 @@
+no location:
+couldn't load file nonexistent.quox
+File Not Found

golden-tests/tests/file-not-found/run

@@ -0,0 +1,2 @@
+. ../lib.sh
+check "$1" nonexistent.quox

golden-tests/tests/hello/expected

@@ -0,0 +1,12 @@
+0.IO : 1.★ → ★
+ω.print : 1.String → IO {ok}
+ω.main : IO {ok}
+IO = □
+print = scheme:(lambda (str) (builtin-io (display str) (newline)))
+#[main] main = print "hello 🐉"
+;; IO erased
+(define print
+   (lambda (str) (builtin-io (display str) (newline))))
+(define main
+   (print "hello \x1f409;"))
+hello 🐉

golden-tests/tests/hello/hello.quox

@@ -0,0 +1,7 @@
+def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
+
+#[compile-scheme "(lambda (str) (builtin-io (display str) (newline)))"]
+postulate print : String → IO {ok}
+
+#[main]
+def main = print "hello 🐉"

golden-tests/tests/hello/run

@@ -0,0 +1,2 @@
+. ../lib.sh
+compile_run "$1" hello.quox hello.ss

golden-tests/tests/ill-typed-main/expected

@@ -0,0 +1,3 @@
+ill-typed-main.quox:1:11-1:12:
+    when checking a function declared as #[main] has type 1.IOState → {𝑎} × IOState
+    expected a function type, but got ℕ

golden-tests/tests/ill-typed-main/ill-typed-main.quox

@@ -0,0 +1,2 @@
+#[main]
+def main : ℕ = 5

golden-tests/tests/ill-typed-main/run

@@ -0,0 +1,2 @@
+. ../lib.sh
+check "$1" ill-typed-main.quox

golden-tests/tests/it-5/expected

@@ -0,0 +1,4 @@
+ω.five : ℕ
+five = 5
+(define five
+   5)

golden-tests/tests/it-5/five.quox

@@ -0,0 +1 @@
+def five : ℕ = 5

golden-tests/tests/it-5/run

@@ -0,0 +1,2 @@
+. ../lib.sh
+scheme "$1" five.quox

golden-tests/tests/lib.sh

@@ -0,0 +1,18 @@
+FLAGS="--dump-check - --dump-erase - --dump-scheme - --color=none --width=100000"
+
+check() {
+  $1 $FLAGS "$2" -P check 2>&1
+}
+
+erase() {
+  $1 $FLAGS "$2" -P erase 2>&1
+}
+
+scheme() {
+  $1 $FLAGS "$2" -P scheme 2>&1
+}
+
+compile_run() {
+  $1 $FLAGS "$2" -o "$3" 2>&1
+  chezscheme --program "$3"
+}

golden-tests/tests/load/expected

@@ -0,0 +1,16 @@
+0.lib.IO : 1.★ → ★
+ω.lib.print : 1.String → lib.IO {ok}
+ω.lib.main : lib.IO {ok}
+ω.main : lib.IO {ok}
+lib.IO = □
+lib.print = scheme:(lambda (str) (builtin-io (display str) (newline)))
+lib.main = lib.print "hello 🐉"
+#[main] main = lib.main
+;; lib.IO erased
+(define lib.print
+   (lambda (str) (builtin-io (display str) (newline))))
+(define lib.main
+   (lib.print "hello \x1f409;"))
+(define main
+   lib.main)
+hello 🐉

golden-tests/tests/load/lib.quox

@@ -0,0 +1,8 @@
+namespace lib {
+def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
+
+#[compile-scheme "(lambda (str) (builtin-io (display str) (newline)))"]
+postulate print : String → IO {ok}
+
+def main = print "hello 🐉"
+}

golden-tests/tests/load/main.quox

@@ -0,0 +1,4 @@
+load "lib.quox"
+
+#[main]
+def main = lib.main

golden-tests/tests/load/run

@@ -0,0 +1,2 @@
+. ../lib.sh
+compile_run "$1" main.quox load.ss

golden-tests/tests/regularity/expected

@@ -0,0 +1 @@
+0.reggie : 1.(A : ★) → 1.(AA : A ≡ A : ★) → 1.(s : A) → 1.(P : 1.A → ★) → 1.(P (coe (𝑖 ⇒ AA @𝑖) @0 @1 s)) → P s

golden-tests/tests/regularity/regularity.quox

@@ -0,0 +1,12 @@
+-- this definition depends on coercion regularity in xtt. which is this
+-- (adapted to quox):
+--
+--           Ψ | Γ ⊢ 0 · A‹0/𝑖› = A‹1/𝑖› ⇐ ★
+-- ---------------------------------------------------------
+--  Ψ | Γ ⊢ π · coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A‹1/𝑖›) ⇒ A‹1/𝑖›
+--
+-- otherwise, the types P (coe ⋯ s) and P s are incompatible
+
+def0 reggie : (A : ★) → (AA : A ≡ A : ★) → (s : A) →
+              (P : A → ★) → P (coe (𝑖 ⇒ AA @𝑖) s) → P s =
+  λ A AA s P p ⇒ p

golden-tests/tests/regularity/run

@@ -0,0 +1,2 @@
+. ../lib.sh
+check "$1" regularity.quox

lib/Control/Monad/ST/Extra.idr

@@ -0,0 +1,82 @@
+module Control.Monad.ST.Extra
+
+import public Control.Monad.ST
+import Data.IORef
+import Control.MonadRec
+
+%default total
+
+export %inline
+MonadRec (ST s) where
+  tailRecM seed (Access rec) st f = MkST $ do
+    let MkST io = f seed st
+    case !io of
+      Done res           => pure res
+      Cont seed2 prf vst =>
+        let MkST io = tailRecM seed2 (rec seed2 prf) vst f in io
+
+
+public export
+interface HasST (0 m : Type -> Type -> Type) where
+  liftST : ST s a -> m s a
+
+export %inline HasST ST where liftST = id
+
+
+public export
+record STErr e s a where
+  constructor STE
+  fromSTErr : ST s (Either e a)
+
+export
+Functor (STErr e s) where
+  map f (STE e) = STE $ map f <$> e
+
+export
+Applicative (STErr e s) where
+  pure x = STE $ pure $ pure x
+  STE f <*> STE x = STE [|f <*> x|]
+
+export
+Monad (STErr e s) where
+  STE m >>= k = STE $ do
+    case !m of
+      Left  err => pure $ Left err
+      Right x   => fromSTErr $ k x
+
+export
+MonadRec (STErr e s) where
+  tailRecM s (Access r) x k = STE $ do
+    let STE m = k s x
+    case !m of
+      Left  err           => pure $ Left err
+      Right (Cont s' p y) => fromSTErr $ tailRecM s' (r s' p) y k
+      Right (Done y)      => pure $ Right y
+
+export
+runSTErr : (forall s. STErr e s a) -> Either e a
+runSTErr ste = runST $ fromSTErr ste
+
+export %inline HasST (STErr e) where liftST = STE . map Right
+
+export
+stLeft : e -> STErr e s a
+stLeft e = STE $ pure $ Left e
+
+
+parameters {auto _ : HasST m}
+  export %inline
+  newSTRef' : a -> m s (STRef s a)
+  newSTRef' x = liftST $ newSTRef x
+
+  export %inline
+  readSTRef' : STRef s a -> m s a
+  readSTRef' r = liftST $ readSTRef r
+
+  export %inline
+  writeSTRef' : STRef s a -> a -> m s ()
+  writeSTRef' r x = liftST $ writeSTRef r x
+
+  export %inline
+  modifySTRef' : STRef s a -> (a -> a) -> m s ()
+  modifySTRef' r f = liftST $ modifySTRef r f

lib/Quox/CharExtra.idr

@@ -166,3 +166,10 @@ isWhitespace ch = ch == '\t' || ch == '\r' || ch == '\n' || isSeparator ch
 export
 %foreign "scheme:string-normalize-nfc"
 normalizeNfc : String -> String
+
+
+export
+isCodepoint : Int -> Bool
+isCodepoint n =
+  n <= 0x10FFFF &&
+  not (n >= 0xD800 && n <= 0xDBFF || n >= 0xDC00 && n <= 0xDFFF)

lib/Quox/CheckBuiltin.idr

@@ -0,0 +1,33 @@
+||| check that special functions (e.g. `main`) have the expected type
+module Quox.CheckBuiltin
+
+import Quox.Syntax
+import Quox.Typing
+import Quox.Whnf
+
+%default total
+
+
+export covering
+expectSingleEnum : Definitions -> TyContext d n -> SQty -> Loc ->
+                   Term d n -> Eff Whnf ()
+expectSingleEnum defs ctx sg loc s = do
+  let err = delay $ ExpectedSingleEnum loc ctx.names s
+  cases <- wrapErr (const err) $ expectEnum defs ctx sg loc s
+  unless (length (SortedSet.toList cases) == 1) $ throw err
+
+||| `main` should have a type `1.IOState → {𝑎} × IOState`,
+||| for some (single) tag `𝑎`
+export covering
+expectMainType : Definitions -> Term 0 0 -> Eff Whnf ()
+expectMainType defs ty =
+  wrapErr (WrongBuiltinType Main) $ do
+    let ctx = TyContext.empty
+    (qty, arg, res) <- expectPi defs ctx SZero ty.loc ty
+    expectEqualQ ty.loc qty One
+    expectIOState defs ctx SZero arg.loc arg
+    let ctx = extendTy qty res.name arg ctx
+    (ret, st) <- expectSig defs ctx SZero res.loc res.term
+    expectSingleEnum defs ctx SZero ret.loc ret
+    let ctx = extendTy qty st.name ret ctx
+    expectIOState defs ctx SZero st.loc st.term

lib/Quox/Context.idr

@@ -6,6 +6,7 @@ import Quox.Name
 
 import Data.DPair
 import Data.Nat
+import Data.Singleton
 import Data.SnocList
 import Data.SnocVect
 import Data.Vect
@@ -57,6 +58,7 @@ public export
 tail : Context tm (S n) -> Context tm n
 tail = fst . unsnoc
 
+
 parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
   export
   toSnocListWith : Telescope tm _ _ -> SnocList a
@@ -107,10 +109,17 @@ fromSnocVect [<]       = [<]
 fromSnocVect (sx :< x) = fromSnocVect sx :< x
 
 
+public export
+tabulateLT : (n : Nat) -> ((i : Nat) -> (0 p : i `LT` n) => tm i) ->
+             Context tm n
+tabulateLT 0     f = [<]
+tabulateLT (S k) f =
+  tabulateLT k (\i => f i @{lteSuccRight %search}) :< f k @{reflexive}
+
 public export
 tabulate : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
-tabulate f 0     = [<]
-tabulate f (S k) = tabulate f k :< f k
+tabulate f n = tabulateLT n (\i => f i)
+-- [todo] fixup argument order lol
 
 public export
 replicate : (n : Nat) -> a -> Context' a n
@@ -180,6 +189,12 @@ export %hint
 succGT = LTESucc reflexive
 
 
+public export
+drop : (m : Nat) -> Context term (m + n) -> Context term n
+drop 0     ctx        = ctx
+drop (S m) (ctx :< _) = drop m ctx
+
+
 parameters {auto _ : Applicative f}
   export
   traverse : (forall n. tm1 n -> f (tm2 n)) ->
@@ -258,16 +273,17 @@ unzip3 (tel :< (x, y, z)) =
 
 
 public export
-lengthPrf : Telescope _ from to -> (len ** len + from = to)
-lengthPrf [<]        = (0 ** Refl)
+lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
+lengthPrf [<]        = Element 0 Refl
 lengthPrf (tel :< _) =
-  let len = lengthPrf tel in (S len.fst ** cong S len.snd)
+  let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
 
 export
-lengthPrf0 : Context _ to -> (len ** len = to)
+lengthPrf0 : Context _ to -> Singleton to
 lengthPrf0 ctx =
-  let len = lengthPrf ctx in
-  (len.fst ** rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
+  let Element len prf = lengthPrf ctx in
+  rewrite sym prf `trans` plusZeroRightNeutral len in
+  [|len|]
 
 public export %inline
 length : Telescope {} -> Nat
@@ -286,6 +302,10 @@ foldl : {0 acc : Nat -> Type} ->
 foldl f z [<]        = z
 foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
 
+export %inline
+foldl_ : (acc -> tm -> acc) -> acc -> Telescope' tm from to -> acc
+foldl_ f z tel = foldl f z tel
+
 export %inline
 foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
 foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
@@ -345,4 +365,4 @@ parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
 namespace BContext
   export
   toNames : BContext n -> SnocList BaseName
-  toNames = foldl (\xs, x => xs :< x.name) [<]
+  toNames = foldl (\xs, x => xs :< x.val) [<]

lib/Quox/Definition.idr

@@ -2,9 +2,12 @@ module Quox.Definition
 
 import public Quox.No
 import public Quox.Syntax
+import Quox.Displace
 import public Data.SortedMap
 import public Quox.Loc
+import Quox.Pretty
 import Control.Eff
+import Data.Singleton
 import Decidable.Decidable
 
 
@@ -23,18 +26,24 @@ namespace DefBody
 public export
 record Definition where
   constructor MkDef
-  qty   : GQty
-  type0 : Term 0 0
-  body0 : DefBody
-  loc_  : Loc
+  qty    : GQty
+  type0  : Term 0 0
+  body0  : DefBody
+  scheme : Maybe String
+  isMain : Bool
+  loc_   : Loc
 
 public export %inline
-mkPostulate : GQty -> (type0 : Term 0 0) -> Loc -> Definition
-mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_}
+mkPostulate : GQty -> (type0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
+              Definition
+mkPostulate qty type0 scheme isMain loc_ =
+  MkDef {qty, type0, body0 = Postulate, scheme, isMain, loc_}
 
 public export %inline
-mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition
-mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, loc_}
+mkDef : GQty -> (type0, term0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
+        Definition
+mkDef qty type0 term0 scheme isMain loc_ =
+  MkDef {qty, type0, body0 = Concrete term0, scheme, isMain, loc_}
 
 export Located Definition where def.loc = def.loc_
 export Relocatable Definition where setLoc loc = {loc_ := loc}
@@ -45,27 +54,51 @@ parameters {d, n : Nat}
   (.type) : Definition -> Term d n
   g.type = g.type0 // shift0 d // shift0 n
 
+  public export %inline
+  (.typeAt) : Definition -> Universe -> Term d n
+  g.typeAt u = displace u g.type
+
   public export %inline
   (.term) : Definition -> Maybe (Term d n)
   g.term = g.body0.term0 <&> \t => t // shift0 d // shift0 n
 
   public export %inline
-  toElim : Definition -> Maybe $ Elim d n
-  toElim def = pure $ Ann !def.term def.type def.loc
+  (.termAt) : Definition -> Universe -> Maybe (Term d n)
+  g.termAt u = displace u <$> g.term
+
+  public export %inline
+  toElim : Definition -> Universe -> Maybe $ Elim d n
+  toElim def u = pure $ Ann !(def.termAt u) (def.typeAt u) def.loc
+
+public export
+(.typeWith) : Definition -> Singleton d -> Singleton n -> Term d n
+g.typeWith (Val d) (Val n) = g.type
+
+public export
+(.typeWithAt) : Definition -> Singleton d -> Singleton n -> Universe -> Term d n
+g.typeWithAt d n u = displace u $ g.typeWith d n
+
+public export
+(.termWith) : Definition -> Singleton d -> Singleton n -> Maybe (Term d n)
+g.termWith (Val d) (Val n) = g.term
 
 
 public export %inline
 isZero : Definition -> Bool
-isZero g = g.qty.fst == Zero
+isZero g = g.qty == GZero
 
 
 public export
-data DefEnvTag = DEFS
+NDefinition : Type
+NDefinition = (Name, Definition)
 
 public export
 Definitions : Type
 Definitions = SortedMap Name Definition
 
+public export
+data DefEnvTag = DEFS
+
 public export
 DefsReader : Type -> Type
 DefsReader = ReaderL DEFS Definitions
@@ -74,7 +107,21 @@ public export
 DefsState : Type -> Type
 DefsState = StateL DEFS Definitions
 
+public export %inline
+lookupElim : {d, n : Nat} -> Name -> Universe -> Definitions -> Maybe (Elim d n)
+lookupElim x u defs = toElim !(lookup x defs) u
 
 public export %inline
-lookupElim : {d, n : Nat} -> Name -> Definitions -> Maybe (Elim d n)
-lookupElim x defs = toElim !(lookup x defs)
+lookupElim0 : Name -> Universe -> Definitions -> Maybe (Elim 0 0)
+lookupElim0 = lookupElim
+
+
+export
+prettyDef : {opts : LayoutOpts} -> Name -> Definition -> Eff Pretty (Doc opts)
+prettyDef name def = withPrec Outer $ do
+  qty   <- prettyQty def.qty.qty
+  dot   <- dotD
+  name  <- prettyFree name
+  colon <- colonD
+  type  <- prettyTerm [<] [<] def.type
+  hangDSingle (hsep [hcat [qty, dot, name], colon]) type

lib/Quox/Displace.idr

@@ -2,6 +2,8 @@ module Quox.Displace
 
 import Quox.Syntax
 
+%default total
+
 
 parameters (k : Universe)
   namespace Term
@@ -14,6 +16,7 @@ parameters (k : Universe)
 
   namespace Term
     doDisplace (TYPE l loc) = TYPE (k + l) loc
+    doDisplace (IOState loc) = IOState loc
     doDisplace (Pi qty arg res loc) =
       Pi qty (doDisplace arg) (doDisplaceS res) loc
     doDisplace (Lam body loc) = Lam (doDisplaceS body) loc
@@ -24,14 +27,18 @@ parameters (k : Universe)
     doDisplace (Eq ty l r loc) =
       Eq (doDisplaceDS ty) (doDisplace l) (doDisplace r) loc
     doDisplace (DLam body loc) = DLam (doDisplaceDS body) loc
-    doDisplace (Nat loc) = Nat loc
-    doDisplace (Zero loc) = Zero loc
+    doDisplace (NAT loc) = NAT loc
+    doDisplace (Nat n loc) = Nat n loc
     doDisplace (Succ p loc) = Succ (doDisplace p) loc
+    doDisplace (STRING loc) = STRING loc
+    doDisplace (Str s loc) = Str s loc
     doDisplace (BOX qty ty loc) = BOX qty (doDisplace ty) loc
     doDisplace (Box val loc) = Box (doDisplace val) loc
+    doDisplace (Let qty rhs body loc) =
+      Let qty (doDisplace rhs) (doDisplaceS body) loc
     doDisplace (E e) = E (doDisplace e)
     doDisplace (CloT (Sub t th)) =
-      CloT (Sub (doDisplace t) (map doDisplace th))
+      CloT (Sub (doDisplace t) (assert_total $ map doDisplace th))
     doDisplace (DCloT (Sub t th)) =
       DCloT (Sub (doDisplace t) th)
 
@@ -47,8 +54,11 @@ parameters (k : Universe)
     doDisplace (App fun arg loc) = App (doDisplace fun) (doDisplace arg) loc
     doDisplace (CasePair qty pair ret body loc) =
       CasePair qty (doDisplace pair) (doDisplaceS ret) (doDisplaceS body) loc
+    doDisplace (Fst pair loc) = Fst (doDisplace pair) loc
+    doDisplace (Snd pair loc) = Snd (doDisplace pair) loc
     doDisplace (CaseEnum qty tag ret arms loc) =
-      CaseEnum qty (doDisplace tag) (doDisplaceS ret) (map doDisplace arms) loc
+      CaseEnum qty (doDisplace tag) (doDisplaceS ret)
+               (assert_total $ map doDisplace arms) loc
     doDisplace (CaseNat qty qtyIH nat ret zero succ loc) =
       CaseNat qty qtyIH (doDisplace nat) (doDisplaceS ret)
               (doDisplace zero) (doDisplaceS succ) loc
@@ -65,9 +75,9 @@ parameters (k : Universe)
            (doDisplaceDS zero) (doDisplaceDS one) loc
     doDisplace (TypeCase ty ret arms def loc) =
       TypeCase (doDisplace ty) (doDisplace ret)
-               (map doDisplaceS arms) (doDisplace def) loc
+               (assert_total $ map doDisplaceS arms) (doDisplace def) loc
     doDisplace (CloE (Sub e th)) =
-      CloE (Sub (doDisplace e) (map doDisplace th))
+      CloE (Sub (doDisplace e) (assert_total $ map doDisplace th))
     doDisplace (DCloE (Sub e th)) =
       DCloE (Sub (doDisplace e) th)
 

lib/Quox/EffExtra.idr

@@ -2,6 +2,7 @@ module Quox.EffExtra
 
 import public Control.Eff
 
+import Control.Monad.ST.Extra
 import Data.IORef
 
 
@@ -26,48 +27,40 @@ local_ : Has (State s) fs => s -> Eff fs a -> Eff fs a
 local_ = localAt_ ()
 
 
-export
-hasDrop : (0 neq : Not (a = b)) ->
-          (ha : Has a fs) => (hb : Has b fs) =>
-          Has a (drop fs hb)
-hasDrop neq {ha = Z}    {hb = Z}    = void $ neq Refl
-hasDrop neq {ha = S ha} {hb = Z}    = ha
-hasDrop neq {ha = Z}    {hb = S hb} = Z
-hasDrop neq {ha = S ha} {hb = S hb} = S $ hasDrop neq {ha, hb}
+export %inline
+getsAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> a) -> Eff fs a
+getsAt lbl f = f <$> getAt lbl
+
+export %inline
+gets : Has (State s) fs => (s -> a) -> Eff fs a
+gets = getsAt ()
+
+
+export %inline
+stateAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> (a, s)) -> Eff fs a
+stateAt lbl f = do (res, x) <- getsAt lbl f; putAt lbl x $> res
+
+export %inline
+state : Has (State s) fs => (s -> (a, s)) -> Eff fs a
+state = stateAt ()
 
-private
-0 ioNotState : Not (IO = StateL _ _)
-ioNotState Refl impossible
 
 export
-runStateIORefAt : (0 lbl : tag) -> (Has IO fs, Has (StateL lbl s) fs) =>
-                  IORef s -> Eff fs a -> Eff (fs - StateL lbl s) a
-runStateIORefAt lbl ref act = do
-  let hh : Has IO (fs - StateL lbl s) := hasDrop ioNotState
-  (val, st) <- runStateAt lbl !(readIORef ref) act
-  writeIORef ref st $> val
-
-export %inline
-runStateIORef : (Has IO fs, Has (State s) fs) =>
-                IORef s -> Eff fs a -> Eff (fs - State s) a
-runStateIORef = runStateIORefAt ()
-
-
-export %inline
-evalStateAt : (0 lbl : tag) -> Has (StateL lbl s) fs =>
-              s -> Eff fs a -> Eff (fs - StateL lbl s) a
-evalStateAt lbl s act = map fst $ runStateAt lbl s act
-
-export %inline
-evalState : Has (State s) fs => s -> Eff fs a -> Eff (fs - State s) a
-evalState = evalStateAt ()
+handleStateIORef : HasIO m => IORef st -> StateL lbl st a -> m a
+handleStateIORef r Get     = readIORef r
+handleStateIORef r (Put s) = writeIORef r s
 
+export
+handleStateSTRef : HasST m => STRef s st -> StateL lbl st a -> m s a
+handleStateSTRef r Get     = liftST $ readSTRef r
+handleStateSTRef r (Put s) = liftST $ writeSTRef r s
 
 
 public export
 data Length : List a -> Type where
   Z : Length []
   S : Length xs -> Length (x :: xs)
+%builtin Natural Length
 
 export
 subsetWith : Length xs => (forall z. Has z xs -> Has z ys) ->
@@ -80,23 +73,77 @@ subsetSelf : Length xs => Subset xs xs
 subsetSelf = subsetWith id
 
 export
-subsetTail : Length xs => Subset xs (x :: xs)
-subsetTail = subsetWith S
+subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
+subsetTail _ = subsetWith S
+
 
 
--- [fixme] allow the error to be anywhere in the effect list
 export
-wrapErrAt : Length fs => (0 lbl : tag) -> (e -> e) ->
-            Eff (ExceptL lbl e :: fs) a -> Eff (ExceptL lbl e :: fs) a
-wrapErrAt lbl f act =
-  rethrowAt lbl . mapFst f =<< lift @{subsetTail} (runExceptAt lbl act)
+rethrowAtWith : (0 lbl : tag) -> Has (ExceptL lbl e') fs =>
+                (e -> e') -> Either e a -> Eff fs a
+rethrowAtWith lbl f = rethrowAt lbl . mapFst f
+
+export
+rethrowWith : Has (Except e') fs => (e -> e') -> Either e a -> Eff fs a
+rethrowWith = rethrowAtWith ()
+
+export
+wrapErr : Length fs => (e -> e') ->
+          Eff (ExceptL lbl e  :: fs) a ->
+          Eff (ExceptL lbl e' :: fs) a
+wrapErr f act =
+  catchAt lbl (throwAt lbl . f) @{S Z} $
+  lift @{subsetTail _} act
+
+
+export
+handleExcept : Functor m => (forall c. e -> m c) -> ExceptL lbl e a -> m a
+handleExcept thr (Err e) = thr e
+
+
+export
+handleReaderConst : Applicative m => r -> ReaderL lbl r a -> m a
+handleReaderConst x Ask = pure x
+
+export
+handleWriterSTRef : HasST m => STRef s (SnocList w) -> WriterL lbl w a -> m s a
+handleWriterSTRef ref (Tell w) = liftST $ modifySTRef ref (:< w)
+
+
+public export
+record IOErr e a where
+  constructor IOE
+  fromIOErr : IO (Either e a)
+
+export
+Functor (IOErr e) where
+  map f (IOE e) = IOE $ map f <$> e
+
+export
+Applicative (IOErr e) where
+  pure x = IOE $ pure $ pure x
+  IOE f <*> IOE x = IOE [|f <*> x|]
+
+export
+Monad (IOErr e) where
+  IOE m >>= k = IOE $ do
+    case !m of
+      Left  err => pure $ Left err
+      Right x   => fromIOErr $ k x
+
+export
+MonadRec (IOErr e) where
+  tailRecM s (Access r) x k = IOE $ do
+    let IOE m = k s x
+    case !m of
+      Left  err           => pure $ Left err
+      Right (Cont s' p y) => fromIOErr $ tailRecM s' (r s' p) y k
+      Right (Done y)      => pure $ Right y
+
+export
+HasIO (IOErr e) where
+  liftIO = IOE . map Right
 
 export %inline
-wrapErr : Length fs => (e -> e) ->
-          Eff (Except e :: fs) a -> Eff (Except e :: fs) a
-wrapErr = wrapErrAt ()
-
-
-export %inline
-runIO : (MonadRec io, HasIO io) => Eff [IO] a -> io a
-runIO act = runEff act [liftIO]
+ioLeft : e -> IOErr e a
+ioLeft = IOE . pure . Left

lib/Quox/FreeVars.idr

@@ -0,0 +1,310 @@
+module Quox.FreeVars
+
+import Quox.Syntax.Term.Base
+import Data.Maybe
+import Data.Nat
+import Data.Singleton
+import Data.SortedSet
+import Derive.Prelude
+
+%language ElabReflection
+
+
+public export
+FreeVars' : Nat -> Type
+FreeVars' n = Context' Bool n
+
+public export
+record FreeVars n where
+  constructor FV
+  vars : FreeVars' n
+%name FreeVars xs
+
+%runElab deriveIndexed "FreeVars" [Eq, Ord, Show]
+
+
+export %inline
+(||) : FreeVars n -> FreeVars n -> FreeVars n
+FV s || FV t = FV $ zipWith (\x, y => x || y) s t
+
+export %inline
+(&&) : FreeVars n -> FreeVars n -> FreeVars n
+FV s && FV t = FV $ zipWith (\x, y => x && y) s t
+
+export %inline Semigroup (FreeVars n) where (<+>) = (||)
+
+export %inline [AndS] Semigroup (FreeVars n) where (<+>) = (&&)
+
+export
+only : {n : Nat} -> Var n -> FreeVars n
+only i = FV $ only' i where
+  only' : {n' : Nat} -> Var n' -> FreeVars' n'
+  only' VZ     = replicate (pred n') False :< True
+  only' (VS i) = only' i :< False
+
+export %inline
+all : {n : Nat} -> FreeVars n
+all = FV $ replicate n True
+
+export %inline
+none : {n : Nat} -> FreeVars n
+none = FV $ replicate n False
+
+
+export %inline
+uncons : FreeVars (S n) -> (FreeVars n, Bool)
+uncons (FV (xs :< x)) = (FV xs, x)
+
+
+export %inline {n : Nat} -> Monoid (FreeVars n) where neutral = none
+export %inline [AndM] {n : Nat} -> Monoid (FreeVars n) where neutral = all
+
+
+private
+self : {n : Nat} -> Context' (FreeVars n) n
+self = tabulate (\i => FV $ tabulate (== i) n) n
+
+export
+shift : forall from, to. Shift from to -> FreeVars from -> FreeVars to
+shift by (FV xs) = FV $ shift' by xs where
+  shift' : Shift from' to' -> FreeVars' from' -> FreeVars' to'
+  shift' SZ      ctx = ctx
+  shift' (SS by) ctx = shift' by ctx :< False
+
+
+export
+fromSet : {n : Nat} -> SortedSet (Var n) -> FreeVars n
+fromSet vs = FV $ tabulateLT n $ \i => contains (V i) vs
+
+export
+toSet : {n : Nat} -> FreeVars n -> SortedSet (Var n)
+toSet (FV vs) =
+  foldl_ (\s, i => maybe s (\i => insert i s) i) empty $
+  zipWith (\i, b => guard b $> i) (tabulateLT n V) vs
+
+
+public export
+interface HasFreeVars (0 tm : Nat -> Type) where
+  constructor HFV
+  fv : {n : Nat} -> tm n -> FreeVars n
+
+public export
+interface HasFreeDVars (0 tm : TermLike) where
+  constructor HFDV
+  fdv : {d, n : Nat} -> tm d n -> FreeVars d
+
+public export %inline
+fvWith : HasFreeVars tm => Singleton n -> tm n -> FreeVars n
+fvWith (Val n) = fv
+
+public export %inline
+fdvWith : HasFreeDVars tm => Singleton d -> Singleton n -> tm d n -> FreeVars d
+fdvWith (Val d) (Val n) = fdv
+
+export
+Fdv : (0 tm : TermLike) -> {n : Nat} ->
+      HasFreeDVars tm => HasFreeVars (\d => tm d n)
+Fdv tm @{HFDV fdv} = HFV fdv
+
+
+export
+fvEach : {n1, n2 : Nat} -> HasFreeVars env =>
+         Subst env n1 n2 -> Context' (Lazy (FreeVars n2)) n1
+fvEach (Shift by) = map (delay . shift by) self
+fvEach (t ::: th) = fvEach th :< fv t
+
+export
+fdvEach : {d, n1, n2 : Nat} -> HasFreeDVars env =>
+          Subst (env d) n1 n2 -> Context' (Lazy (FreeVars d)) n1
+fdvEach (Shift by) = replicate n1 none
+fdvEach (t ::: th) = fdvEach th :< fdv t
+
+
+export
+HasFreeVars Dim where
+  fv (K _ _) = none
+  fv (B i _) = only i
+
+
+export
+{s : Nat} -> HasFreeVars tm => HasFreeVars (Scoped s tm) where
+  fv (S _ (Y body)) = FV $ drop s (fv body).vars
+  fv (S _ (N body)) = fv body
+
+export
+implementation [DScope]
+  {s : Nat} -> HasFreeDVars tm =>
+  HasFreeDVars (\d, n => Scoped s (\d' => tm d' n) d)
+where
+  fdv (S _ (Y body)) = FV $ drop s (fdv body).vars
+  fdv (S _ (N body)) = fdv body
+
+export
+fvD : {0 tm : TermLike} -> {n : Nat} -> (forall d. HasFreeVars (tm d)) =>
+      Scoped s (\d => tm d n) d -> FreeVars n
+fvD (S _ (Y body)) = fv body
+fvD (S _ (N body)) = fv body
+
+export
+fdvT : HasFreeDVars tm => {s, d, n : Nat} -> Scoped s (tm d) n -> FreeVars d
+fdvT (S _ (Y body)) = fdv body
+fdvT (S _ (N body)) = fdv body
+
+
+private
+guardM : Monoid a => Bool -> Lazy a -> a
+guardM b x = if b then x else neutral
+
+export
+implementation
+  (HasFreeVars tm, HasFreeVars env) =>
+  HasFreeVars (WithSubst tm env)
+where
+  fv (Sub term subst) =
+    let Val from = getFrom subst in
+    foldMap (uncurry guardM) $ zipWith (,) (fv term).vars (fvEach subst)
+
+export
+implementation [WithSubst]
+  ((forall d. HasFreeVars (tm d)), HasFreeDVars tm, HasFreeDVars env) =>
+  HasFreeDVars (\d => WithSubst (tm d) (env d))
+where
+  fdv (Sub term subst) =
+    let Val from = getFrom subst in
+    fdv term <+>
+    foldMap (uncurry guardM) (zipWith (,) (fv term).vars (fdvEach subst))
+
+
+export HasFreeVars (Term d)
+export HasFreeVars (Elim d)
+
+export
+HasFreeVars (Term d) where
+  fv (TYPE    {})             = none
+  fv (IOState {})             = none
+  fv (Pi      {arg, res, _})  = fv arg <+> fv res
+  fv (Lam     {body, _})      = fv body
+  fv (Sig     {fst, snd, _})  = fv fst <+> fv snd
+  fv (Pair    {fst, snd, _})  = fv fst <+> fv snd
+  fv (Enum    {})             = none
+  fv (Tag     {})             = none
+  fv (Eq      {ty, l, r, _})  = fvD ty <+> fv l <+> fv r
+  fv (DLam    {body, _})      = fvD body
+  fv (NAT     {})             = none
+  fv (Nat     {})             = none
+  fv (Succ    {p, _})         = fv p
+  fv (STRING  {})             = none
+  fv (Str     {})             = none
+  fv (BOX     {ty, _})        = fv ty
+  fv (Box     {val, _})       = fv val
+  fv (Let     {rhs, body, _}) = fv rhs <+> fv body
+  fv (E       e)              = fv e
+  fv (CloT    s)              = fv s
+  fv (DCloT   s)              = fv s.term
+
+export
+HasFreeVars (Elim d) where
+  fv (F {}) = none
+  fv (B i _) = only i
+  fv (App {fun, arg, _}) = fv fun <+> fv arg
+  fv (CasePair {pair, ret, body, _}) = fv pair <+> fv ret <+> fv body
+  fv (Fst pair _) = fv pair
+  fv (Snd pair _) = fv pair
+  fv (CaseEnum {tag, ret, arms, _}) =
+    fv tag <+> fv ret <+> foldMap fv (values arms)
+  fv (CaseNat {nat, ret, zero, succ, _}) =
+    fv nat <+> fv ret <+> fv zero <+> fv succ
+  fv (CaseBox {box, ret, body, _}) =
+    fv box <+> fv ret <+> fv body
+  fv (DApp {fun, _}) = fv fun
+  fv (Ann {tm, ty, _}) = fv tm <+> fv ty
+  fv (Coe {ty, val, _}) = fvD ty <+> fv val
+  fv (Comp {ty, val, zero, one, _}) =
+    fv ty <+> fv val <+> fvD zero <+> fvD one
+  fv (TypeCase {ty, ret, arms, def, _}) =
+    fv ty <+> fv ret <+> fv def <+> foldMap (\x => fv x.snd) (toList arms)
+  fv (CloE s) = fv s
+  fv (DCloE s) = fv s.term
+
+
+
+private
+expandDShift : {d1 : Nat} -> Shift d1 d2 -> Loc -> Context' (Dim d2) d1
+expandDShift by loc = tabulateLT d1 (\i => BV i loc // by)
+
+private
+expandDSubst : {d1 : Nat} -> DSubst d1 d2 -> Loc -> Context' (Dim d2) d1
+expandDSubst (Shift by) loc = expandDShift by loc
+expandDSubst (t ::: th) loc = expandDSubst th loc :< t
+
+
+private
+fdvSubst' : {d1, d2, n : Nat} -> (Located2 tm, HasFreeDVars tm) =>
+            tm d1 n -> DSubst d1 d2 -> FreeVars d2
+fdvSubst' t th =
+  fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th t.loc)
+where
+  maybeOnly : {d : Nat} -> Bool -> Dim d -> FreeVars d
+  maybeOnly True (B i _) = only i
+  maybeOnly _    _       = none
+
+private
+fdvSubst : {d, n : Nat} -> (Located2 tm, HasFreeDVars tm) =>
+           WithSubst (\d => tm d n) Dim d -> FreeVars d
+fdvSubst (Sub t th) = let Val from = getFrom th in fdvSubst' t th
+
+
+export HasFreeDVars Term
+export HasFreeDVars Elim
+
+export
+HasFreeDVars Term where
+  fdv (TYPE    {})             = none
+  fdv (IOState {})             = none
+  fdv (Pi      {arg, res, _})  = fdv arg <+> fdvT res
+  fdv (Lam     {body, _})      = fdvT body
+  fdv (Sig     {fst, snd, _})  = fdv fst <+> fdvT snd
+  fdv (Pair    {fst, snd, _})  = fdv fst <+> fdv snd
+  fdv (Enum    {})             = none
+  fdv (Tag     {})             = none
+  fdv (Eq      {ty, l, r, _})  = fdv @{DScope} ty <+> fdv l <+> fdv r
+  fdv (DLam    {body, _})      = fdv @{DScope} body
+  fdv (NAT     {})             = none
+  fdv (Nat     {})             = none
+  fdv (Succ    {p, _})         = fdv p
+  fdv (STRING  {})             = none
+  fdv (Str     {})             = none
+  fdv (BOX     {ty, _})        = fdv ty
+  fdv (Box     {val, _})       = fdv val
+  fdv (Let     {rhs, body, _}) = fdv rhs <+> fdvT body
+  fdv (E       e)              = fdv e
+  fdv (CloT    s)              = fdv s @{WithSubst}
+  fdv (DCloT   s)              = fdvSubst s
+
+export
+HasFreeDVars Elim where
+  fdv (F {}) = none
+  fdv (B {}) = none
+  fdv (App {fun, arg, _}) = fdv fun <+> fdv arg
+  fdv (CasePair {pair, ret, body, _}) = fdv pair <+> fdvT ret <+> fdvT body
+  fdv (Fst pair _) = fdv pair
+  fdv (Snd pair _) = fdv pair
+  fdv (CaseEnum {tag, ret, arms, _}) =
+    fdv tag <+> fdvT ret <+> foldMap fdv (values arms)
+  fdv (CaseNat {nat, ret, zero, succ, _}) =
+    fdv nat <+> fdvT ret <+> fdv zero <+> fdvT succ
+  fdv (CaseBox {box, ret, body, _}) =
+    fdv box <+> fdvT ret <+> fdvT body
+  fdv (DApp {fun, arg, _}) =
+    fdv fun <+> fv arg
+  fdv (Ann {tm, ty, _}) =
+    fdv tm <+> fdv ty
+  fdv (Coe {ty, p, q, val, _}) =
+    fdv @{DScope} ty <+> fv p <+> fv q <+> fdv val
+  fdv (Comp {ty, p, q, val, r, zero, one, _}) =
+    fdv ty <+> fv p <+> fv q <+> fdv val <+>
+    fv r <+> fdv @{DScope} zero <+> fdv @{DScope} one
+  fdv (TypeCase {ty, ret, arms, def, _}) =
+    fdv ty <+> fdv ret <+> fdv def <+> foldMap (\x => fdvT x.snd) (toList arms)
+  fdv (CloE s) = fdv s @{WithSubst}
+  fdv (DCloE s) = fdvSubst s

lib/Quox/Loc.idr

@@ -1,6 +1,7 @@
 ||| file locations
 module Quox.Loc
 
+import Quox.PrettyValExtra
 import public Text.Bounded
 import Data.SortedMap
 import Derive.Prelude
@@ -12,12 +13,12 @@ public export
 FileName : Type
 FileName = String
 
-%runElab derive "Bounds" [Ord]
+%runElab derive "Bounds" [Ord, PrettyVal]
 
 public export
 data Loc_ = NoLoc | YesLoc FileName Bounds
 %name Loc_ loc
-%runElab derive "Loc_" [Eq, Ord, Show]
+%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal]
 
 
 ||| a wrapper for locations which are always considered equal
@@ -39,6 +40,18 @@ public export %inline
 makeLoc : FileName -> Bounds -> Loc
 makeLoc = L .: YesLoc
 
+public export %inline
+loc : FileName -> (sl, sc, el, ec : Int) -> Loc
+loc file sl sc el ec = makeLoc file $ MkBounds sl sc el ec
+
+export
+PrettyVal Loc where
+  prettyVal (L NoLoc) = Con "noLoc" []
+  prettyVal (L (YesLoc file (MkBounds sl sc el ec))) =
+    Con "loc" [prettyVal file,
+               prettyVal sl, prettyVal sc,
+               prettyVal el, prettyVal ec]
+
 
 export
 onlyStart_ : Loc_ -> Loc_
@@ -105,6 +118,11 @@ export %inline
 or : Loc -> Loc -> Loc
 or (L l1) (L l2) = L $ l1 `or_` l2
 
+export %inline
+extendOr : Loc -> Loc -> Loc
+extendOr l1 l2 = (l1 `extendL` l2) `or` l2
+
+
 
 public export
 interface Located a where (.loc) : a -> Loc
@@ -113,9 +131,22 @@ public export
 0 Located1 : (a -> Type) -> Type
 Located1 f = forall x. Located (f x)
 
+public export
+0 Located2 : (a -> b -> Type) -> Type
+Located2 f = forall x, y. Located (f x y)
+
 public export
 interface Located a => Relocatable a where setLoc : Loc -> a -> a
 
 public export
 0 Relocatable1 : (a -> Type) -> Type
 Relocatable1 f = forall x. Relocatable (f x)
+
+public export
+0 Relocatable2 : (a -> b -> Type) -> Type
+Relocatable2 f = forall x, y. Relocatable (f x y)
+
+
+export
+locs : Located a => Foldable t => t a -> Loc
+locs = foldl (\loc, y => loc `extendOr` y.loc) noLoc

lib/Quox/Log.idr

@@ -0,0 +1,317 @@
+module Quox.Log
+
+import Quox.Loc
+import Quox.Pretty
+import Quox.PrettyValExtra
+
+import Data.So
+import Data.DPair
+import Data.Maybe
+import Data.List1
+import Control.Eff
+import Control.Monad.ST.Extra
+import Data.IORef
+import System.File
+import Derive.Prelude
+
+%default total
+%language ElabReflection
+
+
+public export %inline
+maxLogLevel : Nat
+maxLogLevel = 100
+
+public export %inline
+logCategories : List String
+logCategories = ["whnf", "equal", "check"]
+
+public export %inline
+isLogLevel : Nat -> Bool
+isLogLevel l = l <= maxLogLevel
+
+public export
+IsLogLevel : Nat -> Type
+IsLogLevel l = So $ isLogLevel l
+
+public export %inline
+isLogCategory : String -> Bool
+isLogCategory cat = cat `elem` logCategories
+
+public export
+IsLogCategory : String -> Type
+IsLogCategory cat = So $ isLogCategory cat
+
+-- Q: why are you using `So` instead of `LT` and `Elem`
+-- A: ① proof search gives up before finding a proof of e.g. ``99 `LT` 100``
+--      (i.e. `LTESucc⁹⁹ LTEZero`)
+--    ② the proofs aren't looked at in any way, i just wanted to make sure the
+--      list of categories was consistent everywhere
+
+
+||| a verbosity level from 0–100. higher is noisier. each log entry has a
+||| verbosity level above which it will be printed, chosen, uh, based on vibes.
+public export
+LogLevel : Type
+LogLevel = Subset Nat IsLogLevel
+
+||| a logging category, like "check" (type checking), "whnf", or whatever.
+public export
+LogCategory : Type
+LogCategory = Subset String IsLogCategory
+
+
+public export %inline
+toLogLevel : Nat -> Maybe LogLevel
+toLogLevel l =
+  case choose $ isLogLevel l of
+    Left  y => Just $ Element l y
+    Right _ => Nothing
+
+public export %inline
+toLogCategory : String -> Maybe LogCategory
+toLogCategory c =
+  case choose $ isLogCategory c of
+    Left  y => Just $ Element c y
+    Right _ => Nothing
+
+
+||| verbosity levels for each category, if they differ from the default
+public export
+LevelMap : Type
+LevelMap = List (LogCategory, LogLevel)
+
+-- Q: why `List` instead of `SortedMap`
+-- A: oof ouch my constant factors (maybe this one was more obvious)
+
+
+public export
+record LogLevels where
+  constructor MkLogLevels
+  defLevel : LogLevel
+  levels   : LevelMap
+%name LogLevels lvls
+%runElab derive "LogLevels" [Eq, Show, PrettyVal]
+
+public export
+LevelStack : Type
+LevelStack = List LogLevels
+
+public export %inline
+defaultLevel : LogLevel
+defaultLevel = Element 0 Oh
+
+export %inline
+defaultLogLevels : LogLevels
+defaultLogLevels = MkLogLevels defaultLevel []
+
+export %inline
+initStack : LevelStack
+initStack = []
+
+export %inline
+getLevel1 : LogCategory -> LogLevels -> LogLevel
+getLevel1 cat (MkLogLevels def lvls) = fromMaybe def $ lookup cat lvls
+
+export %inline
+getLevel : LogCategory -> LevelStack -> LogLevel
+getLevel cat (lvls :: _) = getLevel1 cat lvls
+getLevel cat []          = defaultLevel
+
+export %inline
+getCurLevels : LevelStack -> LogLevels
+getCurLevels (lvls :: _) = lvls
+getCurLevels []          = defaultLogLevels
+
+
+public export
+LogDoc : Type
+LogDoc = Doc (Opts {lineLength = 80})
+
+
+private %inline
+replace : Eq a => a -> b -> List (a, b) -> List (a, b)
+replace k v kvs = (k, v) :: filter (\y => fst y /= k) kvs
+
+private %inline
+mergeLeft : Eq a => List (a, b) -> List (a, b) -> List (a, b)
+mergeLeft l r = foldl (\lst, (k, v) => replace k v lst) r l
+
+
+public export
+data PushArg =
+    SetDefault LogLevel
+  | SetCat     LogCategory LogLevel
+  | SetAll     LogLevel
+%runElab derive "PushArg" [Eq, Ord, Show, PrettyVal]
+%name PushArg push
+
+export %inline
+applyPush : LogLevels -> PushArg -> LogLevels
+applyPush lvls (SetDefault def)     = {defLevel := def} lvls
+applyPush lvls (SetCat     cat lvl) = {levels   $= replace cat lvl} lvls
+applyPush lvls (SetAll     lvl)     = MkLogLevels lvl []
+
+export %inline
+fromPush : PushArg -> LogLevels
+fromPush = applyPush defaultLogLevels
+
+
+public export
+record LogMsg where
+  constructor (:>)
+  level : Nat
+  {auto 0 levelOk : IsLogLevel level}
+  message : Lazy LogDoc
+infix 0 :>
+%name Log.LogMsg msg
+
+public export
+data LogL : (lbl : tag) -> Type -> Type where
+  ||| print some log messages
+  SayMany : (cat : LogCategory) -> (loc : Loc) ->
+            (msgs : List LogMsg) -> LogL lbl ()
+  ||| set some verbosity levels
+  Push : (push : List PushArg) -> LogL lbl ()
+  ||| restore the previous verbosity levels.
+  ||| returns False if the stack was already empty
+  Pop : LogL lbl Bool
+  ||| returns the current verbosity levels
+  CurLevels : LogL lbl LogLevels
+
+public export
+Log : Type -> Type
+Log = LogL ()
+
+parameters (0 lbl : tag) {auto _ : Has (LogL lbl) fs}
+  public export %inline
+  sayManyAt : (cat : String) -> (0 catOk : IsLogCategory cat) =>
+              Loc -> List LogMsg -> Eff fs ()
+  sayManyAt cat loc msgs {catOk} =
+    send $ SayMany {lbl} (Element cat catOk) loc msgs
+
+  public export %inline
+  sayAt : (cat : String) -> (0 catOk : IsLogCategory cat) =>
+          (lvl : Nat)    -> (0 lvlOk : IsLogLevel lvl) =>
+          Loc -> Lazy LogDoc -> Eff fs ()
+  sayAt cat lvl loc msg = sayManyAt cat loc [lvl :> msg]
+
+  public export %inline
+  pushAt : List PushArg -> Eff fs ()
+  pushAt lvls = send $ Push {lbl} lvls
+
+  public export %inline
+  push1At : PushArg -> Eff fs ()
+  push1At lvl = pushAt [lvl]
+
+  public export %inline
+  popAt : Eff fs Bool
+  popAt = send $ Pop {lbl}
+
+  public export %inline
+  curLevelsAt : Eff fs LogLevels
+  curLevelsAt = send $ CurLevels {lbl}
+
+parameters {auto _ : Has Log fs}
+  public export %inline
+  sayMany : (cat : String) -> (0 catOk : IsLogCategory cat) =>
+            Loc -> List LogMsg -> Eff fs ()
+  sayMany = sayManyAt ()
+
+  public export %inline
+  say : (cat : String) -> (0 _ : IsLogCategory cat) =>
+        (lvl : Nat)    -> (0 _ : IsLogLevel lvl) =>
+        Loc -> Lazy LogDoc -> Eff fs ()
+  say = sayAt ()
+
+  public export %inline
+  push : List PushArg -> Eff fs ()
+  push = pushAt ()
+
+  public export %inline
+  push1 : PushArg -> Eff fs ()
+  push1 = push1At ()
+
+  public export %inline
+  pop : Eff fs Bool
+  pop = popAt ()
+
+  public export %inline
+  curLevels : Eff fs LogLevels
+  curLevels = curLevelsAt ()
+
+
+||| handles a `Log` effect with an existing `State` and `Writer`
+export %inline
+handleLogSW : (0 s : ts) -> (0 w : tw) ->
+              Has (StateL s LevelStack) fs => Has (WriterL w LogDoc) fs =>
+              LogL tag a -> Eff fs a
+handleLogSW s w = \case
+  Push push => modifyAt s $ \lst =>
+    foldl applyPush (fromMaybe defaultLogLevels (head' lst)) push :: lst
+  Pop => stateAt s $ maybe (False, []) (True,) . tail'
+  SayMany cat loc msgs => do
+    catLvl <- getsAt s $ fst . getLevel cat
+    let loc = runPretty $ prettyLoc loc
+    for_ msgs $ \(lvl :> msg) => when (lvl <= catLvl) $ tellAt w $
+      hcat [loc, text cat.fst, "@", pshow lvl, ":"] <++> msg
+  CurLevels =>
+    getsAt s getCurLevels
+
+export %inline
+handleLogSW_ : LogL tag a -> Eff [State LevelStack, Writer LogDoc] a
+handleLogSW_ = handleLogSW () ()
+
+export %inline
+handleLogIO : HasIO m => MonadRec m =>
+              (FileError -> m ()) -> IORef LevelStack -> File ->
+              LogL tag a -> m a
+handleLogIO th lvls h act =
+  runEff (handleLogSW_ act) [handleStateIORef lvls, handleWriter {m} printMsg]
+where printMsg : LogDoc -> m ()
+      printMsg msg = fPutStr h (render _ msg) >>= either th pure
+
+export %inline
+handleLogST : HasST m => MonadRec (m s) =>
+              STRef s (SnocList LogDoc) -> STRef s LevelStack ->
+              LogL tag a -> m s a
+handleLogST docs lvls act =
+  runEff (handleLogSW_ act) [handleStateSTRef lvls, handleWriterSTRef docs]
+
+export %inline
+handleLogDiscard : (0 s : ts) -> Has (StateL s Nat) fs =>
+                   LogL tag a -> Eff fs a
+handleLogDiscard s = \case
+  Push _     => modifyAt s S
+  Pop        => stateAt s $ \k => (k > 0, pred k)
+  SayMany {} => pure ()
+  CurLevels  => pure defaultLogLevels
+
+export %inline
+handleLogDiscard_ : LogL tag a -> Eff [State Nat] a
+handleLogDiscard_ = handleLogDiscard ()
+
+export %inline
+handleLogDiscardST : HasST m => MonadRec (m s) => STRef s Nat ->
+                     LogL tag a -> m s a
+handleLogDiscardST ref act =
+  runEff (handleLogDiscard_ act) [handleStateSTRef ref]
+
+export %inline
+handleLogDiscardIO : HasIO m => MonadRec m => IORef Nat ->
+                     LogL tag a -> m a
+handleLogDiscardIO ref act =
+  runEff (handleLogDiscard_ act) [handleStateIORef ref]
+
+
+||| approximate the push/pop effects in a discarded log by trimming a stack or
+||| repeating its most recent element
+export %inline
+fixupDiscardedLog : Nat -> LevelStack -> LevelStack
+fixupDiscardedLog want lvls =
+  let len = length lvls in
+  case compare len want of
+    EQ => lvls
+    GT => drop (len `minus` want) lvls
+    LT => let new = fromMaybe defaultLogLevels $ head' lvls in
+          replicate (want `minus` len) new ++ lvls

lib/Quox/Name.idr

@@ -2,6 +2,7 @@ module Quox.Name
 
 import Quox.Loc
 import Quox.CharExtra
+import Quox.PrettyValExtra
 import public Data.SnocList
 import Data.List
 import Control.Eff
@@ -23,7 +24,7 @@ data BaseName
 = UN String         -- user-given name
 | MN String NameSuf -- machine-generated name
 | Unused            -- "_"
-%runElab derive "BaseName" [Eq, Ord]
+%runElab derive "BaseName" [Eq, Ord, PrettyVal]
 
 export
 baseStr : BaseName -> String
@@ -42,14 +43,14 @@ Mods = SnocList String
 
 public export
 record Name where
-  constructor MakeName
+  constructor MkName
   mods : Mods
   base : BaseName
 %runElab derive "Name" [Eq, Ord]
 
 public export %inline
 unq : BaseName -> Name
-unq = MakeName [<]
+unq = MkName [<]
 
 ||| add some namespaces to the beginning of a name
 public export %inline
@@ -63,31 +64,31 @@ PBaseName = String
 
 public export
 record PName where
-  constructor MakePName
+  constructor MkPName
   mods : Mods
   base : PBaseName
-%runElab derive "PName" [Eq, Ord]
+%runElab derive "PName" [Eq, Ord, PrettyVal]
 
 export %inline
 fromPName : PName -> Name
-fromPName p = MakeName p.mods $ UN p.base
+fromPName p = MkName p.mods $ UN p.base
 
 export %inline
 toPName : Name -> PName
-toPName p = MakePName p.mods $ baseStr p.base
+toPName p = MkPName p.mods $ baseStr p.base
 
 export %inline
 fromPBaseName : PBaseName -> Name
-fromPBaseName = MakeName [<] . UN
+fromPBaseName = MkName [<] . UN
 
 export
 Show PName where
-  show (MakePName mods base) =
+  show (MkPName mods base) =
     show $ concat $ intersperse "." $ toList $ mods :< base
 
 export Show Name where show = show . toPName
 
-export FromString PName where fromString = MakePName [<]
+export FromString PName where fromString = MkPName [<]
 
 export FromString Name where fromString = fromPBaseName
 
@@ -95,9 +96,9 @@ export FromString Name where fromString = fromPBaseName
 public export
 record BindName where
   constructor BN
-  name : BaseName
+  val  : BaseName
   loc_ : Loc
-%runElab derive "BindName" [Eq, Ord, Show]
+%runElab derive "BindName" [Eq, Ord, Show, PrettyVal]
 
 export Located BindName where n.loc = n.loc_
 export Relocatable BindName where setLoc loc (BN x _) = BN x loc
@@ -115,7 +116,7 @@ export
 fromListP : List1 String -> PName
 fromListP (x ::: xs) = go [<] x xs where
   go : SnocList String -> String -> List String -> PName
-  go mods x []        = MakePName mods x
+  go mods x []        = MkPName mods x
   go mods x (y :: ys) = go (mods :< x) y ys
 
 export %inline
@@ -169,14 +170,6 @@ public export
 NameGen : Type -> Type
 NameGen = StateL GEN NameSuf
 
-export
-runNameGenWith : Has NameGen fs =>
-                 NameSuf -> Eff fs a -> Eff (fs - NameGen) (a, NameSuf)
-runNameGenWith = runStateAt GEN
-
-export
-runNameGen : Has NameGen fs => Eff fs a -> Eff (fs - NameGen) a
-runNameGen = map fst . runNameGenWith 0
 
 ||| generate a fresh name with the given base
 export
@@ -186,15 +179,13 @@ mn base = do
   modifyAt GEN S
   pure $ MN base i
 
-||| generate a fresh binding name with the given base and
-||| (optionally) location `loc`
+||| generate a fresh binding name with the given base and location `loc`
 export
-mnb : Has NameGen fs =>
-      PBaseName -> {default noLoc loc : Loc} -> Eff fs BindName
-mnb base = pure $ BN !(mn base) loc
+mnb : Has NameGen fs => PBaseName -> Loc -> Eff fs BindName
+mnb base loc = pure $ BN !(mn base) loc
 
 export
 fresh : Has NameGen fs => BindName -> Eff fs BindName
-fresh (BN (UN str)   loc) = mnb str {loc}
-fresh (BN (MN str k) loc) = mnb str {loc}
-fresh (BN Unused     loc) = mnb "x" {loc}
+fresh (BN (UN str)   loc) = mnb str loc
+fresh (BN (MN str k) loc) = mnb str loc
+fresh (BN Unused     loc) = mnb "x" loc

lib/Quox/NatExtra.idr

@@ -4,6 +4,7 @@ import public Data.Nat
 import Data.Nat.Division
 import Data.SnocList
 import Data.Vect
+import Data.String
 
 %default total
 
@@ -52,6 +53,42 @@ parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char)
   showAtBase : Nat -> String
   showAtBase = pack . showAtBase' []
 
-export
-showHex : Nat -> String
-showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
+namespace Nat
+  export
+  showHex : Nat -> String
+  showHex = showAtBase $ fromList $ unpack "0123456789abcdef"
+
+namespace Int
+  export
+  showHex : Int -> String
+  showHex x =
+    if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x)
+
+
+namespace Int
+  export
+  fromHexit : Char -> Maybe Int
+  fromHexit c =
+    if      c >= '0' && c <= '9' then Just $ ord c - ord '0'
+    else if c >= 'a' && c <= 'f' then Just $ ord c - ord 'a' + 10
+    else if c >= 'A' && c <= 'F' then Just $ ord c - ord 'A' + 10
+    else Nothing
+
+  private
+  fromHex' : Int -> String -> Maybe Int
+  fromHex' acc str = case strM str of
+    StrNil       => Just acc
+    StrCons c cs => fromHex' (16 * acc + !(fromHexit c)) (assert_smaller str cs)
+
+  export %inline
+  fromHex : String -> Maybe Int
+  fromHex str = do guard $ str /= ""; fromHex' 0 str
+
+namespace Nat
+  export
+  fromHexit : Char -> Maybe Nat
+  fromHexit = map cast . Int.fromHexit
+
+  export %inline
+  fromHex : String -> Maybe Nat
+  fromHex = map cast . Int.fromHex

lib/Quox/No.idr

@@ -52,3 +52,8 @@ export %inline
 nchoose : (b : Bool) -> Either (So b) (No b)
 nchoose True  = Left  Oh
 nchoose False = Right Ah
+
+export
+0 notYesNo : {f : Dec p} -> Not p -> No (isYes f)
+notYesNo {f = Yes y} g = absurd $ g y
+notYesNo {f = No  n} g = Ah

lib/Quox/Parser/FromParser.idr

@@ -1,39 +1,31 @@
 ||| take freshly-parsed input, scope check, type check, add to env
 module Quox.Parser.FromParser
 
+import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
+
+import Quox.Pretty
 import Quox.Parser.Syntax
 import Quox.Parser.Parser
+import public Quox.Parser.LoadFile
 import Quox.Typechecker
+import Quox.CheckBuiltin
 
 import Data.List
 import Data.Maybe
 import Data.SnocVect
 import Quox.EffExtra
+import Control.Monad.ST.Extra
 
 import System.File
 import System.Path
 import Data.IORef
 
-import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
-
-%default total
 
 %hide Typing.Error
 %hide Lexer.Error
 %hide Parser.Error
 
-
-public export
-NDefinition : Type
-NDefinition = (Name, Definition)
-
-public export
-IncludePath : Type
-IncludePath = List String
-
-public export
-SeenFiles : Type
-SeenFiles = SortedSet String
+%default total
 
 
 public export
@@ -41,27 +33,50 @@ data StateTag = NS | SEEN
 
 public export
 FromParserPure : List (Type -> Type)
-FromParserPure =
-  [Except Error, DefsState, StateL NS Mods, NameGen]
-
-public export
-LoadFile' : List (Type -> Type)
-LoadFile' = [IO, StateL SEEN SeenFiles, Reader IncludePath]
-
-public export
-LoadFile : List (Type -> Type)
-LoadFile = LoadFile' ++ [Except Error]
+FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
 
 public export
 FromParserIO : List (Type -> Type)
-FromParserIO = FromParserPure ++ LoadFile'
+FromParserIO = FromParserPure ++ [LoadFile]
+
+
+public export
+record PureParserResult a where
+  constructor MkPureParserResult
+  val       : a
+  suf       : NameSuf
+  defs      : Definitions
+  log       : SnocList LogDoc
+  logLevels : LevelStack
+
+export
+fromParserPure : Mods -> NameSuf -> Definitions -> LevelStack ->
+                 Eff FromParserPure a -> Either Error (PureParserResult a)
+fromParserPure ns suf defs lvls act = runSTErr $ do
+  suf  <- newSTRef' suf
+  defs <- newSTRef' defs
+  log  <- newSTRef' [<]
+  lvls <- newSTRef' lvls
+  res  <- runEff act $ with Union.(::)
+    [handleExcept $ \e => stLeft e,
+     handleStateSTRef defs,
+     handleStateSTRef !(newSTRef' ns),
+     handleStateSTRef suf,
+     handleLogST log lvls]
+  pure $ MkPureParserResult {
+    val       = res,
+    suf       = !(readSTRef' suf),
+    defs      = !(readSTRef' defs),
+    log       = !(readSTRef' log),
+    logLevels = !(readSTRef' lvls)
+  }
 
 
 parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
            (xs : Context' PatVar n)
   private
   fromBaseName : PBaseName -> m a
-  fromBaseName x = maybe (f $ MakePName [<] x) b $
+  fromBaseName x = maybe (f $ MkPName [<] x) b $
                    Context.find (\y => y.name == Just x) xs
 
   private
@@ -113,11 +128,10 @@ fromV : Context' PatVar d -> Context' PatVar n ->
         PName -> Maybe Universe -> Loc -> Eff FromParserPure (Term d n)
 fromV ds ns x u loc = fromName bound free ns x where
   bound : Var n -> Eff FromParserPure (Term d n)
-  bound i = do whenJust u $ \u => throw $ DisplacedBoundVar loc x
-               pure $ E $ B i loc
+  bound i = unless (isNothing u) (throw $ DisplacedBoundVar loc x) $> BT i loc
+
   free : PName -> Eff FromParserPure (Term d n)
-  free x = do x <- avoidDim ds loc x
-              resolveName !(getAt NS) loc x u
+  free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
 
 mutual
   export
@@ -127,6 +141,9 @@ mutual
     TYPE k loc =>
       pure $ TYPE k loc
 
+    IOState loc =>
+      pure $ IOState loc
+
     Pi pi x s t loc =>
       Pi (fromPQty pi)
         <$> fromPTermWith ds ns s
@@ -157,17 +174,26 @@ mutual
         <*> fromPTermTScope ds ns [< x, y] body
         <*> pure loc
 
+    Fst pair loc =>
+      map E $ Fst <$> fromPTermElim ds ns pair <*> pure loc
+
+    Snd pair loc =>
+      map E $ Snd <$> fromPTermElim ds ns pair <*> pure loc
+
     Case pi tag (r, ret) (CaseEnum arms _) loc =>
       map E $ CaseEnum (fromPQty pi)
         <$> fromPTermElim ds ns tag
         <*> fromPTermTScope ds ns [< r] ret
-        <*> assert_total fromPTermEnumArms ds ns arms
+        <*> assert_total fromPTermEnumArms loc ds ns arms
         <*> pure loc
 
-    Nat loc => pure $ Nat loc
-    Zero loc => pure $ Zero loc
+    NAT loc => pure $ NAT loc
+    Nat n loc => pure $ Nat n loc
     Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|]
 
+    STRING loc => pure $ STRING loc
+    Str str loc => pure $ Str str loc
+
     Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
       map E $ CaseNat (fromPQty pi) (fromPQty pi')
         <$> fromPTermElim ds ns nat
@@ -176,12 +202,11 @@ mutual
         <*> fromPTermTScope ds ns [< s, ih] suc
         <*> pure loc
 
-    Enum strs loc =>
-      let set = SortedSet.fromList strs in
-      if length strs == length (SortedSet.toList set) then
-        pure $ Enum set loc
-      else
-        throw $ DuplicatesInEnum loc strs
+    Enum strs loc => do
+      let set = SortedSet.fromList strs
+      unless (length strs == length (SortedSet.toList set)) $
+        throw $ DuplicatesInEnumType loc strs
+      pure $ Enum set loc
 
     Tag str loc => pure $ Tag str loc
 
@@ -238,13 +263,22 @@ mutual
         <*> fromPTermDScope ds ns [< j1] val1
         <*> pure loc
 
+    Let (qty, x, rhs) body loc =>
+      Let (fromPQty qty)
+        <$> fromPTermElim ds ns rhs
+        <*> fromPTermTScope ds ns [< x] body
+        <*> pure loc
+
   private
-  fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
+  fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n ->
                       List (PTagVal, PTerm) ->
                       Eff FromParserPure (CaseEnumArms d n)
-  fromPTermEnumArms ds ns =
-    map SortedMap.fromList .
-    traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
+  fromPTermEnumArms loc ds ns arms = do
+    res <- SortedMap.fromList <$>
+           traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms
+    unless (length (keys res) == length arms) $
+      throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms)
+    pure res
 
   private
   fromPTermElim : Context' PatVar d -> Context' PatVar n ->
@@ -271,7 +305,7 @@ mutual
                     Eff FromParserPure (DScopeTermN s d n)
   fromPTermDScope ds ns xs t =
     if all isUnused xs then
-      SN <$> fromPTermWith ds ns t
+      SN {f = \d => Term d n} <$> fromPTermWith ds ns t
     else
       DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
 
@@ -282,72 +316,110 @@ fromPTerm = fromPTermWith [<] [<]
 
 
 export
-globalPQty : Loc -> (q : Qty) -> Eff [Except Error] (So $ isGlobal q)
-globalPQty loc pi = case choose $ isGlobal pi of
-  Left  y => pure y
-  Right _ => throw $ QtyNotGlobal loc pi
-
+globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty
+globalPQty (PQ pi loc) = case toGlobal pi of
+  Just g  => pure g
+  Nothing => throw $ QtyNotGlobal loc pi
 
 export
-fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name
+fromPBaseNameNS : Has (StateL NS Mods) fs => PBaseName -> Eff fs Name
 fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
 
+
 private
-liftTC : TC a -> Eff FromParserPure a
-liftTC act = do
-  res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act
-  rethrow $ mapFst WrapTypeError res
+liftTC : Eff TC a -> Eff FromParserPure a
+liftTC tc = runEff tc $ with Union.(::)
+  [handleExcept $ \e => throw $ WrapTypeError e,
+   handleReaderConst !(getAt DEFS),
+   \g => send g,
+   \g => send g]
+
+private
+liftWhnf : Eff Whnf a -> Eff FromParserPure a
+liftWhnf tc = runEff tc $ with Union.(::)
+  [handleExcept $ \e => throw $ WrapTypeError e,
+   \g => send g,
+   \g => send g]
+
+private
+addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition
+addDef name def = do
+  modifyAt DEFS $ insert name def
+  pure (name, def)
+
 
 export covering
 fromPDef : PDefinition -> Eff FromParserPure NDefinition
-fromPDef (MkPDef qty pname ptype pterm defLoc) = do
-  name <- lift $ fromPBaseNameNS pname
-  qtyGlobal <- lift $ globalPQty qty.loc qty.val
-  let gqty = Element qty.val qtyGlobal
-      sqty = globalToSubj gqty
-  type <- lift $ traverse fromPTerm ptype
-  term <- lift $ fromPTerm pterm
-  case type of
-    Just type => do
-      liftTC $ checkTypeC empty type Nothing
-      liftTC $ ignore $ checkC empty sqty term type
-      let def = mkDef gqty type term defLoc
-      modifyAt DEFS $ insert name def
-      pure (name, def)
-    Nothing => do
-      let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term
-      res <- liftTC $ inferC empty sqty elim
-      let def = mkDef gqty res.type term defLoc
-      modifyAt DEFS $ insert name def
-      pure (name, def)
+fromPDef def = do
+  name <- fromPBaseNameNS def.name
+  defs <- getAt DEFS
+  when (isJust $ lookup name defs) $ do
+    throw $ AlreadyExists def.loc name
+  gqty <- globalPQty def.qty
+  let sqty = globalToSubj gqty
+  case def.body of
+    PConcrete ptype pterm => do
+      type <- traverse fromPTerm ptype
+      term <- fromPTerm pterm
+      type <- case type of
+        Just type => do
+          ignore $ liftTC $ do
+            checkTypeC empty type Nothing
+            checkC empty sqty term type
+          pure type
+        Nothing => do
+          let E elim = term
+            | _ => throw $ AnnotationNeeded term.loc empty term
+          res <- liftTC $ inferC empty sqty elim
+          pure res.type
+      when def.main $ liftWhnf $ expectMainType defs type
+      addDef name $ mkDef gqty type term def.scheme def.main def.loc
+    PPostulate ptype => do
+      type <- fromPTerm ptype
+      addDef name $ mkPostulate gqty type def.scheme def.main def.loc
+
+
+public export
+data HasFail = NoFail | AnyFail | FailWith String
+
+export covering
+expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error
+expectFail loc act = do
+  gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels
+  case fromParserPure ns gen defs (singleton lvl) act of
+    Left  err => pure err
+    Right _   => throw $ ExpectedFail loc
+
+export covering
+maybeFail : Monoid a =>
+            PFail -> Loc -> Eff FromParserPure a -> Eff FromParserPure a
+maybeFail PSucceed         _   act = act
+maybeFail PFailAny         loc act = expectFail loc act $> neutral
+maybeFail (PFailMatch str) loc act = do
+    err <- expectFail loc act
+    let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e
+    if str `isInfixOf` renderInfinite msg
+       then pure neutral
+       else throw $ WrongFail str err loc
 
 export covering
 fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
-fromPDecl (PDef def) = singleton <$> fromPDef def
+fromPDecl (PDef def) =
+  maybeFail def.fail def.loc $ singleton <$> fromPDef def
 fromPDecl (PNs  ns)  =
+  maybeFail ns.fail ns.loc $
   localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
-
-
-export covering
-loadFile : Loc -> String -> Eff LoadFile (Maybe String)
-loadFile loc file =
-  if contains file !(getAt SEEN) then
-    pure Nothing
-  else do
-    Just ifile <- firstExists (map (</> file) !ask)
-      | Nothing => throw $ LoadError loc file FileNotFound
-    case !(readFile ifile) of
-      Right res => modifyAt SEEN (insert file) $> Just res
-      Left  err => throw $ LoadError loc ifile err
+fromPDecl (PPrag prag) =
+  case prag of
+    PLogPush p _ => Log.push p $> []
+    PLogPop    _ => Log.pop    $> []
 
 mutual
   export covering
   loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
   loadProcessFile loc file =
-    case !(lift $ loadFile loc file) of
-      Just inp => do
-        tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
-        concat <$> traverse fromPTopLevel tl
+    case !(loadFile loc file) of
+      Just tl => concat <$> traverse fromPTopLevel tl
       Nothing => pure []
 
   ||| populates the `defs` field of the state
@@ -355,28 +427,3 @@ mutual
   fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
   fromPTopLevel (PD    decl)     = lift $ fromPDecl decl
   fromPTopLevel (PLoad file loc) = loadProcessFile loc file
-
-export
-fromParserPure : NameSuf -> Definitions ->
-                 Eff FromParserPure a ->
-                 (Either Error (a, Definitions), NameSuf)
-fromParserPure suf defs act =
-  extract $
-  runStateAt GEN suf $
-  runExcept $
-  evalStateAt NS [<] $
-  runStateAt DEFS defs act
-
-export
-fromParserIO : (MonadRec io, HasIO io) =>
-               IncludePath ->
-               IORef SeenFiles -> IORef NameSuf -> IORef Definitions ->
-               Eff FromParserIO a -> io (Either Error a)
-fromParserIO inc seen suf defs act =
-  runIO $
-  runStateIORefAt GEN suf $
-  runExcept $
-  evalStateAt NS [<] $
-  runStateIORefAt SEEN seen $
-  runStateIORefAt DEFS defs $
-  runReader inc act

lib/Quox/Parser/FromParser/Error.idr

@@ -1,11 +1,14 @@
 module Quox.Parser.FromParser.Error
 
 import Quox.Parser.Parser
+import Quox.Parser.LoadFile
 import Quox.Typing
 import System.File
 
 import Quox.Pretty
 
+%default total
+
 %hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)
 
 
@@ -21,26 +24,34 @@ ParseError = Parser.Error
 public export
 data Error =
     AnnotationNeeded Loc (NameContexts d n) (Term d n)
-  | DuplicatesInEnum Loc (List TagVal)
+  | DuplicatesInEnumType Loc (List TagVal)
+  | DuplicatesInEnumCase Loc (List TagVal)
   | TermNotInScope Loc Name
   | DimNotInScope Loc PBaseName
   | QtyNotGlobal Loc Qty
   | DimNameInTerm Loc PBaseName
   | DisplacedBoundVar Loc PName
   | WrapTypeError TypeError
-  | LoadError Loc String FileError
+  | AlreadyExists Loc Name
+  | LoadError Loc FilePath FileError
+  | ExpectedFail Loc
+  | SchemeOnNamespace Loc Mods
+  | MainOnNamespace Loc Mods
+  | WrongFail String Error Loc
   | WrapParseError String ParseError
 
 
 export
 prettyLexError : {opts : _} -> String -> LexError -> Eff Pretty (Doc opts)
 prettyLexError file (Err reason line col char) = do
-  let loc = makeLoc file (MkBounds line col line col)
   reason <- case reason of
-    EndInput    => pure "unexpected end of input"
-    NoRuleApply => pure $ text "unrecognised character: \{show char}"
+    Other msg => pure $ text msg
+    NoRuleApply => case char of
+      Just char => pure $ text "unrecognised character: \{show char}"
+      Nothing   => pure $ text "unexpected end of input"
     ComposeNotClosing (sl, sc) (el, ec) => pure $
       hsep ["unterminated token at", !(prettyBounds (MkBounds sl sc el ec))]
+  let loc = makeLoc file (MkBounds line col line col)
   pure $ vappend !(prettyLoc loc) reason
 
 export
@@ -61,19 +72,23 @@ prettyParseError file (ParseError errs) =
     traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
 
 
-parameters (showContext : Bool)
+parameters {opts : LayoutOpts} (showContext : Bool)
   export
-  prettyError : {opts : _} -> Error -> Eff Pretty (Doc opts)
+  prettyError : Error -> Eff Pretty (Doc opts)
   prettyError (AnnotationNeeded loc ctx tm) =
     [|vappend (prettyLoc loc)
         (hangD "type annotation needed on"
                !(prettyTerm ctx.dnames ctx.tnames tm))|]
     -- [todo] print the original PTerm instead
 
-  prettyError (DuplicatesInEnum loc tags) =
+  prettyError (DuplicatesInEnumType loc tags) =
     [|vappend (prettyLoc loc)
         (hangD "duplicate tags in enum type" !(prettyEnum tags))|]
 
+  prettyError (DuplicatesInEnumCase loc tags) =
+    [|vappend (prettyLoc loc)
+        (hangD "duplicate arms in enum case" !(prettyEnum tags))|]
+
   prettyError (DimNotInScope loc i) =
     [|vappend (prettyLoc loc)
         (pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]
@@ -100,10 +115,32 @@ parameters (showContext : Bool)
   prettyError (WrapTypeError err) =
     Typing.prettyError showContext $ trimContext 2 err
 
-  prettyError (LoadError loc str err) = pure $
+  prettyError (AlreadyExists loc name) = pure $
     vsep [!(prettyLoc loc),
-          "couldn't load file" <++> text str,
+          sep [!(prettyFree name), "has already been defined"]]
+
+  prettyError (LoadError loc file err) = pure $
+    vsep [!(prettyLoc loc),
+          "couldn't load file" <++> text file,
           text $ show err]
 
+  prettyError (ExpectedFail loc) = pure $
+    vsep [!(prettyLoc loc), "expected error"]
+
+  prettyError (SchemeOnNamespace loc ns) = pure $
+    vsep [!(prettyLoc loc),
+          hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns),
+                "cannot have #[compile-scheme] attached"]]
+
+  prettyError (MainOnNamespace loc ns) = pure $
+    vsep [!(prettyLoc loc),
+          hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns),
+                "cannot have #[main] attached"]]
+
+  prettyError (WrongFail str err loc) = pure $
+    vsep [!(prettyLoc loc),
+          "wrong error, expected to match", !(hl Constant $ text "\"\{str}\""),
+          "but got", !(prettyError err)]
+
   prettyError (WrapParseError file err) =
     prettyParseError file err

lib/Quox/Parser/Lexer.idr

@@ -1,6 +1,7 @@
 module Quox.Parser.Lexer
 
 import Quox.CharExtra
+import Quox.NatExtra
 import Quox.Name
 import Data.String.Extra
 import Data.SortedMap
@@ -19,7 +20,7 @@ import Derive.Prelude
 ||| @ Reserved reserved token
 ||| @ Name name, possibly qualified
 ||| @ Nat nat literal
-||| @ String string literal
+||| @ Str string literal
 ||| @ Tag tag literal
 ||| @ TYPE "Type" or "★" with ascii nat directly after
 ||| @ Sup superscript or ^ number (displacement, or universe for ★)
@@ -34,16 +35,27 @@ data Token =
   | Sup Nat
 %runElab derive "Token" [Eq, Ord, Show]
 
--- token or whitespace
+||| token or whitespace
+||| @ Skip whitespace, comments, etc
+||| @ Invalid a token which failed a post-lexer check
+|||           (e.g. a qualified name containing a keyword)
+||| @ T a well formed token
 public export
-0 TokenW : Type
-TokenW = Maybe Token
+data ExtToken = Skip | Invalid String String | T Token
+%runElab derive "ExtToken" [Eq, Ord, Show]
 
 
+public export
+data ErrorReason =
+    NoRuleApply
+  | ComposeNotClosing (Int, Int) (Int, Int)
+  | Other String
+%runElab derive "ErrorReason" [Eq, Ord, Show]
+
 public export
 record Error where
   constructor Err
-  reason    : StopReason
+  reason    : ErrorReason
   line, col : Int
   ||| `Nothing` if the error is at the end of the input
   char      : Maybe Char
@@ -52,77 +64,118 @@ record Error where
 
 
 private
-skip : Lexer -> Tokenizer TokenW
-skip t = match t $ const Nothing
+skip : Lexer -> Tokenizer ExtToken
+skip t = match t $ const Skip
 
 private
-match : Lexer -> (String -> Token) -> Tokenizer TokenW
-match t f = Tokenizer.match t (Just . f)
-%hide Tokenizer.match
+tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
+tmatch t f = match t (T . f)
 
 
-private
-name : Tokenizer TokenW
-name = match name $ Name . fromListP . split (== '.') . normalizeNfc
-
-||| [todo] escapes other than `\"` and (accidentally) `\\`
 export
-fromStringLit : String -> String
-fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where
-  go : List Char -> List Char
-  go []                = []
-  go ['\\']            = ['\\'] -- i guess???
-  go ('\\' :: c :: cs) = c :: go cs
-  go (c :: cs)         = c :: go cs
+fromStringLit : (String -> Token) -> String -> ExtToken
+fromStringLit f str =
+  case go $ unpack $ drop 1 $ dropLast 1 str of
+    Left  err => Invalid err str
+    Right ok  => T $ f $ pack ok
+where
+  Interpolation Char where interpolate = singleton
+
+  go, hexEscape : List Char -> Either String (List Char)
+
+  go []                   = Right []
+  go ['\\']               = Left "string ends with \\"
+  go ('\\' :: 'n'  :: cs) = ('\n' ::) <$> go cs
+  go ('\\' :: 't'  :: cs) = ('\t' ::) <$> go cs
+  go ('\\' :: 'x'  :: cs) = hexEscape cs
+  go ('\\' :: 'X'  :: cs) = hexEscape cs
+  go ('\\' :: '\\' :: cs) = ('\\' ::) <$> go cs
+  go ('\\' :: '"'  :: cs) = ('"'  ::) <$> go cs
+  -- [todo] others
+  go ('\\' :: c :: _)     = Left "unknown escape '\{c}'"
+  go (c :: cs)            = (c ::) <$> go cs
+
+  hexEscape cs =
+    case break (== ';') cs of
+      (hs, ';' :: rest) => do
+        let hs = pack hs
+        let Just c = Int.fromHex hs
+          | Nothing => Left #"invalid hex string "\#{hs}" in escape"#
+        if isCodepoint c
+           then (chr c ::) <$> go (assert_smaller cs rest)
+           else Left "codepoint \{hs} out of range"
+      _ => Left "unterminated hex escape"
 
 private
-string : Tokenizer TokenW
-string = match stringLit (Str . fromStringLit)
+string : Tokenizer ExtToken
+string = match stringLit $ fromStringLit Str
+
+
+%hide binLit
+%hide octLit
+%hide hexLit
 
 private
-nat : Tokenizer TokenW
-nat = match (some (range '0' '9')) (Nat . cast)
+nat : Tokenizer ExtToken
+nat = match  hexLit fromHexLit
+  <|> tmatch decLit fromDecLit
+where
+  withUnderscores : Lexer -> Lexer
+  withUnderscores l = l <+> many (opt (is '_') <+> l)
+
+  withoutUnderscores : String -> String
+  withoutUnderscores = pack . go . unpack where
+    go : List Char -> List Char
+    go []          = []
+    go ('_' :: cs) =      go cs
+    go (c   :: cs) = c :: go cs
+
+  decLit =
+    withUnderscores (range '0' '9') <+> reject idContEnd
+
+  hexLit =
+    approx "0x" <+>
+    withUnderscores (range '0' '9' <|> range 'a' 'f' <|> range 'A' 'F') <+>
+    reject idContEnd
+
+  fromDecLit : String -> Token
+  fromDecLit = Nat . cast . withoutUnderscores
+
+  fromHexLit : String -> ExtToken
+  fromHexLit str =
+    maybe (Invalid "invalid hex sequence" str) (T . Nat) $
+    fromHex $ withoutUnderscores $ drop 2 str
+
 
 private
-tag : Tokenizer TokenW
-tag = match (is '\'' <+> name)      (Tag . drop 1)
-  <|> match (is '\'' <+> stringLit) (Tag . fromStringLit . drop 1)
+tag : Tokenizer ExtToken
+tag = tmatch (is '\'' <+> name)      (Tag . drop 1)
+  <|>  match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1)
 
 
-
-private %inline
-fromSub : Char -> Char
-fromSub c = case c of
-  '₀' => '0'; '₁' => '1'; '₂' => '2'; '₃' => '3'; '₄' => '4'
-  '₅' => '5'; '₆' => '6'; '₇' => '7'; '₈' => '8'; '₉' => '9'; _ => c
-
 private %inline
 fromSup : Char -> Char
 fromSup c = case c of
   '⁰' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '⁴' => '4'
   '⁵' => '5'; '⁶' => '6'; '⁷' => '7'; '⁸' => '8'; '⁹' => '9'; _ => c
 
-private %inline
-subToNat : String -> Nat
-subToNat = cast . pack . map fromSub . unpack
-
 private %inline
 supToNat : String -> Nat
 supToNat = cast . pack . map fromSup . unpack
 
--- ★0, Type0. base ★/Type is a Reserved
+-- ★0, Type0. base ★/Type is a Reserved and ★¹/Type¹ are sequences of two tokens
 private
-universe : Tokenizer TokenW
+universe : Tokenizer ExtToken
 universe = universeWith "★" <|> universeWith "Type" where
-  universeWith : String -> Tokenizer TokenW
+  universeWith : String -> Tokenizer ExtToken
   universeWith pfx =
     let len = length pfx in
-    match (exact pfx <+> digits) (TYPE . cast . drop len)
+    tmatch (exact pfx <+> digits) (TYPE . cast . drop len)
 
 private
-sup : Tokenizer TokenW
-sup = match (some $ pred isSupDigit) (Sup . supToNat)
-  <|> match (is '^' <+> digits)      (Sup . cast . drop 1)
+sup : Tokenizer ExtToken
+sup = tmatch (some $ pred isSupDigit) (Sup . supToNat)
+  <|> tmatch (is '^' <+> digits)      (Sup . cast . drop 1)
 
 
 private %inline
@@ -134,9 +187,11 @@ namespace Reserved
   ||| description of a reserved symbol
   ||| @ Word a reserved word (must not be followed by letters, digits, etc)
   ||| @ Sym a reserved symbol (must not be followed by symbolic chars)
-  ||| @ Punc a character that doesn't show up in names (brackets, etc)
+  ||| @ Punc a character that doesn't show up in names (brackets, etc);
+  |||        also a sequence ending in one of those, like `#[`, since the
+  |||        difference relates to lookahead
   public export
-  data Reserved1 = Word String | Sym String | Punc Char
+  data Reserved1 = Word String | Sym String | Punc String
   %runElab derive "Reserved1" [Eq, Ord, Show]
 
   ||| description of a token that might have unicode & ascii-only aliases
@@ -145,17 +200,14 @@ namespace Reserved
   %runElab derive "Reserved" [Eq, Ord, Show]
 
   public export
-  Sym1, Word1 : String -> Reserved
-  Sym1 = Only . Sym
+  Sym1, Word1, Punc1 : String -> Reserved
+  Sym1  = Only . Sym
   Word1 = Only . Word
-
-  public export
-  Punc1 : Char -> Reserved
   Punc1 = Only . Punc
 
 public export
 resString1 : Reserved1 -> String
-resString1 (Punc x) = singleton x
+resString1 (Punc x) = x
 resString1 (Word w) = w
 resString1 (Sym  s) = s
 
@@ -166,17 +218,23 @@ resString : Reserved -> String
 resString (Only r)   = resString1 r
 resString (r `Or` _) = resString1 r
 
+||| return both representative strings for a token description
+public export
+resString2 : Reserved -> List String
+resString2 (Only r)   = [resString1 r]
+resString2 (r `Or` s) = [resString1 r, resString1 s]
+
 private
-resTokenizer1 : Reserved1 -> String -> Tokenizer TokenW
+resTokenizer1 : Reserved1 -> String -> Tokenizer ExtToken
 resTokenizer1 r str =
   let res : String -> Token := const $ Reserved str in
-  case r of Word w => match (exact w <+> reject idContEnd) res
-            Sym s  => match (exact s <+> reject symCont)   res
-            Punc x => match (is x)                         res
+  case r of Word w => tmatch (exact w <+> reject idContEnd) res
+            Sym  s => tmatch (exact s <+> reject symCont)   res
+            Punc x => tmatch (exact x)                      res
 
 ||| match a reserved token
 export
-resTokenizer : Reserved -> Tokenizer TokenW
+resTokenizer : Reserved -> Tokenizer ExtToken
 resTokenizer (Only r)   = resTokenizer1 r (resString1 r)
 resTokenizer (r `Or` s) =
   resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
@@ -188,8 +246,8 @@ resTokenizer (r `Or` s) =
 public export
 reserved : List Reserved
 reserved =
-  [Punc1 '(', Punc1 ')', Punc1 '[', Punc1 ']', Punc1 '{', Punc1 '}',
-   Punc1 ',', Punc1 ';',
+  [Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}",
+   Punc1 ",", Punc1 ";", Punc1 "#[", Punc1 "#![",
    Sym1 "@",
    Sym1 ":",
    Sym "⇒" `Or` Sym "=>",
@@ -197,12 +255,16 @@ reserved =
    Sym "×" `Or` Sym "**",
    Sym "≡" `Or` Sym "==",
    Sym "∷" `Or` Sym "::",
-   Punc1 '.',
+   Punc1 ".",
    Word1 "case",
    Word1 "case0", Word1 "case1",
    Word "caseω" `Or` Word "case#",
    Word1 "return",
    Word1 "of",
+   Word1 "let", Word1 "in",
+   Word1 "let0", Word1 "let1",
+   Word "letω" `Or` Word "let#",
+   Word1 "fst", Word1 "snd",
    Word1 "_",
    Word1 "Eq",
    Word "λ" `Or` Word "fun",
@@ -210,35 +272,71 @@ reserved =
    Word "ω" `Or` Sym "#",
    Sym "★" `Or` Word "Type",
    Word "ℕ" `Or` Word "Nat",
+   Word1 "IOState",
+   Word1 "String",
    Word1 "zero", Word1 "succ",
    Word1 "coe", Word1 "comp",
    Word1 "def",
    Word1 "def0",
    Word "defω" `Or` Word "def#",
+   Word1 "postulate",
+   Word1 "postulate0",
+   Word "postulateω" `Or` Word "postulate#",
    Sym1 "=",
    Word1 "load",
    Word1 "namespace"]
 
+public export
+reservedStrings : List String
+reservedStrings = map resString reserved
+
+public export
+allReservedStrings : List String
+allReservedStrings = foldMap resString2 reserved
+
 ||| `IsReserved str` is true if `Reserved str` might actually show up in
 ||| the token stream
 public export
 IsReserved : String -> Type
-IsReserved str = str `Elem` map resString reserved
+IsReserved str = So (str `elem` reservedStrings)
+
+private
+name : Tokenizer ExtToken
+name =
+  match name $ \str =>
+    let parts = split (== '.') $ normalizeNfc str in
+    case find (`elem` allReservedStrings) (toList parts) of
+      Nothing => T $ Name $ fromListP parts
+      Just w  => Invalid "reserved word '\{w}' inside name \{str}" str
 
 export
-tokens : Tokenizer TokenW
+tokens : Tokenizer ExtToken
 tokens = choice $
   map skip [pred isWhitespace,
             lineComment (exact "--" <+> reject symCont),
             blockComment (exact "{-") (exact "-}")] <+>
-  [universe] <+>  -- ★ᵢ takes precedence over bare ★
+  [universe] <+>  -- Type<i> takes precedence over bare Type
   map resTokenizer reserved <+>
   [sup, nat, string, tag, name]
 
+export
+check : Alternative f =>
+        WithBounds ExtToken -> Either Error (f (WithBounds Token))
+check (MkBounded val irr bounds@(MkBounds line col _ _)) = case val of
+  Skip            => Right empty
+  T tok           => Right $ pure $ MkBounded tok irr bounds
+  Invalid msg tok => Left  $ Err (Other msg) line col (index 0 tok)
+
+export
+toErrorReason : StopReason -> Maybe ErrorReason
+toErrorReason EndInput                = Nothing
+toErrorReason NoRuleApply             = Just NoRuleApply
+toErrorReason (ComposeNotClosing s e) = Just $ ComposeNotClosing s e
+
 export
 lex : String -> Either Error (List (WithBounds Token))
 lex str =
   let (res, reason, line, col, str) = lex tokens str in
-  case reason of
-    EndInput => Right $ mapMaybe sequence res
-    _        => Left  $ Err {reason, line, col, char = index 0 str}
+  case toErrorReason reason of
+    Nothing => concatMap check res @{MonoidApplicative}
+    Just e  => Left $ Err {reason = e, line, col, char = index 0 str}

lib/Quox/Parser/LoadFile.idr

@@ -0,0 +1,100 @@
+module Quox.Parser.LoadFile
+
+import public Quox.Parser.Syntax
+import Quox.Parser.Parser
+import Quox.Loc
+import Quox.EffExtra
+import Data.IORef
+import Data.SortedSet
+import System.File
+import System.Path
+
+
+%default total
+
+public export
+FilePath : Type
+FilePath = String
+
+
+public export
+data LoadFileL : (lbl : k) -> Type -> Type where
+  [search lbl]
+  Seen    : FilePath -> LoadFileL lbl Bool
+  SetSeen : FilePath -> LoadFileL lbl ()
+  DoLoad  : Loc -> FilePath -> LoadFileL lbl PFile
+
+public export
+LoadFile : Type -> Type
+LoadFile = LoadFileL ()
+
+
+export
+seenAt : (0 lbl : k) -> Has (LoadFileL lbl) fs => FilePath -> Eff fs Bool
+seenAt lbl file = send $ Seen {lbl} file
+
+export %inline
+seen : Has LoadFile fs => FilePath -> Eff fs Bool
+seen = seenAt ()
+
+
+export
+setSeenAt : (0 lbl : k) -> Has (LoadFileL lbl) fs => FilePath -> Eff fs ()
+setSeenAt lbl file = send $ SetSeen {lbl} file
+
+export %inline
+setSeen : Has LoadFile fs => FilePath -> Eff fs ()
+setSeen = setSeenAt ()
+
+
+export
+doLoadAt : (0 lbl : k) -> Has (LoadFileL lbl) fs =>
+           Loc -> FilePath -> Eff fs PFile
+doLoadAt lbl loc file = send $ DoLoad {lbl} loc file
+
+export %inline
+doLoad : Has LoadFile fs => Loc -> FilePath -> Eff fs PFile
+doLoad = doLoadAt ()
+
+
+public export
+SeenSet : Type
+SeenSet = SortedSet FilePath
+
+public export
+IncludePath : Type
+IncludePath = List String
+
+export covering
+readFileFrom : HasIO io => IncludePath -> FilePath ->
+               io (Either FileError String)
+readFileFrom inc f =
+  case !(firstExists $ map (</> f) inc) of
+    Just path => readFile path
+    Nothing   => pure $ Left $ FileNotFound
+
+export covering
+handleLoadFileIOE : (Loc -> FilePath -> FileError -> e) ->
+                    (FilePath -> Parser.Error -> e) ->
+                    IORef SeenSet -> IncludePath ->
+                    LoadFileL lbl a -> IOErr e a
+handleLoadFileIOE injf injp seen inc = \case
+  Seen    f   => contains f <$> readIORef seen
+  SetSeen f   => modifyIORef seen $ insert f
+  DoLoad  l f =>
+    case !(readFileFrom inc f) of
+      Left  err => ioLeft $ injf l f err
+      Right str => either (ioLeft . injp f) pure $ lexParseInput f str
+
+
+export
+loadFileAt : (0 lbl : k) -> Has (LoadFileL lbl) fs =>
+             Loc -> FilePath -> Eff fs (Maybe PFile)
+loadFileAt lbl loc file =
+  if !(seenAt lbl file)
+     then pure Nothing
+     else Just <$> doLoadAt lbl loc file <* setSeenAt lbl file
+
+export
+loadFile : Has LoadFile fs => Loc -> FilePath -> Eff fs (Maybe PFile)
+loadFile = loadFileAt ()

lib/Quox/Parser/Parser.idr

@@ -124,7 +124,7 @@ qname = terminalMatch "name" `(Name n) `(n)
 ||| unqualified name
 export
 baseName : Grammar True PBaseName
-baseName = terminalMatch "unqualified name" `(Name (MakePName [<] b)) `(b)
+baseName = terminalMatch "unqualified name" `(Name (MkPName [<] b)) `(b)
 
 ||| dimension constant (0 or 1)
 export
@@ -149,6 +149,12 @@ export
 qty : FileName -> Grammar True PQty
 qty fname = withLoc fname [|PQ qtyVal|]
 
+export
+exactName : String -> Grammar True ()
+exactName name = terminal "expected '\{name}'" $ \case
+  Name (MkPName [<] x) => guard $ x == name
+  _                    => Nothing
+
 
 ||| pattern var (unqualified name or _)
 export
@@ -198,18 +204,21 @@ export
 enumType : Grammar True (List TagVal)
 enumType = delimSep "{" "}" "," bareTag
 
-||| e.g. `case` or `case 1.`
+||| e.g. `case1` or `case 1.`
 export
 caseIntro : FileName -> Grammar True PQty
 caseIntro fname =
       withLoc fname (PQ Zero <$ res "case0")
   <|> withLoc fname (PQ One  <$ res "case1")
   <|> withLoc fname (PQ Any  <$ res "caseω")
-  <|> delim "case" "." (qty fname)
+  <|> do resC "case"
+         qty fname <* needRes "." <|> defLoc fname (PQ One)
 
 export
 qtyPatVar : FileName -> Grammar True (PQty, PatVar)
-qtyPatVar fname = [|(,) (qty fname) (needRes "." *> patVar fname)|]
+qtyPatVar fname =
+      [|(,) (qty fname) (needRes "." *> patVar fname)|]
+  <|> [|(,) (defLoc fname $ PQ One) (patVar fname)|]
 
 
 export
@@ -277,19 +286,81 @@ export
 universe1 : Grammar True Universe
 universe1 = universeTok <|> res "★" *> option 0 super
 
-||| argument/atomic term: single-token terms, or those with delimiters e.g.
-||| `[t]`
+
+public export
+PCaseArm : Type
+PCaseArm = (PCasePat, PTerm)
+
+export
+caseArm : FileName -> Grammar True PCaseArm
+caseArm fname =
+  [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
+
+export
+checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody
+checkCaseArms loc [] = pure $ CaseEnum [] loc
+checkCaseArms loc ((PPair x y _, rhs) :: rest) =
+  if null rest then pure $ CasePair (x, y) rhs loc
+  else fatalError "unexpected pattern after pair"
+checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do
+  let rest = for rest $ \case
+        (PTag tag _, rhs) => Just (tag, rhs)
+        _                 => Nothing
+  maybe (fatalError "expected all patterns to be tags")
+        (\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest
+checkCaseArms loc ((PZero _, rhs1) :: rest) = do
+  let [(PSucc p q ih _, rhs2)] = rest
+    | _ => fatalError "expected succ pattern after zero"
+  pure $ CaseNat rhs1 (p, q, ih, rhs2) loc
+checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do
+  let [(PZero _, rhs2)] = rest
+    | _ => fatalError "expected zero pattern after succ"
+  pure $ CaseNat rhs2 (p, q, ih, rhs1) loc
+checkCaseArms loc ((PBox x _, rhs) :: rest) =
+  if null rest then pure $ CaseBox x rhs loc
+  else fatalError "unexpected pattern after box"
+
+export
+caseBody : FileName -> Grammar True PCaseBody
+caseBody fname = do
+  body <- bounds $ delimSep "{" "}" ";" $ caseArm fname
+  let loc = makeLoc fname body.bounds
+  checkCaseArms loc body.val
+
+export
+caseReturn : FileName -> Grammar True (PatVar, PTerm)
+caseReturn fname = do
+  x   <- patVar fname <* resC "⇒" <|> unused fname
+  ret <- assert_total term fname
+  pure (x, ret)
+
+export
+caseTerm : FileName -> Grammar True PTerm
+caseTerm fname = withLoc fname $ do
+  qty <- caseIntro fname;                     commit
+  head <- mustWork $ assert_total term fname; needRes "return"
+  ret  <- mustWork $ caseReturn fname;        needRes "of"
+  body <- mustWork $ caseBody fname
+  pure $ Case qty head ret body
+
+
+||| argument/atomic term: single-token terms, or those with delimiters
+||| e.g. `[t]`. includes `case` because the end delimiter is the `}`.
 export
 termArg : FileName -> Grammar True PTerm
 termArg fname = withLoc fname $
       [|TYPE universe1|]
+  <|> IOState <$ res "IOState"
   <|> [|Enum enumType|]
   <|> [|Tag tag|]
   <|> const <$> boxTerm fname
-  <|> Nat  <$ res "ℕ"
-  <|> Zero <$ res "zero"
-  <|> [|fromNat nat|]
+  <|> NAT    <$ res "ℕ"
+  <|> Nat 0  <$ res "zero"
+  <|> [|Nat nat|]
+  <|> STRING <$ res "String"
+  <|> [|Str strLit|]
   <|> [|V qname displacement|]
+  <|> const <$> caseTerm fname
   <|> const <$> tupleTerm fname
 
 export
@@ -369,10 +440,10 @@ eqTerm : FileName -> Grammar True PTerm
 eqTerm fname = withLoc fname $
   resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (termArg fname)|]
 
-export
-succTerm : FileName -> Grammar True PTerm
-succTerm fname = withLoc fname $
-  resC "succ" *> mustWork [|Succ (termArg fname)|]
+private
+appArg : Loc -> PTerm -> Either PDim PTerm -> PTerm
+appArg loc f (Left  p) = DApp f p loc
+appArg loc f (Right s) = App  f s loc
 
 ||| a dimension argument with an `@` prefix, or
 ||| a term argument with no prefix
@@ -380,15 +451,32 @@ export
 anyArg : FileName -> Grammar True (Either PDim PTerm)
 anyArg fname = dimArg fname <||> termArg fname
 
+export
+resAppTerm : FileName -> (word : String) -> (0 _ : IsReserved word) =>
+             (PTerm -> Loc -> PTerm) -> Grammar True PTerm
+resAppTerm fname word f = withLoc fname $ do
+  head <- withLoc fname $ resC word *> mustWork [|f (termArg fname)|]
+  args <- many $ anyArg fname
+  pure $ \loc => foldl (appArg loc) head args
+
+export
+succTerm : FileName -> Grammar True PTerm
+succTerm fname = resAppTerm fname "succ" Succ
+
+export
+fstTerm : FileName -> Grammar True PTerm
+fstTerm fname = resAppTerm fname "fst" Fst
+
+export
+sndTerm : FileName -> Grammar True PTerm
+sndTerm fname = resAppTerm fname "snd" Snd
+
 export
 normalAppTerm : FileName -> Grammar True PTerm
 normalAppTerm fname = withLoc fname $ do
   head <- termArg fname
   args <- many $ anyArg fname
-  pure $ \loc => foldl (ap loc) head args
-where ap : Loc -> PTerm -> Either PDim PTerm -> PTerm
-      ap loc f (Left  p) = DApp f p loc
-      ap loc f (Right s) = App  f s loc
+  pure $ \loc => foldl (appArg loc) head args
 
 ||| application term `f x @y z`, or other terms that look like application
 ||| like `succ` or `coe`.
@@ -400,6 +488,8 @@ appTerm fname =
   <|> splitUniverseTerm fname
   <|> eqTerm fname
   <|> succTerm fname
+  <|> fstTerm fname
+  <|> sndTerm fname
   <|> normalAppTerm fname
 
 export
@@ -438,18 +528,6 @@ properBinders fname = assert_total $ do
   t  <- term fname;          needRes ")"
   pure (xs, t)
 
-export
-piTerm : FileName -> Grammar True PTerm
-piTerm fname = withLoc fname $ do
-  q   <- qty fname;               resC "."
-  dom <- piBinder;                needRes "→"
-  cod <- assert_total term fname; commit
-  pure $ \loc => foldr (\x, t => Pi q x (snd dom) t loc) cod (fst dom)
-where
-  piBinder : Grammar True (List1 PatVar, PTerm)
-  piBinder = properBinders fname
-         <|> [|(,) [|singleton $ unused fname|] (termArg fname)|]
-
 export
 sigmaTerm : FileName -> Grammar True PTerm
 sigmaTerm fname =
@@ -470,105 +548,320 @@ where
     rest <- optional $ resC "×" *> sepBy1 (res "×") (annTerm fname)
     pure $ foldr1 cross $ fst ::: maybe [] toList rest
 
-public export
-PCaseArm : Type
-PCaseArm = (PCasePat, PTerm)
+export
+piTerm : FileName -> Grammar True PTerm
+piTerm fname = withLoc fname $ do
+  q   <- [|GivenQ $ qty fname <* resC "."|] <|> defLoc fname DefaultQ
+  dom <- [|Dep $ properBinders fname|] <|> [|Nondep $ ndDom q fname|]
+  cod <- optional $ do resC "→"; assert_total term fname <* commit
+  when (needCod q dom && isNothing cod) $ fail "missing function type result"
+  pure $ maybe (const $ toTerm dom) (makePi q dom) cod
+where
+  data PiQty = GivenQ PQty | DefaultQ Loc
+  data PiDom = Dep (List1 PatVar, PTerm) | Nondep PTerm
+
+  ndDom : PiQty -> FileName -> Grammar True PTerm
+  ndDom (GivenQ   _) = termArg   -- ｢1.(List A)｣, not ｢1.List A｣
+  ndDom (DefaultQ _) = sigmaTerm
+
+  needCod : PiQty -> PiDom -> Bool
+  needCod (DefaultQ _) (Nondep _) = False
+  needCod _            _          = True
+
+  toTerm : PiDom -> PTerm
+  toTerm (Dep (_, s)) = s
+  toTerm (Nondep s)   = s
+
+  toQty : PiQty -> PQty
+  toQty (GivenQ   qty) = qty
+  toQty (DefaultQ loc) = PQ One loc
+
+  toDoms : PQty -> PiDom -> List1 (PQty, PatVar, PTerm)
+  toDoms qty (Dep (xs, s)) = [(qty, x, s) | x <- xs]
+  toDoms qty (Nondep s)    = singleton (qty, Unused s.loc, s)
+
+  makePi : PiQty -> PiDom -> PTerm -> Loc -> PTerm
+  makePi q doms cod loc =
+    foldr (\(q, x, s), t => Pi q x s t loc) cod $ toDoms (toQty q) doms
+
 
 export
-caseArm : FileName -> Grammar True PCaseArm
-caseArm fname =
-  [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
+letIntro : FileName -> Grammar True (Maybe PQty)
+letIntro fname =
+      withLoc fname (Just . PQ Zero <$ res "let0")
+  <|> withLoc fname (Just . PQ One  <$ res "let1")
+  <|> withLoc fname (Just . PQ Any  <$ res "letω")
+  <|> Nothing <$ resC "let"
+
+private
+letBinder : FileName -> Maybe PQty -> Grammar True (PQty, PatVar, PTerm)
+letBinder fname mq = do
+  qty  <- letQty fname mq
+  x    <- patVar fname
+  type <- optional $ resC ":" *> term fname
+  rhs  <- resC "=" *> term fname
+  pure (qty, x, makeLetRhs rhs type)
+where
+  letQty : FileName -> Maybe PQty -> Grammar False PQty
+  letQty fname Nothing  = qty fname <* mustWork (resC ".") <|> defLoc fname (PQ One)
+  letQty fname (Just q) = pure q
+
+  makeLetRhs : PTerm -> Maybe PTerm -> PTerm
+  makeLetRhs tm ty = maybe tm (\t => Ann tm t (extendL tm.loc t.loc)) ty
 
 export
-checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody
-checkCaseArms loc [] = pure $ CaseEnum [] loc
-checkCaseArms loc ((PPair x y _, rhs) :: rest) =
-  if null rest then pure $ CasePair (x, y) rhs loc
-  else fatalError "unexpected pattern after pair"
-checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do
-  let rest = for rest $ \case
-        (PTag tag _, rhs) => Just (tag, rhs)
-        _                 => Nothing
-  maybe (fatalError "expected all patterns to be tags")
-        (\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest
-checkCaseArms loc ((PZero _, rhs1) :: rest) = do
-  let [(PSucc p q ih _, rhs2)] = rest
-    | _ => fatalError "expected succ pattern after zero"
-  pure $ CaseNat rhs1 (p, q, ih, rhs2) loc
-checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do
-  let [(PZero _, rhs2)] = rest
-    | _ => fatalError "expected zero pattern after succ"
-  pure $ CaseNat rhs2 (p, q, ih, rhs1) loc
-checkCaseArms loc ((PBox x _, rhs) :: rest) =
-  if null rest then pure $ CaseBox x rhs loc
-  else fatalError "unexpected pattern after box"
+letTerm : FileName -> Grammar True PTerm
+letTerm fname = withLoc fname $ do
+  qty   <- letIntro fname
+  binds <- sepEndBy1 (res ";") $ assert_total letBinder fname qty
+  mustWork $ resC "in"
+  body  <- assert_total term fname
+  pure $ \loc => foldr (\b, s => Let b s loc) body binds
 
-export
-caseBody : FileName -> Grammar True PCaseBody
-caseBody fname = do
-  body <- bounds $ delimSep "{" "}" ";" $ caseArm fname
-  let loc = makeLoc fname body.bounds
-  checkCaseArms loc body.val
-
-export
-caseReturn : FileName -> Grammar True (PatVar, PTerm)
-caseReturn fname = do
-  x   <- patVar fname <* resC "⇒" <|> unused fname
-  ret <- assert_total term fname
-  pure (x, ret)
-
-export
-caseTerm : FileName -> Grammar True PTerm
-caseTerm fname = withLoc fname $ do
-  qty <- caseIntro fname;                     commit
-  head <- mustWork $ assert_total term fname; needRes "return"
-  ret  <- mustWork $ caseReturn fname;        needRes "of"
-  body <- mustWork $ caseBody fname
-  pure $ Case qty head ret body
-
--- export
 -- term : FileName -> Grammar True PTerm
 term fname = lamTerm fname
-         <|> caseTerm fname
          <|> piTerm fname
          <|> sigmaTerm fname
+         <|> letTerm fname
 
 
 export
-decl : FileName -> Grammar True PDecl
+attr' : FileName -> (o : String) -> (0 _ : IsReserved o) =>
+        Grammar True PAttr
+attr' fname o = withLoc fname $ do
+  resC o
+  name <- baseName
+  args <- many $ termArg fname
+  mustWork $ resC "]"
+  pure $ PA name args
+
+export %inline
+attr : FileName -> Grammar True PAttr
+attr fname = attr' fname "#["
 
-||| `def` alone means `defω`
 export
-defIntro : FileName -> Grammar True PQty
-defIntro fname =
-      withLoc fname (PQ Zero <$ resC "def0")
-  <|> withLoc fname (PQ Any  <$ resC "defω")
-  <|> do pos <- bounds $ resC "def"
+findDups : List PAttr -> List String
+findDups attrs =
+  SortedSet.toList $ snd $ foldl check (empty, empty) attrs
+where
+  Seen = SortedSet String; Dups = SortedSet String
+  check : (Seen, Dups) -> PAttr -> (Seen, Dups)
+  check (seen, dups) (PA a _ _) =
+    (insert a seen, if contains a seen then insert a dups else dups)
+
+export
+noDups : List PAttr -> Grammar False ()
+noDups attrs = do
+  let dups = findDups attrs
+  when (not $ null dups) $
+    fatalError "duplicate attribute names: \{joinBy "," dups}"
+
+export
+attrList : FileName -> Grammar False (List PAttr)
+attrList fname = do
+  res <- many $ attr fname
+  noDups res $> res
+
+public export
+data AttrMatch a =
+    Matched a
+  | NoMatch String (List String)
+  | Malformed String String
+
+export
+Functor AttrMatch where
+  map f (Matched x)     = Matched $ f x
+  map f (NoMatch s w)   = NoMatch s w
+  map f (Malformed a e) = Malformed a e
+
+export
+(<|>) : AttrMatch a -> AttrMatch a -> AttrMatch a
+Matched x     <|> _ = Matched x
+NoMatch {}    <|> y = y
+Malformed a e <|> _ = Malformed a e
+
+export
+isFail : PAttr -> List String -> AttrMatch PFail
+isFail (PA "fail" []        _) _ = Matched PFailAny
+isFail (PA "fail" [Str s _] _) _ = Matched $ PFailMatch s
+isFail (PA "fail" _ _) _ = Malformed "fail" "be absent or a string literal"
+isFail a w = NoMatch a.name w
+
+export
+isMain : PAttr -> List String -> AttrMatch ()
+isMain (PA "main" [] _) _ = Matched ()
+isMain (PA "main" _  _) _ = Malformed "main" "have no arguments"
+isMain a w = NoMatch a.name w
+
+export
+isScheme : PAttr -> List String -> AttrMatch String
+isScheme (PA "compile-scheme" [Str s _] _) _ = Matched s
+isScheme (PA "compile-scheme" _ _) _ =
+  Malformed "compile-scheme" "be a string literal"
+isScheme a w = NoMatch a.name w
+
+export
+matchAttr : String -> AttrMatch a -> Either String a
+matchAttr _ (Matched x) = Right x
+matchAttr d (NoMatch a w) = Left $ unlines
+  ["unrecognised \{d} attribute \{a}", "expected one of: \{show w}"]
+matchAttr _ (Malformed a s) = Left $ unlines
+  ["invalid \{a} attribute", "(should \{s})"]
+
+export
+mkPDef : List PAttr -> PQty -> PBaseName -> PBody ->
+         Either String (Loc -> PDefinition)
+mkPDef attrs qty name body = do
+  let start = MkPDef qty name body PSucceed False Nothing noLoc
+  res <- foldlM addAttr start attrs
+  pure $ \l => {loc_ := l} (the PDefinition res)
+where
+  data PDefAttr = DefFail PFail | DefMain | DefScheme String
+
+  isDefAttr : PAttr -> Either String PDefAttr
+  isDefAttr attr =
+    let defAttrs = ["fail", "main", "compile-scheme"] in
+    matchAttr "definition" $
+        DefFail   <$> isFail attr defAttrs
+    <|> DefMain   <$  isMain attr defAttrs
+    <|> DefScheme <$> isScheme attr defAttrs
+
+  addAttr : PDefinition -> PAttr -> Either String PDefinition
+  addAttr def attr =
+    case !(isDefAttr attr) of
+      DefFail   f   => pure $ {fail := f} def
+      DefMain       => pure $ {main := True} def
+      DefScheme str => pure $ {scheme := Just str} def
+
+export
+mkPNamespace : List PAttr -> Mods -> List PDecl ->
+               Either String (Loc -> PNamespace)
+mkPNamespace attrs name decls = do
+  let start = MkPNamespace name decls PSucceed noLoc
+  res <- foldlM addAttr start attrs
+  pure $ \l => {loc_ := l} (the PNamespace res)
+where
+  isNsAttr a = matchAttr "namespace" $ isFail a ["fail"]
+
+  addAttr : PNamespace -> PAttr -> Either String PNamespace
+  addAttr ns attr = pure $ {fail := !(isNsAttr attr)} ns
+
+||| `def` alone means `defω`; same for `postulate`
+export
+defIntro' : (bare, zero, omega : String) ->
+            (0 _ : IsReserved bare) =>
+            (0 _ : IsReserved zero) =>
+            (0 _ : IsReserved omega) =>
+            FileName -> Grammar True PQty
+defIntro' bare zero omega fname =
+      withLoc fname (PQ Zero <$ resC zero)
+  <|> withLoc fname (PQ Any  <$ resC omega)
+  <|> do pos <- bounds $ resC bare
          let any = PQ Any $ makeLoc fname pos.bounds
          option any $ qty fname <* needRes "."
 
 export
-definition : FileName -> Grammar True PDefinition
-definition fname = withLoc fname $ do
+defIntro : FileName -> Grammar True PQty
+defIntro = defIntro' "def" "def0" "defω"
+
+export
+postulateIntro : FileName -> Grammar True PQty
+postulateIntro = defIntro' "postulate" "postulate0" "postulateω"
+
+export
+postulate : FileName -> List PAttr -> Grammar True PDefinition
+postulate fname attrs = withLoc fname $ do
+  qty  <- postulateIntro fname
+  name <- baseName
+  type <- resC ":" *> mustWork (term fname)
+  optRes ";"
+  either fatalError pure $ mkPDef attrs qty name $ PPostulate type
+
+export
+concrete : FileName -> List PAttr -> Grammar True PDefinition
+concrete fname attrs = withLoc fname $ do
   qty  <- defIntro fname
   name <- baseName
   type <- optional $ resC ":" *> mustWork (term fname)
   term <- needRes "=" *> mustWork (term fname)
   optRes ";"
-  pure $ MkPDef qty name type term
+  either fatalError pure $ mkPDef attrs qty name $ PConcrete type term
 
 export
-namespace_ : FileName -> Grammar True PNamespace
-namespace_ fname = withLoc fname $ do
-  ns    <- resC "namespace" *> qname; needRes "{"
-  decls <- nsInner; optRes ";"
-  pure $ MkPNamespace (ns.mods :< ns.base) decls
+definition : FileName -> List PAttr -> Grammar True PDefinition
+definition fname attrs =
+  try (postulate fname attrs) <|> concrete fname attrs
+
+export
+nsname : Grammar True Mods
+nsname = do ns <- qname; pure $ ns.mods :< ns.base
+
+export
+pragma : FileName -> Grammar True PPragma
+pragma fname = do
+  a <- attr' fname "#!["
+  either fatalError pure $ case a.name of
+    "log" => logArgs a.args a.loc
+    _     => Left $
+      #"unrecognised pragma "\#{a.name}"\n"# ++
+      #"known pragmas: ["log"]"#
+where
+  levelOOB : Nat -> Either String a
+  levelOOB n = Left $
+    "log level \{show n} out of bounds\n" ++
+    "expected number in range 0–\{show maxLogLevel} inclusive"
+
+  toLevel : Nat -> Either String LogLevel
+  toLevel lvl = maybe (levelOOB lvl) Right $ toLogLevel lvl
+
+  unknownCat : String -> Either String a
+  unknownCat cat = Left $
+    "unknown log category \{show cat}\n" ++
+    "known categories: \{show $ ["all", "default"] ++ logCategories}"
+
+  toCat : String -> Either String LogCategory
+  toCat cat = maybe (unknownCat cat) Right $ toLogCategory cat
+
+  fromPair : PTerm -> Either String (String, Nat)
+  fromPair (Pair (V (MkPName [<] x) Nothing _) (Nat n _) _) = Right (x, n)
+  fromPair _ = Left "invalid argument to log pragma"
+
+  logCatArg : (String, Nat) -> Either String Log.PushArg
+  logCatArg ("default", lvl) = [|SetDefault $ toLevel lvl|]
+  logCatArg ("all",     lvl) = [|SetAll $ toLevel lvl|]
+  logCatArg (cat,       lvl) = [|SetCat (toCat cat) (toLevel lvl)|]
+
+  logArgs : List PTerm -> Loc -> Either String PPragma
+  logArgs [] _ = Left "missing arguments to log pragma"
+  logArgs [V "pop" Nothing _] loc = Right $ PLogPop loc
+  logArgs other loc = do
+    args <- traverse (logCatArg <=< fromPair) other
+    pure $ PLogPush args loc
+
+
+export
+decl : FileName -> Grammar True PDecl
+
+export
+namespace_ : FileName -> List PAttr -> Grammar True PNamespace
+namespace_ fname attrs = withLoc fname $ do
+  ns    <- resC "namespace" *> nsname; needRes "{"
+  decls <- nsInner
+  either fatalError pure $ mkPNamespace attrs ns decls
 where
   nsInner : Grammar True (List PDecl)
   nsInner = [] <$ resC "}"
         <|> [|(assert_total decl fname <* commit) :: assert_total nsInner|]
 
-decl fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|]
+export
+declBody : FileName -> List PAttr -> Grammar True PDecl
+declBody fname attrs =
+  [|PDef $ definition fname attrs|] <|> [|PNs $ namespace_ fname attrs|]
+
+-- decl : FileName -> Grammar True PDecl
+decl fname =
+      (attrList fname >>= declBody fname)
+  <|> PPrag <$> pragma fname
 
 export
 load : FileName -> Grammar True PTopLevel
@@ -580,7 +873,7 @@ topLevel : FileName -> Grammar True PTopLevel
 topLevel fname = load fname <|> [|PD $ decl fname|]
 
 export
-input : FileName -> Grammar False (List PTopLevel)
+input : FileName -> Grammar False PFile
 input fname = [] <$ eof
           <|> [|(topLevel fname <* commit) :: assert_total input fname|]
 
@@ -589,5 +882,5 @@ lexParseTerm : FileName -> String -> Either Error PTerm
 lexParseTerm = lexParseWith . term
 
 export
-lexParseInput : FileName -> String -> Either Error (List PTopLevel)
+lexParseInput : FileName -> String -> Either Error PFile
 lexParseInput = lexParseWith . input

lib/Quox/Parser/Syntax.idr

@@ -3,6 +3,8 @@ module Quox.Parser.Syntax
 import public Quox.Loc
 import public Quox.Syntax
 import public Quox.Definition
+import Quox.PrettyValExtra
+import public Quox.Log
 
 import Derive.Prelude
 %hide TT.Name
@@ -14,9 +16,9 @@ import Derive.Prelude
 public export
 data PatVar = Unused Loc | PV PBaseName Loc
 %name PatVar v
-%runElab derive "PatVar" [Eq, Ord, Show]
+%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
 
-export
+export %inline
 Located PatVar where
   (Unused loc).loc = loc
   (PV _   loc).loc = loc
@@ -38,17 +40,17 @@ record PQty where
   val  : Qty
   loc_ : Loc
 %name PQty qty
-%runElab derive "PQty" [Eq, Ord, Show]
+%runElab derive "PQty" [Eq, Ord, Show, PrettyVal]
 
-export Located PQty where q.loc = q.loc_
+export %inline Located PQty where q.loc = q.loc_
 
 namespace PDim
   public export
   data PDim = K DimConst Loc | V PBaseName Loc
   %name PDim p, q
-  %runElab derive "PDim" [Eq, Ord, Show]
+  %runElab derive "PDim" [Eq, Ord, Show, PrettyVal]
 
-export
+export %inline
 Located PDim where
   (K _ loc).loc = loc
   (V _ loc).loc = loc
@@ -56,7 +58,7 @@ Located PDim where
 public export
 data PTagVal = PT TagVal Loc
 %name PTagVal tag
-%runElab derive "PTagVal" [Eq, Ord, Show]
+%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
 
 
 namespace PTerm
@@ -66,6 +68,8 @@ namespace PTerm
     data PTerm =
         TYPE Universe Loc
 
+      | IOState Loc
+
       | Pi PQty PatVar PTerm PTerm Loc
       | Lam PatVar PTerm Loc
       | App PTerm PTerm Loc
@@ -73,6 +77,7 @@ namespace PTerm
       | Sig PatVar PTerm PTerm Loc
       | Pair PTerm PTerm Loc
       | Case PQty PTerm (PatVar, PTerm) PCaseBody Loc
+      | Fst PTerm Loc | Snd PTerm Loc
 
       | Enum (List TagVal) Loc
       | Tag TagVal Loc
@@ -81,8 +86,11 @@ namespace PTerm
       | DLam PatVar PTerm Loc
       | DApp PTerm PDim Loc
 
-      | Nat Loc
-      | Zero Loc | Succ PTerm Loc
+      | NAT Loc
+      | Nat Nat Loc | Succ PTerm Loc
+
+      | STRING Loc  -- "String" is a reserved word in idris
+      | Str String Loc
 
       | BOX PQty PTerm Loc
       | Box PTerm Loc
@@ -93,6 +101,8 @@ namespace PTerm
       | Coe (PatVar, PTerm) PDim PDim PTerm Loc
       | Comp (PatVar, PTerm) PDim PDim PTerm PDim
              (PatVar, PTerm) (PatVar, PTerm) Loc
+
+      | Let (PQty, PatVar, PTerm) PTerm Loc
     %name PTerm s, t
 
     public export
@@ -103,33 +113,43 @@ namespace PTerm
       | CaseBox PatVar PTerm Loc
     %name PCaseBody body
 
-%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
+  public export %inline
+  Zero : Loc -> PTerm
+  Zero = Nat 0
 
-export
+%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal]
+
+export %inline
 Located PTerm where
-  (TYPE _             loc).loc = loc
-  (Pi   _ _ _ _       loc).loc = loc
-  (Lam  _ _           loc).loc = loc
-  (App  _ _           loc).loc = loc
-  (Sig  _ _ _         loc).loc = loc
-  (Pair _ _           loc).loc = loc
-  (Case _ _ _ _       loc).loc = loc
-  (Enum _             loc).loc = loc
-  (Tag  _             loc).loc = loc
-  (Eq   _ _ _         loc).loc = loc
-  (DLam _ _           loc).loc = loc
-  (DApp _ _           loc).loc = loc
-  (Nat                loc).loc = loc
-  (Zero               loc).loc = loc
-  (Succ _             loc).loc = loc
-  (BOX  _ _           loc).loc = loc
-  (Box  _             loc).loc = loc
-  (V    _ _           loc).loc = loc
-  (Ann  _ _           loc).loc = loc
-  (Coe  _ _ _ _       loc).loc = loc
-  (Comp _ _ _ _ _ _ _ loc).loc = loc
+  (TYPE    _             loc).loc = loc
+  (IOState               loc).loc = loc
+  (Pi      _ _ _ _       loc).loc = loc
+  (Lam     _ _           loc).loc = loc
+  (App     _ _           loc).loc = loc
+  (Sig     _ _ _         loc).loc = loc
+  (Pair    _ _           loc).loc = loc
+  (Fst     _             loc).loc = loc
+  (Snd     _             loc).loc = loc
+  (Case    _ _ _ _       loc).loc = loc
+  (Enum    _             loc).loc = loc
+  (Tag     _             loc).loc = loc
+  (Eq      _ _ _         loc).loc = loc
+  (DLam    _ _           loc).loc = loc
+  (DApp    _ _           loc).loc = loc
+  (NAT                   loc).loc = loc
+  (Nat     _             loc).loc = loc
+  (Succ    _             loc).loc = loc
+  (STRING                loc).loc = loc
+  (Str     _             loc).loc = loc
+  (BOX     _ _           loc).loc = loc
+  (Box     _             loc).loc = loc
+  (V       _ _           loc).loc = loc
+  (Ann     _ _           loc).loc = loc
+  (Coe     _ _ _ _       loc).loc = loc
+  (Comp    _ _ _ _ _ _ _ loc).loc = loc
+  (Let     _ _           loc).loc = loc
 
-export
+export %inline
 Located PCaseBody where
   (CasePair _ _ loc).loc = loc
   (CaseEnum _   loc).loc = loc
@@ -137,18 +157,45 @@ Located PCaseBody where
   (CaseBox  _ _ loc).loc = loc
 
 
+public export
+data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm
+%name PBody body
+%runElab derive "PBody" [Eq, Ord, Show, PrettyVal]
+
+
+public export
+data PFail =
+  PSucceed
+| PFailAny
+| PFailMatch String
+%runElab derive "PFail" [Eq, Ord, Show, PrettyVal]
+
 public export
 record PDefinition where
   constructor MkPDef
-  qty  : PQty
-  name : PBaseName
-  type : Maybe PTerm
-  term : PTerm
-  loc_ : Loc
+  qty    : PQty
+  name   : PBaseName
+  body   : PBody
+  fail   : PFail
+  main   : Bool
+  scheme : Maybe String
+  loc_   : Loc
 %name PDefinition def
-%runElab derive "PDefinition" [Eq, Ord, Show]
+%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
 
-export Located PDefinition where def.loc = def.loc_
+export %inline Located PDefinition where def.loc = def.loc_
+
+public export
+data PPragma =
+    PLogPush (List Log.PushArg) Loc
+  | PLogPop  Loc
+%name PPragma prag
+%runElab derive "PPragma" [Eq, Ord, Show, PrettyVal]
+
+export %inline
+Located PPragma where
+  (PLogPush _ loc).loc = loc
+  (PLogPop    loc).loc = loc
 
 mutual
   public export
@@ -156,35 +203,49 @@ mutual
     constructor MkPNamespace
     name  : Mods
     decls : List PDecl
+    fail  : PFail
     loc_  : Loc
   %name PNamespace ns
 
   public export
   data PDecl =
-      PDef PDefinition
-    | PNs  PNamespace
+      PDef  PDefinition
+    | PNs   PNamespace
+    | PPrag PPragma
   %name PDecl decl
-%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show]
+%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
 
-export Located PNamespace where ns.loc = ns.loc_
+export %inline Located PNamespace where ns.loc = ns.loc_
 
-export
+export %inline
 Located PDecl where
-  (PDef def).loc = def.loc
-  (PNs  ns).loc  = ns.loc
+  (PDef  d).loc    = d.loc
+  (PNs   ns).loc   = ns.loc
+  (PPrag prag).loc = prag.loc
 
 public export
 data PTopLevel = PD PDecl | PLoad String Loc
 %name PTopLevel t
-%runElab derive "PTopLevel" [Eq, Ord, Show]
+%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal]
 
-export
+export %inline
 Located PTopLevel where
   (PD    decl).loc  = decl.loc
   (PLoad _ loc).loc = loc
 
 
 public export
-fromNat : Nat -> Loc -> PTerm
-fromNat 0     loc = Zero loc
-fromNat (S k) loc = Succ (fromNat k loc) loc
+record PAttr where
+  constructor PA
+  name : PBaseName
+  args : List PTerm
+  loc_ : Loc
+%name PAttr attr
+%runElab derive "PAttr" [Eq, Ord, Show, PrettyVal]
+
+export %inline Located PAttr where attr.loc = attr.loc_
+
+
+public export
+PFile : Type
+PFile = List PTopLevel

lib/Quox/Pretty.idr

@@ -3,6 +3,7 @@ module Quox.Pretty
 import Quox.Loc
 import Quox.Name
 
+import Control.Monad.ST.Extra
 import public Text.PrettyPrint.Bernardy
 import public Text.PrettyPrint.Bernardy.Core.Decorate
 import public Quox.EffExtra
@@ -40,7 +41,7 @@ data HL
 | Dim  | DVar | DVarErr
 | Qty  | Universe
 | Syntax
-| Tag
+| Constant
 %runElab derive "HL" [Eq, Ord, Show]
 
 
@@ -65,11 +66,12 @@ export %inline
 runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
                 Eff Pretty a -> a
 runPrettyWith prec flavor highlight indent act =
-  extract $
-  evalStateAt PREC prec $
-  runReaderAt FLAVOR flavor $
-  runReaderAt HIGHLIGHT highlight $
-  runReaderAt INDENT indent act
+  runST $ do
+    runEff act $ with Union.(::)
+      [handleStateSTRef !(newSTRef prec),
+       handleReaderConst flavor,
+       handleReaderConst highlight,
+       handleReaderConst indent]
 
 
 export %inline
@@ -84,43 +86,65 @@ toSGR DVarErr  = [SetForeground BrightGreen, SetStyle SingleUnderline]
 toSGR Qty      = [SetForeground BrightMagenta]
 toSGR Universe = [SetForeground BrightRed]
 toSGR Syntax   = [SetForeground BrightCyan]
-toSGR Tag      = [SetForeground BrightRed]
+toSGR Constant = [SetForeground BrightRed]
 
 export %inline
 highlightSGR : HL -> Highlight
 highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
 
+export %inline
+toClass : HL -> String
+toClass Delim    = "dl"
+toClass Free     = "fr"
+toClass TVar     = "tv"
+toClass TVarErr  = "tv err"
+toClass Dim      = "dc"
+toClass DVar     = "dv"
+toClass DVarErr  = "dv err"
+toClass Qty      = "qt"
+toClass Universe = "un"
+toClass Syntax   = "sy"
+toClass Constant = "co"
+
+export %inline
+highlightHtml : HL -> Highlight
+highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
+
+
+export %inline
+runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
+runPrettyHL f = runPrettyWith Outer Unicode f 2
 
 export %inline
 runPretty : Eff Pretty a -> a
-runPretty = runPrettyWith Outer Unicode noHighlight 2
-
-export %inline
-runPrettyColor : Eff Pretty a -> a
-runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
+runPretty = runPrettyHL noHighlight
 
 
 export %inline
-hl : {opts : _} -> HL -> Doc opts -> Eff Pretty (Doc opts)
+hl : {opts : LayoutOpts} -> HL -> Doc opts -> Eff Pretty (Doc opts)
 hl h doc = asksAt HIGHLIGHT $ \f => decorate (f h) doc
 
 
 export %inline
-indentD : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
+indentD : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
 indentD doc = pure $ indent !(askAt INDENT) doc
 
 export %inline
-hangD : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
+hangD : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
 hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
 
 export %inline
-hangDSingle : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
-hangDSingle d1 d2 =
-  pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2))
+hangSingle : {opts : LayoutOpts} -> Nat -> Doc opts -> Doc opts -> Doc opts
+hangSingle n d1 d2 = ifMultiline (d1 <++> d2) (vappend d1 (indent n d2))
+
+export %inline
+hangDSingle : {opts : LayoutOpts} -> Doc opts -> Doc opts ->
+              Eff Pretty (Doc opts)
+hangDSingle d1 d2 = pure $ hangSingle !(askAt INDENT) d1 d2
 
 
 export
-tightDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
+tightDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
               Eff Pretty (Doc opts)
 tightDelims l r inner = do
   l <- hl Delim $ text l
@@ -128,7 +152,7 @@ tightDelims l r inner = do
   pure $ hcat [l, inner, r]
 
 export
-looseDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
+looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
               Eff Pretty (Doc opts)
 looseDelims l r inner = do
   l <- hl Delim $ text l
@@ -138,39 +162,39 @@ looseDelims l r inner = do
   pure $ ifMultiline short long
 
 export %inline
-parens : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
+parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
 parens = tightDelims "(" ")"
 
 export %inline
-bracks : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
+bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
 bracks = tightDelims "[" "]"
 
 export %inline
-braces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
+braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
 braces = looseDelims "{" "}"
 
 export %inline
-tightBraces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
+tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
 tightBraces = tightDelims "{" "}"
 
 export %inline
-parensIf : {opts : _} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
+parensIf : {opts : LayoutOpts} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
 parensIf True  = parens
 parensIf False = pure
 
 
 ||| uses hsep only if the whole list fits on one line
 export
-sepSingle : {opts : _} -> List (Doc opts) -> Doc opts
+sepSingle : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
 sepSingle xs = ifMultiline (hsep xs) (vsep xs)
 
 export
-fillSep : {opts : _} -> List (Doc opts) -> Doc opts
+fillSep : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
 fillSep []        = empty
 fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
 
 export
-exceptLast : {opts : _} -> (Doc opts -> Doc opts) ->
+exceptLast : {opts : LayoutOpts} -> (Doc opts -> Doc opts) ->
              List (Doc opts) -> List (Doc opts)
 exceptLast f []        = []
 exceptLast f [x]       = [x]
@@ -185,11 +209,24 @@ parameters {opts : LayoutOpts} {auto _ : Foldable t}
   separateTight : Doc opts -> t (Doc opts) -> Doc opts
   separateTight d = sep . exceptLast (<+> d) . toList
 
+  export
+  hseparateTight : Doc opts -> t (Doc opts) -> Doc opts
+  hseparateTight d = hsep . exceptLast (<+> d) . toList
+
+  export
+  vseparateTight : Doc opts -> t (Doc opts) -> Doc opts
+  vseparateTight d = vsep . exceptLast (<+> d) . toList
+
   export
   fillSeparateTight : Doc opts -> t (Doc opts) -> Doc opts
   fillSeparateTight d = fillSep . exceptLast (<+> d) . toList
 
 
+export %inline
+pshow : {opts : LayoutOpts} -> Show a => a -> Doc opts
+pshow = text . show
+
+
 export %inline
 ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a
 ifUnicode uni asc =
@@ -198,7 +235,7 @@ ifUnicode uni asc =
     Ascii   => asc
 
 export %inline
-parensIfM : {opts : _} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
+parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
 parensIfM d doc = parensIf (!(getAt PREC) > d) doc
 
 export %inline
@@ -211,64 +248,73 @@ prettyName : Name -> Doc opts
 prettyName = text . toDots
 
 export
-prettyFree : {opts : _} -> Name -> Eff Pretty (Doc opts)
+prettyFree : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts)
 prettyFree = hl Free . prettyName
 
 export
 prettyBind' : BindName -> Doc opts
-prettyBind' = text . baseStr . name
+prettyBind' = text . baseStr . val
 
 export
-prettyTBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
+prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
 prettyTBind = hl TVar . prettyBind'
 
 export
-prettyDBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
+prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
 prettyDBind = hl DVar . prettyBind'
 
 
 
 export %inline
-typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
-eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
-ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD :
-  {opts : _} -> Eff Pretty (Doc opts)
+typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
+stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD,
+zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD :
+  {opts : LayoutOpts} -> Eff Pretty (Doc opts)
 typeD     = hl Syntax . text =<< ifUnicode "★" "Type"
-arrowD    = hl Delim  . text =<< ifUnicode "→" "->"
-darrowD   = hl Delim  . text =<< ifUnicode "⇒" "=>"
-timesD    = hl Delim  . text =<< ifUnicode "×" "**"
+ioStateD  = hl Syntax $ text "IOState"
+arrowD    = hl Syntax . text =<< ifUnicode "→" "->"
+darrowD   = hl Syntax . text =<< ifUnicode "⇒" "=>"
+timesD    = hl Syntax . text =<< ifUnicode "×" "**"
 lamD      = hl Syntax . text =<< ifUnicode "λ" "fun"
-eqndD     = hl Delim  . text =<< ifUnicode "≡" "=="
+eqndD     = hl Syntax . text =<< ifUnicode "≡" "=="
 dlamD     = hl Syntax . text =<< ifUnicode "δ" "dfun"
-annD      = hl Delim  . text =<< ifUnicode "∷" "::"
+annD      = hl Syntax . text =<< ifUnicode "∷" "::"
 natD      = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
-eqD       = hl Syntax $ text "Eq"
-colonD    = hl Delim  $ text ":"
-commaD    = hl Delim  $ text ","
-semiD     = hl Delim  $ text ";"
-caseD     = hl Syntax $ text "case"
-typecaseD = hl Syntax $ text "type-case"
-ofD       = hl Syntax $ text "of"
-returnD   = hl Syntax $ text "return"
-dotD      = hl Delim  $ text "."
-zeroD     = hl Syntax $ text "zero"
-succD     = hl Syntax $ text "succ"
-coeD      = hl Syntax $ text "coe"
-compD     = hl Syntax $ text "comp"
-undD      = hl Syntax $ text "_"
-cstD      = hl Syntax $ text "="
-pipeD     = hl Syntax $ text "|"
+stringD   = hl Syntax   $ text "String"
+eqD       = hl Syntax   $ text "Eq"
+colonD    = hl Syntax   $ text ":"
+commaD    = hl Syntax   $ text ","
+semiD     = hl Delim    $ text ";"
+atD       = hl Delim    $ text "@"
+caseD     = hl Syntax   $ text "case"
+typecaseD = hl Syntax   $ text "type-case"
+ofD       = hl Syntax   $ text "of"
+returnD   = hl Syntax   $ text "return"
+dotD      = hl Delim    $ text "."
+zeroD     = hl Constant $ text "zero"
+succD     = hl Constant $ text "succ"
+coeD      = hl Syntax   $ text "coe"
+compD     = hl Syntax   $ text "comp"
+undD      = hl Syntax   $ text "_"
+cstD      = hl Syntax   $ text "="
+pipeD     = hl Delim    $ text "|"
+fstD      = hl Syntax   $ text "fst"
+sndD      = hl Syntax   $ text "snd"
+letD      = hl Syntax   $ text "let"
+inD       = hl Syntax   $ text "in"
 
 
 export
-prettyApp : {opts : _} -> Nat -> Doc opts -> List (Doc opts) -> Doc opts
+prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
+            List (Doc opts) -> Doc opts
 prettyApp ind f args =
-      hsep (f :: args)
-  <|> hsep [f, vsep args]
-  <|> vsep (f :: map (indent ind) args)
+  ifMultiline
+    (hsep (f :: args))
+    (f <++> vsep args <|> vsep (f :: map (indent ind) args))
 
 export
-prettyAppD : {opts : _} -> Doc opts -> List (Doc opts) -> Eff Pretty (Doc opts)
+prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
+             Eff Pretty (Doc opts)
 prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
 
 
@@ -288,7 +334,7 @@ quoteTag tag =
   "\"" ++ escapeString tag ++ "\""
 
 export
-prettyBounds : {opts : _} -> Bounds -> Eff Pretty (Doc opts)
+prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
 prettyBounds (MkBounds l1 c1 l2 c2) =
   hcat <$> sequence
     [hl TVar $ text $ show l1, colonD,
@@ -297,8 +343,22 @@ prettyBounds (MkBounds l1 c1 l2 c2) =
      hl DVar $ text $ show c2, colonD]
 
 export
-prettyLoc : {opts : _} -> Loc -> Eff Pretty (Doc opts)
+prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
 prettyLoc (L NoLoc) =
   hcat <$> sequence [hl TVarErr "no location", colonD]
 prettyLoc (L (YesLoc file b)) =
   hcat <$> sequence [hl Free $ text file, colonD, prettyBounds b]
+
+export
+prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
+prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
+
+export
+prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
+prettyStrLit s =
+  let s = concatMap esc1 $ unpack s in
+  hl Constant $ hcat ["\"", text s, "\""]
+where
+  esc1 : Char -> String
+  esc1 '"' = "\""; esc1 '\\' = "\\"
+  esc1 c   = singleton c

lib/Quox/PrettyValExtra.idr

@@ -0,0 +1,20 @@
+module Quox.PrettyValExtra
+
+import Data.DPair
+import Derive.Prelude
+import public Text.Show.Value
+import public Text.Show.PrettyVal
+import public Text.Show.PrettyVal.Derive
+
+%language ElabReflection
+
+%runElab derive "SnocList" [PrettyVal]
+
+
+export %inline
+PrettyVal a => PrettyVal (Subset a p) where
+  prettyVal (Element x _) = Con "Element" [prettyVal x, Con "_" []]
+
+export %inline
+(forall x. PrettyVal (p x)) => PrettyVal (Exists p) where
+  prettyVal (Evidence _ p) = Con "Evidence" [Con "_" [], prettyVal p]

lib/Quox/Reduce.idr

@@ -1,751 +0,0 @@
-module Quox.Reduce
-
-import Quox.No
-import Quox.Syntax
-import Quox.Definition
-import Quox.Displace
-import Quox.Typing.Context
-import Quox.Typing.Error
-import Data.SnocVect
-import Data.Maybe
-import Data.List
-import Control.Eff
-
-%default total
-
-
-public export
-Whnf : List (Type -> Type)
-Whnf = [NameGen, Except Error]
-
-export
-runWhnfWith : NameSuf -> Eff Whnf a -> (Either Error a, NameSuf)
-runWhnfWith suf act = extract $ runStateAt GEN suf $ runExcept act
-
-export
-runWhnf : Eff Whnf a -> Either Error a
-runWhnf = fst . runWhnfWith 0
-
-
-public export
-0 RedexTest : TermLike -> Type
-RedexTest tm = {d, n : Nat} -> Definitions -> tm d n -> Bool
-
-public export
-interface CanWhnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm
-where
-  whnf : {d, n : Nat} -> (defs : Definitions) ->
-         (ctx : WhnfContext d n) ->
-         tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs))
-
-public export %inline
-whnf0 : {d, n : Nat} -> {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
-        (defs : Definitions) -> WhnfContext d n -> tm d n -> Eff Whnf (tm d n)
-whnf0 defs ctx t = fst <$> whnf defs ctx t
-
-public export
-0 IsRedex, NotRedex : {isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
-                      Definitions -> Pred (tm d n)
-IsRedex  defs = So . isRedex defs
-NotRedex defs = No . isRedex defs
-
-public export
-0 NonRedex : (tm : TermLike) -> {isRedex : RedexTest tm} ->
-             CanWhnf tm isRedex => (d, n : Nat) -> (defs : Definitions) -> Type
-NonRedex tm d n defs = Subset (tm d n) (NotRedex defs)
-
-public export %inline
-nred : {0 isRedex : RedexTest tm} -> (0 _ : CanWhnf tm isRedex) =>
-       (t : tm d n) -> (0 nr : NotRedex defs t) => NonRedex tm d n defs
-nred t = Element t nr
-
-
-public export %inline
-isLamHead : Elim {} -> Bool
-isLamHead (Ann (Lam {}) (Pi {}) _) = True
-isLamHead (Coe {})                 = True
-isLamHead _                        = False
-
-public export %inline
-isDLamHead : Elim {} -> Bool
-isDLamHead (Ann (DLam {}) (Eq {}) _) = True
-isDLamHead (Coe {})                  = True
-isDLamHead _                         = False
-
-public export %inline
-isPairHead : Elim {} -> Bool
-isPairHead (Ann (Pair {}) (Sig {}) _) = True
-isPairHead (Coe {})                   = True
-isPairHead _                          = False
-
-public export %inline
-isTagHead : Elim {} -> Bool
-isTagHead (Ann (Tag {}) (Enum {}) _) = True
-isTagHead (Coe {})                   = True
-isTagHead _                          = False
-
-public export %inline
-isNatHead : Elim {} -> Bool
-isNatHead (Ann (Zero {}) (Nat {}) _) = True
-isNatHead (Ann (Succ {}) (Nat {}) _) = True
-isNatHead (Coe {})                   = True
-isNatHead _                          = False
-
-public export %inline
-isBoxHead : Elim {} -> Bool
-isBoxHead (Ann (Box {}) (BOX {}) _) = True
-isBoxHead (Coe {})                  = True
-isBoxHead _                         = False
-
-public export %inline
-isE : Term {} -> Bool
-isE (E {}) = True
-isE _      = False
-
-public export %inline
-isAnn : Elim {} -> Bool
-isAnn (Ann {}) = True
-isAnn _        = False
-
-||| true if a term is syntactically a type.
-public export %inline
-isTyCon : Term {} -> Bool
-isTyCon (TYPE  {}) = True
-isTyCon (Pi    {}) = True
-isTyCon (Lam   {}) = False
-isTyCon (Sig   {}) = True
-isTyCon (Pair  {}) = False
-isTyCon (Enum  {}) = True
-isTyCon (Tag   {}) = False
-isTyCon (Eq    {}) = True
-isTyCon (DLam  {}) = False
-isTyCon (Nat   {}) = True
-isTyCon (Zero  {}) = False
-isTyCon (Succ  {}) = False
-isTyCon (BOX   {}) = True
-isTyCon (Box   {}) = False
-isTyCon (E     {}) = False
-isTyCon (CloT  {}) = False
-isTyCon (DCloT {}) = False
-
-||| true if a term is syntactically a type, or a neutral.
-public export %inline
-isTyConE : Term {} -> Bool
-isTyConE s = isTyCon s || isE s
-
-||| true if a term is syntactically a type.
-public export %inline
-isAnnTyCon : Elim {} -> Bool
-isAnnTyCon (Ann ty (TYPE {}) _) = isTyCon ty
-isAnnTyCon _                    = False
-
-public export %inline
-isK : Dim d -> Bool
-isK (K {}) = True
-isK _      = False
-
-
-mutual
-  public export
-  isRedexE : RedexTest Elim
-  isRedexE defs (F {x, _}) {d, n} =
-    isJust $ lookupElim x defs {d, n}
-  isRedexE _ (B {}) = False
-  isRedexE defs (App {fun, _}) =
-    isRedexE defs fun || isLamHead fun
-  isRedexE defs (CasePair {pair, _}) =
-    isRedexE defs pair || isPairHead pair
-  isRedexE defs (CaseEnum {tag, _}) =
-    isRedexE defs tag || isTagHead tag
-  isRedexE defs (CaseNat {nat, _}) =
-    isRedexE defs nat || isNatHead nat
-  isRedexE defs (CaseBox {box, _}) =
-    isRedexE defs box || isBoxHead box
-  isRedexE defs (DApp {fun, arg, _}) =
-    isRedexE defs fun || isDLamHead fun || isK arg
-  isRedexE defs (Ann {tm, ty, _}) =
-    isE tm || isRedexT defs tm || isRedexT defs ty
-  isRedexE defs (Coe {val, _}) =
-    isRedexT defs val || not (isE val)
-  isRedexE defs (Comp {ty, r, _}) =
-    isRedexT defs ty || isK r
-  isRedexE defs (TypeCase {ty, ret, _}) =
-    isRedexE defs ty || isRedexT defs ret || isAnnTyCon ty
-  isRedexE _ (CloE  {}) = True
-  isRedexE _ (DCloE {}) = True
-
-  public export
-  isRedexT : RedexTest Term
-  isRedexT _    (CloT  {}) = True
-  isRedexT _    (DCloT {}) = True
-  isRedexT defs (E {e, _}) = isAnn e || isRedexE defs e
-  isRedexT _    _          = False
-
-
-public export
-tycaseRhs : (k : TyConKind) -> TypeCaseArms d n ->
-            Maybe (ScopeTermN (arity k) d n)
-tycaseRhs k arms = lookupPrecise k arms
-
-public export
-tycaseRhsDef : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
-               ScopeTermN (arity k) d n
-tycaseRhsDef def k arms = fromMaybe (SN def) $ tycaseRhs k arms
-
-public export
-tycaseRhs0 : (k : TyConKind) -> TypeCaseArms d n ->
-             (0 eq : arity k = 0) => Maybe (Term d n)
-tycaseRhs0 k arms {eq} with (tycaseRhs k arms) | (arity k)
-  tycaseRhs0 k arms {eq = Refl} | res | 0 = map (.term) res
-
-public export
-tycaseRhsDef0 : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
-                (0 eq : arity k = 0) => Term d n
-tycaseRhsDef0 def k arms = fromMaybe def $ tycaseRhs0 k arms
-
-
-
-private
-weakDS : (by : Nat) -> DScopeTerm d n -> DScopeTerm d (by + n)
-weakDS by (S names (Y body)) = S names $ Y $ weakT by body
-weakDS by (S names (N body)) = S names $ N $ weakT by body
-
-private
-dweakS : (by : Nat) -> ScopeTerm d n -> ScopeTerm (by + d) n
-dweakS by (S names (Y body)) = S names $ Y $ dweakT by body
-dweakS by (S names (N body)) = S names $ N $ dweakT by body
-
-private
-coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc ->
-            ScopeTermN s d n -> ScopeTermN s d n
-coeScoped ty p q loc (S names (Y body)) =
-  S names $ Y $ E $ Coe (weakDS s ty) p q body loc
-coeScoped ty p q loc (S names (N body)) =
-  S names $ N $ E $ Coe ty p q body loc
-
-
-export covering
-CanWhnf Term Reduce.isRedexT
-
-export covering
-CanWhnf Elim Reduce.isRedexE
-
-parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
-  ||| performs the minimum work required to recompute the type of an elim.
-  |||
-  ||| ⚠ **assumes the elim is already typechecked.** ⚠
-  export covering
-  computeElimType : (e : Elim d n) -> (0 ne : No (isRedexE defs e)) =>
-                    Eff Whnf (Term d n)
-  computeElimType (F {x, u, loc}) = do
-    let Just def = lookup x defs | Nothing => throw $ NotInScope loc x
-    pure $ displace u def.type
-  computeElimType (B {i, _}) = pure $ ctx.tctx !! i
-  computeElimType (App {fun = f, arg = s, loc}) {ne} = do
-    Pi {arg, res, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne}
-      | t => throw $ ExpectedPi loc ctx.names t
-    pure $ sub1 res $ Ann s arg loc
-  computeElimType (CasePair {pair, ret, _}) = pure $ sub1 ret pair
-  computeElimType (CaseEnum {tag, ret, _}) = pure $ sub1 ret tag
-  computeElimType (CaseNat {nat, ret, _}) = pure $ sub1 ret nat
-  computeElimType (CaseBox {box, ret, _}) = pure $ sub1 ret box
-  computeElimType (DApp {fun = f, arg = p, loc}) {ne} = do
-    Eq {ty, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne}
-      | t => throw $ ExpectedEq loc ctx.names t
-    pure $ dsub1 ty p
-  computeElimType (Ann {ty, _}) = pure ty
-  computeElimType (Coe {ty, q, _}) = pure $ dsub1 ty q
-  computeElimType (Comp {ty, _}) = pure ty
-  computeElimType (TypeCase {ret, _}) = pure ret
-
-parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext (S d) n)
-  ||| for π.(x : A) → B, returns (A, B);
-  ||| for an elim returns a pair of type-cases that will reduce to that;
-  ||| for other intro forms error
-  private covering
-  tycasePi : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
-             Eff Whnf (Term (S d) n, ScopeTerm (S d) n)
-  tycasePi (Pi {arg, res, _}) = pure (arg, res)
-  tycasePi (E e) {tnf} = do
-    ty <- computeElimType defs ctx e @{noOr2 tnf}
-    let loc  = e.loc
-        narg = mnb "Arg"; nret = mnb "Ret"
-        arg  = E $ typeCase1Y e ty KPi [< !narg, !nret] (BVT 1 loc) loc
-        res' = typeCase1Y e (Arr Zero arg ty loc) KPi [< !narg, !nret]
-                 (BVT 0 loc) loc
-        res  = SY [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc
-    pure (arg, res)
-  tycasePi t = throw $ ExpectedPi t.loc ctx.names t
-
-  ||| for (x : A) × B, returns (A, B);
-  ||| for an elim returns a pair of type-cases that will reduce to that;
-  ||| for other intro forms error
-  private covering
-  tycaseSig : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
-              Eff Whnf (Term (S d) n, ScopeTerm (S d) n)
-  tycaseSig (Sig {fst, snd, _}) = pure (fst, snd)
-  tycaseSig (E e) {tnf} = do
-    ty <- computeElimType defs ctx e @{noOr2 tnf}
-    let loc  = e.loc
-        nfst = mnb "Fst"; nsnd = mnb "Snd"
-        fst  = E $ typeCase1Y e ty KSig [< !nfst, !nsnd] (BVT 1 loc) loc
-        snd' = typeCase1Y e (Arr Zero fst ty loc) KSig [< !nfst, !nsnd]
-                 (BVT 0 loc) loc
-        snd  = SY [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc
-    pure (fst, snd)
-  tycaseSig t = throw $ ExpectedSig t.loc ctx.names t
-
-  ||| for [π. A], returns A;
-  ||| for an elim returns a type-case that will reduce to that;
-  ||| for other intro forms error
-  private covering
-  tycaseBOX : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
-              Eff Whnf (Term (S d) n)
-  tycaseBOX (BOX {ty, _}) = pure ty
-  tycaseBOX (E e) {tnf} = do
-    ty <- computeElimType defs ctx e @{noOr2 tnf}
-    pure $ E $ typeCase1Y e ty KBOX [< !(mnb "Ty")] (BVT 0 e.loc) e.loc
-  tycaseBOX t = throw $ ExpectedBOX t.loc ctx.names t
-
-  ||| for Eq [i ⇒ A] l r, returns (A‹0/i›, A‹1/i›, A, l, r);
-  ||| for an elim returns five type-cases that will reduce to that;
-  ||| for other intro forms error
-  private covering
-  tycaseEq : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
-             Eff Whnf (Term (S d) n, Term (S d) n, DScopeTerm (S d) n,
-                       Term (S d) n, Term (S d) n)
-  tycaseEq (Eq {ty, l, r, _}) = pure (ty.zero, ty.one, ty, l, r)
-  tycaseEq (E e) {tnf} = do
-    ty <- computeElimType defs ctx e @{noOr2 tnf}
-    let loc   = e.loc
-        names = traverse' (\x => mnb x) [< "A0", "A1", "A", "L", "R"]
-        a0    = E $ typeCase1Y e ty KEq !names (BVT 4 loc) loc
-        a1    = E $ typeCase1Y e ty KEq !names (BVT 3 loc) loc
-        a'    = typeCase1Y e (Eq0 ty a0 a1 loc) KEq !names (BVT 2 loc) loc
-        a     = SY [< !(mnb "i")] $ E $ DApp (dweakE 1 a') (B VZ loc) loc
-        l     = E $ typeCase1Y e a0 KEq !names (BVT 1 loc) loc
-        r     = E $ typeCase1Y e a1 KEq !names (BVT 0 loc) loc
-    pure (a0, a1, a, l, r)
-  tycaseEq t = throw $ ExpectedEq t.loc ctx.names t
-
--- new block because the functions below might pass a different ctx
--- into the ones above
-parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
-  ||| reduce a function application `App (Coe ty p q val) s loc`
-  private covering
-  piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
-          (val, s : Term d n) -> Loc ->
-          Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
-  piCoe sty@(S [< i] ty) p q val s loc = do
-    -- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝
-    -- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›)
-    --   where 𝒔‹j› ≔ coe [i ⇒ A] @q @j s
-    --
-    -- type-case is used to expose A,B if the type is neutral
-    let ctx1 = extendDim i ctx
-    Element ty tynf <- whnf defs ctx1 ty.term
-    (arg, res) <- tycasePi defs ctx1 ty
-    let s0   = CoeT i arg q p s s.loc
-        body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc
-        s1   = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
-                    (s // shift 1) s.loc
-    whnf defs ctx $ CoeT i (sub1 res s1) p q body loc
-
-  ||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc`
-  private covering
-  sigCoe : (qty : Qty) ->
-           (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-           (ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> Loc ->
-           Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
-  sigCoe qty sty@(S [< i] ty) p q val ret body loc = do
-    -- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e }
-    -- ⇝
-    -- caseπ s ∷ ((x : A) × B)‹p/i› return z ⇒ C
-    -- of { (a, b) ⇒
-    --   e[(coe [i ⇒ A] @p @q a)/a,
-    --     (coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i a)/x]] @p @q b)/b] }
-    --
-    -- type-case is used to expose A,B if the type is neutral
-    let ctx1 = extendDim i ctx
-    Element ty tynf <- whnf defs ctx1 ty.term
-    (tfst, tsnd) <- tycaseSig defs ctx1 ty
-    let [< x, y] = body.names
-        a' = CoeT i (weakT 2 tfst) p q (BVT 1 noLoc) x.loc
-        tsnd' = tsnd.term //
-          (CoeT i (weakT 2 $ tfst // (B VZ noLoc ::: shift 2))
-            (weakD 1 p) (B VZ noLoc) (BVT 1 noLoc) y.loc ::: shift 2)
-        b' = CoeT i tsnd' p q (BVT 0 noLoc) y.loc
-    whnf defs ctx $ CasePair qty (Ann val (ty // one p) val.loc) ret
-      (ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc
-
-  ||| reduce a dimension application `DApp (Coe ty p q val) r loc`
-  private covering
-  eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-          (r : Dim d) -> Loc ->
-          Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
-  eqCoe sty@(S [< j] ty) p q val r loc = do
-    -- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r
-    -- ⇝
-    -- comp [j ⇒ A‹r/i›] @p @q (eq ∷ (Eq [i ⇒ A] L R)‹p/j›)
-    --   @r { 0 j ⇒ L; 1 j ⇒ R }
-    let ctx1 = extendDim j ctx
-    Element ty tynf <- whnf defs ctx1 ty.term
-    (a0, a1, a, s, t) <- tycaseEq defs ctx1 ty
-    let a'   = dsub1 a (weakD 1 r)
-        val' = E $ DApp (Ann val (ty // one p) val.loc) r loc
-    whnf defs ctx $ CompH j a' p q val' r j s j t loc
-
-  ||| reduce a pair elimination `CaseBox pi (Coe ty p q val) ret body`
-  private covering
-  boxCoe : (qty : Qty) ->
-           (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-           (ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> Loc ->
-           Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
-  boxCoe qty sty@(S [< i] ty) p q val ret body loc = do
-    -- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e }
-    -- ⇝
-    -- caseπ s ∷ [ρ. A]‹p/i› return z ⇒ C
-    -- of { [a] ⇒ e[(coe [i ⇒ A] p q a)/a] }
-    let ctx1 = extendDim i ctx
-    Element ty tynf <- whnf defs ctx1 ty.term
-    ta <- tycaseBOX defs ctx1 ty
-    let a' = CoeT i (weakT 1 ta) p q (BVT 0 noLoc) body.name.loc
-    whnf defs ctx $ CaseBox qty (Ann val (ty // one p) val.loc) ret
-      (ST body.names $ body.term // (a' ::: shift 1)) loc
-
-
-||| reduce a type-case applied to a type constructor
-private covering
-reduceTypeCase : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
-                 (ty : Term d n) -> (u : Universe) -> (ret : Term d n) ->
-                 (arms : TypeCaseArms d n) -> (def : Term d n) ->
-                 (0 _ : So (isTyCon ty)) => Loc ->
-                 Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
-reduceTypeCase defs ctx ty u ret arms def loc = case ty of
-  -- (type-case ★ᵢ ∷ _ return Q of { ★ ⇒ s; ⋯ }) ⇝ s ∷ Q
-  TYPE {} =>
-    whnf defs ctx $ Ann (tycaseRhsDef0 def KTYPE arms) ret loc
-
-  -- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝
-  -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
-  Pi {arg, res, loc = piLoc, _} =>
-    let arg' = Ann arg (TYPE u noLoc) arg.loc
-        res' = Ann (Lam res res.loc)
-                   (Arr Zero arg (TYPE u noLoc) arg.loc) res.loc
-    in
-    whnf defs ctx $
-      Ann (subN (tycaseRhsDef def KPi arms) [< arg', res']) ret loc
-
-  -- (type-case (x : A) × B ∷ ★ᵢ return Q of { (a × b) ⇒ s; ⋯ }) ⇝
-  -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
-  Sig {fst, snd, loc = sigLoc, _} =>
-    let fst' = Ann fst (TYPE u noLoc) fst.loc
-        snd' = Ann (Lam snd snd.loc)
-                   (Arr Zero fst (TYPE u noLoc) fst.loc) snd.loc
-    in
-    whnf defs ctx $
-      Ann (subN (tycaseRhsDef def KSig arms) [< fst', snd']) ret loc
-
-  -- (type-case {⋯} ∷ _ return Q of { {} ⇒ s; ⋯ }) ⇝ s ∷ Q
-  Enum {} =>
-    whnf defs ctx $ Ann (tycaseRhsDef0 def KEnum arms) ret loc
-
-  -- (type-case Eq [i ⇒ A] L R ∷ ★ᵢ return Q
-  --  of { Eq a₀ a₁ a l r ⇒ s; ⋯ }) ⇝
-  -- s[(A‹0/i› ∷ ★ᵢ)/a₀, (A‹1/i› ∷ ★ᵢ)/a₁,
-  --   ((δ i ⇒ A) ∷ Eq [★ᵢ] A‹0/i› A‹1/i›)/a,
-  --   (L ∷ A‹0/i›)/l, (R ∷ A‹1/i›)/r] ∷ Q
-  Eq {ty = a, l, r, loc = eqLoc, _} =>
-    let a0 = a.zero; a1 = a.one in
-    whnf defs ctx $ Ann
-      (subN (tycaseRhsDef def KEq arms)
-         [< Ann a0 (TYPE u noLoc) a.loc, Ann a1 (TYPE u noLoc) a.loc,
-            Ann (DLam a a.loc) (Eq0 (TYPE u noLoc) a0 a1 a.loc) a.loc,
-            Ann l a0 l.loc, Ann r a1 r.loc])
-      ret loc
-
-  -- (type-case ℕ ∷ _ return Q of { ℕ ⇒ s; ⋯ }) ⇝ s ∷ Q
-  Nat {} =>
-    whnf defs ctx $ Ann (tycaseRhsDef0 def KNat arms) ret loc
-
-  -- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q
-  BOX {ty = a, loc = boxLoc, _} =>
-    whnf defs ctx $ Ann
-      (sub1 (tycaseRhsDef def KBOX arms) (Ann a (TYPE u noLoc) a.loc))
-      ret loc
-
-
-||| pushes a coercion inside a whnf-ed term
-private covering
-pushCoe : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
-          BindName ->
-          (ty : Term (S d) n) -> (0 tynf : No (isRedexT defs ty)) =>
-          Dim d -> Dim d ->
-          (s : Term d n) -> (0 snf : No (isRedexT defs s)) => Loc ->
-          Eff Whnf (NonRedex Elim d n defs)
-pushCoe defs ctx i ty p q s loc =
-  if p == q then whnf defs ctx $ Ann s (ty // one q) loc else
-  case s of
-    -- (coe [_ ⇒ ★ᵢ] @_ @_ ty) ⇝ (ty ∷ ★ᵢ)
-    TYPE {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
-    Pi   {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
-    Sig  {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
-    Enum {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
-    Eq   {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
-    Nat  {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
-    BOX  {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
-
-    -- just η expand it. then whnf for App will handle it later
-    -- this is how @xtt does it
-    --
-    -- (coe [i ⇒ A] @p @q (λ x ⇒ s)) ⇝
-    -- (λ y ⇒ (coe [i ⇒ A] @p @q (λ x ⇒ s)) y) ∷ A‹q/i› ⇝ ⋯
-    lam@(Lam {body, _}) => do
-      let lam'  = CoeT i ty p q lam loc
-          term' = LamY !(fresh body.name)
-                    (E $ App (weakE 1 lam') (BVT 0 noLoc) loc) loc
-          type' = ty // one q
-      whnf defs ctx $ Ann term' type' loc
-
-    -- (coe [i ⇒ (x : A) × B] @p @q (s, t)) ⇝
-    -- (coe [i ⇒ A] @p @q s,
-    --  coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i s)/x]] @p @q t)
-    --   ∷ (x : A‹q/i›) × B‹q/i›
-    --
-    -- can't use η here because... it doesn't exist
-    Pair {fst, snd, loc = pairLoc} => do
-      let Sig {fst = tfst, snd = tsnd, loc = sigLoc} = ty
-        | _ => throw $ ExpectedSig ty.loc (extendDim i ctx.names) ty
-      let fst'  = E $ CoeT i tfst p q fst fst.loc
-          tfst' = tfst // (B VZ noLoc ::: shift 2)
-          tsnd' = sub1 tsnd $
-                  CoeT !(fresh i) tfst' (weakD 1 p) (B VZ noLoc)
-                    (dweakT 1 fst) fst.loc
-          snd'  = E $ CoeT i tsnd' p q snd snd.loc
-      pure $
-        Element (Ann (Pair fst' snd' pairLoc)
-                     (Sig (tfst // one q) (tsnd // one q) sigLoc) loc) Ah
-
-    -- η expand, like for Lam
-    --
-    -- (coe [i ⇒ A] @p @q (δ j ⇒ s)) ⇝
-    -- (δ k ⇒ (coe [i ⇒ A] @p @q (δ j ⇒ s)) @k) ∷ A‹q/i› ⇝ ⋯
-    dlam@(DLam {body, _}) => do
-      let dlam' = CoeT i ty p q dlam loc
-          term' = DLamY !(mnb "j")
-                    (E $ DApp (dweakE 1 dlam') (B VZ noLoc) loc) loc
-          type' = ty // one q
-      whnf defs ctx $ Ann term' type' loc
-
-    -- (coe [_ ⇒ {⋯}] @_ @_ t) ⇝ (t ∷ {⋯})
-    Tag {tag, loc = tagLoc} => do
-      let Enum {cases, loc = enumLoc} = ty
-        | _ => throw $ ExpectedEnum ty.loc (extendDim i ctx.names) ty
-      pure $ Element (Ann (Tag tag tagLoc) (Enum cases enumLoc) loc) Ah
-
-    -- (coe [_ ⇒ ℕ] @_ @_ n) ⇝ (n ∷ ℕ)
-    Zero {loc = zeroLoc} => do
-      pure $ Element (Ann (Zero zeroLoc) (Nat ty.loc) loc) Ah
-    Succ {p = pred, loc = succLoc} => do
-      pure $ Element (Ann (Succ pred succLoc) (Nat ty.loc) loc) Ah
-
-    -- (coe [i ⇒ [π.A]] @p @q [s]) ⇝
-    -- [coe [i ⇒ A] @p @q s] ∷ [π. A‹q/i›]
-    Box {val, loc = boxLoc} => do
-      let BOX {qty, ty = a, loc = tyLoc} = ty
-        | _ => throw $ ExpectedBOX ty.loc (extendDim i ctx.names) ty
-      pure $ Element
-        (Ann (Box (E $ CoeT i a p q val val.loc) boxLoc)
-             (BOX qty (a // one q) tyLoc) loc)
-        Ah
-
-    E e => pure $ Element (CoeT i ty p q (E e) e.loc) (snf `orNo` Ah)
-where
-  unwrapTYPE : Term (S d) n -> Eff Whnf Universe
-  unwrapTYPE (TYPE {l, _}) = pure l
-  unwrapTYPE ty = throw $ ExpectedTYPE ty.loc (extendDim i ctx.names) ty
-
-
-export covering
-CanWhnf Elim Reduce.isRedexE where
-  whnf defs ctx (F x u loc) with (lookupElim x defs) proof eq
-    _ | Just y  = whnf defs ctx $ setLoc loc $ displace u y
-    _ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah
-
-  whnf _ _ (B i loc) = pure $ nred $ B i loc
-
-  -- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x]
-  whnf defs ctx (App f s appLoc) = do
-    Element f fnf <- whnf defs ctx f
-    case nchoose $ isLamHead f of
-      Left _ => case f of
-        Ann (Lam {body, _}) (Pi {arg, res, _}) floc =>
-          let s = Ann s arg s.loc in
-          whnf defs ctx $ Ann (sub1 body s) (sub1 res s) appLoc
-        Coe ty p q val _ => piCoe defs ctx ty p q val s appLoc
-      Right nlh => pure $ Element (App f s appLoc) $ fnf `orNo` nlh
-
-  -- case (s, t) ∷ (x : A) × B return p ⇒ C of { (a, b) ⇒ u } ⇝
-  -- u[s∷A/a, t∷B[s∷A/x]] ∷ C[(s, t)∷((x : A) × B)/p]
-  whnf defs ctx (CasePair pi pair ret body caseLoc) = do
-    Element pair pairnf <- whnf defs ctx pair
-    case nchoose $ isPairHead pair of
-      Left _ => case pair of
-        Ann (Pair {fst, snd, _}) (Sig {fst = tfst, snd = tsnd, _}) pairLoc =>
-          let fst = Ann fst tfst fst.loc
-              snd = Ann snd (sub1 tsnd fst) snd.loc
-          in
-          whnf defs ctx $ Ann (subN body [< fst, snd]) (sub1 ret pair) caseLoc
-        Coe ty p q val _ => do
-          sigCoe defs ctx pi ty p q val ret body caseLoc
-      Right np =>
-        pure $ Element (CasePair pi pair ret body caseLoc) $ pairnf `orNo` np
-
-  -- case 'a ∷ {a,…} return p ⇒ C of { 'a ⇒ u } ⇝
-  -- u ∷ C['a∷{a,…}/p]
-  whnf defs ctx (CaseEnum pi tag ret arms caseLoc) = do
-    Element tag tagnf <- whnf defs ctx tag
-    case nchoose $ isTagHead tag of
-      Left _ => case tag of
-        Ann (Tag t _) (Enum ts _) _ =>
-          let ty = sub1 ret tag in
-          case lookup t arms of
-            Just arm => whnf defs ctx $ Ann arm ty arm.loc
-            Nothing  => throw $ MissingEnumArm caseLoc t (keys arms)
-        Coe ty p q val _ =>
-          -- there is nowhere an equality can be hiding inside an enum type
-          whnf defs ctx $
-            CaseEnum pi (Ann val (dsub1 ty q) val.loc) ret arms caseLoc
-      Right nt =>
-        pure $ Element (CaseEnum pi tag ret arms caseLoc) $ tagnf `orNo` nt
-
-  -- case zero ∷ ℕ return p ⇒ C of { zero ⇒ u; … } ⇝
-  --   u ∷ C[zero∷ℕ/p]
-  --
-  -- case succ n ∷ ℕ return p ⇒ C of { succ n', π.ih ⇒ u; … } ⇝
-  --   u[n∷ℕ/n', (case n ∷ ℕ ⋯)/ih] ∷ C[succ n ∷ ℕ/p]
-  whnf defs ctx (CaseNat pi piIH nat ret zer suc caseLoc) = do
-    Element nat natnf <- whnf defs ctx nat
-    case nchoose $ isNatHead nat of
-      Left _ =>
-        let ty = sub1 ret nat in
-        case nat of
-          Ann (Zero _) (Nat _) _ =>
-            whnf defs ctx $ Ann zer ty zer.loc
-          Ann (Succ n succLoc) (Nat natLoc) _ =>
-            let nn = Ann n (Nat natLoc) succLoc
-                tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc]
-            in
-            whnf defs ctx $ Ann tm ty caseLoc
-          Coe ty p q val _ =>
-            -- same deal as Enum
-            whnf defs ctx $
-              CaseNat pi piIH (Ann val (dsub1 ty q) val.loc) ret zer suc caseLoc
-      Right nn => pure $
-        Element (CaseNat pi piIH nat ret zer suc caseLoc) $ natnf `orNo` nn
-
-  -- case [t] ∷ [π.A] return p ⇒ C of { [x] ⇒ u } ⇝
-  --   u[t∷A/x] ∷ C[[t] ∷ [π.A]/p]
-  whnf defs ctx (CaseBox pi box ret body caseLoc) = do
-    Element box boxnf <- whnf defs ctx box
-    case nchoose $ isBoxHead box of
-      Left _ => case box of
-        Ann (Box val boxLoc) (BOX q bty tyLoc) _ =>
-          let ty = sub1 ret box in
-          whnf defs ctx $ Ann (sub1 body (Ann val bty val.loc)) ty caseLoc
-        Coe ty p q val _ =>
-          boxCoe defs ctx pi ty p q val ret body caseLoc
-      Right nb =>
-        pure $ Element (CaseBox pi box ret body caseLoc) $ boxnf `orNo` nb
-
-  -- e : Eq (𝑗 ⇒ A) t u ⊢ e @0 ⇝ t ∷ A‹0/𝑗›
-  -- e : Eq (𝑗 ⇒ A) t u ⊢ e @1 ⇝ u ∷ A‹1/𝑗›
-  --
-  -- ((δ 𝑖 ⇒ s) ∷ Eq (𝑗 ⇒ A) t u) @𝑘 ⇝ s‹𝑘/𝑖› ∷ A‹𝑘/𝑗›
-  whnf defs ctx (DApp f p appLoc) = do
-    Element f fnf <- whnf defs ctx f
-    case nchoose $ isDLamHead f of
-      Left _ => case f of
-        Ann (DLam {body, _}) (Eq {ty, l, r, _}) _ =>
-          whnf defs ctx $
-            Ann (endsOr (setLoc appLoc l) (setLoc appLoc r) (dsub1 body p) p)
-                (dsub1 ty p) appLoc
-        Coe ty p' q' val _ =>
-          eqCoe defs ctx ty p' q' val p appLoc
-      Right ndlh => case p of
-        K e _ => do
-          Eq {l, r, ty, _} <- whnf0 defs ctx =<< computeElimType defs ctx f
-            | ty => throw $ ExpectedEq ty.loc ctx.names ty
-          whnf defs ctx $
-            ends (Ann (setLoc appLoc l) ty.zero appLoc)
-                 (Ann (setLoc appLoc r) ty.one  appLoc) e
-        B {} => pure $ Element (DApp f p appLoc) $ fnf `orNo` ndlh `orNo` Ah
-
-  -- e ∷ A ⇝ e
-  whnf defs ctx (Ann s a annLoc) = do
-    Element s snf <- whnf defs ctx s
-    case nchoose $ isE s of
-      Left  _  => let E e = s in pure $ Element e $ noOr2 snf
-      Right ne => do
-        Element a anf <- whnf defs ctx a
-        pure $ Element (Ann s a annLoc) $ ne `orNo` snf `orNo` anf
-
-  whnf defs ctx (Coe (S _ (N ty)) _ _ val coeLoc) =
-    whnf defs ctx $ Ann val ty coeLoc
-  whnf defs ctx (Coe (S [< i] ty) p q val coeLoc) = do
-    Element ty  tynf  <- whnf defs (extendDim i ctx) ty.term
-    Element val valnf <- whnf defs ctx val
-    pushCoe defs ctx i ty p q val coeLoc
-
-  whnf defs ctx (Comp ty p q val r zero one compLoc) =
-    -- comp [A] @p @p s { ⋯ } ⇝ s ∷ A
-    if p == q then whnf defs ctx $ Ann val ty compLoc else
-    case nchoose (isK r) of
-      -- comp [A] @p @q s @0 { 0 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A
-      -- comp [A] @p @q s @1 { 1 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A
-      Left y => case r of
-        K Zero _ => whnf defs ctx $ Ann (dsub1 zero q) ty compLoc
-        K One  _ => whnf defs ctx $ Ann (dsub1 one  q) ty compLoc
-      Right nk => do
-        Element ty tynf <- whnf defs ctx ty
-        pure $ Element (Comp ty p q val r zero one compLoc) $ tynf `orNo` nk
-
-  whnf defs ctx (TypeCase ty ret arms def tcLoc) = do
-    Element ty  tynf  <- whnf defs ctx ty
-    Element ret retnf <- whnf defs ctx ret
-    case nchoose $ isAnnTyCon ty of
-      Left  y  =>
-        let Ann ty (TYPE u _) _ = ty in
-        reduceTypeCase defs ctx ty u ret arms def tcLoc
-      Right nt => pure $
-        Element (TypeCase ty ret arms def tcLoc) (tynf `orNo` retnf `orNo` nt)
-
-  whnf defs ctx (CloE  (Sub el th)) = whnf defs ctx $ pushSubstsWith' id th el
-  whnf defs ctx (DCloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' th id el
-
-export covering
-CanWhnf Term Reduce.isRedexT where
-  whnf _ _ t@(TYPE {}) = pure $ nred t
-  whnf _ _ t@(Pi   {}) = pure $ nred t
-  whnf _ _ t@(Lam  {}) = pure $ nred t
-  whnf _ _ t@(Sig  {}) = pure $ nred t
-  whnf _ _ t@(Pair {}) = pure $ nred t
-  whnf _ _ t@(Enum {}) = pure $ nred t
-  whnf _ _ t@(Tag  {}) = pure $ nred t
-  whnf _ _ t@(Eq   {}) = pure $ nred t
-  whnf _ _ t@(DLam {}) = pure $ nred t
-  whnf _ _ t@(Nat  {}) = pure $ nred t
-  whnf _ _ t@(Zero {}) = pure $ nred t
-  whnf _ _ t@(Succ {}) = pure $ nred t
-  whnf _ _ t@(BOX  {}) = pure $ nred t
-  whnf _ _ t@(Box  {}) = pure $ nred t
-
-  -- s ∷ A ⇝ s   (in term context)
-  whnf defs ctx (E e) = do
-    Element e enf <- whnf defs ctx e
-    case nchoose $ isAnn e of
-      Left  _  => let Ann {tm, _} = e in pure $ Element tm $ noOr1 $ noOr2 enf
-      Right na => pure $ Element (E e) $ na `orNo` enf
-
-  whnf defs ctx (CloT  (Sub tm th)) = whnf defs ctx $ pushSubstsWith' id th tm
-  whnf defs ctx (DCloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' th id tm

lib/Quox/Scoped.idr

@@ -0,0 +1,59 @@
+module Quox.Scoped
+
+import public Quox.Var
+import public Quox.Context
+
+import Derive.Prelude
+
+%language ElabReflection
+%default total
+
+
+public export
+data ScopedBody : Nat -> (Nat -> Type) -> Nat -> Type where
+  Y : (body : f (s + n)) -> ScopedBody s f n
+  N : (body : f n)       -> ScopedBody s f n
+%name ScopedBody body
+
+export %inline %hint
+EqScopedBody : (forall n. Eq (f n)) => Eq (ScopedBody s f n)
+EqScopedBody = deriveEq
+
+export %inline %hint
+ShowScopedBody : (forall n. Show (f n)) => Show (ScopedBody s f n)
+ShowScopedBody = deriveShow
+
+||| a scoped term with names
+public export
+record Scoped (s : Nat) (f : Nat -> Type) (n : Nat) where
+  constructor S
+  names : BContext s
+  body  : ScopedBody s f n
+%name Scoped body
+
+export %inline
+(forall n. Eq (f n)) => Eq (Scoped s f n) where
+  s == t = s.body == t.body
+
+export %inline %hint
+ShowScoped : (forall n. Show (f n)) => Show (Scoped s f n)
+ShowScoped = deriveShow
+
+
+||| scope which ignores all its binders
+public export %inline
+SN : Located1 f => {s : Nat} -> f n -> Scoped s f n
+SN body = S (replicate s $ BN Unused body.loc) $ N body
+
+||| scope which uses its binders
+public export %inline
+SY : BContext s -> f (s + n) -> Scoped s f n
+SY ns = S ns . Y
+
+public export %inline
+name : Scoped 1 f n -> BindName
+name (S [< x] _) = x
+
+public export %inline
+(.name) : Scoped 1 f n -> BindName
+s.name = name s

lib/Quox/Syntax.idr

@@ -6,4 +6,5 @@ import public Quox.Syntax.Qty
 import public Quox.Syntax.Shift
 import public Quox.Syntax.Subst
 import public Quox.Syntax.Term
-import public Quox.Syntax.Var
+import public Quox.Syntax.Builtin
+import public Quox.Var

lib/Quox/Syntax/Builtin.idr

@@ -0,0 +1,27 @@
+module Quox.Syntax.Builtin
+
+import Derive.Prelude
+import Quox.PrettyValExtra
+import Quox.Pretty
+import Quox.Syntax.Term
+
+
+%default total
+%language ElabReflection
+
+public export
+data Builtin
+= Main
+%runElab derive "Builtin" [Eq, Ord, Show, PrettyVal]
+
+public export
+builtinDesc : Builtin -> String
+builtinDesc Main = "a function declared as #[main]"
+
+public export
+builtinTypeDoc : {opts : LayoutOpts} -> Builtin -> Eff Pretty (Doc opts)
+builtinTypeDoc Main =
+  prettyTerm [<] [<] $
+    Pi One (IOState noLoc)
+      (SN $ Sig (Enum (fromList [!(ifUnicode "𝑎" "a")]) noLoc)
+                (SN (IOState noLoc)) noLoc) noLoc

lib/Quox/Syntax/Dim.idr

@@ -2,10 +2,11 @@ module Quox.Syntax.Dim
 
 import Quox.Loc
 import Quox.Name
-import Quox.Syntax.Var
+import Quox.Var
 import Quox.Syntax.Subst
 import Quox.Pretty
 import Quox.Context
+import Quox.PrettyValExtra
 
 import Decidable.Equality
 import Control.Function
@@ -18,7 +19,7 @@ import Derive.Prelude
 public export
 data DimConst = Zero | One
 %name DimConst e
-%runElab derive "DimConst" [Eq, Ord, Show]
+%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal]
 
 ||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
 public export

lib/Quox/Syntax/DimEq.idr

@@ -1,11 +1,12 @@
 module Quox.Syntax.DimEq
 
-import public Quox.Syntax.Var
+import public Quox.Var
 import public Quox.Syntax.Dim
 import public Quox.Syntax.Subst
 import public Quox.Context
 import Quox.Pretty
 import Quox.Name
+import Quox.FreeVars
 
 import Data.Maybe
 import Data.Nat
@@ -58,10 +59,15 @@ Traversable (IfConsistent eqs) where
   traverse f Nothing  = pure Nothing
   traverse f (Just x) = Just <$> f x
 
+public export
+ifConsistentElse : Applicative f => (eqs : DimEq d) ->
+                   f a -> f () -> f (IfConsistent eqs a)
+ifConsistentElse ZeroIsOne yes no = Nothing <$  no
+ifConsistentElse (C _)     yes no = Just    <$> yes
+
 public export
 ifConsistent : Applicative f => (eqs : DimEq d) -> f a -> f (IfConsistent eqs a)
-ifConsistent ZeroIsOne act = pure Nothing
-ifConsistent (C _)     act = Just <$> act
+ifConsistent eqs act = ifConsistentElse eqs act (pure ())
 
 public export
 toMaybe : IfConsistent eqs a -> Maybe a
@@ -70,13 +76,13 @@ toMaybe (Just x) = Just x
 
 
 export
-fromGround' : Context' DimConst d -> DimEq' d
-fromGround' [<]        = [<]
-fromGround' (ctx :< e) = fromGround' ctx :< Just (K e noLoc)
+fromGround' : BContext d -> Context' DimConst d -> DimEq' d
+fromGround' [<]       [<]        = [<]
+fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
 
 export
-fromGround : Context' DimConst d -> DimEq d
-fromGround = C . fromGround'
+fromGround : BContext d -> Context' DimConst d -> DimEq d
+fromGround = C .: fromGround'
 
 
 public export %inline
@@ -185,20 +191,28 @@ split1 e loc eqs = case setConst VZ e loc eqs of
   C (eqs :< _) => Just (eqs, K e loc ::: id)
 
 export %inline
-split : Loc -> DimEq' (S d) -> List (Split d)
-split loc eqs = toList (split1 Zero loc eqs) <+> toList (split1 One loc eqs)
+split1' : DimConst -> Loc -> DimEq' (S d) -> List (Split d)
+split1' e loc eqs = toList $ split1 e loc eqs
+
+export %inline
+split : Loc -> DimEq' (S d) -> Bool -> List (Split d)
+split loc eqs False = split1' Zero loc eqs
+split loc eqs True  = split1' Zero loc eqs <+> split1' One loc eqs
 
 export
-splits' : Loc -> DimEq' d -> List (DSubst d 0)
-splits' _   [<]          = [id]
-splits' loc eqs@(_ :< _) =
-  [th . ph | (eqs', th) <- split loc eqs, ph <- splits' loc eqs']
+splits' : Loc -> DimEq' d -> FreeVars d -> List (DSubst d 0)
+splits' _   [<]          _  = [id]
+splits' loc eqs@(_ :< _) us = do
+  let (us, u) = uncons us
+  (eqs', th) <- split loc eqs u
+  ph         <- splits' loc eqs' us
+  pure $ th . ph
 
 ||| the Loc is put into each of the DimConsts
 export %inline
-splits : Loc -> DimEq d -> List (DSubst d 0)
-splits _   ZeroIsOne = []
-splits loc (C eqs)   = splits' loc eqs
+splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
+splits _   ZeroIsOne _   = []
+splits loc (C eqs)   fvs = splits' loc eqs fvs
 
 
 private
@@ -228,9 +242,20 @@ setSelf (B i _)    (C eqs) with (compareP i i) | (compare i.nat i.nat)
   _ | IsGT gt | GT = absurd gt
 
 
+private %inline
+dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec
+dimEqPrec vars eqs =
+  if length vars <= 1 && maybe True null eqs then Arg else Outer
+
 private
-prettyDVars : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
-prettyDVars = traverse prettyDBind . toSnocList'
+prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
+prettyDVars' = traverse prettyDBind . toSnocList'
+
+export
+prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
+prettyDVars vars =
+  parensIfM (dimEqPrec vars Nothing) $
+  fillSeparateTight !commaD $ !(prettyDVars' vars)
 
 private
 prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
@@ -247,16 +272,16 @@ prettyCsts dnames (eqs :< Just q)  =
 
 export
 prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
-prettyDimEq' dnames eqs = do
-  vars <- prettyDVars dnames
-  eqs  <- prettyCsts dnames eqs
-  let prec = if length vars <= 1 && null eqs then Arg else Outer
-  parensIfM prec $ fillSeparateTight !commaD $ toList vars ++ toList eqs
+prettyDimEq' vars eqs = do
+  vars' <- prettyDVars' vars
+  eqs'  <- prettyCsts vars eqs
+  parensIfM (dimEqPrec vars (Just eqs)) $
+    fillSeparateTight !commaD $ vars' ++ eqs'
 
 export
 prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
 prettyDimEq dnames ZeroIsOne = do
-  vars <- prettyDVars dnames
+  vars <- prettyDVars' dnames
   cst  <- prettyCst [<] (K Zero noLoc) (K One noLoc)
   pure $ separateTight !commaD $ vars :< cst
 prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs

lib/Quox/Syntax/Qty.idr

@@ -6,6 +6,7 @@ module Quox.Syntax.Qty
 
 import Quox.Pretty
 import Quox.Decidable
+import Quox.PrettyValExtra
 import Data.DPair
 import Derive.Prelude
 
@@ -20,7 +21,7 @@ import Derive.Prelude
 ||| - ω (or #): don't care. an ω variable *can* also be used 0/1 time
 public export
 data Qty = Zero | One | Any
-%runElab derive "Qty" [Eq, Ord, Show]
+%runElab derive "Qty" [Eq, Ord, Show, PrettyVal]
 %name Qty.Qty pi, rh
 
 
@@ -78,26 +79,16 @@ lub p q = if p == q then p else Any
 ||| to maintain subject reduction, only 0 or 1 can occur
 ||| for the subject of a typing judgment. see @qtt, §2.3 for more detail
 public export
-isSubj : Qty -> Bool
-isSubj Zero = True
-isSubj One  = True
-isSubj Any  = False
-
-public export
-SQty : Type
-SQty = Subset Qty $ So . isSubj
-
-public export %inline
-szero, sone : SQty
-szero = Element Zero Oh
-sone  = Element One  Oh
+data SQty = SZero | SOne
+%runElab derive "SQty" [Eq, Ord, Show, PrettyVal]
+%name Qty.SQty sg
 
 ||| "σ ⨴ π"
 |||
-||| σ ⨭ π is 0 if either of σ or π are, otherwise it is σ.
+||| σ ⨴ π is 0 if either of σ or π are, otherwise it is σ.
 public export
 subjMult : SQty -> Qty -> SQty
-subjMult _  Zero = szero
+subjMult _  Zero = SZero
 subjMult sg _    = sg
 
 
@@ -105,23 +96,59 @@ subjMult sg _    = sg
 ||| quantity of 1, so the only distinction is whether it is present
 ||| at runtime at all or not
 public export
-isGlobal : Qty -> Bool
-isGlobal Zero = True
-isGlobal One  = False
-isGlobal Any  = True
+data GQty = GZero | GAny
+%runElab derive "GQty" [Eq, Ord, Show, PrettyVal]
+%name GQty rh
 
 public export
-GQty : Type
-GQty = Subset Qty $ So . isGlobal
-
-public export
-gzero, gany : GQty
-gzero = Element Zero Oh
-gany  = Element Any  Oh
+toGlobal : Qty -> Maybe GQty
+toGlobal Zero = Just GZero
+toGlobal Any  = Just GAny
+toGlobal One  = Nothing
 
 ||| when checking a definition, a 0 definition is checked at 0,
 ||| but an ω definition is checked at 1 since ω isn't a subject quantity
 public export %inline
 globalToSubj : GQty -> SQty
-globalToSubj (Element Zero _) = szero
-globalToSubj (Element Any  _) = sone
+globalToSubj GZero = SZero
+globalToSubj GAny  = SOne
+
+
+public export
+DecEq Qty where
+  decEq Zero Zero = Yes Refl
+  decEq Zero One  = No $ \case _ impossible
+  decEq Zero Any  = No $ \case _ impossible
+  decEq One  Zero = No $ \case _ impossible
+  decEq One  One  = Yes Refl
+  decEq One  Any  = No $ \case _ impossible
+  decEq Any  Zero = No $ \case _ impossible
+  decEq Any  One  = No $ \case _ impossible
+  decEq Any  Any  = Yes Refl
+
+public export
+DecEq SQty where
+  decEq SZero SZero = Yes Refl
+  decEq SZero SOne  = No $ \case _ impossible
+  decEq SOne  SZero = No $ \case _ impossible
+  decEq SOne  SOne  = Yes Refl
+
+public export
+DecEq GQty where
+  decEq GZero GZero = Yes Refl
+  decEq GZero GAny  = No $ \case _ impossible
+  decEq GAny  GZero = No $ \case _ impossible
+  decEq GAny  GAny  = Yes Refl
+
+
+namespace SQty
+  public export %inline
+  (.qty) : SQty -> Qty
+  (SZero).qty = Zero
+  (SOne).qty  = One
+
+namespace GQty
+  public export %inline
+  (.qty) : GQty -> Qty
+  (GZero).qty = Zero
+  (GAny).qty  = Any

lib/Quox/Syntax/Shift.idr

@@ -1,9 +1,11 @@
 module Quox.Syntax.Shift
 
-import public Quox.Syntax.Var
+import public Quox.Var
 
 import Data.Nat
 import Data.So
+import Data.Singleton
+import Syntax.PreorderReasoning
 
 %default total
 
@@ -146,6 +148,25 @@ weakViaNat s by =
 %transform "Shift.weak" Shift.weak = weakViaNat
 
 
+export
+getFrom : {to : Nat} -> Shift from to -> Singleton from
+getFrom SZ      = Val to
+getFrom (SS by) = getFrom by
+
+private
+0 getFromViaNatProof : (by : Shift from to) -> from = to `minus` by.nat
+getFromViaNatProof by = Calc $
+  |~ from
+  ~~ minus (by.nat + from) by.nat ..<(minusPlus {})
+  ~~ minus to by.nat              ..<(cong (flip minus by.nat) (shiftDiff by))
+
+private
+getFromViaNat : {to : Nat} -> Shift from to -> Singleton from
+getFromViaNat by = rewrite getFromViaNatProof by in Val _
+
+%transform "Shift.getFrom" Shift.getFrom = getFromViaNat
+
+
 public export
 shift : Shift from to -> Var from -> Var to
 shift SZ      i = i
@@ -178,11 +199,12 @@ by . SS bz = SS $ by . bz
 private
 0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
                  to = by.nat + bz.nat + from
-compNatProof by bz =
-  trans (shiftDiff bz) $
-  trans (cong (bz.nat +) (shiftDiff by)) $
-  trans (plusAssociative bz.nat by.nat from) $
-  cong (+ from) (plusCommutative bz.nat by.nat)
+compNatProof by bz = Calc $
+  |~ to
+  ~~ bz.nat + mid             ...(shiftDiff {})
+  ~~ bz.nat + (by.nat + from) ...(cong (bz.nat +) (shiftDiff {}))
+  ~~ bz.nat + by.nat + from   ...(plusAssociative {})
+  ~~ by.nat + bz.nat + from   ...(cong (+ from) (plusCommutative {}))
 
 private %inline
 compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->

lib/Quox/Syntax/Subst.idr

@@ -1,12 +1,13 @@
 module Quox.Syntax.Subst
 
 import public Quox.Syntax.Shift
-import Quox.Syntax.Var
+import Quox.Var
 import Quox.Name
 
 import Data.Nat
 import Data.List
 import Data.SnocVect
+import Data.Singleton
 import Derive.Prelude
 
 %default total
@@ -95,18 +96,18 @@ map f (t ::: th) = f t ::: map f th
 
 
 public export %inline
-push : CanSubstSelf f => Subst f from to -> Subst f (S from) (S to)
-push th = fromVar VZ ::: (th . shift 1)
+push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
+push loc th = fromVarLoc VZ loc ::: (th . shift 1)
 
 -- [fixme] a better way to do this?
 public export
-pushN : CanSubstSelf f => (s : Nat) ->
+pushN : CanSubstSelf f => (s : Nat) -> Loc ->
         Subst f from to -> Subst f (s + from) (s + to)
-pushN 0     th = th
-pushN (S s) th =
+pushN 0     _   th = th
+pushN (S s) loc th =
   rewrite plusSuccRightSucc s from in
   rewrite plusSuccRightSucc s to in
-  pushN s $ fromVar VZ ::: (th . shift 1)
+  pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
 
 public export
 drop1 : Subst f (S from) to -> Subst f from to
@@ -124,6 +125,12 @@ one : f n -> Subst f (S n) n
 one x = fromSnocVect [< x]
 
 
+export
+getFrom : {to : Nat} -> Subst _ from to -> Singleton from
+getFrom (Shift by) = getFrom by
+getFrom (t ::: th) = [|S $ getFrom th|]
+
+
 ||| whether two substitutions with the same codomain have the same shape
 ||| (the same number of terms and the same shift at the end). if so, they
 ||| also have the same domain
@@ -133,7 +140,7 @@ cmpShape : Subst env from1 to -> Subst env from2 to ->
 cmpShape (Shift by) (Shift bz) = cmpLen by bz
 cmpShape (Shift _)  (_ ::: _)  = Left LT
 cmpShape (_ ::: _)  (Shift _)  = Left GT
-cmpShape (_ ::: th) (_ ::: ph) = cong S <$> cmpShape th ph
+cmpShape (_ ::: th) (_ ::: ph) = map (\x => cong S x) $ cmpShape th ph
 
 
 public export

lib/Quox/Syntax/Term/Base.idr

@@ -1,6 +1,7 @@
 module Quox.Syntax.Term.Base
 
-import public Quox.Syntax.Var
+import public Quox.Var
+import public Quox.Scoped
 import public Quox.Syntax.Shift
 import public Quox.Syntax.Subst
 import public Quox.Syntax.Qty
@@ -46,37 +47,6 @@ TagVal : Type
 TagVal = String
 
 
-public export
-data ScopedBody : Nat -> (Nat -> Type) -> Nat -> Type where
-  Y : (body : f (s + n)) -> ScopedBody s f n
-  N : (body : f n)       -> ScopedBody s f n
-%name ScopedBody body
-
-export %inline %hint
-EqScopedBody : (forall n. Eq (f n)) => Eq (ScopedBody s f n)
-EqScopedBody = deriveEq
-
-export %inline %hint
-ShowScopedBody : (forall n. Show (f n)) => Show (ScopedBody s f n)
-ShowScopedBody = deriveShow
-
-||| a scoped term with names
-public export
-record Scoped (s : Nat) (f : Nat -> Type) (n : Nat) where
-  constructor S
-  names : BContext s
-  body  : ScopedBody s f n
-%name Scoped body
-
-export %inline
-(forall n. Eq (f n)) => Eq (Scoped s f n) where
-  s == t = s.body == t.body
-
-export %inline %hint
-ShowScoped : (forall n. Show (f n)) => Show (Scoped s f n)
-ShowScoped = deriveShow
-
-
 infixl 8 :#
 infixl 9 :@, :%
 mutual
@@ -91,6 +61,10 @@ mutual
     ||| type of types
     TYPE : (l : Universe) -> (loc : Loc) -> Term d n
 
+    ||| IO state token. this is a builtin because otherwise #[main] being a
+    ||| builtin makes no sense
+    IOState : (loc : Loc) -> Term d n
+
     ||| function type
     Pi  : (qty : Qty) -> (arg : Term d n) ->
           (res : ScopeTerm d n) -> (loc : Loc) -> Term d n
@@ -113,15 +87,21 @@ mutual
     DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
 
     ||| natural numbers (temporary until 𝐖 gets added)
-    Nat  : (loc : Loc) -> Term d n
-    -- [todo] can these be elims?
-    Zero : (loc : Loc) -> Term d n
+    NAT : (loc : Loc) -> Term d n
+    Nat : (val : Nat) -> (loc : Loc) -> Term d n
     Succ : (p : Term d n) -> (loc : Loc) -> Term d n
 
+    ||| strings
+    STRING : (loc : Loc) -> Term d n
+    Str    : (str : String) -> (loc : Loc) -> Term d n
+
     ||| "box" (package a value up with a certain quantity)
     BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
     Box : (val : Term d n) -> (loc : Loc) -> Term d n
 
+    Let : (qty : Qty) -> (rhs : Elim d n) ->
+          (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
+
     ||| elimination
     E : (e : Elim d n) -> Term d n
 
@@ -155,6 +135,12 @@ mutual
                (loc : Loc) ->
                Elim d n
 
+    ||| first element of a pair. only works in non-linear contexts.
+    Fst : (pair : Elim d n) -> (loc : Loc) -> Elim d n
+
+    ||| second element of a pair. only works in non-linear contexts.
+    Snd : (pair : Elim d n) -> (loc : Loc) -> Elim d n
+
     ||| enum matching
     CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
                (ret : ScopeTerm d n) ->
@@ -250,23 +236,123 @@ mutual
   ShowElim : Show (Elim d n)
   ShowElim = assert_total {a = Show (Elim d n)} deriveShow
 
-||| scope which ignores all its binders
-public export %inline
-SN : {s : Nat} -> f n -> Scoped s f n
-SN = S (replicate s $ BN Unused noLoc) . N
 
-||| scope which uses its binders
-public export %inline
-SY : BContext s -> f (s + n) -> Scoped s f n
-SY ns = S ns . Y
+export
+Located (Elim d n) where
+  (F _ _ loc).loc               = loc
+  (B _ loc).loc                 = loc
+  (App _ _ loc).loc             = loc
+  (CasePair _ _ _ _ loc).loc    = loc
+  (Fst _ loc).loc               = loc
+  (Snd _ loc).loc               = loc
+  (CaseEnum _ _ _ _ loc).loc    = loc
+  (CaseNat _ _ _ _ _ _ loc).loc = loc
+  (CaseBox _ _ _ _ loc).loc     = loc
+  (DApp _ _ loc).loc            = loc
+  (Ann _ _ loc).loc             = loc
+  (Coe _ _ _ _ loc).loc         = loc
+  (Comp _ _ _ _ _ _ _ loc).loc  = loc
+  (TypeCase _ _ _ _ loc).loc    = loc
+  (CloE (Sub e _)).loc          = e.loc
+  (DCloE (Sub e _)).loc         = e.loc
 
-public export %inline
-name : Scoped 1 f n -> BindName
-name (S [< x] _) = x
+export
+Located (Term d n) where
+  (TYPE _ loc).loc      = loc
+  (IOState loc).loc     = loc
+  (Pi _ _ _ loc).loc    = loc
+  (Lam _ loc).loc       = loc
+  (Sig _ _ loc).loc     = loc
+  (Pair _ _ loc).loc    = loc
+  (Enum _ loc).loc      = loc
+  (Tag _ loc).loc       = loc
+  (Eq _ _ _ loc).loc    = loc
+  (DLam _ loc).loc      = loc
+  (NAT loc).loc         = loc
+  (Nat _ loc).loc       = loc
+  (STRING loc).loc      = loc
+  (Str _ loc).loc       = loc
+  (Succ _ loc).loc      = loc
+  (BOX _ _ loc).loc     = loc
+  (Box _ loc).loc       = loc
+  (Let _ _ _ loc).loc   = loc
+  (E e).loc             = e.loc
+  (CloT (Sub t _)).loc  = t.loc
+  (DCloT (Sub t _)).loc = t.loc
+
+export
+Located1 f => Located (ScopedBody s f n) where
+  (Y t).loc = t.loc
+  (N t).loc = t.loc
+
+export
+Located1 f => Located (Scoped s f n) where
+  t.loc = t.body.loc
+
+
+export
+Relocatable (Elim d n) where
+  setLoc loc (F x u _) = F x u loc
+  setLoc loc (B i _) = B i loc
+  setLoc loc (App fun arg _) = App fun arg loc
+  setLoc loc (CasePair qty pair ret body _) =
+    CasePair qty pair ret body loc
+  setLoc loc (Fst pair _) = Fst pair loc
+  setLoc loc (Snd pair _) = Fst pair loc
+  setLoc loc (CaseEnum qty tag ret arms _) =
+    CaseEnum qty tag ret arms loc
+  setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
+    CaseNat qty qtyIH nat ret zero succ loc
+  setLoc loc (CaseBox qty box ret body _) =
+    CaseBox qty box ret body loc
+  setLoc loc (DApp fun arg _) =
+    DApp fun arg loc
+  setLoc loc (Ann tm ty _) =
+    Ann tm ty loc
+  setLoc loc (Coe ty p q val _) =
+    Coe ty p q val loc
+  setLoc loc (Comp ty p q val r zero one _) =
+    Comp ty p q val r zero one loc
+  setLoc loc (TypeCase ty ret arms def _) =
+    TypeCase ty ret arms def loc
+  setLoc loc (CloE (Sub term subst)) =
+    CloE $ Sub (setLoc loc term) subst
+  setLoc loc (DCloE (Sub term subst)) =
+    DCloE $ Sub (setLoc loc term) subst
+
+export
+Relocatable (Term d n) where
+  setLoc loc (TYPE l _) = TYPE l loc
+  setLoc loc (IOState _) = IOState loc
+  setLoc loc (Pi qty arg res _) = Pi qty arg res loc
+  setLoc loc (Lam body _) = Lam body loc
+  setLoc loc (Sig fst snd _) = Sig fst snd loc
+  setLoc loc (Pair fst snd _) = Pair fst snd loc
+  setLoc loc (Enum cases _) = Enum cases loc
+  setLoc loc (Tag tag _) = Tag tag loc
+  setLoc loc (Eq ty l r _) = Eq ty l r loc
+  setLoc loc (DLam body _) = DLam body loc
+  setLoc loc (NAT _) = NAT loc
+  setLoc loc (Nat n _) = Nat n loc
+  setLoc loc (Succ p _) = Succ p loc
+  setLoc loc (STRING _) = STRING loc
+  setLoc loc (Str s _) = Str s loc
+  setLoc loc (BOX qty ty _) = BOX qty ty loc
+  setLoc loc (Box val _) = Box val loc
+  setLoc loc (Let qty rhs body _) = Let qty rhs body loc
+  setLoc loc (E e) = E $ setLoc loc e
+  setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
+  setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
+
+export
+Relocatable1 f => Relocatable (ScopedBody s f n) where
+  setLoc loc (Y body) = Y $ setLoc loc body
+  setLoc loc (N body) = N $ setLoc loc body
+
+export
+Relocatable1 f => Relocatable (Scoped s f n) where
+  setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
 
-public export %inline
-(.name) : Scoped 1 f n -> BindName
-s.name = name s
 
 ||| more convenient Pi
 public export %inline
@@ -324,6 +410,11 @@ public export %inline
 FT : Name -> Universe -> Loc -> Term d n
 FT x u loc = E $ F x u loc
 
+||| same as `B` but as a term
+public export %inline
+BT : Var n -> (loc : Loc) -> Term d n
+BT i loc = E $ B i loc
+
 ||| abbreviation for a bound variable like `BV 4` instead of
 ||| `B (VS (VS (VS (VS VZ))))`
 public export %inline
@@ -335,10 +426,9 @@ public export %inline
 BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
 BVT i loc = E $ BV i loc
 
-public export
-makeNat : Nat -> Loc -> Term d n
-makeNat 0 loc = Zero loc
-makeNat (S k) loc = Succ (makeNat k loc) loc
+public export %inline
+Zero : Loc -> Term d n
+Zero = Nat 0
 
 public export %inline
 enum : List TagVal -> Loc -> Term d n
@@ -353,111 +443,6 @@ public export %inline
 typeCase1Y : Elim d n -> Term d n ->
              (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
              (loc : Loc) ->
-             {default (Nat loc) def : Term d n} ->
+             {default (NAT loc) def : Term d n} ->
              Elim d n
 typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc
-
-
-export
-Located (Elim d n) where
-  (F _ _ loc).loc               = loc
-  (B _ loc).loc                 = loc
-  (App _ _ loc).loc             = loc
-  (CasePair _ _ _ _ loc).loc    = loc
-  (CaseEnum _ _ _ _ loc).loc    = loc
-  (CaseNat _ _ _ _ _ _ loc).loc = loc
-  (CaseBox _ _ _ _ loc).loc     = loc
-  (DApp _ _ loc).loc            = loc
-  (Ann _ _ loc).loc             = loc
-  (Coe _ _ _ _ loc).loc         = loc
-  (Comp _ _ _ _ _ _ _ loc).loc  = loc
-  (TypeCase _ _ _ _ loc).loc    = loc
-  (CloE (Sub e _)).loc          = e.loc
-  (DCloE (Sub e _)).loc         = e.loc
-
-export
-Located (Term d n) where
-  (TYPE _ loc).loc      = loc
-  (Pi _ _ _ loc).loc    = loc
-  (Lam _ loc).loc       = loc
-  (Sig _ _ loc).loc     = loc
-  (Pair _ _ loc).loc    = loc
-  (Enum _ loc).loc      = loc
-  (Tag _ loc).loc       = loc
-  (Eq _ _ _ loc).loc    = loc
-  (DLam _ loc).loc      = loc
-  (Nat loc).loc         = loc
-  (Zero loc).loc        = loc
-  (Succ _ loc).loc      = loc
-  (BOX _ _ loc).loc     = loc
-  (Box _ loc).loc       = loc
-  (E e).loc             = e.loc
-  (CloT (Sub t _)).loc  = t.loc
-  (DCloT (Sub t _)).loc = t.loc
-
-export
-Located1 f => Located (ScopedBody s f n) where
-  (Y t).loc = t.loc
-  (N t).loc = t.loc
-
-export
-Located1 f => Located (Scoped s f n) where
-  t.loc = t.body.loc
-
-
-export
-Relocatable (Elim d n) where
-  setLoc loc (F x u _) = F x u loc
-  setLoc loc (B i _) = B i loc
-  setLoc loc (App fun arg _) = App fun arg loc
-  setLoc loc (CasePair qty pair ret body _) =
-    CasePair qty pair ret body loc
-  setLoc loc (CaseEnum qty tag ret arms _) =
-    CaseEnum qty tag ret arms loc
-  setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
-    CaseNat qty qtyIH nat ret zero succ loc
-  setLoc loc (CaseBox qty box ret body _) =
-    CaseBox qty box ret body loc
-  setLoc loc (DApp fun arg _) =
-    DApp fun arg loc
-  setLoc loc (Ann tm ty _) =
-    Ann tm ty loc
-  setLoc loc (Coe ty p q val _) =
-    Coe ty p q val loc
-  setLoc loc (Comp ty p q val r zero one _) =
-    Comp ty p q val r zero one loc
-  setLoc loc (TypeCase ty ret arms def _) =
-    TypeCase ty ret arms def loc
-  setLoc loc (CloE (Sub term subst)) =
-    CloE $ Sub (setLoc loc term) subst
-  setLoc loc (DCloE (Sub term subst)) =
-    DCloE $ Sub (setLoc loc term) subst
-
-export
-Relocatable (Term d n) where
-  setLoc loc (TYPE l _) = TYPE l loc
-  setLoc loc (Pi qty arg res _) = Pi qty arg res loc
-  setLoc loc (Lam body _) = Lam body loc
-  setLoc loc (Sig fst snd _) = Sig fst snd loc
-  setLoc loc (Pair fst snd _) = Pair fst snd loc
-  setLoc loc (Enum cases _) = Enum cases loc
-  setLoc loc (Tag tag _) = Tag tag loc
-  setLoc loc (Eq ty l r _) = Eq ty l r loc
-  setLoc loc (DLam body _) = DLam body loc
-  setLoc loc (Nat _) = Nat loc
-  setLoc loc (Zero _) = Zero loc
-  setLoc loc (Succ p _) = Succ p loc
-  setLoc loc (BOX qty ty _) = BOX qty ty loc
-  setLoc loc (Box val _) = Box val loc
-  setLoc loc (E e) = E $ setLoc loc e
-  setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
-  setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
-
-export
-Relocatable1 f => Relocatable (ScopedBody s f n) where
-  setLoc loc (Y body) = Y $ setLoc loc body
-  setLoc loc (N body) = N $ setLoc loc body
-
-export
-Relocatable1 f => Relocatable (Scoped s f n) where
-  setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)

lib/Quox/Syntax/Term/Pretty.idr

@@ -30,14 +30,6 @@ BTelescope : Nat -> Nat -> Type
 BTelescope = Telescope' BindName
 
 
-private
-subscript : String -> String
-subscript = pack . map sub . unpack where
-  sub : Char -> Char
-  sub c = case c of
-    '0' => '₀'; '1' => '₁'; '2' => '₂'; '3' => '₃'; '4' => '₄'
-    '5' => '₅'; '6' => '₆'; '7' => '₇'; '8' => '₈'; '9' => '₉'; _ => c
-
 private
 superscript : String -> String
 superscript = pack . map sup . unpack where
@@ -209,8 +201,7 @@ prettyTArg dnames tnames s =
 
 private
 prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
-prettyDArg dnames p =
-  map (text "@" <+>) $ withPrec Arg $ prettyDim dnames p
+prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
 
 private
 splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
@@ -238,7 +229,6 @@ prettyDTApps dnames tnames f xs = do
 private
 record CaseArm opts d n where
   constructor MkCaseArm
-  {0 dinner, ninner : Nat}
   pat    : Doc opts
   dbinds : BTelescope d dinner -- 🍴
   tbinds : BTelescope n ninner
@@ -251,12 +241,11 @@ parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
     body <- withPrec Outer $ assert_total
             prettyTerm (dnames . dbinds) (tnames . tbinds) body
     header <- (pat <++>) <$> darrowD
-    pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
+    pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
 
   private
-  prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (Doc opts)
-  prettyCaseBody xs =
-    braces . separateTight !semiD =<< traverse prettyCaseArm xs
+  prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts))
+  prettyCaseBody xs = traverse prettyCaseArm xs
 
 private
 prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts)
@@ -283,16 +272,12 @@ layoutComp typq val r arms = do
       [typq, [val, r <++> lb], map (indent ind) arms, [rb]])
 
 
-export
-prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
-prettyTag tag = hl Tag $ text $ "'" ++ quoteTag tag
-
 export
 prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
 prettyEnum cases =
   tightBraces =<<
   fillSeparateTight !commaD <$>
-  traverse (hl Tag . Doc.text . quoteTag) cases
+  traverse (hl Constant . Doc.text . quoteTag) cases
 
 private
 prettyCaseRet : {opts : _} ->
@@ -303,7 +288,7 @@ prettyCaseRet dnames tnames body = withPrec Outer $ case body of
   S [< x] (Y tm) => do
     header <- [|prettyTBind x <++> darrowD|]
     body   <- assert_total prettyTerm dnames (tnames :< x) tm
-    pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
+    hangDSingle header body
 
 private
 prettyCase_ : {opts : _} ->
@@ -311,10 +296,16 @@ prettyCase_ : {opts : _} ->
               Doc opts -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) ->
               Eff Pretty (Doc opts)
 prettyCase_ dnames tnames intro head ret body = do
-  head <- assert_total prettyElim dnames tnames head
-  ret  <- prettyCaseRet dnames tnames ret
-  body <- prettyCaseBody dnames tnames body
-  parensIfM Outer $ sep [intro <++> head, !returnD <++> ret, !ofD <++> body]
+  head   <- withPrec Outer $ assert_total prettyElim dnames tnames head
+  ret    <- prettyCaseRet dnames tnames ret
+  bodys  <- prettyCaseBody dnames tnames body
+  return <- returnD; of_ <- ofD
+  lb     <- hl Delim "{"; rb <- hl Delim "}"; semi <- semiD
+  ind    <- askAt INDENT
+  parensIfM Outer $ ifMultiline
+    (hsep [intro, head, return, ret, of_, lb, hseparateTight semi bodys, rb])
+    (vsep [intro <++> head, return <++> ret, of_ <++> lb,
+           indent ind $ vseparateTight semi bodys, rb])
 
 private
 prettyCase : {opts : _} ->
@@ -325,6 +316,62 @@ prettyCase dnames tnames qty head ret body =
   prettyCase_ dnames tnames ![|caseD <+> prettyQty qty|] head ret body
 
 
+private
+LetBinder : Nat -> Nat -> Type
+LetBinder d n = (Qty, BindName, Elim d n)
+
+private
+LetExpr : Nat -> Nat -> Nat -> Type
+LetExpr d n n' = (Telescope (LetBinder d) n n', Term d n')
+
+-- [todo] factor out this and the untyped version somehow
+export
+splitLet : Telescope (LetBinder d) n n' -> Term d n' -> Exists (LetExpr d n)
+splitLet ys t@(Let qty rhs body _) =
+  splitLet (ys :< (qty, body.name, rhs)) (assert_smaller t body.term)
+splitLet ys t =
+  Evidence _ (ys, t)
+
+private covering
+prettyLets : {opts : LayoutOpts} ->
+             BContext d -> BContext a -> Telescope (LetBinder d) a b ->
+             Eff Pretty (SnocList (Doc opts))
+prettyLets dnames xs lets = snd <$> go lets where
+  peelAnn : forall d, n. Elim d n -> Maybe (Term d n, Term d n)
+  peelAnn (Ann tm ty _) = Just (tm, ty)
+  peelAnn e             = Nothing
+
+  letHeader : Qty -> BindName -> Eff Pretty (Doc opts)
+  letHeader qty x = do
+    lett <- [|letD <+> prettyQty qty|]
+    x    <- prettyTBind x
+    pure $ lett <++> x
+
+  letBody : forall n. BContext n ->
+            Doc opts -> Elim d n -> Eff Pretty (Doc opts)
+  letBody tnames hdr e = case peelAnn e of
+    Just (tm, ty) => do
+      ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty
+      tm <- withPrec Outer $ assert_total prettyTerm dnames tnames tm
+      colon <- colonD; eq <- cstD; d <- askAt INDENT
+      pure $ hangSingle d (hangSingle d hdr (colon <++> ty)) (eq <++> tm)
+    Nothing => do
+      e <- withPrec Outer $ assert_total prettyElim dnames tnames e
+      eq <- cstD; d <- askAt INDENT
+      inn <- inD
+      pure $ ifMultiline
+        (hsep [hdr, eq, e, inn])
+        (vsep [hdr, indent d $ hsep [eq, e, inn]])
+
+  go : forall b. Telescope (LetBinder d) a b ->
+       Eff Pretty (BContext b, SnocList (Doc opts))
+  go [<] = pure (xs, [<])
+  go (lets :< (qty, x, rhs)) = do
+    (ys, docs) <- go lets
+    doc        <- letBody ys !(letHeader qty x) rhs
+    pure (ys :< x, docs :< doc)
+
+
 private
 isDefaultDir : Dim d -> Dim d -> Bool
 isDefaultDir (K Zero _) (K One _) = True
@@ -342,6 +389,7 @@ prettyTyCasePat : {opts : _} ->
                   (k : TyConKind) -> BContext (arity k) ->
                   Eff Pretty (Doc opts)
 prettyTyCasePat KTYPE [<] = typeD
+prettyTyCasePat KIOState [<] = ioStateD
 prettyTyCasePat KPi [< a, b] =
   parens . hsep =<< sequence [prettyTBind a, arrowD, prettyTBind b]
 prettyTyCasePat KSig [< a, b] =
@@ -350,6 +398,7 @@ prettyTyCasePat KEnum [<] = hl Syntax $ text "{}"
 prettyTyCasePat KEq [< a0, a1, a, l, r] =
   hsep <$> sequence (eqD :: map prettyTBind [a0, a1, a, l, r])
 prettyTyCasePat KNat [<] = natD
+prettyTyCasePat KString [<] = stringD
 prettyTyCasePat KBOX [< a] = bracks =<< prettyTBind a
 
 
@@ -383,13 +432,13 @@ prettyDisp u = map Just $ hl Universe =<<
   ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
 
 
-prettyTerm dnames tnames (TYPE l _) =
-  case !(askAt FLAVOR) of
-    Unicode => do
-      star  <- hl Syntax "★"
-      level <- hl Universe $ text $ superscript $ show l
-      pure $ hcat [star, level]
-    Ascii   => [|hl Syntax "Type" <++> hl Universe (text $ show l)|]
+prettyTerm dnames tnames (TYPE l _) = do
+  type  <- hl Syntax . text =<< ifUnicode "★" "Type"
+  level <- prettyDisp l
+  pure $ maybe type (type <+>) level
+
+prettyTerm dnames tnames (IOState _) =
+  ioStateD
 
 prettyTerm dnames tnames (Pi qty arg res _) =
   parensIfM Outer =<< do
@@ -426,35 +475,31 @@ prettyTerm dnames tnames (Enum cases _) =
 prettyTerm dnames tnames (Tag tag _) =
   prettyTag tag
 
-prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) = do
-  l  <- withPrec InEq $ prettyTerm dnames tnames l
-  r  <- withPrec InEq $ prettyTerm dnames tnames r
-  ty <- withPrec InEq $ prettyTerm dnames tnames ty
-  pure $ sep [l <++> !eqndD, r <++> !colonD, ty]
+prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) =
+  parensIfM Eq =<< do
+    l  <- withPrec InEq $ prettyTerm dnames tnames l
+    r  <- withPrec InEq $ prettyTerm dnames tnames r
+    ty <- withPrec InEq $ prettyTerm dnames tnames ty
+    pure $ sep [l <++> !eqndD, r <++> !colonD, ty]
 
-prettyTerm dnames tnames (Eq ty l r _) = do
-  ty <- prettyTypeLine dnames tnames ty
-  l  <- withPrec Arg $ prettyTerm dnames tnames l
-  r  <- withPrec Arg $ prettyTerm dnames tnames r
-  prettyAppD !eqD [ty, l, r]
+prettyTerm dnames tnames (Eq ty l r _) =
+  parensIfM App =<< do
+    ty <- prettyTypeLine dnames tnames ty
+    l  <- withPrec Arg $ prettyTerm dnames tnames l
+    r  <- withPrec Arg $ prettyTerm dnames tnames r
+    prettyAppD !eqD [ty, l, r]
 
 prettyTerm dnames tnames s@(DLam {}) =
   prettyLambda dnames tnames s
 
-prettyTerm dnames tnames (Nat _) = natD
-prettyTerm dnames tnames (Zero _) = hl Syntax "0"
-prettyTerm dnames tnames (Succ p _) = do
-  succD <- succD
-  let succ : Doc opts -> Eff Pretty (Doc opts)
-      succ t = prettyAppD succD [t]
-      toNat : Term d n -> Eff Pretty (Either (Doc opts) Nat)
-      toNat s with (pushSubsts' s)
-        _ | Zero _   = pure $ Right 0
-        _ | Succ d _ = bitraverse succ (pure . S) =<<
-                       toNat (assert_smaller s d)
-        _ | s'       = map Left . withPrec Arg $
-                       prettyTerm dnames tnames $ assert_smaller s s'
-  either succ (hl Syntax . text . show . S) =<< toNat p
+prettyTerm dnames tnames (NAT _) = natD
+prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n
+prettyTerm dnames tnames (Succ p _) =
+  parensIfM App =<<
+  prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)]
+
+prettyTerm dnames tnames (STRING _) = stringD
+prettyTerm dnames tnames (Str s _) = prettyStrLit s
 
 prettyTerm dnames tnames (BOX qty ty _) =
   bracks . hcat =<<
@@ -464,7 +509,18 @@ prettyTerm dnames tnames (BOX qty ty _) =
 prettyTerm dnames tnames (Box val _) =
   bracks =<< withPrec Outer (prettyTerm dnames tnames val)
 
-prettyTerm dnames tnames (E e) = prettyElim dnames tnames e
+prettyTerm dnames tnames (Let qty rhs body _) = do
+  let Evidence _ (lets, body) = splitLet [< (qty, body.name, rhs)] body.term
+  heads <- prettyLets dnames tnames lets
+  let tnames = tnames . map (\(_, x, _) => x) lets
+  body <- withPrec Outer $ assert_total prettyTerm dnames tnames body
+  let lines = toList $ heads :< body
+  pure $ ifMultiline (hsep lines) (vsep lines)
+
+prettyTerm dnames tnames (E e) =
+  case the (Elim d n) (pushSubsts' e) of
+    Ann tm _ _ => assert_total prettyTerm dnames tnames tm
+    _          => assert_total prettyElim dnames tnames e
 
 prettyTerm dnames tnames t0@(CloT (Sub t ph)) =
   prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' id ph t
@@ -491,6 +547,16 @@ prettyElim dnames tnames (CasePair qty pair ret body _) = do
   prettyCase dnames tnames qty pair ret
     [MkCaseArm pat [<] [< x, y] body.term]
 
+prettyElim dnames tnames (Fst pair _) =
+  parensIfM App =<< do
+    pair <- prettyTArg dnames tnames (E pair)
+    prettyAppD !fstD [pair]
+
+prettyElim dnames tnames (Snd pair _) =
+  parensIfM App =<< do
+    pair <- prettyTArg dnames tnames (E pair)
+    prettyAppD !sndD [pair]
+
 prettyElim dnames tnames (CaseEnum qty tag ret arms _) = do
   arms <- for (SortedMap.toList arms) $ \(tag, body) =>
     pure $ MkCaseArm !(prettyTag tag) [<] [<] body
@@ -501,7 +567,7 @@ prettyElim dnames tnames (CaseNat qty qtyIH nat ret zero succ _) = do
       [< p, ih] = succ.names
   spat0 <- [|succD <++> prettyTBind p|]
   ihpat0 <- map hcat $ sequence [prettyQty qtyIH, dotD, prettyTBind ih]
-  spat <- if ih.name == Unused
+  spat <- if ih.val == Unused
           then pure spat0
           else pure $ hsep [spat0 <+> !commaD, ihpat0]
   let sarm = MkCaseArm spat [<] [< p, ih] succ.term
@@ -517,35 +583,31 @@ prettyElim dnames tnames e@(DApp {}) =
   prettyDTApps dnames tnames f xs
 
 prettyElim dnames tnames (Ann tm ty _) =
-  parensIfM Outer =<<
-    hangDSingle !(withPrec AnnL  [|prettyTerm dnames tnames tm <++> annD|])
-                !(withPrec Outer (prettyTerm dnames tnames ty))
+  case the (Term d n) (pushSubsts' tm) of
+    E e => assert_total prettyElim dnames tnames e
+    _   => do
+      tm <- withPrec AnnL  $ assert_total prettyTerm dnames tnames tm
+      ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty
+      parensIfM Outer =<< hangDSingle (tm <++> !annD) ty
 
 prettyElim dnames tnames (Coe ty p q val _) =
-  parensIfM App =<<
-    if isDefaultDir p q then do
-      ty  <- prettyTypeLine dnames tnames ty
-      val <- prettyTArg dnames tnames val
-      prettyAppD !coeD [ty, val]
-    else do
-      ty  <- prettyTypeLine dnames tnames ty
-      p   <- prettyDArg dnames p
-      q   <- prettyDArg dnames q
-      val <- prettyTArg dnames tnames val
-      prettyAppD !coeD [ty, sep [p, q], val]
+  parensIfM App =<< do
+    ty  <- prettyTypeLine dnames tnames ty
+    p   <- prettyDArg dnames p
+    q   <- prettyDArg dnames q
+    val <- prettyTArg dnames tnames val
+    prettyAppD !coeD [ty, sep [p, q], val]
 
 prettyElim dnames tnames e@(Comp ty p q val r zero one _) =
   parensIfM App =<< do
-    ty   <- prettyTypeLine dnames tnames $ assert_smaller e $ SN ty
+    ty   <- assert_total $ prettyTypeLine dnames tnames $ SN ty
     pq   <- sep <$> sequence [prettyDArg dnames p, prettyDArg dnames q]
     val  <- prettyTArg dnames tnames val
     r    <- prettyDArg dnames r
     arm0 <- [|prettyCompArm dnames tnames Zero zero <+> semiD|]
     arm1 <- prettyCompArm dnames tnames One one
     ind  <- askAt INDENT
-    if isDefaultDir p q
-       then layoutComp [ty]     val r [arm0, arm1]
-       else layoutComp [ty, pq] val r [arm0, arm1]
+    layoutComp [ty, pq] val r [arm0, arm1]
 
 prettyElim dnames tnames (TypeCase ty ret arms def _) = do
   arms <- for (toList arms) $ \(k ** body) => do

lib/Quox/Syntax/Term/Subst.idr

@@ -2,7 +2,6 @@ module Quox.Syntax.Term.Subst
 
 import Quox.No
 import Quox.Syntax.Term.Base
-import Quox.Syntax.Term.Tighten
 import Data.SnocVect
 
 %default total
@@ -57,12 +56,12 @@ namespace DSubst.DScopeTermN
   (//) : {s : Nat} ->
          DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
          DScopeTermN s d2 n
-  S ns (Y body) // th = S ns $ Y $ body // pushN s th
+  S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
   S ns (N body) // th = S ns $ N $ body // th
 
 
 export %inline FromVar (Elim d) where fromVarLoc = B
-export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
+export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
 
 
 ||| does the minimal reasonable work:
@@ -105,7 +104,7 @@ namespace ScopeTermN
   (//) : {s : Nat} ->
          ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
          ScopeTermN s d n2
-  S ns (Y body) // th = S ns $ Y $ body // pushN s th
+  S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
   S ns (N body) // th = S ns $ N $ body // th
 
 namespace DScopeTermN
@@ -118,6 +117,9 @@ namespace DScopeTermN
 export %inline CanShift (Term d) where s // by = s // Shift by
 export %inline CanShift (Elim d) where e // by = e // Shift by
 
+export %inline CanShift (flip Term n) where s // by = s // Shift by
+export %inline CanShift (flip Elim n) where e // by = e // Shift by
+
 export %inline
 {s : Nat} -> CanShift (ScopeTermN s d) where
   b // by = b // Shift by
@@ -132,6 +134,15 @@ public export %inline
 dweakT : (by : Nat) -> Term d n -> Term (by + d) n
 dweakT by t = t // shift by
 
+public export %inline
+dweakS : (by : Nat) -> ScopeTermN s d n -> ScopeTermN s (by + d) n
+dweakS by t = t // shift by
+
+public export %inline
+dweakDS : {s : Nat} -> (by : Nat) ->
+          DScopeTermN s d n -> DScopeTermN s (by + d) n
+dweakDS by t = t // shift by
+
 public export %inline
 dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
 dweakE by t = t // shift by
@@ -141,34 +152,40 @@ public export %inline
 weakT : (by : Nat) -> Term d n -> Term d (by + n)
 weakT by t = t // shift by
 
+public export %inline
+weakS : {s : Nat} -> (by : Nat) -> ScopeTermN s d n -> ScopeTermN s d (by + n)
+weakS by t = t // shift by
+
+public export %inline
+weakDS : {s : Nat} -> (by : Nat) ->
+         DScopeTermN s d n -> DScopeTermN s d (by + n)
+weakDS by t = t // shift by
+
 public export %inline
 weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
 weakE by t = t // shift by
 
 
-parameters {s : Nat}
-  namespace ScopeTermBody
-    export %inline
-    (.term) : ScopedBody s (Term d) n -> Term d (s + n)
-    (Y b).term = b
-    (N b).term = weakT s b
+parameters {auto _ : CanShift f} {s : Nat}
+  export %inline
+  getTerm : ScopedBody s f n -> f (s + n)
+  getTerm (Y b) = b
+  getTerm (N b) = b // fromNat s
 
-  namespace ScopeTermN
-    export %inline
-    (.term) : ScopeTermN s d n -> Term d (s + n)
-    t.term = t.body.term
+  export %inline
+  (.term) : Scoped s f n -> f (s + n)
+  t.term = getTerm t.body
 
-  namespace DScopeTermBody
-    export %inline
-    (.term) : ScopedBody s (\d => Term d n) d -> Term (s + d) n
-    (Y b).term = b
-    (N b).term = dweakT s b
-
-  namespace DScopeTermN
-    export %inline
-    (.term) : DScopeTermN s d n -> Term (s + d) n
-    t.term = t.body.term
+namespace ScopeTermBody
+  export %inline
+  getTerm0 : ScopedBody 0 f n -> f n
+  getTerm0 (Y b) = b
+  getTerm0 (N b) = b
 
+namespace ScopeTermN
+  export %inline
+  (.term0) : Scoped 0 f n -> f n
+  t.term0 = getTerm0 t.body
 
 export %inline
 subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
@@ -190,11 +207,11 @@ dsub1 t p = dsubN t [< p]
 
 
 public export %inline
-(.zero) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
+(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
 body.zero = dsub1 body $ K Zero loc
 
 public export %inline
-(.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
+(.one) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
 body.one = dsub1 body $ K One loc
 
 
@@ -202,6 +219,7 @@ public export
 0 CloTest : TermLike -> Type
 CloTest tm = forall d, n. tm d n -> Bool
 
+public export
 interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
   pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
                    tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
@@ -249,127 +267,90 @@ mutual
   isCloE (DCloE {}) = True
   isCloE _          = False
 
-mutual
-  export
-  PushSubsts Term Subst.isCloT where
-    pushSubstsWith th ph (TYPE l loc) =
-      nclo $ TYPE l loc
-    pushSubstsWith th ph (Pi qty a body loc) =
-      nclo $ Pi qty (a // th // ph) (body // th // ph) loc
-    pushSubstsWith th ph (Lam body loc) =
-      nclo $ Lam (body // th // ph) loc
-    pushSubstsWith th ph (Sig a b loc) =
-      nclo $ Sig (a // th // ph) (b // th // ph) loc
-    pushSubstsWith th ph (Pair s t loc) =
-      nclo $ Pair (s // th // ph) (t // th // ph) loc
-    pushSubstsWith th ph (Enum tags loc) =
-      nclo $ Enum tags loc
-    pushSubstsWith th ph (Tag tag loc) =
-      nclo $ Tag tag loc
-    pushSubstsWith th ph (Eq ty l r loc) =
-      nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
-    pushSubstsWith th ph (DLam body loc) =
-      nclo $ DLam (body // th // ph) loc
-    pushSubstsWith _ _ (Nat loc) =
-      nclo $ Nat loc
-    pushSubstsWith _ _ (Zero loc) =
-      nclo $ Zero loc
-    pushSubstsWith th ph (Succ n loc) =
-      nclo $ Succ (n // th // ph) loc
-    pushSubstsWith th ph (BOX pi ty loc) =
-      nclo $ BOX pi (ty // th // ph) loc
-    pushSubstsWith th ph (Box val loc) =
-      nclo $ Box (val // th // ph) loc
-    pushSubstsWith th ph (E e) =
-      let Element e nc = pushSubstsWith th ph e in nclo $ E e
-    pushSubstsWith th ph (CloT (Sub s ps)) =
-      pushSubstsWith th (comp th ps ph) s
-    pushSubstsWith th ph (DCloT (Sub s ps)) =
-      pushSubstsWith (ps . th) ph s
+export
+PushSubsts Elim Subst.isCloE where
+  pushSubstsWith th ph (F x u loc) =
+    nclo $ F x u loc
+  pushSubstsWith th ph (B i loc) =
+    let res = getLoc ph i loc in
+    case nchoose $ isCloE res of
+      Left  yes => assert_total pushSubsts res
+      Right no  => Element res no
+  pushSubstsWith th ph (App f s loc) =
+    nclo $ App (f // th // ph) (s // th // ph) loc
+  pushSubstsWith th ph (CasePair pi p r b loc) =
+    nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
+  pushSubstsWith th ph (Fst pair loc) =
+    nclo $ Fst (pair // th // ph) loc
+  pushSubstsWith th ph (Snd pair loc) =
+    nclo $ Snd (pair // th // ph) loc
+  pushSubstsWith th ph (CaseEnum pi t r arms loc) =
+    nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
+             (map (\b => b // th // ph) arms) loc
+  pushSubstsWith th ph (CaseNat pi pi' n r z s loc) =
+    nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph)
+             (z // th // ph) (s // th // ph) loc
+  pushSubstsWith th ph (CaseBox pi x r b loc) =
+    nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc
+  pushSubstsWith th ph (DApp f d loc) =
+    nclo $ DApp (f // th // ph) (d // th) loc
+  pushSubstsWith th ph (Ann s a loc) =
+    nclo $ Ann (s // th // ph) (a // th // ph) loc
+  pushSubstsWith th ph (Coe ty p q val loc) =
+    nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc
+  pushSubstsWith th ph (Comp ty p q val r zero one loc) =
+    nclo $ Comp (ty // th // ph) (p // th) (q // th)
+                (val // th // ph) (r // th)
+                (zero // th // ph) (one // th // ph) loc
+  pushSubstsWith th ph (TypeCase ty ret arms def loc) =
+    nclo $ TypeCase (ty // th // ph) (ret  // th // ph)
+      (map (\t => t // th // ph) arms) (def // th // ph) loc
+  pushSubstsWith th ph (CloE (Sub e ps)) =
+    pushSubstsWith th (comp th ps ph) e
+  pushSubstsWith th ph (DCloE (Sub e ps)) =
+    pushSubstsWith (ps . th) ph e
 
-  export
-  PushSubsts Elim Subst.isCloE where
-    pushSubstsWith th ph (F x u loc) =
-      nclo $ F x u loc
-    pushSubstsWith th ph (B i loc) =
-      let res = getLoc ph i loc in
-      case nchoose $ isCloE res of
-        Left  yes => assert_total pushSubsts res
-        Right no  => Element res no
-    pushSubstsWith th ph (App f s loc) =
-      nclo $ App (f // th // ph) (s // th // ph) loc
-    pushSubstsWith th ph (CasePair pi p r b loc) =
-      nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
-    pushSubstsWith th ph (CaseEnum pi t r arms loc) =
-      nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
-               (map (\b => b // th // ph) arms) loc
-    pushSubstsWith th ph (CaseNat pi pi' n r z s loc) =
-      nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph)
-               (z // th // ph) (s // th // ph) loc
-    pushSubstsWith th ph (CaseBox pi x r b loc) =
-      nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc
-    pushSubstsWith th ph (DApp f d loc) =
-      nclo $ DApp (f // th // ph) (d // th) loc
-    pushSubstsWith th ph (Ann s a loc) =
-      nclo $ Ann (s // th // ph) (a // th // ph) loc
-    pushSubstsWith th ph (Coe ty p q val loc) =
-      nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc
-    pushSubstsWith th ph (Comp ty p q val r zero one loc) =
-      nclo $ Comp (ty // th // ph) (p // th) (q // th)
-                  (val // th // ph) (r // th)
-                  (zero // th // ph) (one // th // ph) loc
-    pushSubstsWith th ph (TypeCase ty ret arms def loc) =
-      nclo $ TypeCase (ty // th // ph) (ret  // th // ph)
-        (map (\t => t // th // ph) arms) (def // th // ph) loc
-    pushSubstsWith th ph (CloE (Sub e ps)) =
-      pushSubstsWith th (comp th ps ph) e
-    pushSubstsWith th ph (DCloE (Sub e ps)) =
-      pushSubstsWith (ps . th) ph e
-
-
-private %inline
-CompHY : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-         (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
-CompHY {ty, p, q, val, r, zero, one, loc} =
-  let ty' = SY ty.names $ ty.term // (B VZ ty.loc ::: shift 2) in
-  Comp {
-    ty = dsub1 ty q, p, q,
-    val = E $ Coe ty p q val val.loc, r,
-    -- [fixme] better locations for these vars?
-    zero = SY zero.names $ E $
-      Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
-    one = SY one.names $ E $
-      Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
-    loc
-  }
-
-public export %inline
-CompH' : (ty : DScopeTerm d n) ->
-         (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
-         (zero : DScopeTerm d n) ->
-         (one : DScopeTerm d n) ->
-         (loc : Loc) ->
-         Elim d n
-CompH' {ty, p, q, val, r, zero, one, loc} =
-  case dsqueeze ty of
-    S _ (N ty) => Comp   {ty, p, q, val, r, zero, one, loc}
-    S _ (Y _)  => CompHY {ty, p, q, val, r, zero, one, loc}
-
-||| heterogeneous composition, using Comp and Coe (and subst)
-|||
-||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ }
-||| ≔
-||| comp [A‹q/i›] @p @q (coe [i ⇒ A] @p @q s) @r {
-|||   0 j ⇒ coe [i ⇒ A] @j @q t₀;
-|||   1 j ⇒ coe [i ⇒ A] @j @q t₁
-||| }
-public export %inline
-CompH : (i : BindName) -> (ty : Term (S d) n) ->
-        (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
-        (j0 : BindName) -> (zero : Term (S d) n) ->
-        (j1 : BindName) -> (one : Term (S d) n) ->
-        (loc : Loc) ->
-        Elim d n
-CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
-  CompH' {ty = SY [< i] ty, p, q, val, r,
-          zero = SY [< j0] zero, one = SY [< j0] one, loc}
+export
+PushSubsts Term Subst.isCloT where
+  pushSubstsWith th ph (TYPE l loc) =
+    nclo $ TYPE l loc
+  pushSubstsWith th ph (IOState loc) =
+    nclo $ IOState loc
+  pushSubstsWith th ph (Pi qty a body loc) =
+    nclo $ Pi qty (a // th // ph) (body // th // ph) loc
+  pushSubstsWith th ph (Lam body loc) =
+    nclo $ Lam (body // th // ph) loc
+  pushSubstsWith th ph (Sig a b loc) =
+    nclo $ Sig (a // th // ph) (b // th // ph) loc
+  pushSubstsWith th ph (Pair s t loc) =
+    nclo $ Pair (s // th // ph) (t // th // ph) loc
+  pushSubstsWith th ph (Enum tags loc) =
+    nclo $ Enum tags loc
+  pushSubstsWith th ph (Tag tag loc) =
+    nclo $ Tag tag loc
+  pushSubstsWith th ph (Eq ty l r loc) =
+    nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
+  pushSubstsWith th ph (DLam body loc) =
+    nclo $ DLam (body // th // ph) loc
+  pushSubstsWith _ _ (NAT loc) =
+    nclo $ NAT loc
+  pushSubstsWith _ _ (Nat n loc) =
+    nclo $ Nat n loc
+  pushSubstsWith th ph (Succ n loc) =
+    nclo $ Succ (n // th // ph) loc
+  pushSubstsWith _ _ (STRING loc) =
+    nclo $ STRING loc
+  pushSubstsWith _ _ (Str s loc) =
+    nclo $ Str s loc
+  pushSubstsWith th ph (BOX pi ty loc) =
+    nclo $ BOX pi (ty // th // ph) loc
+  pushSubstsWith th ph (Box val loc) =
+    nclo $ Box (val // th // ph) loc
+  pushSubstsWith th ph (E e) =
+    let Element e nc = pushSubstsWith th ph e in nclo $ E e
+  pushSubstsWith th ph (Let qty rhs body loc) =
+    nclo $ Let qty (rhs // th // ph) (body // th // ph) loc
+  pushSubstsWith th ph (CloT (Sub s ps)) =
+    pushSubstsWith th (comp th ps ph) s
+  pushSubstsWith th ph (DCloT (Sub s ps)) =
+    pushSubstsWith (ps . th) ph s

lib/Quox/Syntax/Term/Tighten.idr

@@ -1,40 +1,18 @@
 module Quox.Syntax.Term.Tighten
 
 import Quox.Syntax.Term.Base
-import Quox.Syntax.Subst
+import Quox.Syntax.Term.Subst
 import public Quox.OPE
+import Quox.No
 
 %default total
 
 
-export
-Tighten (Shift f) where
-  -- `OPE m n` is a spicy `m ≤ n`,
-  -- and `Shift f n` is a (different) spicy `f ≤ n`
-  -- so the value is `f ≤ m` (as a `Shift`), if that is the case
-  tighten _        SZ      = Nothing
-  tighten Id       by      = Just by
-  tighten (Drop p) (SS by) = tighten p by
-  tighten (Keep p) (SS by) = [|SS $ tighten p by|]
-
-
 export
 Tighten Dim where
   tighten p (K e loc) = pure $ K e loc
   tighten p (B i loc) = B <$> tighten p i <*> pure loc
 
-
-export
-tightenSub : (forall m, n. OPE m n -> env n -> Maybe (env m)) ->
-             OPE t1 t2 -> Subst env f t2 -> Maybe (Subst env f t1)
-tightenSub f p (Shift by) = [|Shift $ tighten p by|]
-tightenSub f p (t ::: th) = [|f p t !::: tightenSub f p th|]
-
-export
-Tighten env => Tighten (Subst env f) where
-  tighten p th = tightenSub tighten p th
-
-
 export
 tightenScope : (forall m, n. OPE m n -> f n -> Maybe (f m)) ->
                {s : Nat} -> OPE m n -> Scoped s f n -> Maybe (Scoped s f m)
@@ -52,82 +30,101 @@ tightenDScope f p (S names (N body)) = S names . N <$> f p body
 mutual
   private
   tightenT : OPE n1 n2 -> Term d n2 -> Maybe (Term d n1)
-  tightenT p (TYPE l loc) = pure $ TYPE l loc
-  tightenT p (Pi qty arg res loc) =
-    Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc
-  tightenT p (Lam body loc) =
-    Lam <$> tightenS p body <*> pure loc
-  tightenT p (Sig fst snd loc) =
-    Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc
-  tightenT p (Pair fst snd loc) =
-    Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc
-  tightenT p (Enum cases loc) =
-    pure $ Enum cases loc
-  tightenT p (Tag tag loc) =
-    pure $ Tag tag loc
-  tightenT p (Eq ty l r loc) =
-    Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc
-  tightenT p (DLam body loc) =
-    DLam <$> tightenDS p body <*> pure loc
-  tightenT p (Nat loc) =
-    pure $ Nat loc
-  tightenT p (Zero loc) =
-    pure $ Zero loc
-  tightenT p (Succ s loc) =
-    Succ <$> tightenT p s <*> pure loc
-  tightenT p (BOX qty ty loc) =
-    BOX qty <$> tightenT p ty <*> pure loc
-  tightenT p (Box val loc) =
-    Box <$> tightenT p val <*> pure loc
-  tightenT p (E e) =
-    assert_total $ E <$> tightenE p e
-  tightenT p (CloT (Sub tm th)) = do
-    th <- assert_total $ tightenSub tightenE p th
-    pure $ CloT $ Sub tm th
-  tightenT p (DCloT (Sub tm th)) = do
-    tm <- tightenT p tm
-    pure $ DCloT $ Sub tm th
+  tightenT p s =
+    let Element s' _ = pushSubsts s in
+    tightenT' p $ assert_smaller s s'
 
   private
   tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
-  tightenE p (F x u loc) =
+  tightenE p e =
+    let Element e' _ = pushSubsts e in
+    tightenE' p $ assert_smaller e e'
+
+  private
+  tightenT' : OPE n1 n2 -> (t : Term d n2) -> (0 nt : NotClo t) =>
+              Maybe (Term d n1)
+  tightenT' p (TYPE l loc) = pure $ TYPE l loc
+  tightenT' p (IOState loc) = pure $ IOState loc
+  tightenT' p (Pi qty arg res loc) =
+    Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc
+  tightenT' p (Lam body loc) =
+    Lam <$> tightenS p body <*> pure loc
+  tightenT' p (Sig fst snd loc) =
+    Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc
+  tightenT' p (Pair fst snd loc) =
+    Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc
+  tightenT' p (Enum cases loc) =
+    pure $ Enum cases loc
+  tightenT' p (Tag tag loc) =
+    pure $ Tag tag loc
+  tightenT' p (Eq ty l r loc) =
+    Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc
+  tightenT' p (DLam body loc) =
+    DLam <$> tightenDS p body <*> pure loc
+  tightenT' p (NAT loc) =
+    pure $ NAT loc
+  tightenT' p (Nat n loc) =
+    pure $ Nat n loc
+  tightenT' p (Succ s loc) =
+    Succ <$> tightenT p s <*> pure loc
+  tightenT' p (STRING loc) =
+    pure $ STRING loc
+  tightenT' p (Str s loc) =
+    pure $ Str s loc
+  tightenT' p (BOX qty ty loc) =
+    BOX qty <$> tightenT p ty <*> pure loc
+  tightenT' p (Box val loc) =
+    Box <$> tightenT p val <*> pure loc
+  tightenT' p (Let qty rhs body loc) =
+    Let qty <$> assert_total tightenE p rhs <*> tightenS p body <*> pure loc
+  tightenT' p (E e) =
+    E <$> assert_total tightenE p e
+
+  private
+  tightenE' : OPE n1 n2 -> (e : Elim d n2) -> (0 ne : NotClo e) =>
+              Maybe (Elim d n1)
+  tightenE' p (F x u loc) =
     pure $ F x u loc
-  tightenE p (B i loc) =
+  tightenE' p (B i loc) =
     B <$> tighten p i <*> pure loc
-  tightenE p (App fun arg loc) =
+  tightenE' p (App fun arg loc) =
     App <$> tightenE p fun <*> tightenT p arg <*> pure loc
-  tightenE p (CasePair qty pair ret body loc) =
+  tightenE' p (CasePair qty pair ret body loc) =
     CasePair qty <$> tightenE p pair
                  <*> tightenS p ret
                  <*> tightenS p body
                  <*> pure loc
-  tightenE p (CaseEnum qty tag ret arms loc) =
+  tightenE' p (Fst pair loc) =
+    Fst <$> tightenE p pair <*> pure loc
+  tightenE' p (Snd pair loc) =
+    Snd <$> tightenE p pair <*> pure loc
+  tightenE' p (CaseEnum qty tag ret arms loc) =
     CaseEnum qty <$> tightenE p tag
                  <*> tightenS p ret
                  <*> traverse (tightenT p) arms
                  <*> pure loc
-  tightenE p (CaseNat qty qtyIH nat ret zero succ loc) =
+  tightenE' p (CaseNat qty qtyIH nat ret zero succ loc) =
     CaseNat qty qtyIH
       <$> tightenE p nat
       <*> tightenS p ret
       <*> tightenT p zero
       <*> tightenS p succ
       <*> pure loc
-  tightenE p (CaseBox qty box ret body loc) =
+  tightenE' p (CaseBox qty box ret body loc) =
     CaseBox qty <$> tightenE p box
                 <*> tightenS p ret
                 <*> tightenS p body
                 <*> pure loc
-  tightenE p (DApp fun arg loc) =
+  tightenE' p (DApp fun arg loc) =
     DApp <$> tightenE p fun <*> pure arg <*> pure loc
-  tightenE p (Ann tm ty loc) =
+  tightenE' p (Ann tm ty loc) =
     Ann <$> tightenT p tm <*> tightenT p ty <*> pure loc
-  tightenE p (Coe ty q0 q1 val loc) =
+  tightenE' p (Coe ty q0 q1 val loc) =
     Coe <$> tightenDS p ty
         <*> pure q0 <*> pure q1
         <*> tightenT p val
         <*> pure loc
-  tightenE p (Comp ty q0 q1 val r zero one loc) =
+  tightenE' p (Comp ty q0 q1 val r zero one loc) =
     Comp <$> tightenT p ty
          <*> pure q0 <*> pure q1
          <*> tightenT p val
@@ -135,18 +132,12 @@ mutual
          <*> tightenDS p zero
          <*> tightenDS p one
          <*> pure loc
-  tightenE p (TypeCase ty ret arms def loc) =
+  tightenE' p (TypeCase ty ret arms def loc) =
     TypeCase <$> tightenE p ty
              <*> tightenT p ret
              <*> traverse (tightenS p) arms
              <*> tightenT p def
              <*> pure loc
-  tightenE p (CloE (Sub el th)) = do
-    th <- assert_total $ tightenSub tightenE p th
-    pure $ CloE $ Sub el th
-  tightenE p (DCloE (Sub el th)) = do
-    el <- tightenE p el
-    pure $ DCloE $ Sub el th
 
   export
   tightenS : {s : Nat} -> OPE m n ->
@@ -164,95 +155,107 @@ export Tighten (Term d) where tighten p t = tightenT p t
 mutual
   export
   dtightenT : OPE d1 d2 -> Term d2 n -> Maybe (Term d1 n)
-  dtightenT p (TYPE l loc) =
-    pure $ TYPE l loc
-  dtightenT p (Pi qty arg res loc) =
-    Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc
-  dtightenT p (Lam body loc) =
-    Lam <$> dtightenS p body <*> pure loc
-  dtightenT p (Sig fst snd loc) =
-    Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc
-  dtightenT p (Pair fst snd loc) =
-    Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc
-  dtightenT p (Enum cases loc) =
-    pure $ Enum cases loc
-  dtightenT p (Tag tag loc) =
-    pure $ Tag tag loc
-  dtightenT p (Eq ty l r loc) =
-    Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc
-  dtightenT p (DLam body loc) =
-    DLam <$> dtightenDS p body <*> pure loc
-  dtightenT p (Nat loc) =
-    pure $ Nat loc
-  dtightenT p (Zero loc) =
-    pure $ Zero loc
-  dtightenT p (Succ s loc) =
-    Succ <$> dtightenT p s <*> pure loc
-  dtightenT p (BOX qty ty loc) =
-    BOX qty <$> dtightenT p ty <*> pure loc
-  dtightenT p (Box val loc) =
-    Box <$> dtightenT p val <*> pure loc
-  dtightenT p (E e) =
-    assert_total $ E <$> dtightenE p e
-  dtightenT p (CloT (Sub tm th)) = do
-    tm <- dtightenT p tm
-    th <- assert_total $ traverse (dtightenE p) th
-    pure $ CloT $ Sub tm th
-  dtightenT p (DCloT (Sub tm th)) = do
-    th <- tighten p th
-    pure $ DCloT $ Sub tm th
+  dtightenT p s =
+    let Element s' _ = pushSubsts s in
+    dtightenT' p $ assert_smaller s s'
 
   export
   dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
-  dtightenE p (F x u loc) =
+  dtightenE p e =
+    let Element e' _ = pushSubsts e in
+    dtightenE' p $ assert_smaller e e'
+
+  private
+  dtightenT' : OPE d1 d2 -> (t : Term d2 n) -> (0 nt : NotClo t) =>
+               Maybe (Term d1 n)
+  dtightenT' p (TYPE l loc) =
+    pure $ TYPE l loc
+  dtightenT' p (IOState loc) =
+    pure $ IOState loc
+  dtightenT' p (Pi qty arg res loc) =
+    Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc
+  dtightenT' p (Lam body loc) =
+    Lam <$> dtightenS p body <*> pure loc
+  dtightenT' p (Sig fst snd loc) =
+    Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc
+  dtightenT' p (Pair fst snd loc) =
+    Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc
+  dtightenT' p (Enum cases loc) =
+    pure $ Enum cases loc
+  dtightenT' p (Tag tag loc) =
+    pure $ Tag tag loc
+  dtightenT' p (Eq ty l r loc) =
+    Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc
+  dtightenT' p (DLam body loc) =
+    DLam <$> dtightenDS p body <*> pure loc
+  dtightenT' p (NAT loc) =
+    pure $ NAT loc
+  dtightenT' p (Nat n loc) =
+    pure $ Nat n loc
+  dtightenT' p (Succ s loc) =
+    Succ <$> dtightenT p s <*> pure loc
+  dtightenT' p (STRING loc) =
+    pure $ STRING loc
+  dtightenT' p (Str s loc) =
+    pure $ Str s loc
+  dtightenT' p (BOX qty ty loc) =
+    BOX qty <$> dtightenT p ty <*> pure loc
+  dtightenT' p (Box val loc) =
+    Box <$> dtightenT p val <*> pure loc
+  dtightenT' p (Let qty rhs body loc) =
+    Let qty <$> assert_total dtightenE p rhs <*> dtightenS p body <*> pure loc
+  dtightenT' p (E e) =
+    E <$> assert_total dtightenE p e
+
+  export
+  dtightenE' : OPE d1 d2 -> (e : Elim d2 n) -> (0 ne : NotClo e) =>
+               Maybe (Elim d1 n)
+  dtightenE' p (F x u loc) =
     pure $ F x u loc
-  dtightenE p (B i loc) =
+  dtightenE' p (B i loc) =
     pure $ B i loc
-  dtightenE p (App fun arg loc) =
+  dtightenE' p (App fun arg loc) =
     App <$> dtightenE p fun <*> dtightenT p arg <*> pure loc
-  dtightenE p (CasePair qty pair ret body loc) =
+  dtightenE' p (CasePair qty pair ret body loc) =
     CasePair qty <$> dtightenE p pair
                  <*> dtightenS p ret
                  <*> dtightenS p body
                  <*> pure loc
-  dtightenE p (CaseEnum qty tag ret arms loc) =
+  dtightenE' p (Fst pair loc) =
+    Fst <$> dtightenE p pair <*> pure loc
+  dtightenE' p (Snd pair loc) =
+    Snd <$> dtightenE p pair <*> pure loc
+  dtightenE' p (CaseEnum qty tag ret arms loc) =
     CaseEnum qty <$> dtightenE p tag
                  <*> dtightenS p ret
                  <*> traverse (dtightenT p) arms
                  <*> pure loc
-  dtightenE p (CaseNat qty qtyIH nat ret zero succ loc) =
+  dtightenE' p (CaseNat qty qtyIH nat ret zero succ loc) =
     CaseNat qty qtyIH
       <$> dtightenE p nat
       <*> dtightenS p ret
       <*> dtightenT p zero
       <*> dtightenS p succ
       <*> pure loc
-  dtightenE p (CaseBox qty box ret body loc) =
+  dtightenE' p (CaseBox qty box ret body loc) =
     CaseBox qty <$> dtightenE p box
                 <*> dtightenS p ret
                 <*> dtightenS p body
                 <*> pure loc
-  dtightenE p (DApp fun arg loc) =
+  dtightenE' p (DApp fun arg loc) =
     DApp <$> dtightenE p fun <*> tighten p arg <*> pure loc
-  dtightenE p (Ann tm ty loc) =
+  dtightenE' p (Ann tm ty loc) =
     Ann <$> dtightenT p tm <*> dtightenT p ty <*> pure loc
-  dtightenE p (Coe ty q0 q1 val loc) =
+  dtightenE' p (Coe ty q0 q1 val loc) =
     [|Coe (dtightenDS p ty) (tighten p q0) (tighten p q1) (dtightenT p val)
           (pure loc)|]
-  dtightenE p (Comp ty q0 q1 val r zero one loc) =
+  dtightenE' p (Comp ty q0 q1 val r zero one loc) =
     [|Comp (dtightenT p ty) (tighten p q0) (tighten p q1)
            (dtightenT p val) (tighten p r)
            (dtightenDS p zero) (dtightenDS p one) (pure loc)|]
-  dtightenE p (TypeCase ty ret arms def loc) =
+  dtightenE' p (TypeCase ty ret arms def loc) =
     [|TypeCase (dtightenE p ty) (dtightenT p ret)
                (traverse (dtightenS p) arms) (dtightenT p def) (pure loc)|]
-  dtightenE p (CloE (Sub el th)) = do
-    el <- dtightenE p el
-    th <- assert_total $ traverse (dtightenE p) th
-    pure $ CloE $ Sub el th
-  dtightenE p (DCloE (Sub el th)) = do
-    th <- tighten p th
-    pure $ DCloE $ Sub el th
 
   export
   dtightenS : OPE d1 d2 -> ScopeTermN s d2 n -> Maybe (ScopeTermN s d1 n)
@@ -264,25 +267,41 @@ mutual
   dtightenDS = assert_total $ tightenScope dtightenT
 
 
-export [TermD] Tighten (\d => Term d n) where tighten p t = dtightenT p t
-export [ElimD] Tighten (\d => Elim d n) where tighten p e = dtightenE p e
+export Tighten (\d => Term d n) where tighten p t = dtightenT p t
+export Tighten (\d => Elim d n) where tighten p e = dtightenE p e
+
+
+parameters {auto _ : Tighten f} {s : Nat}
+  export
+  squeeze : Scoped s f n -> (BContext s, Either (f (s + n)) (f n))
+  squeeze (S ns (N t)) = (ns, Right t)
+  squeeze (S ns (Y t)) = (ns, maybe (Left t) Right $ tightenN s t)
+
+  export
+  squeeze' : Scoped s f n -> Scoped s f n
+  squeeze' t = let (ns, res) = squeeze t in S ns $ either Y N res
+
+parameters {0 f : Nat -> Nat -> Type}
+           {auto tt : Tighten (\d => f d n)} {s : Nat}
+  export
+  dsqueeze : Scoped s (\d => f d n) d ->
+             (BContext s, Either (f (s + d) n) (f d n))
+  dsqueeze = squeeze
+
+  export
+  dsqueeze' : Scoped s (\d => f d n) d -> Scoped s (\d => f d n) d
+  dsqueeze' = squeeze'
 
 
 -- versions of SY, etc, that try to tighten and use SN automatically
 
-public export
+public export %inline
 ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n
-ST names body =
-  case tightenN s body of
-    Just body => S names $ N body
-    Nothing   => S names $ Y body
+ST names body = squeeze' $ SY names body
 
-public export
+public export %inline
 DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n
-DST names body =
-  case tightenN @{TermD} s body of
-    Just body => S names $ N body
-    Nothing   => S names $ Y body
+DST names body = dsqueeze' {f = Term} $ SY names body
 
 public export %inline
 PiT : (qty : Qty) -> (x : BindName) ->
@@ -316,19 +335,42 @@ public export %inline
 typeCase1T : Elim d n -> Term d n ->
              (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
              (loc : Loc) ->
-             {default (Nat loc) def : Term d n} ->
+             {default (NAT loc) def : Term d n} ->
              Elim d n
 typeCase1T ty ret k ns body loc {def} =
   typeCase ty ret [(k ** ST ns body)] def loc
 
 
-export
-squeeze : {s : Nat} -> ScopeTermN s d n -> ScopeTermN s d n
-squeeze (S names (Y body)) = S names $ maybe (Y body) N $ tightenN s body
-squeeze (S names (N body)) = S names $ N body
+public export %inline
+CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
+         (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
+CompH' {ty, p, q, val, r, zero, one, loc} =
+  let ty' = DST ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
+  Comp {
+    ty = dsub1 ty q, p, q,
+    val = E $ Coe ty p q val val.loc, r,
+    zero = DST zero.names $ E $
+      Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
+    one = DST one.names $ E $
+      Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
+    loc
+  }
 
-export
-dsqueeze : {s : Nat} -> DScopeTermN s d n -> DScopeTermN s d n
-dsqueeze (S names (Y body)) =
-  S names $ maybe (Y body) N $ tightenN s body @{TermD}
-dsqueeze (S names (N body)) = S names $ N body
+||| heterogeneous composition, using Comp and Coe (and subst)
+|||
+||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ }
+||| ≔
+||| comp [A‹q/i›] @p @q (coe [i ⇒ A] @p @q s) @r {
+|||   0 j ⇒ coe [i ⇒ A] @j @q t₀;
+|||   1 j ⇒ coe [i ⇒ A] @j @q t₁
+||| }
+public export %inline
+CompH : (i : BindName) -> (ty : Term (S d) n) ->
+        (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
+        (j0 : BindName) -> (zero : Term (S d) n) ->
+        (j1 : BindName) -> (one : Term (S d) n) ->
+        (loc : Loc) ->
+        Elim d n
+CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
+  CompH' {ty = DST [< i] ty, p, q, val, r,
+          zero = DST [< j0] zero, one = DST [< j1] one, loc}

lib/Quox/Syntax/Term/TyConKind.idr

@@ -9,7 +9,8 @@ import Generics.Derive
 
 
 public export
-data TyConKind = KTYPE | KPi | KSig | KEnum | KEq | KNat | KBOX
+data TyConKind =
+  KTYPE | KIOState | KPi | KSig | KEnum | KEq | KNat | KString | KBOX
 %name TyConKind k
 %runElab derive "TyConKind" [Eq.Eq, Ord.Ord, Show.Show, Generic, Meta, DecEq]
 
@@ -25,10 +26,12 @@ allKinds = %runElab do
 ||| in `type-case`, how many variables are bound in this branch
 public export %inline
 arity : TyConKind -> Nat
-arity KTYPE = 0
-arity KPi   = 2
-arity KSig  = 2
-arity KEnum = 0
-arity KEq   = 5
-arity KNat  = 0
-arity KBOX  = 1
+arity KTYPE    = 0
+arity KIOState = 0
+arity KPi      = 2
+arity KSig     = 2
+arity KEnum    = 0
+arity KEq      = 5
+arity KNat     = 0
+arity KString  = 0
+arity KBOX     = 1

lib/Quox/Typechecker.idr

@@ -3,6 +3,7 @@ module Quox.Typechecker
 import public Quox.Typing
 import public Quox.Equal
 import Quox.Displace
+import Quox.Pretty
 
 import Data.List
 import Data.SnocVect
@@ -13,25 +14,14 @@ import Quox.EffExtra
 
 
 public export
-0 TCEff : List (Type -> Type)
-TCEff = [ErrorEff, DefsReader, NameGen]
-
-public export
-0 TC : Type -> Type
-TC = Eff TCEff
-
-export
-runTCWith : NameSuf -> Definitions -> TC a -> (Either Error a, NameSuf)
-runTCWith = runEqualWith
-
-export
-runTC : Definitions -> TC a -> Either Error a
-runTC = runEqual
+0 TC : List (Type -> Type)
+TC = [ErrorEff, DefsReader, NameGen, Log]
 
 
 parameters (loc : Loc)
   export
-  popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) -> Eff fs (QOutput n)
+  popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) ->
+          Eff fs (QOutput n)
   popQs [<]         qout         = pure qout
   popQs (pis :< pi) (qout :< rh) = do expectCompatQ loc rh pi; popQs pis qout
 
@@ -52,34 +42,24 @@ lubs ctx []        = zeroFor ctx
 lubs ctx (x :: xs) = lubs1 $ x ::: xs
 
 
-export
-typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe ->
-              CtxExtension d n (arity k + n)
-typecaseTel k xs u = case k of
-  KTYPE => [<]
-  -- A : ★ᵤ, B : 0.A → ★ᵤ
-  KPi =>
-    let [< a, b] = xs in
-    [< (Zero, a, TYPE u a.loc),
-       (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
-  KSig =>
-    let [< a, b] = xs in
-    [< (Zero, a, TYPE u a.loc),
-       (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
-  KEnum => [<]
-  -- A₀ : ★ᵤ, A₁ : ★ᵤ, A : (A₀ ≡ A₁ : ★ᵤ), L : A₀, R : A₀
-  KEq =>
-    let [< a0, a1, a, l, r] = xs in
-    [< (Zero, a0, TYPE u a0.loc),
-       (Zero, a1, TYPE u a1.loc),
-       (Zero, a,  Eq0 (TYPE u a.loc) (BVT 1 a.loc) (BVT 0 a.loc) a.loc),
-       (Zero, l,  BVT 2 l.loc),
-       (Zero, r,  BVT 2 r.loc)]
-  KNat => [<]
-  -- A : ★ᵤ
-  KBOX => let [< a] = xs in [< (Zero, a, TYPE u a.loc)]
+private
+prettyTermTC : {opts : LayoutOpts} ->
+               TyContext d n -> Term d n -> Eff Pretty (Doc opts)
+prettyTermTC ctx s = prettyTerm ctx.dnames ctx.tnames s
 
 
+private
+checkLogs : String -> TyContext d n -> SQty ->
+            Term d n -> Maybe (Term d n) -> Eff TC ()
+checkLogs fun ctx sg subj ty = do
+  let tyDoc = delay $ maybe (text "none") (runPretty . prettyTermTC ctx) ty
+  sayMany "check" subj.loc
+    [10 :> text fun,
+     95 :> hsep ["ctx =",  runPretty $ prettyTyContext ctx],
+     95 :> hsep ["sg =",   runPretty $ prettyQty sg.qty],
+     10 :> hsep ["subj =", runPretty $ prettyTermTC ctx subj],
+     10 :> hsep ["ty =",   tyDoc]]
+
 mutual
   ||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ"
   |||
@@ -91,28 +71,32 @@ mutual
   ||| doing any further work.
   export covering %inline
   check : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
-          TC (CheckResult ctx.dctx n)
-  check ctx sg subj ty = ifConsistent ctx.dctx $ checkC ctx sg subj ty
+          Eff TC (CheckResult ctx.dctx n)
+  check ctx sg subj ty =
+    ifConsistentElse ctx.dctx
+      (do checkLogs "check" ctx sg subj (Just ty)
+          checkC ctx sg subj ty)
+      (say "check" 20 subj.loc "check: 0=1")
 
   ||| "Ψ | Γ ⊢₀ s ⇐ A"
   |||
   ||| `check0 ctx subj ty` checks a term (as `check`) in a zero context.
   export covering %inline
-  check0 : TyContext d n -> Term d n -> Term d n -> TC ()
-  check0 ctx tm ty = ignore $ check ctx szero tm ty
+  check0 : TyContext d n -> Term d n -> Term d n -> Eff TC ()
+  check0 ctx tm ty = ignore $ check ctx SZero tm ty
     -- the output will always be 𝟎 because the subject quantity is 0
 
   ||| `check`, assuming the dimension context is consistent
   export covering %inline
   checkC : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
-           TC (CheckResult' n)
+           Eff TC (CheckResult' n)
   checkC ctx sg subj ty =
-    wrapErr (WhileChecking ctx sg.fst subj ty) $
+    wrapErr (WhileChecking ctx sg subj ty) $
     checkCNoWrap ctx sg subj ty
 
   export covering %inline
   checkCNoWrap : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
-                 TC (CheckResult' n)
+                 Eff TC (CheckResult' n)
   checkCNoWrap ctx sg subj ty =
     let Element subj nc = pushSubsts subj in
     check' ctx sg subj ty
@@ -122,16 +106,21 @@ mutual
   ||| `checkType ctx subj ty` checks a type (in a zero context). sometimes the
   ||| universe doesn't matter, only that a term is _a_ type, so it is optional.
   export covering %inline
-  checkType : TyContext d n -> Term d n -> Maybe Universe -> TC ()
-  checkType ctx subj l = ignore $ ifConsistent ctx.dctx $ checkTypeC ctx subj l
+  checkType : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
+  checkType ctx subj l = do
+    let univ = TYPE <$> l <*> pure noLoc
+    ignore $ ifConsistentElse ctx.dctx
+      (do checkLogs "checkType" ctx SZero subj univ
+          checkTypeC ctx subj l)
+      (say "check" 20 subj.loc "checkType: 0=1")
 
   export covering %inline
-  checkTypeC : TyContext d n -> Term d n -> Maybe Universe -> TC ()
+  checkTypeC : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
   checkTypeC ctx subj l =
     wrapErr (WhileCheckingTy ctx subj l) $ checkTypeNoWrap ctx subj l
 
   export covering %inline
-  checkTypeNoWrap : TyContext d n -> Term d n -> Maybe Universe -> TC ()
+  checkTypeNoWrap : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
   checkTypeNoWrap ctx subj l =
     let Element subj nc = pushSubsts subj in
     checkType' ctx subj l
@@ -145,15 +134,19 @@ mutual
   ||| doing any further work.
   export covering %inline
   infer : (ctx : TyContext d n) -> SQty -> Elim d n ->
-          TC (InferResult ctx.dctx d n)
-  infer ctx sg subj = ifConsistent ctx.dctx $ inferC ctx sg subj
+          Eff TC (InferResult ctx.dctx d n)
+  infer ctx sg subj = do
+    ifConsistentElse ctx.dctx
+      (do checkLogs "infer" ctx sg (E subj) Nothing
+          inferC ctx sg subj)
+      (say "check" 20 subj.loc "infer: 0=1")
 
   ||| `infer`, assuming the dimension context is consistent
   export covering %inline
   inferC : (ctx : TyContext d n) -> SQty -> Elim d n ->
-           TC (InferResult' d n)
+           Eff TC (InferResult' d n)
   inferC ctx sg subj =
-    wrapErr (WhileInferring ctx sg.fst subj) $
+    wrapErr (WhileInferring ctx sg subj) $
       let Element subj nc = pushSubsts subj in
       infer' ctx sg subj
 
@@ -161,27 +154,29 @@ mutual
   private covering
   toCheckType : TyContext d n -> SQty ->
                 (subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
-                TC (CheckResult' n)
+                Eff TC (CheckResult' n)
   toCheckType ctx sg t ty = do
-    u <- expectTYPE !(askAt DEFS) ctx ty.loc ty
-    expectEqualQ t.loc Zero sg.fst
+    u <- expectTYPE !(askAt DEFS) ctx sg ty.loc ty
+    expectEqualQ t.loc Zero sg.qty
     checkTypeNoWrap ctx t (Just u)
     pure $ zeroFor ctx
 
   private covering
   check' : TyContext d n -> SQty ->
            (subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
-           TC (CheckResult' n)
+           Eff TC (CheckResult' n)
 
   check' ctx sg t@(TYPE {}) ty = toCheckType ctx sg t ty
 
+  check' ctx sg t@(IOState {}) ty = toCheckType ctx sg t ty
+
   check' ctx sg t@(Pi {}) ty = toCheckType ctx sg t ty
 
   check' ctx sg (Lam body loc) ty = do
-    (qty, arg, res) <- expectPi !(askAt DEFS) ctx ty.loc ty
+    (qty, arg, res) <- expectPi !(askAt DEFS) ctx SZero ty.loc ty
     -- if Ψ | Γ, x : A ⊢ σ · t ⇐ B ⊳ Σ, ρ·x
     -- with ρ ≤ σπ
-    let qty' = sg.fst * qty
+    let qty' = sg.qty * qty
     qout <- checkC (extendTy qty' body.name arg ctx) sg body.term res.term
     -- then Ψ | Γ ⊢ σ · (λx ⇒ t) ⇐ (π·x : A) → B ⊳ Σ
     popQ loc qty' qout
@@ -189,7 +184,7 @@ mutual
   check' ctx sg t@(Sig {}) ty = toCheckType ctx sg t ty
 
   check' ctx sg (Pair fst snd loc) ty = do
-    (tfst, tsnd) <- expectSig !(askAt DEFS) ctx ty.loc ty
+    (tfst, tsnd) <- expectSig !(askAt DEFS) ctx SZero ty.loc ty
     -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ₁
     qfst <- checkC ctx sg fst tfst
     let tsnd = sub1 tsnd (Ann fst tfst fst.loc)
@@ -201,7 +196,7 @@ mutual
   check' ctx sg t@(Enum {}) ty = toCheckType ctx sg t ty
 
   check' ctx sg (Tag t loc) ty = do
-    tags <- expectEnum !(askAt DEFS) ctx ty.loc ty
+    tags <- expectEnum !(askAt DEFS) ctx SZero ty.loc ty
     -- if t ∈ ts
     unless (t `elem` tags) $ throw $ TagNotIn loc t tags
     -- then Ψ | Γ ⊢ σ · t ⇐ {ts} ⊳ 𝟎
@@ -210,38 +205,54 @@ mutual
   check' ctx sg t@(Eq {}) ty = toCheckType ctx sg t ty
 
   check' ctx sg (DLam body loc) ty = do
-    (ty, l, r) <- expectEq !(askAt DEFS) ctx ty.loc ty
+    (ty, l, r) <- expectEq !(askAt DEFS) ctx SZero ty.loc ty
     let ctx' = extendDim body.name ctx
         ty   = ty.term
         body = body.term
     -- if Ψ, i | Γ ⊢ σ · t ⇐ A ⊳ Σ
     qout <- checkC ctx' sg body ty
     -- if Ψ, i, i = 0 | Γ ⊢ t = l : A
-    lift $ equal loc (eqDim (B VZ loc) (K Zero loc) ctx') ty body (dweakT 1 l)
+    let ctx0 = eqDim (B VZ loc) (K Zero loc) ctx'
+    lift $ equal loc ctx0 sg ty body $ dweakT 1 l
     -- if Ψ, i, i = 1 | Γ ⊢ t = r : A
-    lift $ equal loc (eqDim (B VZ loc) (K One loc)  ctx') ty body (dweakT 1 r)
+    let ctx1 = eqDim (B VZ loc) (K One loc) ctx'
+    lift $ equal loc ctx1 sg ty body $ dweakT 1 r
     -- then Ψ | Γ ⊢ σ · (δ i ⇒ t) ⇐ Eq [i ⇒ A] l r ⊳ Σ
     pure qout
 
-  check' ctx sg t@(Nat {}) ty = toCheckType ctx sg t ty
+  check' ctx sg t@(NAT {}) ty = toCheckType ctx sg t ty
 
-  check' ctx sg (Zero {}) ty = do
-    expectNat !(askAt DEFS) ctx ty.loc ty
+  check' ctx sg (Nat {}) ty = do
+    expectNAT !(askAt DEFS) ctx SZero ty.loc ty
     pure $ zeroFor ctx
 
   check' ctx sg (Succ n {}) ty = do
-    expectNat !(askAt DEFS) ctx ty.loc ty
+    expectNAT !(askAt DEFS) ctx SZero ty.loc ty
     checkC ctx sg n ty
 
+  check' ctx sg t@(STRING {}) ty = toCheckType ctx sg t ty
+
+  check' ctx sg t@(Str s {}) ty = do
+    expectSTRING !(askAt DEFS) ctx SZero ty.loc ty
+    pure $ zeroFor ctx
+
   check' ctx sg t@(BOX {}) ty = toCheckType ctx sg t ty
 
   check' ctx sg (Box val loc) ty = do
-    (q, ty) <- expectBOX !(askAt DEFS) ctx ty.loc ty
-    -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
-    valout <- checkC ctx sg val ty
+    (q, ty) <- expectBOX !(askAt DEFS) ctx SZero ty.loc ty
+    -- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ
+    valout <- checkC ctx (subjMult sg q) val ty
     -- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ
     pure $ q * valout
 
+  check' ctx sg (Let qty rhs body loc) ty = do
+    eres <- inferC ctx (subjMult sg qty) rhs
+    let sqty = sg.qty * qty
+    qout <- checkC (extendTyLet sqty body.name eres.type (E rhs) ctx)
+              sg body.term (weakT 1 ty)
+        >>= popQ loc sqty
+    pure $ qty * eres.qout + qout
+
   check' ctx sg (E e) ty = do
     -- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ
     infres <- inferC ctx sg e
@@ -253,7 +264,7 @@ mutual
   private covering
   checkType' : TyContext d n ->
                (subj : Term d n) -> (0 nc : NotClo subj) =>
-               Maybe Universe -> TC ()
+               Maybe Universe -> Eff TC ()
 
   checkType' ctx (TYPE k loc) u = do
     -- if 𝓀 < ℓ then Ψ | Γ ⊢₀ Type 𝓀 ⇐ Type ℓ
@@ -261,6 +272,9 @@ mutual
       Just l  => unless (k < l) $ throw $ BadUniverse loc k l
       Nothing => pure ()
 
+  checkType' ctx (IOState loc) u = pure ()
+    -- Ψ | Γ ⊢₀ IOState ⇒ Type ℓ
+
   checkType' ctx (Pi qty arg res _) u = do
     -- if Ψ | Γ ⊢₀ A ⇐ Type ℓ
     checkTypeC ctx arg u
@@ -301,26 +315,35 @@ mutual
   checkType' ctx t@(DLam {}) u =
     throw $ NotType t.loc ctx t
 
-  checkType' ctx (Nat {}) u = pure ()
-  checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t
+  checkType' ctx (NAT {}) u = pure ()
+  checkType' ctx t@(Nat {}) u = throw $ NotType t.loc ctx t
   checkType' ctx t@(Succ {}) u = throw $ NotType t.loc ctx t
 
+  checkType' ctx (STRING loc) u = pure ()
+    -- Ψ | Γ ⊢₀ STRING ⇒ Type ℓ
+  checkType' ctx t@(Str {}) u = throw $ NotType t.loc ctx t
+
   checkType' ctx (BOX q ty _) u = checkType ctx ty u
   checkType' ctx t@(Box {}) u = throw $ NotType t.loc ctx t
 
+  checkType' ctx (Let qty rhs body loc) u = do
+    expectEqualQ loc qty Zero
+    ety <- inferC ctx SZero rhs
+    checkType (extendTy Zero body.name ety.type ctx) body.term u
+
   checkType' ctx (E e) u = do
     -- if Ψ | Γ ⊢₀ E ⇒ Type ℓ
-    infres <- inferC ctx szero e
+    infres <- inferC ctx SZero e
     -- if Ψ | Γ ⊢ Type ℓ <: Type 𝓀
     case u of
-      Just u  => lift $ subtype e.loc ctx infres.type (TYPE u noLoc)
-      Nothing => ignore $ expectTYPE !(askAt DEFS) ctx e.loc infres.type
+      Just u  => lift $ subtype e.loc ctx infres.type (TYPE u e.loc)
+      Nothing => ignore $ expectTYPE !(askAt DEFS) ctx SZero e.loc infres.type
     -- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀
 
 
   private covering
   checkTypeScope : TyContext d n -> Term d n ->
-                   ScopeTerm d n -> Maybe Universe -> TC ()
+                   ScopeTerm d n -> Maybe Universe -> Eff TC ()
   checkTypeScope ctx s (S _     (N body)) u = checkType ctx body u
   checkTypeScope ctx s (S [< x] (Y body)) u =
     checkType (extendTy Zero x s ctx) body u
@@ -329,25 +352,27 @@ mutual
   private covering
   infer' : TyContext d n -> SQty ->
            (subj : Elim d n) -> (0 nc : NotClo subj) =>
-           TC (InferResult' d n)
+           Eff TC (InferResult' d n)
 
   infer' ctx sg (F x u loc) = do
     -- if π·x : A {≔ s} in global context
     g <- lookupFree x loc !(askAt DEFS)
     -- if σ ≤ π
-    expectCompatQ loc sg.fst g.qty.fst
+    expectCompatQ loc sg.qty g.qty.qty
     -- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
-    let Val d = ctx.dimLen; Val n = ctx.termLen
-    pure $ InfRes {type = displace u g.type, qout = zeroFor ctx}
+    pure $ InfRes {
+      type = g.typeWithAt ctx.dimLen ctx.termLen u,
+      qout = zeroFor ctx
+    }
 
   infer' ctx sg (B i _) =
     -- if x : A ∈ Γ
     -- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ (𝟎, σ·x, 𝟎)
-    pure $ lookupBound sg.fst i ctx.tctx
+    pure $ lookupBound sg.qty i ctx.tctx
   where
     lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n
-    lookupBound pi VZ (ctx :< type) =
-      InfRes {type = weakT 1 type, qout = zeroFor ctx :< pi}
+    lookupBound pi VZ (ctx :< var) =
+      InfRes {type = weakT 1 var.type, qout = zeroFor ctx :< pi}
     lookupBound pi (VS i) (ctx :< _) =
       let InfRes {type, qout} = lookupBound pi i ctx in
       InfRes {type = weakT 1 type, qout = qout :< Zero}
@@ -355,7 +380,7 @@ mutual
   infer' ctx sg (App fun arg loc) = do
     -- if Ψ | Γ ⊢ σ · f ⇒ (π·x : A) → B ⊳ Σ₁
     funres <- inferC ctx sg fun
-    (qty, argty, res) <- expectPi !(askAt DEFS) ctx fun.loc funres.type
+    (qty, argty, res) <- expectPi !(askAt DEFS) ctx SZero fun.loc funres.type
     -- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ₂
     argout <- checkC ctx (subjMult sg qty) arg argty
     -- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + πΣ₂
@@ -372,12 +397,12 @@ mutual
     pairres <- inferC ctx sg pair
     -- if Ψ | Γ, p : (x : A) × B ⊢₀ ret ⇐ Type
     checkTypeC (extendTy Zero ret.name pairres.type ctx) ret.term Nothing
-    (tfst, tsnd) <- expectSig !(askAt DEFS) ctx pair.loc pairres.type
+    (tfst, tsnd) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
     -- if Ψ | Γ, x : A, y : B ⊢ σ · body ⇐
     --    ret[(x, y) ∷ (x : A) × B/p] ⊳ Σ₂, ρ₁·x, ρ₂·y
     -- with ρ₁, ρ₂ ≤ πσ
     let [< x, y]  = body.names
-        pisg    = pi * sg.fst
+        pisg    = pi * sg.qty
         bodyctx = extendTyN [< (pisg, x, tfst), (pisg, y, tsnd.term)] ctx
         bodyty  = substCasePairRet body.names pairres.type ret
     bodyout <- checkC bodyctx sg body.term bodyty >>=
@@ -388,10 +413,30 @@ mutual
       qout = pi * pairres.qout + bodyout
     }
 
+  infer' ctx sg (Fst pair loc) = do
+    -- if Ψ | Γ ⊢ σ · e ⇒ (x : A) × B ⊳ Σ
+    pairres <- inferC ctx sg pair
+    (tfst, _) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
+    -- then Ψ | Γ ⊢ σ · fst e ⇒ A ⊳ ωΣ
+    pure $ InfRes {
+      type = tfst,
+      qout = Any * pairres.qout
+    }
+
+  infer' ctx sg (Snd pair loc) = do
+    -- if Ψ | Γ ⊢ σ · e ⇒ (x : A) × B ⊳ Σ
+    pairres <- inferC ctx sg pair
+    (_, tsnd) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
+    -- then Ψ | Γ ⊢ σ · snd e ⇒ B[fst e/x] ⊳ ωΣ
+    pure $ InfRes {
+      type = sub1 tsnd (Fst pair loc),
+      qout = Any * pairres.qout
+    }
+
   infer' ctx sg (CaseEnum pi t ret arms loc) {d, n} = do
     -- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁
     tres <- inferC ctx sg t
-    ttags <- expectEnum !(askAt DEFS) ctx t.loc tres.type
+    ttags <- expectEnum !(askAt DEFS) ctx SZero t.loc tres.type
     -- if 1 ≤ π, OR there is only zero or one option
     unless (length (SortedSet.toList ttags) <= 1) $ expectCompatQ loc One pi
     -- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type
@@ -415,39 +460,43 @@ mutual
     -- if Ψ | Γ ⊢ σ · n ⇒ ℕ ⊳ Σn
     nres <- inferC ctx sg n
     let nat = nres.type
-    expectNat !(askAt DEFS) ctx n.loc nat
+    expectNAT !(askAt DEFS) ctx SZero n.loc nat
     -- if Ψ | Γ, n : ℕ ⊢₀ A ⇐ Type
     checkTypeC (extendTy Zero ret.name nat ctx) ret.term Nothing
     -- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ ℕ/n] ⊳ Σz
     zerout <- checkC ctx sg zer $ sub1 ret $ Ann (Zero zer.loc) nat zer.loc
-    -- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ₁.p, ρ₂.ih
-    -- with ρ₂ ≤ π'σ, (ρ₁ + ρ₂) ≤ πσ
+    -- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ.p, ς.ih
+    -- with ς ≤ π'σ, (ρ + ς) ≤ πσ
     let [< p, ih] = suc.names
-        pisg      = pi * sg.fst
-        sucCtx    = extendTyN [< (pisg, p, Nat p.loc), (pi', ih, ret.term)] ctx
+        pisg      = pi * sg.qty
+        sucCtx    = extendTyN [< (pisg, p, NAT p.loc), (pi', ih, ret.term)] ctx
         sucType   = substCaseSuccRet suc.names ret
     sucout :< qp :< qih <- checkC sucCtx sg suc.term sucType
-    expectCompatQ loc qih (pi' * sg.fst)
+    expectCompatQ loc qih (pi' * sg.qty)
     -- [fixme] better error here
     expectCompatQ loc (qp + qih) pisg
-    -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σz + ωΣs
+    -- if ς = 0, then Σb = lubs(Σz, Σs), otherwise Σb = Σz + ωςΣs
+    let bodyout = case qih of
+          Zero => lubs ctx [zerout, sucout]
+          _    => zerout + Any * sucout
+    -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σb
     pure $ InfRes {
       type = sub1 ret n,
-      qout = pi * nres.qout + zerout + Any * sucout
+      qout = pi * nres.qout + bodyout
     }
 
   infer' ctx sg (CaseBox pi box ret body loc) = do
     -- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁
     boxres <- inferC ctx sg box
-    (q, ty) <- expectBOX !(askAt DEFS) ctx box.loc boxres.type
+    (rh, ty) <- expectBOX !(askAt DEFS) ctx SZero box.loc boxres.type
     -- if Ψ | Γ, x : [ρ.A] ⊢₀ R ⇐ Type
     checkTypeC (extendTy Zero ret.name boxres.type ctx) ret.term Nothing
-    -- if Ψ | Γ, x : A ⊢ t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x
+    -- if Ψ | Γ, x : A ⊢ σ · t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x
     --   with ς ≤ ρπσ
-    let qpisg    = q * pi * sg.fst
-        bodyCtx  = extendTy qpisg body.name ty ctx
+    let rhpisg   = rh * pi * sg.qty
+        bodyCtx  = extendTy rhpisg body.name ty ctx
         bodyType = substCaseBoxRet body.name ty ret
-    bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc qpisg
+    bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc rhpisg
     -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ R[b/x] ⊳ Σ₁ + Σ₂
     pure $ InfRes {
       type = sub1 ret box,
@@ -457,42 +506,54 @@ mutual
   infer' ctx sg (DApp fun dim loc) = do
     -- if Ψ | Γ ⊢ σ · f ⇒ Eq [𝑖 ⇒ A] l r ⊳ Σ
     InfRes {type, qout} <- inferC ctx sg fun
-    ty <- fst <$> expectEq !(askAt DEFS) ctx fun.loc type
+    ty <- fst <$> expectEq !(askAt DEFS) ctx SZero fun.loc type
     -- then Ψ | Γ ⊢ σ · f p ⇒ A‹p/𝑖› ⊳ Σ
     pure $ InfRes {type = dsub1 ty dim, qout}
 
   infer' ctx sg (Coe ty p q val loc) = do
+    -- if Ψ, 𝑖 | Γ ⊢₀ A ⇐ Type _
     checkType (extendDim ty.name ctx) ty.term Nothing
+    -- if Ψ | Γ ⊢ σ · s ⇐ A‹p/𝑖› ⊳ Σ
     qout <- checkC ctx sg val $ dsub1 ty p
+    -- then Ψ | Γ ⊢ σ · coe (𝑖 ⇒ A) @p @q s ⇒ A‹q/𝑖› ⊳ Σ
     pure $ InfRes {type = dsub1 ty q, qout}
 
   infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1) loc) = do
+    -- if Ψ | Γ ⊢₀ A ⇐ Type _
     checkType ctx ty Nothing
+    -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
     qout <- checkC ctx sg val ty
+    -- if Ψ, 𝑗, 𝑖=0      | Γ ⊢ σ · t₀ ⇐ A ⊳ Σ₀
+    --    Ψ, 𝑗, 𝑖=0, 𝑗=p | Γ ⊢ t₀ = s ⇐ A
     let ty'  = dweakT 1 ty; val' = dweakT 1 val; p' = weakD 1 p
         ctx0 = extendDim j0 $ eqDim r (K Zero j0.loc) ctx
-        val0 = val0.term
+        val0 = getTerm val0
     qout0 <- check ctx0 sg val0 ty'
-    lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) ty' val0 val'
+    lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) sg ty' val0 val'
+    -- if Ψ, 𝑗, 𝑖=1      | Γ ⊢ σ · t₁ ⇐ A ⊳ Σ₁
+    --    Ψ, 𝑗, 𝑖=1, 𝑗=p | Γ ⊢ t₁ = s ⇐ A
     let ctx1 = extendDim j1 $ eqDim r (K One j1.loc) ctx
-        val1  = val1.term
+        val1  = getTerm val1
     qout1 <- check ctx1 sg val1 ty'
-    lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) ty' val1 val'
+    -- if Σ = Σ₀ = Σ₁
+    lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) sg ty' val1 val'
     let qouts  = qout :: catMaybes [toMaybe qout0, toMaybe qout1]
+    -- then Ψ | Γ ⊢ comp A @p @q s @r {0 𝑗 ⇒ t₀; 1 𝑗 ⇒ t₁} ⇒ A ⊳ Σ
     pure $ InfRes {type = ty, qout = lubs ctx qouts}
 
   infer' ctx sg (TypeCase ty ret arms def loc) = do
     -- if σ = 0
-    expectEqualQ loc Zero sg.fst
+    expectEqualQ loc Zero sg.qty
     -- if Ψ, Γ ⊢₀ e ⇒ Type u
-    u <- expectTYPE !(askAt DEFS) ctx ty.loc . type =<< inferC ctx szero ty
+    u <- inferC ctx SZero ty >>=
+         expectTYPE !(askAt DEFS) ctx SZero ty.loc . type
     -- if Ψ, Γ ⊢₀ C ⇐ Type (non-dependent return type)
     checkTypeC ctx ret Nothing
     -- if Ψ, Γ' ⊢₀ A ⇐ C for each rhs A
     for_ allKinds $ \k =>
       for_ (lookupPrecise k arms) $ \(S names t) =>
         check0 (extendTyN (typecaseTel k names u) ctx)
-               t.term (weakT (arity k) ret)
+               (getTerm t) (weakT (arity k) ret)
     -- then Ψ, Γ ⊢₀ type-case ⋯ ⇒ C
     pure $ InfRes {type = ret, qout = zeroFor ctx}
 

lib/Quox/Typing.idr

@@ -6,7 +6,8 @@ import public Quox.Typing.Error as Typing
 
 import public Quox.Syntax
 import public Quox.Definition
-import public Quox.Reduce
+import public Quox.Whnf
+import public Quox.Pretty
 
 import Language.Reflection
 import Control.Eff
@@ -46,16 +47,15 @@ lookupFree x loc defs = maybe (throw $ NotInScope loc x) pure $ lookup x defs
 public export
 substCasePairRet : BContext 2 -> Term d n -> ScopeTerm d n -> Term d (2 + n)
 substCasePairRet [< x, y] dty retty =
-  let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc
-      arg = Ann tm (dty // fromNat 2) tm.loc
-  in
+  let tm  = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc
+      arg = Ann tm (dty // fromNat 2) tm.loc in
   retty.term // (arg ::: shift 2)
 
 public export
 substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n)
 substCaseSuccRet [< p, ih] retty =
-  let arg = Ann (Succ (BVT 1 p.loc) p.loc) (Nat noLoc) $ p.loc `extendL` ih.loc
-  in
+  let loc = p.loc `extendL` ih.loc
+      arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT p.loc) loc in
   retty.term // (arg ::: shift 2)
 
 public export
@@ -65,23 +65,31 @@ substCaseBoxRet x dty retty =
   retty.term // (arg ::: shift 1)
 
 
-parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
+private
+0 ExpectErrorConstructor : Type
+ExpectErrorConstructor =
+  forall d, n. Loc -> NameContexts d n -> Term d n -> Error
+
+parameters (defs : Definitions)
+           {auto _ : (Has ErrorEff fs, Has NameGen fs, Has Log fs)}
   namespace TyContext
-   parameters (ctx : TyContext d n) (loc : Loc)
+   parameters (ctx : TyContext d n) (sg : SQty) (loc : Loc)
     export covering
     whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
-           tm d n -> Eff fs (NonRedex tm d n defs)
+           tm d n -> Eff fs (NonRedex tm d n defs (toWhnfContext ctx) sg)
     whnf tm = do
       let Val n = ctx.termLen; Val d = ctx.dimLen
-      res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm
+      res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
       rethrow res
 
     private covering %macro
-    expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
-             TTImp -> TTImp -> Elab (Term d n -> Eff fs a)
-    expect k l r = do
-      f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
-      pure $ \t => maybe (throw $ k loc ctx.names t) pure . f . fst =<< whnf t
+    expect : ExpectErrorConstructor -> TTImp -> TTImp ->
+             Elab (Term d n -> Eff fs a)
+    expect err pat rhs = Prelude.do
+      match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
+      pure $ \term => do
+        res <- whnf term
+        maybe (throw $ err loc ctx.names term) pure $ match $ fst res
 
     export covering %inline
     expectTYPE : Term d n -> Eff fs Universe
@@ -104,32 +112,40 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
     expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
 
     export covering %inline
-    expectNat : Term d n -> Eff fs ()
-    expectNat = expect ExpectedNat `(Nat {}) `(())
+    expectNAT : Term d n -> Eff fs ()
+    expectNAT = expect ExpectedNAT `(NAT {}) `(())
+
+    export covering %inline
+    expectSTRING : Term d n -> Eff fs ()
+    expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
 
     export covering %inline
     expectBOX : Term d n -> Eff fs (Qty, Term d n)
     expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
 
+    export covering %inline
+    expectIOState : Term d n -> Eff fs ()
+    expectIOState = expect ExpectedIOState `(IOState {}) `(())
+
 
   namespace EqContext
-   parameters (ctx : EqContext n) (loc : Loc)
+   parameters (ctx : EqContext n) (sg : SQty) (loc : Loc)
     export covering
     whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
-           tm 0 n -> Eff fs (NonRedex tm 0 n defs)
+           tm 0 n -> Eff fs (NonRedex tm 0 n defs (toWhnfContext ctx) sg)
     whnf tm = do
-      let Val n = ctx.termLen
-      res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm
+      res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
       rethrow res
 
     private covering %macro
-    expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
-             TTImp -> TTImp -> Elab (Term 0 n -> Eff fs a)
-    expect k l r = do
-      f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
-      pure $ \t =>
-        let err = throw $ k loc ctx.names (t // shift0 ctx.dimLen) in
-        maybe err pure . f . fst =<< whnf t
+    expect : ExpectErrorConstructor -> TTImp -> TTImp ->
+             Elab (Term 0 n -> Eff fs a)
+    expect err pat rhs = do
+      match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
+      pure $ \term => do
+        res <- whnf term
+        let t0 = delay $ term // shift0 ctx.dimLen
+        maybe (throw $ err loc ctx.names t0) pure $ match $ fst res
 
     export covering %inline
     expectTYPE : Term 0 n -> Eff fs Universe
@@ -152,9 +168,17 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
     expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
 
     export covering %inline
-    expectNat : Term 0 n -> Eff fs ()
-    expectNat = expect ExpectedNat `(Nat {}) `(())
+    expectNAT : Term 0 n -> Eff fs ()
+    expectNAT = expect ExpectedNAT `(NAT {}) `(())
+
+    export covering %inline
+    expectSTRING : Term 0 n -> Eff fs ()
+    expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
 
     export covering %inline
     expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n)
     expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
+
+    export covering %inline
+    expectIOState : Term 0 n -> Eff fs ()
+    expectIOState = expect ExpectedIOState `(IOState {}) `(())

lib/Quox/Typing/Context.idr

@@ -4,17 +4,51 @@ import Quox.Syntax
 import Quox.Context
 import Quox.Pretty
 import public Data.Singleton
+import Derive.Prelude
 
 %default total
+%language ElabReflection
 
 
 public export
 QContext : Nat -> Type
 QContext = Context' Qty
 
+public export
+record LocalVar d n where
+  constructor MkLocal
+  type : Term d n
+  term : Maybe (Term d n) -- if from a `let`
+%runElab deriveIndexed "LocalVar" [Show]
+
+namespace LocalVar
+  export %inline
+  letVar : (type, term : Term d n) -> LocalVar d n
+  letVar type term = MkLocal {type, term = Just term}
+
+  export %inline
+  lamVar : (type : Term d n) -> LocalVar d n
+  lamVar type = MkLocal {type, term = Nothing}
+
+  export %inline
+  mapVar : (Term d n -> Term d' n') -> LocalVar d n -> LocalVar d' n'
+  mapVar f = {type $= f, term $= map f}
+
+  export %inline
+  subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n
+  subD th = mapVar (// th)
+
+  export %inline
+  weakD : LocalVar d n -> LocalVar (S d) n
+  weakD = subD $ shift 1
+
+export %inline CanShift  (LocalVar d) where l // by = mapVar (// by) l
+export %inline CanDSubst LocalVar     where l // by = mapVar (// by) l
+export %inline CanTSubst LocalVar     where l // by = mapVar (// by) l
+
 public export
 TContext : TermLike
-TContext d = Context (Term d)
+TContext d = Context (LocalVar d)
 
 public export
 QOutput : Nat -> Type
@@ -31,11 +65,12 @@ record TyContext d n where
   {auto dimLen  : Singleton d}
   {auto termLen : Singleton n}
   dctx   : DimEq d
-  dnames : BContext d
+  dnames : BContext d -- only used for printing
   tctx   : TContext d n
-  tnames : BContext n
+  tnames : BContext n -- only used for printing
   qtys   : QContext n -- only used for printing
 %name TyContext ctx
+%runElab deriveIndexed "TyContext" [Show]
 
 
 public export
@@ -46,29 +81,29 @@ record EqContext n where
   dassign : DimAssign dimLen -- only used for printing
   dnames  : BContext dimLen -- only used for printing
   tctx    : TContext 0 n
-  tnames  : BContext n
+  tnames  : BContext n -- only used for printing
   qtys    : QContext n -- only used for printing
 %name EqContext ctx
+%runElab deriveIndexed "EqContext" [Show]
 
 
 public export
 record WhnfContext d n where
   constructor MkWhnfContext
+  {auto dimLen  : Singleton d}
+  {auto termLen : Singleton n}
   dnames : BContext d
   tnames : BContext n
   tctx   : TContext d n
 %name WhnfContext ctx
+%runElab deriveIndexed "WhnfContext" [Show]
 
 namespace TContext
-  export %inline
-  pushD : TContext d n -> TContext (S d) n
-  pushD tel = map (// shift 1) tel
-
   export %inline
   zeroFor : Context tm n -> QOutput n
   zeroFor ctx = Zero <$ ctx
 
-private
+public export
 extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
 extendLen [<]        x = x
 extendLen (tel :< _) x = [|S $ extendLen tel x|]
@@ -78,32 +113,66 @@ public export
 CtxExtension : Nat -> Nat -> Nat -> Type
 CtxExtension d = Telescope ((Qty, BindName,) . Term d)
 
+public export
+CtxExtension0 : Nat -> Nat -> Nat -> Type
+CtxExtension0 d = Telescope ((BindName,) . Term d)
+
+public export
+CtxExtensionLet : Nat -> Nat -> Nat -> Type
+CtxExtensionLet d = Telescope ((Qty, BindName,) . LocalVar d)
+
+public export
+CtxExtensionLet0 : Nat -> Nat -> Nat -> Type
+CtxExtensionLet0 d = Telescope ((BindName,) . LocalVar d)
+
 namespace TyContext
   public export %inline
   empty : TyContext 0 0
-  empty =
-    MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
+  empty = MkTyContext {
+    dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]
+  }
 
   public export %inline
   null : TyContext d n -> Bool
   null ctx = null ctx.dnames && null ctx.tnames
 
   export %inline
-  extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
-  extendTyN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
-    let (qs, xs, ss) = unzip3 xss in
+  extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2
+  extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
+    let (qs, xs, ls) = unzip3 xss in
     MkTyContext {
       dctx, dnames,
       termLen = extendLen xss termLen,
-      tctx    = tctx . ss,
+      tctx    = tctx . ls,
       tnames  = tnames . xs,
       qtys    = qtys . qs
     }
 
+  export %inline
+  extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
+  extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
+
+  export %inline
+  extendTyLetN0 : CtxExtensionLet0 d n1 n2 -> TyContext d n1 -> TyContext d n2
+  extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
+
+  export %inline
+  extendTyN0 : CtxExtension0 d n1 n2 -> TyContext d n1 -> TyContext d n2
+  extendTyN0 xss = extendTyN (map (Zero,) xss)
+
+  export %inline
+  extendTyLet : Qty -> BindName -> Term d n -> Term d n ->
+                TyContext d n -> TyContext d (S n)
+  extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
+
   export %inline
   extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
   extendTy q x s = extendTyN [< (q, x, s)]
 
+  export %inline
+  extendTy0 : BindName -> Term d n -> TyContext d n -> TyContext d (S n)
+  extendTy0 = extendTy Zero
+
   export %inline
   extendDim : BindName -> TyContext d n -> TyContext (S d) n
   extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
@@ -111,7 +180,7 @@ namespace TyContext
       dctx   = dctx :<? Nothing,
       dnames = dnames :< x,
       dimLen = [|S dimLen|],
-      tctx   = pushD tctx,
+      tctx   = map weakD tctx,
       tnames, qtys
     }
 
@@ -150,7 +219,7 @@ makeEqContext' ctx th = MkEqContext {
   termLen = ctx.termLen,
   dassign = makeDAssign th,
   dnames  = ctx.dnames,
-  tctx    = map (// th) ctx.tctx,
+  tctx    = map (subD th) ctx.tctx,
   tnames  = ctx.tnames,
   qtys    = ctx.qtys
 }
@@ -158,7 +227,7 @@ makeEqContext' ctx th = MkEqContext {
 export
 makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
 makeEqContext ctx@(MkTyContext {dnames, _}) th =
-  let (d' ** Refl) = lengthPrf0 dnames in makeEqContext' ctx th
+  let Val d = lengthPrf0 dnames in makeEqContext' ctx th
 
 namespace EqContext
   public export %inline
@@ -172,21 +241,42 @@ namespace EqContext
   null ctx = null ctx.dnames && null ctx.tnames
 
   export %inline
-  extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
-  extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
-    let (qs, xs, ss) = unzip3 xss in
+  extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2
+  extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
+    let (qs, xs, ls) = unzip3 xss in
     MkEqContext {
       termLen = extendLen xss termLen,
-      tctx    = tctx . ss,
+      tctx    = tctx . ls,
       tnames  = tnames . xs,
       qtys    = qtys . qs,
       dassign, dnames
     }
 
+  export %inline
+  extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
+  extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
+
+  export %inline
+  extendTyLetN0 : CtxExtensionLet0 0 n1 n2 -> EqContext n1 -> EqContext n2
+  extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
+
+  export %inline
+  extendTyN0 : CtxExtension0 0 n1 n2 -> EqContext n1 -> EqContext n2
+  extendTyN0 xss = extendTyN (map (Zero,) xss)
+
+  export %inline
+  extendTyLet : Qty -> BindName -> Term 0 n -> Term 0 n ->
+                EqContext n -> EqContext (S n)
+  extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
+
   export %inline
   extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
   extendTy q x s = extendTyN [< (q, x, s)]
 
+  export %inline
+  extendTy0 : BindName -> Term 0 n -> EqContext n -> EqContext (S n)
+  extendTy0 = extendTy Zero
+
   export %inline
   extendDim : BindName -> DimConst -> EqContext n -> EqContext n
   extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) =
@@ -197,8 +287,8 @@ namespace EqContext
   toTyContext : (e : EqContext n) -> TyContext e.dimLen n
   toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
     MkTyContext {
-      dctx = fromGround dassign,
-      tctx = map (// shift0 dimLen) tctx,
+      dctx = fromGround dnames dassign,
+      tctx = map (subD $ shift0 dimLen) tctx,
       dnames, tnames, qtys
     }
 
@@ -207,18 +297,44 @@ namespace EqContext
   toWhnfContext (MkEqContext {tnames, tctx, _}) =
     MkWhnfContext {dnames = [<], tnames, tctx}
 
+  export
+  injElim : WhnfContext d n -> Elim 0 0 -> Elim d n
+  injElim ctx e =
+    let Val d = ctx.dimLen; Val n = ctx.termLen in
+    e // shift0 d // shift0 n
+
 namespace WhnfContext
   public export %inline
   empty : WhnfContext 0 0
   empty = MkWhnfContext [<] [<] [<]
 
+  export
+  extendTy' : BindName -> LocalVar d n -> WhnfContext d n -> WhnfContext d (S n)
+  extendTy' x var (MkWhnfContext {termLen, dnames, tnames, tctx}) =
+    MkWhnfContext {
+      dnames,
+      termLen = [|S termLen|],
+      tnames  = tnames :< x,
+      tctx    = tctx   :< var
+    }
+
+  export %inline
+  extendTy : BindName -> Term d n -> WhnfContext d n -> WhnfContext d (S n)
+  extendTy x ty ctx = extendTy' x (lamVar ty) ctx
+
+  export %inline
+  extendTyLet : BindName -> (type, term : Term d n) ->
+                WhnfContext d n -> WhnfContext d (S n)
+  extendTyLet x type term ctx = extendTy' x (letVar {type, term}) ctx
+
   export
   extendDimN : {s : Nat} -> BContext s -> WhnfContext d n ->
                WhnfContext (s + d) n
-  extendDimN ns (MkWhnfContext {dnames, tnames, tctx}) =
+  extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) =
     MkWhnfContext {
+      dimLen = [|Val s + dimLen|],
       dnames = dnames ++ toSnocVect' ns,
-      tctx   = dweakT s <$> tctx,
+      tctx   = map (subD $ shift s) tctx,
       tnames
     }
 
@@ -230,14 +346,25 @@ namespace WhnfContext
 private
 prettyTContextElt : {opts : _} ->
                     BContext d -> BContext n ->
-                    Qty -> BindName -> Term d n -> Eff Pretty (Doc opts)
-prettyTContextElt dnames tnames q x s =
-  pure $ hsep [hcat [!(prettyQty q), !dotD, !(prettyTBind x)], !colonD,
-               !(withPrec Outer $ prettyTerm dnames tnames s)]
+                    Doc opts -> BindName -> LocalVar d n ->
+                    Eff Pretty (Doc opts)
+prettyTContextElt dnames tnames q x s = do
+  dot <- dotD
+  x  <- prettyTBind x; colon <- colonD
+  ty <- withPrec Outer $ prettyTerm dnames tnames s.type; eq <- cstD
+  tm <- traverse (withPrec Outer . prettyTerm dnames tnames) s.term
+  d  <- askAt INDENT
+  let qx = hcat [q, dot, x]
+  pure $ case tm of
+    Nothing =>
+      ifMultiline (hsep [qx, colon, ty]) (vsep [qx, indent d $ colon <++> ty])
+    Just tm =>
+      ifMultiline (hsep [qx, colon, ty, eq, tm])
+                  (vsep [qx, indent d $ colon <++> ty, indent d $ eq <++> tm])
 
 private
 prettyTContext' : {opts : _} ->
-                  BContext d -> QContext n -> BContext n ->
+                  BContext d -> Context' (Doc opts) n -> BContext n ->
                   TContext d n -> Eff Pretty (SnocList (Doc opts))
 prettyTContext' _ [<] [<] [<] = pure [<]
 prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
@@ -248,8 +375,11 @@ export
 prettyTContext : {opts : _} ->
                  BContext d -> QContext n -> BContext n ->
                  TContext d n -> Eff Pretty (Doc opts)
-prettyTContext dnames qtys tnames tys =
-  separateTight !commaD <$> prettyTContext' dnames qtys tnames tys
+prettyTContext dnames qtys tnames tys = do
+  comma <- commaD
+  qtys <- traverse prettyQty qtys
+  sepSingle . exceptLast (<+> comma) . toList <$>
+    prettyTContext' dnames qtys tnames tys
 
 export
 prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
@@ -257,9 +387,16 @@ prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
   case dctx of
     C [<] => prettyTContext dnames qtys tnames tctx
     _     => pure $
-      sep [!(prettyDimEq dnames dctx) <++> !pipeD,
-           !(prettyTContext dnames qtys tnames tctx)]
+      sepSingle [!(prettyDimEq dnames dctx) <++> !pipeD,
+                 !(prettyTContext dnames qtys tnames tctx)]
 
 export
 prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts)
 prettyEqContext ctx = prettyTyContext $ toTyContext ctx
+
+export
+prettyWhnfContext : {opts : _} -> WhnfContext d n -> Eff Pretty (Doc opts)
+prettyWhnfContext ctx =
+  let Val n = ctx.termLen in
+  sepSingle . exceptLast (<+> comma) . toList <$>
+    prettyTContext' ctx.dnames (replicate n "_") ctx.tnames ctx.tctx

lib/Quox/Typing/Error.idr

@@ -2,12 +2,19 @@ module Quox.Typing.Error
 
 import Quox.Loc
 import Quox.Syntax
+import Quox.Syntax.Builtin
 import Quox.Typing.Context
 import Quox.Typing.EqMode
 import Quox.Pretty
 
 import Data.List
 import Control.Eff
+import Derive.Prelude
+
+%language ElabReflection
+%hide TT.Name
+
+%default total
 
 
 public export
@@ -15,6 +22,7 @@ record NameContexts d n where
   constructor MkNameContexts
   dnames : BContext d
   tnames : BContext n
+%runElab deriveIndexed "NameContexts" [Show]
 
 namespace NameContexts
   export
@@ -55,17 +63,19 @@ namespace WhnfContext
 
 public export
 data Error
-= ExpectedTYPE Loc (NameContexts d n) (Term d n)
-| ExpectedPi   Loc (NameContexts d n) (Term d n)
-| ExpectedSig  Loc (NameContexts d n) (Term d n)
-| ExpectedEnum Loc (NameContexts d n) (Term d n)
-| ExpectedEq   Loc (NameContexts d n) (Term d n)
-| ExpectedNat  Loc (NameContexts d n) (Term d n)
-| ExpectedBOX  Loc (NameContexts d n) (Term d n)
-| BadUniverse  Loc Universe Universe
-| TagNotIn     Loc TagVal (SortedSet TagVal)
-| BadCaseEnum  Loc (SortedSet TagVal) (SortedSet TagVal)
-| BadQtys      Loc String (TyContext d n) (List (QOutput n, Term d n))
+= ExpectedTYPE    Loc (NameContexts d n) (Term d n)
+| ExpectedPi      Loc (NameContexts d n) (Term d n)
+| ExpectedSig     Loc (NameContexts d n) (Term d n)
+| ExpectedEnum    Loc (NameContexts d n) (Term d n)
+| ExpectedEq      Loc (NameContexts d n) (Term d n)
+| ExpectedNAT     Loc (NameContexts d n) (Term d n)
+| ExpectedSTRING  Loc (NameContexts d n) (Term d n)
+| ExpectedBOX     Loc (NameContexts d n) (Term d n)
+| ExpectedIOState Loc (NameContexts d n) (Term d n)
+| BadUniverse     Loc Universe Universe
+| TagNotIn        Loc TagVal (SortedSet TagVal)
+| BadCaseEnum     Loc (SortedSet TagVal) (SortedSet TagVal)
+| BadQtys         Loc String (TyContext d n) (List (QOutput n, Term d n))
 
 -- first term arg of ClashT is the type
 | ClashT  Loc (EqContext n) EqMode (Term 0 n) (Term 0 n) (Term 0 n)
@@ -78,11 +88,14 @@ data Error
 | NotType Loc (TyContext d n) (Term d n)
 | WrongType Loc (EqContext n) (Term 0 n) (Term 0 n)
 
+| WrongBuiltinType Builtin Error
+| ExpectedSingleEnum Loc (NameContexts d n) (Term d n)
+
 | MissingEnumArm Loc TagVal (List TagVal)
 
 -- extra context
 | WhileChecking
-    (TyContext d n) Qty
+    (TyContext d n) SQty
     (Term d n) -- term
     (Term d n) -- type
     Error
@@ -92,19 +105,20 @@ data Error
     (Maybe Universe)
     Error
 | WhileInferring
-    (TyContext d n) Qty
+    (TyContext d n) SQty
     (Elim d n)
     Error
 | WhileComparingT
-    (EqContext n) EqMode
+    (EqContext n) EqMode SQty
     (Term 0 n) -- type
     (Term 0 n) (Term 0 n) -- lhs/rhs
     Error
 | WhileComparingE
-    (EqContext n) EqMode
+    (EqContext n) EqMode SQty
     (Elim 0 n) (Elim 0 n)
     Error
 %name Error err
+%runElab derive "Error" [Show]
 
 public export
 ErrorEff : Type -> Type
@@ -113,31 +127,35 @@ ErrorEff = Except Error
 
 export
 Located Error where
-  (ExpectedTYPE    loc _ _).loc       = loc
-  (ExpectedPi      loc _ _).loc       = loc
-  (ExpectedSig     loc _ _).loc       = loc
-  (ExpectedEnum    loc _ _).loc       = loc
-  (ExpectedEq      loc _ _).loc       = loc
-  (ExpectedNat     loc _ _).loc       = loc
-  (ExpectedBOX     loc _ _).loc       = loc
-  (BadUniverse     loc _ _).loc       = loc
-  (TagNotIn        loc _ _).loc       = loc
-  (BadCaseEnum     loc _ _).loc       = loc
-  (BadQtys         loc _ _ _).loc     = loc
-  (ClashT          loc _ _ _ _ _).loc = loc
-  (ClashTy         loc _ _ _ _).loc   = loc
-  (ClashE          loc _ _ _ _).loc   = loc
-  (ClashU          loc _ _ _).loc     = loc
-  (ClashQ          loc _ _).loc       = loc
-  (NotInScope      loc _).loc         = loc
-  (NotType         loc _ _).loc       = loc
-  (WrongType       loc _ _ _).loc     = loc
-  (MissingEnumArm  loc _ _).loc       = loc
-  (WhileChecking   _ _ _ _ err).loc   = err.loc
-  (WhileCheckingTy _ _ _ err).loc     = err.loc
-  (WhileInferring  _ _ _ err).loc     = err.loc
-  (WhileComparingT _ _ _ _ _ err).loc = err.loc
-  (WhileComparingE _ _ _ _ err).loc   = err.loc
+  (ExpectedTYPE     loc _ _).loc        = loc
+  (ExpectedPi       loc _ _).loc        = loc
+  (ExpectedSig      loc _ _).loc        = loc
+  (ExpectedEnum     loc _ _).loc        = loc
+  (ExpectedEq       loc _ _).loc        = loc
+  (ExpectedNAT      loc _ _).loc        = loc
+  (ExpectedSTRING   loc _ _).loc        = loc
+  (ExpectedBOX      loc _ _).loc        = loc
+  (ExpectedIOState  loc _ _).loc        = loc
+  (BadUniverse      loc _ _).loc        = loc
+  (TagNotIn         loc _ _).loc        = loc
+  (BadCaseEnum      loc _ _).loc        = loc
+  (BadQtys          loc _ _ _).loc      = loc
+  (ClashT           loc _ _ _ _ _).loc  = loc
+  (ClashTy          loc _ _ _ _).loc    = loc
+  (ClashE           loc _ _ _ _).loc    = loc
+  (ClashU           loc _ _ _).loc      = loc
+  (ClashQ           loc _ _).loc        = loc
+  (NotInScope       loc _).loc          = loc
+  (NotType          loc _ _).loc        = loc
+  (WrongType        loc _ _ _).loc      = loc
+  (WrongBuiltinType _ err).loc          = err.loc
+  (ExpectedSingleEnum loc _ _).loc      = loc
+  (MissingEnumArm   loc _ _).loc        = loc
+  (WhileChecking   _ _ _ _ err).loc     = err.loc
+  (WhileCheckingTy _ _ _ err).loc       = err.loc
+  (WhileInferring  _ _ _ err).loc       = err.loc
+  (WhileComparingT _ _ _ _ _ _ err).loc = err.loc
+  (WhileComparingE _ _ _ _ _ err).loc   = err.loc
 
 
 ||| separates out all the error context layers
@@ -150,10 +168,10 @@ explodeContext (WhileCheckingTy ctx s k err) =
   mapFst (WhileCheckingTy ctx s k ::) $ explodeContext err
 explodeContext (WhileInferring ctx x e err) =
   mapFst (WhileInferring ctx x e ::) $ explodeContext err
-explodeContext (WhileComparingT ctx x s t r err) =
-  mapFst (WhileComparingT ctx x s t r ::) $ explodeContext err
-explodeContext (WhileComparingE ctx x e f err) =
-  mapFst (WhileComparingE ctx x e f ::) $ explodeContext err
+explodeContext (WhileComparingT ctx x sg s t r err) =
+  mapFst (WhileComparingT ctx x sg s t r ::) $ explodeContext err
+explodeContext (WhileComparingE ctx x sg e f err) =
+  mapFst (WhileComparingE ctx x sg e f ::) $ explodeContext err
 explodeContext err = ([], err)
 
 ||| leaves the outermost context layer, and the innermost (up to) n, and removes
@@ -240,160 +258,186 @@ where
      hangDSingle "with quantities" $
       separateTight !commaD $ toSnocList' !(traverse prettyQty qs)]
 
-export
-prettyErrorNoLoc : {opts : _} -> (showContext : Bool) -> Error ->
-                   Eff Pretty (Doc opts)
-prettyErrorNoLoc showContext = \case
-  ExpectedTYPE _ ctx s =>
-    hangDSingle "expected a type universe, but got"
-      !(prettyTerm ctx.dnames ctx.tnames s)
-
-  ExpectedPi _ ctx s =>
-    hangDSingle "expected a function type, but got"
-      !(prettyTerm ctx.dnames ctx.tnames s)
-
-  ExpectedSig _ ctx s =>
-    hangDSingle "expected a pair type, but got"
-      !(prettyTerm ctx.dnames ctx.tnames s)
-
-  ExpectedEnum _ ctx s =>
-    hangDSingle "expected an enumeration type, but got"
-      !(prettyTerm ctx.dnames ctx.tnames s)
-
-  ExpectedEq _ ctx s =>
-    hangDSingle "expected an enumeration type, but got"
-      !(prettyTerm ctx.dnames ctx.tnames s)
-
-  ExpectedNat _ ctx s =>
-    hangDSingle
-      ("expected the type" <++>
-        !(prettyTerm [<] [<] $ Nat noLoc) <+> ", but got")
-      !(prettyTerm ctx.dnames ctx.tnames s)
-
-  ExpectedBOX _ ctx s =>
-    hangDSingle "expected a box type, but got"
-      !(prettyTerm ctx.dnames ctx.tnames s)
-
-  BadUniverse _ k l => pure $
-    sep ["the universe level" <++> !(prettyUniverse k),
-         "is not strictly less than" <++> !(prettyUniverse l)]
-
-  TagNotIn _ tag set =>
-    hangDSingle (hsep ["the tag", !(prettyTag tag), "is not contained in"])
-      !(prettyTerm [<] [<] $ Enum set noLoc)
-
-  BadCaseEnum _ head body => sep <$> sequence
-    [hangDSingle "case expression has head of type"
-       !(prettyTerm [<] [<] $ Enum head noLoc),
-     hangDSingle "but cases for"
-       !(prettyTerm [<] [<] $ Enum body noLoc)]
-
-  BadQtys _ what ctx arms =>
-    hangDSingle (text "inconsistent variable usage in \{what}") $
-      sep !(printCaseQtys ctx ctx.tnames arms)
-
-  ClashT _ ctx mode ty s t =>
-    inEContext ctx . sep =<< sequence
-    [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s),
-     hangDSingle (text "is not \{prettyMode mode}")
-        !(prettyTerm [<] ctx.tnames t),
-     hangDSingle "at type" !(prettyTerm [<] ctx.tnames ty)]
-
-  ClashTy _ ctx mode a b =>
-    inEContext ctx . sep =<< sequence
-    [hangDSingle "the type" !(prettyTerm [<] ctx.tnames a),
-     hangDSingle (text "is not \{prettyMode mode}")
-        !(prettyTerm [<] ctx.tnames b)]
-
-  ClashE _ ctx mode e f =>
-    inEContext ctx . sep =<< sequence
-    [hangDSingle "the term" !(prettyElim [<] ctx.tnames e),
-     hangDSingle (text "is not \{prettyMode mode}")
-        !(prettyElim [<] ctx.tnames f)]
-
-  ClashU _ mode k l => pure $
-    sep ["the universe level" <++> !(prettyUniverse k),
-         text "is not \{prettyModeU mode}" <++> !(prettyUniverse l)]
-
-  ClashQ _ pi rh => pure $
-    sep ["the quantity" <++> !(prettyQty pi),
-         "is not equal to" <++> !(prettyQty rh)]
-
-  NotInScope _ x => pure $
-    hsep [!(prettyFree x), "is not in scope"]
-
-  NotType _ ctx s =>
-    inTContext ctx . sep =<< sequence
-    [hangDSingle "the term" !(prettyTerm ctx.dnames ctx.tnames s),
-     pure "is not a type"]
-
-  WrongType _ ctx ty s =>
-    inEContext ctx . sep =<< sequence
-    [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s),
-     hangDSingle "cannot have type" !(prettyTerm [<] ctx.tnames ty)]
-
-  MissingEnumArm _ tag tags => pure $
-    sep [hsep ["the tag", !(prettyTag tag), "is not contained in"],
-         !(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)]
-
-  WhileChecking ctx pi s a err =>
-    [|vappendBlank
-        (inTContext ctx . sep =<< sequence
-          [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
-           hangDSingle "has type"       !(prettyTerm ctx.dnames ctx.tnames a),
-           hangDSingle "with quantity"  !(prettyQty pi)])
-        (prettyErrorNoLoc showContext err)|]
-
-  WhileCheckingTy ctx a k err =>
-    [|vappendBlank
-        (inTContext ctx . sep =<< sequence
-          [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a),
-           pure $ text $ isTypeInUniverse k])
-        (prettyErrorNoLoc showContext err)|]
-
-  WhileInferring ctx pi e err =>
-    [|vappendBlank
-        (inTContext ctx . sep =<< sequence
-          [hangDSingle "while inferring the type of"
-              !(prettyElim ctx.dnames ctx.tnames e),
-           hangDSingle "with quantity"  !(prettyQty pi)])
-        (prettyErrorNoLoc showContext err)|]
-
-  WhileComparingT ctx mode a s t err =>
-    [|vappendBlank
-        (inEContext ctx . sep =<< sequence
-          [hangDSingle "while checking that" !(prettyTerm [<] ctx.tnames s),
-           hangDSingle (text "is \{prettyMode mode}")
-              !(prettyTerm [<] ctx.tnames t),
-           hangDSingle "at type" !(prettyTerm [<] ctx.tnames a)])
-        (prettyErrorNoLoc showContext err)|]
-
-  WhileComparingE ctx mode e f err =>
-    [|vappendBlank
-        (inEContext ctx . sep =<< sequence
-          [hangDSingle "while checking that" !(prettyElim [<] ctx.tnames e),
-           hangDSingle (text "is \{prettyMode mode}")
-              !(prettyElim [<] ctx.tnames f)])
-        (prettyErrorNoLoc showContext err)|]
-
-where
-  vappendBlank : Doc opts -> Doc opts -> Doc opts
-  vappendBlank a b = flush a `vappend` b
+parameters {opts : LayoutOpts} (showContext : Bool)
+  export
+  inContext' : Bool -> a -> (a -> Eff Pretty (Doc opts)) ->
+               Doc opts -> Eff Pretty (Doc opts)
+  inContext' null ctx f doc =
+    if showContext && not null then
+      vappend doc <$> hangDSingle "in context" !(f ctx)
+    else pure doc
 
+  export %inline
   inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
-  inTContext ctx doc =
-    if showContext && not (null ctx) then
-      pure $ vappend doc (sep ["in context", !(prettyTyContext ctx)])
-    else pure doc
+  inTContext ctx = inContext' (null ctx) ctx prettyTyContext
 
+  export %inline
   inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
-  inEContext ctx doc =
-    if showContext && not (null ctx) then
-      pure $ vappend doc (sep ["in context", !(prettyEqContext ctx)])
-    else pure doc
+  inEContext ctx = inContext' (null ctx) ctx prettyEqContext
 
-export
-prettyError : {opts : _} -> (showContext : Bool) ->
-              Error -> Eff Pretty (Doc opts)
-prettyError showContext err = sep <$> sequence
-  [prettyLoc err.loc, indentD =<< prettyErrorNoLoc showContext err]
+  export
+  prettyErrorNoLoc : Error -> Eff Pretty (Doc opts)
+  prettyErrorNoLoc err0 = case err0 of
+    ExpectedTYPE _ ctx s =>
+      hangDSingle "expected a type universe, but got"
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    ExpectedPi _ ctx s =>
+      hangDSingle "expected a function type, but got"
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    ExpectedSig _ ctx s =>
+      hangDSingle "expected a pair type, but got"
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    ExpectedEnum _ ctx s =>
+      hangDSingle "expected an enumeration type, but got"
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    ExpectedEq _ ctx s =>
+      hangDSingle "expected an equality type, but got"
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    ExpectedNAT _ ctx s =>
+      hangDSingle
+        ("expected the type" <++>
+          !(prettyTerm [<] [<] $ NAT noLoc) <+> ", but got")
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    ExpectedSTRING _ ctx s =>
+      hangDSingle
+        ("expected the type" <++>
+          !(prettyTerm [<] [<] $ STRING noLoc) <+> ", but got")
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    ExpectedBOX _ ctx s =>
+      hangDSingle "expected a box type, but got"
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    ExpectedIOState _ ctx s =>
+      hangDSingle "expected IOState, but got"
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    BadUniverse _ k l => pure $
+      sep ["the universe level" <++> !(prettyUniverse k),
+           "is not strictly less than" <++> !(prettyUniverse l)]
+
+    TagNotIn _ tag set =>
+      hangDSingle (hsep ["the tag", !(prettyTag tag), "is not contained in"])
+        !(prettyTerm [<] [<] $ Enum set noLoc)
+
+    BadCaseEnum _ head body => sep <$> sequence
+      [hangDSingle "case expression has head of type"
+         !(prettyTerm [<] [<] $ Enum head noLoc),
+       hangDSingle "but cases for"
+         !(prettyTerm [<] [<] $ Enum body noLoc)]
+
+    BadQtys _ what ctx arms =>
+      hangDSingle (text "inconsistent variable usage in \{what}") $
+        sep !(printCaseQtys ctx ctx.tnames arms)
+
+    ClashT _ ctx mode ty s t =>
+      inEContext ctx . sep =<< sequence
+      [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s),
+       hangDSingle (text "is not \{prettyMode mode}")
+          !(prettyTerm [<] ctx.tnames t),
+       hangDSingle "at type" !(prettyTerm [<] ctx.tnames ty)]
+
+    ClashTy _ ctx mode a b =>
+      inEContext ctx . sep =<< sequence
+      [hangDSingle "the type" !(prettyTerm [<] ctx.tnames a),
+       hangDSingle (text "is not \{prettyMode mode}")
+          !(prettyTerm [<] ctx.tnames b)]
+
+    ClashE _ ctx mode e f =>
+      inEContext ctx . sep =<< sequence
+      [hangDSingle "the term" !(prettyElim [<] ctx.tnames e),
+       hangDSingle (text "is not \{prettyMode mode}")
+          !(prettyElim [<] ctx.tnames f)]
+
+    ClashU _ mode k l => pure $
+      sep ["the universe level" <++> !(prettyUniverse k),
+           text "is not \{prettyModeU mode}" <++> !(prettyUniverse l)]
+
+    ClashQ _ pi rh => pure $
+      sep ["the quantity" <++> !(prettyQty pi),
+           "is not equal to" <++> !(prettyQty rh)]
+
+    NotInScope _ x => pure $
+      hsep [!(prettyFree x), "is not in scope"]
+
+    NotType _ ctx s =>
+      inTContext ctx . sep =<< sequence
+      [hangDSingle "the term" !(prettyTerm ctx.dnames ctx.tnames s),
+       pure "is not a type"]
+
+    WrongType _ ctx ty s =>
+      inEContext ctx . sep =<< sequence
+      [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s),
+       hangDSingle "cannot have type" !(prettyTerm [<] ctx.tnames ty)]
+
+    WrongBuiltinType b err => pure $
+      vappend
+        (sep [sep ["when checking", text $ builtinDesc b],
+              sep ["has type", !(builtinTypeDoc b)]])
+        !(prettyErrorNoLoc err)
+
+    ExpectedSingleEnum _ ctx s =>
+      hangDSingle "expected an enumeration type with one case, but got"
+        !(prettyTerm ctx.dnames ctx.tnames s)
+
+    MissingEnumArm _ tag tags => pure $
+      sep [hsep ["the tag", !(prettyTag tag), "is not contained in"],
+           !(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)]
+
+    WhileChecking ctx sg s a err =>
+      [|vappendBlank
+          (inTContext ctx . sep =<< sequence
+            [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
+             hangDSingle "has type"       !(prettyTerm ctx.dnames ctx.tnames a),
+             hangDSingle "with quantity"  !(prettyQty sg.qty)])
+          (prettyErrorNoLoc err)|]
+
+    WhileCheckingTy ctx a k err =>
+      [|vappendBlank
+          (inTContext ctx . sep =<< sequence
+            [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a),
+             pure $ text $ isTypeInUniverse k])
+          (prettyErrorNoLoc err)|]
+
+    WhileInferring ctx sg e err =>
+      [|vappendBlank
+          (inTContext ctx . sep =<< sequence
+            [hangDSingle "while inferring the type of"
+                !(prettyElim ctx.dnames ctx.tnames e),
+             hangDSingle "with quantity" !(prettyQty sg.qty)])
+          (prettyErrorNoLoc err)|]
+
+    WhileComparingT ctx mode sg a s t err =>
+      [|vappendBlank
+          (inEContext ctx . sep =<< sequence
+            [hangDSingle "while checking that" !(prettyTerm [<] ctx.tnames s),
+             hangDSingle (text "is \{prettyMode mode}")
+                !(prettyTerm [<] ctx.tnames t),
+             hangDSingle "at type" !(prettyTerm [<] ctx.tnames a),
+             hangDSingle "with quantity" !(prettyQty sg.qty)])
+          (prettyErrorNoLoc err)|]
+
+    WhileComparingE ctx mode sg e f err =>
+      [|vappendBlank
+          (inEContext ctx . sep =<< sequence
+            [hangDSingle "while checking that" !(prettyElim [<] ctx.tnames e),
+             hangDSingle (text "is \{prettyMode mode}")
+                !(prettyElim [<] ctx.tnames f),
+             hangDSingle "with quantity" !(prettyQty sg.qty)])
+          (prettyErrorNoLoc err)|]
+
+  where
+    vappendBlank : Doc opts -> Doc opts -> Doc opts
+    vappendBlank a b = flush a `vappend` b
+
+  export
+  prettyError : Error -> Eff Pretty (Doc opts)
+  prettyError err = hangDSingle
+    !(prettyLoc err.loc)
+    !(indentD =<< prettyErrorNoLoc err)

lib/Quox/Untyped/Erase.idr

@@ -0,0 +1,568 @@
+module Quox.Untyped.Erase
+
+import Quox.Definition as Q
+import Quox.Pretty
+import Quox.Syntax.Term.Base as Q
+import Quox.Syntax.Term.Subst
+import Quox.Typing
+import Quox.Untyped.Syntax as U
+import Quox.Whnf
+
+import Quox.EffExtra
+import Data.List1
+import Data.Singleton
+import Data.SnocVect
+import Language.Reflection
+
+%default total
+%language ElabReflection
+
+%hide TT.Name
+%hide AppView.(.head)
+
+
+public export
+data IsErased = Erased | Kept
+
+public export
+isErased : Qty -> IsErased
+isErased Zero = Erased
+isErased One  = Kept
+isErased Any  = Kept
+
+
+public export
+ErasureContext : Nat -> Nat -> Type
+ErasureContext = TyContext
+
+
+public export
+TypeError : Type
+TypeError = Typing.Error.Error
+%hide Typing.Error.Error
+
+public export
+data Error =
+  CompileTimeOnly (ErasureContext d n) (Q.Term d n)
+| WrapTypeError   TypeError
+| Postulate       Loc Name
+| WhileErasing    Name Q.Definition Error
+| MainIsErased    Loc Name
+%name Error err
+
+private %inline
+notInScope : Loc -> Name -> Error
+notInScope = WrapTypeError .: NotInScope
+
+export
+Located Error where
+  (CompileTimeOnly _ s).loc  = s.loc
+  (WrapTypeError err).loc    = err.loc
+  (Postulate loc _).loc      = loc
+  (WhileErasing _ def e).loc = e.loc `or` def.loc
+  (MainIsErased loc _).loc   = loc
+
+
+parameters {opts : LayoutOpts} (showContext : Bool)
+  export
+  prettyErrorNoLoc : Error -> Eff Pretty (Doc opts)
+  prettyErrorNoLoc (CompileTimeOnly ctx s) =
+    inTContext showContext ctx $
+    sep ["the term", !(prettyTerm ctx.dnames ctx.tnames s),
+         "only exists at compile time"]
+  prettyErrorNoLoc (WrapTypeError err) =
+    prettyErrorNoLoc showContext err
+  prettyErrorNoLoc (Postulate _ x) =
+    pure $ sep [!(prettyFree x), "is a postulate with no definition"]
+  prettyErrorNoLoc (WhileErasing x def err) = pure $
+    vsep [hsep ["while erasing the definition", !(prettyFree x)],
+          !(prettyErrorNoLoc err)]
+  prettyErrorNoLoc (MainIsErased _ x) =
+    pure $ hsep [!(prettyFree x), "is marked #[main] but is erased"]
+
+  export
+  prettyError : Error -> Eff Pretty (Doc opts)
+  prettyError err = sep <$> sequence
+    [prettyLoc err.loc, indentD =<< prettyErrorNoLoc err]
+
+
+public export
+Erase : List (Type -> Type)
+Erase = [Except Error, NameGen, Log]
+
+export
+liftWhnf : Eff Whnf a -> Eff Erase a
+liftWhnf act = lift $ wrapErr WrapTypeError act
+
+export covering
+computeElimType : Q.Definitions -> ErasureContext d n -> SQty ->
+                  Elim d n -> Eff Erase (Term d n)
+computeElimType defs ctx sg e = do
+  let ctx = toWhnfContext ctx
+  liftWhnf $ do
+    Element e _ <- whnf defs ctx sg e
+    computeElimType defs ctx sg e
+
+
+private %macro
+wrapExpect : TTImp ->
+             Elab (Q.Definitions -> TyContext d n -> Loc ->
+                   Term d n -> Eff Erase a)
+wrapExpect f_ = do
+  f <- check `(\x => ~(f_) x)
+  pure $ \defs, ctx, loc, s => liftWhnf $ f defs ctx SZero loc s
+
+
+public export
+record EraseElimResult d n where
+  constructor EraRes
+  type : Lazy (Q.Term d n)
+  term : U.Term n
+
+
+export covering
+eraseTerm' : (defs : Q.Definitions) -> (ctx : ErasureContext d n) ->
+             (ty, tm : Q.Term d n) ->
+             (0 _ : NotRedex defs (toWhnfContext ctx) SZero ty) =>
+             Eff Erase (U.Term n)
+
+-- "Ψ | Γ | Σ ⊢ s ⤋ s' ⇐ A" for `s' <- eraseTerm (Ψ,Γ,Σ) A s`
+--
+-- in the below comments, Ψ, Γ, Σ are implicit and
+-- only their extensions are written
+export covering
+eraseTerm : Q.Definitions -> ErasureContext d n ->
+            (ty, tm : Q.Term d n) -> Eff Erase (U.Term n)
+eraseTerm defs ctx ty tm = do
+  Element ty _ <- liftWhnf $ Interface.whnf defs (toWhnfContext ctx) SZero ty
+  eraseTerm' defs ctx ty tm
+
+
+-- "Ψ | Γ | Σ ⊢ e ⤋ e' ⇒ A" for `EraRes A e' <- eraseElim (Ψ,Γ,Σ) e`
+export covering
+eraseElim : Q.Definitions -> ErasureContext d n -> (tm : Q.Elim d n) ->
+            Eff Erase (EraseElimResult d n)
+
+eraseTerm' defs ctx _ s@(TYPE {}) =
+  throw $ CompileTimeOnly ctx s
+
+eraseTerm' defs ctx _ s@(IOState {}) =
+  throw $ CompileTimeOnly ctx s
+
+eraseTerm' defs ctx _ s@(Pi {}) =
+  throw $ CompileTimeOnly ctx s
+
+--      x : A | 0.x ⊢ s ⤋ s' ⇐ B
+-- -------------------------------------
+--  (λ x ⇒ s) ⤋ s'[⌷/x] ⇐ 0.(x : A) → B
+--
+--    x : A | π.x ⊢ s ⤋ s' ⇐ B   π ≠ 0
+-- ----------------------------------------
+--  (λ x ⇒ s) ⤋ (λ x ⇒ s') ⇐ π.(x : A) → B
+eraseTerm' defs ctx ty (Lam body loc) = do
+  let x = body.name
+  (qty, arg, res) <- wrapExpect `(expectPi) defs ctx loc ty
+  body            <- eraseTerm defs (extendTy qty x arg ctx) res.term body.term
+  pure $ case isErased qty of
+    Kept   => U.Lam x body loc
+    Erased => sub1 (Erased loc) body
+
+eraseTerm' defs ctx _ s@(Sig {}) =
+  throw $ CompileTimeOnly ctx s
+
+--   s ⤋ s' ⇐ A    t ⤋ t' ⇐ B[s/x]
+-- ---------------------------------
+--  (s, t) ⤋ (s', t') ⇐ (x : A) × B
+eraseTerm' defs ctx ty (Pair fst snd loc) = do
+  (a, b) <- wrapExpect `(expectSig) defs ctx loc ty
+  let b = sub1 b (Ann fst a a.loc)
+  fst <- eraseTerm defs ctx a fst
+  snd <- eraseTerm defs ctx b snd
+  pure $ Pair fst snd loc
+
+eraseTerm' defs ctx _ s@(Enum {}) =
+  throw $ CompileTimeOnly ctx s
+
+-- '𝐚 ⤋ '𝐚 ⇐ {⋯}
+eraseTerm' defs ctx _ (Tag tag loc) =
+  pure $ Tag tag loc
+
+eraseTerm' defs ctx ty s@(Eq {}) =
+  throw $ CompileTimeOnly ctx s
+
+--        𝑖 ⊢ s ⤋ s' ⇐ A
+-- ---------------------------------
+--  (δ 𝑖 ⇒ s) ⤋ s' ⇐ Eq (𝑖 ⇒ A) l r
+eraseTerm' defs ctx ty (DLam body loc) = do
+  a <- fst <$> wrapExpect `(expectEq) defs ctx loc ty
+  eraseTerm defs (extendDim body.name ctx) a.term body.term
+
+eraseTerm' defs ctx _ s@(NAT {}) =
+  throw $ CompileTimeOnly ctx s
+
+-- n ⤋ n ⇐ ℕ
+eraseTerm' _ _ _ (Nat n loc) =
+  pure $ Nat n loc
+
+--       s ⤋ s' ⇐ ℕ
+-- -----------------------
+--  succ s ⤋ succ s' ⇐ ℕ
+eraseTerm' defs ctx ty (Succ p loc) = do
+  p <- eraseTerm defs ctx ty p
+  pure $ Succ p loc
+
+eraseTerm' defs ctx ty s@(STRING {}) =
+  throw $ CompileTimeOnly ctx s
+
+-- s ⤋ s ⇐ String
+eraseTerm' _ _ _ (Str s loc) =
+  pure $ Str s loc
+
+eraseTerm' defs ctx ty s@(BOX {}) =
+  throw $ CompileTimeOnly ctx s
+
+-- [s] ⤋ ⌷ ⇐ [0.A]
+--
+--  π ≠ 0   s ⤋ s' ⇐ A
+-- --------------------
+--   [s] ⤋ s' ⇐ [π.A]
+eraseTerm' defs ctx ty (Box val loc) = do
+  (qty, a) <- wrapExpect `(expectBOX) defs ctx loc ty
+  case isErased qty of
+    Erased => pure $ Erased loc
+    Kept   => eraseTerm defs ctx a val
+
+--            s ⤋ s' ⇐ A
+-- ---------------------------------
+--   let0 x = e in s ⤋ s'[⌷/x] ⇐ A
+--
+--        e ⤋ e' ⇒ E   π ≠ 0
+--      x : E ≔ e ⊢ s ⤋ s' ⇐ A
+-- -------------------------------------
+--  letπ x = e in s ⤋ let x = e' in s'
+eraseTerm' defs ctx ty (Let pi e s loc) = do
+  let x = s.name
+  case isErased pi of
+    Erased => do
+      ety <- computeElimType defs ctx SZero e
+      s'  <- eraseTerm defs (extendTyLet pi x ety (E e) ctx) (weakT 1 ty) s.term
+      pure $ sub1 (Erased e.loc) s'
+    Kept => do
+      EraRes ety e' <- eraseElim defs ctx e
+      s' <- eraseTerm defs (extendTyLet pi x ety (E e) ctx) (weakT 1 ty) s.term
+      pure $ Let True x e' s' loc
+
+--  e ⤋ e' ⇒ B
+-- ------------
+--  e ⤋ e' ⇐ A
+eraseTerm' defs ctx ty (E e) =
+  term <$> eraseElim defs ctx e
+
+eraseTerm' defs ctx ty (CloT (Sub term th)) =
+  eraseTerm defs ctx ty $ pushSubstsWith' id th term
+
+eraseTerm' defs ctx ty (DCloT (Sub term th)) =
+  eraseTerm defs ctx ty $ pushSubstsWith' th id term
+
+--  defω x : A = s
+-- ----------------
+--    x ⤋ x ⇒ A
+eraseElim defs ctx e@(F x u loc) = do
+  let Just def = lookup x defs
+    | Nothing => throw $ notInScope loc x
+  case isErased def.qty.qty of
+    Erased => throw $ CompileTimeOnly ctx $ E e
+    Kept   => pure $ EraRes (def.typeWith ctx.dimLen ctx.termLen) $ F x loc
+
+--  π.x ∈ Σ   π ≠ 0
+-- -----------------
+--     x ⤋ x ⇒ A
+eraseElim defs ctx e@(B i loc) = do
+  case isErased $ ctx.qtys !!! i of
+    Erased => throw $ CompileTimeOnly ctx $ E e
+    Kept   => pure $ EraRes (ctx.tctx !! i).type $ B i loc
+
+--  f ⤋ f' ⇒ π.(x : A) → B   s ⤋ s' ⇒ A   π ≠ 0
+-- ---------------------------------------------
+--             f s ⤋ f' s' ⇒ B[s/x]
+--
+--  f ⤋ f' ⇒ 0.(x : A) → B
+-- -------------------------
+--    f s ⤋ f' ⇒ B[s/x]
+eraseElim defs ctx (App fun arg loc) = do
+  efun              <- eraseElim defs ctx fun
+  (qty, targ, tres) <- wrapExpect `(expectPi) defs ctx loc efun.type
+  let ty = sub1 tres (Ann arg targ arg.loc)
+  case isErased qty of
+    Erased => pure $ EraRes ty efun.term
+    Kept   => do arg <- eraseTerm defs ctx targ arg
+                 pure $ EraRes ty $ App efun.term arg loc
+
+--                        e ⇒ (x : A) × B
+--    x : A, y : B | ρ.x, ρ.y ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z]
+-- -------------------------------------------------------------------
+--   (case0 e return z ⇒ R of {(x, y) ⇒ s}) ⤋ s'[⌷/x, ⌷/y] ⇒ R[e/z]
+--
+--                     e ⤋ e' ⇒ (x : A) × B   ρ ≠ 0
+--    x : A, y : B | ρ.x, ρ.y ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z]
+-- ----------------------------------------------------------------------------
+--   (caseρ e return z ⇒ R of {(x, y) ⇒ s}) ⤋
+--     ⤋
+--   let xy = e' in let x = fst xy in let y = snd xy in s' ⇒ R[e/z]
+eraseElim defs ctx (CasePair qty pair ret body loc) = do
+  let [< x, y] = body.names
+  case isErased qty of
+    Kept => do
+      EraRes ety eterm <- eraseElim defs ctx pair
+      let ty = sub1 (ret // shift 2) $
+               Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 ety) loc
+      (tfst, tsnd) <- wrapExpect `(expectSig) defs ctx loc ety
+      let ctx' = extendTyN [< (qty, x, tfst), (qty, y, tsnd.term)] ctx
+      body' <- eraseTerm defs ctx' ty body.term
+      p <- mnb "p" loc
+      pure $ EraRes (sub1 ret pair) $
+        Let False p eterm
+          (Let False x (Fst (B VZ loc) loc)
+            (Let False y (Snd (B (VS VZ) loc) loc)
+              (body' // (B VZ loc ::: B (VS VZ) loc ::: shift 3))
+              loc) loc) loc
+    Erased => do
+      ety <- computeElimType defs ctx SOne pair
+      let ty = sub1 (ret // shift 2) $
+               Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 ety) loc
+      (tfst, tsnd) <- wrapExpect `(expectSig) defs ctx loc ety
+      let ctx' = extendTyN0 [< (x, tfst), (y, tsnd.term)] ctx
+      body' <- eraseTerm defs ctx' ty body.term
+      pure $ EraRes (sub1 ret pair) $ subN [< Erased loc, Erased loc] body'
+
+--  e ⤋ e' ⇒ (x : A) × B
+-- ----------------------
+--   fst e ⤋ fst e' ⇒ A
+eraseElim defs ctx (Fst pair loc) = do
+  epair      <- eraseElim defs ctx pair
+  a          <- fst <$> wrapExpect `(expectSig) defs ctx loc epair.type
+  pure $ EraRes a $ Fst epair.term loc
+
+--     e ⤋ e' ⇒ (x : A) × B
+-- -----------------------------
+--  snd e ⤋ snd e' ⇒ B[fst e/x]
+eraseElim defs ctx (Snd pair loc) = do
+  epair      <- eraseElim defs ctx pair
+  b          <- snd <$> wrapExpect `(expectSig) defs ctx loc epair.type
+  pure $ EraRes (sub1 b (Fst pair loc)) $ Snd epair.term loc
+
+-- caseρ e return z ⇒ R of {} ⤋ absurd ⇒ R[e/z]
+--
+--               s ⤋ s' ⇐ R[𝐚∷{𝐚}/z]
+-- -----------------------------------------------
+--  case0 e return z ⇒ R of {𝐚 ⇒ s} ⤋ s' ⇒ R[e/z]
+--
+--         e ⤋ e' ⇒ A   sᵢ ⤋ s'ᵢ ⇐ R[𝐚ᵢ/z]   ρ ≠ 0   i ≠ 0
+-- -------------------------------------------------------------------
+--  caseρ e return z ⇒ R of {𝐚ᵢ ⇒ sᵢ} ⤋ case e of {𝐚ᵢ ⇒ s'ᵢ} ⇒ R[e/z]
+eraseElim defs ctx e@(CaseEnum qty tag ret arms loc) = do
+  let ty = sub1 ret tag
+  case isErased qty of
+    Erased => case SortedMap.toList arms of
+      []         => pure $ EraRes ty $ Absurd loc
+      [(t, rhs)] => do
+        let ty' = sub1 ret (Ann (Tag t loc) (enum [t] loc) loc)
+        rhs' <- eraseTerm defs ctx ty' rhs
+        pure $ EraRes ty rhs'
+      _ => throw $ CompileTimeOnly ctx $ E e
+    Kept => case List1.fromList $ SortedMap.toList arms of
+      Nothing   => pure $ EraRes ty $ Absurd loc
+      Just arms => do
+        etag <- eraseElim defs ctx tag
+        arms <- for arms $ \(t, rhs) => do
+          let ty' = sub1 ret (Ann (Tag t loc) etag.type loc)
+          rhs' <- eraseTerm defs ctx ty' rhs
+          pure (t, rhs')
+        pure $ EraRes ty $ CaseEnum etag.term arms loc
+
+--        n ⤋ n' ⇒ ℕ   z ⤋ z' ⇐ R[zero∷ℕ/z]   ς ≠ 0
+--  m : ℕ, ih : R[m/z] | ρ.m, ς.ih ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z]
+-- -----------------------------------------------------------
+--      caseρ n return z ⇒ R of {0 ⇒ z; succ m, ς.ih ⇒ s}
+--        ⤋
+--      case n' of {0 ⇒ z'; succ m, ih ⇒ s'} ⇒ R[n/z]
+--
+--             n ⤋ n' ⇒ ℕ   z ⤋ z' ⇐ R[zero∷ℕ/z]
+--  m : ℕ, ih : R[m/z] | ρ.m, 0.ih ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z]
+-- -----------------------------------------------------------
+--      caseρ n return z ⇒ R of {0 ⇒ z; succ m, 0.ih ⇒ s}
+--        ⤋
+--      case n' of {0 ⇒ z'; succ m ⇒ s'[⌷/ih]} ⇒ R[n/z]
+eraseElim defs ctx (CaseNat qty qtyIH nat ret zero succ loc) = do
+  let ty = sub1 ret nat
+  enat <- eraseElim defs ctx nat
+  zero <- eraseTerm defs ctx (sub1 ret (Ann (Zero loc) (NAT loc) loc)) zero
+  let [< p, ih] = succ.names
+  succ' <- eraseTerm defs
+    (extendTyN [< (qty, p, NAT loc),
+                  (qtyIH, ih, sub1 (ret // shift 1) (BV 0 loc))] ctx)
+    (sub1 (ret // shift 2) (Ann (Succ (BVT 1 loc) loc) (NAT loc) loc))
+    succ.term
+  let succ = case isErased qtyIH of
+               Kept   => NSRec    p ih succ'
+               Erased => NSNonrec p    (sub1 (Erased loc) succ')
+  pure $ EraRes ty $ CaseNat enat.term zero succ loc
+
+--  b ⤋ b' ⇒ [π.A]   πρ ≠ 0   x : A | πρ.x ⊢ s ⤋ s' ⇐ R[[x]∷[π.A]/z]
+-- ------------------------------------------------------------------
+--   caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ let x = b' in s' ⇒ R[b/z]
+--
+--   b ⇒ [π.A]   x : A | 0.x ⊢ s ⤋ s' ⇐ R[[x]∷[0.A]/z]   πρ = 0
+-- -------------------------------------------------------------
+--  caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[⌷/x] ⇒ R[b/z]
+eraseElim defs ctx (CaseBox qty box ret body loc) = do
+  tbox <- computeElimType defs ctx SOne box
+  (pi, tinner) <- wrapExpect `(expectBOX) defs ctx loc tbox
+  let ctx' = extendTy (pi * qty) body.name tinner ctx
+      bty  = sub1 (ret // shift 1) $
+             Ann (Box (BVT 0 loc) loc) (weakT 1 tbox) loc
+  case isErased $ qty * pi of
+    Kept => do
+      ebox  <- eraseElim defs ctx box
+      ebody <- eraseTerm defs ctx' bty body.term
+      pure $ EraRes (sub1 ret box) $ Let False body.name ebox.term ebody loc
+    Erased => do
+      body' <- eraseTerm defs ctx' bty body.term
+      pure $ EraRes (sub1 ret box) $ body' // one (Erased loc)
+
+--    f ⤋ f' ⇒ Eq (𝑖 ⇒ A) l r
+-- ------------------------------
+--      f @r ⤋ f' ⇒ A‹r/𝑖›
+eraseElim defs ctx (DApp fun arg loc) = do
+  efun <- eraseElim defs ctx fun
+  a    <- fst <$> wrapExpect `(expectEq) defs ctx loc efun.type
+  pure $ EraRes (dsub1 a arg) efun.term
+
+--    s ⤋ s' ⇐ A
+-- ----------------
+--  s ∷ A ⤋ s' ⇒ A
+eraseElim defs ctx (Ann tm ty loc) =
+  EraRes ty <$> eraseTerm defs ctx ty tm
+
+--        s ⤋ s' ⇐ A‹p/𝑖›
+-- -----------------------------------
+--  coe (𝑖 ⇒ A) @p @q s ⤋ s' ⇒ A‹q/𝑖›
+eraseElim defs ctx (Coe ty p q val loc) = do
+  val <- eraseTerm defs ctx (dsub1 ty p) val
+  pure $ EraRes (dsub1 ty q) val
+
+--          s ⤋ s' ⇐ A
+-- --------------------------------
+--  comp A @p @q s @r {⋯} ⤋ s' ⇒ A
+eraseElim defs ctx (Comp ty p q val r zero one loc) =
+  EraRes ty <$> eraseTerm defs ctx ty val
+
+eraseElim defs ctx t@(TypeCase ty ret arms def loc) =
+  throw $ CompileTimeOnly ctx $ E t
+
+eraseElim defs ctx (CloE (Sub term th)) =
+  eraseElim defs ctx $ pushSubstsWith' id th term
+
+eraseElim defs ctx (DCloE (Sub term th)) =
+  eraseElim defs ctx $ pushSubstsWith' th id term
+
+
+export
+uses : Var n -> Term n -> Nat
+uses i (F {}) = 0
+uses i (B j _) = if i == j then 1 else 0
+uses i (Lam x body _) = uses (VS i) body
+uses i (App fun arg _) = uses i fun + uses i arg
+uses i (Pair fst snd _) = uses i fst + uses i snd
+uses i (Fst pair _) = uses i pair
+uses i (Snd pair _) = uses i pair
+uses i (Tag tag _) = 0
+uses i (CaseEnum tag cases _) =
+  uses i tag + foldl max 0 (map (assert_total uses i . snd) cases)
+uses i (Absurd {}) = 0
+uses i (Nat {}) = 0
+uses i (Succ nat _) = uses i nat
+uses i (CaseNat nat zer suc _) = uses i nat + max (uses i zer) (uses' suc)
+  where uses' : CaseNatSuc n -> Nat
+        uses' (NSRec  _ _ s) = uses (VS (VS i)) s
+        uses' (NSNonrec _ s) = uses (VS i) s
+uses i (Str {}) = 0
+uses i (Let _ x rhs body _) = uses i rhs + uses (VS i) body
+uses i (Erased {}) = 0
+
+export
+inlineable : U.Term n -> Bool
+inlineable (F {})      = True
+inlineable (B {})      = True
+inlineable (Tag {})    = True
+inlineable (Nat {})    = True
+inlineable (Str {})    = True
+inlineable (Absurd {}) = True
+inlineable (Erased {}) = True
+inlineable _           = False
+
+export
+droppable : U.Term n -> Bool
+droppable (F {})      = True
+droppable (B {})      = True
+droppable (Fst e _)   = droppable e
+droppable (Snd e _)   = droppable e
+droppable (Tag {})    = True
+droppable (Nat {})    = True
+droppable (Str {})    = True
+droppable (Absurd {}) = True
+droppable (Erased {}) = True
+droppable _           = False
+
+export
+trimLets : U.Term n -> U.Term n
+trimLets (F x loc) = F x loc
+trimLets (B i loc) = B i loc
+trimLets (Lam x body loc) = Lam x (trimLets body) loc
+trimLets (App fun arg loc) = App (trimLets fun) (trimLets arg) loc
+trimLets (Pair fst snd loc) = Pair (trimLets fst) (trimLets snd) loc
+trimLets (Fst pair loc) = Fst (trimLets pair) loc
+trimLets (Snd pair loc) = Snd (trimLets pair) loc
+trimLets (Tag tag loc) = Tag tag loc
+trimLets (CaseEnum tag cases loc) =
+  let tag   = trimLets tag
+      cases = map (map $ \c => trimLets $ assert_smaller cases c) cases in
+  if droppable tag && length cases == 1
+     then snd cases.head
+     else CaseEnum tag cases loc
+trimLets (Absurd loc) = Absurd loc
+trimLets (Nat n loc) = Nat n loc
+trimLets (Succ nat loc) = Succ (trimLets nat) loc
+trimLets (CaseNat nat zer suc loc) =
+  CaseNat (trimLets nat) (trimLets zer) (trimLets' suc) loc
+  where trimLets' : CaseNatSuc n -> CaseNatSuc n
+        trimLets' (NSRec x ih s) = NSRec    x ih $ trimLets s
+        trimLets' (NSNonrec x s) = NSNonrec x    $ trimLets s
+trimLets (Str s loc) = Str s loc
+trimLets (Let True x rhs body loc) =
+  Let True x (trimLets rhs) (trimLets body) loc
+trimLets (Let False x rhs body loc) =
+  let rhs'  = trimLets rhs
+      body' = trimLets body
+      uses  = uses VZ body in
+  if inlineable rhs' || uses == 1 || (droppable rhs' && uses == 0)
+     then sub1 rhs' body'
+     else Let False x rhs' body' loc
+trimLets (Erased loc) = Erased loc
+
+
+export covering
+eraseDef : Q.Definitions -> Name -> Q.Definition -> Eff Erase U.Definition
+eraseDef defs name def@(MkDef qty type body scheme isMain loc) =
+  wrapErr (WhileErasing name def) $
+  case isErased qty.qty of
+    Erased => do
+      when isMain $ throw $ MainIsErased loc name
+      pure ErasedDef
+    Kept   =>
+      case scheme of
+        Just str => pure $ SchemeDef isMain str
+        Nothing  => case body of
+          Postulate     => throw $ Postulate loc name
+          Concrete body => KeptDef isMain . trimLets <$>
+                           eraseTerm defs empty type body

lib/Quox/Untyped/Scheme.idr

@@ -0,0 +1,378 @@
+module Quox.Untyped.Scheme
+
+import Quox.Name
+import Quox.Context
+import Quox.Untyped.Syntax
+import Quox.Pretty
+
+import Quox.EffExtra
+import Quox.CharExtra
+import Quox.NatExtra
+import Data.DPair
+import Data.List1
+import Data.String
+import Data.SortedSet
+import Data.Vect
+import Derive.Prelude
+
+%default total
+%language ElabReflection
+
+%hide TT.Name
+
+
+
+export
+isSchemeInitial : Char -> Bool
+isSchemeInitial c =
+  let gc = genCat c in
+  isLetter gc || isSymbol gc && c /= '|' ||
+  gc == Number Letter ||
+  gc == Number Other ||
+  gc == Mark NonSpacing ||
+  gc == Punctuation Dash ||
+  gc == Punctuation Connector ||
+  gc == Punctuation Other && c /= '\'' && c /= '\\' ||
+  gc == Other PrivateUse ||
+  (c `elem` unpack "!$%&*/:<=>?~_^")
+
+export
+isSchemeSubsequent : Char -> Bool
+isSchemeSubsequent c =
+  let gc = genCat c in
+  isSchemeInitial c ||
+  isNumber gc ||
+  isMark gc ||
+  (c `elem` unpack ".+-@")
+
+export
+isSchemeId : String -> Bool
+isSchemeId str =
+  str == "1+" || str == "1-" ||
+  case unpack str of
+    []      => False
+    c :: cs => isSchemeInitial c && all isSchemeSubsequent cs
+
+export
+escId : String -> String
+escId str =
+  let str' = concatMap doEsc $ unpack str in
+  if isSchemeId str' then str' else "|\{str}|"
+where
+  doEsc : Char -> String
+  doEsc '\\' = "\\\\"
+  doEsc '|'  = "\\|"
+  doEsc '\'' = "^"
+  doEsc c    = singleton c
+
+
+public export
+data Id = I String Nat
+%runElab derive "Id" [Eq, Ord]
+
+export
+prettyId' : {opts : LayoutOpts} -> Id -> Doc opts
+prettyId' (I str 0) = text $ escId str
+prettyId' (I str k) = text $ escId "\{str}:\{show k}"
+
+export
+prettyId : {opts : LayoutOpts} -> Id -> Eff Pretty (Doc opts)
+prettyId x = hl TVar $ prettyId' x
+
+
+public export
+data StateTag = AVOID | MAIN
+
+public export
+Scheme : List (Type -> Type)
+Scheme = [StateL AVOID (SortedSet Id), StateL MAIN (List Id)]
+  -- names to avoid, and functions with #[main] (should only be one)
+
+
+public export
+data Sexp =
+  V Id
+| L (List Sexp)
+| Q Sexp
+| N Nat
+| S String
+| Lambda (List Id) Sexp
+| LambdaC (List Id) Sexp -- curried lambda
+| Let Id Sexp Sexp
+| Case Sexp (List1 (List Sexp, Sexp))
+| Define Id Sexp
+| Literal String
+
+export
+FromString Sexp where fromString s = V $ I s 0
+
+
+private
+makeIdBase : Mods -> String -> String
+makeIdBase mods str = joinBy "." $ toList $ mods :< str
+
+export
+makeId : Name -> Id
+makeId (MkName mods (UN str))   = I (makeIdBase mods str) 0
+makeId (MkName mods (MN str k)) = I (makeIdBase mods str) 0
+makeId (MkName mods Unused)     = I (makeIdBase mods "_") 0
+
+export
+makeIdB : BindName -> Id
+makeIdB (BN name _) = makeId $ MkName [<] name
+
+private
+bump : Id -> Id
+bump (I x i) = I x (S i)
+
+export covering
+getFresh : SortedSet Id -> Id -> Id
+getFresh used x =
+  if contains x used then getFresh used (bump x) else x
+
+export covering
+freshIn : Id -> (Id -> Eff Scheme a) -> Eff Scheme a
+freshIn x k =
+  let x = getFresh !(getAt AVOID) x in
+  localAt AVOID (insert x) $ k x
+
+export covering
+freshInB : BindName -> (Id -> Eff Scheme a) -> Eff Scheme a
+freshInB x = freshIn (makeIdB x)
+
+export covering
+freshInBT : Telescope' BindName m n ->
+            (Telescope' Id m n -> Eff Scheme a) ->
+            Eff Scheme a
+freshInBT xs act = do
+  let (xs', used') = go (map makeIdB xs) !(getAt AVOID)
+  localAt_ AVOID used' $ act xs'
+where
+  go : forall n. Telescope' Id m n ->
+       SortedSet Id -> (Telescope' Id m n, SortedSet Id)
+  go [<]       used = ([<], used)
+  go (xs :< x) used =
+    let x          = getFresh used x
+        (xs, used) = go xs (insert x used)
+    in
+    (xs :< x, used)
+
+export covering
+freshInBC : Context' BindName n -> (Context' Id n -> Eff Scheme a) ->
+            Eff Scheme a
+freshInBC = freshInBT
+
+export covering
+toScheme : Context' Id n -> Term n -> Eff Scheme Sexp
+toScheme xs (F x _) = pure $ V $ makeId x
+
+toScheme xs (B i _) = pure $ V $ xs !!! i
+
+toScheme xs (Lam x body _) =
+  let Evidence n' (ys, body) = splitLam [< x] body in
+  freshInBT ys $ \ys => do
+    pure $ LambdaC (toList' ys) !(toScheme (xs . ys) body)
+
+toScheme xs (App fun arg _) = do
+  let (fun, args) = splitApp fun
+  fun  <- toScheme xs fun
+  args <- traverse (toScheme xs) args
+  arg  <- toScheme xs arg
+  pure $ if null args
+            then L [fun, arg]
+            else L $ "%" :: fun :: toList (args :< arg)
+
+toScheme xs (Pair fst snd _) =
+  pure $ L ["cons", !(toScheme xs fst), !(toScheme xs snd)]
+
+toScheme xs (Fst pair _) =
+  pure $ L ["car", !(toScheme xs pair)]
+
+toScheme xs (Snd pair _) =
+  pure $ L ["cdr", !(toScheme xs pair)]
+
+toScheme xs (Tag tag _) =
+  pure $ Q $ fromString tag
+
+toScheme xs (CaseEnum tag cases _) =
+  Case <$> toScheme xs tag
+       <*> for cases (\(t, rhs) => ([fromString t],) <$> toScheme xs rhs)
+
+toScheme xs (Absurd _) =
+  pure $ Q "absurd"
+
+toScheme xs (Nat n _) =
+  pure $ N n
+
+toScheme xs (Succ nat _) =
+  pure $ L ["+", !(toScheme xs nat), N 1]
+
+toScheme xs (CaseNat nat zer (NSRec p ih suc) _) =
+  freshInBC [< p, ih] $ \[< p, ih] =>
+  pure $
+    L ["case-nat-rec",
+       Lambda []      !(toScheme xs zer),
+       Lambda [p, ih] !(toScheme (xs :< p :< ih) suc),
+       !(toScheme xs nat)]
+
+toScheme xs (Str s _) = pure $ S s
+
+toScheme xs (CaseNat nat zer (NSNonrec p suc) _) =
+  freshInB p $ \p =>
+  pure $
+    L ["case-nat-nonrec",
+       Lambda []  !(toScheme xs zer),
+       Lambda [p] !(toScheme (xs :< p) suc),
+       !(toScheme xs nat)]
+
+toScheme xs (Let _ x rhs body _) =
+  freshInB x $ \x =>
+  pure $ Let x !(toScheme xs rhs) !(toScheme (xs :< x) body)
+
+toScheme xs (Erased _) =
+  pure $ Q "erased"
+
+
+export
+prelude : String
+prelude = """
+#!r6rs
+(import (rnrs))
+
+; curried lambda
+(define-syntax lambda%
+  (syntax-rules ()
+    [(_ (x . xs) . body) (lambda (x) (lambda% xs . body))]
+    [(_ ()       . body) (begin . body)]))
+
+; curried application
+(define-syntax %
+  (syntax-rules ()
+    [(_ e0 e1 . es) (% (e0 e1) . es)]
+    [(_ e) e]))
+
+; curried function definition
+(define-syntax define%
+  (syntax-rules ()
+    [(_ (f . xs) . body) (define f (lambda% xs . body))]
+    [(_ f        . body) (define f . body)]))
+
+(define-syntax builtin-io
+  (syntax-rules ()
+    [(_ . body) (lambda (s) (cons (begin . body) s))]))
+
+(define (case-nat-rec z s n)
+  (do [(i 0 (+ i 1)) (acc (z) (s i acc))]
+      [(= i n) acc]))
+
+(define (case-nat-nonrec z s n)
+  (if (= n 0) (z) (s (- n 1))))
+
+(define (run-main f) (f 'io-state))
+"""
+
+export
+escape : String -> String
+escape = foldMap esc1 . unpack where
+  esc1 : Char -> String
+  esc1 c =
+    if c == '\\' || c == '"' then
+      "\\" ++ singleton c
+    else if c < ' ' || c > '~' then
+      "\\x" ++ showHex (ord c) ++ ";"
+    else singleton c
+
+export covering
+defToScheme : Name -> Definition -> Eff Scheme (Maybe Sexp)
+defToScheme x ErasedDef = pure Nothing
+defToScheme x (KeptDef isMain def) = do
+  let x = makeId x
+  when isMain $ modifyAt MAIN (x ::)
+  modifyAt AVOID $ insert x
+  pure $ Just $ Define x !(toScheme [<] def)
+defToScheme x (SchemeDef isMain str) = do
+  let x = makeId x
+  when isMain $ modifyAt MAIN (x ::)
+  modifyAt AVOID $ insert x
+  pure $ Just $ Define x $ Literal str
+
+orIndent : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
+orIndent a b = do
+  one <- parens $ a <++> b
+  two <- parens $ a `vappend` indent 2 b
+  pure $ ifMultiline one two
+
+export covering
+prettySexp : {opts : LayoutOpts} -> Sexp -> Eff Pretty (Doc opts)
+
+private covering
+prettyLambda : {opts : LayoutOpts} ->
+               String -> List Id -> Sexp -> Eff Pretty (Doc opts)
+prettyLambda lam xs e =
+  orIndent
+    (hsep [!(hl Syntax $ text lam), !(prettySexp $ L $ map V xs)])
+    !(prettySexp e)
+
+private covering
+prettyBind : {opts : LayoutOpts} -> (Id, Sexp) -> Eff Pretty (Doc opts)
+prettyBind (x, e) = parens $ sep [!(prettyId x), !(prettySexp e)]
+
+private covering
+prettyLet : {opts : LayoutOpts} ->
+            SnocList (Id, Sexp) -> Sexp -> Eff Pretty (Doc opts)
+prettyLet ps (Let x rhs body) = prettyLet (ps :< (x, rhs)) body
+prettyLet ps e =
+  orIndent
+    (hsep [!(hl Syntax "let*"),
+           !(bracks . vsep . toList =<< traverse prettyBind ps)])
+    !(prettySexp e)
+
+private covering
+prettyDefine : {opts : LayoutOpts} ->
+               String -> Either Id (List Id) -> Sexp -> Eff Pretty (Doc opts)
+prettyDefine def xs body =
+  parens $ vappend
+    (hsep [!(hl Syntax $ text def),
+           !(either prettyId (prettySexp . L . map V) xs)])
+    (indent 2 !(prettySexp body))
+
+prettySexp (V x) = prettyId x
+prettySexp (L []) = hl Delim "()"
+prettySexp (L (x :: xs)) = do
+  d  <- prettySexp x
+  ds <- traverse prettySexp xs
+  parens $ ifMultiline
+    (hsep $ d :: ds)
+    (hsep [d, vsep ds] <|> vsep (d :: map (indent 2) ds))
+prettySexp (Q (V x)) = hl Constant $ "'" <+> prettyId' x
+prettySexp (Q x) = pure $ hcat [!(hl Constant "'"), !(prettySexp x)]
+prettySexp (N n) = hl Constant $ pshow n
+prettySexp (S s) = prettyStrLit $ escape s
+prettySexp (Lambda xs e) = prettyLambda "lambda" xs e
+prettySexp (LambdaC xs e) = prettyLambda "lambda%" xs e
+prettySexp (Let x rhs e) = prettyLet [< (x, rhs)] e
+prettySexp (Case h as) = do
+  header' <- prettySexp h
+  case_   <- caseD
+  let header = ifMultiline (case_ <++> header')
+                           (case_ `vappend` indent 2 header')
+  arms <- traverse prettyCase $ toList as
+  pure $ ifMultiline
+    (parens $ header <++> hsep arms)
+    (parens $ vsep $ header :: map (indent 2) arms)
+where
+  prettyCase : (List Sexp, Sexp) -> Eff Pretty (Doc opts)
+  prettyCase (ps, e) = bracks $
+    ifMultiline
+      (hsep [!(parens . hsep =<< traverse prettySexp ps), !(prettySexp e)])
+      (vsep [!(parens .  sep =<< traverse prettySexp ps), !(prettySexp e)])
+prettySexp (Define x e) = case e of
+  LambdaC xs e => prettyDefine "define%" (Right $ x :: xs) e
+  Lambda  xs e => prettyDefine "define"  (Right $ x :: xs) e
+  _            => prettyDefine "define"  (Left x)          e
+prettySexp (Literal sexp) =
+  pure $ text sexp
+
+export covering
+makeRunMain : {opts : LayoutOpts} -> Id -> Eff Pretty (Doc opts)
+makeRunMain x = prettySexp $ L ["run-main", V x]

lib/Quox/Untyped/Syntax.idr

@@ -0,0 +1,308 @@
+module Quox.Untyped.Syntax
+
+import Quox.Var
+import Quox.Context
+import Quox.Name
+import Quox.Pretty
+import Quox.Syntax.Subst
+
+import Data.Vect
+import Data.DPair
+import Data.SortedMap
+import Data.SnocVect
+import Derive.Prelude
+%hide TT.Name
+
+%default total
+%language ElabReflection
+
+
+public export
+data Term : Nat -> Type
+
+public export
+data CaseNatSuc : Nat -> Type
+
+data Term where
+  F : (x : Name) -> Loc -> Term n
+  B : (i : Var n) -> Loc -> Term n
+
+  Lam : (x : BindName) -> (body : Term (S n)) -> Loc -> Term n
+  App : (fun, arg : Term n) -> Loc -> Term n
+
+  Pair : (fst, snd : Term n) -> Loc -> Term n
+  Fst : (pair : Term n) -> Loc -> Term n
+  Snd : (pair : Term n) -> Loc -> Term n
+
+  Tag : (tag : String) -> Loc -> Term n
+  CaseEnum : (tag : Term n) -> (cases : List1 (String, Term n)) -> Loc -> Term n
+  ||| empty match
+  Absurd : Loc -> Term n
+
+  Nat : (val : Nat) -> Loc -> Term n
+  Succ : (nat : Term n) -> Loc -> Term n
+  CaseNat : (nat : Term n) -> (zer : Term n) -> (suc : CaseNatSuc n) ->
+            Loc -> Term n
+
+  Str : (str : String) -> Loc -> Term n
+
+  ||| bool is true if the let comes from the original source code
+  Let : (real : Bool) -> (x : BindName) -> (rhs : Term n) ->
+        (body : Term (S n)) -> Loc -> Term n
+
+  Erased : Loc -> Term n
+%name Term s, t, u
+
+data CaseNatSuc where
+  NSRec    : (x, ih : BindName) -> Term (2 + n) -> CaseNatSuc n
+  NSNonrec : (x     : BindName) -> Term (S n)   -> CaseNatSuc n
+%name CaseNatSuc suc
+
+%runElab deriveParam $
+  map (\ty => PI ty allIndices [Eq, Ord, Show]) ["Term", "CaseNatSuc"]
+
+
+export
+Located (Term n) where
+  (F _ loc).loc           = loc
+  (B _ loc).loc           = loc
+  (Lam _ _ loc).loc       = loc
+  (App _ _ loc).loc       = loc
+  (Pair _ _ loc).loc      = loc
+  (Fst _ loc).loc         = loc
+  (Snd _ loc).loc         = loc
+  (Tag _ loc).loc         = loc
+  (CaseEnum _ _ loc).loc  = loc
+  (Absurd loc).loc        = loc
+  (Nat _ loc).loc         = loc
+  (Succ _ loc).loc        = loc
+  (CaseNat _ _ _ loc).loc = loc
+  (Str _ loc).loc         = loc
+  (Let _ _ _ _ loc).loc   = loc
+  (Erased loc).loc        = loc
+
+
+public export
+data Definition =
+  ErasedDef
+| KeptDef   Bool (Term 0)
+| SchemeDef Bool String
+  -- bools are presence of #[main] flag
+
+public export
+0 Definitions : Type
+Definitions = SortedMap Name Definition
+
+public export
+0 NDefinition : Type
+NDefinition = (Name, Definition)
+
+
+export covering
+prettyTerm : {opts : LayoutOpts} -> BContext n ->
+             Term n -> Eff Pretty (Doc opts)
+
+export covering
+prettyArg : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts)
+prettyArg xs arg = withPrec Arg $ prettyTerm xs arg
+
+export covering
+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 covering %inline
+prettyApp : {opts : LayoutOpts} -> BContext n ->
+            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
+  constructor MkPrettyCaseArm
+  lhs : a
+  {len : Nat}
+  vars : Vect len BindName
+  rhs : Term (len + n)
+
+export covering
+prettyCase : {opts : LayoutOpts} -> BContext n ->
+             (a -> Eff Pretty (Doc opts)) ->
+             Term n -> List (PrettyCaseArm a n) ->
+             Eff Pretty (Doc opts)
+prettyCase xs f head arms =
+  parensIfM Outer =<< do
+    header <- hsep <$> sequence [caseD, prettyTerm xs head, ofD]
+    cases  <- for arms $ \(MkPrettyCaseArm lhs ys rhs) => do
+      lhs <- hsep <$> sequence [f lhs, darrowD]
+      rhs <- withPrec Outer $ prettyTerm (xs <>< ys) rhs
+      hangDSingle lhs rhs
+    lb <- hl Delim "{"; sc <- semiD; rb <- hl Delim "}"; d <- askAt INDENT
+    pure $ ifMultiline
+      (hsep [header, lb, separateTight sc cases, rb])
+      (vsep [hsep [header, lb], indent d $ vsep (map (<+> sc) cases), rb])
+
+private
+sucPat : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
+sucPat x = pure $ !succD <++> !(prettyTBind x)
+
+export
+splitApp : Term n -> (Term n, SnocList (Term n))
+splitApp (App f x _) = mapSnd (:< x) $ splitApp f
+splitApp f           = (f, [<])
+
+export
+splitPair : Term n -> List (Term n)
+splitPair (Pair s t _) = s :: splitPair t
+splitPair t            = [t]
+
+export
+splitLam : Telescope' BindName a b -> Term b ->
+           Exists $ \c => (Telescope' BindName a c, Term c)
+splitLam ys (Lam x body _) = splitLam (ys :< x) body
+splitLam ys t              = Evidence _ (ys, t)
+
+export
+splitLet : Telescope (\i => (BindName, Term i)) a b -> Term b ->
+           Exists $ \c => (Telescope (\i => (BindName, Term i)) a c, Term c)
+splitLet ys (Let _ x rhs body _) = splitLet (ys :< (x, rhs)) body
+splitLet ys t                    = Evidence _ (ys, t)
+
+private covering
+prettyLets : {opts : LayoutOpts} ->
+             BContext a -> Telescope (\i => (BindName, Term i)) a b ->
+             Eff Pretty (SnocList (Doc opts))
+prettyLets xs lets = sequence $ snd $ go lets where
+  go : forall b. Telescope (\i => (BindName, Term i)) a b ->
+       (BContext b, SnocList (Eff Pretty (Doc opts)))
+  go [<]                = (xs, [<])
+  go (lets :< (x, rhs)) =
+    let (ys, docs) = go lets
+        doc = do
+          x   <- prettyTBind x
+          rhs <- withPrec Outer $ prettyTerm ys rhs
+          hangDSingle (hsep [!letD, x, !cstD]) (hsep [rhs, !inD]) in
+    (ys :< x, docs :< doc)
+
+private
+sucCaseArm : {opts : LayoutOpts} ->
+             CaseNatSuc n -> Eff Pretty (PrettyCaseArm (Doc opts) n)
+sucCaseArm (NSRec x ih s) = pure $
+  MkPrettyCaseArm (!(sucPat x) <+> !commaD <++> !(prettyTBind ih)) [x, ih] s
+sucCaseArm (NSNonrec x s) = pure $
+  MkPrettyCaseArm !(sucPat x) [x] s
+
+prettyTerm _  (F x _) = prettyFree x
+prettyTerm xs (B i _) = prettyTBind $ xs !!! i
+prettyTerm xs (Lam x body _) =
+  parensIfM Outer =<< do
+    let Evidence n' (ys, body) = splitLam [< 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 _) = 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 (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 (CaseNat nat zer suc _) =
+  prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)]
+prettyTerm xs (Str s _) =
+  prettyStrLit s
+prettyTerm xs (Let _ x rhs body _) =
+  parensIfM Outer =<< do
+    let Evidence n' (lets, body) = splitLet [< (x, rhs)] body
+    heads <- prettyLets xs lets
+    body  <- withPrec Outer $ prettyTerm (xs . map fst lets) body
+    let lines = toList $ heads :< body
+    pure $ ifMultiline (hsep lines) (vsep lines)
+prettyTerm _ (Erased _) =
+  hl Syntax =<< ifUnicode "□" "[]"
+
+export covering
+prettyDef : {opts : LayoutOpts} -> Name ->
+            Definition -> Eff Pretty (Doc opts)
+prettyDef name ErasedDef =
+  pure $ hsep [!(prettyFree name), !cstD, !(prettyTerm [<] $ Erased noLoc)]
+prettyDef name (KeptDef isMain rhs) = do
+  name <- prettyFree name {opts}
+  eq   <- cstD
+  rhs  <- withPrec Outer $ prettyTerm [<] rhs
+  let header = if isMain then text "#[main]" <++> name else name
+  hangDSingle (header <++> eq) rhs
+prettyDef name (SchemeDef isMain str) = do
+  name <- prettyFree name {opts}
+  eq   <- cstD
+  let rhs = text $ "scheme:" ++ str
+  let header = if isMain then text "#[main]" <++> name else name
+  hangDSingle (header <++> eq) rhs
+
+
+public export
+USubst : Nat -> Nat -> Type
+USubst = Subst Term
+
+
+public export FromVar Term where fromVarLoc = B
+
+
+public export
+CanSubstSelf Term where
+  s // th = case s of
+    F x loc =>
+      F x loc
+    B i loc =>
+      getLoc th i loc
+    Lam x body loc =>
+      Lam x (assert_total $ body // push x.loc th) loc
+    App fun arg loc =>
+      App (fun // th) (arg // th) loc
+    Pair fst snd loc =>
+      Pair (fst // th) (snd // th) loc
+    Fst pair loc =>
+      Fst (pair // th) loc
+    Snd pair loc =>
+      Snd (pair // th) loc
+    Tag tag loc =>
+      Tag tag loc
+    CaseEnum tag cases loc =>
+      CaseEnum (tag // th) (map (assert_total mapSnd (// th)) cases) loc
+    Absurd loc =>
+      Absurd loc
+    Nat n loc =>
+      Nat n loc
+    Succ nat loc =>
+      Succ (nat // th) loc
+    CaseNat nat zer suc loc =>
+      CaseNat (nat // th) (zer // th) (assert_total substSuc suc th) loc
+    Str s loc =>
+      Str s loc
+    Let u x rhs body loc =>
+      Let u x (rhs // th) (assert_total $ body // push x.loc th) loc
+    Erased loc =>
+      Erased loc
+  where
+    substSuc : forall from, to.
+               CaseNatSuc from -> USubst from to -> CaseNatSuc to
+    substSuc (NSRec    x ih t) th = NSRec    x ih $ t // pushN 2 x.loc th
+    substSuc (NSNonrec x    t) th = NSNonrec x    $ t // push    x.loc th
+
+public export
+subN : SnocVect s (Term n) -> Term (s + n) -> Term n
+subN th t = t // fromSnocVect th
+
+public export
+sub1 : Term n -> Term (S n) -> Term n
+sub1 e = subN [< e]

lib/Quox/Var.idr

@@ -1,4 +1,4 @@
-module Quox.Syntax.Var
+module Quox.Var
 
 import public Quox.Loc
 import public Quox.Name
@@ -141,9 +141,6 @@ weakIsSpec p i = toNatInj $ trans (weakCorrect p i) (sym $ weakSpecCorrect p i)
 public export
 interface FromVar f where %inline fromVarLoc : Var n -> Loc -> f n
 
-public export %inline
-fromVar : FromVar f => Var n -> {default noLoc loc : Loc} -> f n
-fromVar x = fromVarLoc x loc
 
 public export FromVar Var where fromVarLoc x _ = x
 

lib/Quox/Whnf.idr

@@ -0,0 +1,5 @@
+module Quox.Whnf
+
+import public Quox.Whnf.Interface       as Quox.Whnf
+import public Quox.Whnf.ComputeElimType as Quox.Whnf
+import public Quox.Whnf.Main            as Quox.Whnf

lib/Quox/Whnf/Coercion.idr

@@ -0,0 +1,252 @@
+module Quox.Whnf.Coercion
+
+import Quox.Whnf.Interface
+import Quox.Whnf.ComputeElimType
+import Quox.Whnf.TypeCase
+
+%default total
+
+
+
+private
+coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc ->
+            ScopeTermN s d n -> ScopeTermN s d n
+coeScoped ty p q loc (S names (N body)) =
+  S names $ N $ E $ Coe ty p q body loc
+coeScoped ty p q loc (S names (Y body)) =
+  ST names $ E $ Coe (weakDS s ty) p q body loc
+where
+  weakDS : (by : Nat) -> DScopeTerm d n -> DScopeTerm d (by + n)
+  weakDS by (S names (Y body)) = S names $ Y $ weakT by body
+  weakDS by (S names (N body)) = S names $ N $ weakT by body
+
+
+parameters {auto _ : CanWhnf Term Interface.isRedexT}
+           {auto _ : CanWhnf Elim Interface.isRedexE}
+           (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty)
+  ||| reduce a function application `App (Coe ty p q val) s loc`
+  export covering
+  piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
+          (val, s : Term d n) -> Loc ->
+          Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+  piCoe sty@(S [< i] ty) p q val s loc = do
+    -- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝
+    -- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›)
+    --   where 𝒔‹j› ≔ coe [i ⇒ A] @q @j s
+    --
+    -- type-case is used to expose A,B if the type is neutral
+    let ctx1 = extendDim i ctx
+    Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
+    (arg, res) <- tycasePi defs ctx1 ty
+    let s0   = CoeT i arg q p s s.loc
+        body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc
+        s1   = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
+                    (s // shift 1) s.loc
+    whnf defs ctx sg $ CoeT i (sub1 res s1) p q body loc
+
+  ||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc`
+  export covering
+  sigCoe : (qty : Qty) ->
+           (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
+           (ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> Loc ->
+           Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+  sigCoe qty sty@(S [< i] ty) p q val ret body loc = do
+    -- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e }
+    --   ⇝
+    -- caseπ s ∷ ((x : A) × B)‹p/i› return z ⇒ C
+    -- of { (a, b) ⇒
+    --   e[(coe [i ⇒ A] @p @q a)/a,
+    --     (coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i a)/x]] @p @q b)/b] }
+    --
+    -- type-case is used to expose A,B if the type is neutral
+    let ctx1 = extendDim i ctx
+    Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
+    (tfst, tsnd) <- tycaseSig defs ctx1 ty
+    let [< x, y] = body.names
+        a' = CoeT i (weakT 2 tfst) p q (BVT 1 x.loc) x.loc
+        tsnd' = tsnd.term //
+          (CoeT i (weakT 2 $ tfst // (B VZ tsnd.loc ::: shift 2))
+            (weakD 1 p) (B VZ i.loc) (BVT 1 tsnd.loc) y.loc ::: shift 2)
+        b' = CoeT i tsnd' p q (BVT 0 y.loc) y.loc
+    whnf defs ctx sg $ CasePair qty (Ann val (ty // one p) val.loc) ret
+      (ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc
+
+  ||| reduce a pair projection `Fst (Coe ty p q val) loc`
+  export covering
+  fstCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
+           Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+  fstCoe sty@(S [< i] ty) p q val loc = do
+    -- fst (coe (𝑖 ⇒ (x : A) × B) @p @q s)
+    --   ⇝
+    -- coe (𝑖 ⇒ A) @p @q (fst (s ∷ (x : A‹p/𝑖›) × B‹p/𝑖›))
+    --
+    -- type-case is used to expose A,B if the type is neutral
+    let ctx1 = extendDim i ctx
+    Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
+    (tfst, _) <- tycaseSig defs ctx1 ty
+    whnf defs ctx sg $
+      Coe (ST [< i] tfst) p q
+          (E (Fst (Ann val (ty // one p) val.loc) val.loc)) loc
+
+  ||| reduce a pair projection `Snd (Coe ty p q val) loc`
+  export covering
+  sndCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
+           Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+  sndCoe sty@(S [< i] ty) p q val loc = do
+    -- snd (coe (𝑖 ⇒ (x : A) × B) @p @q s)
+    --   ⇝
+    -- coe (𝑖 ⇒ B[coe (𝑗 ⇒ A‹𝑗/𝑖›) @p @𝑖 (fst (s ∷ (x : A) × B))/x]) @p @q
+    --     (snd (s ∷ (x : A‹p/𝑖›) × B‹p/𝑖›))
+    --
+    -- type-case is used to expose A,B if the type is neutral
+    let ctx1 = extendDim i ctx
+    Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
+    (tfst, tsnd) <- tycaseSig defs ctx1 ty
+    whnf defs ctx sg $
+      Coe (ST [< i] $ sub1 tsnd $
+            Coe (ST [< !(fresh i)] $ tfst // (BV 0 i.loc ::: shift 2))
+                (weakD 1 p) (BV 0 loc)
+                (E (Fst (Ann (dweakT 1 val) ty val.loc) val.loc)) loc)
+          p q
+          (E (Snd (Ann val (ty // one p) val.loc) val.loc))
+          loc
+
+  ||| reduce a dimension application `DApp (Coe ty p q val) r loc`
+  export covering
+  eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
+          (r : Dim d) -> Loc ->
+          Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+  eqCoe sty@(S [< j] ty) p q val r loc = do
+    -- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r
+    --   ⇝
+    -- comp [j ⇒ A‹r/i›] @p @q ((eq ∷ (Eq [i ⇒ A] L R)‹p/j›) @r)
+    --   @r { 0 j ⇒ L; 1 j ⇒ R }
+    let ctx1 = extendDim j ctx
+    Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
+    (a0, a1, a, s, t) <- tycaseEq defs ctx1 ty
+    let a'   = dsub1 a (weakD 1 r)
+        val' = E $ DApp (Ann val (ty // one p) val.loc) r loc
+    whnf defs ctx sg $ CompH j a' p q val' r j s j t loc
+
+  ||| reduce a pair elimination `CaseBox pi (Coe ty p q val) ret body`
+  export covering
+  boxCoe : (qty : Qty) ->
+           (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
+           (ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> Loc ->
+           Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+  boxCoe qty sty@(S [< i] ty) p q val ret body loc = do
+    -- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e }
+    --   ⇝
+    -- caseπ s ∷ [ρ. A]‹p/i› return z ⇒ C of { [a] ⇒ e[(coe [i ⇒ A] p q a)/a] }
+    let ctx1 = extendDim i ctx
+    Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
+    ta <- tycaseBOX defs ctx1 ty
+    let xloc = body.name.loc
+    let a' = CoeT i (weakT 1 ta) p q (BVT 0 xloc) xloc
+    whnf defs ctx sg $ CaseBox qty (Ann val (ty // one p) val.loc) ret
+      (ST body.names $ body.term // (a' ::: shift 1)) loc
+
+
+-- new params block to call the above functions at different `n`
+parameters {auto _ : CanWhnf Term Interface.isRedexT}
+           {auto _ : CanWhnf Elim Interface.isRedexE}
+           (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty)
+  ||| pushes a coercion inside a whnf-ed term
+  export covering
+  pushCoe : BindName ->
+            (ty : Term (S d) n) -> (p, q : Dim d) -> (s : Term d n) -> Loc ->
+            (0 pc : So (canPushCoe sg ty s)) =>
+            Eff Whnf (NonRedex Elim d n defs ctx sg)
+  pushCoe i ty p q s loc =
+    case ty of
+      -- (coe ★ᵢ @_ @_ s) ⇝ (s ∷ ★ᵢ)
+      TYPE l tyLoc =>
+        whnf defs ctx sg $ Ann s (TYPE l tyLoc) loc
+
+      -- (coe IOState @_ @_ s) ⇝ (s ∷ IOState)
+      IOState tyLoc =>
+        whnf defs ctx sg $ Ann s (IOState tyLoc) loc
+
+      -- η expand, then simplify the Coe/App in the body
+      --
+      -- (coe (𝑖 ⇒ π.(x : A) → B) @p @q s)
+      --   ⇝
+      -- (λ y ⇒ (coe (𝑖 ⇒ π.(x : A) → B) @p @q s) y) ∷ (π.(x : A) → B)‹q/𝑖›
+      --   ⇝     ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
+      -- (λ y ⇒ ⋯) ∷ (π.(x : A) → B)‹q/𝑖›   -- see `piCoe`
+      --
+      -- do the piCoe step here because otherwise equality checking keeps
+      -- doing the η forever
+      Pi {arg, res = S [< x] _, _} => do
+        let ctx' = extendTy x (arg // one p) ctx
+        body <- piCoe defs ctx' sg
+          (weakDS 1 $ SY [< i] ty) p q (weakT 1 s) (BVT 0 loc) loc
+        whnf defs ctx sg $
+          Ann (LamY x (E body.fst) loc) (ty // one q) loc
+
+      -- no η!!!
+      -- push into a pair constructor, otherwise still stuck
+      --
+      --   s̃‹𝑘› ≔ coe (𝑗 ⇒ A‹𝑗/𝑖›) @p @𝑘 s
+      -- -----------------------------------------------
+      --   (coe (𝑖 ⇒ (x : A) × B) @p @q (s, t))
+      --     ⇝
+      --   (s̃‹q›, coe (𝑖 ⇒ B[s̃‹𝑖›/x]) @p @q t)
+      --     ∷ ((x : A) × B)‹q/𝑖›
+      Sig tfst tsnd tyLoc => do
+        let Pair fst snd sLoc = s
+            fst' = CoeT i tfst p q fst fst.loc
+            fstInSnd =
+              CoeT !(fresh i)
+                   (tfst // (BV 0 loc ::: shift 2))
+                   (weakD 1 p) (BV 0 loc) (dweakT 1 fst) fst.loc
+            snd' = CoeT i (sub1 tsnd fstInSnd) p q snd snd.loc
+        whnf defs ctx sg $
+          Ann (Pair (E fst') (E snd') sLoc) (ty // one q) loc
+
+      -- (coe {𝐚̄} @_ @_ s) ⇝ (s ∷ {𝐚̄})
+      Enum cases tyLoc =>
+        whnf defs ctx sg $ Ann s (Enum cases tyLoc) loc
+
+      -- η expand/simplify, same as for Π
+      --
+      -- (coe (𝑖 ⇒ Eq (𝑗 ⇒ A) l r) @p @q s)
+      --   ⇝
+      -- (δ 𝑘 ⇒ (coe (𝑖 ⇒ Eq (𝑗 ⇒ A) l r) @p @q s) @𝑘) ∷ (Eq (𝑗 ⇒ A) l r)‹q/𝑖›
+      --   ⇝     ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
+      -- (δ 𝑘 ⇒ ⋯) ∷ (Eq (𝑗 ⇒ A) l r)‹q/𝑖›   -- see `eqCoe`
+      --
+      -- do the eqCoe step here because otherwise equality checking keeps
+      -- doing the η forever
+      Eq {ty = S [< j] _, _} => do
+        let ctx' = extendDim j ctx
+        body <- eqCoe defs ctx' sg
+          (dweakDS 1 $ S [< i] $ Y ty) (weakD 1 p) (weakD 1 q)
+          (dweakT 1 s) (BV 0 loc) loc
+        whnf defs ctx sg $
+          Ann (DLamY i (E body.fst) loc) (ty // one q) loc
+
+      -- (coe ℕ @_ @_ s) ⇝ (s ∷ ℕ)
+      NAT tyLoc =>
+        whnf defs ctx sg $ Ann s (NAT tyLoc) loc
+
+      -- (coe String @_ @_ s) ⇝ (s ∷ String)
+      STRING tyLoc =>
+        whnf defs ctx sg $ Ann s (STRING tyLoc) loc
+
+      -- η expand/simplify
+      --
+      -- (coe (𝑖 ⇒ [π.A]) @p @q s)
+      --   ⇝
+      -- [case coe (𝑖 ⇒ [π.A]) @p @q s return A‹q/𝑖› of {[x] ⇒ x}]
+      --   ⇝
+      -- [case1 s ∷ [π.A]‹p/𝑖› ⋯] ∷ [π.A]‹q/𝑖›   -- see `boxCoe`
+      --
+      -- do the eqCoe step here because otherwise equality checking keeps
+      -- doing the η forever
+      BOX qty inner tyLoc => do
+        body <- boxCoe defs ctx sg qty
+          (SY [< i] ty) p q s
+          (SN $ inner // one q)
+          (SY [< !(mnb "inner" loc)] (BVT 0 loc)) loc
+        whnf defs ctx sg $ Ann (Box (E body.fst) loc) (ty // one q) loc

lib/Quox/Whnf/ComputeElimType.idr

@@ -0,0 +1,110 @@
+module Quox.Whnf.ComputeElimType
+
+import Quox.Whnf.Interface
+import Quox.Displace
+import Quox.Pretty
+
+%default total
+
+
+||| performs the minimum work required to recompute the type of an elim.
+|||
+||| - assumes the elim is already typechecked
+||| - the return value is not reduced
+export covering
+computeElimType :
+  CanWhnf Term Interface.isRedexT =>
+  CanWhnf Elim Interface.isRedexE =>
+  (defs : Definitions) -> (ctx : WhnfContext d n) -> (0 sg : SQty) ->
+  (e : Elim d n) -> (0 ne : No (isRedexE defs ctx sg e)) =>
+  Eff Whnf (Term d n)
+
+||| computes a type and then reduces it to whnf
+export covering
+computeWhnfElimType0 :
+  CanWhnf Term Interface.isRedexT =>
+  CanWhnf Elim Interface.isRedexE =>
+  (defs : Definitions) -> (ctx : WhnfContext d n) -> (0 sg : SQty) ->
+  (e : Elim d n) -> (0 ne : No (isRedexE defs ctx sg e)) =>
+  Eff Whnf (Term d n)
+
+
+private covering
+computeElimTypeNoLog, computeWhnfElimType0NoLog :
+  CanWhnf Term Interface.isRedexT =>
+  CanWhnf Elim Interface.isRedexE =>
+  (defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) ->
+  (e : Elim d n) -> (0 ne : No (isRedexE defs ctx sg e)) =>
+  Eff Whnf (Term d n)
+
+computeElimTypeNoLog defs ctx sg e =
+  case e of
+    F x u loc => do
+      let Just def = lookup x defs
+        | Nothing => throw $ NotInScope loc x
+      pure $ def.typeWithAt ctx.dimLen ctx.termLen u
+
+    B i _ =>
+      pure (ctx.tctx !! i).type
+
+    App f s loc =>
+      case !(computeWhnfElimType0NoLog defs ctx sg f {ne = noOr1 ne}) of
+        Pi {arg, res, _} => pure $ sub1 res $ Ann s arg loc
+        ty               => throw $ ExpectedPi loc ctx.names ty
+
+    CasePair {pair, ret, _} =>
+      pure $ sub1 ret pair
+
+    Fst pair loc =>
+      case !(computeWhnfElimType0NoLog defs ctx sg pair {ne = noOr1 ne}) of
+        Sig {fst, _} => pure fst
+        ty           => throw $ ExpectedSig loc ctx.names ty
+
+    Snd pair loc =>
+      case !(computeWhnfElimType0NoLog defs ctx sg pair {ne = noOr1 ne}) of
+        Sig {snd, _} => pure $ sub1 snd $ Fst pair loc
+        ty           => throw $ ExpectedSig loc ctx.names ty
+
+    CaseEnum {tag, ret, _} =>
+      pure $ sub1 ret tag
+
+    CaseNat {nat, ret, _} =>
+      pure $ sub1 ret nat
+
+    CaseBox {box, ret, _} =>
+      pure $ sub1 ret box
+
+    DApp {fun = f, arg = p, loc} =>
+      case !(computeWhnfElimType0NoLog defs ctx sg f {ne = noOr1 ne}) of
+        Eq {ty, _} => pure $ dsub1 ty p
+        t          => throw $ ExpectedEq loc ctx.names t
+
+    Ann {ty, _} =>
+      pure ty
+
+    Coe {ty, q, _} =>
+      pure $ dsub1 ty q
+
+    Comp {ty, _} =>
+      pure ty
+
+    TypeCase {ret, _} =>
+      pure ret
+
+computeElimType defs ctx sg e {ne} = do
+  let Val n = ctx.termLen
+  sayMany "whnf" e.loc
+    [90 :> "computeElimType",
+     95 :> hsep ["ctx =", runPretty $ prettyWhnfContext ctx],
+     90 :> hsep ["e =", runPretty $ prettyElim ctx.dnames ctx.tnames e]]
+  res <- computeElimTypeNoLog defs ctx sg e {ne}
+  say "whnf" 91 e.loc $
+    hsep ["computeElimType ⇝",
+          runPretty $ prettyTerm ctx.dnames ctx.tnames res]
+  pure res
+
+computeWhnfElimType0 defs ctx sg e =
+  computeElimType defs ctx sg e >>= whnf0 defs ctx SZero
+
+computeWhnfElimType0NoLog defs ctx sg e {ne} =
+  computeElimTypeNoLog defs ctx sg e {ne} >>= whnf0 defs ctx SZero

lib/Quox/Whnf/Interface.idr

@@ -0,0 +1,266 @@
+module Quox.Whnf.Interface
+
+import public Quox.No
+import public Quox.Log
+import public Quox.Syntax
+import public Quox.Definition
+import public Quox.Typing.Context
+import public Quox.Typing.Error
+import public Data.Maybe
+import public Control.Eff
+
+%default total
+
+
+public export
+Whnf : List (Type -> Type)
+Whnf = [Except Error, NameGen, Log]
+
+
+public export
+0 RedexTest : TermLike -> Type
+RedexTest tm =
+  {0 d, n : Nat} -> Definitions -> WhnfContext d n -> SQty -> tm d n -> Bool
+
+public export
+interface CanWhnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm
+where
+  whnf, whnfNoLog :
+    (defs : Definitions) -> (ctx : WhnfContext d n) -> (q : SQty) ->
+    tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs ctx q))
+  -- having isRedex be part of the class header, and needing to be explicitly
+  -- quantified on every use since idris can't infer its type, is a little ugly.
+  -- but none of the alternatives i've thought of so far work. e.g. in some
+  -- cases idris can't tell that `isRedex` and `isRedexT` are the same thing
+
+public export %inline
+whnf0, whnfNoLog0 :
+  {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
+  Definitions -> WhnfContext d n -> SQty -> tm d n -> Eff Whnf (tm d n)
+whnf0      defs ctx q t = fst <$> whnf defs ctx q t
+whnfNoLog0 defs ctx q t = fst <$> whnfNoLog defs ctx q t
+
+public export
+0 IsRedex, NotRedex : {isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
+                      Definitions -> WhnfContext d n -> SQty -> Pred (tm d n)
+IsRedex  defs ctx q = So . isRedex defs ctx q
+NotRedex defs ctx q = No . isRedex defs ctx q
+
+public export
+0 NonRedex : (tm : TermLike) -> {isRedex : RedexTest tm} ->
+             CanWhnf tm isRedex => (d, n : Nat) ->
+             Definitions -> WhnfContext d n -> SQty -> Type
+NonRedex tm d n defs ctx q = Subset (tm d n) (NotRedex defs ctx q)
+
+public export %inline
+nred : {0 isRedex : RedexTest tm} -> (0 _ : CanWhnf tm isRedex) =>
+       (t : tm d n) -> (0 nr : NotRedex defs ctx q t) =>
+       NonRedex tm d n defs ctx q
+nred t = Element t nr
+
+
+||| an expression like `(λ x ⇒ s) ∷ π.(x : A) → B`
+public export %inline
+isLamHead : Elim {} -> Bool
+isLamHead (Ann (Lam {}) (Pi {}) _) = True
+isLamHead (Coe {})                 = True
+isLamHead _                        = False
+
+||| an expression like `(δ 𝑖 ⇒ s) ∷ Eq (𝑖 ⇒ A) s t`
+public export %inline
+isDLamHead : Elim {} -> Bool
+isDLamHead (Ann (DLam {}) (Eq {}) _) = True
+isDLamHead (Coe {})                  = True
+isDLamHead _                         = False
+
+||| an expression like `(s, t) ∷ (x : A) × B`
+public export %inline
+isPairHead : Elim {} -> Bool
+isPairHead (Ann (Pair {}) (Sig {}) _) = True
+isPairHead (Coe {})                   = True
+isPairHead _                          = False
+
+||| an expression like `'a ∷ {a, b, c}`
+public export %inline
+isTagHead : Elim {} -> Bool
+isTagHead (Ann (Tag {}) (Enum {}) _) = True
+isTagHead (Coe {})                   = True
+isTagHead _                          = False
+
+||| an expression like `𝑘 ∷ ℕ` for a natural constant 𝑘, or `suc n ∷ ℕ`
+public export %inline
+isNatHead : Elim {} -> Bool
+isNatHead (Ann (Nat  {}) (NAT {}) _) = True
+isNatHead (Ann (Succ {}) (NAT {}) _) = True
+isNatHead (Coe {})                   = True
+isNatHead _                          = False
+
+||| a natural constant, with or without an annotation
+public export %inline
+isNatConst : Term d n -> Bool
+isNatConst (Nat {})               = True
+isNatConst (E (Ann (Nat {}) _ _)) = True
+isNatConst _                      = False
+
+||| an expression like `[s] ∷ [π. A]`
+public export %inline
+isBoxHead : Elim {} -> Bool
+isBoxHead (Ann (Box {}) (BOX {}) _) = True
+isBoxHead (Coe {})                  = True
+isBoxHead _                         = False
+
+||| an elimination in a term context
+public export %inline
+isE : Term {} -> Bool
+isE (E {}) = True
+isE _      = False
+
+||| an expression like `s ∷ A`
+public export %inline
+isAnn : Elim {} -> Bool
+isAnn (Ann {}) = True
+isAnn _        = False
+
+||| a syntactic type
+public export %inline
+isTyCon : Term {} -> Bool
+isTyCon (TYPE    {}) = True
+isTyCon (IOState {}) = True
+isTyCon (Pi      {}) = True
+isTyCon (Lam     {}) = False
+isTyCon (Sig     {}) = True
+isTyCon (Pair    {}) = False
+isTyCon (Enum    {}) = True
+isTyCon (Tag     {}) = False
+isTyCon (Eq      {}) = True
+isTyCon (DLam    {}) = False
+isTyCon (NAT     {}) = True
+isTyCon (Nat     {}) = False
+isTyCon (Succ    {}) = False
+isTyCon (STRING  {}) = True
+isTyCon (Str     {}) = False
+isTyCon (BOX     {}) = True
+isTyCon (Box     {}) = False
+isTyCon (Let     {}) = False
+isTyCon (E       {}) = False
+isTyCon (CloT    {}) = False
+isTyCon (DCloT   {}) = False
+
+||| a syntactic type, or a neutral
+public export %inline
+isTyConE : Term {} -> Bool
+isTyConE s = isTyCon s || isE s
+
+||| a syntactic type with an annotation `★ᵢ`
+public export %inline
+isAnnTyCon : Elim {} -> Bool
+isAnnTyCon (Ann ty (TYPE {}) _) = isTyCon ty
+isAnnTyCon _                    = False
+
+||| 0 or 1
+public export %inline
+isK : Dim d -> Bool
+isK (K {}) = True
+isK _      = False
+
+
+||| true if `ty` is a type constructor, and `val` is a value of that type where
+||| a coercion can be reduced
+|||
+||| 1. `ty` is an atomic type
+||| 2. `ty` has an η law that is usable in this context
+|||    (e.g. η for pairs only exists when σ=0, not when σ=1)
+||| 3. `val` is a constructor form
+public export %inline
+canPushCoe : SQty -> (ty, val : Term {}) -> Bool
+canPushCoe sg (TYPE    {}) _         = True
+canPushCoe sg (IOState {}) _         = True
+canPushCoe sg (Pi      {}) _         = True
+canPushCoe sg (Lam     {}) _         = False
+canPushCoe sg (Sig     {}) (Pair {}) = True
+canPushCoe sg (Sig     {}) _         = False
+canPushCoe sg (Pair    {}) _         = False
+canPushCoe sg (Enum    {}) _         = True
+canPushCoe sg (Tag     {}) _         = False
+canPushCoe sg (Eq      {}) _         = True
+canPushCoe sg (DLam    {}) _         = False
+canPushCoe sg (NAT     {}) _         = True
+canPushCoe sg (Nat     {}) _         = False
+canPushCoe sg (Succ    {}) _         = False
+canPushCoe sg (STRING  {}) _         = True
+canPushCoe sg (Str     {}) _         = False
+canPushCoe sg (BOX     {}) _         = True
+canPushCoe sg (Box     {}) _         = False
+canPushCoe sg (Let     {}) _         = False
+canPushCoe sg (E       {}) _         = False
+canPushCoe sg (CloT    {}) _         = False
+canPushCoe sg (DCloT   {}) _         = False
+
+
+mutual
+  ||| a reducible elimination
+  |||
+  ||| 1. a free variable, if its definition is known
+  ||| 2. a bound variable pointing to a `let`
+  ||| 3. an elimination whose head is reducible
+  ||| 4. an "active" elimination:
+  |||    an application whose head is an annotated lambda,
+  |||    a case expression whose head is an annotated constructor form, etc
+  ||| 5. a redundant annotation, or one whose term or type is reducible
+  ||| 6. a coercion `coe (𝑖 ⇒ A) @p @q s` where:
+  |||      a. `A` is reducible or a type constructor, or
+  |||      b. `𝑖` is not mentioned in `A`
+  |||         ([fixme] should be A‹0/𝑖› = A‹1/𝑖›), or
+  |||      c. `p = q`
+  ||| 7. a composition `comp A @p @q s @r {⋯}`
+  |||    where `p = q`, `r = 0`, or `r = 1`
+  ||| 8. a closure
+  public export
+  isRedexE : RedexTest Elim
+  isRedexE defs ctx sg (F {x, u, _}) = isJust $ lookupElim0 x u defs
+  isRedexE _    ctx sg (B {i, _}) = isJust (ctx.tctx !! i).term
+  isRedexE defs ctx sg (App {fun, _}) =
+    isRedexE defs ctx sg fun || isLamHead fun
+  isRedexE defs ctx sg (CasePair {pair, _}) =
+    isRedexE defs ctx sg pair || isPairHead pair || isYes (sg `decEq` SZero)
+  isRedexE defs ctx sg (Fst pair _) =
+    isRedexE defs ctx sg pair || isPairHead pair
+  isRedexE defs ctx sg (Snd pair _) =
+    isRedexE defs ctx sg pair || isPairHead pair
+  isRedexE defs ctx sg (CaseEnum {tag, _}) =
+    isRedexE defs ctx sg tag || isTagHead tag
+  isRedexE defs ctx sg (CaseNat {nat, _}) =
+    isRedexE defs ctx sg nat || isNatHead nat
+  isRedexE defs ctx sg (CaseBox {box, _}) =
+    isRedexE defs ctx sg box || isBoxHead box
+  isRedexE defs ctx sg (DApp {fun, arg, _}) =
+    isRedexE defs ctx sg fun || isDLamHead fun || isK arg
+  isRedexE defs ctx sg (Ann {tm, ty, _}) =
+    isE tm || isRedexT defs ctx sg tm || isRedexT defs ctx SZero ty
+  isRedexE defs ctx sg (Coe {ty = S _ (N _), _}) = True
+  isRedexE defs ctx sg (Coe {ty = S [< i] (Y ty), p, q, val, _}) =
+    isRedexT defs (extendDim i ctx) SZero ty ||
+    canPushCoe sg ty val || isYes (p `decEqv` q)
+  isRedexE defs ctx sg (Comp {ty, p, q, r, _}) =
+    isYes (p `decEqv` q) || isK r
+  isRedexE defs ctx sg (TypeCase {ty, ret, _}) =
+    isRedexE defs ctx sg ty || isRedexT defs ctx sg ret || isAnnTyCon ty
+  isRedexE _ _ _ (CloE  {}) = True
+  isRedexE _ _ _ (DCloE {}) = True
+
+  ||| a reducible term
+  |||
+  ||| 1. a reducible elimination, as `isRedexE`
+  ||| 2. an annotated elimination
+  |||    (the annotation is redundant in a checkable context)
+  ||| 3. a closure
+  ||| 4. `succ` applied to a natural constant
+  ||| 5. a `let` expression
+  public export
+  isRedexT : RedexTest Term
+  isRedexT _    _   _  (CloT  {})  = True
+  isRedexT _    _   _  (DCloT {})  = True
+  isRedexT _    _   _  (Let   {})  = True
+  isRedexT defs ctx sg (E {e, _})  = isAnn e || isRedexE defs ctx sg e
+  isRedexT _    _   _  (Succ p {}) = isNatConst p
+  isRedexT _    _   _  _           = False

lib/Quox/Whnf/Main.idr

@@ -0,0 +1,300 @@
+module Quox.Whnf.Main
+
+import Quox.Whnf.Interface
+import Quox.Whnf.ComputeElimType
+import Quox.Whnf.TypeCase
+import Quox.Whnf.Coercion
+import Quox.Pretty
+import Quox.Displace
+import Data.SnocVect
+
+%default total
+
+
+export covering CanWhnf Term Interface.isRedexT
+export covering CanWhnf Elim Interface.isRedexE
+
+
+-- the String is what to call the "s" argument in logs (maybe "s", or "e")
+private %inline
+whnfDefault :
+  {0 isRedex : RedexTest tm} ->
+  (CanWhnf tm isRedex, Located2 tm) =>
+  String ->
+  (forall d, n. WhnfContext d n -> tm d n -> Eff Pretty LogDoc) ->
+  (defs : Definitions) ->
+  (ctx : WhnfContext d n) ->
+  (sg : SQty) ->
+  (s : tm d n) ->
+  Eff Whnf (Subset (tm d n) (No . isRedex defs ctx sg))
+whnfDefault name ppr defs ctx sg s = do
+  sayMany "whnf" s.loc
+    [10 :> "whnf",
+     95 :> hsep ["ctx =", runPretty $ prettyWhnfContext ctx],
+     95 :> hsep ["sg =", runPretty $ prettyQty sg.qty],
+     10 :> hsep [text name, "=", runPretty $ ppr ctx s]]
+  res <- whnfNoLog defs ctx sg s
+  say "whnf" 11 s.loc $ hsep ["whnf ⇝", runPretty $ ppr ctx res.fst]
+  pure res
+
+covering
+CanWhnf Elim Interface.isRedexE where
+  whnf = whnfDefault "e" $ \ctx, e => prettyElim ctx.dnames ctx.tnames e
+
+  whnfNoLog defs ctx sg (F x u loc) with (lookupElim0 x u defs) proof eq
+    _ | Just y  = whnf defs ctx sg $ setLoc loc $ injElim ctx y
+    _ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah
+
+  whnfNoLog defs ctx sg (B i loc) with (ctx.tctx !! i) proof eq1
+    _ | l with (l.term) proof eq2
+      _ | Just y  = whnf defs ctx sg $ Ann y l.type loc
+      _ | Nothing = pure $ Element (B i loc) $ rewrite eq1 in rewrite eq2 in Ah
+
+  -- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x]
+  whnfNoLog defs ctx sg (App f s appLoc) = do
+    Element f fnf <- whnf defs ctx sg f
+    case nchoose $ isLamHead f of
+      Left _ => case f of
+        Ann (Lam {body, _}) (Pi {arg, res, _}) floc =>
+          let s = Ann s arg s.loc in
+          whnf defs ctx sg $ Ann (sub1 body s) (sub1 res s) appLoc
+        Coe ty p q val _ => piCoe defs ctx sg ty p q val s appLoc
+      Right nlh => pure $ Element (App f s appLoc) $ fnf `orNo` nlh
+
+  -- case (s, t) ∷ (x : A) × B return p ⇒ C of { (a, b) ⇒ u } ⇝
+  -- u[s∷A/a, t∷B[s∷A/x]] ∷ C[(s, t)∷((x : A) × B)/p]
+  --
+  -- 0 · case e return p ⇒ C of { (a, b) ⇒ u } ⇝
+  -- u[fst e/a, snd e/b] ∷ C[e/p]
+  whnfNoLog defs ctx sg (CasePair pi pair ret body caseLoc) = do
+    Element pair pairnf <- whnf defs ctx sg pair
+    case nchoose $ isPairHead pair of
+      Left _ => case pair of
+        Ann (Pair {fst, snd, _}) (Sig {fst = tfst, snd = tsnd, _}) pairLoc =>
+          let fst = Ann fst tfst fst.loc
+              snd = Ann snd (sub1 tsnd fst) snd.loc
+          in
+          whnf defs ctx sg $ Ann (subN body [< fst, snd]) (sub1 ret pair) caseLoc
+        Coe ty p q val _ => do
+          sigCoe defs ctx sg pi ty p q val ret body caseLoc
+      Right np =>
+        case sg `decEq` SZero of
+          Yes Refl =>
+            whnf defs ctx SZero $
+              Ann (subN body [< Fst pair caseLoc, Snd pair caseLoc])
+                  (sub1 ret pair)
+                  caseLoc
+          No n0 =>
+            pure $ Element (CasePair pi pair ret body caseLoc)
+                           (pairnf `orNo` np `orNo` notYesNo n0)
+
+  -- fst ((s, t) ∷ (x : A) × B) ⇝ s ∷ A
+  whnfNoLog defs ctx sg (Fst pair fstLoc) = do
+    Element pair pairnf <- whnf defs ctx sg pair
+    case nchoose $ isPairHead pair of
+      Left _ => case pair of
+        Ann (Pair {fst, snd, _}) (Sig {fst = tfst, snd = tsnd, _}) pairLoc =>
+          whnf defs ctx sg $ Ann fst tfst pairLoc
+        Coe ty p q val _ => do
+          fstCoe defs ctx sg ty p q val fstLoc
+      Right np =>
+        pure $ Element (Fst pair fstLoc) (pairnf `orNo` np)
+
+  -- snd ((s, t) ∷ (x : A) × B) ⇝ t ∷ B[(s ∷ A)/x]
+  whnfNoLog defs ctx sg (Snd pair sndLoc) = do
+    Element pair pairnf <- whnf defs ctx sg pair
+    case nchoose $ isPairHead pair of
+      Left _ => case pair of
+        Ann (Pair {fst, snd, _}) (Sig {fst = tfst, snd = tsnd, _}) pairLoc =>
+          whnf defs ctx sg $ Ann snd (sub1 tsnd (Ann fst tfst fst.loc)) sndLoc
+        Coe ty p q val _ => do
+          sndCoe defs ctx sg ty p q val sndLoc
+      Right np =>
+        pure $ Element (Snd pair sndLoc) (pairnf `orNo` np)
+
+  -- case 'a ∷ {a,…} return p ⇒ C of { 'a ⇒ u } ⇝
+  -- u ∷ C['a∷{a,…}/p]
+  whnfNoLog defs ctx sg (CaseEnum pi tag ret arms caseLoc) = do
+    Element tag tagnf <- whnf defs ctx sg tag
+    case nchoose $ isTagHead tag of
+      Left _ => case tag of
+        Ann (Tag t _) (Enum ts _) _ =>
+          let ty = sub1 ret tag in
+          case lookup t arms of
+            Just arm => whnf defs ctx sg $ Ann arm ty arm.loc
+            Nothing  => throw $ MissingEnumArm caseLoc t (keys arms)
+        Coe ty p q val _ =>
+          -- there is nowhere an equality can be hiding inside an enum type
+          whnf defs ctx sg $
+            CaseEnum pi (Ann val (dsub1 ty q) val.loc) ret arms caseLoc
+      Right nt =>
+        pure $ Element (CaseEnum pi tag ret arms caseLoc) $ tagnf `orNo` nt
+
+  -- case zero ∷ ℕ return p ⇒ C of { zero ⇒ u; … } ⇝
+  --   u ∷ C[zero∷ℕ/p]
+  --
+  -- case succ n ∷ ℕ return p ⇒ C of { succ n', π.ih ⇒ u; … } ⇝
+  --   u[n∷ℕ/n', (case n ∷ ℕ ⋯)/ih] ∷ C[succ n ∷ ℕ/p]
+  whnfNoLog defs ctx sg (CaseNat pi piIH nat ret zer suc caseLoc) = do
+    Element nat natnf <- whnf defs ctx sg nat
+    case nchoose $ isNatHead nat of
+      Left _ =>
+        let ty = sub1 ret nat in
+        case nat of
+          Ann (Nat 0 _) (NAT _) _ =>
+            whnf defs ctx sg $ Ann zer ty zer.loc
+          Ann (Nat (S n) succLoc) (NAT natLoc) _ =>
+            let nn = Ann (Nat n succLoc) (NAT natLoc) succLoc
+                tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc]
+            in
+            whnf defs ctx sg $ Ann tm ty caseLoc
+          Ann (Succ n succLoc) (NAT natLoc) _ =>
+            let nn = Ann n (NAT natLoc) succLoc
+                tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc]
+            in
+            whnf defs ctx sg $ Ann tm ty caseLoc
+          Coe ty p q val _ =>
+            -- same deal as Enum
+            whnf defs ctx sg $
+              CaseNat pi piIH (Ann val (dsub1 ty q) val.loc) ret zer suc caseLoc
+      Right nn => pure $
+        Element (CaseNat pi piIH nat ret zer suc caseLoc) (natnf `orNo` nn)
+
+  -- case [t] ∷ [π.A] return p ⇒ C of { [x] ⇒ u } ⇝
+  --   u[t∷A/x] ∷ C[[t] ∷ [π.A]/p]
+  whnfNoLog defs ctx sg (CaseBox pi box ret body caseLoc) = do
+    Element box boxnf <- whnf defs ctx sg box
+    case nchoose $ isBoxHead box of
+      Left _ => case box of
+        Ann (Box val boxLoc) (BOX q bty tyLoc) _ =>
+          let ty = sub1 ret box in
+          whnf defs ctx sg $ Ann (sub1 body (Ann val bty val.loc)) ty caseLoc
+        Coe ty p q val _ =>
+          boxCoe defs ctx sg pi ty p q val ret body caseLoc
+      Right nb =>
+        pure $ Element (CaseBox pi box ret body caseLoc) (boxnf `orNo` nb)
+
+  -- e : Eq (𝑗 ⇒ A) t u ⊢ e @0 ⇝ t ∷ A‹0/𝑗›
+  -- e : Eq (𝑗 ⇒ A) t u ⊢ e @1 ⇝ u ∷ A‹1/𝑗›
+  --
+  -- ((δ 𝑖 ⇒ s) ∷ Eq (𝑗 ⇒ A) t u) @𝑘 ⇝ s‹𝑘/𝑖› ∷ A‹𝑘/𝑗›
+  whnfNoLog defs ctx sg (DApp f p appLoc) = do
+    Element f fnf <- whnf defs ctx sg f
+    case nchoose $ isDLamHead f of
+      Left _ => case f of
+        Ann (DLam {body, _}) (Eq {ty, l, r, _}) _ =>
+          whnf defs ctx sg $
+            Ann (endsOr (setLoc appLoc l) (setLoc appLoc r) (dsub1 body p) p)
+                (dsub1 ty p) appLoc
+        Coe ty p' q' val _ =>
+          eqCoe defs ctx sg ty p' q' val p appLoc
+      Right ndlh => case p of
+        K e _ => do
+          Eq {l, r, ty, _} <- computeWhnfElimType0 defs ctx sg f
+            | ty => throw $ ExpectedEq ty.loc ctx.names ty
+          whnf defs ctx sg $
+            ends (Ann (setLoc appLoc l) ty.zero appLoc)
+                 (Ann (setLoc appLoc r) ty.one  appLoc) e
+        B {} => pure $ Element (DApp f p appLoc) (fnf `orNo` ndlh `orNo` Ah)
+
+  -- e ∷ A ⇝ e
+  whnfNoLog defs ctx sg (Ann s a annLoc) = do
+    Element s snf <- whnf defs ctx sg s
+    case nchoose $ isE s of
+      Left  _  => let E e = s in pure $ Element e $ noOr2 snf
+      Right ne => do
+        Element a anf <- whnf defs ctx SZero a
+        pure $ Element (Ann s a annLoc) (ne `orNo` snf `orNo` anf)
+
+  whnfNoLog defs ctx sg (Coe sty p q val coeLoc) =
+    --   𝑖 ∉ fv(A)
+    -- -------------------------------
+    --   coe (𝑖 ⇒ A) @p @q s ⇝ s ∷ A
+    --
+    -- [fixme] needs a real equality check between A‹0/𝑖› and A‹1/𝑖›
+    case dsqueeze sty {f = Term} of
+      ([< i], Left ty) =>
+        case p `decEqv` q of
+          -- coe (𝑖 ⇒ A) @p @p s ⇝ (s ∷ A‹p/𝑖›)
+          Yes _   => whnf defs ctx sg $ Ann val (dsub1 sty p) coeLoc
+          No  npq => do
+            Element ty tynf <- whnf defs (extendDim i ctx) SZero ty
+            case nchoose $ canPushCoe sg ty val of
+              Left  pc  => pushCoe defs ctx sg i ty p q val coeLoc
+              Right npc => pure $ Element (Coe (SY [< i] ty) p q val coeLoc)
+                                          (tynf `orNo` npc `orNo` notYesNo npq)
+      (_, Right ty) =>
+        whnf defs ctx sg $ Ann val ty coeLoc
+
+  whnfNoLog defs ctx sg (Comp ty p q val r zero one compLoc) =
+    case p `decEqv` q of
+      -- comp [A] @p @p s @r { ⋯ } ⇝ s ∷ A
+      Yes y   => whnf defs ctx sg $ Ann val ty compLoc
+      No  npq => case r of
+        -- comp [A] @p @q s @0 { 0 𝑗 ⇒ t₀; ⋯ } ⇝ t₀‹q/𝑗› ∷ A
+        K Zero _ => whnf defs ctx sg $ Ann (dsub1 zero q) ty compLoc
+        -- comp [A] @p @q s @1 { 1 𝑗 ⇒ t₁; ⋯ } ⇝ t₁‹q/𝑗› ∷ A
+        K One  _ => whnf defs ctx sg $ Ann (dsub1 one  q) ty compLoc
+        B {}     => pure $ Element (Comp ty p q val r zero one compLoc)
+                                   (notYesNo npq `orNo` Ah)
+
+  whnfNoLog defs ctx sg (TypeCase ty ret arms def tcLoc) =
+    case sg `decEq` SZero of
+      Yes Refl => do
+        Element ty  tynf  <- whnf defs ctx SZero ty
+        Element ret retnf <- whnf defs ctx SZero ret
+        case nchoose $ isAnnTyCon ty of
+          Left  y  => let Ann ty (TYPE u _) _ = ty in
+                      reduceTypeCase defs ctx ty u ret arms def tcLoc
+          Right nt => pure $ Element (TypeCase ty ret arms def tcLoc)
+                                     (tynf `orNo` retnf `orNo` nt)
+      No _ =>
+        throw $ ClashQ tcLoc sg.qty Zero
+
+  whnfNoLog defs ctx sg (CloE (Sub el th)) =
+    whnfNoLog defs ctx sg $ pushSubstsWith' id th el
+  whnfNoLog defs ctx sg (DCloE (Sub el th)) =
+    whnfNoLog defs ctx sg $ pushSubstsWith' th id el
+
+covering
+CanWhnf Term Interface.isRedexT where
+  whnf = whnfDefault "e" $ \ctx, s => prettyTerm ctx.dnames ctx.tnames s
+
+  whnfNoLog _ _ _ t@(TYPE    {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(IOState {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Pi      {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Lam     {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Sig     {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Pair    {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Enum    {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Tag     {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Eq      {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(DLam    {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(NAT     {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Nat     {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(STRING  {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Str     {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(BOX     {}) = pure $ nred t
+  whnfNoLog _ _ _ t@(Box     {}) = pure $ nred t
+
+  whnfNoLog _ _ _ (Succ p loc) =
+    case nchoose $ isNatConst p of
+      Left _ => case p of
+        Nat p _               => pure $ nred $ Nat (S p) loc
+        E (Ann (Nat p _) _ _) => pure $ nred $ Nat (S p) loc
+      Right nc => pure $ nred $ Succ p loc
+
+  whnfNoLog defs ctx sg (Let _ rhs body _) =
+    whnf defs ctx sg $ sub1 body rhs
+
+  -- s ∷ A ⇝ s   (in term context)
+  whnfNoLog defs ctx sg (E e) = do
+    Element e enf <- whnf defs ctx sg e
+    case nchoose $ isAnn e of
+      Left  _  => let Ann {tm, _} = e in pure $ Element tm $ noOr1 $ noOr2 enf
+      Right na => pure $ Element (E e) $ na `orNo` enf
+
+  whnfNoLog defs ctx sg (CloT (Sub tm th)) =
+    whnfNoLog defs ctx sg $ pushSubstsWith' id th tm
+  whnfNoLog defs ctx sg (DCloT (Sub tm th)) =
+    whnfNoLog defs ctx sg $ pushSubstsWith' th id tm

lib/Quox/Whnf/TypeCase.idr

@@ -0,0 +1,170 @@
+module Quox.Whnf.TypeCase
+
+import Quox.Whnf.Interface
+import Quox.Whnf.ComputeElimType
+import Data.SnocVect
+
+%default total
+
+
+private
+tycaseRhs : (k : TyConKind) -> TypeCaseArms d n ->
+            Maybe (ScopeTermN (arity k) d n)
+tycaseRhs k arms = lookupPrecise k arms
+
+private
+tycaseRhsDef : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
+               ScopeTermN (arity k) d n
+tycaseRhsDef def k arms = fromMaybe (SN def) $ tycaseRhs k arms
+
+private
+tycaseRhs0 : (k : TyConKind) -> TypeCaseArms d n ->
+             (0 eq : arity k = 0) => Maybe (Term d n)
+tycaseRhs0 k arms = map (.term0) $ rewrite sym eq in tycaseRhs k arms
+
+private
+tycaseRhsDef0 : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
+                (0 eq : arity k = 0) => Term d n
+tycaseRhsDef0 def k arms = fromMaybe def $ tycaseRhs0 k arms
+
+
+parameters {auto _ : CanWhnf Term Interface.isRedexT}
+           {auto _ : CanWhnf Elim Interface.isRedexE}
+           (defs : Definitions) (ctx : WhnfContext d n)
+  ||| for π.(x : A) → B, returns (A, B);
+  ||| for an elim returns a pair of type-cases that will reduce to that;
+  ||| for other intro forms error
+  export covering
+  tycasePi : (t : Term d n) -> (0 tnf : No (isRedexT defs ctx SZero t)) =>
+             Eff Whnf (Term d n, ScopeTerm d n)
+  tycasePi (Pi {arg, res, _}) = pure (arg, res)
+  tycasePi (E e) {tnf} = do
+    ty <- computeElimType defs ctx SZero e {ne = noOr2 tnf}
+    let loc  = e.loc
+        narg = mnb "Arg" loc; nret = mnb "Ret" loc
+        arg  = E $ typeCase1Y e ty KPi [< !narg, !nret] (BVT 1 loc) loc
+        res' = typeCase1Y e (Arr Zero arg ty loc) KPi [< !narg, !nret]
+                 (BVT 0 loc) loc
+        res  = ST [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc
+    pure (arg, res)
+  tycasePi t = throw $ ExpectedPi t.loc ctx.names t
+
+  ||| for (x : A) × B, returns (A, B);
+  ||| for an elim returns a pair of type-cases that will reduce to that;
+  ||| for other intro forms error
+  export covering
+  tycaseSig : (t : Term d n) -> (0 tnf : No (isRedexT defs ctx SZero t)) =>
+              Eff Whnf (Term d n, ScopeTerm d n)
+  tycaseSig (Sig {fst, snd, _}) = pure (fst, snd)
+  tycaseSig (E e) {tnf} = do
+    ty <- computeElimType defs ctx SZero e {ne = noOr2 tnf}
+    let loc  = e.loc
+        nfst = mnb "Fst" loc; nsnd = mnb "Snd" loc
+        fst  = E $ typeCase1Y e ty KSig [< !nfst, !nsnd] (BVT 1 loc) loc
+        snd' = typeCase1Y e (Arr Zero fst ty loc) KSig [< !nfst, !nsnd]
+                 (BVT 0 loc) loc
+        snd  = ST [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc
+    pure (fst, snd)
+  tycaseSig t = throw $ ExpectedSig t.loc ctx.names t
+
+  ||| for [π. A], returns A;
+  ||| for an elim returns a type-case that will reduce to that;
+  ||| for other intro forms error
+  export covering
+  tycaseBOX : (t : Term d n) -> (0 tnf : No (isRedexT defs ctx SZero t)) =>
+              Eff Whnf (Term d n)
+  tycaseBOX (BOX {ty, _}) = pure ty
+  tycaseBOX (E e) {tnf} = do
+    ty <- computeElimType defs ctx SZero e {ne = noOr2 tnf}
+    pure $ E $ typeCase1Y e ty KBOX [< !(mnb "Ty" e.loc)] (BVT 0 e.loc) e.loc
+  tycaseBOX t = throw $ ExpectedBOX t.loc ctx.names t
+
+  ||| for Eq [i ⇒ A] l r, returns (A‹0/i›, A‹1/i›, A, l, r);
+  ||| for an elim returns five type-cases that will reduce to that;
+  ||| for other intro forms error
+  export covering
+  tycaseEq : (t : Term d n) -> (0 tnf : No (isRedexT defs ctx SZero t)) =>
+             Eff Whnf (Term d n, Term d n, DScopeTerm d n, Term d n, Term d n)
+  tycaseEq (Eq {ty, l, r, _}) = pure (ty.zero, ty.one, ty, l, r)
+  tycaseEq (E e) {tnf} = do
+    ty <- computeElimType defs ctx SZero e {ne = noOr2 tnf}
+    let loc   = e.loc
+        names = traverse' (\x => mnb x loc) [< "A0", "A1", "A", "L", "R"]
+        a0    = E $ typeCase1Y e ty KEq !names (BVT 4 loc) loc
+        a1    = E $ typeCase1Y e ty KEq !names (BVT 3 loc) loc
+        a'    = typeCase1Y e (Eq0 ty a0 a1 loc) KEq !names (BVT 2 loc) loc
+        a     = DST [< !(mnb "i" loc)] $ E $ DApp (dweakE 1 a') (B VZ loc) loc
+        l     = E $ typeCase1Y e a0 KEq !names (BVT 1 loc) loc
+        r     = E $ typeCase1Y e a1 KEq !names (BVT 0 loc) loc
+    pure (a0, a1, a, l, r)
+  tycaseEq t = throw $ ExpectedEq t.loc ctx.names t
+
+  ||| reduce a type-case applied to a type constructor
+  |||
+  ||| `reduceTypeCase A i Q arms def _` reduces an expression
+  ||| `type-case A ∷ ★ᵢ return Q of { arms; _ ⇒ def }`
+  export covering
+  reduceTypeCase : (ty : Term d n) -> (u : Universe) -> (ret : Term d n) ->
+                   (arms : TypeCaseArms d n) -> (def : Term d n) ->
+                   (0 _ : So (isTyCon ty)) => Loc ->
+                   Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx SZero))
+  reduceTypeCase ty u ret arms def loc = case ty of
+    -- (type-case ★ᵢ ∷ _ return Q of { ★ ⇒ s; ⋯ }) ⇝ s ∷ Q
+    TYPE {} =>
+      whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KTYPE arms) ret loc
+
+    -- (type-case IOState ∷ _ return Q of { IOState ⇒ s; ⋯ }) ⇝ s ∷ Q
+    IOState {} =>
+      whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KIOState arms) ret loc
+
+    -- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝
+    -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
+    Pi {arg, res, loc = piLoc, _} =>
+      let arg' = Ann arg (TYPE u arg.loc) arg.loc
+          res' = Ann (Lam res res.loc)
+                     (Arr Zero arg (TYPE u arg.loc) arg.loc) res.loc
+      in
+      whnf defs ctx SZero $
+        Ann (subN (tycaseRhsDef def KPi arms) [< arg', res']) ret loc
+
+    -- (type-case (x : A) × B ∷ ★ᵢ return Q of { (a × b) ⇒ s; ⋯ }) ⇝
+    -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
+    Sig {fst, snd, loc = sigLoc, _} =>
+      let fst' = Ann fst (TYPE u fst.loc) fst.loc
+          snd' = Ann (Lam snd snd.loc)
+                     (Arr Zero fst (TYPE u fst.loc) fst.loc) snd.loc
+      in
+      whnf defs ctx SZero $
+        Ann (subN (tycaseRhsDef def KSig arms) [< fst', snd']) ret loc
+
+    -- (type-case {⋯} ∷ _ return Q of { {} ⇒ s; ⋯ }) ⇝ s ∷ Q
+    Enum {} =>
+      whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KEnum arms) ret loc
+
+    -- (type-case Eq [i ⇒ A] L R ∷ ★ᵢ return Q
+    --  of { Eq a₀ a₁ a l r ⇒ s; ⋯ }) ⇝
+    -- s[(A‹0/i› ∷ ★ᵢ)/a₀, (A‹1/i› ∷ ★ᵢ)/a₁,
+    --   ((δ i ⇒ A) ∷ Eq [★ᵢ] A‹0/i› A‹1/i›)/a,
+    --   (L ∷ A‹0/i›)/l, (R ∷ A‹1/i›)/r] ∷ Q
+    Eq {ty = a, l, r, loc = eqLoc, _} =>
+      let a0 = a.zero; a1 = a.one in
+      whnf defs ctx SZero $ Ann
+        (subN (tycaseRhsDef def KEq arms)
+           [< Ann a0 (TYPE u a.loc) a.loc, Ann a1 (TYPE u a.loc) a.loc,
+              Ann (DLam a a.loc) (Eq0 (TYPE u a.loc) a0 a1 a.loc) a.loc,
+              Ann l a0 l.loc, Ann r a1 r.loc])
+        ret loc
+
+    -- (type-case ℕ ∷ _ return Q of { ℕ ⇒ s; ⋯ }) ⇝ s ∷ Q
+    NAT {} =>
+      whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KNat arms) ret loc
+
+    -- (type-case String ∷ _ return Q of { String ⇒ s; ⋯ }) ⇝ s ∷ Q
+    STRING {} =>
+      whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KString arms) ret loc
+
+    -- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q
+    BOX {ty = a, loc = boxLoc, _} =>
+      whnf defs ctx SZero $ Ann
+        (sub1 (tycaseRhsDef def KBOX arms) (Ann a (TYPE u a.loc) a.loc))
+        ret loc

lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr

@@ -1,28 +1,37 @@
 -- this module has to be called this because a module A.B's private elements are
 -- still visible to A.B.C, even if they're in different packages. which i don't
 -- think is a good idea but i also don't want to fork prettier over it
+--
+-- also i adapted this code from stefan höck's prettier-ansi package
+-- (https://github.com/idris-community/idris2-ansi)
 module Text.PrettyPrint.Bernardy.Core.Decorate
 
 import public Text.PrettyPrint.Bernardy.Core
 import Data.DPair
+import Data.String
+import Derive.Prelude
+
+%language ElabReflection
 
 
 public export
 record Highlight where
   constructor MkHighlight
   before, after : String
+%name Highlight h
+%runElab derive "Highlight" [Eq]
 
 export
-emptyHL : Highlight -> Bool
-emptyHL (MkHighlight before after) = before == "" && after == ""
+emptyHL : Highlight
+emptyHL = MkHighlight "" ""
 
 
--- taken from prettier-ansi
+-- lifted from prettier-ansi
 private
 decorateImpl : Highlight ->
                (ss : SnocList String) -> (0 _ : NonEmptySnoc ss) =>
                Subset (SnocList String) NonEmptySnoc
-decorateImpl h [<x]      = Element [< h.before ++ x ++ h.after] %search
+decorateImpl h [< x]     = Element [< h.before ++ x ++ h.after] %search
 decorateImpl h (sx :< x) = Element (go [] sx :< (x ++ h.after)) %search
   where
     go : List String -> SnocList String -> SnocList String
@@ -34,12 +43,23 @@ decorateImpl h (sx :< x) = Element (go [] sx :< (x ++ h.after)) %search
 ||| changing its stats like width or height.
 export
 decorateLayout : Highlight -> Layout -> Layout
-decorateLayout h l@(MkLayout content stats) =
-  if emptyHL h then l else
+decorateLayout h (MkLayout content stats) =
   layout (decorateImpl h content) stats
 
 ||| Decorate a `Doc` with the given highlighting *without*
 ||| changing its stats like width or height.
 export
-decorate : {opts : _} -> Highlight -> Doc opts -> Doc opts
-decorate h doc = doc >>= \l => pure (decorateLayout h l)
+decorate : {opts : LayoutOpts} -> Highlight -> Doc opts -> Doc opts
+decorate h doc =
+  if h == emptyHL then doc else doc >>= pure . decorateLayout h
+
+
+-- this function has nothing to do with highlighting but it's here because it
+-- _also_ needs access to the private stuff
+||| render a doc with no line breaks at all
+export
+renderInfinite : Doc opts -> String
+renderInfinite (MkDoc (MkLayout content _) _) = unwords content where
+  unwords : SnocList String -> String
+  unwords [<]       = ""
+  unwords (xs :< x) = foldMap (++ " ") xs ++ x