wip

.gitignore

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

CREDITS.md

@@ -1,4 +0,0 @@
-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

@@ -5,6 +5,3 @@ 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,35 +4,24 @@ namespace bool {
 
 def0 Bool : ★ = {true, 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 boolω : 1.Bool → [ω.Bool] =
+  λ b ⇒ case1 b return [ω.Bool] of { 'true ⇒ ['true]; 'false ⇒ ['false] };
 
-def if : 0.(A : ★) → (b : Bool) → ω.A → ω.A → A =
-  λ A ⇒ if-dep (λ _ ⇒ A);
+def if : 0.(A : ★) → 1.Bool → ω.A → ω.A → A =
+  λ A b t f ⇒ case1 b return A 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 If : 1.Bool → 0.★ → 0.★ → ★ =
+  λ b T F ⇒ case1 b return ★ of { 'true ⇒ T; 'false ⇒ F };
 
-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);
+def0 T : ω.Bool → ★ = λ b ⇒ If b True False;
 
 def true-not-false : Not ('true ≡ 'false : Bool) =
-  λ eq ⇒ coe (𝑖 ⇒ T (eq @𝑖)) 'true;
+  λ eq ⇒ coe (i ⇒ T (eq @i)) 'true;
 
 
 -- [todo] infix
-def and : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
-def or  : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
+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;
 
 }
 

examples/either.quox

@@ -5,35 +5,35 @@ namespace either {
 
 def0 Tag : ★ = {left, right};
 
-def0 Payload : ★ → ★ → Tag → ★ =
-  λ A B tag ⇒ case tag return ★ of { 'left ⇒ A; 'right ⇒ B };
+def0 Payload : 0.★ → 0.★ → 1.Tag → ★ =
+  λ A B tag ⇒ case1 tag return ★ of { 'left ⇒ A; 'right ⇒ B };
 
-def0 Either : ★ → ★ → ★ =
+def0 Either : 0.★ → 0.★ → ★ =
   λ A B ⇒ (tag : Tag) × Payload A B tag;
 
-def Left : 0.(A B : ★) → A → Either A B =
+def Left : 0.(A B : ★) → 1.A → Either A B =
   λ A B x ⇒ ('left, x);
 
-def Right : 0.(A B : ★) → B → Either A B =
+def Right : 0.(A B : ★) → 1.B → Either A B =
   λ A B x ⇒ ('right, x);
 
 def elim' :
     0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
-    ω.((x : A) → P (Left  A B x)) →
-    ω.((x : B) → P (Right A B x)) →
-    (t : Tag) → (a : Payload A B t) → P (t, a) =
+    ω.(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) =
   λ A B P f g t ⇒
-    case t
-    return t' ⇒ (a : Payload A B t') → P (t', a)
+    case1 t
+    return t' ⇒ 1.(a : Payload A B t') → P (t', a)
     of { 'left ⇒ f; 'right ⇒ g };
 
 def elim :
     0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
-    ω.((x : A) → P (Left  A B x)) →
-    ω.((x : B) → P (Right A B x)) →
-    (x : Either A B) → P x =
+    ω.(1.(x : A) → P (Left  A B x)) →
+    ω.(1.(x : B) → P (Right A B x)) →
+    1.(x : Either A B) → P x =
   λ A B P f g e ⇒
-    case e return e' ⇒ P e' of { (t, a) ⇒ elim' A B P f g t a };
+    case1 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 : ★ → ★ = λ A ⇒ Either [0.A] [0.Not A];
+def0 Dec : 0.★ → ★ = λ 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 : ★ → ★ =
+def0 DecEq : 0.★ → ★ =
   λ 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)) →
-    (x : Dec A) → P x =
+    1.(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 : ★) → Dec A → Bool =
+def bool : 0.(A : ★) → 1.(Dec A) → Bool =
   λ A ⇒ elim A (λ _ ⇒ Bool) (λ _ ⇒ 'true) (λ _ ⇒ 'false);
 
 }

examples/eta.quox

@@ -1,25 +0,0 @@
-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

@@ -1,16 +0,0 @@
-#[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

@@ -1,26 +0,0 @@
-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

@@ -1,31 +0,0 @@
-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,91 +1,41 @@
 load "nat.quox";
 
-namespace vec {
+namespace list {
 
-def0 Vec : ℕ → ★ → ★ =
+def0 Vec : 0.ℕ → 0.★ → ★ =
   λ n A ⇒
   caseω n return ★ of {
     zero           ⇒ {nil};
     succ _, 0.Tail ⇒ A × Tail
   };
 
-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)
-        }
-    };
-
-#[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 : ★ → ★ =
+def0 List : 0.★ → ★ =
   λ A ⇒ (len : ℕ) × Vec len A;
 
-def Nil : 0.(A : ★) → List 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 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 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 : ★) →
+             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 : ★) → B → ω.(A → B → B) → List A → B =
-  λ A B z f xs ⇒ elim A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs;
+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 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);
+def sum : 1.(List ℕ) → ℕ = foldr ℕ ℕ 0 nat.plus;
 
-def0 All : (A : ★) → (P : A → ★) → List A → ★ =
-  λ A P xs ⇒ foldr¹ A ★ True (λ x ps ⇒ P x × ps) (up A xs);
+def numbers : List ℕ = (5, (0, 1, 2, 3, 4, 'nil));
+
+def number-sum : sum numbers ≡ 10 : ℕ = δ _ ⇒ 10;
 
 }
-
-def0 List = list.List;

examples/maybe.quox

@@ -5,10 +5,10 @@ namespace maybe {
 
 def0 Tag : ★ = {nothing, just}
 
-def0 Payload : Tag → ★ → ★ =
-  λ tag A ⇒ case tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
+def0 Payload : ω.Tag → ω.★ → ★ =
+  λ tag A ⇒ caseω tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
 
-def0 Maybe : ★ → ★ =
+def0 Maybe : ω.★ → ★ =
   λ A ⇒ (t : Tag) × Payload t A
 
 def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
@@ -17,13 +17,13 @@ def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
 def Nothing : 0.(A : ★) → Maybe A =
   λ _ ⇒ ('nothing, 'true)
 
-def Just : 0.(A : ★) → A → Maybe A =
+def Just : 0.(A : ★) → 1.A → Maybe A =
   λ _ x ⇒ ('just, x)
 
-def0 IsJustTag : Tag → ★ =
-  λ t ⇒ case t return ★ of { 'just ⇒ True; 'nothing ⇒ False }
+def0 IsJustTag : ω.Tag → ★ =
+  λ t ⇒ caseω t return ★ of { 'just ⇒ True; 'nothing ⇒ False }
 
-def0 IsJust : (A : ★) → Maybe A → ★ =
+def0 IsJust : 0.(A : ★) → ω.(Maybe A) → ★ =
   λ A x ⇒ IsJustTag (tag A x)
 
 def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
@@ -34,31 +34,32 @@ def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
   }
 
 def0 nothing-unique :
-    (A : ★) → (x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
+    0.(A : ★) → ω.(x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
   λ A x ⇒
-  case x return x' ⇒ ('nothing, x') ≡ Nothing A : Maybe A of {
+  caseω x return x' ⇒ ('nothing, x') ≡ Nothing A : Maybe A of {
     'true ⇒ δ _ ⇒ ('nothing, 'true)
   }
 
 def elim :
     0.(A : ★) →
-    0.(P : Maybe A → ★) →
+    0.(P : 0.(Maybe A) → ★) →
     ω.(P (Nothing A)) →
-    ω.((x : A) → P (Just A x)) →
-    (x : Maybe A) → P x =
+    ω.(ω.(x : A) → P (Just A x)) →
+    1.(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)
+  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)
   }
 
 }

examples/misc.quox

@@ -1,83 +1,36 @@
-def0 True : ★ = {true}
+def0 True : ★ = {true};
 
-def0 False : ★ = {}
-def0 Not : ★ → ★ = λ A ⇒ ω.A → False
+def0 False : ★ = {};
+def0 Not : 0.★ → ★ = λ 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 All : (A : ★) → (0.A → ★) → ★ =
-  λ A P ⇒ (x : A) → P x
+def0 Pred : 0.★ → ★¹ = λ A ⇒ 0.A → ★;
 
-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
+def0 All : 0.(A : ★) → 0.(Pred A) → ★¹ =
+  λ A P ⇒ 1.(x : A) → P 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 : 0.A → ★) →
+    0.(A : ★) → 0.(P : Pred 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 : 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 @𝑖
+    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 @𝑖;
 
-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 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 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 @𝑗 }
-
-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 @𝑖)]) }
-  }
-
-}
+    comp A (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 };

examples/nat.quox

@@ -4,72 +4,41 @@ load "either.quox";
 
 namespace nat {
 
-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] =
+def dup : 1.ℕ → [ω.ℕ] =
   λ n ⇒
-  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
+  case1 n return [ω.ℕ] of {
+    zero        ⇒ [zero];
+    succ _, 1.d ⇒ case1 d return [ω.ℕ] of { [d] ⇒ [succ d] }
   };
 
-def dup : ℕ → [ω.ℕ] =
-  λ n ⇒ appω (Sing ℕ n) ℕ (sing.val ℕ n) (dup! n);
-
-#[compile-scheme "(lambda% (m n) (+ m n))"]
-def plus : ℕ → ℕ → ℕ =
+def plus : 1.ℕ → 1.ℕ → ℕ =
   λ m n ⇒
-  case m return ℕ of {
-    zero      ⇒ n;
-    succ _, p ⇒ succ p
+  case1 m return ℕ of {
+    zero        ⇒ n;
+    succ _, 1.p ⇒ succ p
   };
 
-#[compile-scheme "(lambda% (m n) (* m n))"]
-def timesω : ℕ → ω.ℕ → ℕ =
+def timesω : 1.ℕ → ω.ℕ → ℕ =
   λ m n ⇒
-  case m return ℕ of {
-    zero      ⇒ zero;
-    succ _, t ⇒ plus n t
+  case1 m return ℕ of {
+    zero        ⇒ zero;
+    succ _, 1.t ⇒ plus n t
   };
 
-def times : ℕ → ℕ → ℕ =
-  λ m n ⇒ case dup n return ℕ of { [n] ⇒ timesω m n };
+def times : 1.ℕ → 1.ℕ → ℕ =
+  λ m n ⇒ case1 dup n return ℕ of { [n] ⇒ timesω m n };
 
-def pred : ℕ → ℕ = λ n ⇒ case n return ℕ of { zero ⇒ zero; succ n ⇒ n };
+def pred : 1.ℕ → ℕ = λ n ⇒ case1 n return ℕ of { zero ⇒ zero; succ n ⇒ n };
 
 def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ =
   λ n ⇒ δ 𝑖 ⇒ n;
 
-def0 succ-inj : (m n : ℕ) → succ m ≡ succ n : ℕ → m ≡ n : ℕ =
+def0 succ-inj : 0.(m n : ℕ) → 0.(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 : ℕ → ★ =
-  λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True };
+def0 IsSucc : 0.ℕ → ★ =
+  λ n ⇒ caseω n return ★ of { zero ⇒ False; succ _ ⇒ True };
 
 def isSucc? : ω.(n : ℕ) → Dec (IsSucc n) =
   λ n ⇒
@@ -85,15 +54,14 @@ def succ-not-zero : 0.(m : ℕ) → Not (succ m ≡ zero : ℕ) =
   λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true;
 
 
-def0 not-succ-self : (m : ℕ) → Not (m ≡ succ m : ℕ) =
+def0 not-succ-self : 0.(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
@@ -118,48 +86,28 @@ def eq? : DecEq ℕ =
 def eqb : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ dec.bool (m ≡ n : ℕ) (eq? m n);
 
 
-def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ =
+def0 plus-zero : 0.(m : ℕ) → m ≡ plus m 0 : ℕ =
   λ m ⇒
-  case m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
-    zero        ⇒ δ _ ⇒ 0;
-    succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
+  caseω m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
+    zero         ⇒ δ _ ⇒ zero;
+    succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
   };
 
-def0 plus-succ : (m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ =
+def0 plus-succ : 0.(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 : (m n : ℕ) → plus m n ≡ plus n m : ℕ =
+def0 plus-comm : 0.(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,74 +1,55 @@
 namespace pair {
 
-def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x;
+def0 Σ : 0.(A : ★) → 0.(0.A → ★) → ★ = λ A B ⇒ (x : A) × B x;
 
-{-
--- now builtins
-def fst : 0.(A : ★) → 0.(B : A → ★) → ω.(Σ A B) → A =
+def fst : 0.(A : ★) → 0.(B : 0.A → ★) → ω.(Σ A B) → A =
   λ A B p ⇒ caseω p return A of { (x, _) ⇒ x };
 
-def snd : 0.(A : ★) → 0.(B : A → ★) → ω.(p : Σ A B) → B (fst A B p) =
+def snd : 0.(A : ★) → 0.(B : 0.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 : A → ★) → 0.(C : (x : A) → (B x) → ★) →
-    (f : (x : A) → (y : B x) → C x y) →
-    (p : Σ A B) → C (fst p) (snd p) =
+    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) =
   λ A B C f p ⇒
-    case p return p' ⇒ C (fst p') (snd p') of { (x, y) ⇒ f x y };
+    case1 p return p' ⇒ C (fst A B p') (snd A B p') of { (x, y) ⇒ f x y };
 
 def uncurry' :
-    0.(A B C : ★) → (A → B → C) → (A × B) → C =
+    0.(A B C : ★) → 1.(1.A → 1.B → C) → 1.(A × B) → C =
   λ A B C ⇒ uncurry A (λ _ ⇒ B) (λ _ _ ⇒ C);
 
 def curry :
-    0.(A : ★) → 0.(B : A → ★) → 0.(C : (Σ A B) → ★) →
-    (f : (p : Σ A B) → C p) → (x : A) → (y : B x) → C (x, y) =
+    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) =
   λ A B C f x y ⇒ f (x, y);
 
 def curry' :
-    0.(A B C : ★) → (A × B → C) → A → B → C =
+    0.(A B C : ★) → 1.(1.(A × B) → C) → 1.A → 1.B → C =
   λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C);
 
 def0 fst-snd :
-    (A : ★) → (B : A → ★) →
-    (p : Σ A B) → p ≡ (fst p, snd p) : Σ A B =
+    0.(A : ★) → 0.(B : 0.A → ★) →
+    1.(p : Σ A B) → p ≡ (fst A B p, snd A B p) : Σ A B =
   λ A B p ⇒
-    case p
-    return p' ⇒ p' ≡ (fst p', snd p') : Σ A B
+    case1 p
+    return p' ⇒ p' ≡ (fst A B p', snd A B 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 : A → ★) → 0.(B' : A' → ★) →
-    (f : A → A') → (g : 0.(x : A) → (B x) → B' (f x)) →
-    Σ A B → Σ A' B' =
+    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' =
   λ A A' B B' f g p ⇒
-    case p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
+    case1 p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
 
-def map' : 0.(A A' B B' : ★) → (A → A') → (B → B') → (A × B) → A' × B' =
+def map' : 0.(A A' B B' : ★) →
+           1.(1.A → A') → 1.(1.B → B') → 1.(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

@@ -1,77 +0,0 @@
-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

@@ -1,164 +0,0 @@
-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

@@ -1,49 +0,0 @@
-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,118 +1,46 @@
 module Main
 
-import Quox.Syntax as Q
-import Quox.Definition as Q
-import Quox.Untyped.Syntax as U
+import Quox.Syntax
 import Quox.Parser
-import Quox.Untyped.Erase
-import Quox.Untyped.Scheme
+import Quox.Definition
 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
 
-%default total
-
-%hide Doc.(>>=)
-%hide Core.(>>=)
-
-%hide FromParser.Error
-%hide Erase.Error
-%hide Lexer.Error
-%hide Parser.Error
-
+private
+Opts : LayoutOpts
+Opts = Opts 80
 
 private
-Step : Type -> Type -> Type
-Step a b = OpenFile -> a -> Eff Compile b
+putDoc : Doc Opts -> IO ()
+putDoc = putStr . render Opts
 
 private
-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
+die : Doc Opts -> IO a
+die err = do putDoc err; exitFailure
 
+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
 
-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
+export
 main : IO ()
 main = do
-  (_, opts, files) <- options
-  case !(runCompile opts !newState $ traverse_ processFile files) of
-    Right () => pure ()
-    Left  e  => dieError opts e
-
+  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
 
 -----------------------------------
 {-
@@ -127,13 +55,6 @@ text _ =
    #" /_/"#,
    ""]
 
---   ["",
---    #" __ _ _  _ _____ __"#,
---    #"/ _` | || / _ \ \ /"#,
---    #"\__, |\_,_\___/_\_\"#,
---    #"   |_|"#,
---    ""]
-
 private
 qtuwu : PrettyOpts -> List String
 qtuwu opts =

exe/Options.idr

@@ -1,258 +0,0 @@
-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

@@ -1,59 +0,0 @@
-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, pretty-show, quox-lib
+depends = base, contrib, elab-util, sop, quox-lib
 
 executable = quox
 main = Main

golden-tests/Tests.idr

@@ -1,15 +0,0 @@
-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

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

golden-tests/run-tests.sh

@@ -1,10 +0,0 @@
-#!/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

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

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

@@ -1,33 +0,0 @@
--- 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

@@ -1,9 +0,0 @@
-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

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

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

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

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

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

golden-tests/tests/hello/expected

@@ -1,12 +0,0 @@
-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

@@ -1,7 +0,0 @@
-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

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

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

@@ -1,3 +0,0 @@
-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

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

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

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

golden-tests/tests/isprop-subsing/expected

@@ -1,2 +0,0 @@
-0.IsProp : 1.★ → ★
-0.feq : 1.(A : ★) → 1.(f : IsProp A) → 1.(g : IsProp A) → f ≡ g : IsProp A

golden-tests/tests/isprop-subsing/isprop-subsing.quox

@@ -1,4 +0,0 @@
-def0 IsProp : ★ → ★ = λ A ⇒ (x y : A) → x ≡ y : A
-
-def0 feq : (A : ★) → (f g : IsProp A) → f ≡ g : IsProp A =
-  λ A f g ⇒ δ _ ⇒ f

golden-tests/tests/isprop-subsing/run

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

golden-tests/tests/it-5/expected

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

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

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

golden-tests/tests/it-5/run

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

golden-tests/tests/lib.sh

@@ -1,18 +0,0 @@
-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

@@ -1,16 +0,0 @@
-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

@@ -1,8 +0,0 @@
-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

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

golden-tests/tests/load/run

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

golden-tests/tests/regularity/expected

@@ -1 +0,0 @@
-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

@@ -1,12 +0,0 @@
--- 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

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

golden-tests/tests/useless-coe/coe.quox

@@ -1,9 +0,0 @@
--- non-dependent coe should reduce to its body
-
-def five  : ℕ = 5
-def five? : ℕ = coe ℕ 5
-
-def eq : five ≡ five? : ℕ = δ _ ⇒ 5
-
-def subst1 : 0.(P : ℕ → ★) → P five  → P five? = λ P p ⇒ p
-def subst2 : 0.(P : ℕ → ★) → P five? → P five  = λ P p ⇒ p

golden-tests/tests/useless-coe/expected

@@ -1,5 +0,0 @@
-ω.five : ℕ
-ω.five? : ℕ
-ω.eq : five ≡ five? : ℕ
-ω.subst1 : 0.(P : 1.ℕ → ★) → 1.(P five) → P five?
-ω.subst2 : 0.(P : 1.ℕ → ★) → 1.(P five?) → P five

golden-tests/tests/useless-coe/run

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

lib/Control/Monad/ST/Extra.idr

@@ -1,82 +0,0 @@
-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/BoolExtra.idr

@@ -3,8 +3,8 @@ module Quox.BoolExtra
 import public Data.Bool
 
 
-export infixr 5 `andM`
-export infixr 4 `orM`
+infixr 5 `andM`
+infixr 4 `orM`
 
 public export
 andM, orM : Monad m => m Bool -> m Bool -> m Bool

lib/Quox/CharExtra.idr

@@ -166,10 +166,3 @@ 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

@@ -1,33 +0,0 @@
-||| 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,13 +6,16 @@ import Quox.Name
 
 import Data.DPair
 import Data.Nat
+import Data.Fin
 import Data.Singleton
 import Data.SnocList
 import Data.SnocVect
 import Data.Vect
 import Control.Monad.Identity
+import Derive.Prelude
 
 %default total
+%language ElabReflection
 
 
 ||| a sequence of bindings under an existing context. each successive element
@@ -58,7 +61,6 @@ 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
@@ -85,6 +87,13 @@ export %inline
 toSnocList' : Telescope' a _ _ -> SnocList a
 toSnocList' = toSnocListWith id
 
+export %inline
+toSnocListRelevant : {n1 : Nat} -> Telescope tm n1 n2 -> SnocList (n ** tm n)
+toSnocListRelevant tel = toSnocList' $ snd $ go tel where
+  go : Telescope tm n1 n2' -> (Singleton n2', Telescope' (n ** tm n) n1 n2')
+  go [<]        = (Val n1, [<])
+  go (tel :< x) = let (Val n, tel) = go tel in (Val (S n), tel :< (n ** x))
+
 export %inline
 toList : Telescope tm _ _ -> List (Exists tm)
 toList = toListWith (Evidence _)
@@ -109,17 +118,10 @@ 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 n = tabulateLT n (\i => f i)
--- [todo] fixup argument order lol
+tabulate f 0     = [<]
+tabulate f (S k) = tabulate f k :< f k
 
 public export
 replicate : (n : Nat) -> a -> Context' a n
@@ -145,34 +147,34 @@ tel ++ (sx :< x) = (tel ++ sx) :< x
 
 public export
 getShiftWith : (forall from, to. tm from -> Shift from to -> tm to) ->
-               Shift len out -> Context tm len -> Var len -> tm out
-getShiftWith shft by (ctx :< t) VZ     = t `shft` ssDown by
-getShiftWith shft by (ctx :< t) (VS i) = getShiftWith shft (ssDown by) ctx i
+               Shift len out -> Context tm len -> Fin len -> tm out
+getShiftWith shft by (ctx :< t) FZ     = t `shft` ssDown by
+getShiftWith shft by (ctx :< t) (FS i) = getShiftWith shft (ssDown by) ctx i
 
 public export %inline
-getShift : CanShift tm => Shift len out -> Context tm len -> Var len -> tm out
+getShift : CanShift tm => Shift len out -> Context tm len -> Fin len -> tm out
 getShift = getShiftWith (//)
 
 public export %inline
 getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
-          Context tm len -> Var len -> tm len
+          Context tm len -> Fin len -> tm len
 getWith shft = getShiftWith shft SZ
 
-export infixl 8 !!
+infixl 8 !!
 public export %inline
-(!!) : CanShift tm => Context tm len -> Var len -> tm len
+(!!) : CanShift tm => Context tm len -> Fin len -> tm len
 (!!) = getWith (//)
 
-export infixl 8 !!!
+infixl 8 !!!
 public export %inline
-(!!!) : Context' tm len -> Var len -> tm
+(!!!) : Context' tm len -> Fin len -> tm
 (!!!) = getWith const
 
 public export
 find : Alternative f =>
-       (forall n. tm n -> Bool) -> Context tm len -> f (Var len)
+       (forall n. tm n -> Bool) -> Context tm len -> f (Fin len)
 find p [<]        = empty
-find p (ctx :< x) = (guard (p x) $> VZ) <|> (VS <$> find p ctx)
+find p (ctx :< x) = (guard (p x) $> FZ) <|> (FS <$> find p ctx)
 
 
 export
@@ -189,12 +191,6 @@ 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)) ->
@@ -206,7 +202,7 @@ parameters {auto _ : Applicative f}
   traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
   traverse' f = traverse f
 
-  export infixl 3 `app`
+  infixl 3 `app`
   ||| like `(<*>)` but with effects
   export
   app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
@@ -273,17 +269,16 @@ unzip3 (tel :< (x, y, z)) =
 
 
 public export
-lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
-lengthPrf [<]        = Element 0 Refl
+lengthPrf : Telescope _ from to -> (len ** len + from = to)
+lengthPrf [<]        = (0 ** Refl)
 lengthPrf (tel :< _) =
-  let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
+  let len = lengthPrf tel in (S len.fst ** cong S len.snd)
 
 export
-lengthPrf0 : Context _ to -> Singleton to
+lengthPrf0 : Context _ to -> (len ** len = to)
 lengthPrf0 ctx =
-  let Element len prf = lengthPrf ctx in
-  rewrite sym prf `trans` plusZeroRightNeutral len in
-  [|len|]
+  let len = lengthPrf ctx in
+  (len.fst ** rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
 
 public export %inline
 length : Telescope {} -> Nat
@@ -302,10 +297,6 @@ 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
@@ -340,6 +331,14 @@ export %inline
     where Show (Exists tm) where showPrec d t = showPrec d t.snd
 
 
+export
+implementation [ShowTelRelevant]
+  {n1 : Nat} -> ({n : Nat} -> Show (f n)) => Show (Telescope f n1 n2)
+where
+  showPrec d = showPrec d . toSnocListRelevant
+    where Show (n : Nat ** f n) where showPrec d (_ ** t) = showPrec d t
+
+
 parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
            (nameHL : HL)
            (pterm : forall n. BContext n -> tm n -> Eff Pretty (Doc opts))
@@ -365,4 +364,4 @@ parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
 namespace BContext
   export
   toNames : BContext n -> SnocList BaseName
-  toNames = foldl (\xs, x => xs :< x.val) [<]
+  toNames = foldl (\xs, x => xs :< x.name) [<]

lib/Quox/Definition.idr

@@ -2,12 +2,9 @@ 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
 
 
@@ -26,24 +23,18 @@ namespace DefBody
 public export
 record Definition where
   constructor MkDef
-  qty    : GQty
-  type0  : Term 0 0
-  body0  : DefBody
-  scheme : Maybe String
-  isMain : Bool
-  loc_   : Loc
+  qty   : GQty
+  type0 : Term 0 0
+  body0 : DefBody
+  loc_  : Loc
 
 public export %inline
-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_}
+mkPostulate : GQty -> (type0 : Term 0 0) -> Loc -> Definition
+mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_}
 
 public export %inline
-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_}
+mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition
+mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, loc_}
 
 export Located Definition where def.loc = def.loc_
 export Relocatable Definition where setLoc loc = {loc_ := loc}
@@ -54,51 +45,27 @@ 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
-  (.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
+  toElim : Definition -> Maybe $ Elim d n
+  toElim def = pure $ Ann !def.term def.type def.loc
 
 
 public export %inline
 isZero : Definition -> Bool
-isZero g = g.qty == GZero
+isZero g = g.qty.fst == Zero
 
 
 public export
-NDefinition : Type
-NDefinition = (Name, Definition)
+data DefEnvTag = DEFS
 
 public export
 Definitions : Type
 Definitions = SortedMap Name Definition
 
-public export
-data DefEnvTag = DEFS
-
 public export
 DefsReader : Type -> Type
 DefsReader = ReaderL DEFS Definitions
@@ -107,21 +74,7 @@ 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
-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
+lookupElim : {d, n : Nat} -> Name -> Definitions -> Maybe (Elim d n)
+lookupElim x defs = toElim !(lookup x defs)

lib/Quox/Displace.idr

@@ -2,8 +2,6 @@ module Quox.Displace
 
 import Quox.Syntax
 
-%default total
-
 
 parameters (k : Universe)
   namespace Term
@@ -16,7 +14,6 @@ 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
@@ -27,18 +24,14 @@ 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 (Nat n loc) = Nat n loc
+    doDisplace (Nat loc) = Nat loc
+    doDisplace (Zero loc) = Zero 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) (assert_total $ map doDisplace th))
+      CloT (Sub (doDisplace t) (map doDisplace th))
     doDisplace (DCloT (Sub t th)) =
       DCloT (Sub (doDisplace t) th)
 
@@ -54,11 +47,8 @@ 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)
-               (assert_total $ map doDisplace arms) loc
+      CaseEnum qty (doDisplace tag) (doDisplaceS ret) (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
@@ -75,9 +65,9 @@ parameters (k : Universe)
            (doDisplaceDS zero) (doDisplaceDS one) loc
     doDisplace (TypeCase ty ret arms def loc) =
       TypeCase (doDisplace ty) (doDisplace ret)
-               (assert_total $ map doDisplaceS arms) (doDisplace def) loc
+               (map doDisplaceS arms) (doDisplace def) loc
     doDisplace (CloE (Sub e th)) =
-      CloE (Sub (doDisplace e) (assert_total $ map doDisplace th))
+      CloE (Sub (doDisplace e) (map doDisplace th))
     doDisplace (DCloE (Sub e th)) =
       DCloE (Sub (doDisplace e) th)
 

lib/Quox/EffExtra.idr

@@ -2,7 +2,6 @@ module Quox.EffExtra
 
 import public Control.Eff
 
-import Control.Monad.ST.Extra
 import Data.IORef
 
 
@@ -27,40 +26,48 @@ local_ : Has (State s) fs => s -> Eff fs a -> Eff fs a
 local_ = localAt_ ()
 
 
-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 ()
+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}
 
+private
+0 ioNotState : Not (IO = StateL _ _)
+ioNotState Refl impossible
 
 export
-handleStateIORef : HasIO m => IORef st -> StateL lbl st a -> m a
-handleStateIORef r Get     = readIORef r
-handleStateIORef r (Put s) = writeIORef r s
+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 ()
 
-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) ->
@@ -73,77 +80,23 @@ subsetSelf : Length xs => Subset xs xs
 subsetSelf = subsetWith id
 
 export
-subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
-subsetTail _ = subsetWith S
-
+subsetTail : Length xs => Subset xs (x :: xs)
+subsetTail = subsetWith S
 
 
+-- [fixme] allow the error to be anywhere in the effect list
 export
-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
+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)
 
 export %inline
-ioLeft : e -> IOErr e a
-ioLeft = IOE . pure . Left
+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]

lib/Quox/FinExtra.idr

@@ -0,0 +1,44 @@
+module Quox.FinExtra
+
+import public Data.Fin
+import Quox.Decidable
+
+public export
+data LT : Rel (Fin n) where
+  LTZ : FZ `LT` FS i
+  LTS : i `LT` j -> FS i `LT` FS j
+%builtin Natural FinExtra.LT
+%name FinExtra.LT lt
+
+public export %inline
+GT : Rel (Fin n)
+GT = flip LT
+
+export
+Transitive (Fin n) LT where
+  transitive LTZ     (LTS _) = LTZ
+  transitive (LTS p) (LTS q) = LTS $ transitive p q
+
+export Uninhabited (i `FinExtra.LT` i) where uninhabited (LTS p) = uninhabited p
+export Uninhabited (FS i `LT` FZ) where uninhabited _ impossible
+
+
+public export
+data Compare : Rel (Fin n) where
+  IsLT : (lt : i `LT` j) -> Compare i j
+  IsEQ :                    Compare i i
+  IsGT : (gt : i `GT` j) -> Compare i j
+%name Compare cmp
+
+export
+compareS : Compare i j -> Compare (FS i) (FS j)
+compareS (IsLT lt) = IsLT (LTS lt)
+compareS IsEQ      = IsEQ
+compareS (IsGT gt) = IsGT (LTS gt)
+
+export
+compareP : (i, j : Fin n) -> Compare i j
+compareP FZ     FZ     = IsEQ
+compareP FZ     (FS j) = IsLT LTZ
+compareP (FS i) FZ     = IsGT LTZ
+compareP (FS i) (FS j) = compareS $ compareP i j

lib/Quox/FreeVars.idr

@@ -1,310 +0,0 @@
-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,7 +1,6 @@
 ||| file locations
 module Quox.Loc
 
-import Quox.PrettyValExtra
 import public Text.Bounded
 import Data.SortedMap
 import Derive.Prelude
@@ -13,12 +12,12 @@ public export
 FileName : Type
 FileName = String
 
-%runElab derive "Bounds" [Ord, PrettyVal]
+%runElab derive "Bounds" [Ord]
 
 public export
 data Loc_ = NoLoc | YesLoc FileName Bounds
 %name Loc_ loc
-%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal]
+%runElab derive "Loc_" [Eq, Ord, Show]
 
 
 ||| a wrapper for locations which are always considered equal
@@ -40,18 +39,6 @@ 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_
@@ -108,7 +95,7 @@ extendL : Loc -> Loc -> Loc
 extendL l1 l2 = l1 `extend'` l2.bounds
 
 
-export infixr 1 `or_`, `or`
+infixr 1 `or_`, `or`
 export %inline
 or_ : Loc_ -> Loc_ -> Loc_
 or_ l1@(YesLoc {}) _  = l1
@@ -118,11 +105,6 @@ 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
@@ -131,22 +113,9 @@ 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

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

@@ -1,13 +1,19 @@
 module Quox.NatExtra
 
 import public Data.Nat
+import public Data.Nat.Views
 import Data.Nat.Division
 import Data.SnocList
 import Data.Vect
-import Data.String
+import Syntax.PreorderReasoning
 
 %default total
 
+infixl 8 `shiftL`, `shiftR`
+infixl 7 .&.
+infixl 6 `xor`
+infixl 5 .|.
+
 
 public export
 data LTE' : Nat -> Nat -> Type where
@@ -53,42 +59,151 @@ parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char)
   showAtBase : Nat -> String
   showAtBase = pack . showAtBase' []
 
-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)
+export
+showHex : Nat -> String
+showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
 
 
-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
+export
+0 notEvenOdd : (a, b : Nat) -> Not (a + a = S (b + b))
+notEvenOdd 0     b prf = absurd prf
+notEvenOdd (S a) b prf =
+  notEvenOdd b a $ Calc $
+    |~ b + b
+    ~~ a + S a   ..<(inj S prf)
+    ~~ S (a + a) ..<(plusSuccRightSucc {})
 
-  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
+0 doubleInj : (m, n : Nat) -> m + m = n + n -> m = n
+doubleInj 0     0     _   = Refl
+doubleInj (S m) (S n) prf =
+  cong S $ doubleInj m n $
+  inj S $ Calc $
+    |~ S (m + m)
+    ~~ m + S m   ...(plusSuccRightSucc {})
+    ~~ n + S n   ...(inj S prf)
+    ~~ S (n + n) ..<(plusSuccRightSucc {})
 
-  export %inline
-  fromHex : String -> Maybe Int
-  fromHex str = do guard $ str /= ""; fromHex' 0 str
+export
+0 halfDouble : (n : Nat) -> half (n + n) = HalfEven n
+halfDouble n with (half (n + n)) | (n + n) proof nn
+  _ | HalfOdd  k | S (k + k) = void $ notEvenOdd n k nn
+  _ | HalfEven k | k + k     = rewrite doubleInj n k nn in Refl
 
-namespace Nat
-  export
-  fromHexit : Char -> Maybe Nat
-  fromHexit = map cast . Int.fromHexit
+export
+floorHalf : Nat -> Nat
+floorHalf k = case half k of
+  HalfOdd  n => n
+  HalfEven n => n
 
-  export %inline
-  fromHex : String -> Maybe Nat
-  fromHex = map cast . Int.fromHex
+
+||| like in intercal ☺
+|||
+||| take all the bits of `subj` that are set in `mask`, and squish them down
+||| towards the lsb
+public export
+select : (mask, subj : Nat) -> Nat
+select mask subj = go 1 (halfRec mask) subj 0 where
+  go : forall mask. Nat -> HalfRec mask -> Nat -> Nat -> Nat
+  go bit HalfRecZ            subj res = res
+  go bit (HalfRecEven _ rec) subj res = go bit rec (floorHalf subj) res
+  go bit (HalfRecOdd  _ rec) subj res = case half subj of
+    HalfOdd  subj => go (bit + bit) rec subj (res + bit)
+    HalfEven subj => go (bit + bit) rec subj res
+
+||| take the i least significant bits of subj (where i = popCount mask),
+||| and place them where mask's set bits are
+|||
+||| left inverse of select if mask .|. subj = mask
+public export
+spread : (mask, subj : Nat) -> Nat
+spread mask subj = go 1 (halfRec mask) subj 0 where
+  go : forall mask. Nat -> HalfRec mask -> Nat -> Nat -> Nat
+  go bit HalfRecZ            subj res = res
+  go bit (HalfRecEven _ rec) subj res = go (bit + bit) rec subj res
+  go bit (HalfRecOdd  _ rec) subj res = case half subj of
+    HalfOdd  subj => go (bit + bit) rec subj (res + bit)
+    HalfEven subj => go (bit + bit) rec subj res
+
+
+
+public export
+data BitwiseRec : Nat -> Nat -> Type where
+  BwDone : BitwiseRec 0 0
+  Bw00   : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
+           BitwiseRec (m + m) (n + n)
+  Bw01   : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
+           BitwiseRec (m + m) (S (n + n))
+  Bw10   : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
+           BitwiseRec (S (m + m)) (n + n)
+  Bw11   : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
+           BitwiseRec (S (m + m)) (S (n + n))
+
+export
+bitwiseRec : (m, n : Nat) -> BitwiseRec m n
+bitwiseRec m n = go (halfRec m) (halfRec n) where
+  go : forall m, n. HalfRec m -> HalfRec n -> BitwiseRec m n
+  go HalfRecZ           HalfRecZ           = BwDone
+  go HalfRecZ           (HalfRecEven n nr) = Bw00 0 n $ go HalfRecZ nr
+  go HalfRecZ           (HalfRecOdd  n nr) = Bw01 0 n $ go HalfRecZ nr
+  go (HalfRecEven m mr) HalfRecZ           = Bw00 m 0 $ go mr HalfRecZ
+  go (HalfRecEven m mr) (HalfRecEven n nr) = Bw00 m n $ go mr nr
+  go (HalfRecEven m mr) (HalfRecOdd  n nr) = Bw01 m n $ go mr nr
+  go (HalfRecOdd  m mr) HalfRecZ           = Bw10 m 0 $ go mr HalfRecZ
+  go (HalfRecOdd  m mr) (HalfRecEven n nr) = Bw10 m n $ go mr nr
+  go (HalfRecOdd  m mr) (HalfRecOdd  n nr) = Bw11 m n $ go mr nr
+
+public export
+bitwise : (Bool -> Bool -> Bool) -> Nat -> Nat -> Nat
+bitwise f m n = go 1 (bitwiseRec m n) 0 where
+  one : Bool -> Bool -> Nat -> Nat -> Nat
+  one p q bit res = if f p q then bit + res else res
+  go : forall m, n. Nat -> BitwiseRec m n -> Nat -> Nat
+  go bit BwDone         res = res
+  go bit (Bw00 m n rec) res = go (bit + bit) rec $ one False False bit res
+  go bit (Bw01 m n rec) res = go (bit + bit) rec $ one False True  bit res
+  go bit (Bw10 m n rec) res = go (bit + bit) rec $ one True  False bit res
+  go bit (Bw11 m n rec) res = go (bit + bit) rec $ one True  True  bit res
+
+public export
+(.&.) : Nat -> Nat -> Nat
+(.&.) = bitwise $ \p, q => p && q
+
+private %foreign "scheme:blodwen-and"
+primAnd : Nat -> Nat -> Nat
+%transform "NatExtra.(.&.)" NatExtra.(.&.) m n = primAnd m n
+
+public export
+(.|.) : Nat -> Nat -> Nat
+(.|.) = bitwise $ \p, q => p || q
+
+private %foreign "scheme:blodwen-or"
+primOr : Nat -> Nat -> Nat
+%transform "NatExtra.(.|.)" NatExtra.(.|.) m n = primOr m n
+
+public export
+xor : Nat -> Nat -> Nat
+xor = bitwise (/=)
+
+private %foreign "scheme:blodwen-xor"
+primXor : Nat -> Nat -> Nat
+%transform "NatExtra.xor" NatExtra.xor m n = primXor m n
+
+
+public export
+shiftL : Nat -> Nat -> Nat
+shiftL n 0     = n
+shiftL n (S i) = shiftL (n + n) i
+
+private %foreign "scheme:blodwen-shl"
+primShiftL : Nat -> Nat -> Nat
+%transform "NatExtra.shiftL" NatExtra.shiftL n i = primShiftL n i
+
+public export
+shiftR : Nat -> Nat -> Nat
+shiftR n 0     = n
+shiftR n (S i) = shiftL (floorHalf n) i
+
+private %foreign "scheme:blodwen-shr"
+primShiftR : Nat -> Nat -> Nat
+%transform "NatExtra.shiftR" NatExtra.shiftR n i = primShiftR n i

lib/Quox/No.idr

@@ -43,7 +43,7 @@ parameters {0 a, b : Bool}
   noOr2 = snd . noOr
 
 
-export infixr 1 `orNo`
+infixr 1 `orNo`
 export %inline
 orNo : No a -> No b -> No (a || b)
 orNo Ah Ah = Ah
@@ -52,8 +52,3 @@ 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/OPE.idr

@@ -0,0 +1,76 @@
+||| "order preserving embeddings", for recording a correspondence between
+||| a smaller scope and part of a larger one.
+module Quox.OPE
+
+import Quox.NatExtra
+import Data.Nat
+
+%default total
+
+
+public export
+data OPE : Nat -> Nat -> Type where
+  Id   : OPE n n
+  Drop : OPE m n -> OPE m     (S n)
+  Keep : OPE m n -> OPE (S m) (S n)
+%name OPE p, q
+
+public export %inline Injective Drop where injective Refl = Refl
+public export %inline Injective Keep where injective Refl = Refl
+
+public export
+opeZero : {n : Nat} -> OPE 0 n
+opeZero {n = 0}   = Id
+opeZero {n = S n} = Drop opeZero
+
+public export
+(.) : OPE m n -> OPE n p -> OPE m p
+p      . Id     = p
+Id     . q      = q
+p      . Drop q = Drop $ p . q
+Drop p . Keep q = Drop $ p . q
+Keep p . Keep q = Keep $ p . q
+
+public export
+toLTE : {m : Nat} -> OPE m n -> m `LTE` n
+toLTE Id       = reflexive
+toLTE (Drop p) = lteSuccRight $ toLTE p
+toLTE (Keep p) = LTESucc      $ toLTE p
+
+
+public export
+keepN : (n : Nat) -> OPE a b -> OPE (n + a) (n + b)
+keepN 0     p = p
+keepN (S n) p = Keep $ keepN n p
+
+public export
+dropInner' : LTE' m n -> OPE m n
+dropInner' LTERefl      = Id
+dropInner' (LTESuccR p) = Drop $ dropInner' $ force p
+
+public export
+dropInner : {n : Nat} -> LTE m n -> OPE m n
+dropInner = dropInner' . fromLte
+
+public export
+dropInnerN : (m : Nat) -> OPE n (m + n)
+dropInnerN 0     = Id
+dropInnerN (S m) = Drop $ dropInnerN m
+
+
+public export
+interface Tighten t where
+  tighten : OPE m n -> t n -> Maybe (t m)
+
+parameters {auto _ : Tighten t}
+  export %inline
+  tightenInner : {n : Nat} -> m `LTE` n -> t n -> Maybe (t m)
+  tightenInner = tighten . dropInner
+
+  export %inline
+  tightenN : (m : Nat) -> t (m + n) -> Maybe (t n)
+  tightenN m = tighten $ dropInnerN m
+
+  export %inline
+  tighten1 : t (S n) -> Maybe (t n)
+  tighten1 = tightenN 1

lib/Quox/Parser/FromParser.idr

@@ -1,31 +1,39 @@
 ||| 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
 
-%default total
+
+public export
+NDefinition : Type
+NDefinition = (Name, Definition)
+
+public export
+IncludePath : Type
+IncludePath = List String
+
+public export
+SeenFiles : Type
+SeenFiles = SortedSet String
 
 
 public export
@@ -33,50 +41,27 @@ data StateTag = NS | SEEN
 
 public export
 FromParserPure : List (Type -> Type)
-FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
+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]
 
 public export
 FromParserIO : List (Type -> Type)
-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)
-  }
+FromParserIO = FromParserPure ++ LoadFile'
 
 
 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 $ MkPName [<] x) b $
+  fromBaseName x = maybe (f $ MakePName [<] x) b $
                    Context.find (\y => y.name == Just x) xs
 
   private
@@ -128,10 +113,11 @@ 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 = unless (isNothing u) (throw $ DisplacedBoundVar loc x) $> BT i loc
-
+  bound i = do whenJust u $ \u => throw $ DisplacedBoundVar loc x
+               pure $ E $ B i loc
   free : PName -> Eff FromParserPure (Term d n)
-  free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
+  free x = do x <- avoidDim ds loc x
+              resolveName !(getAt NS) loc x u
 
 mutual
   export
@@ -141,9 +127,6 @@ 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
@@ -174,26 +157,17 @@ 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 loc ds ns arms
+        <*> assert_total fromPTermEnumArms ds ns arms
         <*> pure loc
 
-    NAT loc => pure $ NAT loc
-    Nat n loc => pure $ Nat n loc
+    Nat loc => pure $ Nat loc
+    Zero loc => pure $ Zero 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
@@ -202,11 +176,12 @@ mutual
         <*> fromPTermTScope ds ns [< s, ih] suc
         <*> pure loc
 
-    Enum strs loc => do
-      let set = SortedSet.fromList strs
-      unless (length strs == length (SortedSet.toList set)) $
-        throw $ DuplicatesInEnumType loc strs
-      pure $ Enum set 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
 
     Tag str loc => pure $ Tag str loc
 
@@ -263,22 +238,13 @@ 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 : Loc -> Context' PatVar d -> Context' PatVar n ->
+  fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
                       List (PTagVal, PTerm) ->
                       Eff FromParserPure (CaseEnumArms d n)
-  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
+  fromPTermEnumArms ds ns =
+    map SortedMap.fromList .
+    traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
 
   private
   fromPTermElim : Context' PatVar d -> Context' PatVar n ->
@@ -297,7 +263,7 @@ mutual
     if all isUnused xs then
       SN <$> fromPTermWith ds ns t
     else
-      SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
+      ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
 
   private
   fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
@@ -305,9 +271,9 @@ mutual
                     Eff FromParserPure (DScopeTermN s d n)
   fromPTermDScope ds ns xs t =
     if all isUnused xs then
-      SN {f = \d => Term d n} <$> fromPTermWith ds ns t
+      SN <$> fromPTermWith ds ns t
     else
-      SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
+      DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
 
 
 export %inline
@@ -316,110 +282,72 @@ fromPTerm = fromPTermWith [<] [<]
 
 
 export
-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
+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
+
 
 export
-fromPBaseNameNS : Has (StateL NS Mods) fs => PBaseName -> Eff fs Name
+fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name
 fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
 
-
 private
-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)
-
+liftTC : TC a -> Eff FromParserPure a
+liftTC act = do
+  res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act
+  rethrow $ mapFst WrapTypeError res
 
 export covering
 fromPDef : PDefinition -> Eff FromParserPure NDefinition
-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
+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)
 
 export covering
 fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
-fromPDecl (PDef def) =
-  maybeFail def.fail def.loc $ singleton <$> fromPDef def
+fromPDecl (PDef def) = singleton <$> fromPDef def
 fromPDecl (PNs  ns)  =
-  maybeFail ns.fail ns.loc $
   localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
-fromPDecl (PPrag prag) =
-  case prag of
-    PLogPush p _ => Log.push p $> []
-    PLogPop    _ => Log.pop    $> []
+
+
+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
 
 mutual
   export covering
   loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
   loadProcessFile loc file =
-    case !(loadFile loc file) of
-      Just tl => concat <$> traverse fromPTopLevel tl
+    case !(lift $ loadFile loc file) of
+      Just inp => do
+        tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
+        concat <$> traverse fromPTopLevel tl
       Nothing => pure []
 
   ||| populates the `defs` field of the state
@@ -427,3 +355,28 @@ 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,14 +1,11 @@
 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.(<++>)
 
 
@@ -24,34 +21,26 @@ ParseError = Parser.Error
 public export
 data Error =
     AnnotationNeeded Loc (NameContexts d n) (Term d n)
-  | DuplicatesInEnumType Loc (List TagVal)
-  | DuplicatesInEnumCase Loc (List TagVal)
+  | DuplicatesInEnum Loc (List TagVal)
   | TermNotInScope Loc Name
   | DimNotInScope Loc PBaseName
   | QtyNotGlobal Loc Qty
   | DimNameInTerm Loc PBaseName
   | DisplacedBoundVar Loc PName
   | WrapTypeError TypeError
-  | AlreadyExists Loc Name
-  | LoadError Loc FilePath FileError
-  | ExpectedFail Loc
-  | SchemeOnNamespace Loc Mods
-  | MainOnNamespace Loc Mods
-  | WrongFail String Error Loc
+  | LoadError Loc String FileError
   | 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
-    Other msg => pure $ text msg
-    NoRuleApply => case char of
-      Just char => pure $ text "unrecognised character: \{show char}"
-      Nothing   => pure $ text "unexpected end of input"
+    EndInput    => pure "unexpected end of input"
+    NoRuleApply => pure $ text "unrecognised character: \{show char}"
     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
@@ -72,23 +61,19 @@ prettyParseError file (ParseError errs) =
     traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
 
 
-parameters {opts : LayoutOpts} (showContext : Bool)
+parameters (showContext : Bool)
   export
-  prettyError : Error -> Eff Pretty (Doc opts)
+  prettyError : {opts : _} -> 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 (DuplicatesInEnumType loc tags) =
+  prettyError (DuplicatesInEnum 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"])|]
@@ -115,32 +100,10 @@ parameters {opts : LayoutOpts} (showContext : Bool)
   prettyError (WrapTypeError err) =
     Typing.prettyError showContext $ trimContext 2 err
 
-  prettyError (AlreadyExists loc name) = pure $
+  prettyError (LoadError loc str err) = pure $
     vsep [!(prettyLoc loc),
-          sep [!(prettyFree name), "has already been defined"]]
-
-  prettyError (LoadError loc file err) = pure $
-    vsep [!(prettyLoc loc),
-          "couldn't load file" <++> text file,
+          "couldn't load file" <++> text str,
           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,7 +1,6 @@
 module Quox.Parser.Lexer
 
 import Quox.CharExtra
-import Quox.NatExtra
 import Quox.Name
 import Data.String.Extra
 import Data.SortedMap
@@ -20,7 +19,7 @@ import Derive.Prelude
 ||| @ Reserved reserved token
 ||| @ Name name, possibly qualified
 ||| @ Nat nat literal
-||| @ Str string literal
+||| @ String string literal
 ||| @ Tag tag literal
 ||| @ TYPE "Type" or "★" with ascii nat directly after
 ||| @ Sup superscript or ^ number (displacement, or universe for ★)
@@ -35,27 +34,16 @@ data Token =
   | Sup Nat
 %runElab derive "Token" [Eq, Ord, Show]
 
-||| 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
+-- token or whitespace
 public export
-data ExtToken = Skip | Invalid String String | T Token
-%runElab derive "ExtToken" [Eq, Ord, Show]
+0 TokenW : Type
+TokenW = Maybe Token
 
 
-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    : ErrorReason
+  reason    : StopReason
   line, col : Int
   ||| `Nothing` if the error is at the end of the input
   char      : Maybe Char
@@ -64,118 +52,77 @@ record Error where
 
 
 private
-skip : Lexer -> Tokenizer ExtToken
-skip t = match t $ const Skip
+skip : Lexer -> Tokenizer TokenW
+skip t = match t $ const Nothing
 
 private
-tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
-tmatch t f = match t (T . f)
+match : Lexer -> (String -> Token) -> Tokenizer TokenW
+match t f = Tokenizer.match t (Just . f)
+%hide Tokenizer.match
 
 
+private
+name : Tokenizer TokenW
+name = match name $ Name . fromListP . split (== '.') . normalizeNfc
+
+||| [todo] escapes other than `\"` and (accidentally) `\\`
 export
-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"
+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
 
 private
-string : Tokenizer ExtToken
-string = match stringLit $ fromStringLit Str
-
-
-%hide binLit
-%hide octLit
-%hide hexLit
+string : Tokenizer TokenW
+string = match stringLit (Str . fromStringLit)
 
 private
-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
-
+nat : Tokenizer TokenW
+nat = match (some (range '0' '9')) (Nat . cast)
 
 private
-tag : Tokenizer ExtToken
-tag = tmatch (is '\'' <+> name)      (Tag . drop 1)
-  <|>  match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1)
+tag : Tokenizer TokenW
+tag = match (is '\'' <+> name)      (Tag . drop 1)
+  <|> match (is '\'' <+> stringLit) (Tag . fromStringLit . 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 and ★¹/Type¹ are sequences of two tokens
+-- ★0, Type0. base ★/Type is a Reserved
 private
-universe : Tokenizer ExtToken
+universe : Tokenizer TokenW
 universe = universeWith "★" <|> universeWith "Type" where
-  universeWith : String -> Tokenizer ExtToken
+  universeWith : String -> Tokenizer TokenW
   universeWith pfx =
     let len = length pfx in
-    tmatch (exact pfx <+> digits) (TYPE . cast . drop len)
+    match (exact pfx <+> digits) (TYPE . cast . drop len)
 
 private
-sup : Tokenizer ExtToken
-sup = tmatch (some $ pred isSupDigit) (Sup . supToNat)
-  <|> tmatch (is '^' <+> digits)      (Sup . cast . drop 1)
+sup : Tokenizer TokenW
+sup = match (some $ pred isSupDigit) (Sup . supToNat)
+  <|> match (is '^' <+> digits)      (Sup . cast . drop 1)
 
 
 private %inline
@@ -187,11 +134,9 @@ 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);
-  |||        also a sequence ending in one of those, like `#[`, since the
-  |||        difference relates to lookahead
+  ||| @ Punc a character that doesn't show up in names (brackets, etc)
   public export
-  data Reserved1 = Word String | Sym String | Punc String
+  data Reserved1 = Word String | Sym String | Punc Char
   %runElab derive "Reserved1" [Eq, Ord, Show]
 
   ||| description of a token that might have unicode & ascii-only aliases
@@ -200,14 +145,17 @@ namespace Reserved
   %runElab derive "Reserved" [Eq, Ord, Show]
 
   public export
-  Sym1, Word1, Punc1 : String -> Reserved
-  Sym1  = Only . Sym
+  Sym1, Word1 : String -> Reserved
+  Sym1 = Only . Sym
   Word1 = Only . Word
+
+  public export
+  Punc1 : Char -> Reserved
   Punc1 = Only . Punc
 
 public export
 resString1 : Reserved1 -> String
-resString1 (Punc x) = x
+resString1 (Punc x) = singleton x
 resString1 (Word w) = w
 resString1 (Sym  s) = s
 
@@ -218,23 +166,17 @@ 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 ExtToken
+resTokenizer1 : Reserved1 -> String -> Tokenizer TokenW
 resTokenizer1 r str =
   let res : String -> Token := const $ Reserved str in
-  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
+  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
 
 ||| match a reserved token
 export
-resTokenizer : Reserved -> Tokenizer ExtToken
+resTokenizer : Reserved -> Tokenizer TokenW
 resTokenizer (Only r)   = resTokenizer1 r (resString1 r)
 resTokenizer (r `Or` s) =
   resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
@@ -246,8 +188,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 "=>",
@@ -255,16 +197,12 @@ 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",
@@ -272,71 +210,35 @@ 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 = 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
+IsReserved str = str `Elem` map resString reserved
 
 export
-tokens : Tokenizer ExtToken
+tokens : Tokenizer TokenW
 tokens = choice $
   map skip [pred isWhitespace,
             lineComment (exact "--" <+> reject symCont),
             blockComment (exact "{-") (exact "-}")] <+>
-  [universe] <+>  -- Type<i> takes precedence over bare Type
+  [universe] <+>  -- ★ᵢ takes precedence over bare ★
   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 toErrorReason reason of
-    Nothing => concatMap check res @{MonoidApplicative}
-    Just e  => Left $ Err {reason = e, line, col, char = index 0 str}
+  case reason of
+    EndInput => Right $ mapMaybe sequence res
+    _        => Left  $ Err {reason, line, col, char = index 0 str}

lib/Quox/Parser/LoadFile.idr

@@ -1,100 +0,0 @@
-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 (MkPName [<] b)) `(b)
+baseName = terminalMatch "unqualified name" `(Name (MakePName [<] b)) `(b)
 
 ||| dimension constant (0 or 1)
 export
@@ -149,12 +149,6 @@ 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
@@ -204,21 +198,18 @@ export
 enumType : Grammar True (List TagVal)
 enumType = delimSep "{" "}" "," bareTag
 
-||| e.g. `case1` or `case 1.`
+||| e.g. `case` 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ω")
-  <|> do resC "case"
-         qty fname <* needRes "." <|> defLoc fname (PQ One)
+  <|> delim "case" "." (qty fname)
 
 export
 qtyPatVar : FileName -> Grammar True (PQty, PatVar)
-qtyPatVar fname =
-      [|(,) (qty fname) (needRes "." *> patVar fname)|]
-  <|> [|(,) (defLoc fname $ PQ One) (patVar fname)|]
+qtyPatVar fname = [|(,) (qty fname) (needRes "." *> patVar fname)|]
 
 
 export
@@ -286,81 +277,19 @@ export
 universe1 : Grammar True Universe
 universe1 = universeTok <|> res "★" *> option 0 super
 
-
-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 `}`.
+||| argument/atomic term: single-token terms, or those with delimiters e.g.
+||| `[t]`
 export
 termArg : FileName -> Grammar True PTerm
 termArg fname = withLoc fname $
       [|TYPE universe1|]
-  <|> IOState <$ res "IOState"
   <|> [|Enum enumType|]
   <|> [|Tag tag|]
   <|> const <$> boxTerm fname
-  <|> NAT    <$ res "ℕ"
-  <|> Nat 0  <$ res "zero"
-  <|> [|Nat nat|]
-  <|> STRING <$ res "String"
-  <|> [|Str strLit|]
+  <|> Nat  <$ res "ℕ"
+  <|> Zero <$ res "zero"
+  <|> [|fromNat nat|]
   <|> [|V qname displacement|]
-  <|> const <$> caseTerm fname
   <|> const <$> tupleTerm fname
 
 export
@@ -440,10 +369,10 @@ eqTerm : FileName -> Grammar True PTerm
 eqTerm fname = withLoc fname $
   resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (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
+export
+succTerm : FileName -> Grammar True PTerm
+succTerm fname = withLoc fname $
+  resC "succ" *> mustWork [|Succ (termArg fname)|]
 
 ||| a dimension argument with an `@` prefix, or
 ||| a term argument with no prefix
@@ -451,32 +380,15 @@ 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 (appArg loc) head args
+  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
 
 ||| application term `f x @y z`, or other terms that look like application
 ||| like `succ` or `coe`.
@@ -488,8 +400,6 @@ appTerm fname =
   <|> splitUniverseTerm fname
   <|> eqTerm fname
   <|> succTerm fname
-  <|> fstTerm fname
-  <|> sndTerm fname
   <|> normalAppTerm fname
 
 export
@@ -528,6 +438,18 @@ 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 =
@@ -548,320 +470,105 @@ where
     rest <- optional $ resC "×" *> sepBy1 (res "×") (annTerm fname)
     pure $ foldr1 cross $ fst ::: maybe [] toList rest
 
-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
-
+public export
+PCaseArm : Type
+PCaseArm = (PCasePat, PTerm)
 
 export
-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
+caseArm : FileName -> Grammar True PCaseArm
+caseArm fname =
+  [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
 
 export
-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
+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
+
+-- export
 -- term : FileName -> Grammar True PTerm
 term fname = lamTerm fname
+         <|> caseTerm fname
          <|> piTerm fname
          <|> sigmaTerm fname
-         <|> letTerm fname
-
-
-export
-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 "#["
-
-export
-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
-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 ";"
-  either fatalError pure $ mkPDef attrs qty name $ PConcrete type term
-
-export
-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
 
+||| `def` alone means `defω`
 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
+defIntro : FileName -> Grammar True PQty
+defIntro fname =
+      withLoc fname (PQ Zero <$ resC "def0")
+  <|> withLoc fname (PQ Any  <$ resC "defω")
+  <|> do pos <- bounds $ resC "def"
+         let any = PQ Any $ makeLoc fname pos.bounds
+         option any $ qty fname <* needRes "."
+
+export
+definition : FileName -> Grammar True PDefinition
+definition fname = 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
+
+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
 where
   nsInner : Grammar True (List PDecl)
   nsInner = [] <$ resC "}"
         <|> [|(assert_total decl fname <* commit) :: assert_total nsInner|]
 
-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
+decl fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|]
 
 export
 load : FileName -> Grammar True PTopLevel
@@ -873,7 +580,7 @@ topLevel : FileName -> Grammar True PTopLevel
 topLevel fname = load fname <|> [|PD $ decl fname|]
 
 export
-input : FileName -> Grammar False PFile
+input : FileName -> Grammar False (List PTopLevel)
 input fname = [] <$ eof
           <|> [|(topLevel fname <* commit) :: assert_total input fname|]
 
@@ -882,5 +589,5 @@ lexParseTerm : FileName -> String -> Either Error PTerm
 lexParseTerm = lexParseWith . term
 
 export
-lexParseInput : FileName -> String -> Either Error PFile
+lexParseInput : FileName -> String -> Either Error (List PTopLevel)
 lexParseInput = lexParseWith . input

lib/Quox/Parser/Syntax.idr

@@ -3,8 +3,6 @@ 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
@@ -16,9 +14,9 @@ import Derive.Prelude
 public export
 data PatVar = Unused Loc | PV PBaseName Loc
 %name PatVar v
-%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PatVar" [Eq, Ord, Show]
 
-export %inline
+export
 Located PatVar where
   (Unused loc).loc = loc
   (PV _   loc).loc = loc
@@ -40,17 +38,17 @@ record PQty where
   val  : Qty
   loc_ : Loc
 %name PQty qty
-%runElab derive "PQty" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PQty" [Eq, Ord, Show]
 
-export %inline Located PQty where q.loc = q.loc_
+export 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, PrettyVal]
+  %runElab derive "PDim" [Eq, Ord, Show]
 
-export %inline
+export
 Located PDim where
   (K _ loc).loc = loc
   (V _ loc).loc = loc
@@ -58,7 +56,7 @@ Located PDim where
 public export
 data PTagVal = PT TagVal Loc
 %name PTagVal tag
-%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PTagVal" [Eq, Ord, Show]
 
 
 namespace PTerm
@@ -68,8 +66,6 @@ namespace PTerm
     data PTerm =
         TYPE Universe Loc
 
-      | IOState Loc
-
       | Pi PQty PatVar PTerm PTerm Loc
       | Lam PatVar PTerm Loc
       | App PTerm PTerm Loc
@@ -77,7 +73,6 @@ 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
@@ -86,11 +81,8 @@ namespace PTerm
       | DLam PatVar PTerm Loc
       | DApp PTerm PDim Loc
 
-      | NAT Loc
-      | Nat Nat Loc | Succ PTerm Loc
-
-      | STRING Loc  -- "String" is a reserved word in idris
-      | Str String Loc
+      | Nat Loc
+      | Zero Loc | Succ PTerm Loc
 
       | BOX PQty PTerm Loc
       | Box PTerm Loc
@@ -101,8 +93,6 @@ 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
@@ -113,43 +103,33 @@ namespace PTerm
       | CaseBox PatVar PTerm Loc
     %name PCaseBody body
 
-  public export %inline
-  Zero : Loc -> PTerm
-  Zero = Nat 0
+%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
 
-%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal]
-
-export %inline
+export
 Located PTerm where
-  (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
+  (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
 
-export %inline
+export
 Located PCaseBody where
   (CasePair _ _ loc).loc = loc
   (CaseEnum _   loc).loc = loc
@@ -157,45 +137,18 @@ 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
-  body   : PBody
-  fail   : PFail
-  main   : Bool
-  scheme : Maybe String
-  loc_   : Loc
+  qty  : PQty
+  name : PBaseName
+  type : Maybe PTerm
+  term : PTerm
+  loc_ : Loc
 %name PDefinition def
-%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PDefinition" [Eq, Ord, Show]
 
-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
+export Located PDefinition where def.loc = def.loc_
 
 mutual
   public export
@@ -203,49 +156,35 @@ mutual
     constructor MkPNamespace
     name  : Mods
     decls : List PDecl
-    fail  : PFail
     loc_  : Loc
   %name PNamespace ns
 
   public export
   data PDecl =
-      PDef  PDefinition
-    | PNs   PNamespace
-    | PPrag PPragma
+      PDef PDefinition
+    | PNs  PNamespace
   %name PDecl decl
-%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
+%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show]
 
-export %inline Located PNamespace where ns.loc = ns.loc_
+export Located PNamespace where ns.loc = ns.loc_
 
-export %inline
+export
 Located PDecl where
-  (PDef  d).loc    = d.loc
-  (PNs   ns).loc   = ns.loc
-  (PPrag prag).loc = prag.loc
+  (PDef def).loc = def.loc
+  (PNs  ns).loc  = ns.loc
 
 public export
 data PTopLevel = PD PDecl | PLoad String Loc
 %name PTopLevel t
-%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PTopLevel" [Eq, Ord, Show]
 
-export %inline
+export
 Located PTopLevel where
   (PD    decl).loc  = decl.loc
   (PLoad _ loc).loc = loc
 
 
 public export
-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
+fromNat : Nat -> Loc -> PTerm
+fromNat 0     loc = Zero loc
+fromNat (S k) loc = Succ (fromNat k loc) loc

lib/Quox/Pretty.idr

@@ -3,7 +3,6 @@ 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
@@ -41,7 +40,7 @@ data HL
 | Dim  | DVar | DVarErr
 | Qty  | Universe
 | Syntax
-| Constant
+| Tag
 %runElab derive "HL" [Eq, Ord, Show]
 
 
@@ -66,12 +65,11 @@ export %inline
 runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
                 Eff Pretty a -> a
 runPrettyWith prec flavor highlight indent act =
-  runST $ do
-    runEff act $ with Union.(::)
-      [handleStateSTRef !(newSTRef prec),
-       handleReaderConst flavor,
-       handleReaderConst highlight,
-       handleReaderConst indent]
+  extract $
+  evalStateAt PREC prec $
+  runReaderAt FLAVOR flavor $
+  runReaderAt HIGHLIGHT highlight $
+  runReaderAt INDENT indent act
 
 
 export %inline
@@ -86,65 +84,43 @@ toSGR DVarErr  = [SetForeground BrightGreen, SetStyle SingleUnderline]
 toSGR Qty      = [SetForeground BrightMagenta]
 toSGR Universe = [SetForeground BrightRed]
 toSGR Syntax   = [SetForeground BrightCyan]
-toSGR Constant = [SetForeground BrightRed]
+toSGR Tag      = [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 = runPrettyHL noHighlight
+runPretty = runPrettyWith Outer Unicode noHighlight 2
+
+export %inline
+runPrettyColor : Eff Pretty a -> a
+runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
 
 
 export %inline
-hl : {opts : LayoutOpts} -> HL -> Doc opts -> Eff Pretty (Doc opts)
+hl : {opts : _} -> HL -> Doc opts -> Eff Pretty (Doc opts)
 hl h doc = asksAt HIGHLIGHT $ \f => decorate (f h) doc
 
 
 export %inline
-indentD : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+indentD : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
 indentD doc = pure $ indent !(askAt INDENT) doc
 
 export %inline
-hangD : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
+hangD : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
 hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
 
 export %inline
-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
+hangDSingle : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
+hangDSingle d1 d2 =
+  pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2))
 
 
 export
-tightDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
+tightDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
               Eff Pretty (Doc opts)
 tightDelims l r inner = do
   l <- hl Delim $ text l
@@ -152,7 +128,7 @@ tightDelims l r inner = do
   pure $ hcat [l, inner, r]
 
 export
-looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
+looseDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
               Eff Pretty (Doc opts)
 looseDelims l r inner = do
   l <- hl Delim $ text l
@@ -162,39 +138,39 @@ looseDelims l r inner = do
   pure $ ifMultiline short long
 
 export %inline
-parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+parens : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
 parens = tightDelims "(" ")"
 
 export %inline
-bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+bracks : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
 bracks = tightDelims "[" "]"
 
 export %inline
-braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+braces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
 braces = looseDelims "{" "}"
 
 export %inline
-tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+tightBraces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
 tightBraces = tightDelims "{" "}"
 
 export %inline
-parensIf : {opts : LayoutOpts} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
+parensIf : {opts : _} -> 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 : LayoutOpts} -> List (Doc opts) -> Doc opts
+sepSingle : {opts : _} -> List (Doc opts) -> Doc opts
 sepSingle xs = ifMultiline (hsep xs) (vsep xs)
 
 export
-fillSep : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
+fillSep : {opts : _} -> List (Doc opts) -> Doc opts
 fillSep []        = empty
 fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
 
 export
-exceptLast : {opts : LayoutOpts} -> (Doc opts -> Doc opts) ->
+exceptLast : {opts : _} -> (Doc opts -> Doc opts) ->
              List (Doc opts) -> List (Doc opts)
 exceptLast f []        = []
 exceptLast f [x]       = [x]
@@ -209,24 +185,11 @@ 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 =
@@ -235,7 +198,7 @@ ifUnicode uni asc =
     Ascii   => asc
 
 export %inline
-parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
+parensIfM : {opts : _} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
 parensIfM d doc = parensIf (!(getAt PREC) > d) doc
 
 export %inline
@@ -248,73 +211,64 @@ prettyName : Name -> Doc opts
 prettyName = text . toDots
 
 export
-prettyFree : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts)
+prettyFree : {opts : _} -> Name -> Eff Pretty (Doc opts)
 prettyFree = hl Free . prettyName
 
 export
 prettyBind' : BindName -> Doc opts
-prettyBind' = text . baseStr . val
+prettyBind' = text . baseStr . name
 
 export
-prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
+prettyTBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
 prettyTBind = hl TVar . prettyBind'
 
 export
-prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
+prettyDBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
 prettyDBind = hl DVar . prettyBind'
 
 
 
 export %inline
-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, 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     = hl Syntax . text =<< ifUnicode "★" "Type"
-ioStateD  = hl Syntax $ text "IOState"
-arrowD    = hl Syntax . text =<< ifUnicode "→" "->"
-darrowD   = hl Syntax . text =<< ifUnicode "⇒" "=>"
-timesD    = hl Syntax . text =<< ifUnicode "×" "**"
+arrowD    = hl Delim  . text =<< ifUnicode "→" "->"
+darrowD   = hl Delim  . text =<< ifUnicode "⇒" "=>"
+timesD    = hl Delim  . text =<< ifUnicode "×" "**"
 lamD      = hl Syntax . text =<< ifUnicode "λ" "fun"
-eqndD     = hl Syntax . text =<< ifUnicode "≡" "=="
+eqndD     = hl Delim  . text =<< ifUnicode "≡" "=="
 dlamD     = hl Syntax . text =<< ifUnicode "δ" "dfun"
-annD      = hl Syntax . text =<< ifUnicode "∷" "::"
+annD      = hl Delim  . text =<< ifUnicode "∷" "::"
 natD      = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
-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"
+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 "|"
 
 
 export
-prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
-            List (Doc opts) -> Doc opts
+prettyApp : {opts : _} -> Nat -> Doc opts -> List (Doc opts) -> Doc opts
 prettyApp ind f args =
-  ifMultiline
-    (hsep (f :: args))
-    (f <++> vsep args <|> vsep (f :: map (indent ind) args))
+      hsep (f :: args)
+  <|> hsep [f, vsep args]
+  <|> vsep (f :: map (indent ind) args)
 
 export
-prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
-             Eff Pretty (Doc opts)
+prettyAppD : {opts : _} -> Doc opts -> List (Doc opts) -> Eff Pretty (Doc opts)
 prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
 
 
@@ -334,7 +288,7 @@ quoteTag tag =
   "\"" ++ escapeString tag ++ "\""
 
 export
-prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
+prettyBounds : {opts : _} -> Bounds -> Eff Pretty (Doc opts)
 prettyBounds (MkBounds l1 c1 l2 c2) =
   hcat <$> sequence
     [hl TVar $ text $ show l1, colonD,
@@ -343,22 +297,8 @@ prettyBounds (MkBounds l1 c1 l2 c2) =
      hl DVar $ text $ show c2, colonD]
 
 export
-prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
+prettyLoc : {opts : _} -> 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

@@ -1,20 +0,0 @@
-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

@@ -0,0 +1,751 @@
+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

@@ -1,59 +0,0 @@
-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,5 +6,4 @@ import public Quox.Syntax.Qty
 import public Quox.Syntax.Shift
 import public Quox.Syntax.Subst
 import public Quox.Syntax.Term
-import public Quox.Syntax.Builtin
-import public Quox.Var
+import public Quox.Syntax.Var

lib/Quox/Syntax/Builtin.idr

@@ -1,27 +0,0 @@
-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

@@ -1,16 +1,18 @@
 module Quox.Syntax.Dim
 
-import Quox.Loc
-import Quox.Name
-import Quox.Var
+import Quox.Thin
+import Quox.Syntax.Var
 import Quox.Syntax.Subst
 import Quox.Pretty
+import Quox.Name
+import Quox.Loc
 import Quox.Context
-import Quox.PrettyValExtra
 
 import Decidable.Equality
 import Control.Function
 import Derive.Prelude
+import Data.DPair
+import Data.SnocVect
 
 %default total
 %language ElabReflection
@@ -19,7 +21,7 @@ import Derive.Prelude
 public export
 data DimConst = Zero | One
 %name DimConst e
-%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal]
+%runElab derive "DimConst" [Eq, Ord, Show]
 
 ||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
 public export
@@ -40,38 +42,48 @@ DecEq DimConst where
 
 public export
 data Dim : Nat -> Type where
-  K : DimConst -> Loc -> Dim d
-  B : Var d -> Loc -> Dim d
+  K : DimConst -> Loc -> Dim 0
+  B : Loc -> Dim 1
 %name Dim.Dim p, q
 %runElab deriveIndexed "Dim" [Eq, Ord, Show]
 
 
+public export
+DimT : Nat -> Type
+DimT = Thinned Dim
+
+public export %inline
+KT : DimConst -> Loc -> DimT d
+KT e loc = Th zero $ K e loc
+
+
 ||| `endsOr l r x p` returns `ends l r ε` if `p` is a constant ε, and
 ||| `x` otherwise.
 public export
 endsOr : Lazy a -> Lazy a -> Lazy a -> Dim n -> a
 endsOr l r x (K e _) = ends l r e
-endsOr l r x (B _ _) = x
+endsOr l r x (B _)   = x
 
 
 export
 Located (Dim d) where
   (K _ loc).loc = loc
-  (B _ loc).loc = loc
+  (B loc).loc   = loc
 
 export
 Relocatable (Dim d) where
   setLoc loc (K e _) = K e loc
-  setLoc loc (B i _) = B i loc
+  setLoc loc (B _)   = B loc
 
-export
-prettyDimConst : {opts : _} -> DimConst -> Eff Pretty (Doc opts)
-prettyDimConst = hl Dim . text . ends "0" "1"
+parameters {opts : LayoutOpts}
+  export
+  prettyDimConst : DimConst -> Eff Pretty (Doc opts)
+  prettyDimConst = hl Dim . text . ends "0" "1"
 
-export
-prettyDim : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
-prettyDim names (K e _) = prettyDimConst e
-prettyDim names (B i _) = prettyDBind $ names !!! i
+  export
+  prettyDim : {d : Nat} -> BContext d -> DimT d -> Eff Pretty (Doc opts)
+  prettyDim names (Th _ (K e _)) = prettyDimConst e
+  prettyDim names (Th i (B _)) = prettyDBind $ names !!! i.fin
 
 
 public export %inline
@@ -84,57 +96,54 @@ DSubst : Nat -> Nat -> Type
 DSubst = Subst Dim
 
 
-public export FromVar Dim where fromVarLoc = B
+-- public export FromVar Dim where fromVarLoc = B
 
 
-export
-CanShift Dim where
-  K e loc // _  = K e loc
-  B i loc // by = B (i // by) loc
+-- export
+-- CanShift Dim where
+--   K e loc // _  = K e loc
+--   B i loc // by = B (i // by) loc
 
-export
+export %inline FromVar Dim where var = B
+
+export %inline
 CanSubstSelf Dim where
-  K e loc // _  = K e loc
-  B i loc // th = getLoc th i loc
+  Th _ (K e loc) // _  = KT e loc
+  Th i (B loc)   // th = get th i.fin
 
 
-export Uninhabited (B i loc1 = K e loc2) where uninhabited _ impossible
-export Uninhabited (K e loc1 = B i loc2) where uninhabited _ impossible
+export Uninhabited (B loc1   = K e loc2) where uninhabited _ impossible
+export Uninhabited (K e loc1 = B loc2)   where uninhabited _ impossible
 
-public export
-data Eqv : Dim d1 -> Dim d2 -> Type where
-  EK : K e _ `Eqv` K e _
-  EB : i `Eqv` j -> B i _ `Eqv` B j _
+-- public export
+-- data Eqv : Dim d1 -> Dim d2 -> Type where
+--   EK : K e _ `Eqv` K e _
+--   EB : i `Eqv` j -> B i _ `Eqv` B j _
 
-export Uninhabited (K e l1 `Eqv` B i l2) where uninhabited _ impossible
-export Uninhabited (B i l1 `Eqv` K e l2) where uninhabited _ impossible
+-- export Uninhabited (K e l1 `Eqv` B i l2) where uninhabited _ impossible
+-- export Uninhabited (B i l1 `Eqv` K e l2) where uninhabited _ impossible
 
-export
-injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j
-injectiveB (EB e) = e
+-- export
+-- injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j
+-- injectiveB (EB e) = e
 
-export
-injectiveK : K e loc1 `Eqv` K f loc2 -> e = f
-injectiveK EK = Refl
+-- export
+-- injectiveK : K e loc1 `Eqv` K f loc2 -> e = f
+-- injectiveK EK = Refl
 
-public export
-decEqv : Dec2 Dim.Eqv
-decEqv (K e _) (K f _) = case decEq e f of
-  Yes Refl => Yes EK
-  No  n    => No $ n . injectiveK
-decEqv (B i _) (B j _) = case decEqv i j of
-  Yes y => Yes $ EB y
-  No  n => No  $ \(EB y) => n y
-decEqv (B _ _) (K _ _) = No absurd
-decEqv (K _ _) (B _ _) = No absurd
+-- public export
+-- decEqv : Dec2 Dim.Eqv
+-- decEqv (K e _) (K f _) = case decEq e f of
+--   Yes Refl => Yes EK
+--   No  n    => No $ n . injectiveK
+-- decEqv (B i _) (B j _) = case decEqv i j of
+--   Yes y => Yes $ EB y
+--   No  n => No  $ \(EB y) => n y
+-- decEqv (B _ _) (K _ _) = No absurd
+-- decEqv (K _ _) (B _ _) = No absurd
 
 ||| abbreviation for a bound variable like `BV 4` instead of
 ||| `B (VS (VS (VS (VS VZ))))`
 public export %inline
-BV : (i : Nat) -> (0 _ : LT i d) => (loc : Loc) -> Dim d
-BV i loc = B (V i) loc
-
-
-export
-weakD : (by : Nat) -> Dim d -> Dim (by + d)
-weakD by p = p // shift by
+BV : (i : Fin d) -> (loc : Loc) -> DimT d
+BV i loc = Th (one' i) $ B loc

lib/Quox/Syntax/DimEq.idr

@@ -1,17 +1,19 @@
 module Quox.Syntax.DimEq
 
-import public Quox.Var
+import public Quox.Syntax.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 Quox.Thin
+import Quox.FinExtra
 
 import Data.Maybe
 import Data.Nat
 import Data.DPair
 import Data.Fun.Graph
+import Data.SnocVect
 import Decidable.Decidable
 import Decidable.Equality
 import Derive.Prelude
@@ -22,7 +24,7 @@ import Derive.Prelude
 
 public export
 DimEq' : Nat -> Type
-DimEq' = Context (Maybe . Dim)
+DimEq' = Context (Maybe . DimT)
 
 
 public export
@@ -30,7 +32,12 @@ data DimEq : Nat -> Type where
   ZeroIsOne : DimEq d
   C         : (eqs : DimEq' d) -> DimEq d
 %name DimEq eqs
-%runElab deriveIndexed "DimEq" [Eq, Ord, Show]
+%runElab deriveIndexed "DimEq" [Eq]
+
+export
+Show (DimEq d) where
+  showPrec d ZeroIsOne = "ZeroIsOne"
+  showPrec d (C eq')   = showCon d "C" $ showArg eq' @{ShowTelRelevant}
 
 
 public export
@@ -59,15 +66,10 @@ 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 eqs act = ifConsistentElse eqs act (pure ())
+ifConsistent ZeroIsOne act = pure Nothing
+ifConsistent (C _)     act = Just <$> act
 
 public export
 toMaybe : IfConsistent eqs a -> Maybe a
@@ -76,13 +78,13 @@ toMaybe (Just x) = Just x
 
 
 export
-fromGround' : BContext d -> Context' DimConst d -> DimEq' d
-fromGround' [<]       [<]        = [<]
-fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
+fromGround' : Context' DimConst d -> DimEq' d
+fromGround' [<]        = [<]
+fromGround' (ctx :< e) = fromGround' ctx :< Just (KT e noLoc)
 
 export
-fromGround : BContext d -> Context' DimConst d -> DimEq d
-fromGround = C .: fromGround'
+fromGround : Context' DimConst d -> DimEq d
+fromGround = C . fromGround'
 
 
 public export %inline
@@ -100,39 +102,40 @@ new = C new'
 
 
 public export %inline
-get' : DimEq' d -> Var d -> Maybe (Dim d)
+get' : DimEq' d -> Fin d -> Maybe (DimT d)
 get' = getWith $ \p, by => map (// by) p
 
 public export %inline
-getVar : DimEq' d -> Var d -> Loc -> Dim d
-getVar eqs i loc = fromMaybe (B i loc) $ get' eqs i
-
-public export %inline
-getShift' : Shift len out -> DimEq' len -> Var len -> Maybe (Dim out)
+getShift' : Shift len out -> DimEq' len -> Fin len -> Maybe (DimT out)
 getShift' = getShiftWith $ \p, by => map (// by) p
 
 public export %inline
-get : DimEq' d -> Dim d -> Dim d
-get _   (K e loc) = K e loc
-get eqs (B i loc) = getVar eqs i loc
+get : {d : Nat} -> DimEq' d -> DimT d -> DimT d
+get eqs p@(Th _ (K {})) = p
+get eqs p@(Th i (B _))  = fromMaybe p $ get' eqs i.fin
 
 
 public export %inline
-equal : DimEq d -> (p, q : Dim d) -> Bool
+equal : {d : Nat} -> DimEq d -> (p, q : DimT d) -> Bool
 equal ZeroIsOne p q = True
 equal (C eqs)   p q = get eqs p == get eqs q
 
 
-export infixl 7 :<?
+infixl 7 :<?
 export %inline
-(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
+(:<?) : {d : Nat} -> DimEq d -> Maybe (DimT d) -> DimEq (S d)
 ZeroIsOne :<? d = ZeroIsOne
 C eqs     :<? d = C $ eqs :< map (get eqs) d
 
 
 private %inline
-ifVar : Var d -> Dim d -> Maybe (Dim d) -> Maybe (Dim d)
-ifVar i p = map $ \q => if q == B i noLoc then p else q
+isVar : {d : Nat} -> Fin d -> DimT d -> Bool
+isVar i (Th j (B _))  = i == j.fin
+isVar i (Th _ (K {})) = False
+
+private %inline
+ifVar : {d : Nat} -> Fin d -> DimT d -> Maybe (DimT d) -> Maybe (DimT d)
+ifVar i p = map $ \q => if isVar i q then p else q
 
 -- (using decEq instead of (==) because of the proofs below)
 private %inline
@@ -141,43 +144,45 @@ checkConst e f eqs = if isYes $ e `decEq` f then C eqs else ZeroIsOne
 
 
 export
-setConst : Var d -> DimConst -> Loc -> DimEq' d -> DimEq d
-setConst VZ e loc (eqs :< Nothing) =
-  C $ eqs :< Just (K e loc)
-setConst VZ e _ (eqs :< Just (K f loc)) =
-  checkConst e f $ eqs :< Just (K f loc)
-setConst VZ e loc (eqs :< Just (B i _)) =
-  setConst i e loc eqs :<? Just (K e loc)
-setConst (VS i) e loc (eqs :< p) =
-  setConst i e loc eqs :<? ifVar i (K e loc) p
+setConst : {d : Nat} -> Fin d -> DimConst -> Loc -> DimEq' d -> DimEq d
+setConst FZ e loc (eqs :< Nothing) =
+  C $ eqs :< Just (KT e loc)
+setConst FZ e _ (eqs :< Just (Th _ (K f loc))) =
+  checkConst e f $ eqs :< Just (KT f loc)
+setConst FZ e loc (eqs :< Just (Th j (B _))) =
+  setConst j.fin e loc eqs :<? Just (KT e loc)
+setConst (FS i) e loc (eqs :< p) =
+  setConst i e loc eqs :<? ifVar i (KT e loc) p
 
 mutual
   private
-  setVar' : (i, j : Var d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
-  setVar' VZ (VS i) LTZ loc (eqs :< Nothing) =
-    C eqs :<? Just (B i loc)
-  setVar' VZ (VS i) LTZ loc (eqs :< Just (K e eloc)) =
-    setConst i e loc eqs :<? Just (K e eloc)
-  setVar' VZ (VS i) LTZ loc (eqs :< Just (B j jloc)) =
-    setVar i j loc jloc eqs :<? Just (if j > i then B j jloc else B i loc)
-  setVar' (VS i) (VS j) (LTS lt) loc (eqs :< p) =
-    setVar' i j lt loc eqs :<? ifVar i (B j loc) p
+  setVar' : {d : Nat} ->
+            (i, j : Fin d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
+  setVar' FZ (FS i) LTZ loc (eqs :< Nothing) =
+    C eqs :<? Just (BV i loc)
+  setVar' FZ (FS i) LTZ loc (eqs :< Just (Th _ (K e eloc))) =
+    setConst i e loc eqs :<? Just (KT e eloc)
+  setVar' FZ (FS i) LTZ loc (eqs :< Just (Th j (B jloc))) =
+    let j = j.fin in
+    setVar i j loc jloc eqs :<? Just (if j > i then BV j jloc else BV i loc)
+  setVar' (FS i) (FS j) (LTS lt) loc (eqs :< p) =
+    setVar' i j lt loc eqs :<? ifVar i (BV j loc) p
 
   export %inline
-  setVar : (i, j : Var d) -> Loc -> Loc -> DimEq' d -> DimEq d
-  setVar i j li lj eqs with (compareP i j) | (compare i.nat j.nat)
-    setVar i j li lj eqs | IsLT lt | LT = setVar' i j lt lj eqs
-    setVar i i li lj eqs | IsEQ    | EQ = C eqs
-    setVar i j li lj eqs | IsGT gt | GT = setVar' j i gt li eqs
+  setVar : {d : Nat} -> (i, j : Fin d) -> Loc -> Loc -> DimEq' d -> DimEq d
+  setVar i j li lj eqs with (compareP i j)
+    setVar i j li lj eqs | IsLT lt = setVar' i j lt lj eqs
+    setVar i i li lj eqs | IsEQ    = C eqs
+    setVar i j li lj eqs | IsGT gt = setVar' j i gt li eqs
 
 
 export %inline
-set : (p, q : Dim d) -> DimEq d -> DimEq d
+set : {d : Nat} -> (p, q : DimT d) -> DimEq d -> DimEq d
 set _ _ ZeroIsOne = ZeroIsOne
-set (K e eloc) (K f floc) (C eqs) = checkConst e f eqs
-set (K e eloc) (B i iloc) (C eqs) = setConst i e eloc eqs
-set (B i iloc) (K e eloc) (C eqs) = setConst i e eloc eqs
-set (B i iloc) (B j jloc) (C eqs) = setVar   i j iloc jloc eqs
+set (Th _ (K e _))  (Th _ (K f _))  (C eqs) = checkConst e f eqs
+set (Th _ (K e el)) (Th j (B _))    (C eqs) = setConst j.fin e el eqs
+set (Th i (B _))    (Th _ (K e el)) (C eqs) = setConst i.fin e el eqs
+set (Th i (B il))   (Th j (B jl))   (C eqs) = setVar i.fin j.fin il jl eqs
 
 
 public export %inline
@@ -185,116 +190,99 @@ Split : Nat -> Type
 Split d = (DimEq' d, DSubst (S d) d)
 
 export %inline
-split1 : DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
-split1 e loc eqs = case setConst VZ e loc eqs of
+split1 : {d : Nat} -> DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
+split1 e loc eqs = case setConst 0 e loc eqs of
   ZeroIsOne    => Nothing
-  C (eqs :< _) => Just (eqs, K e loc ::: id)
+  C (eqs :< _) => Just (eqs, id (B loc) :< KT e loc)
 
 export %inline
-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
+split : {d : Nat} -> Loc -> DimEq' (S d) -> List (Split d)
+split loc eqs = toList (split1 Zero loc eqs) <+> toList (split1 One loc eqs)
 
 export
-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
+splits' : {d : Nat} -> Loc -> DimEq' d -> List (DSubst d 0)
+splits' _   [<]          = [[<]]
+splits' loc eqs@(_ :< _) =
+  [th . ph | (eqs', th) <- split loc eqs, ph <- splits' loc eqs']
 
 ||| the Loc is put into each of the DimConsts
 export %inline
-splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
-splits _   ZeroIsOne _   = []
-splits loc (C eqs)   fvs = splits' loc eqs fvs
+splits : {d : Nat} -> Loc -> DimEq d -> List (DSubst d 0)
+splits _   ZeroIsOne = []
+splits loc (C eqs)   = splits' loc eqs
 
 
-private
-0 newGetShift : (d : Nat) -> (i : Var d) -> (by : Shift d d') ->
-                getShift' by (new' {d}) i = Nothing
-newGetShift (S d) VZ     by = Refl
-newGetShift (S d) (VS i) by = newGetShift d i (ssDown by)
+-- private
+-- 0 newGetShift : (d : Nat) -> (i : Fin d) -> (by : Shift d d') ->
+--                 getShift' by (new' {d}) i = Nothing
+-- newGetShift (S d) FZ     by = Refl
+-- newGetShift (S d) (FS i) by = newGetShift d i (ssDown by)
 
-export
-0 newGet' : (d : Nat) -> (i : Var d) -> get' (new' {d}) i = Nothing
-newGet' d i = newGetShift d i SZ
+-- export
+-- 0 newGet' : (d : Nat) -> (i : Fin d) -> get' (new' {d}) i = Nothing
+-- newGet' d i = newGetShift d i SZ
 
-export
-0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p
-newGet d (K e _) = Refl
-newGet d (B i _) = rewrite newGet' d i in Refl
+-- export
+-- 0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p
+-- newGet d (K e _) = Refl
+-- newGet d (B i _) = rewrite newGet' d i in Refl
 
 
-export
-0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs
-setSelf p ZeroIsOne = Refl
-setSelf (K Zero _) (C eqs) = Refl
-setSelf (K One _)  (C eqs) = Refl
-setSelf (B i _)    (C eqs) with (compareP i i) | (compare i.nat i.nat)
-  _ | IsLT lt | LT = absurd lt
-  _ | IsEQ    | EQ = Refl
-  _ | IsGT gt | GT = absurd gt
+-- export
+-- 0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs
+-- setSelf p ZeroIsOne = Refl
+-- setSelf (K Zero _) (C eqs) = Refl
+-- setSelf (K One _)  (C eqs) = Refl
+-- setSelf (B i _)    (C eqs) with (compareP i i) | (compare i.nat i.nat)
+--   _ | IsLT lt | LT = absurd lt
+--   _ | IsEQ    | EQ = Refl
+--   _ | 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
+parameters {opts : LayoutOpts}
+  private
+  prettyDVars : {d : Nat} -> BContext d -> Eff Pretty (SnocList (Doc opts))
+  prettyDVars = traverse prettyDBind . toSnocList'
 
-private
-prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
-prettyDVars' = traverse prettyDBind . toSnocList'
+  private
+  prettyCst : {d : Nat} -> BContext d -> DimT d -> DimT d -> Eff Pretty (Doc opts)
+  prettyCst dnames p q =
+    hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
 
-export
-prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
-prettyDVars vars =
-  parensIfM (dimEqPrec vars Nothing) $
-  fillSeparateTight !commaD $ !(prettyDVars' vars)
+  private
+  prettyCsts : {d : Nat} -> BContext d -> DimEq' d ->
+               Eff Pretty (SnocList (Doc opts))
+  prettyCsts [<] [<] = pure [<]
+  prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs
+  prettyCsts dnames (eqs :< Just q)  =
+    [|prettyCsts (tail dnames) eqs :<
+      prettyCst dnames (BV 0 noLoc) (weak 1 q)|]
 
-private
-prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
-prettyCst dnames p q =
-  hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
+  export
+  prettyDimEq' : {d : Nat} -> 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
 
-private
-prettyCsts : {opts : _} -> BContext d -> DimEq' d ->
-             Eff Pretty (SnocList (Doc opts))
-prettyCsts [<] [<] = pure [<]
-prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs
-prettyCsts dnames (eqs :< Just q)  =
-  [|prettyCsts (tail dnames) eqs :< prettyCst dnames (BV 0 noLoc) (weakD 1 q)|]
-
-export
-prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
-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
-  cst  <- prettyCst [<] (K Zero noLoc) (K One noLoc)
-  pure $ separateTight !commaD $ vars :< cst
-prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
+  export
+  prettyDimEq : {d : Nat} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
+  prettyDimEq dnames ZeroIsOne = do
+    vars <- prettyDVars dnames
+    cst  <- prettyCst [<] (KT Zero noLoc) (KT One noLoc)
+    pure $ separateTight !commaD $ vars :< cst
+  prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
 
 
 public export
-wf' : DimEq' d -> Bool
-wf' [<]                   = True
-wf' (eqs :< Nothing)      = wf' eqs
-wf' (eqs :< Just (K e _)) = wf' eqs
-wf' (eqs :< Just (B i _)) = isNothing (get' eqs i) && wf' eqs
+wf' : {d : Nat} -> DimEq' d -> Bool
+wf' [<]                         = True
+wf' (eqs :< Nothing)            = wf' eqs
+wf' (eqs :< Just (Th _ (K {}))) = wf' eqs
+wf' (eqs :< Just (Th i (B _)))  = isNothing (get' eqs i.fin) && wf' eqs
 
 public export
-wf : DimEq d -> Bool
+wf : {d : Nat} -> DimEq d -> Bool
 wf ZeroIsOne = True
 wf (C eqs)   = wf' eqs

lib/Quox/Syntax/Qty.idr

@@ -6,7 +6,6 @@ module Quox.Syntax.Qty
 
 import Quox.Pretty
 import Quox.Decidable
-import Quox.PrettyValExtra
 import Data.DPair
 import Derive.Prelude
 
@@ -21,7 +20,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, PrettyVal]
+%runElab derive "Qty" [Eq, Ord, Show]
 %name Qty.Qty pi, rh
 
 
@@ -79,16 +78,26 @@ 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
-data SQty = SZero | SOne
-%runElab derive "SQty" [Eq, Ord, Show, PrettyVal]
-%name Qty.SQty sg
+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
 
 ||| "σ ⨴ π"
 |||
-||| σ ⨴ π 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
 
 
@@ -96,59 +105,23 @@ subjMult sg _    = sg
 ||| quantity of 1, so the only distinction is whether it is present
 ||| at runtime at all or not
 public export
-data GQty = GZero | GAny
-%runElab derive "GQty" [Eq, Ord, Show, PrettyVal]
-%name GQty rh
+isGlobal : Qty -> Bool
+isGlobal Zero = True
+isGlobal One  = False
+isGlobal Any  = True
 
 public export
-toGlobal : Qty -> Maybe GQty
-toGlobal Zero = Just GZero
-toGlobal Any  = Just GAny
-toGlobal One  = Nothing
+GQty : Type
+GQty = Subset Qty $ So . isGlobal
+
+public export
+gzero, gany : GQty
+gzero = Element Zero Oh
+gany  = Element Any  Oh
 
 ||| 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 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
+globalToSubj (Element Zero _) = szero
+globalToSubj (Element Any  _) = sone

lib/Quox/Syntax/Shift.idr

@@ -1,11 +1,11 @@
 module Quox.Syntax.Shift
 
-import public Quox.Var
+import public Quox.Syntax.Var
+import public Quox.Thin
 
 import Data.Nat
 import Data.So
-import Data.Singleton
-import Syntax.PreorderReasoning
+import Data.DPair
 
 %default total
 
@@ -148,25 +148,6 @@ 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
@@ -199,12 +180,11 @@ 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 = 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 {}))
+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)
 
 private %inline
 compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
@@ -227,7 +207,7 @@ compViaNatCorrect by (SS bz) =
 %transform "Shift.(.)" Shift.(.) = compViaNat
 
 
-export infixl 8 //
+infixl 8 //
 public export
 interface CanShift f where
   (//) : f from -> Shift from to -> f to
@@ -242,3 +222,15 @@ namespace CanShift
 
   public export %inline
   [Const] CanShift (\_ => a) where x // _ = x
+
+
+export
+shiftOPE : {mask : Nat} -> (0 ope : OPE m n mask) ->
+           Shift n n' -> Subset Nat (OPE m n')
+shiftOPE ope SZ      = Element _ ope
+shiftOPE ope (SS by) =
+  let Element _ ope = shiftOPE ope by in Element _ $ drop ope
+
+export
+CanShift (Thinned f) where
+  Th ope tm // by = Th (shiftOPE ope by).snd tm

lib/Quox/Syntax/Subst.idr

@@ -1,13 +1,11 @@
 module Quox.Syntax.Subst
 
-import public Quox.Syntax.Shift
-import Quox.Var
-import Quox.Name
+import Quox.Thin
+import Quox.Loc
 
-import Data.Nat
+import Data.DPair
 import Data.List
 import Data.SnocVect
-import Data.Singleton
 import Derive.Prelude
 
 %default total
@@ -15,155 +13,159 @@ import Derive.Prelude
 
 
 public export
-data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
-  Shift : Shift from to -> Subst env from to
-  (:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
-%name Subst th, ph, ps
+Subst : (Nat -> Type) -> Nat -> Nat -> Type
+Subst env from to = SnocVect from (Lazy (Thinned env to))
 
-export infixr 7 !:::
-||| in case the automatic laziness insertion gets confused
 public export
-(!:::) : env to -> Subst env from to -> Subst env (S from) to
-t !::: ts = t ::: ts
-
-
-private
-Repr : (Nat -> Type) -> Nat -> Type
-Repr f to = (List (f to), Nat)
-
-private
-repr : Subst f from to -> Repr f to
-repr (Shift by) = ([], by.nat)
-repr (t ::: th) = let (ts, i) = repr th in (t::ts, i)
-
-
-export Eq   (f to) => Eq   (Subst f from to) where (==) = (==) `on` repr
-export Ord  (f to) => Ord  (Subst f from to) where compare = compare `on` repr
-export Show (f to) => Show (Subst f from to) where show = show . repr
-
-
-export infixl 8 //
-public export
-interface FromVar term => CanSubstSelf term where
-  (//) : term from -> Lazy (Subst term from to) -> term to
+Subst2 : (Nat -> Nat -> Type) -> Nat -> Nat -> Nat -> Type
+Subst2 env d from to = SnocVect from (Lazy (Thinned2 env d to))
 
 
 public export
-getLoc : FromVar term => Subst term from to -> Var from -> Loc -> term to
-getLoc (Shift by) i      loc = fromVarLoc (shift by i) loc
-getLoc (t ::: th) VZ     _   = t
-getLoc (t ::: th) (VS i) loc = getLoc th i loc
+get : Subst env f t -> Fin f -> Thinned env t
+get (sx :< x) FZ     = x
+get (sx :< x) (FS i) = get sx i
 
 
 public export
-CanSubstSelf Var where
-  i    // Shift by   = shift by i
-  VZ   // (t ::: th) = t
-  VS i // (t ::: th) = i // th
+interface FromVar (0 term : Nat -> Type) where
+  var : Loc -> term 1
 
+public export
+0 FromVar2 : (Nat -> Nat -> Type) -> Type
+FromVar2 t = FromVar (t 0)
 
-public export %inline
-shift : (by : Nat) -> Subst env from (by + from)
-shift by = Shift $ fromNat by
+public export
+varT : FromVar term => Fin n -> Loc -> Thinned term n
+varT i loc = Th (one' i) (var loc)
 
-public export %inline
-shift0 : (by : Nat) -> Subst env 0 by
-shift0 by = rewrite sym $ plusZeroRightNeutral by in Shift $ fromNat by
+public export
+varT2 : FromVar2 term => Fin n -> Loc -> Thinned2 term d n
+varT2 i loc = Th2 zero (one' i) (var loc)
+
+infixl 8 //
+namespace CanSubstSelf
+  public export
+  interface FromVar term => CanSubstSelf term where
+    (//) : {f : Nat} -> Thinned term f -> Subst term f t -> Thinned term t
+
+namespace CanSubstSelf2
+  public export
+  interface FromVar2 term => CanSubstSelf2 term where
+    (//) : {f : Nat} -> Thinned2 term d f ->
+           Subst2 term d f t -> Thinned2 term d t
+
+public export
+(.) : {mid : Nat} -> CanSubstSelf f =>
+      Subst f from mid -> Subst f mid to -> Subst f from to
+th . ph = map (\(Delay x) => x // ph) th
+
+infixr 9 .%
+
+public export
+(.%) : {mid : Nat} -> CanSubstSelf2 f =>
+       Subst2 f d from mid -> Subst2 f d mid to -> Subst2 f d from to
+th .% ph = map (\(Delay x) => x // ph) th
 
 
 public export
-(.) : CanSubstSelf f => Subst f from mid -> Subst f mid to -> Subst f from to
-Shift by      . Shift bz   = Shift $ by . bz
-Shift SZ      . ph         = ph
-Shift (SS by) . (t ::: th) = Shift by . th
-(t ::: th)    . ph         = (t // ph) ::: (th . ph)
-
-public export %inline
-id : Subst f n n
-id = shift 0
+tabulate : (n : Nat) -> SnocVect n (Fin n)
+tabulate n = go n id where
+  go : (n : Nat) -> (Fin n -> Fin n') -> SnocVect n (Fin n')
+  go 0     f = [<]
+  go (S n) f = go n (f . FS) :< f FZ
 
 public export
-traverse : Applicative m =>
-           (f to -> m (g to)) -> Subst f from to -> m (Subst g from to)
-traverse f (Shift by) = pure $ Shift by
-traverse f (t ::: th) = [|f t !::: traverse f th|]
-
--- not in terms of traverse because this map can maintain laziness better
-public export
-map : (f to -> g to) -> Subst f from to -> Subst g from to
-map f (Shift by) = Shift by
-map f (t ::: th) = f t ::: map f th
-
-
-public export %inline
-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) -> Loc ->
-        Subst f from to -> Subst f (s + from) (s + to)
-pushN 0     _   th = th
-pushN (S s) loc th =
-  rewrite plusSuccRightSucc s from in
-  rewrite plusSuccRightSucc s to in
-  pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
+id : FromVar term => {n : Nat} -> (under : Nat) -> Loc ->
+     Subst term n (n + under)
+id under loc =
+  map (\i => delay $ varT (weakenN under i) loc) (tabulate n)
 
 public export
-drop1 : Subst f (S from) to -> Subst f from to
-drop1 (Shift by) = Shift $ ssDown by
-drop1 (t ::: th) = th
-
-
-public export
-fromSnocVect : SnocVect s (f n) -> Subst f (s + n) n
-fromSnocVect [<]       = id
-fromSnocVect (xs :< x) = x ::: fromSnocVect xs
-
-public export %inline
-one : f n -> Subst f (S n) n
-one x = fromSnocVect [< x]
-
+id2 : FromVar2 term => {n : Nat} -> Loc -> Subst2 term d n n
+id2 loc = map (\i => delay $ varT2 i loc) $ tabulate n
 
 export
-getFrom : {to : Nat} -> Subst _ from to -> Singleton from
-getFrom (Shift by) = getFrom by
-getFrom (t ::: th) = [|S $ getFrom th|]
+select : {n, mask : Nat} -> (0 ope : OPE m n mask) ->
+         SnocVect n a -> SnocVect m a
+select ope sx with %syntactic (view ope)
+  select _ [<]       | StopV       = [<]
+  select _ (sx :< x) | DropV _ ope = select ope sx
+  select _ (sx :< x) | KeepV _ ope = select ope sx :< x
 
-
-||| 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
 export
-cmpShape : Subst env from1 to -> Subst env from2 to ->
-           Either Ordering (from1 = from2)
-cmpShape (Shift by) (Shift bz) = cmpLen by bz
-cmpShape (Shift _)  (_ ::: _)  = Left LT
-cmpShape (_ ::: _)  (Shift _)  = Left GT
-cmpShape (_ ::: th) (_ ::: ph) = map (\x => cong S x) $ cmpShape th ph
+opeToFins : {n, mask : Nat} ->
+            (0 ope : OPE m n mask) -> SnocVect m (Fin n)
+opeToFins ope = select ope $ tabulate n
+
+export
+shift : FromVar term => {from : Nat} ->
+        (n : Nat) -> Loc -> Subst term from (n + from)
+shift n loc = map (\i => delay $ varT (shift n i) loc) $ tabulate from
+
+public export
+pushN : CanSubstSelf term => {to : Nat} -> (by : Nat) ->
+        Subst term from to -> Loc -> Subst term (by + from) (by + to)
+pushN by th loc =
+  rewrite plusCommutative by from in
+  (th . shift by loc) ++ id to loc
+
+public export %inline
+push : CanSubstSelf f => {to : Nat} ->
+       Subst f from to -> Loc -> Subst f (S from) (S to)
+push = pushN 1
+
+
+public export %inline
+one : Thinned f n -> Subst f 1 n
+one x = [< x]
+
+
+||| whether two substitutions with the same codomain have the same domain
+export
+cmpShape : SnocVect m a -> SnocVect n a -> Either Ordering (m = n)
+cmpShape [<]       [<]       = Right Refl
+cmpShape [<]       (sx :< _) = Left LT
+cmpShape (sx :< _) [<]       = Left GT
+cmpShape (sx :< _) (sy :< _) = cong S <$> cmpShape sx sy
 
 
 public export
 record WithSubst tm env n where
   constructor Sub
   term  : tm from
-  subst : Lazy (Subst env from n)
+  subst : Subst env from n
 
+{-
 export
-(Eq (env n), forall n. Eq (tm n)) => Eq (WithSubst tm env n) where
+(forall n. Eq (env n), forall n. Eq (tm n)) =>
+Eq (WithSubst tm env n) where
   Sub t1 s1 == Sub t2 s2 =
     case cmpShape s1 s2 of
       Left  _    => False
-      Right Refl => t1 == t2 && s1 == s2
+      Right Refl =>
+        t1 == t2 && concat @{All} (zipWith ((==) `on` force) s1 s2)
 
 export
-(Ord (env n), forall n. Ord (tm n)) => Ord (WithSubst tm env n) where
+(forall n. Ord (env n), forall n. Ord (tm n)) =>
+Ord (WithSubst tm env n) where
   Sub t1 s1 `compare` Sub t2 s2 =
     case cmpShape s1 s2 of
       Left  o    => o
-      Right Refl => compare (t1, s1) (t2, s2)
+      Right Refl =>
+        compare t1 t2 <+> concat (zipWith (compare `on` force) s1 s2)
 
 export %hint
-ShowWithSubst : (Show (env n), forall n. Show (tm n)) =>
+ShowWithSubst : {n : Nat} ->
+                (forall n. Show (env n), forall n. Show (tm n)) =>
                 Show (WithSubst tm env n)
-ShowWithSubst = deriveShow
+ShowWithSubst = deriveShow where
+  Show (Lazy (Thinned env n)) where showPrec d = showPrec d . force
+-}
+
+
+public export
+record WithSubst2 tm env d n where
+  constructor Sub2
+  term  : tm d from
+  subst : Subst2 env d from n

lib/Quox/Syntax/Term.idr

@@ -3,3 +3,4 @@ module Quox.Syntax.Term
 import public Quox.Syntax.Term.Base
 import public Quox.Syntax.Term.Subst
 import public Quox.Syntax.Term.Pretty
+import public Quox.Syntax.Term.Tighten

lib/Quox/Syntax/Term/Base.idr

@@ -1,7 +1,7 @@
 module Quox.Syntax.Term.Base
 
-import public Quox.Var
-import public Quox.Scoped
+import public Quox.Thin
+import public Quox.Syntax.Var
 import public Quox.Syntax.Shift
 import public Quox.Syntax.Subst
 import public Quox.Syntax.Qty
@@ -19,9 +19,6 @@ import Data.Maybe
 import Data.Nat
 import public Data.So
 import Data.String
-import public Data.SortedMap
-import public Data.SortedMap.Dependent
-import public Data.SortedSet
 import Derive.Prelude
 
 %default total
@@ -47,406 +44,344 @@ TagVal : Type
 TagVal = String
 
 
-mutual
-  public export
-  TSubst : TSubstLike
-  TSubst d = Subst $ \n => Elim d n
+||| type-checkable terms, which consists of types and constructor forms.
+|||
+||| first argument `d` is dimension scope size; second `n` is term scope size
+public export
+data Term : (d, n : Nat) -> Type
+%name Term s, t, r
 
-  ||| first argument `d` is dimension scope size;
-  ||| second `n` is term scope size
-  public export
-  data Term : (d, n : Nat) -> Type where
-    ||| 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
-    ||| function term
-    Lam : (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
-
-    ||| pair type
-    Sig : (fst : Term d n) -> (snd : ScopeTerm d n) -> (loc : Loc) -> Term d n
-    ||| pair value
-    Pair : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
-
-    ||| enumeration type
-    Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term d n
-    ||| enumeration value
-    Tag : (tag : TagVal) -> (loc : Loc) -> Term d n
-
-    ||| equality type
-    Eq : (ty : DScopeTerm d n) -> (l, r : Term d n) -> (loc : Loc) -> Term d n
-    ||| equality term
-    DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
-
-    ||| natural numbers (temporary until 𝐖 gets added)
-    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
-
-    ||| term closure/suspended substitution
-    CloT  : WithSubst (Term d) (Elim d) n -> Term d n
-    ||| dimension closure/suspended substitution
-    DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
-  %name Term s, t, r
-
-  ||| first argument `d` is dimension scope size, second `n` is term scope size
-  public export
-  data Elim : (d, n : Nat) -> Type where
-    ||| free variable, possibly with a displacement (see @crude, or @mugen for a
-    ||| more abstract and formalised take)
-    |||
-    ||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
-    F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim d n
-    ||| bound variable
-    B : (i : Var n) -> (loc : Loc) -> Elim d n
-
-    ||| term application
-    App : (fun : Elim d n) -> (arg : Term d n) -> (loc : Loc) -> Elim d n
-
-    ||| pair destruction
-    |||
-    ||| `CasePair 𝜋 𝑒 ([𝑟], 𝐴) ([𝑥, 𝑦], 𝑡)` is
-    ||| `𝐜𝐚𝐬𝐞 𝜋 · 𝑒 𝐫𝐞𝐭𝐮𝐫𝐧 𝑟 ⇒ 𝐴 𝐨𝐟 { (𝑥, 𝑦) ⇒ 𝑡 }`
-    CasePair : (qty : Qty) -> (pair : Elim d n) ->
-               (ret : ScopeTerm d n) ->
-               (body : ScopeTermN 2 d n) ->
-               (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) ->
-               (arms : CaseEnumArms d n) ->
-               (loc : Loc) ->
-               Elim d n
-
-    ||| nat matching
-    CaseNat : (qty, qtyIH : Qty) -> (nat : Elim d n) ->
-              (ret : ScopeTerm d n) ->
-              (zero : Term d n) ->
-              (succ : ScopeTermN 2 d n) ->
-              (loc : Loc) ->
-              Elim d n
-
-    ||| unboxing
-    CaseBox : (qty : Qty) -> (box : Elim d n) ->
-              (ret : ScopeTerm d n) ->
-              (body : ScopeTerm d n) ->
-              (loc : Loc) ->
-              Elim d n
-
-    ||| dim application
-    DApp : (fun : Elim d n) -> (arg : Dim d) -> (loc : Loc) -> Elim d n
-
-    ||| type-annotated term
-    Ann : (tm, ty : Term d n) -> (loc : Loc) -> Elim d n
-
-    ||| coerce a value along a type equality, or show its coherence
-    ||| [@xtt; §2.1.1]
-    Coe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
-          (val : Term d n) -> (loc : Loc) -> Elim d n
-
-    ||| "generalised composition" [@xtt; §2.1.2]
-    Comp : (ty : Term d n) -> (p, q : Dim d) ->
-           (val : Term d n) -> (r : Dim d) ->
-           (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
-
-    ||| match on types. needed for b.s. of coercions [@xtt; §2.2]
-    TypeCase : (ty : Elim d n) -> (ret : Term d n) ->
-               (arms : TypeCaseArms d n) -> (def : Term d n) ->
-               (loc : Loc) ->
-               Elim d n
-
-    ||| term closure/suspended substitution
-    CloE  : WithSubst (Elim d) (Elim d) n -> Elim d n
-    ||| dimension closure/suspended substitution
-    DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
-  %name Elim e, f
-
-  public export
-  CaseEnumArms : TermLike
-  CaseEnumArms d n = SortedMap TagVal (Term d n)
-
-  public export
-  TypeCaseArms : TermLike
-  TypeCaseArms d n = SortedDMap TyConKind (\k => TypeCaseArmBody k d n)
-
-  public export
-  TypeCaseArm : TermLike
-  TypeCaseArm d n = (k ** TypeCaseArmBody k d n)
-
-  public export
-  TypeCaseArmBody : TyConKind -> TermLike
-  TypeCaseArmBody k = ScopeTermN (arity k)
+||| inferrable terms, which consists of elimination forms like application and
+||| `case` (as well as other terms with an annotation)
+|||
+||| first argument `d` is dimension scope size; second `n` is term scope size
+public export
+data Elim : (d, n : Nat) -> Type
+%name Elim e, f
 
 
-  public export
-  ScopeTermN, DScopeTermN : Nat -> TermLike
-  ScopeTermN  s d n = Scoped s (Term d) n
-  DScopeTermN s d n = Scoped s (\d => Term d n) d
+public export
+ScopeTermN : Nat -> TermLike
+ScopeTermN s d n = ScopedN s (\n => Term d n) n
 
-  public export
-  ScopeTerm, DScopeTerm : TermLike
-  ScopeTerm  = ScopeTermN 1
-  DScopeTerm = DScopeTermN 1
+public export
+DScopeTermN : Nat -> TermLike
+DScopeTermN s d n = ScopedN s (\d => Term d n) d
 
-mutual
-  export %hint
-  EqTerm : Eq (Term d n)
-  EqTerm = assert_total {a = Eq (Term d n)} deriveEq
+public export
+ScopeTerm : TermLike
+ScopeTerm = ScopeTermN 1
 
-  export %hint
-  EqElim : Eq (Elim d n)
-  EqElim = assert_total {a = Eq (Elim d n)} deriveEq
-
-mutual
-  export %hint
-  ShowTerm : Show (Term d n)
-  ShowTerm = assert_total {a = Show (Term d n)} deriveShow
-
-  export %hint
-  ShowElim : Show (Elim d n)
-  ShowElim = assert_total {a = Show (Elim d n)} deriveShow
+public export
+DScopeTerm : TermLike
+DScopeTerm = DScopeTermN 1
 
 
-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
+TermT : TermLike
+TermT = Thinned2 (\d, n => Term d n)
 
-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
+public export
+ElimT : TermLike
+ElimT = Thinned2 (\d, n => Elim d n)
 
 
-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
+DimArg : TermLike
+DimArg d n = Dim d
 
 
-||| more convenient Pi
-public export %inline
-PiY : (qty : Qty) -> (x : BindName) ->
-      (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
-PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc}
+data Term where
+  ||| type of types
+  TYPE : (l : Universe) -> (loc : Loc) -> Term 0 0
 
-||| more convenient Lam
-public export %inline
-LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
-LamY {x, body, loc} = Lam {body = SY [< x] body, loc}
+  ||| function type
+  Pi : Qty -> Subterms [Term, ScopeTerm] d n -> Loc -> Term d n
+  ||| function value
+  Lam : ScopeTerm d n -> Loc -> Term d n
 
-public export %inline
-LamN : (body : Term d n) -> (loc : Loc) -> Term d n
-LamN {body, loc} = Lam {body = SN body, loc}
+  ||| pair type
+  Sig : Subterms [Term, ScopeTerm] d n -> Loc -> Term d n
+  ||| pair value
+  Pair : Subterms [Term, Term] d n -> Loc -> Term d n
 
-||| non dependent function type
-public export %inline
-Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n
-Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}
+  ||| enum type
+  Enum : List TagVal -> Loc -> Term 0 0
+  ||| enum value
+  Tag : TagVal -> Loc -> Term 0 0
 
-||| more convenient Sig
-public export %inline
-SigY : (x : BindName) -> (fst : Term d n) ->
-       (snd : Term d (S n)) -> (loc : Loc) -> Term d n
-SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}
+  ||| equality type
+  Eq : Subterms [DScopeTerm, Term, Term] d n -> Loc -> Term d n
+  ||| equality value
+  DLam : DScopeTerm d n -> Loc -> Term d n
 
-||| non dependent pair type
-public export %inline
-And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
-And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}
+  ||| natural numbers (temporary until 𝐖 gets added)
+  Nat  : Loc -> Term 0 0
+  Zero : Loc -> Term 0 0
+  Succ : Term d n -> Loc -> Term 0 0
 
-||| more convenient Eq
-public export %inline
-EqY : (i : BindName) -> (ty : Term (S d) n) ->
-      (l, r : Term d n) -> (loc : Loc) -> Term d n
-EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}
+  ||| package a value with a quantity
+  ||| e.g. a value of [ω. A], when unpacked, can be used ω times,
+  ||| even if the box itself is linear
+  BOX : Qty -> Term d n -> Loc -> Term d n
+  Box : Term d n -> Loc -> Term d n
 
-||| more convenient DLam
-public export %inline
-DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
-DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}
+  E : Elim d n -> Term d n
 
-public export %inline
-DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
-DLamN {body, loc} = DLam {body = SN body, loc}
+  ||| term closure/suspended substitution
+  CloT  : WithSubst2 Term Elim d n -> Term d n
+  ||| dimension closure/suspended substitution
+  DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
 
-||| more convenient Coe
-public export %inline
-CoeY : (i : BindName) -> (ty : Term (S d) n) ->
-       (p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
-CoeY {i, ty, p, q, val, loc} = Coe {ty = SY [< i] ty, p, q, val, loc}
+public export
+data Elim where
+  ||| free variable, possibly with a displacement (see @crude, or @mugen for a
+  ||| more abstract and formalised take)
+  |||
+  ||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
+  F : Name -> Universe -> Loc -> Elim 0 0
+  ||| bound variable
+  B : Loc -> Elim 0 1
+
+  ||| term application
+  App : Subterms [Elim, Term] d n -> Loc -> Elim d n
+
+  ||| pair match
+  ||| - the subterms are, in order: [head, return type, body]
+  ||| - the quantity is that of the head, and since pairs only have one
+  |||   constructor, can be 0
+  CasePair : Qty -> Subterms [Elim, ScopeTerm, ScopeTermN 2] d n ->
+             Loc -> Elim d n
+
+  ||| enum match
+  CaseEnum : Qty -> (arms : List TagVal) ->
+             Subterms (Elim :: ScopeTerm :: (Term <$ arms)) d n ->
+             Loc -> Elim d n
+
+  ||| nat match
+  CaseNat : Qty -> Qty ->
+            Subterms [Elim, ScopeTerm, Term, ScopeTermN 2] d n ->
+            Loc -> Elim d n
+
+  ||| box match
+  CaseBox : Qty -> Subterms [Elim, ScopeTerm, ScopeTerm] d n -> Loc -> Elim d n
+
+  ||| dim application
+  DApp : Subterms [Elim, DimArg] d n -> Loc -> Elim d n
+
+  ||| type-annotated term
+  Ann : Subterms [Term, Term] d n -> Loc -> Elim d n
+
+  ||| coerce a value along a type equality, or show its coherence
+  ||| [@xtt; §2.1.1]
+  Coe : Subterms [DScopeTerm, DimArg, DimArg, Term] d n ->
+        Loc -> Elim d n
+
+  ||| "generalised composition" [@xtt; §2.1.2]
+  Comp : Subterms [Term, DimArg, DimArg, Term,
+                   DimArg, DScopeTerm, DScopeTerm] d n ->
+         Loc -> Elim d n
+
+  ||| match on types. needed for b.s. of coercions [@xtt; §2.2]
+  TypeCase : Subterms [Elim, Term,   -- head, type
+                       Term,         -- ★
+                       ScopeTermN 2, -- pi
+                       ScopeTermN 2, -- sig
+                       Term,         -- enum
+                       ScopeTermN 5, -- eq
+                       Term,         -- nat
+                       ScopeTerm     -- box
+                      ] d n -> Loc -> Elim d n
+
+  ||| term closure/suspended substitution
+  CloE  : WithSubst2 Elim Elim d n -> Elim d n
+  ||| dimension closure/suspended substitution
+  DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
+
+
+-- this kills the idris ☹
+-- export %hint
+-- EqTerm : Eq (Term d n)
+
+-- export %hint
+-- EqElim : Eq (Elim d n)
+
+-- EqTerm = deriveEq
+-- EqElim = deriveEq
+
+
+-- mutual
+--   export %hint
+--   ShowTerm : Show (Term d n)
+--   ShowTerm = assert_total {a = Show (Term d n)} deriveShow
+
+--   export %hint
+--   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
+
+-- 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
+
+-- ||| more convenient Pi
+-- public export %inline
+-- PiY : (qty : Qty) -> (x : BindName) ->
+--       (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
+-- PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc}
+
+-- ||| more convenient Lam
+-- public export %inline
+-- LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
+-- LamY {x, body, loc} = Lam {body = SY [< x] body, loc}
+
+-- public export %inline
+-- LamN : (body : Term d n) -> (loc : Loc) -> Term d n
+-- LamN {body, loc} = Lam {body = SN body, loc}
+
+-- ||| non dependent function type
+-- public export %inline
+-- Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n
+-- Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}
+
+-- ||| more convenient Sig
+-- public export %inline
+-- SigY : (x : BindName) -> (fst : Term d n) ->
+--        (snd : Term d (S n)) -> (loc : Loc) -> Term d n
+-- SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}
+
+-- ||| non dependent pair type
+-- public export %inline
+-- And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
+-- And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}
+
+-- ||| more convenient Eq
+-- public export %inline
+-- EqY : (i : BindName) -> (ty : Term (S d) n) ->
+--       (l, r : Term d n) -> (loc : Loc) -> Term d n
+-- EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}
+
+-- ||| more convenient DLam
+-- public export %inline
+-- DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
+-- DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}
+
+-- public export %inline
+-- DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
+-- DLamN {body, loc} = DLam {body = SN body, loc}
+
+-- ||| non dependent equality type
+-- public export %inline
+-- Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
+-- Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
 
-||| non dependent equality type
-public export %inline
-Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
-Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
 
 ||| same as `F` but as a term
 public export %inline
-FT : Name -> Universe -> Loc -> Term d n
+FT : Name -> Universe -> Loc -> Term 0 0
 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
-BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n
-BV i loc = B (V i) loc
+BV : (i : Fin n) -> (loc : Loc) -> ElimT d n
+BV i loc = Th2 zero (one' i) $ B loc
 
 ||| same as `BV` but as a term
 public export %inline
-BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
-BVT i loc = E $ BV i loc
+BVT : (i : Fin n) -> (loc : Loc) -> TermT d n
+BVT i loc = Th2 zero (one' i) $ E $ B loc
 
-public export %inline
-Zero : Loc -> Term d n
-Zero = Nat 0
+public export
+makeNat : Nat -> Loc -> Term 0 0
+makeNat 0     loc = Zero loc
+makeNat (S k) loc = Succ (makeNat k loc) loc
 
-public export %inline
-enum : List TagVal -> Loc -> Term d n
-enum ts loc = Enum (SortedSet.fromList ts) loc
 
-public export %inline
-typeCase : Elim d n -> Term d n ->
-           List (TypeCaseArm d n) -> Term d n -> Loc -> Elim d n
-typeCase ty ret arms def loc = TypeCase ty ret (fromList arms) 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 (Sub2 e _)).loc    = e.loc
+  (DCloE (Sub e _)).loc    = e.loc
 
-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} ->
-             Elim d n
-typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def 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 (Sub2 t _)).loc = t.loc
+  (DCloT (Sub t _)).loc = t.loc
+
+
+export
+Relocatable (Elim d n) where
+  setLoc loc (F x u _)                = F x u loc
+  setLoc loc (B _)                    = B loc
+  setLoc loc (App ts _)               = App ts loc
+  setLoc loc (CasePair qty ts _)      = CasePair qty ts loc
+  setLoc loc (CaseEnum qty arms ts _) = CaseEnum qty arms ts loc
+  setLoc loc (CaseNat qty qtyIH ts _) = CaseNat qty qtyIH ts loc
+  setLoc loc (CaseBox qty ts _)       = CaseBox qty ts loc
+  setLoc loc (DApp ts _)              = DApp ts loc
+  setLoc loc (Ann ts _)               = Ann ts loc
+  setLoc loc (Coe ts _)               = Coe ts loc
+  setLoc loc (Comp ts _)              = Comp ts loc
+  setLoc loc (TypeCase ts _)          = TypeCase ts loc
+  setLoc loc (CloE (Sub2 term subst)) = CloE $ Sub2 (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 ts _)            = Pi qty ts loc
+  setLoc loc (Lam body _)             = Lam body loc
+  setLoc loc (Sig ts _)               = Sig ts loc
+  setLoc loc (Pair ts _)              = Pair ts loc
+  setLoc loc (Enum cases _)           = Enum cases loc
+  setLoc loc (Tag tag _)              = Tag tag loc
+  setLoc loc (Eq ts _)                = Eq ts 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 (Sub2 term subst)) = CloT $ Sub2 (setLoc loc term) subst
+  setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst

lib/Quox/Syntax/Term/Pretty.idr

@@ -18,11 +18,11 @@ prettyUniverse = hl Universe . text . show
 
 
 export
-prettyTerm : {opts : _} -> BContext d -> BContext n -> Term d n ->
+prettyTerm : {opts : _} -> BContext d -> BContext n -> TermT d n ->
              Eff Pretty (Doc opts)
 
 export
-prettyElim : {opts : _} -> BContext d -> BContext n -> Elim d n ->
+prettyElim : {opts : _} -> BContext d -> BContext n -> ElimT d n ->
              Eff Pretty (Doc opts)
 
 private
@@ -30,6 +30,14 @@ 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
@@ -201,7 +209,8 @@ prettyTArg dnames tnames s =
 
 private
 prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
-prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
+prettyDArg dnames p =
+  map (text "@" <+>) $ withPrec Arg $ prettyDim dnames p
 
 private
 splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
@@ -229,6 +238,7 @@ 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
@@ -241,11 +251,12 @@ parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
     body <- withPrec Outer $ assert_total
             prettyTerm (dnames . dbinds) (tnames . tbinds) body
     header <- (pat <++>) <$> darrowD
-    pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
+    pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
 
   private
-  prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts))
-  prettyCaseBody xs = traverse prettyCaseArm xs
+  prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (Doc opts)
+  prettyCaseBody xs =
+    braces . separateTight !semiD =<< traverse prettyCaseArm xs
 
 private
 prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts)
@@ -272,12 +283,16 @@ 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 Constant . Doc.text . quoteTag) cases
+  traverse (hl Tag . Doc.text . quoteTag) cases
 
 private
 prettyCaseRet : {opts : _} ->
@@ -288,7 +303,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
-    hangDSingle header body
+    pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
 
 private
 prettyCase_ : {opts : _} ->
@@ -296,16 +311,10 @@ 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   <- 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])
+  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]
 
 private
 prettyCase : {opts : _} ->
@@ -316,62 +325,6 @@ 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
@@ -389,7 +342,6 @@ 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] =
@@ -398,7 +350,6 @@ 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
 
 
@@ -432,13 +383,13 @@ prettyDisp u = map Just $ hl Universe =<<
   ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
 
 
-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 (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 (Pi qty arg res _) =
   parensIfM Outer =<< do
@@ -475,31 +426,35 @@ prettyTerm dnames tnames (Enum cases _) =
 prettyTerm dnames tnames (Tag tag _) =
   prettyTag tag
 
-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 (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 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 (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 s@(DLam {}) =
   prettyLambda dnames tnames s
 
-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 (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 (BOX qty ty _) =
   bracks . hcat =<<
@@ -509,18 +464,7 @@ prettyTerm dnames tnames (BOX qty ty _) =
 prettyTerm dnames tnames (Box val _) =
   bracks =<< withPrec Outer (prettyTerm dnames tnames val)
 
-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 (E e) = prettyElim dnames tnames e
 
 prettyTerm dnames tnames t0@(CloT (Sub t ph)) =
   prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' id ph t
@@ -547,16 +491,6 @@ 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
@@ -567,7 +501,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.val == Unused
+  spat <- if ih.name == Unused
           then pure spat0
           else pure $ hsep [spat0 <+> !commaD, ihpat0]
   let sarm = MkCaseArm spat [<] [< p, ih] succ.term
@@ -583,31 +517,35 @@ prettyElim dnames tnames e@(DApp {}) =
   prettyDTApps dnames tnames f xs
 
 prettyElim dnames tnames (Ann tm 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
+  parensIfM Outer =<<
+    hangDSingle !(withPrec AnnL  [|prettyTerm dnames tnames tm <++> annD|])
+                !(withPrec Outer (prettyTerm dnames tnames ty))
 
 prettyElim dnames tnames (Coe ty 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]
+  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]
 
 prettyElim dnames tnames e@(Comp ty p q val r zero one _) =
   parensIfM App =<< do
-    ty   <- assert_total $ prettyTypeLine dnames tnames $ SN ty
+    ty   <- prettyTypeLine dnames tnames $ assert_smaller e $ 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
-    layoutComp [ty, pq] val r [arm0, arm1]
+    if isDefaultDir p q
+       then layoutComp [ty]     val r [arm0, arm1]
+       else 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,383 +2,462 @@ module Quox.Syntax.Term.Subst
 
 import Quox.No
 import Quox.Syntax.Term.Base
+import Quox.Syntax.Subst
+
 import Data.SnocVect
+import Data.Singleton
 
 %default total
 
-namespace CanDSubst
-  public export
-  interface CanDSubst (0 tm : TermLike) where
-    (//) : tm d1 n -> Lazy (DSubst d1 d2) -> tm d2 n
 
-||| does the minimal reasonable work:
-||| - deletes the closure around an atomic constant like `TYPE`
-||| - deletes an identity substitution
-||| - composes (lazily) with an existing top-level dim-closure
-||| - otherwise, wraps in a new closure
-export
-CanDSubst Term where
-  s                // Shift SZ = s
-  TYPE l loc       // _        = TYPE l loc
-  DCloT (Sub s ph) // th       = DCloT $ Sub s $ ph . th
-  s                // th       = DCloT $ Sub s th
+infixl 8 ///
 
-private
-subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
-subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
-subDArgs e              th = DCloE $ Sub e th
+parameters {0 f : Nat -> Nat -> Type}
+  private
+  th0 : f 0 0 -> Thinned2 f d n
+  th0 = Th2 zero zero
 
-||| does the minimal reasonable work:
-||| - deletes the closure around a term variable
-||| - deletes an identity substitution
-||| - composes (lazily) with an existing top-level dim-closure
-||| - immediately looks up bound variables in a
-|||   top-level sequence of dimension applications
-||| - otherwise, wraps in a new closure
-export
-CanDSubst Elim where
-  e                // Shift SZ = e
-  F x u loc        // _        = F x u loc
-  B i loc          // _        = B i loc
-  e@(DApp {})      // th       = subDArgs e th
-  DCloE (Sub e ph) // th       = DCloE $ Sub e $ ph . th
-  e                // th       = DCloE $ Sub e th
+  private
+  th1 : {d, n : Nat} -> f d n -> Thinned2 f d n
+  th1 = Th2 id' id'
 
-namespace DSubst.ScopeTermN
-  export %inline
-  (//) : ScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
-         ScopeTermN s d2 n
-  S ns (Y body) // th = S ns $ Y $ body // th
-  S ns (N body) // th = S ns $ N $ body // th
+private dsubTerm : {d1, d2, n : Nat} -> Term d1 n -> DSubst d1 d2 -> TermT d2 n
+private dsubElim : {d1, d2, n : Nat} -> Elim d1 n -> DSubst d1 d2 -> ElimT d2 n
 
-namespace DSubst.DScopeTermN
-  export %inline
-  (//) : {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 (locs $ toList' ns) th
-  S ns (N body) // th = S ns $ N $ body // th
+dsubTerm (TYPE l loc) th = th0 $ TYPE l loc
+dsubTerm (Enum strs loc) th = th0 $ Enum strs loc
+dsubTerm (Tag str loc) th = th0 $ Tag str loc
+dsubTerm (Nat loc) th = th0 $ Nat loc
+dsubTerm (Zero loc) th = th0 $ Zero loc
+dsubTerm (E e) th =
+  let Th2 dope tope e' = dsubElim e th in
+  Th2 dope tope $ E e'
+dsubTerm (DCloT (Sub t ph)) th = th1 $ DCloT $ Sub t $ ph . th
+dsubTerm t th = th1 $ DCloT $ Sub t th
 
-
-export %inline FromVar (Elim d) where fromVarLoc = B
-export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
-
-
-||| does the minimal reasonable work:
-||| - deletes the closure around a *free* name
-||| - deletes an identity substitution
-||| - composes (lazily) with an existing top-level closure
-||| - immediately looks up a bound variable
-||| - otherwise, wraps in a new closure
-export
-CanSubstSelf (Elim d) where
-  F x u loc       // _  = F x u loc
-  B i loc         // th = getLoc th i loc
-  CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th
-  e               // th = case force th of
-                               Shift SZ => e
-                               th       => CloE $ Sub e th
-
-namespace CanTSubst
-  public export
-  interface CanTSubst (0 tm : TermLike) where
-    (//) : tm d n1 -> Lazy (TSubst d n1 n2) -> tm d n2
-
-||| does the minimal reasonable work:
-||| - deletes the closure around an atomic constant like `TYPE`
-||| - deletes an identity substitution
-||| - composes (lazily) with an existing top-level closure
-||| - goes inside `E` in case it is a simple variable or something
-||| - otherwise, wraps in a new closure
-export
-CanTSubst Term where
-  TYPE l loc      // _  = TYPE l loc
-  E e             // th = E $ e // th
-  CloT (Sub s ph) // th = CloT $ Sub s $ ph . th
-  s               // th = case force th of
-                               Shift SZ => s
-                               th       => CloT $ Sub s th
-
-namespace ScopeTermN
-  export %inline
-  (//) : {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 (locs $ toList' ns) th
-  S ns (N body) // th = S ns $ N $ body // th
-
-namespace DScopeTermN
-  export %inline
-  (//) : {s : Nat} ->
-         DScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> DScopeTermN s d n2
-  S ns (Y body) // th = S ns $ Y $ body // map (// shift s) th
-  S ns (N body) // th = S ns $ N $ body // th
-
-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
-
-
-export %inline
-comp : DSubst d1 d2 -> TSubst d1 n1 mid -> TSubst d2 mid n2 -> TSubst d2 n1 n2
-comp th ps ph = map (// th) ps . ph
-
-
-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
-
-
-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 {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
-
-  export %inline
-  (.term) : Scoped s f n -> f (s + n)
-  t.term = getTerm t.body
-
-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
-subN (S _ (Y body)) es = body // fromSnocVect es
-subN (S _ (N body)) _  = body
-
-export %inline
-sub1 : ScopeTerm d n -> Elim d n -> Term d n
-sub1 t e = subN t [< e]
-
-export %inline
-dsubN : DScopeTermN s d n -> SnocVect s (Dim d) -> Term d n
-dsubN (S _ (Y body)) ps = body // fromSnocVect ps
-dsubN (S _ (N body)) _  = body
-
-export %inline
-dsub1 : DScopeTerm d n -> Dim d -> Term d n
-dsub1 t p = dsubN t [< p]
-
-
-public export %inline
-(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
-body.zero = dsub1 body $ K Zero loc
-
-public export %inline
-(.one) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
-body.one = dsub1 body $ K One loc
-
-
-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)
-
-public export
-0 NotClo : {isClo : CloTest tm} -> PushSubsts tm isClo => Pred (tm d n)
-NotClo = No . isClo
-
-public export
-0 NonClo : (tm : TermLike) -> {isClo : CloTest tm} ->
-           PushSubsts tm isClo => TermLike
-NonClo tm d n = Subset (tm d n) NotClo
-
-public export %inline
-nclo : {isClo : CloTest tm} -> (0 _ : PushSubsts tm isClo) =>
-       (t : tm d n) -> (0 nc : NotClo t) => NonClo tm d n
-nclo t = Element t nc
-
-parameters {0 isClo : CloTest tm} {auto _ : PushSubsts tm isClo}
-  ||| if the input term has any top-level closures, push them under one layer of
-  ||| syntax
-  export %inline
-  pushSubsts : tm d n -> NonClo tm d n
-  pushSubsts s = pushSubstsWith id id s
-
-  export %inline
-  pushSubstsWith' : DSubst d1 d2 -> TSubst d2 n1 n2 -> tm d1 n1 -> tm d2 n2
-  pushSubstsWith' th ph x = fst $ pushSubstsWith th ph x
-
-  export %inline
-  pushSubsts' : tm d n -> tm d n
-  pushSubsts' s = fst $ pushSubsts s
+dsubElim (F x l loc) th = th0 $ F x l loc
+dsubElim (B loc) th = Th2 zero id' $ B loc
+dsubElim (DCloE (Sub e ph)) th = th1 $ DCloE $ Sub e $ ph . th
+dsubElim e th = th1 $ DCloE $ Sub e th
 
 mutual
-  public export
-  isCloT : CloTest Term
-  isCloT (CloT  {}) = True
-  isCloT (DCloT {}) = True
-  isCloT (E e)      = isCloE e
-  isCloT _          = False
+  namespace Term
+    export
+    (///) : {d1, d2, n : Nat} -> TermT d1 n -> DSubst d1 d2 -> TermT d2 n
+    Th2 dope tope term /// th =
+      let Val tscope = appOpe n tope; Val dscope = appOpe d1 dope
+          Th2 dope' tope' term' = dsubTerm term (select dope th)
+      in
+      Th2 dope' (tope . tope') term'
+
+  namespace Elim
+    export
+    (///) : {d1, d2, n : Nat} -> ElimT d1 n -> DSubst d1 d2 -> ElimT d2 n
+    Th2 dope tope elim /// th =
+      let Val tscope = appOpe n tope; Val dscope = appOpe d1 dope
+          Th2 dope' tope' elim' = dsubElim elim (select dope th)
+      in
+      Th2 dope' (tope . tope') elim'
+
+
+public export
+TSubst : Nat -> Nat -> Nat -> Type
+TSubst = Subst2 Elim
+
+
+public export %inline FromVar (Elim 0) where var = B
+
+export CanSubstSelf2 Elim
+
+private subTerm : {d, n1, n2 : Nat} -> Term d n1 -> TSubst d n1 n2 -> TermT d n2
+private subElim : {d, n1, n2 : Nat} -> Elim d n1 -> TSubst d n1 n2 -> ElimT d n2
+
+subTerm (TYPE l loc) th = th0 $ TYPE l loc
+subTerm (Nat loc) th = th0 $ Nat loc
+subTerm (Zero loc) th = th0 $ Zero loc
+subTerm (E e) th = let Th2 dope tope e' = subElim e th in Th2 dope tope $ E e'
+subTerm (CloT (Sub2 s ph)) th = th1 $ CloT $ Sub2 s $ ph .% th
+subTerm s th = th1 $ CloT $ Sub2 s th
+
+subElim (F x k loc) th = th0 $ F x k loc
+subElim (B loc) [< e] = e
+subElim (CloE (Sub2 e ph)) th = th1 $ CloE $ Sub2 e $ ph .% th
+subElim e th = th1 $ CloE $ Sub2 e th
+
 
-  public export
-  isCloE : CloTest Elim
-  isCloE (CloE  {}) = True
-  isCloE (DCloE {}) = True
-  isCloE _          = False
 
 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
+CanSubstSelf2 Elim where
+  Th2 dope tope elim // th =
+    let
+        th' = select tope th
+    in
+    ?sube2
 
-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
+-- namespace CanDSubst
+--   public export
+--   interface CanDSubst (0 tm : TermLike) where
+--     (//) : {d1 : Nat} -> Thinned2 tm d1 n -> Lazy (DSubst d1 d2) ->
+--            Thinned2 tm d2 n
+
+-- ||| does the minimal reasonable work:
+-- ||| - deletes the closure around an atomic constant like `TYPE`
+-- ||| - deletes an identity substitution
+-- ||| - composes (lazily) with an existing top-level dim-closure
+-- ||| - otherwise, wraps in a new closure
+-- export
+-- CanDSubst Term where
+--   Th2 _ _ (TYPE l loc)       // _        = Th2 zero zero $ TYPE l loc
+--   Th2 i j (DCloT (Sub s ph)) // th       =
+--     Th2 ?i' j $ DCloT $ Sub s $ ph . ?th'
+--   Th2 i j s                  // th       = ?sdf -- DCloT $ Sub s th
+
+-- -- private
+-- -- subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
+-- -- subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
+-- -- subDArgs e              th = DCloE $ Sub e th
+
+-- -- ||| does the minimal reasonable work:
+-- -- ||| - deletes the closure around a term variable
+-- -- ||| - deletes an identity substitution
+-- -- ||| - composes (lazily) with an existing top-level dim-closure
+-- -- ||| - immediately looks up bound variables in a
+-- -- |||   top-level sequence of dimension applications
+-- -- ||| - otherwise, wraps in a new closure
+-- -- export
+-- -- CanDSubst Elim where
+-- --   e                // Shift SZ = e
+-- --   F x u loc        // _        = F x u loc
+-- --   B i loc          // _        = B i loc
+-- --   e@(DApp {})      // th       = subDArgs e th
+-- --   DCloE (Sub e ph) // th       = DCloE $ Sub e $ ph . th
+-- --   e                // th       = DCloE $ Sub e th
+
+-- -- namespace DSubst.ScopeTermN
+-- --   export %inline
+-- --   (//) : ScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
+-- --          ScopeTermN s d2 n
+-- --   S ns (Y body) // th = S ns $ Y $ body // th
+-- --   S ns (N body) // th = S ns $ N $ body // th
+
+-- -- namespace DSubst.DScopeTermN
+-- --   export %inline
+-- --   (//) : {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 (N body) // th = S ns $ N $ body // th
 
 
-||| heterogeneous comp, in terms of Comp and Coe
-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' = SY 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 = 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
-  }
+-- -- export %inline FromVar (Elim d) where fromVarLoc = B
+-- -- export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
 
-||| heterogeneous comp, in terms of Comp and Coe
-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 [< j1] one, loc}
+
+-- -- ||| does the minimal reasonable work:
+-- -- ||| - deletes the closure around a *free* name
+-- -- ||| - deletes an identity substitution
+-- -- ||| - composes (lazily) with an existing top-level closure
+-- -- ||| - immediately looks up a bound variable
+-- -- ||| - otherwise, wraps in a new closure
+-- -- export
+-- -- CanSubstSelf (Elim d) where
+-- --   F x u loc       // _  = F x u loc
+-- --   B i loc         // th = getLoc th i loc
+-- --   CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th
+-- --   e               // th = case force th of
+-- --                                Shift SZ => e
+-- --                                th       => CloE $ Sub e th
+
+-- -- namespace CanTSubst
+-- --   public export
+-- --   interface CanTSubst (0 tm : TermLike) where
+-- --     (//) : tm d n1 -> Lazy (TSubst d n1 n2) -> tm d n2
+
+-- -- ||| does the minimal reasonable work:
+-- -- ||| - deletes the closure around an atomic constant like `TYPE`
+-- -- ||| - deletes an identity substitution
+-- -- ||| - composes (lazily) with an existing top-level closure
+-- -- ||| - goes inside `E` in case it is a simple variable or something
+-- -- ||| - otherwise, wraps in a new closure
+-- -- export
+-- -- CanTSubst Term where
+-- --   TYPE l loc      // _  = TYPE l loc
+-- --   E e             // th = E $ e // th
+-- --   CloT (Sub s ph) // th = CloT $ Sub s $ ph . th
+-- --   s               // th = case force th of
+-- --                                Shift SZ => s
+-- --                                th       => CloT $ Sub s th
+
+-- -- namespace ScopeTermN
+-- --   export %inline
+-- --   (//) : {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 (N body) // th = S ns $ N $ body // th
+
+-- -- namespace DScopeTermN
+-- --   export %inline
+-- --   (//) : {s : Nat} ->
+-- --          DScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> DScopeTermN s d n2
+-- --   S ns (Y body) // th = S ns $ Y $ body // map (// shift s) th
+-- --   S ns (N body) // th = S ns $ N $ body // th
+
+-- -- export %inline CanShift (Term d) where s // by = s // Shift by
+-- -- export %inline CanShift (Elim d) where e // by = e // Shift by
+
+-- -- export %inline
+-- -- {s : Nat} -> CanShift (ScopeTermN s d) where
+-- --   b // by = b // Shift by
+
+
+-- -- export %inline
+-- -- comp : DSubst d1 d2 -> TSubst d1 n1 mid -> TSubst d2 mid n2 -> TSubst d2 n1 n2
+-- -- comp th ps ph = map (// th) ps . ph
+
+
+-- -- public export %inline
+-- -- dweakT : (by : Nat) -> Term d n -> Term (by + d) n
+-- -- dweakT by t = t // shift by
+
+-- -- public export %inline
+-- -- dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
+-- -- dweakE by t = t // shift by
+
+
+-- -- public export %inline
+-- -- weakT : (by : Nat) -> Term d n -> Term d (by + n)
+-- -- weakT 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
+
+-- --   namespace ScopeTermN
+-- --     export %inline
+-- --     (.term) : ScopeTermN s d n -> Term d (s + n)
+-- --     t.term = t.body.term
+
+-- --   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
+
+
+-- -- export %inline
+-- -- subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
+-- -- subN (S _ (Y body)) es = body // fromSnocVect es
+-- -- subN (S _ (N body)) _  = body
+
+-- -- export %inline
+-- -- sub1 : ScopeTerm d n -> Elim d n -> Term d n
+-- -- sub1 t e = subN t [< e]
+
+-- -- export %inline
+-- -- dsubN : DScopeTermN s d n -> SnocVect s (Dim d) -> Term d n
+-- -- dsubN (S _ (Y body)) ps = body // fromSnocVect ps
+-- -- dsubN (S _ (N body)) _  = body
+
+-- -- export %inline
+-- -- dsub1 : DScopeTerm d n -> Dim d -> Term d n
+-- -- dsub1 t p = dsubN t [< p]
+
+
+-- -- public export %inline
+-- -- (.zero) : DScopeTerm d n -> {default noLoc 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
+-- -- body.one = dsub1 body $ K One loc
+
+
+-- -- public export
+-- -- 0 CloTest : TermLike -> Type
+-- -- CloTest tm = forall d, n. tm d n -> Bool
+
+-- -- 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)
+
+-- -- public export
+-- -- 0 NotClo : {isClo : CloTest tm} -> PushSubsts tm isClo => Pred (tm d n)
+-- -- NotClo = No . isClo
+
+-- -- public export
+-- -- 0 NonClo : (tm : TermLike) -> {isClo : CloTest tm} ->
+-- --            PushSubsts tm isClo => TermLike
+-- -- NonClo tm d n = Subset (tm d n) NotClo
+
+-- -- public export %inline
+-- -- nclo : {isClo : CloTest tm} -> (0 _ : PushSubsts tm isClo) =>
+-- --        (t : tm d n) -> (0 nc : NotClo t) => NonClo tm d n
+-- -- nclo t = Element t nc
+
+-- -- parameters {0 isClo : CloTest tm} {auto _ : PushSubsts tm isClo}
+-- --   ||| if the input term has any top-level closures, push them under one layer of
+-- --   ||| syntax
+-- --   export %inline
+-- --   pushSubsts : tm d n -> NonClo tm d n
+-- --   pushSubsts s = pushSubstsWith id id s
+
+-- --   export %inline
+-- --   pushSubstsWith' : DSubst d1 d2 -> TSubst d2 n1 n2 -> tm d1 n1 -> tm d2 n2
+-- --   pushSubstsWith' th ph x = fst $ pushSubstsWith th ph x
+
+-- --   export %inline
+-- --   pushSubsts' : tm d n -> tm d n
+-- --   pushSubsts' s = fst $ pushSubsts s
+
+-- -- mutual
+-- --   public export
+-- --   isCloT : CloTest Term
+-- --   isCloT (CloT  {}) = True
+-- --   isCloT (DCloT {}) = True
+-- --   isCloT (E e)      = isCloE e
+-- --   isCloT _          = False
+
+-- --   public export
+-- --   isCloE : CloTest Elim
+-- --   isCloE (CloE  {}) = True
+-- --   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 (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}

lib/Quox/Syntax/Term/Tighten.idr

@@ -0,0 +1,334 @@
+module Quox.Syntax.Term.Tighten
+
+import Quox.Syntax.Term.Base
+import Quox.Syntax.Subst
+import public Quox.OPE
+
+%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)
+tightenScope f p (S names (Y body)) = SY names <$> f (keepN s p) body
+tightenScope f p (S names (N body)) = S names . N <$> f p body
+
+export
+tightenDScope : {0 f : Nat -> Nat -> Type} ->
+                (forall m, n, k. OPE m n -> f n k -> Maybe (f m k)) ->
+                OPE m n -> Scoped s (f n) k -> Maybe (Scoped s (f m) k)
+tightenDScope f p (S names (Y body)) = SY names <$> f p body
+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
+
+  private
+  tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
+  tightenE p (F x u loc) =
+    pure $ F x u loc
+  tightenE p (B i loc) =
+    B <$> tighten p i <*> pure loc
+  tightenE p (App fun arg loc) =
+    App <$> tightenE p fun <*> tightenT p arg <*> pure 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) =
+    CaseEnum qty <$> tightenE p tag
+                 <*> tightenS p ret
+                 <*> traverse (tightenT p) arms
+                 <*> pure 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) =
+    CaseBox qty <$> tightenE p box
+                <*> tightenS p ret
+                <*> tightenS p body
+                <*> pure loc
+  tightenE p (DApp fun arg loc) =
+    DApp <$> tightenE p fun <*> pure arg <*> pure loc
+  tightenE p (Ann tm ty loc) =
+    Ann <$> tightenT p tm <*> tightenT p ty <*> pure 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) =
+    Comp <$> tightenT p ty
+         <*> pure q0 <*> pure q1
+         <*> tightenT p val
+         <*> pure r
+         <*> tightenDS p zero
+         <*> tightenDS p one
+         <*> pure 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 ->
+             ScopeTermN s f n -> Maybe (ScopeTermN s f m)
+  tightenS = assert_total $ tightenScope tightenT
+
+  export
+  tightenDS : OPE m n -> DScopeTermN s f n -> Maybe (DScopeTermN s f m)
+  tightenDS = assert_total $ tightenDScope tightenT {f = \n, d => Term d n}
+
+export Tighten (Elim d) where tighten p e = tightenE p e
+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
+
+  export
+  dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
+  dtightenE p (F x u loc) =
+    pure $ F x u loc
+  dtightenE p (B i loc) =
+    pure $ B i loc
+  dtightenE p (App fun arg loc) =
+    App <$> dtightenE p fun <*> dtightenT p arg <*> pure 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) =
+    CaseEnum qty <$> dtightenE p tag
+                 <*> dtightenS p ret
+                 <*> traverse (dtightenT p) arms
+                 <*> pure 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) =
+    CaseBox qty <$> dtightenE p box
+                <*> dtightenS p ret
+                <*> dtightenS p body
+                <*> pure loc
+  dtightenE p (DApp fun arg loc) =
+    DApp <$> dtightenE p fun <*> tighten p arg <*> pure loc
+  dtightenE p (Ann tm ty loc) =
+    Ann <$> dtightenT p tm <*> dtightenT p ty <*> pure 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) =
+    [|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) =
+    [|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)
+  dtightenS = assert_total $ tightenDScope dtightenT {f = Term}
+
+  export
+  dtightenDS : {s : Nat} -> OPE d1 d2 ->
+               DScopeTermN s d2 n -> Maybe (DScopeTermN s d1 n)
+  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
+
+
+-- versions of SY, etc, that try to tighten and use SN automatically
+
+public export
+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
+
+public export
+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
+
+public export %inline
+PiT : (qty : Qty) -> (x : BindName) ->
+      (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
+PiT {qty, x, arg, res, loc} = Pi {qty, arg, res = ST [< x] res, loc}
+
+public export %inline
+LamT : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
+LamT {x, body, loc} = Lam {body = ST [< x] body, loc}
+
+public export %inline
+SigT : (x : BindName) -> (fst : Term d n) ->
+       (snd : Term d (S n)) -> (loc : Loc) -> Term d n
+SigT {x, fst, snd, loc} = Sig {fst, snd = ST [< x] snd, loc}
+
+public export %inline
+EqT : (i : BindName) -> (ty : Term (S d) n) ->
+      (l, r : Term d n) -> (loc : Loc) -> Term d n
+EqT {i, ty, l, r, loc} = Eq {ty = DST [< i] ty, l, r, loc}
+
+public export %inline
+DLamT : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
+DLamT {i, body, loc} = DLam {body = DST [< i] body, loc}
+
+public export %inline
+CoeT : (i : BindName) -> (ty : Term (S d) n) ->
+       (p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
+CoeT {i, ty, p, q, val, loc} = Coe {ty = DST [< i] ty, p, q, val, loc}
+
+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} ->
+             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
+
+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

lib/Quox/Syntax/Term/TyConKind.idr

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

lib/Quox/Syntax/Var.idr

@@ -1,7 +1,8 @@
-module Quox.Var
+module Quox.Syntax.Var
 
 import public Quox.Loc
 import public Quox.Name
+import Quox.OPE
 
 import Data.Nat
 import Data.List
@@ -137,12 +138,6 @@ export
 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 FromVar Var where fromVarLoc x _ = x
-
 export
 tabulateV : {0 tm : Nat -> Type} -> (forall n. Var n -> tm n) ->
             (n : Nat) -> Vect n (tm n)
@@ -289,3 +284,12 @@ decEqFromBool i j =
 %transform "Var.decEq" varDecEq = decEqFromBool
 
 public export %inline DecEq (Var n) where decEq = varDecEq
+
+
+export
+Tighten Var where
+  tighten Id       i      = Just i
+  tighten (Drop p) VZ     = Nothing
+  tighten (Drop p) (VS i) = tighten p i
+  tighten (Keep p) VZ     = Just VZ
+  tighten (Keep p) (VS i) = VS <$> tighten p i

lib/Quox/Thin.idr

@@ -0,0 +1,13 @@
+module Quox.Thin
+
+import public Quox.Thin.Base
+import public Quox.Thin.View
+import public Quox.Thin.Eqv
+import public Quox.Thin.Cons
+import public Quox.Thin.List
+import public Quox.Thin.Append
+import public Quox.Thin.Comp
+import public Quox.Thin.Cover
+import public Quox.Thin.Coprod
+import public Quox.Thin.Split
+import public Quox.Thin.Term

lib/Quox/Thin/Append.idr

@@ -0,0 +1,27 @@
+module Quox.Thin.Append
+
+import public Quox.Thin.Base
+import public Quox.Thin.View
+import Data.DPair
+
+%default total
+
+public export
+app' : OPE m1 n1 mask1 -> OPE m2 n2 mask2 -> Exists (OPE (m1 + m2) (n1 + n2))
+app' Stop             ope2 = Evidence _ ope2
+app' (Drop ope1 Refl) ope2 = Evidence _ $ Drop (app' ope1 ope2).snd Refl
+app' (Keep ope1 Refl) ope2 = Evidence _ $ Keep (app' ope1 ope2).snd Refl
+
+public export
+(++) : {n1, n2, mask1, mask2 : Nat} ->
+       (0 ope1 : OPE m1 n1 mask1) -> (0 ope2 : OPE m2 n2 mask2) ->
+       Subset Nat (OPE (m1 + m2) (n1 + n2))
+ope1 ++ ope2 with %syntactic (view ope1)
+  Stop           ++ ope2 | StopV = Element _ ope2
+  Drop ope1 Refl ++ ope2 | DropV mask ope1 =
+    Element _ $ Drop (ope1 ++ ope2).snd Refl
+  Keep ope1 Refl ++ ope2 | KeepV mask ope1 =
+    Element _ $ Keep (ope1 ++ ope2).snd Refl
+
+-- [todo] this mask is just (mask1 << n2) | mask2
+-- prove it and add %transform

lib/Quox/Thin/Base.idr

@@ -0,0 +1,81 @@
+module Quox.Thin.Base
+
+import Data.Fin
+import Data.DPair
+
+%default total
+
+||| "order preserving embeddings", for recording a correspondence between a
+||| smaller scope and part of a larger one. the third argument is a bitmask
+||| representing this OPE, unique for a given `n`.
+public export
+data OPE : (m, n, mask : Nat) -> Type where
+  [search m n]
+  Stop : OPE 0 0 0
+  Drop : OPE m n mask -> mask' = mask + mask       -> OPE m     (S n) mask'
+  Keep : OPE m n mask -> mask' = (S (mask + mask)) -> OPE (S m) (S n) mask'
+%name OPE ope
+
+export
+Show (OPE m n mask) where
+  showPrec d Stop            = "Stop"
+  showPrec d (Drop ope Refl) = showCon d "Drop" $ showArg ope ++ " Refl"
+  showPrec d (Keep ope Refl) = showCon d "Keep" $ showArg ope ++ " Refl"
+
+public export %inline
+drop : OPE m n mask -> OPE m (S n) (mask + mask)
+drop ope = Drop ope Refl
+
+public export %inline
+keep : OPE m n mask -> OPE (S m) (S n) (S (mask + mask))
+keep ope = Keep ope Refl
+
+
+public export
+data IsStop : OPE m n mask -> Type where ItIsStop : IsStop Stop
+
+public export
+data IsDrop : OPE m n mask -> Type where ItIsDrop : IsDrop (Drop ope eq)
+
+public export
+data IsKeep : OPE m n mask -> Type where ItIsKeep : IsKeep (Keep ope eq)
+
+
+export
+0 zeroIsStop : (ope : OPE m 0 mask) -> IsStop ope
+zeroIsStop Stop = ItIsStop
+
+
+||| everything selected
+public export
+id : {m : Nat} -> Subset Nat (OPE m m)
+id {m = 0}   = Element _ Stop
+id {m = S m} = Element _ $ Keep id.snd Refl
+
+public export %inline
+0 id' : {m : Nat} -> OPE m m (fst (Base.id {m}))
+id' = id.snd
+
+||| nothing selected
+public export
+zero : {m : Nat} -> OPE 0 m 0
+zero {m = 0}   = Stop
+zero {m = S m} = Drop zero Refl
+
+||| a single slot selected
+public export
+one : Fin n -> Subset Nat (OPE 1 n)
+one FZ     = Element _ $ keep zero
+one (FS i) = Element _ $ drop (one i).snd
+
+public export %inline
+0 one' : (i : Fin n) -> OPE 1 n (one i).fst
+one' i = (one i).snd
+
+
+public export
+record SomeOPE n where
+  constructor MkOPE
+  {0 scope : Nat}
+  {mask : Nat}
+  0 ope : OPE scope n mask

lib/Quox/Thin/Comp.idr

@@ -0,0 +1,55 @@
+module Quox.Thin.Comp
+
+import public Quox.Thin.Base
+import public Quox.Thin.View
+import Quox.NatExtra
+import Data.Singleton
+
+%default total
+
+||| inductive definition of OPE composition
+public export
+data Comp : (l : OPE n p mask1) -> (r : OPE m n mask2) ->
+            (res : OPE m p mask3) -> Type where
+  [search l r]
+  StopZ : Comp Stop Stop Stop
+  DropZ : Comp a b c -> Comp (Drop a Refl) b (Drop c Refl)
+  KeepZ : Comp a b c -> Comp (Keep a Refl) (Keep b Refl) (Keep c Refl)
+  KDZ   : Comp a b c -> Comp (Keep a Refl) (Drop b Refl) (Drop c Refl)
+
+public export
+record CompResult (ope1 : OPE n p mask1) (ope2 : OPE m n mask2) where
+  constructor MkComp
+  {mask : Nat}
+  {0 ope : OPE m p mask}
+  0 comp : Comp ope1 ope2 ope
+%name CompResult comp
+
+||| compose two OPEs, if the middle scope size is already known at runtime
+export
+comp' : {n, p, mask1, mask2 : Nat} ->
+        (0 ope1 : OPE n p mask1) -> (0 ope2 : OPE m n mask2) ->
+        CompResult ope1 ope2
+comp' ope1 ope2 with %syntactic (view ope1) | (view ope2)
+  comp' Stop Stop | StopV | StopV =
+    MkComp StopZ
+  comp' (Drop ope1 Refl) ope2 | DropV _ ope1 | _ =
+    MkComp $ DropZ (comp' ope1 ope2).comp
+  comp' (Keep ope1 Refl) (Drop ope2 Refl) | KeepV _ ope1 | DropV _ ope2 =
+    MkComp $ KDZ (comp' ope1 ope2).comp
+  comp' (Keep ope1 Refl) (Keep ope2 Refl) | KeepV _ ope1 | KeepV _ ope2 =
+    MkComp $ KeepZ (comp' ope1 ope2).comp
+
+||| compose two OPEs, after recomputing the middle scope size using `appOpe`
+export
+comp : {p, mask1, mask2 : Nat} ->
+       (0 ope1 : OPE n p mask1) -> (0 ope2 : OPE m n mask2) ->
+       CompResult ope1 ope2
+comp ope1 ope2 = let Val n = appOpe p ope1 in comp' ope1 ope2
+
+-- [todo] is there a quick way to compute the mask of comp?
+
+export
+0 (.) : (ope1 : OPE n p mask1) -> (ope2 : OPE m n mask2) ->
+        OPE m p (comp ope1 ope2).mask
+ope1 . ope2 = (comp ope1 ope2).ope