some refactoring in tests

closes #38, again

.gitignore

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

CREDITS.md

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

Makefile

@@ -1,38 +0,0 @@
-all: quox
-
-NIXFLAGS := --no-warn-dirty
-
-# these two are real files, but always ask nix if they need remaking
-.PHONY: quox
-quox:
-	@echo [build] quox
-	nix build $(NIXFLAGS) --no-link '.#quox'
-	ln -sfL $$(nix path-info $(NIXFLAGS) '.#quox')/bin/quox quox
-
-.PHONY: quox-tests
-quox-tests:
-	@echo [build] quox-tests
-	nix build $(NIXFLAGS) --no-link '.#quox-tests'
-	ln -sfL $$(nix path-info $(NIXFLAGS) '.#quox-tests')/bin/quox-tests quox-tests
-
-
-.PHONY: lib
-lib:
-	@echo [build] quox-lib
-	nix build $(NIXFLAGS) --no-link '.#quox-lib'
-
-.PHONY: test
-test:
-	nix run $(NIXFLAGS) -- '.#quox-tests' -V 14 -c
-
-.PHONY: prove
-prove:
-	nix build $(NIXFLAGS) --no-link '.#quox-tests'
-	prove $$(nix path-info $(NIXFLAGS) '.#quox-tests')/bin/quox-tests
-
-.PHONY: clean
-clean:
-	@echo [clean]
-	rm -f quox quox-tests result
-
-.SILENT:

README.md

@@ -1,4 +1,4 @@
-# ![](qtuwu.png) quantitative observational extensional(ish) type theory
+# ![](qtuwu.png) quantitative extensional(ish) type theory
 
 hey what would happen if some idiot tried to weld qtt and xtt together?
 let's find out together

default.nix

@@ -1 +0,0 @@
-(import (fetchTarball "https://github.com/edolstra/flake-compat/archive/master.tar.gz") { src = ./.; }).defaultNix

examples/all.quox

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

examples/bool.quox

@@ -0,0 +1,39 @@
+load "misc.quox";
+
+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 if : 0.(A : ★) → (b : Bool) → ω.A → ω.A → A =
+  λ A ⇒ if-dep (λ _ ⇒ A);
+
+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);
+
+def if2 : 0.(A B : ★) → (b : Bool) → ω.A → ω.B → if¹ ★ b A B =
+  λ A B ⇒ if-dep (λ b ⇒ if-dep¹ (λ _ ⇒ ★) b A B);
+
+def0 T : Bool → ★ = λ b ⇒ if¹ ★ b True False;
+
+def dup! : (b : Bool) → [ω. Sing Bool b] =
+  λ b ⇒ if-dep (λ b ⇒ [ω. Sing Bool b]) b
+    [('true,  [δ _ ⇒ 'true])]
+    [('false, [δ _ ⇒ 'false])];
+
+def dup : Bool → [ω. Bool] =
+  λ b ⇒ appω (Sing Bool b) Bool (sing.val Bool b) (dup! b);
+
+def true-not-false : Not ('true ≡ 'false : Bool) =
+  λ eq ⇒ coe (𝑖 ⇒ T (eq @𝑖)) '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;
+
+}
+
+def0 Bool = bool.Bool;

examples/either.quox

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

examples/eta.quox

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

examples/fail.quox

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

examples/hello.quox

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

examples/io.quox

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

examples/list.quox

@@ -0,0 +1,91 @@
+load "nat.quox";
+
+namespace vec {
+
+def0 Vec : ℕ → ★ → ★ =
+  λ 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 : ★ → ★ =
+  λ A ⇒ (len : ℕ) × Vec len A;
+
+def Nil : 0.(A : ★) → List A =
+  λ A ⇒ (0, 'nil);
+
+def Cons : 0.(A : ★) → A → List A → List A =
+  λ A x xs ⇒ case xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
+
+def elim : 0.(A : ★) → 0.(P : List A → ★) →
+           P (Nil A) →
+           ω.((x : A) → 0.(xs : List A) → P xs → P (Cons A x xs)) →
+           (xs : List A) → P xs =
+  λ A P pn pc xs ⇒
+    case xs return xs' ⇒ P xs' of { (len, elems) ⇒
+      vec.elim A (λ n xs ⇒ P (n, xs))
+        pn (λ x n xs ih ⇒ pc x (n, xs) ih)
+        len elems
+    };
+
+-- [fixme] List A <: List¹ A should be automatic, imo
+#[compile-scheme "(lambda (xs) xs)"]
+def up : 0.(A : ★) → List A → List¹ A =
+  λ A xs ⇒
+  case xs return List¹ A of { (len, elems) ⇒
+    case nat.dup! len return List¹ A of { [p] ⇒
+      caseω p return List¹ A of { (lenω, eq0) ⇒
+        case eq0 return List¹ A of { [eq] ⇒
+          (lenω, vec.up A lenω (coe (𝑖 ⇒ Vec (eq @𝑖) A) @1 @0 elems))
+        }
+      }
+    }
+  };
+
+def foldr : 0.(A B : ★) → B → ω.(A → B → B) → List A → B =
+  λ A B z f xs ⇒ elim A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs;
+
+def map : 0.(A B : ★) → ω.(A → B) → List A → List B =
+  λ A B f ⇒ foldr A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys);
+
+def0 All : (A : ★) → (P : A → ★) → List A → ★ =
+  λ A P xs ⇒ foldr¹ A ★ True (λ x ps ⇒ P x × ps) (up A xs);
+
+}
+
+def0 List = list.List;

examples/maybe.quox

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

examples/misc.quox

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

examples/nat.quox

@@ -0,0 +1,165 @@
+load "misc.quox";
+load "bool.quox";
+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] =
+  λ 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
+  };
+
+def dup : ℕ → [ω.ℕ] =
+  λ n ⇒ appω (Sing ℕ n) ℕ (sing.val ℕ n) (dup! n);
+
+#[compile-scheme "(lambda% (m n) (+ m n))"]
+def plus : ℕ → ℕ → ℕ =
+  λ m n ⇒
+  case m return ℕ of {
+    zero      ⇒ n;
+    succ _, p ⇒ succ p
+  };
+
+#[compile-scheme "(lambda% (m n) (* m n))"]
+def timesω : ℕ → ω.ℕ → ℕ =
+  λ m n ⇒
+  case m return ℕ of {
+    zero      ⇒ zero;
+    succ _, t ⇒ plus n t
+  };
+
+def times : ℕ → ℕ → ℕ =
+  λ m n ⇒ case dup n return ℕ of { [n] ⇒ timesω m n };
+
+def pred : ℕ → ℕ = λ n ⇒ case n return ℕ of { zero ⇒ zero; succ n ⇒ n };
+
+def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ =
+  λ n ⇒ δ 𝑖 ⇒ n;
+
+def0 succ-inj : (m n : ℕ) → succ m ≡ succ n : ℕ → m ≡ n : ℕ =
+  λ m n eq ⇒ δ 𝑖 ⇒ pred (eq @𝑖);
+
+#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"]
+def minus : ℕ → ℕ → ℕ =
+  λ m n ⇒
+  (case n return ℕ → ℕ of {
+    zero      ⇒ λ m ⇒ m;
+    succ _, f ⇒ λ m ⇒ f (pred m)
+  }) m;
+
+
+def0 IsSucc : ℕ → ★ =
+  λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True };
+
+def isSucc? : ω.(n : ℕ) → Dec (IsSucc n) =
+  λ n ⇒
+  caseω n return n' ⇒ Dec (IsSucc n') of {
+    zero   ⇒ No  (IsSucc zero)      (λ v ⇒ v);
+    succ n ⇒ Yes (IsSucc (succ n)) 'true
+  };
+
+def zero-not-succ : 0.(m : ℕ) → Not (zero ≡ succ m : ℕ) =
+  λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) @1 @0 'true;
+
+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 : ℕ) =
+  λ m ⇒
+  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
+  return m' ⇒ ω.(n : ℕ) → Dec (m' ≡ n : ℕ)
+  of {
+    zero ⇒ λ n ⇒
+      caseω n return n' ⇒ Dec (zero ≡ n' : ℕ) of {
+        zero    ⇒ Yes (zero ≡ zero    : ℕ) (δ _ ⇒ zero);
+        succ n' ⇒ No  (zero ≡ succ n' : ℕ) (λ eq ⇒ zero-not-succ n' eq)
+      };
+    succ m', ω.ih ⇒ λ n ⇒
+      caseω n return n' ⇒ Dec (succ m' ≡ n' : ℕ) of {
+        zero    ⇒ No (succ m' ≡ zero : ℕ) (λ eq ⇒ succ-not-zero m' eq);
+        succ n' ⇒
+          dec.elim (m' ≡ n' : ℕ) (λ _ ⇒ Dec (succ m' ≡ succ n' : ℕ))
+            (λ y ⇒ Yes (succ m' ≡ succ n' : ℕ) (δ 𝑖 ⇒ succ (y @𝑖)))
+            (λ n ⇒ No  (succ m' ≡ succ n' : ℕ) (λ eq ⇒ n (succ-inj m' n' eq)))
+            (ih n')
+      }
+  };
+
+def eqb : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ dec.bool (m ≡ n : ℕ) (eq? m n);
+
+
+def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ =
+  λ m ⇒
+  case m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
+    zero        ⇒ δ _ ⇒ 0;
+    succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
+  };
+
+def0 plus-succ : (m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ =
+  λ m n ⇒
+  case m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : ℕ of {
+    zero       ⇒ δ _ ⇒ succ n;
+    succ _, ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
+  };
+
+def0 plus-comm : (m n : ℕ) → plus m n ≡ plus n m : ℕ =
+  λ m n ⇒
+  case m return m' ⇒ plus m' n ≡ plus n m' : ℕ of {
+    zero ⇒ plus-zero n;
+    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

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

examples/qty.quox

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

exe/CompileMonad.idr

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

exe/Error.idr

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

exe/Main.idr

@@ -1,16 +1,121 @@
 module Main
 
-import public Quox.Name
+import Quox.Syntax as Q
-import public Quox.Syntax
+import Quox.Definition as Q
-import public Quox.Equal
+import Quox.Untyped.Syntax as U
-import public Quox.Pretty
+import Quox.Parser
-import public Quox.Typechecker
+import Quox.Untyped.Erase
+import Quox.Untyped.Scheme
+import Quox.Pretty
+import Quox.Log
+import Options
+import Output
+import Error
+import CompileMonad
 
-import Data.Nat
+import System
-import Data.Vect
+import System.File
-import Data.List
+import Data.IORef
-import Control.ANSI
+import Control.Eff
 
+%default total
+
+%hide Doc.(>>=)
+%hide Core.(>>=)
+
+%hide FromParser.Error
+%hide Erase.Error
+%hide Lexer.Error
+%hide Parser.Error
+
+
+private
+Step : Type -> Type -> Type
+Step a b = OpenFile -> a -> Eff Compile b
+
+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
+
+
+private covering
+parse : Step String PFile
+parse h file = do
+  Just ast <- loadFile noLoc file
+    | Nothing => pure []
+  outputStr h $ show ast
+  pure ast
+
+private covering
+check : Step PFile (List Q.NDefinition)
+check h decls =
+  map concat $ for decls $ \decl => do
+    defs <- liftFromParser $ fromPTopLevel decl
+    outputDocs h $ traverse (\(x, d) => prettyDef x d) defs
+    pure defs
+
+private covering
+erase : Step (List Q.NDefinition) (List U.NDefinition)
+erase h defList =
+  for defList $ \(x, def) => do
+    def <- liftErase defs $ eraseDef defs x def
+    outputDoc h $ U.prettyDef x def
+    pure (x, def)
+where defs = SortedMap.fromList defList
+
+private covering
+scheme : Step (List U.NDefinition) (List Sexp, List Id)
+scheme h defs = do
+  sexps' <- for defs $ \(x, d) => do
+    (msexp, mains) <- liftScheme $ defToScheme x d
+    outputDoc h $ case msexp of
+      Just s  => prettySexp s
+      Nothing => pure $ hsep [";;", prettyName x, "erased"]
+    pure (msexp, mains)
+  pure $ bimap catMaybes concat $ unzip sexps'
+
+private covering
+output : Step (List Sexp, List Id) ()
+output h (sexps, mains) = do
+  main <- case mains of
+    [m] => pure m
+    []  => throw NoMain
+    _   => throw $ MultipleMains mains
+  lift $ outputDocs h $ do
+    res    <- traverse prettySexp sexps
+    runner <- makeRunMain main
+    pure $ text Scheme.prelude :: res ++ [runner]
+
+private covering
+processFile : String -> Eff Compile ()
+processFile file = withEarlyStop $ pipeline !(askAt OPTS) file where
+  pipeline : Options -> String -> Eff CompileStop ()
+  pipeline opts =
+    step CErr Parse  opts.dump.parse  Main.parse  >=>
+    step CErr Check  opts.dump.check  Main.check  >=>
+    step CErr Erase  opts.dump.erase  Main.erase  >=>
+    step CErr Scheme opts.dump.scheme Main.scheme >=>
+    step COut End    opts.outFile     Main.output
+
+
+export covering
+main : IO ()
+main = do
+  (_, opts, files) <- options
+  case !(runCompile opts !newState $ traverse_ processFile files) of
+    Right () => pure ()
+    Left  e  => dieError opts e
+
+
+-----------------------------------
+{-
 
 private
 text : PrettyOpts -> List String
@@ -22,22 +127,29 @@ text _ =
    #" /_/"#,
    ""]
 
+--   ["",
+--    #" __ _ _  _ _____ __"#,
+--    #"/ _` | || / _ \ \ /"#,
+--    #"\__, |\_,_\___/_\_\"#,
+--    #"   |_|"#,
+--    ""]
+
 private
 qtuwu : PrettyOpts -> List String
 qtuwu opts =
   if opts.unicode then
     [#"      ___,-´⎠  "#,
      #"(·`──´ ◡    -´⎠"#,
-     #" \⋀/───´⎞/`──´ "#,
+     #" \/\/──´⎞/`──´ "#,
-     #"  ⋃────,-₎   ⎞ "#,
+     #"  ⎜⎟───,-₎   ⎞ "#,
-     #"      (‾‾)   ⎟ "#,
+     #"  ⎝⎠  (‾‾)   ⎟ "#,
      #"     (‾‾‾)   ⎟ "#]
   else
     [#"      ___,-´/  "#,
      #"(.`--´ u    -´/"#,
      #" \/\/--´|/`--´ "#,
-     #"  U----,-,   \ "#,
+     #"  ||---,-,   \ "#,
-     #"      (--)   | "#,
+     #"  `´  (--)   | "#,
      #"     (---)   | "#]
 
 private
@@ -51,16 +163,4 @@ join1 opts l r =
 export
 banner : PrettyOpts -> String
 banner opts = unlines $ zipWith (join1 opts) (qtuwu opts) (text opts)
-
+-}
-export
-tm : Term 1 2
-tm =
-  (Pi One "a" (BVT 0) (TUsed $ E (F "F" :@@ [BVT 0, FT "w"]))
-    `DCloT` (K One ::: id))
-    `CloT`  (F "y" ::: TYPE (U 1) :# TYPE (U 2) ::: id)
-
-main : IO Unit
-main = do
-  putStrLn $ banner defPrettyOpts
-  prettyTermDef tm
-  prettyTermDef $ pushSubstsT tm

exe/Options.idr

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

exe/Output.idr

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

exe/quox.ipkg

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

flake.lock

@@ -1,588 +0,0 @@
-{
-  "nodes": {
-    "Prettier": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639310097,
-        "narHash": "sha256-+eSLEJDuy2ZRkh1h0Y5IF6RUeHEcWhAHpWhwdwW65f0=",
-        "owner": "Z-snails",
-        "repo": "prettier",
-        "rev": "4a90663b1d586f6d6fce25873aa0f0d7bc633b89",
-        "type": "github"
-      },
-      "original": {
-        "owner": "Z-snails",
-        "repo": "prettier",
-        "type": "github"
-      }
-    },
-    "collie": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1631011321,
-        "narHash": "sha256-goYctB+WBoLgsbjA0DlqGjD8i9wr1K0lv0agqpuwflU=",
-        "owner": "ohad",
-        "repo": "collie",
-        "rev": "ed2eda5e04fbd02a7728e915d396e14cc7ec298e",
-        "type": "github"
-      },
-      "original": {
-        "owner": "ohad",
-        "repo": "collie",
-        "type": "github"
-      }
-    },
-    "comonad": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1638093386,
-        "narHash": "sha256-kxmN6XuszFLK2i76C6LSGHe5XxAURFu9NpzJbi3nodk=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-comonad",
-        "rev": "06d6b551db20f1f940eb24c1dae051c957de97ad",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-comonad",
-        "type": "github"
-      }
-    },
-    "dom": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639041519,
-        "narHash": "sha256-4ZYc0qaUEVARxhWuH3JgejIeT+GEDNxdS6zIGhBCk34=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-dom",
-        "rev": "01ab52d0ffdb3b47481413a949b8f0c0688c97e4",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-dom",
-        "type": "github"
-      }
-    },
-    "dot-parse": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1638264571,
-        "narHash": "sha256-VJQITz+vuQgl5HwR5QdUGwN8SRtGcb2/lJaAVfFbiSk=",
-        "owner": "CodingCellist",
-        "repo": "idris2-dot-parse",
-        "rev": "48fbda8bf8adbaf9e8ebd6ea740228e4394154d9",
-        "type": "github"
-      },
-      "original": {
-        "owner": "CodingCellist",
-        "repo": "idris2-dot-parse",
-        "type": "github"
-      }
-    },
-    "effect": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1637477153,
-        "narHash": "sha256-Ta2Vogg/IiSBkfhhD57jjPTEf3S4DOiVRmof38hmwlM=",
-        "owner": "russoul",
-        "repo": "idris2-effect",
-        "rev": "ea1daf53b2d7e52f9917409f5653adc557f0ee1a",
-        "type": "github"
-      },
-      "original": {
-        "owner": "russoul",
-        "repo": "idris2-effect",
-        "type": "github"
-      }
-    },
-    "elab-util": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639041013,
-        "narHash": "sha256-K61s/xifFiTDXJTak5NZmZL6757CTYCY+TGywRZMD7M=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-elab-util",
-        "rev": "7a381c7c5dc3adb7b97c8b8be17e4fb4cc63027d",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-elab-util",
-        "type": "github"
-      }
-    },
-    "flake-utils": {
-      "locked": {
-        "lastModified": 1659877975,
-        "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0",
-        "type": "github"
-      },
-      "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "type": "github"
-      }
-    },
-    "frex": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1637410704,
-        "narHash": "sha256-BthU1t++n0ZvS76p0fCHsE33QSoXYxf0hMUSKajDY8w=",
-        "owner": "frex-project",
-        "repo": "idris-frex",
-        "rev": "22c480e879c757a5cebca7bb555ec3d21ae3ac28",
-        "type": "github"
-      },
-      "original": {
-        "owner": "frex-project",
-        "repo": "idris-frex",
-        "type": "github"
-      }
-    },
-    "fvect": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1633247988,
-        "narHash": "sha256-zElIze03XpcrYL4H5Aj0ZGNplJGbtOx+iWnivJMzHm0=",
-        "owner": "mattpolzin",
-        "repo": "idris-fvect",
-        "rev": "1c5e3761e0cd83e711a3535ef9051bea45e6db3f",
-        "type": "github"
-      },
-      "original": {
-        "owner": "mattpolzin",
-        "repo": "idris-fvect",
-        "type": "github"
-      }
-    },
-    "hashable": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1633965157,
-        "narHash": "sha256-Dggf5K//RCZ7uvtCyeiLNJS6mm+8/n0RFW3zAc7XqPg=",
-        "owner": "z-snails",
-        "repo": "idris2-hashable",
-        "rev": "d6fec8c878057909b67f3d4da334155de4f37907",
-        "type": "github"
-      },
-      "original": {
-        "owner": "z-snails",
-        "repo": "idris2-hashable",
-        "type": "github"
-      }
-    },
-    "hedgehog": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639041435,
-        "narHash": "sha256-893cPy7gGSQpVmm9co3QCpWsgjukafZHy8YFk9xts30=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-hedgehog",
-        "rev": "a66b1eb0bf84c4a7b743cfb217be69866bc49ad8",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-hedgehog",
-        "type": "github"
-      }
-    },
-    "idrall": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1636495701,
-        "narHash": "sha256-aOdCRd4XsSxwqVGta1adlZBy8TVTxTwFDnJ1dyMZK8M=",
-        "owner": "alexhumphreys",
-        "repo": "idrall",
-        "rev": "13ef174290169d05c9e9abcd77c53412e3e0c944",
-        "type": "github"
-      },
-      "original": {
-        "owner": "alexhumphreys",
-        "ref": "13ef174",
-        "repo": "idrall",
-        "type": "github"
-      }
-    },
-    "idris-server": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1634507315,
-        "narHash": "sha256-ulo23yLJXsvImoMB/1C6yRRTqmn/Odo+aUaVi+tUhJo=",
-        "owner": "avidela",
-        "repo": "idris-server",
-        "rev": "661a4ecf0fadaa2bd79c8e922c2d4f79b0b7a445",
-        "type": "gitlab"
-      },
-      "original": {
-        "owner": "avidela",
-        "repo": "idris-server",
-        "type": "gitlab"
-      }
-    },
-    "idris2": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639427352,
-        "narHash": "sha256-C1K2FM1Kio8vi9FTrivdacYCX4cywIsLBeNCsZ6ft4g=",
-        "owner": "idris-lang",
-        "repo": "idris2",
-        "rev": "36918e618646177b1e0c2fd01f21cc8d04d9da30",
-        "type": "github"
-      },
-      "original": {
-        "owner": "idris-lang",
-        "repo": "idris2",
-        "type": "github"
-      }
-    },
-    "idris2-pkgs": {
-      "inputs": {
-        "Prettier": "Prettier",
-        "collie": "collie",
-        "comonad": "comonad",
-        "dom": "dom",
-        "dot-parse": "dot-parse",
-        "effect": "effect",
-        "elab-util": "elab-util",
-        "flake-utils": [
-          "flake-utils"
-        ],
-        "frex": "frex",
-        "fvect": "fvect",
-        "hashable": "hashable",
-        "hedgehog": "hedgehog",
-        "idrall": "idrall",
-        "idris-server": "idris-server",
-        "idris2": "idris2",
-        "indexed": "indexed",
-        "inigo": "inigo",
-        "ipkg-to-json": "ipkg-to-json",
-        "json": "json",
-        "katla": "katla",
-        "lsp": "lsp",
-        "nixpkgs": [
-          "nixpkgs"
-        ],
-        "odf": "odf",
-        "pretty-show": "pretty-show",
-        "python": "python",
-        "rhone": "rhone",
-        "rhone-js": "rhone-js",
-        "snocvect": "snocvect",
-        "sop": "sop",
-        "tailrec": "tailrec",
-        "xml": "xml"
-      },
-      "locked": {
-        "lastModified": 1642030375,
-        "narHash": "sha256-J1uXnpPR72mjFjLBuYcvDHStBxVya6/MjBNNwqxGeD0=",
-        "owner": "claymager",
-        "repo": "idris2-pkgs",
-        "rev": "ac33a49d4d4bd2b50fddb040cd889733a02c8f09",
-        "type": "github"
-      },
-      "original": {
-        "owner": "claymager",
-        "repo": "idris2-pkgs",
-        "type": "github"
-      }
-    },
-    "indexed": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1638685238,
-        "narHash": "sha256-FceB7o88yKYzjTfRC6yfhOL6oDPMmCQAsJZu/pjE2uA=",
-        "owner": "mattpolzin",
-        "repo": "idris-indexed",
-        "rev": "ff3ba99b0063da6a74c96178e7f3c58a4ac1693e",
-        "type": "github"
-      },
-      "original": {
-        "owner": "mattpolzin",
-        "repo": "idris-indexed",
-        "type": "github"
-      }
-    },
-    "inigo": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1637596767,
-        "narHash": "sha256-LNx30LO0YWDVSPTxRLWGTFL4f3d5ANG6c60WPdmiYdY=",
-        "owner": "idris-community",
-        "repo": "Inigo",
-        "rev": "57f5b5c051222d8c630010a0a3cf7d7138910127",
-        "type": "github"
-      },
-      "original": {
-        "owner": "idris-community",
-        "repo": "Inigo",
-        "type": "github"
-      }
-    },
-    "ipkg-to-json": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1634937414,
-        "narHash": "sha256-LhSmWRpI7vyIQE7QTo38ZTjlqYPVSvV/DIpIxzPmqS0=",
-        "owner": "claymager",
-        "repo": "ipkg-to-json",
-        "rev": "2969b6b83714eeddc31e41577a565778ee5922e6",
-        "type": "github"
-      },
-      "original": {
-        "owner": "claymager",
-        "repo": "ipkg-to-json",
-        "type": "github"
-      }
-    },
-    "json": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639041459,
-        "narHash": "sha256-TP/V1jBBP1hFPm/cJ5O2EJiaNoZ19KvBOAI0S9lvAR4=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-json",
-        "rev": "7c0c028acad0ba0b63b37b92199f37e6ec73864a",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-json",
-        "type": "github"
-      }
-    },
-    "katla": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1636542431,
-        "narHash": "sha256-X83NA/P3k1iPcBa8g5z8JldEmFEz/jxVeViJX0/FikY=",
-        "owner": "idris-community",
-        "repo": "katla",
-        "rev": "d841ec243f96b4762074211ee81033e28884c858",
-        "type": "github"
-      },
-      "original": {
-        "owner": "idris-community",
-        "repo": "katla",
-        "type": "github"
-      }
-    },
-    "lsp": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639486283,
-        "narHash": "sha256-po396FnUu8iqiipwPxqpFZEU4rtpX3jnt3cySwjLsH8=",
-        "owner": "idris-community",
-        "repo": "idris2-lsp",
-        "rev": "7ebb6caf6bb4b57c5107579aba2b871408e6f183",
-        "type": "github"
-      },
-      "original": {
-        "owner": "idris-community",
-        "repo": "idris2-lsp",
-        "type": "github"
-      }
-    },
-    "nixpkgs": {
-      "locked": {
-        "lastModified": 1638239011,
-        "narHash": "sha256-AjhmbT4UBlJWqxY0ea8a6GU2C2HdKUREkG43oRr3TZg=",
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "rev": "a7ecde854aee5c4c7cd6177f54a99d2c1ff28a31",
-        "type": "github"
-      },
-      "original": {
-        "id": "nixpkgs",
-        "ref": "21.11",
-        "type": "indirect"
-      }
-    },
-    "odf": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1638184051,
-        "narHash": "sha256-usSdPx+UqOGImHHdHcrytdzi2LXtIRZuUW0fkD/Wwnk=",
-        "owner": "madman-bob",
-        "repo": "idris2-odf",
-        "rev": "d2f532437321c8336f1ca786b44b6ebef4117126",
-        "type": "github"
-      },
-      "original": {
-        "owner": "madman-bob",
-        "repo": "idris2-odf",
-        "type": "github"
-      }
-    },
-    "pretty-show": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639041411,
-        "narHash": "sha256-BzEe1fpX+lqGEk8b1JZoQT1db5I7s7SZnLCttRVGXdY=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-pretty-show",
-        "rev": "a4bc6156b9dac43699f87504cbdb8dada5627863",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-pretty-show",
-        "type": "github"
-      }
-    },
-    "python": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1635936936,
-        "narHash": "sha256-c9mcMApN0qgu0AXQVu0V+NXt2poP258wCPkyvtQvv4I=",
-        "owner": "madman-bob",
-        "repo": "idris2-python",
-        "rev": "0eab028933c65bebe744e879881416f5136d6943",
-        "type": "github"
-      },
-      "original": {
-        "owner": "madman-bob",
-        "repo": "idris2-python",
-        "type": "github"
-      }
-    },
-    "rhone": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639041532,
-        "narHash": "sha256-2g43shlWQIT/1ogesUBUBV9N8YiD3RwaCbbhdKLVp1s=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-rhone",
-        "rev": "c4d828b0b8efea495d9a5f1e842a9c67cad57724",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-rhone",
-        "type": "github"
-      }
-    },
-    "rhone-js": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639041546,
-        "narHash": "sha256-ddWVsSRbfA6ghmwiRMzDpHBPM+esGdutuqm1qQZgs88=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-rhone-js",
-        "rev": "520dd59549f5b14075045314b6805c7492ed636e",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-rhone-js",
-        "type": "github"
-      }
-    },
-    "root": {
-      "inputs": {
-        "flake-utils": "flake-utils",
-        "idris2-pkgs": "idris2-pkgs",
-        "nixpkgs": "nixpkgs",
-        "tap": "tap"
-      }
-    },
-    "snocvect": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1641633224,
-        "narHash": "sha256-6zTU4sDzd/R/dFCTNZaX41H4L3/USGLFghMS0Oc9liY=",
-        "owner": "mattpolzin",
-        "repo": "idris-snocvect",
-        "rev": "ff1e7afba360a62f7e522e9bbb856096a79702c4",
-        "type": "github"
-      },
-      "original": {
-        "owner": "mattpolzin",
-        "repo": "idris-snocvect",
-        "type": "github"
-      }
-    },
-    "sop": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1639041379,
-        "narHash": "sha256-PDTf1Wx6EygiWszguvoVPiqIISYFLabI4e0lXHlrjcA=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-sop",
-        "rev": "e4354d1883cd73616019457cb9ebf864d99df6a0",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-sop",
-        "type": "github"
-      }
-    },
-    "tailrec": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1637146655,
-        "narHash": "sha256-0yi7MQIrISPvAwkgDC1M5PHDEeVyIaISF0HjKDaT0Rw=",
-        "owner": "stefan-hoeck",
-        "repo": "idris2-tailrec",
-        "rev": "dd0bc6381b3a2e69aa37f9a8c1b165d4b1516ad7",
-        "type": "github"
-      },
-      "original": {
-        "owner": "stefan-hoeck",
-        "repo": "idris2-tailrec",
-        "type": "github"
-      }
-    },
-    "tap": {
-      "inputs": {
-        "flake-utils": [
-          "flake-utils"
-        ],
-        "idris2-pkgs": [
-          "idris2-pkgs"
-        ],
-        "nixpkgs": [
-          "nixpkgs"
-        ]
-      },
-      "locked": {
-        "lastModified": 1660774921,
-        "narHash": "sha256-7xbw0rnQ6BFjiQvxWTkwmmSs3slSwbfKyuz4TGlOlas=",
-        "ref": "main",
-        "rev": "d0311bbca54352b45079a42e90fa292fc3748961",
-        "revCount": 11,
-        "type": "git",
-        "url": "https://git.rhiannon.website/rhi/idris2-tap"
-      },
-      "original": {
-        "ref": "main",
-        "type": "git",
-        "url": "https://git.rhiannon.website/rhi/idris2-tap"
-      }
-    },
-    "xml": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1637939752,
-        "narHash": "sha256-yYJBhPfwYoi7amlHmeNGrVCOAc3BjZpKTCd9wDs3XEM=",
-        "owner": "madman-bob",
-        "repo": "idris2-xml",
-        "rev": "1292ccfcd58c551089ef699e4560343d5c473d64",
-        "type": "github"
-      },
-      "original": {
-        "owner": "madman-bob",
-        "repo": "idris2-xml",
-        "type": "github"
-      }
-    }
-  },
-  "root": "root",
-  "version": 7
-}

flake.nix

@@ -1,62 +0,0 @@
-{ description = "quox: quantitative extensional type theory";
-
-  inputs = {
-    nixpkgs.url = "nixpkgs/21.11";
-
-    flake-utils = {
-      url = "github:numtide/flake-utils";
-      inputs.nixpkgs.follows = "nixpkgs";
-    };
-
-    idris2-pkgs = {
-      url = "github:claymager/idris2-pkgs";
-      inputs.nixpkgs.follows = "nixpkgs";
-      inputs.flake-utils.follows = "flake-utils";
-    };
-
-    tap = {
-      url = "git+https://git.rhiannon.website/rhi/idris2-tap?ref=main";
-      inputs.nixpkgs.follows = "nixpkgs";
-      inputs.flake-utils.follows = "flake-utils";
-      inputs.idris2-pkgs.follows = "idris2-pkgs";
-    };
-  };
-
-  outputs = { self, nixpkgs, idris2-pkgs, flake-utils, tap }:
-    let
-      packagePaths = {
-        quox-lib   = ./lib;
-        quox       = ./exe;
-        quox-tests = ./tests;
-      };
-
-      extraDeps = [ tap ];
-
-      systems = with flake-utils.lib.system;
-          [ x86_64-darwin x86_64-linux i686-linux ];
-    in
-    with builtins;
-    flake-utils.lib.eachSystem systems (system:
-      let
-        basePkgs = import nixpkgs {
-          inherit system;
-          overlays = [ idris2-pkgs.overlay ];
-        };
-        builders = basePkgs.idris2-pkgs._builders;
-
-        extraDepPkgs =
-          foldl' (acc: pkg: acc // pkg.packages.${system}) { } extraDeps;
-        mkPackage = name: path:
-          builders.idrisPackage path { extraPkgs = extraDepPkgs // packages; };
-        mkDevShell = _: pkg:
-          basePkgs.mkShell { buildInputs = [ (builders.devEnv pkg) ]; };
-
-        packages = mapAttrs mkPackage packagePaths;
-        devShells = mapAttrs mkDevShell packages;
-      in {
-        inherit packages devShells;
-        defaultPackage = packages.quox;
-        devShell = devShells.quox-lib;
-      }
-    );
-}

golden-tests/Tests.idr

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

golden-tests/quox-golden-tests.ipkg

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

golden-tests/run-tests.sh

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

golden-tests/tests/empty/run

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

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

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

golden-tests/tests/eta-singleton/expected

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

golden-tests/tests/eta-singleton/run

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

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

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

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

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

golden-tests/tests/hello/expected

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

golden-tests/tests/hello/hello.quox

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

golden-tests/tests/hello/run

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

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

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

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

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

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

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

golden-tests/tests/isprop-subsing/expected

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

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

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

golden-tests/tests/it-5/expected

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

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

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

golden-tests/tests/it-5/run

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

golden-tests/tests/lib.sh

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

golden-tests/tests/load/expected

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

golden-tests/tests/load/lib.quox

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

golden-tests/tests/load/main.quox

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

golden-tests/tests/load/run

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

golden-tests/tests/regularity/expected

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

golden-tests/tests/regularity/regularity.quox

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

golden-tests/tests/regularity/run

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

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

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

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

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

lib/Control/Monad/ST/Extra.idr

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

lib/Quox/BoolExtra.idr

@@ -0,0 +1,12 @@
+module Quox.BoolExtra
+
+import public Data.Bool
+
+
+export infixr 5 `andM`
+export infixr 4 `orM`
+
+public export
+andM, orM : Monad m => m Bool -> m Bool -> m Bool
+andM a b = if     !a then b else pure False
+orM  a b = if not !a then b else pure True

lib/Quox/CharExtra.idr

@@ -0,0 +1,175 @@
+module Quox.CharExtra
+
+import Derive.Prelude
+
+
+%default total
+%language ElabReflection
+
+
+namespace Letter
+  public export
+  data Letter = Uppercase | Lowercase | Titlecase | Modifier | Other
+  %runElab derive "Letter" [Eq, Ord, Show]
+
+namespace Mark
+  public export
+  data Mark = NonSpacing | SpacingCombining | Enclosing
+  %runElab derive "Mark" [Eq, Ord, Show]
+
+namespace Number
+  public export
+  data Number = Decimal | Letter | Other
+  %runElab derive "Number" [Eq, Ord, Show]
+
+namespace Punctuation
+  public export
+  data Punctuation = Connector | Dash | Open | Close
+                   | InitialQuote | FinalQuote | Other
+  %runElab derive "Punctuation" [Eq, Ord, Show]
+
+namespace Symbol
+  public export
+  data Symbol = Math | Currency | Modifier | Other
+  %runElab derive "Symbol" [Eq, Ord, Show]
+
+namespace Separator
+  public export
+  data Separator = Space | Line | Paragraph
+  %runElab derive "Separator" [Eq, Ord, Show]
+
+namespace Other
+  public export
+  data Other = Control | Format | Surrogate | PrivateUse | NotAssigned
+  %runElab derive "Other" [Eq, Ord, Show]
+
+
+public export
+data GeneralCategory
+= Letter      Letter
+| Mark        Mark
+| Number      Number
+| Punctuation Punctuation
+| Symbol      Symbol
+| Separator   Separator
+| Other       Other
+%runElab derive "GeneralCategory" [Eq, Ord, Show]
+
+private
+%foreign "scheme:(lambda (c) (symbol->string (char-general-category c)))"
+prim__genCat : Char -> String
+
+export
+genCat : Char -> GeneralCategory
+genCat ch = assert_total $
+  case prim__genCat ch of
+    "Lu" => Letter      Uppercase
+    "Ll" => Letter      Lowercase
+    "Lt" => Letter      Titlecase
+    "Lm" => Letter      Modifier
+    "Lo" => Letter      Other
+    "Mn" => Mark        NonSpacing
+    "Mc" => Mark        SpacingCombining
+    "Me" => Mark        Enclosing
+    "Nd" => Number      Decimal
+    "Nl" => Number      Letter
+    "No" => Number      Other
+    "Pc" => Punctuation Connector
+    "Pd" => Punctuation Dash
+    "Ps" => Punctuation Open
+    "Pe" => Punctuation Close
+    "Pi" => Punctuation InitialQuote
+    "Pf" => Punctuation FinalQuote
+    "Po" => Punctuation Other
+    "Sm" => Symbol      Math
+    "Sc" => Symbol      Currency
+    "Sk" => Symbol      Modifier
+    "So" => Symbol      Other
+    "Zs" => Separator   Space
+    "Zl" => Separator   Line
+    "Zp" => Separator   Paragraph
+    "Cc" => Other       Control
+    "Cf" => Other       Format
+    "Cs" => Other       Surrogate
+    "Co" => Other       PrivateUse
+    "Cn" => Other       NotAssigned
+    cat  => idris_crash #"Quox.Unicode.genCat: unknown category "\{cat}""#
+
+
+namespace GeneralCategory
+  public export %inline
+  isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator, isOther :
+    GeneralCategory -> Bool
+  isLetter      = \case Letter      _ => True; _ => False
+  isMark        = \case Mark        _ => True; _ => False
+  isNumber      = \case Number      _ => True; _ => False
+  isPunctuation = \case Punctuation _ => True; _ => False
+  isSymbol      = \case Symbol      _ => True; _ => False
+  isSeparator   = \case Separator   _ => True; _ => False
+  isOther       = \case Other       _ => True; _ => False
+
+namespace Char
+  public export %inline
+  isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator, isOther :
+    Char -> Bool
+  isLetter      = isLetter      . genCat
+  isMark        = isMark        . genCat
+  isNumber      = isNumber      . genCat
+  isPunctuation = isPunctuation . genCat
+  isSymbol      = isSymbol      . genCat
+  isSeparator   = isSeparator   . genCat
+  isOther       = isOther       . genCat
+
+
+export
+isSupDigit : Char -> Bool
+isSupDigit ch = ch `elem` unpack "⁰¹²³⁴⁵⁶⁷⁸⁹"
+
+export
+isSubDigit : Char -> Bool
+isSubDigit ch = ch `elem` unpack "₀₁₂₃₄₅₆₇₈₉"
+
+export
+isAsciiDigit : Char -> Bool
+isAsciiDigit ch = '0' <= ch && ch <= '9'
+
+export
+isIdStart : Char -> Bool
+isIdStart ch =
+  (ch == '_' || isLetter ch || isNumber ch) &&
+  not (isSupDigit ch || isAsciiDigit ch)
+
+export
+isIdCont : Char -> Bool
+isIdCont ch =
+  (isIdStart ch || ch == '\'' || ch == '-' || isMark ch || isNumber ch) &&
+  not (isSupDigit ch)
+
+export
+isIdConnector : Char -> Bool
+isIdConnector ch = genCat ch == Punctuation Connector
+
+
+export
+isSymChar : Char -> Bool
+isSymChar ch = case genCat ch of
+  Symbol      _     => True
+  Punctuation Dash  => True
+  Punctuation Other => True
+  _                 => False
+
+export
+isWhitespace : Char -> Bool
+isWhitespace ch = ch == '\t' || ch == '\r' || ch == '\n' || isSeparator ch
+
+
+export
+%foreign "scheme:string-normalize-nfc"
+normalizeNfc : String -> String
+
+
+export
+isCodepoint : Int -> Bool
+isCodepoint n =
+  n <= 0x10FFFF &&
+  not (n >= 0xD800 && n <= 0xDBFF || n >= 0xDC00 && n <= 0xDFFF)

lib/Quox/CheckBuiltin.idr

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

lib/Quox/Context.idr

@@ -2,17 +2,19 @@ module Quox.Context
 
 import Quox.Syntax.Shift
 import Quox.Pretty
-import public Quox.NatExtra
+import Quox.Name
 
 import Data.DPair
 import Data.Nat
+import Data.Singleton
 import Data.SnocList
+import Data.SnocVect
+import Data.Vect
 import Control.Monad.Identity
 
 %default total
 
 
-infixl 5 :<
 ||| a sequence of bindings under an existing context. each successive element
 ||| has one more bound variable, which correspond to all previous elements
 ||| as well as the surrounding context.
@@ -35,40 +37,111 @@ public export
 Context' : (a : Type) -> (len : Nat) -> Type
 Context' a = Context (\_ => a)
 
+public export
+NContext : Nat -> Type
+NContext = Context' BaseName
+
+public export
+BContext : Nat -> Type
+BContext = Context' BindName
+
+
+public export
+unsnoc : Context tm (S n) -> (Context tm n, tm n)
+unsnoc (tel :< x) = (tel, x)
+
+public export
+head : Context tm (S n) -> tm n
+head = snd . unsnoc
 
 public export
 tail : Context tm (S n) -> Context tm n
-tail (tel :< _) = tel
+tail = fst . unsnoc
 
-export
-toSnocList : Telescope tm _ _ -> SnocList (Exists tm)
-toSnocList [<]        = [<]
-toSnocList (tel :< t) = toSnocList tel :< Evidence _ t
 
-private
+parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
-toListAcc : Telescope tm _ _ -> List (Exists tm) -> List (Exists tm)
+  export
-toListAcc [<]        acc = acc
+  toSnocListWith : Telescope tm _ _ -> SnocList a
-toListAcc (tel :< t) acc = toListAcc tel (Evidence _ t :: acc)
+  toSnocListWith [<]        = [<]
+  toSnocListWith (tel :< t) = toSnocListWith tel :< f t
+
+  export
+  toListWith : Telescope tm _ _ -> List a
+  toListWith tel = toListAcc tel [] where
+    toListAcc : Telescope tm _ _ -> List a -> List a
+    toListAcc [<]        acc = acc
+    toListAcc (tel :< t) acc = toListAcc tel (f t :: acc)
+
+  export
+  toSnocVectWith : Context tm n -> SnocVect n a
+  toSnocVectWith [<]        = [<]
+  toSnocVectWith (tel :< t) = toSnocVectWith tel :< f t
 
 export %inline
-toList : Telescope tm _ _ -> List (Exists tm)
+toSnocList : Telescope tm _ _ -> SnocList (Exists tm)
-toList tel = toListAcc tel []
+toSnocList = toSnocListWith (Evidence _)
 
 export %inline
 toSnocList' : Telescope' a _ _ -> SnocList a
-toSnocList' = map snd . toSnocList
+toSnocList' = toSnocListWith id
+
+export %inline
+toList : Telescope tm _ _ -> List (Exists tm)
+toList = toListWith (Evidence _)
 
 export %inline
 toList' : Telescope' a _ _ -> List a
-toList' = map snd . toList
+toList' = toListWith id
+
+export %inline
+toSnocVect : Context tm n -> SnocVect n (Exists tm)
+toSnocVect = toSnocVectWith (Evidence _)
+
+export %inline
+toSnocVect' : Context' a n -> SnocVect n a
+toSnocVect' = toSnocVectWith id
+
+
+
+export
+fromSnocVect : SnocVect n a -> Context' a n
+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
+
+public export
+replicate : (n : Nat) -> a -> Context' a n
+replicate n x = tabulate (const x) n
 
 
-infixl 9 .
 public export
 (.) : Telescope tm from mid -> Telescope tm mid to -> Telescope tm from to
 tel1 . [<]         = tel1
 tel1 . (tel2 :< s) = (tel1 . tel2) :< s
 
+export
+(<><) : Telescope' a from to -> Vect n a -> Telescope' a from (n + to)
+(<><) tel [] = tel
+(<><) tel (x :: xs) {n = S n} =
+  rewrite plusSuccRightSucc n to in
+  (tel :< x) <>< xs
+
+export
+(++) : Telescope' a from to -> SnocVect n a -> Telescope' a from (n + to)
+tel ++ [<]       = tel
+tel ++ (sx :< x) = (tel ++ sx) :< x
 
 public export
 getShiftWith : (forall from, to. tm from -> Shift from to -> tm to) ->
@@ -85,25 +158,22 @@ getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
           Context tm len -> Var len -> tm len
 getWith shft = getShiftWith shft SZ
 
-infixl 8 !!
+export infixl 8 !!
+public export %inline
 (!!) : CanShift tm => Context tm len -> Var len -> tm len
 (!!) = getWith (//)
 
-infixl 8 !!!
+export infixl 8 !!!
 public export %inline
 (!!!) : Context' tm len -> Var len -> tm
 (!!!) = getWith const
 
-
-||| a triangle of bindings. each type binding in a context counts the ues of
-||| others in its type, and all of these together form a triangle.
 public export
-Triangle : (tm : Nat -> Type) -> (len : Nat) -> Type
+find : Alternative f =>
-Triangle = Context . Context
+       (forall n. tm n -> Bool) -> Context tm len -> f (Var len)
+find p [<]        = empty
+find p (ctx :< x) = (guard (p x) $> VZ) <|> (VS <$> find p ctx)
 
-public export
-Triangle' : Type -> (len : Nat) -> Type
-Triangle' a = Context $ Context (\_ => a)
 
 export
 0 telescopeLTE : Telescope _ from to -> from `LTE` to
@@ -119,6 +189,12 @@ export %hint
 succGT = LTESucc reflexive
 
 
+public export
+drop : (m : Nat) -> Context term (m + n) -> Context term n
+drop 0     ctx        = ctx
+drop (S m) (ctx :< _) = drop m ctx
+
+
 parameters {auto _ : Applicative f}
   export
   traverse : (forall n. tm1 n -> f (tm2 n)) ->
@@ -126,7 +202,11 @@ parameters {auto _ : Applicative f}
   traverse f [<]        = pure [<]
   traverse f (tel :< x) = [|traverse f tel :< f x|]
 
-  infixl 3 `app`
+  export %inline
+  traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
+  traverse' f = traverse f
+
+  export infixl 3 `app`
   ||| like `(<*>)` but with effects
   export
   app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
@@ -140,6 +220,7 @@ parameters {auto _ : Applicative f}
   sequence : Telescope (f . tm) from to -> f (Telescope tm from to)
   sequence = traverse id
 
+
 parameters {0 tm1, tm2 : Nat -> Type}
            (f : forall n. tm1 n -> tm2 n)
   export %inline
@@ -150,33 +231,17 @@ parameters {0 tm1, tm2 : Nat -> Type}
   (<$>) : Telescope tm1 from to -> Telescope tm2 from to
   (<$>) = map
 
+
+
 export %inline
 (<*>) : Telescope (\n => tm1 n -> tm2 n) from to ->
         Telescope tm1 from to -> Telescope tm2 from to
 ftel <*> xtel = runIdentity $ (pure .) <$> ftel `app` xtel
 -- ...but can't write pure without `from,to` being ω, so no idiom brackets ☹
 
-export
+export %inline
-teleLte' : Telescope tm from to -> from `LTE'` to
+(<$) : (forall n. tm1 n) -> Telescope tm2 from to -> Telescope tm1 from to
-teleLte' [<]        = LTERefl
+x <$ tel = const x <$> tel
-teleLte' (tel :< _) = LTESuccR (teleLte' tel)
-
-
-export
-tabulate : ((n : Nat) -> tm n) ->
-           (from, to : Nat) -> from `LTE'` to => Telescope tm from to
-tabulate f from from   @{LTERefl}    = [<]
-tabulate f from (S to) @{LTESuccR _} = tabulate f from to :< f to
-
-export
-tabulate0 : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
-tabulate0 f n = tabulate f 0 n
-
-
-export
-pure : from `LTE'` to => a -> Telescope' a from to
-pure @{LTERefl}    x = [<]
-pure @{LTESuccR _} x = pure x :< x
 
 
 export %inline
@@ -185,14 +250,6 @@ zipWith : (forall n. tm1 n -> tm2 n -> tm3 n) ->
           Telescope tm3 from to
 zipWith f tel1 tel2 = f <$> tel1 <*> tel2
 
-export %inline
-zipWith3 : (forall n. tm1 n -> tm2 n -> tm3 n -> tm4 n) ->
-           Telescope tm1 from to ->
-           Telescope tm2 from to ->
-           Telescope tm3 from to ->
-           Telescope tm4 from to
-zipWith3 f tel1 tel2 tel3 = f <$> tel1 <*> tel2 <*> tel3
-
 export %inline
 zipWithLazy : forall tm1, tm2, tm3.
               (forall n. tm1 n -> tm2 n -> tm3 n) ->
@@ -200,32 +257,43 @@ zipWithLazy : forall tm1, tm2, tm3.
               Telescope (\n => Lazy (tm3 n)) from to
 zipWithLazy f = zipWith $ delay .: f
 
-export %inline
+export
-zipWith3Lazy : forall tm1, tm2, tm3, tm4.
+unzip : Telescope (\n => (tm1 n, tm2 n)) from to ->
-               (forall n. tm1 n -> tm2 n -> tm3 n -> tm4 n) ->
+        (Telescope tm1 from to, Telescope tm2 from to)
-               Telescope tm1 from to ->
+unzip [<]             = ([<], [<])
-               Telescope tm2 from to ->
+unzip (tel :< (x, y)) = let (xs, ys) = unzip tel in (xs :< x, ys :< y)
-               Telescope tm3 from to ->
-               Telescope (\n => Lazy (tm4 n)) from to
-zipWith3Lazy f = zipWith3 $ \x, y, z => delay $ f x y z
-
 
 export
+unzip3 : Telescope (\n => (tm1 n, tm2 n, tm3 n)) from to ->
+         (Telescope tm1 from to, Telescope tm2 from to, Telescope tm3 from to)
+unzip3 [<] = ([<], [<], [<])
+unzip3 (tel :< (x, y, z)) =
+  let (xs, ys, zs) = unzip3 tel in (xs :< x, ys :< y, zs :< z)
+
+
+
+public export
 lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
 lengthPrf [<]        = Element 0 Refl
 lengthPrf (tel :< _) =
   let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
 
 export
-lengthPrf0 : Context _ to -> Subset Nat (\len => len = to)
+lengthPrf0 : Context _ to -> Singleton to
 lengthPrf0 ctx =
-  let len = lengthPrf ctx in
+  let Element len prf = lengthPrf ctx in
-  Element len.fst (rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
+  rewrite sym prf `trans` plusZeroRightNeutral len in
+  [|len|]
 
 public export %inline
 length : Telescope {} -> Nat
 length = fst . lengthPrf
 
+public export
+null : Telescope _ from to -> Bool
+null [<] = True
+null _   = False
+
 
 export
 foldl : {0 acc : Nat -> Type} ->
@@ -234,6 +302,10 @@ foldl : {0 acc : Nat -> Type} ->
 foldl f z [<]        = z
 foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
 
+export %inline
+foldl_ : (acc -> tm -> acc) -> acc -> Telescope' tm from to -> acc
+foldl_ f z tel = foldl f z tel
+
 export %inline
 foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
 foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
@@ -249,41 +321,48 @@ foldLazy = foldMap force
 
 
 export %inline
-and : Telescope' (Lazy Bool) _ _ -> Bool
+all, any : (forall n. tm n -> Bool) -> Telescope tm from to -> Bool
-and = force . fold @{All}
+all p = foldMap @{All} p
-
+any p = foldMap @{Any} p
-export %inline
-all : (forall n. tm n -> Bool) -> Telescope tm _ _ -> Bool
-all p = and . map (delay . p)
-
-export %inline
-all2 : (forall n. tm n -> tm2 n -> Bool) ->
-       Telescope tm from to -> Telescope tm2 from to -> Bool
-all2 p = and .: zipWithLazy p
-
-
-export %inline
-or : Telescope' (Lazy Bool) _ _ -> Bool
-or = force . fold @{Any}
-
-export %inline
-any : (forall n. tm n -> Bool) -> Telescope tm _ _ -> Bool
-any p = or . map (delay . p)
-
-export %inline
-any2 : (forall n. tm1 n -> tm2 n -> Bool) ->
-       Telescope tm1 from to -> Telescope tm2 from to -> Bool
-any2 p = or .: zipWithLazy p
 
 
 export %inline
 (forall n. Eq (tm n)) => Eq (Telescope tm from to) where
-  (==) = all2 (==)
+  (==) = foldLazy @{All} .: zipWithLazy (==)
 
 export %inline
 (forall n. Ord (tm n)) => Ord (Telescope tm from to) where
   compare = foldLazy .: zipWithLazy compare
 
 export %inline
-(forall n. PrettyHL (tm n)) => PrettyHL (Telescope tm from to) where
+(forall n. Show (tm n)) => Show (Telescope tm from to) where
-  prettyM tel = separate (hl Delim ";") <$> traverse prettyM (toList tel)
+  showPrec d = showPrec d . toSnocList
+    where Show (Exists tm) where showPrec d t = showPrec d t.snd
+
+
+parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
+           (nameHL : HL)
+           (pterm : forall n. BContext n -> tm n -> Eff Pretty (Doc opts))
+  private
+  prettyOne : BindName -> BContext to -> tm to -> Eff Pretty (Doc opts)
+  prettyOne x xs tm = hsep <$> sequence
+    [hl nameHL $ prettyBind' x, hl Delim $ text ":", pterm xs tm]
+
+  private
+  prettyEach : BContext to -> Telescope tm from to ->
+               Eff Pretty (Telescope' (Doc opts) from to)
+  prettyEach _         [<]       = pure [<]
+  prettyEach (xs :< x) (ts :< t) = [|prettyEach xs ts :< prettyOne x xs t|]
+
+  export
+  prettyTel : BContext to -> Telescope tm from to -> Eff Pretty (Doc opts)
+  prettyTel names tel = do
+    docs <- prettyEach names tel
+    comma <- hl Delim $ text ","
+    pure $ separateTight comma $ toList' docs
+
+
+namespace BContext
+  export
+  toNames : BContext n -> SnocList BaseName
+  toNames = foldl (\xs, x => xs :< x.val) [<]

lib/Quox/Decidable.idr

@@ -0,0 +1,53 @@
+module Quox.Decidable
+
+import public Data.Bool.Decidable
+import public Decidable.Decidable
+import public Decidable.Equality
+import public Control.Relation
+
+
+public export
+0 REL : Type -> Type -> Type
+REL a b = a -> b -> Type
+
+
+public export
+0 Pred : Type -> Type
+Pred a = a -> Type
+
+
+public export
+0 Dec1 : Pred a -> Type
+Dec1 p = (x : a) -> Dec (p x)
+
+public export
+0 Dec2 : REL a b -> Type
+Dec2 p = (x : a) -> (y : b) -> Dec (p x y)
+
+
+public export
+0 Reflects1 : Pred a -> (a -> Bool) -> Type
+p `Reflects1` f = (x : a) -> p x `Reflects` f x
+
+public export
+0 Reflects2 : REL a b -> (a -> b -> Bool) -> Type
+p `Reflects2` f = (x : a) -> (y : b) -> p x y `Reflects` f x y
+
+
+public export
+(||) : Dec p -> Dec q -> Dec (Either p q)
+Yes y1 || _      = Yes $ Left y1
+No  _  || Yes y2 = Yes $ Right y2
+No  n1 || No  n2 = No  $ \case Left y1 => n1 y1; Right y2 => n2 y2
+
+public export
+(&&) : Dec p -> Dec q -> Dec (p, q)
+Yes y1 && Yes y2 = Yes (y1, y2)
+Yes _  && No  n2 = No $ n2 . snd
+No  n1 && _      = No $ n1 . fst
+
+
+public export
+reflectToDec : p `Reflects` b -> Dec p
+reflectToDec (RTrue  y) = Yes y
+reflectToDec (RFalse n) = No  n

lib/Quox/Definition.idr

@@ -1,52 +1,127 @@
 module Quox.Definition
 
+import public Quox.No
 import public Quox.Syntax
+import Quox.Displace
 import public Data.SortedMap
-import public Control.Monad.State
+import public Quox.Loc
+import Quox.Pretty
+import Control.Eff
+import Data.Singleton
+import Decidable.Decidable
 
 
 public export
-record AnyTerm where
+data DefBody =
-  constructor T
+    Concrete (Term 0 0)
-  def : forall d, n. Term d n
+  | Postulate
+
+namespace DefBody
+  public export
+  (.term0) : DefBody -> Maybe (Term 0 0)
+  (Concrete t).term0 = Just t
+  (Postulate).term0  = Nothing
+
 
 public export
 record Definition where
-  constructor MkDef'
+  constructor MkDef
-  qty         : Qty
+  qty    : GQty
-  0 qtyGlobal : IsGlobal qty
+  type0  : Term 0 0
-  type        : AnyTerm
+  body0  : DefBody
-  term        : Maybe AnyTerm
+  scheme : Maybe String
+  isMain : Bool
+  loc_   : Loc
 
 public export %inline
-MkDef : (qty : Qty) -> (0 qtyGlobal : IsGlobal qty) =>
+mkPostulate : GQty -> (type0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
-           (type, term : forall d, n. Term d n) -> Definition
+              Definition
-MkDef {qty, type, term} =
+mkPostulate qty type0 scheme isMain loc_ =
-  MkDef' {qty, qtyGlobal = %search, type = T type, term = Just (T term)}
+  MkDef {qty, type0, body0 = Postulate, scheme, isMain, loc_}
 
 public export %inline
-MkAbstract : (qty : Qty) -> (0 qtyGlobal : IsGlobal qty) =>
+mkDef : GQty -> (type0, term0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
-             (type : forall d, n. Term d n) -> Definition
+        Definition
-MkAbstract {qty, type} =
+mkDef qty type0 term0 scheme isMain loc_ =
-  MkDef' {qty, qtyGlobal = %search, type = T type, term = Nothing}
+  MkDef {qty, type0, body0 = Concrete term0, scheme, isMain, loc_}
+
+export Located Definition where def.loc = def.loc_
+export Relocatable Definition where setLoc loc = {loc_ := loc}
 
 
-public export %inline
+parameters {d, n : Nat}
-(.type0) : Definition -> Term 0 0
+  public export %inline
-g.type0 = g.type.def
+  (.type) : Definition -> Term d n
+  g.type = g.type0 // shift0 d // shift0 n
 
-public export %inline
+  public export %inline
-(.term0) : Definition -> Maybe (Term 0 0)
+  (.typeAt) : Definition -> Universe -> Term d n
-g.term0 = map (\t => t.def) g.term
+  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
 
-public export %inline
-(.qtyP) : Definition -> Subset Qty IsGlobal
-g.qtyP = Element g.qty g.qtyGlobal
 
 public export %inline
 isZero : Definition -> Bool
-isZero g = g.qty == Zero
+isZero g = g.qty == GZero
+
+
+public export
+NDefinition : Type
+NDefinition = (Name, Definition)
 
 public export
 Definitions : Type
 Definitions = SortedMap Name Definition
+
+public export
+data DefEnvTag = DEFS
+
+public export
+DefsReader : Type -> Type
+DefsReader = ReaderL DEFS Definitions
+
+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

lib/Quox/Displace.idr

@@ -0,0 +1,95 @@
+module Quox.Displace
+
+import Quox.Syntax
+
+%default total
+
+
+parameters (k : Universe)
+  namespace Term
+    export doDisplace   : Term d n          -> Term d n
+    export doDisplaceS  : ScopeTermN s d n  -> ScopeTermN s d n
+    export doDisplaceDS : DScopeTermN s d n -> DScopeTermN s d n
+
+  namespace Elim
+    export doDisplace : Elim d n -> Elim d n
+
+  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
+    doDisplace (Sig fst snd loc) = Sig (doDisplace fst) (doDisplaceS snd) loc
+    doDisplace (Pair fst snd loc) = Pair (doDisplace fst) (doDisplace snd) loc
+    doDisplace (Enum cases loc) = Enum cases loc
+    doDisplace (Tag tag loc) = Tag tag loc
+    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 (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))
+    doDisplace (DCloT (Sub t th)) =
+      DCloT (Sub (doDisplace t) th)
+
+    doDisplaceS (S names (Y body)) = S names $ Y $ doDisplace body
+    doDisplaceS (S names (N body)) = S names $ N $ doDisplace body
+
+    doDisplaceDS (S names (Y body)) = S names $ Y $ doDisplace body
+    doDisplaceDS (S names (N body)) = S names $ N $ doDisplace body
+
+  namespace Elim
+    doDisplace (F x u loc) = F x (k + u) loc
+    doDisplace (B i loc) = B i loc
+    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
+    doDisplace (CaseNat qty qtyIH nat ret zero succ loc) =
+      CaseNat qty qtyIH (doDisplace nat) (doDisplaceS ret)
+              (doDisplace zero) (doDisplaceS succ) loc
+    doDisplace (CaseBox qty box ret body loc) =
+      CaseBox qty (doDisplace box) (doDisplaceS ret) (doDisplaceS body) loc
+    doDisplace (DApp fun arg loc) =
+      DApp (doDisplace fun) arg loc
+    doDisplace (Ann tm ty loc) =
+      Ann (doDisplace tm) (doDisplace ty) loc
+    doDisplace (Coe ty p q val loc) =
+      Coe (doDisplaceDS ty) p q (doDisplace val) loc
+    doDisplace (Comp ty p q val r zero one loc) =
+      Comp (doDisplace ty) p q (doDisplace val) r
+           (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
+    doDisplace (CloE (Sub e th)) =
+      CloE (Sub (doDisplace e) (assert_total $ map doDisplace th))
+    doDisplace (DCloE (Sub e th)) =
+      DCloE (Sub (doDisplace e) th)
+
+
+namespace Term
+  export
+  displace : Universe -> Term d n -> Term d n
+  displace 0 t = t
+  displace u t = doDisplace u t
+
+namespace Elim
+  export
+  displace : Universe -> Elim d n -> Elim d n
+  displace 0 t = t
+  displace u t = doDisplace u t

lib/Quox/EffExtra.idr

@@ -0,0 +1,149 @@
+module Quox.EffExtra
+
+import public Control.Eff
+
+import Control.Monad.ST.Extra
+import Data.IORef
+
+
+export
+localAt : (0 lbl : tag) -> Has (StateL lbl s) fs =>
+          (s -> s) -> Eff fs a -> Eff fs a
+localAt lbl f act = do
+  old <- getAt lbl
+  modifyAt lbl f *> act <* putAt lbl old
+
+export %inline
+localAt_ : (0 lbl : tag) -> Has (StateL lbl s) fs =>
+           s -> Eff fs a -> Eff fs a
+localAt_ lbl x = localAt lbl $ const x
+
+export %inline
+local : Has (State s) fs => (s -> s) -> Eff fs a -> Eff fs a
+local = localAt ()
+
+export %inline
+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
+handleStateIORef : HasIO m => IORef st -> StateL lbl st a -> m a
+handleStateIORef r Get     = readIORef r
+handleStateIORef r (Put s) = writeIORef r s
+
+export
+handleStateSTRef : HasST m => STRef s st -> StateL lbl st a -> m s a
+handleStateSTRef r Get     = liftST $ readSTRef r
+handleStateSTRef r (Put s) = liftST $ writeSTRef r s
+
+
+public export
+data Length : List a -> Type where
+  Z : Length []
+  S : Length xs -> Length (x :: xs)
+%builtin Natural Length
+
+export
+subsetWith : Length xs => (forall z. Has z xs -> Has z ys) ->
+             Subset xs ys
+subsetWith @{Z}     f = []
+subsetWith @{S len} f = f Z :: subsetWith (f . S)
+
+export
+subsetSelf : Length xs => Subset xs xs
+subsetSelf = subsetWith id
+
+export
+subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
+subsetTail _ = subsetWith S
+
+
+
+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
+
+export %inline
+ioLeft : e -> IOErr e a
+ioLeft = IOE . pure . Left

lib/Quox/FreeVars.idr

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

lib/Quox/Lexer.idr

@@ -1,102 +0,0 @@
-module Quox.Lexer
-
-import public Quox.Token
-
-import Data.String
-import Data.String.Extra
-import public Text.Lexer
-import public Text.Lexer.Tokenizer
-import Control.Monad.Either
-import Generics.Derive
-
-%default total
-%language ElabReflection
-
-
-public export
-record Error where
-  constructor Err
-  reason    : StopReason
-  line, col : Int
-  char      : Char
-
-
-
-nameStart = pred $ \c => isAlpha c || c == '_'
-nameCont  = pred $ \c => isAlphaNum c || c == '_' || c == '\''
-
-name = nameStart <+> many nameCont <+> reject nameCont
-
-wild = is '_' <+> reject nameCont
-
-%hide Text.Lexer.symbol
-symbol = is '\'' <+> name
-
-decimal = some digit <+> reject nameCont
-
-
-natToNumber : Nat -> Number
-natToNumber 0 = Zero
-natToNumber 1 = One
-natToNumber k = Other k
-
-
-skip : Lexer -> Tokenizer (Maybe a)
-skip lex = match lex $ const Nothing
-
-simple : Char -> a -> Tokenizer (Maybe a)
-simple ch = match (is ch) . const . Just
-
-keyword : String -> Keyword -> Tokenizer (Maybe Token)
-keyword str = match (exact str <+> reject nameCont) . const . Just . K
-
-choice : (xs : List (Tokenizer a)) -> {auto 0 _ : NonEmpty xs} -> Tokenizer a
-choice (t :: ts) = foldl (\a, b => a <|> b) t ts
-
-match : Lexer -> (String -> a) -> Tokenizer (Maybe a)
-match lex f = Tokenizer.match lex (Just . f)
-%hide Tokenizer.match
-
-
-tokens : Tokenizer (Maybe Token)
-tokens = choice [
-  skip $ lineComment $ exact "--",
-  skip $ blockComment (exact "{-") (exact "-}"),
-  skip spaces,
-
-  simple '(' $ P LParen,  simple ')' $ P RParen,
-  simple '[' $ P LSquare, simple ']' $ P RSquare,
-  simple '{' $ P LBrace,  simple '}' $ P RBrace,
-  simple ',' $ P Comma,
-  simple '∷' $ P DblColon,
-  simple ':' $ P Colon, -- needs to be after '::'
-  simple '.' $ P Dot,
-
-  simple '→' $ P Arrow,
-  simple '⇒' $ P DblArrow,
-  simple '×' $ P Times,
-  simple '⊲' $ P Triangle,
-  match wild $ const $ P Wild,
-
-  keyword "λ"    Lam,
-  keyword "let"  Let,  keyword "in" In,
-  keyword "case" Case, keyword "of" Of,
-  keyword "ω"    Omega,
-  keyword "Π"    Pi,   keyword "Σ"  Sigma, keyword "W" W,
-
-  match name   $ Name,
-  match symbol $ Symbol . assert_total strTail,
-
-  match decimal $ N . natToNumber . cast,
-  match (is '★' <+> decimal) $ TYPE . cast . assert_total strTail
-]
-
-
-export
-lex : String -> Either Error (List BToken)
-lex str =
-  let (res, (reason, line, col, str)) = lex tokens str in
-  case reason of
-       EndInput => Right $ mapMaybe sequence res
-       _        => let char = assert_total strIndex str 0 in
-                   Left $ Err {reason, line, col, char}

lib/Quox/Loc.idr

@@ -0,0 +1,152 @@
+||| file locations
+module Quox.Loc
+
+import Quox.PrettyValExtra
+import public Text.Bounded
+import Data.SortedMap
+import Derive.Prelude
+
+%default total
+%language ElabReflection
+
+public export
+FileName : Type
+FileName = String
+
+%runElab derive "Bounds" [Ord, PrettyVal]
+
+public export
+data Loc_ = NoLoc | YesLoc FileName Bounds
+%name Loc_ loc
+%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal]
+
+
+||| a wrapper for locations which are always considered equal
+public export
+record Loc where
+  constructor L
+  val : Loc_
+%name Loc loc
+%runElab derive "Loc" [Show]
+
+export %inline Eq  Loc where _ == _ = True
+export %inline Ord Loc where compare _ _ = EQ
+
+public export %inline
+noLoc : Loc
+noLoc = L NoLoc
+
+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_
+onlyStart_ NoLoc = NoLoc
+onlyStart_ (YesLoc fname (MkBounds sl sc _ _)) =
+  YesLoc fname $ MkBounds sl sc sl sc
+
+export %inline
+onlyStart : Loc -> Loc
+onlyStart = {val $= onlyStart_}
+
+export
+onlyEnd_ : Loc_ -> Loc_
+onlyEnd_ NoLoc = NoLoc
+onlyEnd_ (YesLoc fname (MkBounds _ _ el ec)) =
+  YesLoc fname $ MkBounds el ec el ec
+
+export %inline
+onlyEnd : Loc -> Loc
+onlyEnd = {val $= onlyEnd_}
+
+
+export
+extend_ : Loc_ -> Bounds -> Loc_
+extend_ NoLoc _ = NoLoc
+extend_ (YesLoc fname (MkBounds sl1 sc1 el1 ec1)) (MkBounds sl2 sc2 el2 ec2) =
+  let (sl, sc) = (sl1, sc1) `min` (sl2, sc2)
+      (el, ec) = (el1, ec1) `max` (el2, ec2)
+  in
+  YesLoc fname $ MkBounds sl sc el ec
+
+export
+extend : Loc -> Bounds -> Loc
+extend l b = L $ extend_ l.val b
+
+export
+extend' : Loc -> Maybe Bounds -> Loc
+extend' l b = maybe l (extend l) b
+
+
+namespace Loc_
+  export
+  (.bounds) : Loc_ -> Maybe Bounds
+  (YesLoc _ b).bounds = Just b
+  (NoLoc).bounds      = Nothing
+
+namespace Loc
+  export
+  (.bounds) : Loc -> Maybe Bounds
+  l.bounds = l.val.bounds
+
+export %inline
+extendL : Loc -> Loc -> Loc
+extendL l1 l2 = l1 `extend'` l2.bounds
+
+
+export infixr 1 `or_`, `or`
+export %inline
+or_ : Loc_ -> Loc_ -> Loc_
+or_ l1@(YesLoc {}) _  = l1
+or_ NoLoc          l2 = l2
+
+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
+
+public export
+0 Located1 : (a -> Type) -> Type
+Located1 f = forall x. Located (f x)
+
+public export
+0 Located2 : (a -> b -> Type) -> Type
+Located2 f = forall x, y. Located (f x y)
+
+public export
+interface Located a => Relocatable a where setLoc : Loc -> a -> a
+
+public export
+0 Relocatable1 : (a -> Type) -> Type
+Relocatable1 f = forall x. Relocatable (f x)
+
+public export
+0 Relocatable2 : (a -> b -> Type) -> Type
+Relocatable2 f = forall x, y. Relocatable (f x y)
+
+
+export
+locs : Located a => Foldable t => t a -> Loc
+locs = foldl (\loc, y => loc `extendOr` y.loc) noLoc

lib/Quox/Log.idr

@@ -0,0 +1,317 @@
+module Quox.Log
+
+import Quox.Loc
+import Quox.Pretty
+import Quox.PrettyValExtra
+
+import Data.So
+import Data.DPair
+import Data.Maybe
+import Data.List1
+import Control.Eff
+import Control.Monad.ST.Extra
+import Data.IORef
+import System.File
+import Derive.Prelude
+
+%default total
+%language ElabReflection
+
+
+public export %inline
+maxLogLevel : Nat
+maxLogLevel = 100
+
+public export %inline
+logCategories : List String
+logCategories = ["whnf", "equal", "check"]
+
+public export %inline
+isLogLevel : Nat -> Bool
+isLogLevel l = l <= maxLogLevel
+
+public export
+IsLogLevel : Nat -> Type
+IsLogLevel l = So $ isLogLevel l
+
+public export %inline
+isLogCategory : String -> Bool
+isLogCategory cat = cat `elem` logCategories
+
+public export
+IsLogCategory : String -> Type
+IsLogCategory cat = So $ isLogCategory cat
+
+-- Q: why are you using `So` instead of `LT` and `Elem`
+-- A: ① proof search gives up before finding a proof of e.g. ``99 `LT` 100``
+--      (i.e. `LTESucc⁹⁹ LTEZero`)
+--    ② the proofs aren't looked at in any way, i just wanted to make sure the
+--      list of categories was consistent everywhere
+
+
+||| a verbosity level from 0–100. higher is noisier. each log entry has a
+||| verbosity level above which it will be printed, chosen, uh, based on vibes.
+public export
+LogLevel : Type
+LogLevel = Subset Nat IsLogLevel
+
+||| a logging category, like "check" (type checking), "whnf", or whatever.
+public export
+LogCategory : Type
+LogCategory = Subset String IsLogCategory
+
+
+public export %inline
+toLogLevel : Nat -> Maybe LogLevel
+toLogLevel l =
+  case choose $ isLogLevel l of
+    Left  y => Just $ Element l y
+    Right _ => Nothing
+
+public export %inline
+toLogCategory : String -> Maybe LogCategory
+toLogCategory c =
+  case choose $ isLogCategory c of
+    Left  y => Just $ Element c y
+    Right _ => Nothing
+
+
+||| verbosity levels for each category, if they differ from the default
+public export
+LevelMap : Type
+LevelMap = List (LogCategory, LogLevel)
+
+-- Q: why `List` instead of `SortedMap`
+-- A: oof ouch my constant factors (maybe this one was more obvious)
+
+
+public export
+record LogLevels where
+  constructor MkLogLevels
+  defLevel : LogLevel
+  levels   : LevelMap
+%name LogLevels lvls
+%runElab derive "LogLevels" [Eq, Show, PrettyVal]
+
+public export
+LevelStack : Type
+LevelStack = List LogLevels
+
+public export %inline
+defaultLevel : LogLevel
+defaultLevel = Element 0 Oh
+
+export %inline
+defaultLogLevels : LogLevels
+defaultLogLevels = MkLogLevels defaultLevel []
+
+export %inline
+initStack : LevelStack
+initStack = []
+
+export %inline
+getLevel1 : LogCategory -> LogLevels -> LogLevel
+getLevel1 cat (MkLogLevels def lvls) = fromMaybe def $ lookup cat lvls
+
+export %inline
+getLevel : LogCategory -> LevelStack -> LogLevel
+getLevel cat (lvls :: _) = getLevel1 cat lvls
+getLevel cat []          = defaultLevel
+
+export %inline
+getCurLevels : LevelStack -> LogLevels
+getCurLevels (lvls :: _) = lvls
+getCurLevels []          = defaultLogLevels
+
+
+public export
+LogDoc : Type
+LogDoc = Doc (Opts {lineLength = 80})
+
+
+private %inline
+replace : Eq a => a -> b -> List (a, b) -> List (a, b)
+replace k v kvs = (k, v) :: filter (\y => fst y /= k) kvs
+
+private %inline
+mergeLeft : Eq a => List (a, b) -> List (a, b) -> List (a, b)
+mergeLeft l r = foldl (\lst, (k, v) => replace k v lst) r l
+
+
+public export
+data PushArg =
+    SetDefault LogLevel
+  | SetCat     LogCategory LogLevel
+  | SetAll     LogLevel
+%runElab derive "PushArg" [Eq, Ord, Show, PrettyVal]
+%name PushArg push
+
+export %inline
+applyPush : LogLevels -> PushArg -> LogLevels
+applyPush lvls (SetDefault def)     = {defLevel := def} lvls
+applyPush lvls (SetCat     cat lvl) = {levels   $= replace cat lvl} lvls
+applyPush lvls (SetAll     lvl)     = MkLogLevels lvl []
+
+export %inline
+fromPush : PushArg -> LogLevels
+fromPush = applyPush defaultLogLevels
+
+
+public export
+record LogMsg where
+  constructor (:>)
+  level : Nat
+  {auto 0 levelOk : IsLogLevel level}
+  message : Lazy LogDoc
+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

@@ -1,8 +1,13 @@
 module Quox.Name
 
+import Quox.Loc
+import Quox.CharExtra
+import Quox.PrettyValExtra
 import public Data.SnocList
 import Data.List
-import Generics.Derive
+import Control.Eff
+import Text.Lexer
+import Derive.Prelude
 
 %hide TT.Name
 
@@ -10,42 +15,177 @@ import Generics.Derive
 %language ElabReflection
 
 
+public export
+NameSuf : Type
+NameSuf = Nat
+
 public export
 data BaseName
-= UN String -- user-given name
+= UN String         -- user-given name
-%runElab derive "BaseName" [Generic, Meta, Eq, Ord, DecEq]
+| MN String NameSuf -- machine-generated name
-
+| Unused            -- "_"
-export
+%runElab derive "BaseName" [Eq, Ord, PrettyVal]
-Show BaseName where
-  show (UN x) = x
-
 
 export
 baseStr : BaseName -> String
-baseStr (UN x) = x
+baseStr (UN x)   = x
+baseStr (MN x i) = "\{x}#\{show i}"
+baseStr Unused   = "_"
 
-export
+export Show BaseName where show = show . baseStr
-FromString BaseName where
+export FromString BaseName where fromString = UN
-  fromString = UN
+
+
+public export
+Mods : Type
+Mods = SnocList String
 
 
 public export
 record Name where
-  constructor MakeName
+  constructor MkName
-  mods : SnocList String
+  mods : Mods
   base : BaseName
-%runElab derive "Name" [Generic, Meta, Eq, Ord]
+%runElab derive "Name" [Eq, Ord]
+
+public export %inline
+unq : BaseName -> Name
+unq = MkName [<]
+
+||| add some namespaces to the beginning of a name
+public export %inline
+addMods : Mods -> Name -> Name
+addMods ms = {mods $= (ms <+>)}
+
+
+public export
+PBaseName : Type
+PBaseName = String
+
+public export
+record PName where
+  constructor MkPName
+  mods : Mods
+  base : PBaseName
+%runElab derive "PName" [Eq, Ord, PrettyVal]
+
+export %inline
+fromPName : PName -> Name
+fromPName p = MkName p.mods $ UN p.base
+
+export %inline
+toPName : Name -> PName
+toPName p = MkPName p.mods $ baseStr p.base
+
+export %inline
+fromPBaseName : PBaseName -> Name
+fromPBaseName = MkName [<] . UN
 
 export
-Show Name where
+Show PName where
-  show (MakeName mods base) =
+  show (MkPName mods base) =
-    concat $ intersperse "." $ toList $ mods :< show base
+    show $ concat $ intersperse "." $ toList $ mods :< base
+
+export Show Name where show = show . toPName
+
+export FromString PName where fromString = MkPName [<]
+
+export FromString Name where fromString = fromPBaseName
+
+
+public export
+record BindName where
+  constructor BN
+  val  : BaseName
+  loc_ : Loc
+%runElab derive "BindName" [Eq, Ord, Show, PrettyVal]
+
+export Located BindName where n.loc = n.loc_
+export Relocatable BindName where setLoc loc (BN x _) = BN x loc
+
 
 export
-FromString Name where
+toDotsP : PName -> String
-  fromString x = MakeName [<] (fromString x)
+toDotsP x = fastConcat $ cast $ map (<+> ".") x.mods :< x.base
-
 
 export
 toDots : Name -> String
 toDots x = fastConcat $ cast $ map (<+> ".") x.mods :< baseStr x.base
+
+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 (y :: ys) = go (mods :< x) y ys
+
+export %inline
+fromList : List1 String -> Name
+fromList = fromPName . fromListP
+
+
+export
+syntaxChars : List Char
+syntaxChars = ['(', ')', '[', ']', '{', '}', '"', '\'', ',', '.', ';', '^']
+
+export
+isSymStart, isSymCont : Char -> Bool
+isSymStart c = not (c `elem` syntaxChars) && isSymChar c
+isSymCont  c = c == '\'' || isSymStart c
+
+export
+idStart, idCont, idEnd, idContEnd : Lexer
+idStart   = pred isIdStart
+idCont    = pred isIdCont
+idEnd     = pred $ \c => c `elem` unpack "?!#"
+idContEnd = idCont <|> idEnd
+
+export
+symStart, symCont : Lexer
+symStart  = pred isSymStart
+symCont   = pred isSymCont
+
+export
+baseName : Lexer
+baseName = idStart <+> many idCont <+> many idEnd
+       <|> symStart <+> many symCont
+
+export
+name : Lexer
+name = baseName <+> many (is '.' <+> baseName)
+
+
+export
+isName : String -> Bool
+isName str =
+  case scan name [] (unpack str) of
+    Just (_, []) => True
+    _            => False
+
+
+public export
+data GenTag = GEN
+
+public export
+NameGen : Type -> Type
+NameGen = StateL GEN NameSuf
+
+
+||| generate a fresh name with the given base
+export
+mn : Has NameGen fs => PBaseName -> Eff fs BaseName
+mn base = do
+  i <- getAt GEN
+  modifyAt GEN S
+  pure $ MN base i
+
+||| generate a fresh binding name with the given base and location `loc`
+export
+mnb : Has NameGen fs => PBaseName -> Loc -> Eff fs BindName
+mnb base loc = pure $ BN !(mn base) loc
+
+export
+fresh : Has NameGen fs => BindName -> Eff fs BindName
+fresh (BN (UN str)   loc) = mnb str loc
+fresh (BN (MN str k) loc) = mnb str loc
+fresh (BN Unused     loc) = mnb "x" loc

lib/Quox/NatExtra.idr

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

lib/Quox/No.idr

@@ -0,0 +1,59 @@
+||| like Data.So, but for False instead.
+||| less messing about with `not` (and constantly rewriting everything)
+||| or `Not` (unfriendly to proof search).
+module Quox.No
+
+import public Data.So
+import public Quox.Decidable
+import Data.Bool
+
+public export
+data No : Pred Bool where
+  Ah : No False
+
+export Uninhabited (No True) where uninhabited _ impossible
+
+export %inline
+soNo : So b -> No b -> Void
+soNo Oh Ah impossible
+
+
+private
+0 orFalse : (a, b : Bool) -> (a || b) = False -> (a = False, b = False)
+orFalse a b eq1 with (a || b) proof eq2
+  orFalse False False Refl | False = (Refl, Refl)
+  orFalse False True  Refl | False = absurd eq2
+  orFalse True  False Refl | False = absurd eq2
+  orFalse True  True  Refl | False = absurd eq2
+
+parameters {0 a, b : Bool}
+  export %inline
+  noOr : No (a || b) -> (No a, No b)
+  noOr n with 0 (a || b) proof eq
+    noOr Ah | False =
+      let 0 eqs = orFalse a b eq in
+      (rewrite fst eqs in Ah, rewrite snd eqs in Ah)
+
+  export %inline
+  noOr1 : No (a || b) -> No a
+  noOr1 = fst . noOr
+
+  export %inline
+  noOr2 : No (a || b) -> No b
+  noOr2 = snd . noOr
+
+
+export infixr 1 `orNo`
+export %inline
+orNo : No a -> No b -> No (a || b)
+orNo Ah Ah = Ah
+
+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

@@ -1,196 +0,0 @@
-||| "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
-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 : Alternative f => OPE m n -> t n -> f (t m)
-
-parameters {auto _ : Tighten t} {auto _ : Alternative f}
-  export
-  tightenInner : {n : Nat} -> m `LTE` n -> t n -> f (t m)
-  tightenInner = tighten . dropInner
-
-  export
-  tightenN : (m : Nat) -> t (m + n) -> f (t n)
-  tightenN m = tighten $ dropInnerN m
-
-  export
-  tighten1 : t (S n) -> f (t n)
-  tighten1 = tightenN 1
-
-
-
--- [todo] can this be done with fancy nats too?
--- with bitmasks sure but that might not be worth the effort
--- [the next day] it probably isn't
-
--- public export
--- data OPE' : Nat -> Nat -> Type where
---   None : OPE' 0 0
---   Drop : OPE' m n -> OPE' m (S n)
---   Keep : OPE' m n -> OPE' (S m) (S n)
--- %name OPE' q
-
-
--- public export %inline
--- drop' : Integer -> Integer
--- drop' n = n * 2
-
--- public export %inline
--- keep' : Integer -> Integer
--- keep' n = 1 + 2 * n
-
--- public export
--- data IsOPE : Integer -> (OPE' m n) -> Type where
---   IsNone : 0 `IsOPE` None
---   IsDrop : (0 _ : m `IsOPE` q) -> drop' m `IsOPE` Drop q
---   IsKeep : (0 _ : m `IsOPE` q) -> keep' m `IsOPE` Keep q
--- %name IsOPE p
-
-
--- public export
--- record OPE m n where
---   constructor MkOPE
---   value  : Integer
---   0 spec : OPE' m n
---   0 prf  : value `IsOPE` spec
---   0 pos  : So (value >= 0)
-
-
--- private
--- 0 idrisPleaseLearnAboutIntegers : {x, y : Integer} -> x = y
--- idrisPleaseLearnAboutIntegers {x, y} = believe_me $ Refl {x}
-
--- private
--- 0 natIntPlus : (m, n : Nat) ->
---                natToInteger (m + n) = natToInteger m + natToInteger n
--- natIntPlus m n = idrisPleaseLearnAboutIntegers
-
--- private
--- 0 shiftTwice : (x : Integer) -> (m, n : Nat) ->
---                x `shiftL` (m + n) = (x `shiftL` m) `shiftL` n
--- shiftTwice x m n = idrisPleaseLearnAboutIntegers
-
--- private
--- 0 shift1 : (x : Integer) -> (x `shiftL` 1) = 2 * x
--- shift1 x = idrisPleaseLearnAboutIntegers
-
--- private
--- 0 intPlusComm : (x, y : Integer) -> (x + y) = (y + x)
--- intPlusComm x y = idrisPleaseLearnAboutIntegers
-
--- private
--- 0 intTimes2Minus1 : (x : Integer) -> 2 * x - 1 = 2 * (x - 1) + 1
--- intTimes2Minus1 x = idrisPleaseLearnAboutIntegers
-
--- private
--- 0 intPosShift : So (x > 0) -> So (x `shiftL` i > 0)
--- intPosShift p = believe_me Oh
-
--- private
--- 0 intNonnegDec : {x : Integer} -> So (x > 0) -> So (x - 1 >= 0)
--- intNonnegDec p = believe_me Oh
-
-
--- private
--- 0 shiftSucc : (x : Integer) -> (n : Nat) ->
---               x `shiftL` S n = 2 * (x `shiftL` n)
--- shiftSucc x n = Calc $
---   |~  x `shiftL` S n
---   ~~  x `shiftL` (n + 1)
---         ...(cong (x `shiftL`) $ sym $ plusCommutative {})
---   ~~  (x `shiftL` n) `shiftL` 1
---         ...(shiftTwice {})
---   ~~  2 * (x `shiftL` n)
---         ...(shift1 {})
-
-
--- private
--- opeIdVal : (n : Nat) -> Integer
--- opeIdVal n = (1 `shiftL` n) - 1
-
--- private
--- 0 opeIdValSpec : (n : Nat) -> Integer
--- opeIdValSpec 0     = 0
--- opeIdValSpec (S n) = keep' $ opeIdValSpec n
-
--- private
--- 0 opeIdValOk :  (n : Nat) -> opeIdVal n = opeIdValSpec n
--- opeIdValOk 0     = Refl
--- opeIdValOk (S n) = Calc $
---   |~  (1 `shiftL` S n) - 1
---   ~~  2 * (1 `shiftL` n) - 1      ...(cong (\x => x - 1) $ shiftSucc {})
---   ~~  2 * (1 `shiftL` n - 1) + 1  ...(intTimes2Minus1 {})
---   ~~  1 + 2 * (1 `shiftL` n - 1)  ...(intPlusComm {})
---   ~~  1 + 2 * opeIdValSpec n      ...(cong (\x => 1 + 2 * x) $ opeIdValOk {})
-
--- private
--- 0 opeIdSpec : (n : Nat) -> OPE' n n
--- opeIdSpec 0     = None
--- opeIdSpec (S n) = Keep $ opeIdSpec n
-
--- private
--- 0 opeIdProof' : (n : Nat) -> opeIdValSpec n `IsOPE` opeIdSpec n
--- opeIdProof' 0     = IsNone
--- opeIdProof' (S n) = IsKeep (opeIdProof' n)
-
--- private
--- 0 opeIdProof : (n : Nat) -> opeIdVal n `IsOPE` opeIdSpec n
--- opeIdProof n = rewrite opeIdValOk n in opeIdProof' n
-
--- export
--- opeId : {n : Nat} -> OPE n n
--- opeId {n} = MkOPE {prf = opeIdProof n, pos = intNonnegDec $ intPosShift Oh, _}

lib/Quox/Parser.idr

@@ -1,159 +1,6 @@
 module Quox.Parser
 
-import Quox.Syntax
+import public Quox.Parser.Syntax
-import Quox.Token
+import public Quox.Parser.Lexer
-import Quox.Lexer
+import public Quox.Parser.Parser
-
+import public Quox.Parser.FromParser
-import Data.Maybe
-import Data.SnocVect
-import Data.SnocList
-import Text.Parser
-
-%default total
-
-
-public export
-Vars : Nat -> Type
-Vars n = SnocVect n String
-
-public export
-Grammar : Bool -> Type -> Type
-Grammar = Core.Grammar () Token
-%hide Core.Grammar
-
-public export
-data Error
-= Lex (Lexer.Error)
-| Parse (List1 (ParsingError Token))
-| Leftover (List BToken)
-%hide Lexer.Error
-
-
-public export
-parseAll : {c : Bool} -> Grammar c a -> List BToken -> Either Error a
-parseAll grm input =
-  case parse grm input of
-       Right (x, [])   => Right x
-       Right (x, rest) => Left $ Leftover rest
-       Left  errs      => Left $ Parse errs
-
-public export
-lexParseAll : {c : Bool} -> Grammar c a -> String -> Either Error a
-lexParseAll grm = lex' >=> parseAll grm
-  where lex' : String -> Either Error (List BToken)
-        lex' = bimap Lex id . lex
-
-
-
-export
-punc : Punc -> Grammar True ()
-punc p = terminal (show p) $ \case
-  P p' => if p == p' then Just () else Nothing
-  _    => Nothing
-
-export
-keyword : Keyword -> Grammar True ()
-keyword k = terminal (show k) $ \case
-  K k' => if k == k' then Just () else Nothing
-  _    => Nothing
-
-export
-between : Punc -> Punc -> Grammar True a -> Grammar True a
-between opener closer inner = punc opener *> inner <* punc closer
-
-export
-parens, squares, braces : Grammar True a -> Grammar True a
-parens  = between LParen  RParen
-squares = between LSquare RSquare
-braces  = between LBrace  RBrace
-
-
-export
-number : Grammar True Nat
-number = terminal "number" $ \case
-  N Zero      => Just 0
-  N One       => Just 1
-  N (Other k) => Just k
-  _           => Nothing
-
-export
-universe : Grammar True Nat
-universe = terminal "universe" $ \case TYPE k => Just k; _ => Nothing
-
-export
-zero, one, omega : Grammar True ()
-zero  = terminal "0" $ \case N Zero  => Just (); _ => Nothing
-one   = terminal "1" $ \case N One   => Just (); _ => Nothing
-omega = terminal "ω" $ \case K Omega => Just (); _ => Nothing
-
-export
-quantity : Grammar True Qty
-quantity = Zero <$ zero <|> One <$ one <|> Any <$ omega
-
-
-find1 : Eq a => SnocVect k a -> a -> Maybe (Var k)
-find1 [<]       y = Nothing
-find1 (sx :< x) y = if x == y then Just VZ else VS <$> find1 sx y
-
-find : Vars k -> Name -> Maybe (Var k)
-find vs (MakeName [<] (UN y)) = find1 vs y
-find _  _                     = Nothing
-
-
-export
-checkAvoid1 : Vars n -> String -> Grammar False ()
-checkAvoid1 avoid y =
-  when (isJust $ find1 avoid y) $
-    fail "wrong type of bound variable: \{show y}"
-
-export
-checkAvoid : Vars n -> Name -> Grammar False ()
-checkAvoid avoid (MakeName [<] (UN y)) = checkAvoid1 avoid y
-checkAvoid _     _                     = pure ()
-
-export
-bound : (what : String) -> (bound : Vars k) -> (avoid : Vars n) ->
-        Grammar True (Var k)
-bound what vs avoid = do
-  x <- terminal "bound \{what} variable" $ \case Name x => Just x; _ => Nothing
-  checkAvoid1 avoid x
-  maybe (fail "not in scope: \{x}") pure $ find1 vs x
-
-export
-sname : Grammar True String
-sname = terminal "simple name" $ \case Name x => pure x; _ => Nothing
-
-export
-qname : Grammar True Name
-qname = do
-  parts <- sepBy1 (punc Dot) sname
-  pure $ MakeName {mods = cast $ init parts, base = UN $ last parts}
-
-export
-nameWith : (bound : Vars k) -> (avoid : Vars n) ->
-           Grammar True (Either (Var k) Name)
-nameWith bound avoid = do
-  y <- qname
-  checkAvoid avoid y
-  pure $ maybe (Right y) Left $ find bound y
-
-
-export
-dimension : (dvars : Vars d) -> (tvars : Vars n) -> Grammar True (Dim d)
-dimension dvars tvars =
-      K Zero <$  zero
-  <|> K One  <$  one
-  <|> B      <$> bound "dimension" {bound = dvars, avoid = tvars}
-
-
-mutual
-  export
-  term : (dvars : Vars d) -> (tvars : Vars n) -> Grammar True (Term d n)
-  term dvars tvars =
-        E <$> squares (elim {dvars, tvars})
-    <|> TYPE . U <$> universe
-
-  export
-  elim : (dvars : Vars d) -> (tvars : Vars n) -> Grammar True (Elim d n)
-  elim dvars tvars =
-        either B F <$> nameWith {bound = tvars, avoid = dvars}

lib/Quox/Parser/FromParser.idr

@@ -0,0 +1,429 @@
+||| 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
+
+
+%hide Typing.Error
+%hide Lexer.Error
+%hide Parser.Error
+
+%default total
+
+
+public export
+data StateTag = NS | SEEN
+
+public export
+FromParserPure : List (Type -> Type)
+FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
+
+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)
+  }
+
+
+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 $
+                   Context.find (\y => y.name == Just x) xs
+
+  private
+  fromName : PName -> m a
+  fromName x = if null x.mods then fromBaseName x.base else f x
+
+export
+fromPDimWith : Has (Except Error) fs =>
+               Context' PatVar d -> PDim -> Eff fs (Dim d)
+fromPDimWith ds (K e loc) = pure $ K e loc
+fromPDimWith ds (V i loc) =
+  fromBaseName (\i => pure $ B i loc)
+               (const $ throw $ DimNotInScope loc i) ds i
+
+private
+avoidDim : Has (Except Error) fs =>
+           Context' PatVar d -> Loc -> PName -> Eff fs Name
+avoidDim ds loc x =
+  fromName (const $ throw $ DimNameInTerm loc x.base) (pure . fromPName) ds x
+
+private
+resolveName : Mods -> Loc -> Name -> Maybe Universe ->
+              Eff FromParserPure (Term d n)
+resolveName ns loc x u =
+  let here = addMods ns x in
+  if isJust $ lookup here !(getAt DEFS) then
+    pure $ FT here (fromMaybe 0 u) loc
+  else do
+    let ns :< _ = ns
+      | _ => throw $ TermNotInScope loc x
+    resolveName ns loc x u
+
+export
+fromPatVar : PatVar -> BindName
+fromPatVar (Unused loc) = BN Unused loc
+fromPatVar (PV x   loc) = BN (UN x) loc
+
+export
+fromPQty : PQty -> Qty
+fromPQty (PQ q _) = q
+
+export
+fromPTagVal : PTagVal -> TagVal
+fromPTagVal (PT t _) = t
+
+
+private
+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
+
+  free : PName -> Eff FromParserPure (Term d n)
+  free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
+
+mutual
+  export
+  fromPTermWith : Context' PatVar d -> Context' PatVar n ->
+                  PTerm -> Eff FromParserPure (Term d n)
+  fromPTermWith ds ns t0 = case t0 of
+    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
+        <*> fromPTermTScope ds ns [< x] t
+        <*> pure loc
+
+    Lam x s loc =>
+      Lam <$> fromPTermTScope ds ns [< x] s <*> pure loc
+
+    App s t loc =>
+      map E $ App
+        <$> fromPTermElim ds ns s
+        <*> fromPTermWith ds ns t
+        <*> pure loc
+
+    Sig x s t loc =>
+      Sig <$> fromPTermWith ds ns s
+          <*> fromPTermTScope ds ns [< x] t
+          <*> pure loc
+
+    Pair s t loc =>
+      Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t <*> pure loc
+
+    Case pi pair (r, ret) (CasePair (x, y) body _) loc =>
+      map E $ CasePair (fromPQty pi)
+        <$> fromPTermElim ds ns pair
+        <*> fromPTermTScope ds ns [< r] ret
+        <*> 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
+        <*> pure loc
+
+    NAT loc => pure $ NAT loc
+    Nat n loc => pure $ Nat n loc
+    Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|]
+
+    STRING loc => pure $ STRING loc
+    Str str loc => pure $ Str str loc
+
+    Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
+      map E $ CaseNat (fromPQty pi) (fromPQty pi')
+        <$> fromPTermElim ds ns nat
+        <*> fromPTermTScope ds ns [< r] ret
+        <*> fromPTermWith ds ns zer
+        <*> 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
+
+    Tag str loc => pure $ Tag str loc
+
+    Eq (i, ty) s t loc =>
+      Eq <$> fromPTermDScope ds ns [< i] ty
+         <*> fromPTermWith ds ns s
+         <*> fromPTermWith ds ns t
+         <*> pure loc
+
+    DLam i s loc =>
+      DLam <$> fromPTermDScope ds ns [< i] s <*> pure loc
+
+    DApp s p loc =>
+      map E $ DApp
+        <$> fromPTermElim ds ns s
+        <*> fromPDimWith ds p
+        <*> pure loc
+
+    BOX q ty loc => BOX (fromPQty q) <$> fromPTermWith ds ns ty <*> pure loc
+
+    Box val loc => Box <$> fromPTermWith ds ns val <*> pure loc
+
+    Case pi box (r, ret) (CaseBox b body _) loc =>
+      map E $ CaseBox (fromPQty pi)
+        <$> fromPTermElim ds ns box
+        <*> fromPTermTScope ds ns [< r] ret
+        <*> fromPTermTScope ds ns [< b] body
+        <*> pure loc
+
+    V x u loc => fromV ds ns x u loc
+
+    Ann s a loc =>
+      map E $ Ann
+        <$> fromPTermWith ds ns s
+        <*> fromPTermWith ds ns a
+        <*> pure loc
+
+    Coe (i, ty) p q val loc =>
+      map E $ Coe
+        <$> fromPTermDScope ds ns [< i] ty
+        <*> fromPDimWith ds p
+        <*> fromPDimWith ds q
+        <*> fromPTermWith ds ns val
+        <*> pure loc
+
+    Comp (i, ty) p q val r (j0, val0) (j1, val1) loc =>
+      map E $ CompH'
+        <$> fromPTermDScope ds ns [< i] ty
+        <*> fromPDimWith ds p
+        <*> fromPDimWith ds q
+        <*> fromPTermWith ds ns val
+        <*> fromPDimWith ds r
+        <*> fromPTermDScope ds ns [< j0] val0
+        <*> 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 ->
+                      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
+
+  private
+  fromPTermElim : Context' PatVar d -> Context' PatVar n ->
+                  PTerm -> Eff FromParserPure (Elim d n)
+  fromPTermElim ds ns e =
+    case !(fromPTermWith ds ns e) of
+      E e => pure e
+      t   => let ctx = MkNameContexts (map fromPatVar ds) (map fromPatVar ns) in
+             throw $ AnnotationNeeded t.loc ctx t
+
+  private
+  fromPTermTScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
+                    SnocVect s PatVar -> PTerm ->
+                    Eff FromParserPure (ScopeTermN s d n)
+  fromPTermTScope ds ns xs t =
+    if all isUnused xs then
+      SN <$> fromPTermWith ds ns t
+    else
+      SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
+
+  private
+  fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
+                    SnocVect s PatVar -> PTerm ->
+                    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
+    else
+      SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
+
+
+export %inline
+fromPTerm : PTerm -> Eff FromParserPure (Term 0 0)
+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
+
+export
+fromPBaseNameNS : Has (StateL NS Mods) fs => PBaseName -> Eff fs 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)
+
+
+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
+
+export covering
+fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
+fromPDecl (PDef def) =
+  maybeFail def.fail def.loc $ singleton <$> fromPDef def
+fromPDecl (PNs  ns)  =
+  maybeFail ns.fail ns.loc $
+  localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
+fromPDecl (PPrag prag) =
+  case prag of
+    PLogPush p _ => Log.push p $> []
+    PLogPop    _ => Log.pop    $> []
+
+mutual
+  export covering
+  loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
+  loadProcessFile loc file =
+    case !(loadFile loc file) of
+      Just tl => concat <$> traverse fromPTopLevel tl
+      Nothing => pure []
+
+  ||| populates the `defs` field of the state
+  export covering
+  fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
+  fromPTopLevel (PD    decl)     = lift $ fromPDecl decl
+  fromPTopLevel (PLoad file loc) = loadProcessFile loc file

lib/Quox/Parser/FromParser/Error.idr

@@ -0,0 +1,146 @@
+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.(<++>)
+
+
+public export
+TypeError, LexError, ParseError : Type
+TypeError = Typing.Error
+LexError = Lexer.Error
+ParseError = Parser.Error
+%hide Typing.Error
+%hide Lexer.Error
+%hide Parser.Error
+
+public export
+data Error =
+    AnnotationNeeded Loc (NameContexts d n) (Term d n)
+  | DuplicatesInEnumType Loc (List TagVal)
+  | DuplicatesInEnumCase Loc (List TagVal)
+  | TermNotInScope Loc Name
+  | DimNotInScope Loc PBaseName
+  | QtyNotGlobal Loc Qty
+  | DimNameInTerm Loc PBaseName
+  | DisplacedBoundVar Loc PName
+  | WrapTypeError TypeError
+  | AlreadyExists Loc Name
+  | LoadError Loc FilePath FileError
+  | ExpectedFail Loc
+  | SchemeOnNamespace Loc Mods
+  | MainOnNamespace Loc Mods
+  | WrongFail String Error Loc
+  | WrapParseError String ParseError
+
+
+export
+prettyLexError : {opts : _} -> String -> LexError -> Eff Pretty (Doc opts)
+prettyLexError file (Err reason line col char) = do
+  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"
+    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
+prettyParseError1 : {opts : _} -> String -> ParsingError _ ->
+                    Eff Pretty (Doc opts)
+prettyParseError1 file (Error msg Nothing) =
+  pure $ text msg
+prettyParseError1 file (Error msg (Just bounds)) =
+  pure $ vappend !(prettyLoc $ makeLoc file bounds) (text msg)
+
+export
+prettyParseError : {opts : _} -> String -> ParseError ->
+                   Eff Pretty (Doc opts)
+prettyParseError file (LexError err) =
+  pure $ vsep ["lexical error:", !(prettyLexError file err)]
+prettyParseError file (ParseError errs) =
+  map (vsep . ("parse error:" ::)) $
+    traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
+
+
+parameters {opts : LayoutOpts} (showContext : Bool)
+  export
+  prettyError : Error -> Eff Pretty (Doc opts)
+  prettyError (AnnotationNeeded loc ctx tm) =
+    [|vappend (prettyLoc loc)
+        (hangD "type annotation needed on"
+               !(prettyTerm ctx.dnames ctx.tnames tm))|]
+    -- [todo] print the original PTerm instead
+
+  prettyError (DuplicatesInEnumType loc tags) =
+    [|vappend (prettyLoc loc)
+        (hangD "duplicate tags in enum type" !(prettyEnum tags))|]
+
+  prettyError (DuplicatesInEnumCase loc tags) =
+    [|vappend (prettyLoc loc)
+        (hangD "duplicate arms in enum case" !(prettyEnum tags))|]
+
+  prettyError (DimNotInScope loc i) =
+    [|vappend (prettyLoc loc)
+        (pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]
+
+  prettyError (TermNotInScope loc x) =
+    [|vappend (prettyLoc loc)
+        (pure $ hsep ["term variable", !(prettyFree x), "not in scope"])|]
+
+  prettyError (QtyNotGlobal loc pi) = pure $
+    vappend !(prettyLoc loc)
+      (sep ["quantity" <++> !(prettyQty pi),
+            "can't be used on a top level declaration"])
+
+  prettyError (DimNameInTerm loc i) = pure $
+    vappend !(prettyLoc loc)
+      (sep ["dimension" <++> !(hl DVar $ text i),
+            "used in a term context"])
+
+  prettyError (DisplacedBoundVar loc x) = pure $
+    vappend !(prettyLoc loc)
+      (sep ["local variable" <++> !(hl TVar $ text $ toDotsP x),
+            "cannot be displaced"])
+
+  prettyError (WrapTypeError err) =
+    Typing.prettyError showContext $ trimContext 2 err
+
+  prettyError (AlreadyExists loc name) = 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,
+          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

@@ -0,0 +1,342 @@
+module Quox.Parser.Lexer
+
+import Quox.CharExtra
+import Quox.NatExtra
+import Quox.Name
+import Data.String.Extra
+import Data.SortedMap
+import public Data.String -- for singleton to reduce in IsReserved
+import public Data.List.Elem
+import public Text.Lexer
+import public Text.Lexer.Tokenizer
+import Derive.Prelude
+%hide TT.Name
+
+
+%default total
+%language ElabReflection
+
+
+||| @ Reserved reserved token
+||| @ Name name, possibly qualified
+||| @ Nat nat literal
+||| @ Str string literal
+||| @ Tag tag literal
+||| @ TYPE "Type" or "★" with ascii nat directly after
+||| @ Sup superscript or ^ number (displacement, or universe for ★)
+public export
+data Token =
+    Reserved String
+  | Name PName
+  | Nat Nat
+  | Str String
+  | Tag String
+  | TYPE Nat
+  | 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
+public export
+data ExtToken = Skip | Invalid String String | T Token
+%runElab derive "ExtToken" [Eq, Ord, Show]
+
+
+public export
+data ErrorReason =
+    NoRuleApply
+  | ComposeNotClosing (Int, Int) (Int, Int)
+  | Other String
+%runElab derive "ErrorReason" [Eq, Ord, Show]
+
+public export
+record Error where
+  constructor Err
+  reason    : ErrorReason
+  line, col : Int
+  ||| `Nothing` if the error is at the end of the input
+  char      : Maybe Char
+%runElab derive "StopReason" [Eq, Ord, Show]
+%runElab derive "Error"      [Eq, Ord, Show]
+
+
+private
+skip : Lexer -> Tokenizer ExtToken
+skip t = match t $ const Skip
+
+private
+tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
+tmatch t f = match t (T . f)
+
+
+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"
+
+private
+string : Tokenizer ExtToken
+string = match stringLit $ fromStringLit Str
+
+
+%hide binLit
+%hide octLit
+%hide hexLit
+
+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
+
+
+private
+tag : Tokenizer ExtToken
+tag = tmatch (is '\'' <+> name)      (Tag . drop 1)
+  <|>  match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1)
+
+
+private %inline
+fromSup : Char -> Char
+fromSup c = case c of
+  '⁰' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '⁴' => '4'
+  '⁵' => '5'; '⁶' => '6'; '⁷' => '7'; '⁸' => '8'; '⁹' => '9'; _ => c
+
+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
+private
+universe : Tokenizer ExtToken
+universe = universeWith "★" <|> universeWith "Type" where
+  universeWith : String -> Tokenizer ExtToken
+  universeWith pfx =
+    let len = length pfx in
+    tmatch (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)
+
+
+private %inline
+choice : (xs : List (Tokenizer a)) -> (0 _ : NonEmpty xs) => Tokenizer a
+choice (t :: ts) = foldl (\a, b => a <|> b) t ts
+
+
+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
+  public export
+  data Reserved1 = Word String | Sym String | Punc String
+  %runElab derive "Reserved1" [Eq, Ord, Show]
+
+  ||| description of a token that might have unicode & ascii-only aliases
+  public export
+  data Reserved = Only Reserved1 | Or Reserved1 Reserved1
+  %runElab derive "Reserved" [Eq, Ord, Show]
+
+  public export
+  Sym1, Word1, Punc1 : String -> Reserved
+  Sym1  = Only . Sym
+  Word1 = Only . Word
+  Punc1 = Only . Punc
+
+public export
+resString1 : Reserved1 -> String
+resString1 (Punc x) = x
+resString1 (Word w) = w
+resString1 (Sym  s) = s
+
+||| return the representative string for a token description. if there are
+||| two, then it's the first one, which should be the full-unicode one
+public export
+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 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
+
+||| match a reserved token
+export
+resTokenizer : Reserved -> Tokenizer ExtToken
+resTokenizer (Only r)   = resTokenizer1 r (resString1 r)
+resTokenizer (r `Or` s) =
+  resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
+
+||| reserved words & symbols.
+||| the tokens recognised by ``a `Or` b`` will be `Reserved a`.
+||| e.g. `=>` in the input (if not part of a longer name)
+||| will be returned as `Reserved "⇒"`.
+public export
+reserved : List Reserved
+reserved =
+  [Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}",
+   Punc1 ",", Punc1 ";", Punc1 "#[", Punc1 "#![",
+   Sym1 "@",
+   Sym1 ":",
+   Sym "⇒" `Or` Sym "=>",
+   Sym "→" `Or` Sym "->",
+   Sym "×" `Or` Sym "**",
+   Sym "≡" `Or` Sym "==",
+   Sym "∷" `Or` Sym "::",
+   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",
+   Word "δ" `Or` Word "dfun",
+   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
+
+export
+tokens : Tokenizer ExtToken
+tokens = choice $
+  map skip [pred isWhitespace,
+            lineComment (exact "--" <+> reject symCont),
+            blockComment (exact "{-") (exact "-}")] <+>
+  [universe] <+>  -- Type<i> takes precedence over bare Type
+  map resTokenizer reserved <+>
+  [sup, nat, string, tag, name]
+
+export
+check : Alternative f =>
+        WithBounds ExtToken -> Either Error (f (WithBounds Token))
+check (MkBounded val irr bounds@(MkBounds line col _ _)) = case val of
+  Skip            => Right empty
+  T tok           => Right $ pure $ MkBounded tok irr bounds
+  Invalid msg tok => Left  $ Err (Other msg) line col (index 0 tok)
+
+export
+toErrorReason : StopReason -> Maybe ErrorReason
+toErrorReason EndInput                = Nothing
+toErrorReason NoRuleApply             = Just NoRuleApply
+toErrorReason (ComposeNotClosing s e) = Just $ ComposeNotClosing s e
+
+export
+lex : String -> Either Error (List (WithBounds Token))
+lex str =
+  let (res, reason, line, col, str) = lex tokens str in
+  case toErrorReason reason of
+    Nothing => concatMap check res @{MonoidApplicative}
+    Just e  => Left $ Err {reason = e, line, col, char = index 0 str}

lib/Quox/Parser/LoadFile.idr

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

lib/Quox/Parser/Parser.idr

@@ -0,0 +1,886 @@
+module Quox.Parser.Parser
+
+import public Quox.Parser.Lexer
+import public Quox.Parser.Syntax
+
+import Data.Bool
+import Data.Fin
+import Data.Vect
+import public Text.Parser
+import Derive.Prelude
+
+%language ElabReflection
+%default total
+
+
+public export
+0 Grammar : Bool -> Type -> Type
+Grammar = Core.Grammar () Token
+%hide Core.Grammar
+
+
+public export
+data Error =
+    LexError   Lexer.Error
+  | ParseError (List1 (ParsingError Token))
+%hide Lexer.Error
+%runElab derive "Error" [Show]
+
+
+export
+lexParseWith : {c : Bool} -> Grammar c a -> String -> Either Error a
+lexParseWith grm input = do
+  toks <- mapFst LexError $ lex input
+  bimap ParseError fst $ parse (grm <* eof) toks
+
+export
+withLoc : {c : Bool} -> FileName -> (Grammar c (Loc -> a)) -> Grammar c a
+withLoc fname act = bounds act <&> \res =>
+  if res.isIrrelevant then res.val noLoc
+  else res.val $ makeLoc fname res.bounds
+
+export
+defLoc : FileName -> (Loc -> a) -> Grammar False a
+defLoc fname f = position <&> f . makeLoc fname
+
+export
+unused : FileName -> Grammar False PatVar
+unused fname = defLoc fname Unused
+
+
+||| reserved token, like punctuation or keywords etc
+export
+res : (str : String) -> (0 _ : IsReserved str) => Grammar True ()
+res str = terminal "expected \"\{str}\"" $ guard . (== Reserved str)
+
+||| optional reserved token, e.g. trailing comma
+export
+optRes : (str : String) -> (0 _ : IsReserved str) => Grammar False ()
+optRes str = ignore $ optional $ res str
+
+||| reserved token, then commit
+export
+resC : (str : String) -> (0 _ : IsReserved str) => Grammar True ()
+resC str = do res str; commit
+
+||| reserved token or fatal error
+export
+needRes : (str : String) -> (0 _ : IsReserved str) => Grammar True ()
+needRes str = resC str <|> fatalError "expected \"\{str}\""
+
+
+private
+terminalMatchN_ : String -> List (TTImp, TTImp) -> Elab (Grammar True a)
+terminalMatchN_ what matches = do
+  func <- check $ lam (lambdaArg `{x}) $
+    iCase `(x) implicitFalse $
+    map (\(l, r) => patClause l `(Just ~(r))) matches ++
+      [patClause `(_) `(Nothing)]
+  pure $ terminal "expected \{what}" func
+
+private %macro
+terminalMatchN : String -> List (TTImp, TTImp) -> Elab (Grammar True a)
+terminalMatchN = terminalMatchN_
+
+private %macro
+terminalMatch : String -> TTImp -> TTImp -> Elab (Grammar True a)
+terminalMatch what l r = terminalMatchN_ what [(l, r)]
+
+||| tag without leading `'`
+export
+bareTag : Grammar True TagVal
+bareTag = terminalMatchN "bare tag"
+  [(`(Name t), `(toDotsP t)), (`(Str s), `(s))]
+
+||| tag with leading quote
+export
+tag : Grammar True TagVal
+tag = terminalMatch "tag" `(Tag t) `(t)
+
+||| natural number
+export
+nat : Grammar True Nat
+nat = terminalMatch "natural number" `(Nat n) `(n)
+
+||| string literal
+export
+strLit : Grammar True String
+strLit = terminalMatch "string literal" `(Str s) `(s)
+
+||| single-token universe, like ★0 or Type1
+export
+universeTok : Grammar True Universe
+universeTok = terminalMatch "universe" `(TYPE u) `(u)
+
+export
+super : Grammar True Nat
+super = terminalMatch "superscript number or '^'" `(Sup n) `(n)
+
+||| possibly-qualified name
+export
+qname : Grammar True PName
+qname = terminalMatch "name" `(Name n) `(n)
+
+||| unqualified name
+export
+baseName : Grammar True PBaseName
+baseName = terminalMatch "unqualified name" `(Name (MkPName [<] b)) `(b)
+
+||| dimension constant (0 or 1)
+export
+dimConst : Grammar True DimConst
+dimConst = terminalMatchN "dimension constant"
+  [(`(Nat 0), `(Zero)), (`(Nat 1), `(One))]
+
+||| quantity (0, 1, or ω)
+export
+qtyVal : Grammar True Qty
+qtyVal = terminalMatchN "quantity"
+  [(`(Nat 0), `(Zero)), (`(Nat 1), `(One)), (`(Reserved "ω"), `(Any))]
+
+
+||| optional superscript number
+export
+displacement : Grammar False (Maybe Universe)
+displacement = optional super
+
+||| quantity (0, 1, or ω)
+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
+patVar : FileName -> Grammar True PatVar
+patVar fname = withLoc fname $
+  [|PV baseName|] <|> Unused <$ res "_"
+
+
+||| dimension (without `@` prefix)
+export
+dim : FileName -> Grammar True PDim
+dim fname = withLoc fname $ [|K dimConst|] <|> [|V baseName|]
+
+||| dimension argument (with @)
+export
+dimArg : FileName -> Grammar True PDim
+dimArg fname = do resC "@"; mustWork $ dim fname
+
+
+delim : (o, c : String) -> (0 _ : IsReserved o) => (0 _ : IsReserved c) =>
+        {k : Bool} -> Grammar k a -> Grammar True a
+delim o c p = resC o *> p <* needRes c
+
+-- this stuff is Like This (rather than just being delim + sepEndBy{1})
+-- so that it checks for the close bracket before trying another list element,
+-- giving (imo) a better error
+parameters (o, c, s : String)
+           {auto 0 _ : IsReserved o} {auto 0 _ : IsReserved c}
+           {auto 0 _ : IsReserved s}
+           (p : Grammar True a)
+  private
+  dsBeforeDelim, dsAfterDelim : Grammar True (List a)
+  dsBeforeDelim = [] <$ resC c <|> resC s *> assert_total dsAfterDelim
+  dsAfterDelim  = [] <$ resC c <|> [|p :: assert_total dsBeforeDelim|]
+
+  export
+  delimSep1 : Grammar True (List1 a)
+  delimSep1 = resC o *> [|p ::: dsBeforeDelim|]
+
+  export
+  delimSep : Grammar True (List a)
+  delimSep = resC o *> dsAfterDelim
+
+
+||| enum type, e.g. `{a, b, c.d, "e f g"}`
+export
+enumType : Grammar True (List TagVal)
+enumType = delimSep "{" "}" "," bareTag
+
+||| e.g. `case1` or `case 1.`
+export
+caseIntro : FileName -> Grammar True PQty
+caseIntro fname =
+      withLoc fname (PQ Zero <$ res "case0")
+  <|> withLoc fname (PQ One  <$ res "case1")
+  <|> withLoc fname (PQ Any  <$ res "caseω")
+  <|> do resC "case"
+         qty fname <* needRes "." <|> defLoc fname (PQ One)
+
+export
+qtyPatVar : FileName -> Grammar True (PQty, PatVar)
+qtyPatVar fname =
+      [|(,) (qty fname) (needRes "." *> patVar fname)|]
+  <|> [|(,) (defLoc fname $ PQ One) (patVar fname)|]
+
+
+export
+ptag : FileName -> Grammar True PTagVal
+ptag fname = withLoc fname $ [|PT tag|]
+
+public export
+data PCasePat =
+    PPair PatVar PatVar Loc
+  | PTag  PTagVal Loc
+  | PZero Loc
+  | PSucc PatVar PQty PatVar Loc
+  | PBox  PatVar Loc
+%runElab derive "PCasePat" [Eq, Ord, Show]
+
+export
+Located PCasePat where
+  (PPair _ _   loc).loc = loc
+  (PTag  _     loc).loc = loc
+  (PZero       loc).loc = loc
+  (PSucc _ _ _ loc).loc = loc
+  (PBox  _     loc).loc = loc
+
+||| either `zero` or `0`
+export
+zeroPat : Grammar True ()
+zeroPat = resC "zero" <|> terminal "expected '0'" (guard . (== Nat 0))
+
+export
+casePat : FileName -> Grammar True PCasePat
+casePat fname = withLoc fname $
+      delim "(" ")" [|PPair (patVar fname) (needRes "," *> patVar fname)|]
+  <|> [|PTag (ptag fname)|]
+  <|> PZero <$ zeroPat
+  <|> do p  <- resC "succ" *> patVar fname
+         ih <- resC "," *> qtyPatVar fname
+           <|> [|(,) (defLoc fname $ PQ Zero) (unused fname)|]
+         pure $ PSucc p (fst ih) (snd ih)
+  <|> delim "[" "]" [|PBox (patVar fname)|]
+  <|> fatalError "invalid pattern"
+
+export
+term : FileName -> Grammar True PTerm
+-- defined after all the subterm parsers
+
+||| box term `[t]` or type `[π.A]`
+export
+boxTerm : FileName -> Grammar True PTerm
+boxTerm fname = withLoc fname $ do
+  res "["; commit
+  q <- optional $ qty fname <* res "."
+  t <- mustWork $ assert_total term fname <* needRes "]"
+  pure $ maybe (Box t) (\q => BOX q t) q
+
+||| tuple term like `(a, b)`, or parenthesised single term.
+||| allows terminating comma. more than two elements are nested on the right:
+||| `(a, b, c, d) = (a, (b, (c, d)))`.
+export
+tupleTerm : FileName -> Grammar True PTerm
+tupleTerm fname = withLoc fname $ do
+  terms <- delimSep1 "(" ")" "," $ assert_total term fname
+  pure $ \loc => foldr1 (\s, t => Pair s t loc) terms
+
+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 `}`.
+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|]
+  <|> [|V qname displacement|]
+  <|> const <$> caseTerm fname
+  <|> const <$> tupleTerm fname
+
+export
+properTypeLine : FileName -> Grammar True (PatVar, PTerm)
+properTypeLine fname = do
+  resC "("
+  i <- patVar fname <* resC "⇒" <|> unused fname
+  t <- assert_total term fname <* needRes ")"
+  pure (i, t)
+
+export
+typeLine : FileName -> Grammar True (PatVar, PTerm)
+typeLine fname =
+  properTypeLine fname <|> [|(,) (unused fname) (termArg fname)|]
+
+||| optionally, two dimension arguments. if absent default to `@0 @1`
+private
+optDirection : FileName -> Grammar False (PDim, PDim)
+optDirection fname = withLoc fname $ do
+  dims <- optional [|(,) (dimArg fname) (dimArg fname)|]
+  pure $ \loc => fromMaybe (K Zero loc, K One loc) dims
+
+export
+coeTerm : FileName -> Grammar True PTerm
+coeTerm fname = withLoc fname $ do
+  resC "coe"
+  mustWork $ do
+    line   <- typeLine fname
+    (p, q) <- optDirection fname
+    val    <- termArg fname
+    pure $ Coe line p q val
+
+public export
+CompBranch : Type
+CompBranch = (DimConst, PatVar, PTerm)
+
+export
+compBranch : FileName -> Grammar True CompBranch
+compBranch fname =
+  [|(,,) dimConst (patVar fname) (needRes "⇒" *> assert_total term fname)|]
+
+private
+checkCompTermBody : (PatVar, PTerm) -> PDim -> PDim -> PTerm -> PDim ->
+                    CompBranch -> CompBranch -> Bounds ->
+                    Grammar False (Loc -> PTerm)
+checkCompTermBody a p q s r (e0, s0) (e1, s1) bounds =
+  case (e0, e1) of
+    (Zero, One)  => pure $ Comp a p q s r s0 s1
+    (One,  Zero) => pure $ Comp a p q s r s1 s0
+    (_,    _)    =>
+      fatalLoc bounds "body of 'comp' needs one 0 case and one 1 case"
+
+export
+compTerm : FileName -> Grammar True PTerm
+compTerm fname = withLoc fname $ do
+  resC "comp"
+  mustWork $ do
+    a <- typeLine fname
+    (p, q) <- optDirection fname
+    s <- termArg fname; r <- dimArg fname
+    bodyStart <- bounds $ needRes "{"
+    s0 <- compBranch fname; needRes ";"
+    s1 <- compBranch fname; optRes  ";"
+    bodyEnd <- bounds $ needRes "}"
+    let body = bounds $ mergeBounds bodyStart bodyEnd
+    checkCompTermBody a p q s r s0 s1 body
+
+export
+splitUniverseTerm : FileName -> Grammar True PTerm
+splitUniverseTerm fname =
+  withLoc fname $ resC "★" *> [|TYPE $ option 0 $ nat <|> super|]
+  -- some of this looks redundant, but when parsing a non-atomic term
+  -- this branch will be taken first
+
+export
+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
+
+||| a dimension argument with an `@` prefix, or
+||| a term argument with no prefix
+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
+
+||| application term `f x @y z`, or other terms that look like application
+||| like `succ` or `coe`.
+export
+appTerm : FileName -> Grammar True PTerm
+appTerm fname =
+      coeTerm fname
+  <|> compTerm fname
+  <|> splitUniverseTerm fname
+  <|> eqTerm fname
+  <|> succTerm fname
+  <|> fstTerm fname
+  <|> sndTerm fname
+  <|> normalAppTerm fname
+
+export
+infixEqTerm : FileName -> Grammar True PTerm
+infixEqTerm fname = withLoc fname $ do
+  l <- appTerm fname; commit
+  rest <- optional $ res "≡" *>
+    [|(,) (assert_total term fname) (needRes ":" *> appTerm fname)|]
+  let u = Unused $ onlyStart l.loc
+  pure $ \loc => maybe l (\rest => Eq (u, snd rest) l (fst rest) loc) rest
+
+export
+annTerm : FileName -> Grammar True PTerm
+annTerm fname = withLoc fname $ do
+  tm <- infixEqTerm fname; commit
+  ty <- optional $ res "∷" *> assert_total term fname
+  pure $ \loc => maybe tm (\ty => Ann tm ty loc) ty
+
+export
+lamTerm : FileName -> Grammar True PTerm
+lamTerm fname = withLoc fname $ do
+  k <- DLam <$ res "δ" <|> Lam <$ res "λ"
+  mustWork $ do
+    xs   <- some $ patVar fname;     needRes "⇒"
+    body <- assert_total term fname; commit
+    pure $ \loc => foldr (\x, s => k x s loc) body xs
+
+-- [todo] fix the backtracking in e.g. (F x y z × B)
+export
+properBinders : FileName -> Grammar True (List1 PatVar, PTerm)
+properBinders fname = assert_total $ do
+  -- putting assert_total directly on `term`, in this one function,
+  -- doesn't work. i cannot tell why
+  res "("
+  xs <- some $ patVar fname; resC ":"
+  t  <- term fname;          needRes ")"
+  pure (xs, t)
+
+export
+sigmaTerm : FileName -> Grammar True PTerm
+sigmaTerm fname =
+      (properBinders fname >>= continueDep)
+  <|> (annTerm fname       >>= continueNondep)
+where
+  continueDep : (List1 PatVar, PTerm) -> Grammar True PTerm
+  continueDep (names, fst) = withLoc fname $ do
+    snd <- needRes "×" *> sigmaTerm fname
+    pure $ \loc => foldr (\x, snd => Sig x fst snd loc) snd names
+
+  cross : PTerm -> PTerm -> PTerm
+  cross l r = let loc = extend' l.loc r.loc.bounds in
+              Sig (Unused $ onlyStart l.loc) l r loc
+
+  continueNondep : PTerm -> Grammar False PTerm
+  continueNondep fst = do
+    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
+
+
+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
+
+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
+
+-- term : FileName -> Grammar True PTerm
+term fname = lamTerm 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
+
+export
+namespace_ : FileName -> List PAttr -> Grammar True PNamespace
+namespace_ fname attrs = withLoc fname $ do
+  ns    <- resC "namespace" *> nsname; needRes "{"
+  decls <- nsInner
+  either fatalError pure $ mkPNamespace attrs ns decls
+where
+  nsInner : Grammar True (List PDecl)
+  nsInner = [] <$ resC "}"
+        <|> [|(assert_total decl fname <* commit) :: assert_total nsInner|]
+
+export
+declBody : FileName -> List PAttr -> Grammar True PDecl
+declBody fname attrs =
+  [|PDef $ definition fname attrs|] <|> [|PNs $ namespace_ fname attrs|]
+
+-- decl : FileName -> Grammar True PDecl
+decl fname =
+      (attrList fname >>= declBody fname)
+  <|> PPrag <$> pragma fname
+
+export
+load : FileName -> Grammar True PTopLevel
+load fname = withLoc fname $
+  resC "load" *> mustWork [|PLoad strLit|] <* optRes ";"
+
+export
+topLevel : FileName -> Grammar True PTopLevel
+topLevel fname = load fname <|> [|PD $ decl fname|]
+
+export
+input : FileName -> Grammar False PFile
+input fname = [] <$ eof
+          <|> [|(topLevel fname <* commit) :: assert_total input fname|]
+
+export
+lexParseTerm : FileName -> String -> Either Error PTerm
+lexParseTerm = lexParseWith . term
+
+export
+lexParseInput : FileName -> String -> Either Error PFile
+lexParseInput = lexParseWith . input

lib/Quox/Parser/Syntax.idr

@@ -0,0 +1,251 @@
+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
+
+%default total
+%language ElabReflection
+
+
+public export
+data PatVar = Unused Loc | PV PBaseName Loc
+%name PatVar v
+%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
+
+export %inline
+Located PatVar where
+  (Unused loc).loc = loc
+  (PV _   loc).loc = loc
+
+export
+(.name) : PatVar -> Maybe PBaseName
+(Unused _).name = Nothing
+(PV nm  _).name = Just nm
+
+export
+isUnused : PatVar -> Bool
+isUnused (Unused {}) = True
+isUnused _           = False
+
+
+public export
+record PQty where
+  constructor PQ
+  val  : Qty
+  loc_ : Loc
+%name PQty qty
+%runElab derive "PQty" [Eq, Ord, Show, PrettyVal]
+
+export %inline Located PQty where q.loc = q.loc_
+
+namespace PDim
+  public export
+  data PDim = K DimConst Loc | V PBaseName Loc
+  %name PDim p, q
+  %runElab derive "PDim" [Eq, Ord, Show, PrettyVal]
+
+export %inline
+Located PDim where
+  (K _ loc).loc = loc
+  (V _ loc).loc = loc
+
+public export
+data PTagVal = PT TagVal Loc
+%name PTagVal tag
+%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
+
+
+namespace PTerm
+  mutual
+    ||| terms out of the parser with BVs and bidirectionality still tangled up
+    public export
+    data PTerm =
+        TYPE Universe Loc
+
+      | IOState Loc
+
+      | Pi PQty PatVar PTerm PTerm Loc
+      | Lam PatVar PTerm Loc
+      | App PTerm PTerm Loc
+
+      | 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
+
+      | Eq (PatVar, PTerm) PTerm PTerm Loc
+      | 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
+
+      | BOX PQty PTerm Loc
+      | Box PTerm Loc
+
+      | V PName (Maybe Universe) Loc
+      | Ann PTerm PTerm Loc
+
+      | 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
+    data PCaseBody =
+        CasePair (PatVar, PatVar) PTerm Loc
+      | CaseEnum (List (PTagVal, PTerm)) Loc
+      | CaseNat PTerm (PatVar, PQty, PatVar, PTerm) Loc
+      | CaseBox PatVar PTerm Loc
+    %name PCaseBody body
+
+  public export %inline
+  Zero : Loc -> PTerm
+  Zero = Nat 0
+
+%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal]
+
+export %inline
+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
+
+export %inline
+Located PCaseBody where
+  (CasePair _ _ loc).loc = loc
+  (CaseEnum _   loc).loc = loc
+  (CaseNat  _ _ loc).loc = loc
+  (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
+%name PDefinition def
+%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
+
+export %inline Located PDefinition where def.loc = def.loc_
+
+public export
+data PPragma =
+    PLogPush (List Log.PushArg) Loc
+  | PLogPop  Loc
+%name PPragma prag
+%runElab derive "PPragma" [Eq, Ord, Show, PrettyVal]
+
+export %inline
+Located PPragma where
+  (PLogPush _ loc).loc = loc
+  (PLogPop    loc).loc = loc
+
+mutual
+  public export
+  record PNamespace where
+    constructor MkPNamespace
+    name  : Mods
+    decls : List PDecl
+    fail  : PFail
+    loc_  : Loc
+  %name PNamespace ns
+
+  public export
+  data PDecl =
+      PDef  PDefinition
+    | PNs   PNamespace
+    | PPrag PPragma
+  %name PDecl decl
+%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
+
+export %inline Located PNamespace where ns.loc = ns.loc_
+
+export %inline
+Located PDecl where
+  (PDef  d).loc    = d.loc
+  (PNs   ns).loc   = ns.loc
+  (PPrag prag).loc = prag.loc
+
+public export
+data PTopLevel = PD PDecl | PLoad String Loc
+%name PTopLevel t
+%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal]
+
+export %inline
+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

lib/Quox/Pretty.idr

@@ -1,16 +1,18 @@
 module Quox.Pretty
 
+import Quox.Loc
 import Quox.Name
 
-import public Text.PrettyPrint.Prettyprinter.Doc
+import Control.Monad.ST.Extra
-import Text.PrettyPrint.Prettyprinter.Render.String
+import public Text.PrettyPrint.Bernardy
-import Text.PrettyPrint.Prettyprinter.Render.Terminal
+import public Text.PrettyPrint.Bernardy.Core.Decorate
+import public Quox.EffExtra
 import public Data.String
-import Data.DPair
+import Control.ANSI.SGR
 
-import public Control.Monad.Identity
+import Data.DPair
-import public Control.Monad.Reader
+import Data.SnocList
-import Generics.Derive
+import Derive.Prelude
 
 %default total
 %language ElabReflection
@@ -19,13 +21,17 @@ import Generics.Derive
 
 
 public export
-record PrettyOpts where
+data PPrec
-  constructor MakePrettyOpts
+= Outer
-  unicode, color : Bool
+| Times   -- "_ × _"
-
+| InTimes -- arguments of ×
-public export
+| AnnL    -- left of "∷"
-defPrettyOpts : PrettyOpts
+| Eq      -- "_ ≡ _ : _"
-defPrettyOpts = MakePrettyOpts {unicode = True, color = True}
+| InEq    -- arguments of ≡
+  -- ...
+| App  -- term/dimension application
+| Arg  -- argument to nonfix function
+%runElab derive "PPrec" [Eq, Ord, Show]
 
 
 public export
@@ -33,169 +39,326 @@ data HL
 = Delim
 | Free | TVar | TVarErr
 | Dim  | DVar | DVarErr
-| Qty
+| Qty  | Universe
 | Syntax
-%runElab derive "HL" [Generic, Meta, Eq, Ord, DecEq, Show]
+| Constant
+%runElab derive "HL" [Eq, Ord, Show]
+
 
 public export
-data PPrec
+data Flavor = Unicode | Ascii
-= Outer
+%runElab derive "Flavor" [Eq, Ord, Show]
-| Ann  -- right of "::"
+
-| AnnL -- left  of "::"
+export %inline
-  -- ...
+noHighlight : HL -> Highlight
-| App  -- term/dimension application
+noHighlight _ = MkHighlight "" ""
-| SApp -- substitution application
+
-| Arg  -- argument to nonfix function
+
-%runElab derive "PPrec" [Generic, Meta, Eq, Ord, DecEq, Show]
+public export
+data EffTag = PREC | FLAVOR | HIGHLIGHT | INDENT
+
+public export
+Pretty : List (Type -> Type)
+Pretty = [StateL PREC PPrec, ReaderL FLAVOR Flavor,
+          ReaderL HIGHLIGHT (HL -> Highlight), ReaderL INDENT Nat]
+
+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]
 
 
 export %inline
-hl : HL -> Doc HL -> Doc HL
+toSGR : HL -> List SGR
-hl = annotate
+toSGR Delim    = []
+toSGR Free     = [SetForeground BrightBlue]
+toSGR TVar     = [SetForeground BrightYellow]
+toSGR TVarErr  = [SetForeground BrightYellow, SetStyle SingleUnderline]
+toSGR Dim      = [SetForeground BrightGreen]
+toSGR DVar     = [SetForeground BrightGreen]
+toSGR DVarErr  = [SetForeground BrightGreen, SetStyle SingleUnderline]
+toSGR Qty      = [SetForeground BrightMagenta]
+toSGR Universe = [SetForeground BrightRed]
+toSGR Syntax   = [SetForeground BrightCyan]
+toSGR Constant = [SetForeground BrightRed]
 
 export %inline
-hl' : HL -> Doc HL -> Doc HL
+highlightSGR : HL -> Highlight
-hl' h = hl h . unAnnotate
+highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
 
 export %inline
-hlF : Functor f => HL -> f (Doc HL) -> f (Doc HL)
+toClass : HL -> String
-hlF = map . hl
+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
-hlF' : Functor f => HL -> f (Doc HL) -> f (Doc HL)
+highlightHtml : HL -> Highlight
-hlF' = map . hl'
+highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
 
 
 export %inline
-parens : Doc HL -> Doc HL
+runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
-parens doc = hl Delim "(" <+> doc <+> hl Delim ")"
+runPrettyHL f = runPrettyWith Outer Unicode f 2
-%hide Symbols.parens
 
 export %inline
-parensIf : Bool -> Doc HL -> Doc HL
+runPretty : Eff Pretty a -> a
+runPretty = runPrettyHL noHighlight
+
+
+export %inline
+hl : {opts : LayoutOpts} -> 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 doc = pure $ indent !(askAt INDENT) doc
+
+export %inline
+hangD : {opts : LayoutOpts} -> 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
+
+
+export
+tightDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
+              Eff Pretty (Doc opts)
+tightDelims l r inner = do
+  l <- hl Delim $ text l
+  r <- hl Delim $ text r
+  pure $ hcat [l, inner, r]
+
+export
+looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
+              Eff Pretty (Doc opts)
+looseDelims l r inner = do
+  l <- hl Delim $ text l
+  r <- hl Delim $ text r
+  let short = hsep [l, inner, r]
+      long  = vsep [l, !(indentD inner), r]
+  pure $ ifMultiline short long
+
+export %inline
+parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+parens = tightDelims "(" ")"
+
+export %inline
+bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+bracks = tightDelims "[" "]"
+
+export %inline
+braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+braces = looseDelims "{" "}"
+
+export %inline
+tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
+tightBraces = tightDelims "{" "}"
+
+export %inline
+parensIf : {opts : LayoutOpts} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
 parensIf True  = parens
-parensIf False = id
+parensIf False = pure
+
+
+||| uses hsep only if the whole list fits on one line
+export
+sepSingle : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
+sepSingle xs = ifMultiline (hsep xs) (vsep xs)
+
+export
+fillSep : {opts : LayoutOpts} -> 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) ->
+             List (Doc opts) -> List (Doc opts)
+exceptLast f []        = []
+exceptLast f [x]       = [x]
+exceptLast f (x :: xs) = f x :: exceptLast f xs
+
+parameters {opts : LayoutOpts} {auto _ : Foldable t}
+  export
+  separateLoose : Doc opts -> t (Doc opts) -> Doc opts
+  separateLoose d = sep . exceptLast (<++> d) . toList
+
+  export
+  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 =
+  asksAt FLAVOR $ \case
+    Unicode => uni
+    Ascii   => asc
+
+export %inline
+parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
+parensIfM d doc = parensIf (!(getAt PREC) > d) doc
+
+export %inline
+withPrec : PPrec -> Eff Pretty a -> Eff Pretty a
+withPrec = localAt_ PREC
 
 
 export
-separate' : Doc a -> List (Doc a) -> List (Doc a)
+prettyName : Name -> Doc opts
-separate' s []        = []
+prettyName = text . toDots
-separate' s [x]       = [x]
+
-separate' s (x :: xs) = x <+> s :: separate' s xs
+export
+prettyFree : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts)
+prettyFree = hl Free . prettyName
+
+export
+prettyBind' : BindName -> Doc opts
+prettyBind' = text . baseStr . val
+
+export
+prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
+prettyTBind = hl TVar . prettyBind'
+
+export
+prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
+prettyDBind = hl DVar . prettyBind'
+
+
 
 export %inline
-separate : Doc a -> List (Doc a) -> Doc a
+typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
-separate s = sep . separate' s
+stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD,
-
+zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD :
-export %inline
+  {opts : LayoutOpts} -> Eff Pretty (Doc opts)
-hseparate : Doc a -> List (Doc a) -> Doc a
+typeD     = hl Syntax . text =<< ifUnicode "★" "Type"
-hseparate s = hsep . separate' s
+ioStateD  = hl Syntax $ text "IOState"
-
+arrowD    = hl Syntax . text =<< ifUnicode "→" "->"
-export %inline
+darrowD   = hl Syntax . text =<< ifUnicode "⇒" "=>"
-vseparate : Doc a -> List (Doc a) -> Doc a
+timesD    = hl Syntax . text =<< ifUnicode "×" "**"
-vseparate s = vsep . separate' s
+lamD      = hl Syntax . text =<< ifUnicode "λ" "fun"
-
+eqndD     = hl Syntax . text =<< ifUnicode "≡" "=="
-
+dlamD     = hl Syntax . text =<< ifUnicode "δ" "dfun"
-public export
+annD      = hl Syntax . text =<< ifUnicode "∷" "::"
-record PrettyEnv where
+natD      = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
-  constructor MakePrettyEnv
+stringD   = hl Syntax   $ text "String"
-  ||| names of bound dimension variables
+eqD       = hl Syntax   $ text "Eq"
-  dnames  : List Name
+colonD    = hl Syntax   $ text ":"
-  ||| names of bound term variables
+commaD    = hl Syntax   $ text ","
-  tnames  : List Name
+semiD     = hl Delim    $ text ";"
-  ||| use non-ascii characters for syntax
+atD       = hl Delim    $ text "@"
-  unicode : Bool
+caseD     = hl Syntax   $ text "case"
-  ||| surrounding precedence level
+typecaseD = hl Syntax   $ text "type-case"
-  prec    : PPrec
+ofD       = hl Syntax   $ text "of"
-
+returnD   = hl Syntax   $ text "return"
-public export
+dotD      = hl Delim    $ text "."
-HasEnv : (Type -> Type) -> Type
+zeroD     = hl Constant $ text "zero"
-HasEnv = MonadReader PrettyEnv
+succD     = hl Constant $ text "succ"
-
+coeD      = hl Syntax   $ text "coe"
-export %inline
+compD     = hl Syntax   $ text "comp"
-ifUnicode : HasEnv m => (uni, asc : Lazy a) -> m a
+undD      = hl Syntax   $ text "_"
-ifUnicode uni asc = if (!ask).unicode then [|uni|] else [|asc|]
+cstD      = hl Syntax   $ text "="
-
+pipeD     = hl Delim    $ text "|"
-export %inline
+fstD      = hl Syntax   $ text "fst"
-parensIfM : HasEnv m => PPrec -> Doc HL -> m (Doc HL)
+sndD      = hl Syntax   $ text "snd"
-parensIfM d doc = pure $ parensIf ((!ask).prec > d) doc
+letD      = hl Syntax   $ text "let"
-
+inD       = hl Syntax   $ text "in"
-export %inline
-withPrec : HasEnv m => PPrec -> m a -> m a
-withPrec d = local {prec := d}
-
-public export data BinderSort = T | D
-
-export %inline
-under : HasEnv m => BinderSort -> Name -> m a -> m a
-under T x = local {prec := Outer, tnames $= (x ::)}
-under D x = local {prec := Outer, dnames $= (x ::)}
-
-
-public export
-interface PrettyHL a where
-  prettyM : HasEnv m => a -> m (Doc HL)
-
-export %inline
-pretty0M : (PrettyHL a, HasEnv m) => a -> m (Doc HL)
-pretty0M = local {prec := Outer} . prettyM
-
-export %inline
-pretty0 : PrettyHL a => (unicode : Bool) -> a -> Doc HL
-pretty0 unicode x =
-  let env = MakePrettyEnv {dnames = [], tnames = [], unicode, prec = Outer} in
-  runReader env $ prettyM x
 
 
 export
-(forall a. PrettyHL (f a)) => PrettyHL (Exists f) where
+prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
-  prettyM x = prettyM x.snd
+            List (Doc opts) -> Doc opts
+prettyApp ind f args =
+  ifMultiline
+    (hsep (f :: args))
+    (f <++> vsep args <|> vsep (f :: map (indent ind) args))
 
 export
-PrettyHL a => PrettyHL (Subset a b) where
+prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
-  prettyM x = prettyM x.fst
+             Eff Pretty (Doc opts)
-
+prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
-
-export PrettyHL BaseName where prettyM = pure . pretty . baseStr
-export PrettyHL Name     where prettyM = pure . pretty . toDots
-
-
-export %inline
-prettyStr : PrettyHL a => (unicode : Bool) -> a -> String
-prettyStr unicode =
-  let layout = layoutSmart (MkLayoutOptions (AvailablePerLine 80 0.8)) in
-  renderString . layout . pretty0 unicode
 
 
 export
-termHL : HL -> AnsiStyle
+escapeString : String -> String
-termHL Delim   = color BrightBlack
+escapeString = concatMap esc1 . unpack where
-termHL TVar    = color BrightYellow
+  esc1 : Char -> String
-termHL TVarErr = color BrightYellow  <+> underline
+  esc1 '"'  = #"\""#
-termHL Dim     = color BrightGreen   <+> bold
+  esc1 '\\' = #"\\"#
-termHL DVar    = color BrightGreen
+  esc1 '\n' = #"\n"#
-termHL DVarErr = color BrightGreen   <+> underline
+  esc1 c    = singleton c
-termHL Qty     = color BrightMagenta <+> bold
-termHL Free    = color BrightWhite
-termHL Syntax  = color BrightCyan
 
-export %inline
+export
-prettyTerm : PrettyOpts -> PrettyHL a => a -> IO Unit
+quoteTag : String -> String
-prettyTerm opts x =
+quoteTag tag =
-  let reann = if opts.color then map termHL else unAnnotate in
+  if isName tag then tag else
-  Terminal.putDoc $ reann $ pretty0 opts.unicode x
+  "\"" ++ escapeString tag ++ "\""
 
-export %inline
+export
-prettyTermDef : PrettyHL a => a -> IO Unit
+prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
-prettyTermDef = prettyTerm defPrettyOpts
+prettyBounds (MkBounds l1 c1 l2 c2) =
+  hcat <$> sequence
+    [hl TVar $ text $ show l1, colonD,
+     hl DVar $ text $ show c1, hl Delim "-",
+     hl TVar $ text $ show l2, colonD,
+     hl DVar $ text $ show c2, colonD]
 
+export
+prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
+prettyLoc (L NoLoc) =
+  hcat <$> sequence [hl TVarErr "no location", colonD]
+prettyLoc (L (YesLoc file b)) =
+  hcat <$> sequence [hl Free $ text file, colonD, prettyBounds b]
 
-infixr 6 <//>
+export
-export %inline
+prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
-(<//>) : Doc a -> Doc a -> Doc a
+prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
-a <//> b = sep [a, b]
 
-infixr 6 </>
+export
-export %inline
+prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
-(</>) : Doc a -> Doc a -> Doc a
+prettyStrLit s =
-a </> b = cat [a, b]
+  let s = concatMap esc1 $ unpack s in
+  hl Constant $ hcat ["\"", text s, "\""]
+where
+  esc1 : Char -> String
+  esc1 '"' = "\""; esc1 '\\' = "\\"
+  esc1 c   = singleton c

lib/Quox/PrettyValExtra.idr

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

lib/Quox/Scoped.idr

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

lib/Quox/Syntax.idr

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

lib/Quox/Syntax/Builtin.idr

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

lib/Quox/Syntax/Dim.idr

@@ -1,94 +1,35 @@
 module Quox.Syntax.Dim
 
-import Quox.Syntax.Var
+import Quox.Loc
+import Quox.Name
+import Quox.Var
 import Quox.Syntax.Subst
 import Quox.Pretty
+import Quox.Context
+import Quox.PrettyValExtra
 
 import Decidable.Equality
 import Control.Function
-import Generics.Derive
+import Derive.Prelude
 
 %default total
 %language ElabReflection
-%hide SOP.from; %hide SOP.to
 
 
 public export
 data DimConst = Zero | One
 %name DimConst e
+%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal]
 
-%runElab derive "DimConst" [Generic, Meta, Eq, Ord, DecEq, Show]
+||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
-
-
 public export
-data Dim : Nat -> Type where
+ends : Lazy a -> Lazy a -> DimConst -> a
-  K : DimConst -> Dim d
+ends l r Zero = l
-  B : Var d -> Dim d
+ends l r One  = r
-%name Dim.Dim p, q
-
-private %inline
-drepr : Dim n -> Either DimConst (Var n)
-drepr (K k) = Left k
-drepr (B x) = Right x
-
-export Eq  (Dim n) where (==) = (==) `on` drepr
-export Ord (Dim n) where compare = compare `on` drepr
-
-export
-Show (Dim n) where
-  show (K k) = showCon App "K" $ show k
-  show (B i) = showCon App "B" $ show i
-
-export
-PrettyHL DimConst where
-  prettyM Zero = hl Dim <$> ifUnicode "𝟬" "0"
-  prettyM One  = hl Dim <$> ifUnicode "𝟭" "1"
-
-export
-PrettyHL (Dim n) where
-  prettyM (K e) = prettyM e
-  prettyM (B i) = prettyVar DVar DVarErr (!ask).dnames i
-
-
-public export %inline
-toConst : Dim 0 -> DimConst
-toConst (K e) = e
-
-
-public export
-DSubst : Nat -> Nat -> Type
-DSubst = Subst Dim
-
-
-export %inline
-prettyDSubst : Pretty.HasEnv m => DSubst from to -> m (Doc HL)
-prettyDSubst th =
-  prettySubstM prettyM (!ask).dnames DVar
-    !(ifUnicode "⟨" "<") !(ifUnicode "⟩" ">") th
-
-
-export FromVar Dim where fromVar = B
-
-export
-CanShift Dim where
-  K e // _  = K e
-  B i // by = B (i // by)
-
-export
-CanSubst Dim Dim where
-  K e // _  = K e
-  B i // th = th !! i
-
 
 export Uninhabited (Zero = One)  where uninhabited _ impossible
 export Uninhabited (One  = Zero) where uninhabited _ impossible
 
-export Uninhabited (B i = K e) where uninhabited _ impossible
-export Uninhabited (K e = B i) where uninhabited _ impossible
-
-public export %inline Injective Dim.B where injective Refl = Refl
-public export %inline Injective Dim.K where injective Refl = Refl
-
 public export
 DecEq DimConst where
   decEq Zero Zero = Yes Refl
@@ -96,13 +37,104 @@ DecEq DimConst where
   decEq One  Zero = No absurd
   decEq One  One  = Yes Refl
 
+
 public export
-DecEq (Dim d) where
+data Dim : Nat -> Type where
-  decEq (K e) (K f) with (decEq e f)
+  K : DimConst -> Loc -> Dim d
-    _ | Yes prf    = Yes $ cong K prf
+  B : Var d -> Loc -> Dim d
-    _ | No  contra = No  $ contra . injective
+%name Dim.Dim p, q
-  decEq (K e) (B j) = No absurd
+%runElab deriveIndexed "Dim" [Eq, Ord, Show]
-  decEq (B i) (K f) = No absurd
+
-  decEq (B i) (B j) with (decEq i j)
+
-    _ | Yes prf    = Yes $ cong B prf
+||| `endsOr l r x p` returns `ends l r ε` if `p` is a constant ε, and
-    _ | No  contra = No  $ contra . injective
+||| `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
+
+
+export
+Located (Dim d) where
+  (K _ 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
+
+export
+prettyDimConst : {opts : _} -> 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
+
+
+public export %inline
+toConst : Dim 0 -> DimConst
+toConst (K e _) = e
+
+
+public export
+DSubst : Nat -> Nat -> Type
+DSubst = Subst Dim
+
+
+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
+CanSubstSelf Dim where
+  K e loc // _  = K e loc
+  B i loc // th = getLoc th i loc
+
+
+export Uninhabited (B i loc1 = K e loc2) where uninhabited _ impossible
+export Uninhabited (K e loc1 = B i 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 _
+
+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
+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
+
+||| 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

lib/Quox/Syntax/DimEq.idr

@@ -1,9 +1,12 @@
 module Quox.Syntax.DimEq
 
-import public Quox.Syntax.Var
+import public Quox.Var
 import public Quox.Syntax.Dim
 import public Quox.Syntax.Subst
 import public Quox.Context
+import Quox.Pretty
+import Quox.Name
+import Quox.FreeVars
 
 import Data.Maybe
 import Data.Nat
@@ -11,7 +14,9 @@ import Data.DPair
 import Data.Fun.Graph
 import Decidable.Decidable
 import Decidable.Equality
+import Derive.Prelude
 
+%language ElabReflection
 %default total
 
 
@@ -24,99 +29,155 @@ public export
 data DimEq : Nat -> Type where
   ZeroIsOne : DimEq d
   C         : (eqs : DimEq' d) -> DimEq d
-
 %name DimEq eqs
+%runElab deriveIndexed "DimEq" [Eq, Ord, Show]
+
+
+public export
+consistent : DimEq d -> Bool
+consistent ZeroIsOne = False
+consistent (C eqs)   = True
+
+
+public export
+data IfConsistent : DimEq d -> Type -> Type where
+  Nothing :      IfConsistent ZeroIsOne a
+  Just    : a -> IfConsistent (C eqs)   a
+
+export
+Functor (IfConsistent eqs) where
+  map f Nothing  = Nothing
+  map f (Just x) = Just (f x)
+
+export
+Foldable (IfConsistent eqs) where
+  foldr f z Nothing  = z
+  foldr f z (Just x) = f x z
+
+export
+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 ())
+
+public export
+toMaybe : IfConsistent eqs a -> Maybe a
+toMaybe Nothing  = Nothing
+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)
+
+export
+fromGround : BContext d -> Context' DimConst d -> DimEq d
+fromGround = C .: fromGround'
+
+
+public export %inline
 zeroEq : DimEq 0
 zeroEq = C [<]
 
-export
+public export %inline
 new' : {d : Nat} -> DimEq' d
 new' {d = 0}   = [<]
 new' {d = S d} = new' :< Nothing
 
-export %inline
+public export %inline
 new : {d : Nat} -> DimEq d
 new = C new'
 
 
-private %inline
+public export %inline
-shiftMay : Maybe (Dim from) -> Shift from to -> Maybe (Dim to)
-shiftMay p by = map (// by) p
-
-export %inline
 get' : DimEq' d -> Var d -> Maybe (Dim d)
-get' = getWith shiftMay
+get' = getWith $ \p, by => map (// by) p
 
-private %inline
+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' = getShiftWith shiftMay
+getShift' = getShiftWith $ \p, by => map (// by) p
 
-export %inline
+public export %inline
 get : DimEq' d -> Dim d -> Dim d
-get _   (K e) = K e
+get _   (K e loc) = K e loc
-get eqs (B i) = fromMaybe (B i) $ get' eqs i
+get eqs (B i loc) = getVar eqs i loc
 
 
-export %inline
+public export %inline
 equal : DimEq d -> (p, q : Dim d) -> Bool
 equal ZeroIsOne p q = True
 equal (C eqs)   p q = get eqs p == get eqs q
 
 
-infixl 5 :<?
+export infixl 7 :<?
 export %inline
 (:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
 ZeroIsOne :<? d = ZeroIsOne
-C eqs     :<? d = C $ eqs :< d
+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 isYes $ q `decEq` B i then p else q
+ifVar i p = map $ \q => if q == B i noLoc then p else q
 
+-- (using decEq instead of (==) because of the proofs below)
 private %inline
 checkConst : (e, f : DimConst) -> (eqs : Lazy (DimEq' d)) -> DimEq d
-checkConst Zero Zero eqs = C eqs
+checkConst e f eqs = if isYes $ e `decEq` f then C eqs else ZeroIsOne
-checkConst One  One  eqs = C eqs
+
-checkConst _    _    _   = ZeroIsOne
 
 export
-setConst : Var d -> DimConst -> DimEq' d -> DimEq d
+setConst : Var d -> DimConst -> Loc -> DimEq' d -> DimEq d
-setConst VZ e (eqs :< Nothing)    = C $ eqs :< Just (K e)
+setConst VZ e loc (eqs :< Nothing) =
-setConst VZ e (eqs :< Just (K f)) = checkConst e f $ eqs :< Just (K f)
+  C $ eqs :< Just (K e loc)
-setConst VZ e (eqs :< Just (B i)) = setConst i e eqs :<? Just (K e)
+setConst VZ e _ (eqs :< Just (K f loc)) =
-setConst (VS i) e (eqs :< p)      = setConst i e eqs :<? ifVar i (K e) p
+  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
 
 mutual
   private
-  setVar' : (i, j : Var d) -> i `LT` j -> DimEq' d -> DimEq d
+  setVar' : (i, j : Var d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
-  setVar' VZ (VS i) LTZ (eqs :< Nothing) =
+  setVar' VZ (VS i) LTZ loc (eqs :< Nothing) =
-    C $ eqs :< Just (B i)
+    C eqs :<? Just (B i loc)
-  setVar' VZ (VS i) LTZ (eqs :< Just (K e)) =
+  setVar' VZ (VS i) LTZ loc (eqs :< Just (K e eloc)) =
-    setConst i e eqs :<? Just (K e)
+    setConst i e loc eqs :<? Just (K e eloc)
-  setVar' VZ (VS i) LTZ (eqs :< Just (B j)) =
+  setVar' VZ (VS i) LTZ loc (eqs :< Just (B j jloc)) =
-    setVar i j eqs :<? Just (B (max i j))
+    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) (eqs :< p) =
+  setVar' (VS i) (VS j) (LTS lt) loc (eqs :< p) =
-    setVar' i j lt eqs :<? ifVar i (B j) p
+    setVar' i j lt loc eqs :<? ifVar i (B j loc) p
 
   export %inline
-  setVar : (i, j : Var d) -> DimEq' d -> DimEq d
+  setVar : (i, j : Var d) -> Loc -> Loc -> DimEq' d -> DimEq d
-  setVar i j eqs with (compareP i j)
+  setVar i j li lj eqs with (compareP i j) | (compare i.nat j.nat)
-    _              | IsLT lt = setVar' i j lt eqs
+    setVar i j li lj eqs | IsLT lt | LT = setVar' i j lt lj eqs
-    setVar i i eqs | IsEQ    = C eqs
+    setVar i i li lj eqs | IsEQ    | EQ = C eqs
-    _              | IsGT gt = setVar' j i gt eqs
+    setVar i j li lj eqs | IsGT gt | GT = setVar' j i gt li eqs
 
 
 export %inline
 set : (p, q : Dim d) -> DimEq d -> DimEq d
 set _ _ ZeroIsOne = ZeroIsOne
-set (K e) (K f) (C eqs) = checkConst e f eqs
+set (K e eloc) (K f floc) (C eqs) = checkConst e f eqs
-set (K e) (B i) (C eqs) = setConst i e eqs
+set (K e eloc) (B i iloc) (C eqs) = setConst i e eloc eqs
-set (B i) (K e) (C eqs) = setConst i e eqs
+set (B i iloc) (K e eloc) (C eqs) = setConst i e eloc eqs
-set (B i) (B j) (C eqs) = setVar   i j eqs
+set (B i iloc) (B j jloc) (C eqs) = setVar   i j iloc jloc eqs
 
 
 public export %inline
@@ -124,25 +185,34 @@ Split : Nat -> Type
 Split d = (DimEq' d, DSubst (S d) d)
 
 export %inline
-split1 : DimConst -> DimEq' (S d) -> Maybe (Split d)
+split1 : DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
-split1 e eqs = case setConst VZ e eqs of
+split1 e loc eqs = case setConst VZ e loc eqs of
   ZeroIsOne    => Nothing
-  C (eqs :< _) => Just (eqs, K e ::: id)
+  C (eqs :< _) => Just (eqs, K e loc ::: id)
 
 export %inline
-split : DimEq' (S d) -> List (Split d)
+split1' : DimConst -> Loc -> DimEq' (S d) -> List (Split d)
-split eqs = toList (split1 Zero eqs) <+> toList (split1 One eqs)
+split1' e loc eqs = toList $ split1 e loc eqs
 
+export %inline
+split : Loc -> DimEq' (S d) -> Bool -> List (Split d)
+split loc eqs False = split1' Zero loc eqs
+split loc eqs True  = split1' Zero loc eqs <+> split1' One loc eqs
 
 export
-splits' : DimEq' d -> List (DSubst d 0)
+splits' : Loc -> DimEq' d -> FreeVars d -> List (DSubst d 0)
-splits' [<]          = [id]
+splits' _   [<]          _  = [id]
-splits' eqs@(_ :< _) = [th . ph | (eqs', th) <- split eqs, ph <- splits' eqs']
+splits' loc eqs@(_ :< _) us = do
+  let (us, u) = uncons us
+  (eqs', th) <- split loc eqs u
+  ph         <- splits' loc eqs' us
+  pure $ th . ph
 
+||| the Loc is put into each of the DimConsts
 export %inline
-splits : DimEq d -> List (DSubst d 0)
+splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
-splits ZeroIsOne = []
+splits _   ZeroIsOne _   = []
-splits (C eqs)   = splits' eqs
+splits loc (C eqs)   fvs = splits' loc eqs fvs
 
 
 private
@@ -157,19 +227,74 @@ 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 (K e _) = Refl
-newGet d (B i) = rewrite newGet' d i in 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 Zero _) (C eqs) = Refl
-setSelf (K One)  (C eqs) = Refl
+setSelf (K One _)  (C eqs) = Refl
-setSelf (B i)    (C eqs) = rewrite comparePSelf i in 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
 
 
--- [todo] "well formed" dimeqs
+private %inline
--- [todo] operations maintain well-formedness
+dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec
--- [todo] if 'Wf eqs' then 'equal eqs' is an equivalence
+dimEqPrec vars eqs =
--- [todo] 'set' never breaks existing equalities
+  if length vars <= 1 && maybe True null eqs then Arg else Outer
+
+private
+prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
+prettyDVars' = traverse prettyDBind . toSnocList'
+
+export
+prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
+prettyDVars vars =
+  parensIfM (dimEqPrec vars Nothing) $
+  fillSeparateTight !commaD $ !(prettyDVars' vars)
+
+private
+prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
+prettyCst dnames p q =
+  hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
+
+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
+
+
+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
+
+public export
+wf : DimEq d -> Bool
+wf ZeroIsOne = True
+wf (C eqs)   = wf' eqs

lib/Quox/Syntax/Qty.idr

@@ -1,84 +1,154 @@
+||| quantities count how many times a bound variable is used [@nuttin; @qtt].
+|||
+||| i tried grtt [@grtt] for a bit but i think it was more complex than
+||| it's worth in a language that has other stuff going on too
 module Quox.Syntax.Qty
 
 import Quox.Pretty
-
+import Quox.Decidable
-import Data.Fin
+import Quox.PrettyValExtra
-import Generics.Derive
+import Data.DPair
+import Derive.Prelude
 
 %default total
 %language ElabReflection
 
 
+||| the possibilities we care about are:
+|||
+||| - 0: a variable is used only at compile time, not run time
+||| - 1: a variable is used exactly once at run time
+||| - ω (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]
 %name Qty.Qty pi, rh
 
-%runElab derive "Qty" [Generic, Meta, Eq, Ord, DecEq, Show]
-
 
 export
-PrettyHL Qty where
+prettyQty : {opts : _} -> Qty -> Eff Pretty (Doc opts)
-  prettyM pi = hl Qty <$>
+prettyQty Zero = hl Qty $ text "0"
-    case pi of
+prettyQty One  = hl Qty $ text "1"
-      Zero => ifUnicode "𝟬" "0"
+prettyQty Any  = hl Qty =<< ifUnicode (text "ω") (text "#")
-      One  => ifUnicode "𝟭" "1"
-      Any  => ifUnicode "𝛚" "*"
-
-private
-commas : List (Doc HL) -> List (Doc HL)
-commas [] = []
-commas [x] = [x]
-commas (x::xs) = (x <+> hl Delim ",") :: commas xs
-
-export %inline
-prettyQtyBinds : Pretty.HasEnv m => List Qty -> m (Doc HL)
-prettyQtyBinds =
-  map ((hl Delim "@" <++>) . align . sep . commas) . traverse pretty0M
-
 
+||| prints in a form that can be a suffix of "case"
 public export
-plus : Qty -> Qty -> Qty
+prettySuffix : {opts : _} -> Qty -> Eff Pretty (Doc opts)
-plus Zero rh   = rh
+prettySuffix = prettyQty
-plus pi   Zero = pi
-plus _    _    = Any
 
+
+||| e.g. if in the expression `(s, t)`, the variable `x` is
+||| used π times in `s` and ρ times in `t`, then it's used
+||| (π + ρ) times in the whole expression
 public export
-times : Qty -> Qty -> Qty
+(+) : Qty -> Qty -> Qty
-times Zero _    = Zero
+Zero + rh   = rh
-times _    Zero = Zero
+pi   + Zero = pi
-times One  rh   = rh
+_    + _    = Any
-times pi   One  = pi
-times Any  Any  = Any
 
-infix 6 <=.
+||| e.g. if a function `f` uses its argument π times,
+||| and `f x` occurs in a σ context, then `x` is used `πσ` times overall
+public export
+(*) : Qty -> Qty -> Qty
+Zero * _    = Zero
+_    * Zero = Zero
+One  * rh   = rh
+pi   * One  = pi
+Any  * Any  = Any
+
+||| "π ≤ ρ"
+|||
+||| if a variable is bound with quantity ρ, then it can be used with a total
+||| quantity π as long as π ≤ ρ. for example, an ω variable can be used any
+||| number of times, so π ≤ ω for any π.
 public export
 compat : Qty -> Qty -> Bool
-compat pi rh = rh == Any || pi == rh
+compat pi Any = True
+compat pi rh  = pi == rh
+
+
+||| "π ∨ ρ"
+|||
+||| returns a quantity τ with π ≤ τ and ρ ≤ τ.
+||| if π = ρ, then it's that, otherwise it's ω.
+public export
+lub : Qty -> Qty -> Qty
+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
+
+||| "σ ⨴ π"
+|||
+||| σ ⨴ π is 0 if either of σ or π are, otherwise it is σ.
+public export
+subjMult : SQty -> Qty -> SQty
+subjMult _  Zero = SZero
+subjMult sg _    = sg
+
+
+||| it doesn't make much sense for a top level declaration to have a
+||| 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
+
+public export
+toGlobal : Qty -> Maybe GQty
+toGlobal Zero = Just GZero
+toGlobal Any  = Just GAny
+toGlobal One  = Nothing
+
+||| when checking a definition, a 0 definition is checked at 0,
+||| but an ω definition is checked at 1 since ω isn't a subject quantity
+public export %inline
+globalToSubj : GQty -> SQty
+globalToSubj GZero = SZero
+globalToSubj GAny  = SOne
 
 
 public export
-interface IsQty q where
+DecEq Qty where
-  zero, one : q
+  decEq Zero Zero = Yes Refl
-  (+),  (*) : q -> q -> q
+  decEq Zero One  = No $ \case _ impossible
-  (<=.)     : q -> q -> Bool
+  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
-IsQty Qty where
+DecEq SQty where
-  zero  = Zero; one = One
+  decEq SZero SZero = Yes Refl
-  (+)   = plus; (*) = times
+  decEq SZero SOne  = No $ \case _ impossible
-  (<=.) = compat
+  decEq SOne  SZero = No $ \case _ impossible
-
+  decEq SOne  SOne  = Yes Refl
 
 public export
-data IsSubj : Qty -> Type where
+DecEq GQty where
-  SZero : IsSubj Zero
+  decEq GZero GZero = Yes Refl
-  SOne  : IsSubj One
+  decEq GZero GAny  = No $ \case _ impossible
+  decEq GAny  GZero = No $ \case _ impossible
+  decEq GAny  GAny  = Yes Refl
 
-export Uninhabited (IsSubj Any) where uninhabited _ impossible
 
-public export
+namespace SQty
-data IsGlobal : Qty -> Type where
+  public export %inline
-  GZero : IsGlobal Zero
+  (.qty) : SQty -> Qty
-  GAny  : IsGlobal Any
+  (SZero).qty = Zero
+  (SOne).qty  = One
 
-export Uninhabited (IsGlobal One) where uninhabited _ impossible
+namespace GQty
+  public export %inline
+  (.qty) : GQty -> Qty
+  (GZero).qty = Zero
+  (GAny).qty  = Any

lib/Quox/Syntax/Shift.idr

@@ -1,17 +1,18 @@
 module Quox.Syntax.Shift
 
-import public Quox.Syntax.Var
+import public Quox.Var
-import Quox.Pretty
 
 import Data.Nat
 import Data.So
+import Data.Singleton
+import Syntax.PreorderReasoning
 
 %default total
 
 
 ||| represents the difference between a smaller scope and a larger one.
 public export
-data Shift : (0 from, to : Nat) -> Type where
+data Shift : (from, to : Nat) -> Type where
   SZ : Shift from from
   SS : Shift from to -> Shift from (S to)
 %name Shift by, bz
@@ -35,20 +36,28 @@ public export
 data Eqv : Shift from1 to1 -> Shift from2 to2 -> Type where
   EqSZ : SZ `Eqv` SZ
   EqSS : by `Eqv` bz -> SS by `Eqv` SS bz
-%name Eqv e
+%name Shift.Eqv e
+
+using (by : Shift from to, bz : Shift from to)
+  ||| two equivalent shifts are equal if they have the same indices.
+  export
+  0 fromEqv : by `Eqv` bz -> by = bz
+  fromEqv EqSZ     = Refl
+  fromEqv (EqSS e) = cong SS $ fromEqv e
+
+  ||| two equal shifts are equivalent.
+  export
+  0 toEqv : by = bz -> by `Eqv` bz
+  toEqv Refl {by = SZ}      = EqSZ
+  toEqv Refl {by = (SS by)} = EqSS $ toEqv Refl
+
 
-||| two equivalent shifts are equal if they have the same indices.
 export
-0 fromEqv : by `Eqv` bz -> by = bz
+cmpLen : Shift from1 to -> Shift from2 to -> Either Ordering (from1 = from2)
-fromEqv EqSZ     = Refl
+cmpLen SZ      SZ      = Right Refl
-fromEqv (EqSS e) = cong SS $ fromEqv e
+cmpLen SZ      (SS by) = Left LT
-
+cmpLen (SS by) SZ      = Left GT
-||| two equal shifts are equivalent.
+cmpLen (SS by) (SS bz) = cmpLen by bz
-export
-0 toEqv : by = bz -> by `Eqv` bz
-toEqv Refl {by = SZ}      = EqSZ
-toEqv Refl {by = (SS by)} = EqSS $ toEqv Refl
-
 
 export
 0 shiftDiff : (by : Shift from to) -> to = by.nat + from
@@ -110,7 +119,52 @@ export
 ssDownEqv SZ      = EqSS EqSZ
 ssDownEqv (SS by) = EqSS $ ssDownEqv by
 
-%transform "Shift.ssDown" ssDown by = believe_me (SS by)
+private %inline
+ssDownViaNat : Shift (S from) to -> Shift from to
+ssDownViaNat by =
+  rewrite shiftDiff by in
+  rewrite sym $ plusSuccRightSucc by.nat from in
+  fromNat $ S by.nat
+
+%transform "Shift.ssDown" ssDown = ssDownViaNat
+
+
+public export
+weak : (s : Nat) -> Shift from to -> Shift (s + from) (s + to)
+weak s SZ = SZ
+weak s (SS by) {to = S to} =
+  rewrite sym $ plusSuccRightSucc s to in
+  SS $ weak s by
+
+private
+weakViaNat : (s : Nat) -> Shift from to -> Shift (s + from) (s + to)
+weakViaNat s by =
+  rewrite shiftDiff by in
+  rewrite plusAssociative s by.nat from in
+  rewrite plusCommutative s by.nat in
+  rewrite sym $ plusAssociative by.nat s from in
+  fromNat by.nat
+
+%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
@@ -118,12 +172,12 @@ shift : Shift from to -> Var from -> Var to
 shift SZ      i = i
 shift (SS by) i = VS $ shift by i
 
-private
+private %inline
 shiftViaNat' : (by : Shift from to) -> (i : Var from) ->
                (0 p : by.nat + i.nat `LT` to) -> Var to
 shiftViaNat' by i p = V $ by.nat + i.nat
 
-private
+private %inline
 shiftViaNat : Shift from to -> Var from -> Var to
 shiftViaNat by i = shiftViaNat' by i $ shiftVarLT by i
 
@@ -137,7 +191,6 @@ shiftViaNatCorrect (SS by) i (LTESucc p) = cong VS $ shiftViaNatCorrect by i p
 %transform "Shift.shift" shift = shiftViaNat
 
 
-infixl 9 .
 public export
 (.) : Shift from mid -> Shift mid to -> Shift from to
 by . SZ    = by
@@ -146,22 +199,19 @@ 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 =
+compNatProof by bz = Calc $
-  shiftDiff bz                       >>>
+  |~ to
-  cong (bz.nat +) (shiftDiff by)     >>>
+  ~~ bz.nat + mid             ...(shiftDiff {})
-  plusAssociative bz.nat by.nat from >>>
+  ~~ bz.nat + (by.nat + from) ...(cong (bz.nat +) (shiftDiff {}))
-  cong (+ from) (plusCommutative bz.nat by.nat)
+  ~~ bz.nat + by.nat + from   ...(plusAssociative {})
- where
+  ~~ by.nat + bz.nat + from   ...(cong (+ from) (plusCommutative {}))
-  infixr 0 >>>
-  0 (>>>) : a = b -> b = c -> a = c
-  x >>> y = trans x y
 
-private
+private %inline
 compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
               Shift from (by.nat + bz.nat + from)
 compViaNat' by bz = fromNat $ by.nat + bz.nat
 
-private
+private %inline
 compViaNat : (by : Shift from mid) -> (bz : Shift mid to) -> Shift from to
 compViaNat by bz = rewrite compNatProof by bz in compViaNat' by bz
 
@@ -177,35 +227,18 @@ compViaNatCorrect by (SS bz) =
 %transform "Shift.(.)" Shift.(.) = compViaNat
 
 
-||| `prettyShift bnd unicode prec by` pretty-prints the shift `by`, with the
+export infixl 8 //
-||| following arguments:
-|||
-||| * `by : Shift from to`
-||| * `bnd : HL` is the highlight used for bound variables of this kind
-||| * `unicode : Bool` is whether to use unicode characters in the output
-||| * `prec : PPrec` is the surrounding precedence level
-export
-prettyShift : Pretty.HasEnv m => (bnd : HL) -> Shift from to -> m (Doc HL)
-prettyShift bnd by =
-  parensIfM Outer $ hsep $
-    [hl bnd   !(ifUnicode "𝑖"  "i"), hl Delim !(ifUnicode "≔" ":="),
-     hl bnd $ !(ifUnicode "𝑖+" "i+") <+> pretty by.nat]
-
-||| prints using the `TVar` highlight for variables
-export PrettyHL (Shift from to) where prettyM = prettyShift TVar
-
-
-infixl 8 //
 public export
 interface CanShift f where
   (//) : f from -> Shift from to -> f to
 
-export CanShift Var where i // by = shift by i
+export %inline
+CanShift Var where i // by = shift by i
 
 namespace CanShift
-  public export
+  public export %inline
   [Map] (Functor f, CanShift tm) => CanShift (f . tm) where
     x // by = map (// by) x
 
-  public export
+  public export %inline
   [Const] CanShift (\_ => a) where x // _ = x

lib/Quox/Syntax/Subst.idr

@@ -1,22 +1,31 @@
 module Quox.Syntax.Subst
 
 import public Quox.Syntax.Shift
-import Quox.Syntax.Var
+import Quox.Var
 import Quox.Name
-import Quox.Pretty
 
+import Data.Nat
 import Data.List
+import Data.SnocVect
+import Data.Singleton
+import Derive.Prelude
 
 %default total
+%language ElabReflection
 
 
-infixr 5 :::
 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
 
+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
@@ -28,30 +37,26 @@ 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 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 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
 
 
-infixl 8 //
+export infixl 8 //
 public export
-interface FromVar env => CanSubst env term where
+interface FromVar term => CanSubstSelf term where
-  (//) : term from -> Lazy (Subst env from to) -> term to
+  (//) : term from -> Lazy (Subst term from to) -> term to
-
-public export
-CanSubst1 : (Nat -> Type) -> Type
-CanSubst1 f = CanSubst f f
-
-
-infixl 8 !!
-public export
-(!!) : FromVar term => Subst term from to -> Var from -> term to
-(Shift by) !! i      = fromVar $ shift by i
-(t ::: th) !! VZ     = t
-(t ::: th) !! (VS i) = th !! i
 
 
 public export
-CanSubst Var Var where
+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
+
+
+public export
+CanSubstSelf Var where
   i    // Shift by   = shift by i
   VZ   // (t ::: th) = t
   VS i // (t ::: th) = i // th
@@ -61,10 +66,13 @@ public export %inline
 shift : (by : Nat) -> Subst env from (by + from)
 shift by = Shift $ fromNat by
 
+public export %inline
+shift0 : (by : Nat) -> Subst env 0 by
+shift0 by = rewrite sym $ plusZeroRightNeutral by in Shift $ fromNat by
+
 
-infixl 9 .
 public export
-(.) : CanSubst1 f => Subst f from mid -> Subst f mid to -> Subst f from to
+(.) : 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
@@ -74,6 +82,13 @@ public export %inline
 id : Subst f n n
 id = shift 0
 
+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
@@ -81,8 +96,18 @@ map f (t ::: th) = f t ::: map f th
 
 
 public export %inline
-push : CanSubst1 f => Subst f from to -> Subst f (S from) (S to)
+push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
-push th = fromVar VZ ::: (th . shift 1)
+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)
 
 public export
 drop1 : Subst f (S from) to -> Subst f from to
@@ -90,40 +115,55 @@ 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 = x ::: id
+one x = fromSnocVect [< x]
 
 
-||| `prettySubst pr names bnd op cl th` pretty-prints the substitution `th`,
-||| with the following arguments:
-|||
-||| * `th : Subst f from to`
-||| * `pr : f to -> m (Doc HL)` prints a single element
-||| * `names : List Name` is a list of known bound var names
-||| * `bnd : HL` is the highlight to use for bound variables being subsituted
-||| * `op, cl : Doc HL` are the opening and closing brackets
 export
-prettySubstM : Pretty.HasEnv m =>
+getFrom : {to : Nat} -> Subst _ from to -> Singleton from
-               (pr : f to -> m (Doc HL)) ->
+getFrom (Shift by) = getFrom by
-               (names : List Name) -> (bnd : HL) -> (op, cl : Doc HL) ->
+getFrom (t ::: th) = [|S $ getFrom th|]
-               Subst f from to -> m (Doc HL)
-prettySubstM pr names bnd op cl th =
-  encloseSep (hl Delim op) (hl Delim cl) (hl Delim "; ") <$>
-    withPrec Outer (go 0 th)
- where
-  go1 : Nat -> f to -> m (Doc HL)
-  go1 i t = pure $ hang 2 $ sep
-    [hsep [!(prettyVar' bnd bnd names i),
-           hl Delim !(ifUnicode "≔" ":=")],
-     !(pr t)]
 
-  go : forall from. Nat -> Subst f from to -> m (List (Doc HL))
-  go _ (Shift SZ) = pure []
-  go _ (Shift by) = [|pure (prettyShift bnd by)|]
-  go i (t ::: th) = [|go1 i t :: go (S i) th|]
 
-||| prints with [square brackets] and the `TVar` highlight for variables
+||| 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
-PrettyHL (f to) => PrettyHL (Subst f from to) where
+cmpShape : Subst env from1 to -> Subst env from2 to ->
-  prettyM th = prettySubstM prettyM (!ask).tnames TVar "[" "]" th
+           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
+
+
+public export
+record WithSubst tm env n where
+  constructor Sub
+  term  : tm from
+  subst : Lazy (Subst env from n)
+
+export
+(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
+
+export
+(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)
+
+export %hint
+ShowWithSubst : (Show (env n), forall n. Show (tm n)) =>
+                Show (WithSubst tm env n)
+ShowWithSubst = deriveShow

lib/Quox/Syntax/Term.idr

@@ -1,7 +1,5 @@
 module Quox.Syntax.Term
 
 import public Quox.Syntax.Term.Base
-import public Quox.Syntax.Term.Split
 import public Quox.Syntax.Term.Subst
-import public Quox.Syntax.Term.Reduce
 import public Quox.Syntax.Term.Pretty

lib/Quox/Syntax/Term/Base.idr

@@ -1,13 +1,15 @@
 module Quox.Syntax.Term.Base
 
-import public Quox.Syntax.Var
+import public Quox.Var
+import public Quox.Scoped
 import public Quox.Syntax.Shift
 import public Quox.Syntax.Subst
-import public Quox.Syntax.Universe
 import public Quox.Syntax.Qty
 import public Quox.Syntax.Dim
+import public Quox.Syntax.Term.TyConKind
 import public Quox.Name
-import public Quox.OPE
+import public Quox.Loc
+import public Quox.Context
 
 import Quox.Pretty
 
@@ -17,94 +19,434 @@ import Data.Maybe
 import Data.Nat
 import public Data.So
 import Data.String
-import Data.Vect
+import public Data.SortedMap
+import public Data.SortedMap.Dependent
+import public Data.SortedSet
+import Derive.Prelude
 
 %default total
+%language ElabReflection
+
+%hide TT.Name
+
+
+public export
+TermLike : Type
+TermLike = Nat -> Nat -> Type
+
+public export
+TSubstLike : Type
+TSubstLike = Nat -> Nat -> Nat -> Type
+
+public export
+Universe : Type
+Universe = Nat
+
+public export
+TagVal : Type
+TagVal = String
 
 
-infixl 8 :#
-infixl 9 :@
 mutual
   public export
-  TSubst : Nat -> Nat -> Nat -> Type
+  TSubst : TSubstLike
-  TSubst d = Subst (\n => Elim d n)
+  TSubst d = Subst $ \n => Elim d n
 
-  ||| first argument `d` is dimension scope size, second `n` is term scope size
+  ||| 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) -> Term d n
+    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) -> (x : Name) ->
+    Pi  : (qty : Qty) -> (arg : Term d n) ->
-          (arg : Term d n) -> (res : ScopeTerm d n) -> Term d n
+          (res : ScopeTerm d n) -> (loc : Loc) -> Term d n
     ||| function term
-    Lam : (x : Name) -> (body : ScopeTerm d n) -> Term d n
+    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  : (tm : Term d from)  -> (th : Lazy (TSubst d from to)) -> Term d to
+    CloT  : WithSubst (Term d) (Elim d) n -> Term d n
     ||| dimension closure/suspended substitution
-    DCloT : (tm : Term dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Term dto n
+    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
+    ||| free variable, possibly with a displacement (see @crude, or @mugen for a
-    F : (x : Name) -> Elim d n
+    ||| 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) -> Elim d n
+    B : (i : Var n) -> (loc : Loc) -> Elim d n
 
     ||| term application
-    (:@) : (fun : Elim d n) -> (arg : Term d n) -> Elim d n
+    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
-    (:#) : (tm, ty : Term d n) -> Elim d n
+    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  : (el : Elim d from)  -> (th : Lazy (TSubst d from to)) -> Elim d to
+    CloE  : WithSubst (Elim d) (Elim d) n -> Elim d n
     ||| dimension closure/suspended substitution
-    DCloE : (el : Elim dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Elim dto n
+    DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
+  %name Elim e, f
 
-  ||| a scope with one more bound variable
   public export
-  data ScopeTerm : (d, n : Nat) -> Type where
+  CaseEnumArms : TermLike
-    ||| variable is used
+  CaseEnumArms d n = SortedMap TagVal (Term d n)
-    TUsed : (body : Term d (S n)) -> ScopeTerm d n
-    ||| variable is unused
-    TUnused : (body : Term d n) -> ScopeTerm d n
 
-  ||| a scope with one more bound dimension variable
   public export
-  data DScopeTerm : (d, n : Nat) -> Type where
+  TypeCaseArms : TermLike
-    ||| variable is used
+  TypeCaseArms d n = SortedDMap TyConKind (\k => TypeCaseArmBody k d n)
-    DUsed : (body : Term (S d) n) -> DScopeTerm d n
-    ||| variable is unused
-    DUnused : (body : Term d n) -> DScopeTerm d n
 
-%name Term s, t, r
+  public export
-%name Elim e, f
+  TypeCaseArm : TermLike
-%name ScopeTerm body
+  TypeCaseArm d n = (k ** TypeCaseArmBody k d n)
-%name DScopeTerm body
+
+  public export
+  TypeCaseArmBody : TyConKind -> TermLike
+  TypeCaseArmBody k = ScopeTermN (arity k)
+
+
+  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
+  ScopeTerm, DScopeTerm : TermLike
+  ScopeTerm  = ScopeTermN 1
+  DScopeTerm = DScopeTermN 1
+
+mutual
+  export %hint
+  EqTerm : Eq (Term d n)
+  EqTerm = assert_total {a = Eq (Term d n)} deriveEq
+
+  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
+
+
+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
+
+export
+Located (Term d n) where
+  (TYPE _ loc).loc      = loc
+  (IOState loc).loc     = loc
+  (Pi _ _ _ loc).loc    = loc
+  (Lam _ loc).loc       = loc
+  (Sig _ _ loc).loc     = loc
+  (Pair _ _ loc).loc    = loc
+  (Enum _ loc).loc      = loc
+  (Tag _ loc).loc       = loc
+  (Eq _ _ _ loc).loc    = loc
+  (DLam _ loc).loc      = loc
+  (NAT loc).loc         = loc
+  (Nat _ loc).loc       = loc
+  (STRING loc).loc      = loc
+  (Str _ loc).loc       = loc
+  (Succ _ loc).loc      = loc
+  (BOX _ _ loc).loc     = loc
+  (Box _ loc).loc       = loc
+  (Let _ _ _ loc).loc   = loc
+  (E e).loc             = e.loc
+  (CloT (Sub t _)).loc  = t.loc
+  (DCloT (Sub t _)).loc = t.loc
+
+export
+Located1 f => Located (ScopedBody s f n) where
+  (Y t).loc = t.loc
+  (N t).loc = t.loc
+
+export
+Located1 f => Located (Scoped s f n) where
+  t.loc = t.body.loc
+
+
+export
+Relocatable (Elim d n) where
+  setLoc loc (F x u _) = F x u loc
+  setLoc loc (B i _) = B i loc
+  setLoc loc (App fun arg _) = App fun arg loc
+  setLoc loc (CasePair qty pair ret body _) =
+    CasePair qty pair ret body loc
+  setLoc loc (Fst pair _) = Fst pair loc
+  setLoc loc (Snd pair _) = Fst pair loc
+  setLoc loc (CaseEnum qty tag ret arms _) =
+    CaseEnum qty tag ret arms loc
+  setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
+    CaseNat qty qtyIH nat ret zero succ loc
+  setLoc loc (CaseBox qty box ret body _) =
+    CaseBox qty box ret body loc
+  setLoc loc (DApp fun arg _) =
+    DApp fun arg loc
+  setLoc loc (Ann tm ty _) =
+    Ann tm ty loc
+  setLoc loc (Coe ty p q val _) =
+    Coe ty p q val loc
+  setLoc loc (Comp ty p q val r zero one _) =
+    Comp ty p q val r zero one loc
+  setLoc loc (TypeCase ty ret arms def _) =
+    TypeCase ty ret arms def loc
+  setLoc loc (CloE (Sub term subst)) =
+    CloE $ Sub (setLoc loc term) subst
+  setLoc loc (DCloE (Sub term subst)) =
+    DCloE $ Sub (setLoc loc term) subst
+
+export
+Relocatable (Term d n) where
+  setLoc loc (TYPE l _) = TYPE l loc
+  setLoc loc (IOState _) = IOState loc
+  setLoc loc (Pi qty arg res _) = Pi qty arg res loc
+  setLoc loc (Lam body _) = Lam body loc
+  setLoc loc (Sig fst snd _) = Sig fst snd loc
+  setLoc loc (Pair fst snd _) = Pair fst snd loc
+  setLoc loc (Enum cases _) = Enum cases loc
+  setLoc loc (Tag tag _) = Tag tag loc
+  setLoc loc (Eq ty l r _) = Eq ty l r loc
+  setLoc loc (DLam body _) = DLam body loc
+  setLoc loc (NAT _) = NAT loc
+  setLoc loc (Nat n _) = Nat n loc
+  setLoc loc (Succ p _) = Succ p loc
+  setLoc loc (STRING _) = STRING loc
+  setLoc loc (Str s _) = Str s loc
+  setLoc loc (BOX qty ty _) = BOX qty ty loc
+  setLoc loc (Box val _) = Box val loc
+  setLoc loc (Let qty rhs body _) = Let qty rhs body loc
+  setLoc loc (E e) = E $ setLoc loc e
+  setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
+  setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
+
+export
+Relocatable1 f => Relocatable (ScopedBody s f n) where
+  setLoc loc (Y body) = Y $ setLoc loc body
+  setLoc loc (N body) = N $ setLoc loc body
+
+export
+Relocatable1 f => Relocatable (Scoped s f n) where
+  setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
+
+
+||| 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
-Arr : (qty : Qty) -> (arg, res : Term d n) -> Term d n
+LamN : (body : Term d n) -> (loc : Loc) -> Term d n
-Arr {qty, arg, res} = Pi {qty, x = "_", arg, res = TUnused res}
+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}
+
+||| 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}
+
+||| 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 -> Term d n
+FT : Name -> Universe -> Loc -> Term d n
-FT = E . F
+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) => Elim d n
+BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n
-BV i = B $ V i
+BV i loc = B (V i) loc
 
 ||| same as `BV` but as a term
 public export %inline
-BVT : (i : Nat) -> (0 _ : LT i n) => Term d n
+BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
-BVT i = E $ BV i
+BVT i loc = E $ BV i loc
+
+public export %inline
+Zero : Loc -> Term d n
+Zero = Nat 0
+
+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
+
+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

lib/Quox/Syntax/Term/Pretty.idr

@@ -1,86 +1,623 @@
 module Quox.Syntax.Term.Pretty
 
 import Quox.Syntax.Term.Base
-import Quox.Syntax.Term.Split
 import Quox.Syntax.Term.Subst
+import Quox.Context
 import Quox.Pretty
 
 import Data.Vect
+import Derive.Prelude
 
 %default total
+%language ElabReflection
 
 
-parameters {auto _ : Pretty.HasEnv m}
+export
-  private %inline arrowD : m (Doc HL)
+prettyUniverse : {opts : _} -> Universe -> Eff Pretty (Doc opts)
-  arrowD = hlF Syntax $ ifUnicode "→" "->"
+prettyUniverse = hl Universe . text . show
 
-  private %inline lamD : m (Doc HL)
-  lamD = hlF Syntax $ ifUnicode "λ" "fun"
 
-  private %inline annD : m (Doc HL)
+export
-  annD = hlF Syntax $ ifUnicode "⦂" "::"
+prettyTerm : {opts : _} -> BContext d -> BContext n -> Term d n ->
+             Eff Pretty (Doc opts)
 
-private %inline typeD : Doc HL
+export
-typeD = hl Syntax "Type"
+prettyElim : {opts : _} -> BContext d -> BContext n -> Elim d n ->
+             Eff Pretty (Doc opts)
 
-private %inline colonD : Doc HL
+private
-colonD = hl Syntax ":"
+BTelescope : Nat -> Nat -> Type
+BTelescope = Telescope' BindName
 
-mutual
-  export covering
-  PrettyHL (Term d n) where
-    prettyM (TYPE l) =
-      parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l)
-    prettyM (Pi qty x s t) =
-      parensIfM Outer $ hang 2 $
-        !(prettyBinder [qty] x s) <++> !arrowD
-          <//> !(under T x $ prettyM t)
-    prettyM (Lam x t) =
-      parensIfM Outer $
-        sep [!lamD, hl TVar !(prettyM x), !arrowD]
-          <//> !(under T x $ prettyM t)
-    prettyM (E e) =
-      pure $ hl Delim "[" <+> !(prettyM e) <+> hl Delim "]"
-    prettyM (CloT s th) =
-      parensIfM SApp . hang 2 =<<
-        [|withPrec SApp (prettyM s) </> prettyTSubst th|]
-    prettyM (DCloT s th) =
-      parensIfM SApp . hang 2 =<<
-        [|withPrec SApp (prettyM s) </> prettyDSubst th|]
 
-  export covering
+private
-  PrettyHL (Elim d n) where
+superscript : String -> String
-    prettyM (F x) =
+superscript = pack . map sup . unpack where
-      hl' Free <$> prettyM x
+  sup : Char -> Char
-    prettyM (B i) =
+  sup c = case c of
-      prettyVar TVar TVarErr (!ask).tnames i
+    '0' => '⁰'; '1' => '¹'; '2' => '²'; '3' => '³'; '4' => '⁴'
-    prettyM (e :@ s) =
+    '5' => '⁵'; '6' => '⁶'; '7' => '⁷'; '8' => '⁸'; '9' => '⁹'; _ => c
-      let GotArgs f args _ = getArgs' e [s] in
-      parensIfM App =<< withPrec Arg
-        [|prettyM f <//> (align . sep <$> traverse prettyM args)|]
-    prettyM (s :# a) =
-      parensIfM Ann $ hang 2 $
-        !(withPrec AnnL $ prettyM s) <++> !annD
-          <//> !(withPrec Ann $ prettyM a)
-    prettyM (CloE e th)  =
-      parensIfM SApp . hang 2 =<<
-        [|withPrec SApp (prettyM e) </> prettyTSubst th|]
-    prettyM (DCloE e th) =
-      parensIfM SApp . hang 2 =<<
-        [|withPrec SApp (prettyM e) </> prettyDSubst th|]
 
-  export covering
-  PrettyHL (ScopeTerm d n) where
-    prettyM body = prettyM $ fromScopeTerm body
 
-  export covering
+private
-  prettyTSubst : Pretty.HasEnv m => TSubst d from to -> m (Doc HL)
+PiBind : Nat -> Nat -> Type
-  prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s
+PiBind d n = (Qty, BindName, Term d n)
 
-  export covering
+private
-  prettyBinder : Pretty.HasEnv m => List Qty -> Name -> Term d n -> m (Doc HL)
+pbname : PiBind d n -> BindName
-  prettyBinder pis x a =
+pbname (_, x, _) = x
-    pure $ parens $ hang 2 $
+
-      hsep [hl TVar !(prettyM x),
+private
-            sep [!(prettyQtyBinds pis),
+record SplitPi d n where
-                 hsep [colonD, !(withPrec Outer $ prettyM a)]]]
+  constructor MkSplitPi
+  {0 inner : Nat}
+  binds : Telescope (PiBind d) n inner
+  cod   : Term d inner
+
+private
+splitPi : Telescope (PiBind d) n n' -> Term d n' -> SplitPi d n
+splitPi binds (Pi qty arg res _) =
+  splitPi (binds :< (qty, res.name, arg)) $
+    assert_smaller res $ pushSubsts' res.term
+splitPi binds cod = MkSplitPi {binds, cod}
+
+private
+prettyPiBind1 : {opts : _} ->
+                Qty -> BindName -> BContext d -> BContext n -> Term d n ->
+                Eff Pretty (Doc opts)
+prettyPiBind1 pi (BN Unused _) dnames tnames s =
+  hcat <$> sequence
+    [prettyQty pi, dotD,
+     withPrec Arg $ assert_total prettyTerm dnames tnames s]
+prettyPiBind1 pi x dnames tnames s = hcat <$> sequence
+  [prettyQty pi, dotD,
+   hl Delim $ text "(",
+   hsep <$> sequence
+     [prettyTBind x, hl Delim $ text ":",
+      withPrec Outer $ assert_total prettyTerm dnames tnames s],
+   hl Delim $ text ")"]
+
+private
+prettyPiBinds : {opts : _} ->
+                BContext d -> BContext n ->
+                Telescope (PiBind d) n n' ->
+                Eff Pretty (SnocList (Doc opts))
+prettyPiBinds _ _ [<] = pure [<]
+prettyPiBinds dnames tnames (binds :< (q, x, t)) =
+  let tnames' = tnames . map pbname binds in
+  [|prettyPiBinds dnames tnames binds :<
+    prettyPiBind1 q x dnames tnames' t|]
+
+
+private
+SigBind : Nat -> Nat -> Type
+SigBind d n = (BindName, Term d n)
+
+private
+record SplitSig d n where
+  constructor MkSplitSig
+  {0 inner : Nat}
+  binds : Telescope (SigBind d) n inner
+  last  : Term d inner
+
+private
+splitSig : Telescope (SigBind d) n n' -> Term d n' -> SplitSig d n
+splitSig binds (Sig fst snd _) =
+  splitSig (binds :< (snd.name, fst)) $
+    assert_smaller snd $ pushSubsts' snd.term
+splitSig binds last = MkSplitSig {binds, last}
+
+private
+prettySigBind1 : {opts : _} ->
+                 BindName -> BContext d -> BContext n -> Term d n ->
+                 Eff Pretty (Doc opts)
+prettySigBind1 (BN Unused _) dnames tnames s =
+  withPrec InTimes $ assert_total prettyTerm dnames tnames s
+prettySigBind1 x dnames tnames s = hcat <$> sequence
+  [hl Delim $ text "(",
+   hsep <$> sequence
+     [prettyTBind x, hl Delim $ text ":",
+      withPrec Outer $ assert_total prettyTerm dnames tnames s],
+   hl Delim $ text ")"]
+
+private
+prettySigBinds : {opts : _} ->
+                 BContext d -> BContext n ->
+                 Telescope (SigBind d) n n' ->
+                 Eff Pretty (SnocList (Doc opts))
+prettySigBinds _ _ [<] = pure [<]
+prettySigBinds dnames tnames (binds :< (x, t)) =
+  let tnames' = tnames . map fst binds in
+  [|prettySigBinds dnames tnames binds :<
+    prettySigBind1 x dnames tnames' t|]
+
+
+private
+prettyTypeLine : {opts : _} ->
+                 BContext d -> BContext n ->
+                 DScopeTerm d n ->
+                 Eff Pretty (Doc opts)
+prettyTypeLine dnames tnames (S _ (N body)) =
+  withPrec Arg (prettyTerm dnames tnames body)
+prettyTypeLine dnames tnames (S [< i] (Y body)) =
+  parens =<< do
+    i'  <- prettyDBind i
+    ty' <- withPrec Outer $ prettyTerm (dnames :< i) tnames body
+    pure $ sep [hsep [i', !darrowD], ty']
+
+
+private
+data NameSort = T | D
+%runElab derive "NameSort" [Eq]
+
+private
+NameChunks : Type
+NameChunks = SnocList (NameSort, SnocList BindName)
+
+private
+record SplitLams d n where
+  constructor MkSplitLams
+  {0 dinner, ninner : Nat}
+  dnames : BTelescope d dinner
+  tnames : BTelescope n ninner
+  chunks : NameChunks
+  body   : Term dinner ninner
+
+private
+splitLams : Term d n -> SplitLams d n
+splitLams s = go [<] [<] [<] (pushSubsts' s)
+where
+  push : NameSort -> BindName -> NameChunks -> NameChunks
+  push s y [<] = [< (s, [< y])]
+  push s y (xss :< (s', xs)) =
+    if s == s' then xss :< (s', xs :< y)
+    else xss :< (s', xs) :< (s, [< y])
+
+  go : BTelescope d d' -> BTelescope n n' ->
+       SnocList (NameSort, SnocList BindName) ->
+       Term d' n' -> SplitLams d n
+  go dnames tnames chunks (Lam b _) =
+    go dnames (tnames :< b.name) (push T b.name chunks) $
+       assert_smaller b $ pushSubsts' b.term
+  go dnames tnames chunks (DLam b _) =
+    go (dnames :< b.name) tnames (push D b.name chunks) $
+       assert_smaller b $ pushSubsts' b.term
+  go dnames tnames chunks s =
+    MkSplitLams dnames tnames chunks s
+
+
+private
+splitTuple : SnocList (Term d n) -> Term d n -> SnocList (Term d n)
+splitTuple ss p@(Pair t1 t2 _) =
+  splitTuple (ss :< t1) $ assert_smaller p $ pushSubsts' t2
+splitTuple ss t = ss :< t
+
+
+private
+prettyTArg : {opts : _} -> BContext d -> BContext n ->
+             Term d n -> Eff Pretty (Doc opts)
+prettyTArg dnames tnames s =
+  withPrec Arg $ assert_total prettyTerm dnames tnames s
+
+private
+prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
+prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
+
+private
+splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
+splitApps e = go [] (pushSubsts' e)
+where
+  go : List (Either (Dim d) (Term d n)) -> Elim d n ->
+       (Elim d n, List (Either (Dim d) (Term d n)))
+  go xs e@(App  f s _) =
+    go (Right s :: xs) $ assert_smaller e $ pushSubsts' f
+  go xs e@(DApp f p _) =
+    go (Left  p :: xs) $ assert_smaller e $ pushSubsts' f
+  go xs s = (s, xs)
+
+private
+prettyDTApps : {opts : _} ->
+               BContext d -> BContext n ->
+               Elim d n -> List (Either (Dim d) (Term d n)) ->
+               Eff Pretty (Doc opts)
+prettyDTApps dnames tnames f xs = do
+  f  <- withPrec Arg $ assert_total prettyElim dnames tnames f
+  xs <- for xs $ either (prettyDArg dnames) (prettyTArg dnames tnames)
+  parensIfM App =<< prettyAppD f xs
+
+
+private
+record CaseArm opts d n where
+  constructor MkCaseArm
+  pat    : Doc opts
+  dbinds : BTelescope d dinner -- 🍴
+  tbinds : BTelescope n ninner
+  body   : Term dinner ninner
+
+parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
+  private
+  prettyCaseArm : CaseArm opts d n -> Eff Pretty (Doc opts)
+  prettyCaseArm (MkCaseArm pat dbinds tbinds body) = do
+    body <- withPrec Outer $ assert_total
+            prettyTerm (dnames . dbinds) (tnames . tbinds) body
+    header <- (pat <++>) <$> darrowD
+    pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
+
+  private
+  prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts))
+  prettyCaseBody xs = traverse prettyCaseArm xs
+
+private
+prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts)
+prettyCompPat e x = [|prettyDimConst e <++> prettyDBind x|]
+
+private
+prettyCompArm : {opts : _} -> BContext d -> BContext n ->
+                DimConst -> DScopeTerm d n -> Eff Pretty (Doc opts)
+prettyCompArm dnames tnames e s = prettyCaseArm dnames tnames $
+  MkCaseArm !(prettyCompPat e s.name) [< s.name] [<] s.term
+
+private
+layoutComp : {opts : _} ->
+             (typq : List (Doc opts)) -> (val, r : Doc opts) ->
+             (arms : List (Doc opts)) -> Eff Pretty (Doc opts)
+layoutComp typq val r arms = do
+  comp <- compD; lb <- hl Delim "{"; rb <- hl Delim "}"
+  ind  <- askAt INDENT
+  pure $ ifMultiline
+    (hsep $ concat {t = List} [[comp], typq, [val, r, lb], arms, [rb]]) $
+    (comp <++>
+      vsep [sep typq, val, r <++> lb, indent ind $ vsep arms, rb]) <|>
+    (vsep $ (comp ::) $ map (indent ind) $ concat {t = List}
+      [typq, [val, r <++> lb], map (indent ind) arms, [rb]])
+
+
+export
+prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
+prettyEnum cases =
+  tightBraces =<<
+  fillSeparateTight !commaD <$>
+  traverse (hl Constant . Doc.text . quoteTag) cases
+
+private
+prettyCaseRet : {opts : _} ->
+                BContext d -> BContext n ->
+                ScopeTerm d n -> Eff Pretty (Doc opts)
+prettyCaseRet dnames tnames body = withPrec Outer $ case body of
+  S _     (N tm) => assert_total prettyTerm dnames tnames tm
+  S [< x] (Y tm) => do
+    header <- [|prettyTBind x <++> darrowD|]
+    body   <- assert_total prettyTerm dnames (tnames :< x) tm
+    hangDSingle header body
+
+private
+prettyCase_ : {opts : _} ->
+              BContext d -> BContext n ->
+              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])
+
+private
+prettyCase : {opts : _} ->
+             BContext d -> BContext n ->
+             Qty -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) ->
+             Eff Pretty (Doc opts)
+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
+isDefaultDir _ _ = False
+
+
+-- [fixme] use telescopes in Scoped
+private
+toTel : BContext s -> BTelescope n (s + n)
+toTel [<]        = [<]
+toTel (ctx :< x) = toTel ctx :< x
+
+private
+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] =
+  parens . hsep =<< sequence [prettyTBind a, timesD, prettyTBind b]
+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
+
+
+prettyLambda : {opts : _} -> BContext d -> BContext n ->
+               Term d n -> Eff Pretty (Doc opts)
+prettyLambda dnames tnames s =
+  parensIfM Outer =<< do
+    let MkSplitLams {dnames = ds, tnames = ts, chunks, body} = splitLams s
+    hangDSingle !(header chunks)
+      !(assert_total prettyTerm (dnames . ds) (tnames . ts) body)
+where
+  introChar : NameSort -> Eff Pretty (Doc opts)
+  introChar T = lamD
+  introChar D = dlamD
+
+  prettyBind : NameSort -> BindName -> Eff Pretty (Doc opts)
+  prettyBind T = prettyTBind
+  prettyBind D = prettyDBind
+
+  header1 : NameSort -> List BindName -> Eff Pretty (Doc opts)
+  header1 s xs = hsep <$> sequence
+    [introChar s, sep <$> traverse (prettyBind s) xs, darrowD]
+
+  header : NameChunks -> Eff Pretty (Doc opts)
+  header cs = sep <$> traverse (\(s, xs) => header1 s (toList xs)) (toList cs)
+
+
+prettyDisp : {opts : _} -> Universe -> Eff Pretty (Maybe (Doc opts))
+prettyDisp 0 = pure Nothing
+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 (Pi qty arg res _) =
+  parensIfM Outer =<< do
+    let MkSplitPi {binds, cod} = splitPi [< (qty, res.name, arg)] res.term
+    arr   <- arrowD
+    lines <- map (<++> arr) <$> prettyPiBinds dnames tnames binds
+    let tnames = tnames . map pbname binds
+    cod <- withPrec Outer $ prettyTerm dnames tnames (assert_smaller res cod)
+    pure $ sepSingle $ toList $ lines :< cod
+
+prettyTerm dnames tnames s@(Lam {}) =
+  prettyLambda dnames tnames s
+
+prettyTerm dnames tnames (Sig fst snd _) =
+  parensIfM Times =<< do
+    let MkSplitSig {binds, last} = splitSig [< (snd.name, fst)] snd.term
+    times <- timesD
+    lines <- map (<++> times) <$> prettySigBinds dnames tnames binds
+    let tnames = tnames . map Builtin.fst binds
+    last <- withPrec InTimes $
+            prettyTerm dnames tnames (assert_smaller snd last)
+    pure $ sepSingle $ toList $ lines :< last
+
+prettyTerm dnames tnames p@(Pair fst snd _) =
+  parens =<< do
+    let elems = splitTuple [< fst] snd
+    lines <- for elems $ \t =>
+      withPrec Outer $ prettyTerm dnames tnames $ assert_smaller p t
+    pure $ separateTight !commaD lines
+
+prettyTerm dnames tnames (Enum cases _) =
+  prettyEnum $ SortedSet.toList 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 ty l r _) =
+  parensIfM App =<< do
+    ty <- prettyTypeLine dnames tnames ty
+    l  <- withPrec Arg $ prettyTerm dnames tnames l
+    r  <- withPrec Arg $ prettyTerm dnames tnames r
+    prettyAppD !eqD [ty, l, r]
+
+prettyTerm dnames tnames s@(DLam {}) =
+  prettyLambda dnames tnames s
+
+prettyTerm dnames tnames (NAT _) = natD
+prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n
+prettyTerm dnames tnames (Succ p _) =
+  parensIfM App =<<
+  prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)]
+
+prettyTerm dnames tnames (STRING _) = stringD
+prettyTerm dnames tnames (Str s _) = prettyStrLit s
+
+prettyTerm dnames tnames (BOX qty ty _) =
+  bracks . hcat =<<
+    sequence [prettyQty qty, dotD,
+              withPrec Outer $ prettyTerm dnames tnames 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 t0@(CloT (Sub t ph)) =
+  prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' id ph t
+
+prettyTerm dnames tnames t0@(DCloT (Sub t ph)) =
+  prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' ph id t
+
+prettyElim dnames tnames (F x u _) = do
+  x <- prettyFree x
+  u <- prettyDisp u
+  pure $ maybe x (x <+>) u
+
+prettyElim dnames tnames (B i _) =
+  prettyTBind $ tnames !!! i
+
+prettyElim dnames tnames e@(App {}) =
+  let (f, xs) = splitApps e in
+  prettyDTApps dnames tnames f xs
+
+prettyElim dnames tnames (CasePair qty pair ret body _) = do
+  let [< x, y] = body.names
+  pat <- parens . hsep =<< sequence
+         [[|prettyTBind x <+> commaD|], prettyTBind y]
+  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
+  prettyCase dnames tnames qty tag ret arms
+
+prettyElim dnames tnames (CaseNat qty qtyIH nat ret zero succ _) = do
+  let zarm = MkCaseArm !zeroD [<] [<] zero
+      [< p, ih] = succ.names
+  spat0 <- [|succD <++> prettyTBind p|]
+  ihpat0 <- map hcat $ sequence [prettyQty qtyIH, dotD, prettyTBind ih]
+  spat <- if ih.val == Unused
+          then pure spat0
+          else pure $ hsep [spat0 <+> !commaD, ihpat0]
+  let sarm = MkCaseArm spat [<] [< p, ih] succ.term
+  prettyCase dnames tnames qty nat ret [zarm, sarm]
+
+prettyElim dnames tnames (CaseBox qty box ret body _) = do
+  pat <- bracks =<< prettyTBind body.name
+  let arm = MkCaseArm pat [<] [< body.name] body.term
+  prettyCase dnames tnames qty box ret [arm]
+
+prettyElim dnames tnames e@(DApp {}) =
+  let (f, xs) = splitApps e in
+  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
+
+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]
+
+prettyElim dnames tnames e@(Comp ty p q val r zero one _) =
+  parensIfM App =<< do
+    ty   <- assert_total $ prettyTypeLine dnames tnames $ SN ty
+    pq   <- sep <$> sequence [prettyDArg dnames p, prettyDArg dnames q]
+    val  <- prettyTArg dnames tnames val
+    r    <- prettyDArg dnames r
+    arm0 <- [|prettyCompArm dnames tnames Zero zero <+> semiD|]
+    arm1 <- prettyCompArm dnames tnames One one
+    ind  <- askAt INDENT
+    layoutComp [ty, pq] val r [arm0, arm1]
+
+prettyElim dnames tnames (TypeCase ty ret arms def _) = do
+  arms <- for (toList arms) $ \(k ** body) => do
+    pat <- prettyTyCasePat k body.names
+    pure $ MkCaseArm pat [<] (toTel body.names) body.term
+  let darm = MkCaseArm !undD [<] [<] def
+  prettyCase_ dnames tnames !typecaseD ty (SN ret) $ arms ++ [darm]
+
+prettyElim dnames tnames e0@(CloE (Sub e ph)) =
+  prettyElim dnames tnames $ assert_smaller e0 $ pushSubstsWith' id ph e
+
+prettyElim dnames tnames e0@(DCloE (Sub e ph)) =
+  prettyElim dnames tnames $ assert_smaller e0 $ pushSubstsWith' ph id e

lib/Quox/Syntax/Term/Reduce.idr

@@ -1,299 +0,0 @@
-module Quox.Syntax.Term.Reduce
-
-import Quox.Syntax.Term.Base
-import Quox.Syntax.Term.Subst
-
-%default total
-
-
-mutual
-  ||| true if a term has a closure or dimension closure at the top level,
-  ||| or is `E` applied to such an elimination
-  public export %inline
-  topCloT : Term d n -> Bool
-  topCloT (CloT  _ _) = True
-  topCloT (DCloT _ _) = True
-  topCloT (E e)       = topCloE e
-  topCloT _           = False
-
-  ||| true if an elimination has a closure or dimension closure at the top level
-  public export %inline
-  topCloE : Elim d n -> Bool
-  topCloE (CloE  _ _) = True
-  topCloE (DCloE _ _) = True
-  topCloE _           = False
-
-
-public export IsNotCloT : Term d n -> Type
-IsNotCloT = So . not . topCloT
-
-||| a term which is not a top level closure
-public export NotCloTerm : Nat -> Nat -> Type
-NotCloTerm d n = Subset (Term d n) IsNotCloT
-
-public export IsNotCloE : Elim d n -> Type
-IsNotCloE = So . not . topCloE
-
-||| an elimination which is not a top level closure
-public export NotCloElim : Nat -> Nat -> Type
-NotCloElim d n = Subset (Elim d n) IsNotCloE
-
-public export %inline
-ncloT : (t : Term d n) -> (0 _ : IsNotCloT t) => NotCloTerm d n
-ncloT t @{p} = Element t p
-
-public export %inline
-ncloE : (t : Elim d n) -> (0 _ : IsNotCloE t) => NotCloElim d n
-ncloE e @{p} = Element e p
-
-
-
-mutual
-  ||| if the input term has any top-level closures, push them under one layer of
-  ||| syntax
-  export %inline
-  pushSubstsT : Term d n -> NotCloTerm d n
-  pushSubstsT s = pushSubstsTWith id id s
-
-  ||| if the input elimination has any top-level closures, push them under one
-  ||| layer of syntax
-  export %inline
-  pushSubstsE : Elim d n -> NotCloElim d n
-  pushSubstsE e = pushSubstsEWith id id e
-
-  export
-  pushSubstsTWith : DSubst dfrom dto -> TSubst dto from to ->
-                    Term dfrom from -> NotCloTerm dto to
-  pushSubstsTWith th ph (TYPE l) =
-    ncloT $ TYPE l
-  pushSubstsTWith th ph (Pi qty x a body) =
-    ncloT $ Pi qty x (subs a th ph) (subs body th ph)
-  pushSubstsTWith th ph (Lam x body) =
-    ncloT $ Lam x $ subs body th ph
-  pushSubstsTWith th ph (E e) =
-    let Element e _ = pushSubstsEWith th ph e in ncloT $ E e
-  pushSubstsTWith th ph (CloT  s ps) =
-    pushSubstsTWith th (comp' th ps ph) s
-  pushSubstsTWith th ph (DCloT s ps) =
-    pushSubstsTWith (ps . th) ph s
-
-  export
-  pushSubstsEWith : DSubst dfrom dto -> TSubst dto from to ->
-                    Elim dfrom from -> NotCloElim dto to
-  pushSubstsEWith th ph (F x) =
-    ncloE $ F x
-  pushSubstsEWith th ph (B i) =
-    let res = ph !! i in
-    case choose $ topCloE res of
-         Left  _ => assert_total pushSubstsE res
-         Right _ => ncloE res
-  pushSubstsEWith th ph (f :@ s) =
-    ncloE $ subs f th ph :@ subs s th ph
-  pushSubstsEWith th ph (s :# a) =
-    ncloE $ subs s th ph :# subs a th ph
-  pushSubstsEWith th ph (CloE  e ps) =
-    pushSubstsEWith th (comp' th ps ph) e
-  pushSubstsEWith th ph (DCloE e ps) =
-    pushSubstsEWith (ps . th) ph e
-
-
-parameters (th : DSubst dfrom dto) (ph : TSubst dto from to)
-  public export %inline
-  pushSubstsTWith' : Term dfrom from -> Term dto to
-  pushSubstsTWith' s = (pushSubstsTWith th ph s).fst
-
-  public export %inline
-  pushSubstsEWith' : Elim dfrom from -> Elim dto to
-  pushSubstsEWith' e = (pushSubstsEWith th ph e).fst
-
-
-public export %inline
-pushSubstsT' : Term d n -> Term d n
-pushSubstsT' s = (pushSubstsT s).fst
-
-public export %inline
-pushSubstsE' : Elim d n -> Elim d n
-pushSubstsE' e = (pushSubstsE e).fst
-
-
-mutual
-  -- tightening a term/elim also causes substitutions to be pushed through.
-  -- this is because otherwise a variable in an unused part of the subst
-  -- would cause it to incorrectly fail
-
-  export covering
-  Tighten (Term d) where
-    tighten p (TYPE l) =
-      pure $ TYPE l
-    tighten p (Pi qty x arg res) =
-      Pi qty x <$> tighten p arg
-               <*> tighten p res
-    tighten p (Lam x body) =
-      Lam x <$> tighten p body
-    tighten p (E e) =
-      E <$> tighten p e
-    tighten p (CloT tm th) =
-      tighten p $ pushSubstsTWith' id th tm
-    tighten p (DCloT tm th) =
-      tighten p $ pushSubstsTWith' th id tm
-
-  export covering
-  Tighten (Elim d) where
-    tighten p (F x) =
-      pure $ F x
-    tighten p (B i) =
-      B <$> tighten p i
-    tighten p (fun :@ arg) =
-      [|tighten p fun :@ tighten p arg|]
-    tighten p (tm :# ty) =
-      [|tighten p tm :# tighten p ty|]
-    tighten p (CloE el th) =
-      tighten p $ pushSubstsEWith' id th el
-    tighten p (DCloE el th) =
-      tighten p $ pushSubstsEWith' th id el
-
-  export covering
-  Tighten (ScopeTerm d) where
-    tighten p (TUsed   body) = TUsed   <$> tighten (Keep p) body
-    tighten p (TUnused body) = TUnused <$> tighten p body
-
-
-public export %inline
-weakT : Term d n -> Term d (S n)
-weakT t = t //. shift 1
-
-public export %inline
-weakE : Elim d n -> Elim d (S n)
-weakE t = t //. shift 1
-
-
-mutual
-  public export
-  data IsRedexT : Term d n -> Type where
-    IsUpsilonT : IsRedexT $ E (_ :# _)
-    IsCloT     : IsRedexT $ CloT {}
-    IsDCloT    : IsRedexT $ DCloT {}
-    IsERedex   : IsRedexE e -> IsRedexT $ E e
-
-  public export %inline
-  NotRedexT : Term d n -> Type
-  NotRedexT = Not . IsRedexT
-
-  public export
-  data IsRedexE : Elim d n -> Type where
-    IsUpsilonE : IsRedexE $ E _ :# _
-    IsBetaLam  : IsRedexE $ (Lam {} :# Pi {}) :@ _
-    IsCloE     : IsRedexE $ CloE {}
-    IsDCloE    : IsRedexE $ DCloE {}
-
-  public export %inline
-  NotRedexE : Elim d n -> Type
-  NotRedexE = Not . IsRedexE
-
-
-mutual
-  export %inline
-  isRedexT : (t : Term d n) -> Dec (IsRedexT t)
-  isRedexT (E (tm :# ty)) = Yes IsUpsilonT
-  isRedexT (CloT {})      = Yes IsCloT
-  isRedexT (DCloT {})     = Yes IsDCloT
-  isRedexT (E (CloE  {})) = Yes $ IsERedex IsCloE
-  isRedexT (E (DCloE {})) = Yes $ IsERedex IsDCloE
-  isRedexT (E e@(_ :@ _)) with (isRedexE e)
-    _ | Yes yes = Yes $ IsERedex yes
-    _ | No  no  = No \case IsERedex p => no p
-  isRedexT (TYPE {}) = No $ \x => case x of {}
-  isRedexT (Pi   {}) = No $ \x => case x of {}
-  isRedexT (Lam  {}) = No $ \x => case x of {}
-  isRedexT (E (F _)) = No $ \x => case x of IsERedex _ impossible
-  isRedexT (E (B _)) = No $ \x => case x of IsERedex _ impossible
-
-  export %inline
-  isRedexE : (e : Elim d n) -> Dec (IsRedexE e)
-  isRedexE (E _ :# _)                    = Yes IsUpsilonE
-  isRedexE ((Lam {} :# Pi {}) :@ _)      = Yes IsBetaLam
-  isRedexE (CloE {})                     = Yes IsCloE
-  isRedexE (DCloE {})                    = Yes IsDCloE
-  isRedexE (F x)                         = No $ \x => case x of {}
-  isRedexE (B i)                         = No $ \x => case x of {}
-  isRedexE (F _                    :@ _) = No $ \x => case x of {}
-  isRedexE (B _                    :@ _) = No $ \x => case x of {}
-  isRedexE (_ :@ _                 :@ _) = No $ \x => case x of {}
-  isRedexE ((TYPE _   :# _)        :@ _) = No $ \x => case x of {}
-  isRedexE ((Pi {}    :# _)        :@ _) = No $ \x => case x of {}
-  isRedexE ((Lam {}   :# TYPE _)   :@ _) = No $ \x => case x of {}
-  isRedexE ((Lam {}   :# Lam {})   :@ _) = No $ \x => case x of {}
-  isRedexE ((Lam {}   :# E _)      :@ _) = No $ \x => case x of {}
-  isRedexE ((Lam {}   :# CloT {})  :@ _) = No $ \x => case x of {}
-  isRedexE ((Lam {}   :# DCloT {}) :@ _) = No $ \x => case x of {}
-  isRedexE ((E _      :# _)        :@ _) = No $ \x => case x of {}
-  isRedexE ((CloT {}  :# _)        :@ _) = No $ \x => case x of {}
-  isRedexE ((DCloT {} :# _)        :@ _) = No $ \x => case x of {}
-  isRedexE (CloE {}                :@ _) = No $ \x => case x of {}
-  isRedexE (DCloE {}               :@ _) = No $ \x => case x of {}
-  isRedexE (TYPE _   :# _)               = No $ \x => case x of {}
-  isRedexE (Pi {}    :# _)               = No $ \x => case x of {}
-  isRedexE (Lam {}   :# _)               = No $ \x => case x of {}
-  isRedexE (CloT {}  :# _)               = No $ \x => case x of {}
-  isRedexE (DCloT {} :# _)               = No $ \x => case x of {}
-
-
-public export %inline
-RedexTerm : Nat -> Nat -> Type
-RedexTerm d n = Subset (Term d n) IsRedexT
-
-public export %inline
-NonRedexTerm : Nat -> Nat -> Type
-NonRedexTerm d n = Subset (Term d n) NotRedexT
-
-
-public export %inline
-RedexElim : Nat -> Nat -> Type
-RedexElim d n = Subset (Elim d n) IsRedexE
-
-public export %inline
-NonRedexElim : Nat -> Nat -> Type
-NonRedexElim d n = Subset (Elim d n) NotRedexE
-
-
-||| substitute a term with annotation for the bound variable of a `ScopeTerm`
-export %inline
-substScope : (arg, argTy : Term d n) -> (body : ScopeTerm d n) -> Term d n
-substScope arg argTy (TUsed   body) = body // one (arg :# argTy)
-substScope arg argTy (TUnused body) = body
-
-mutual
-  export %inline
-  stepT' : (s : Term d n) -> IsRedexT s -> Term d n
-  stepT' (E (s :# _)) IsUpsilonT   = s
-  stepT' (CloT  s th) IsCloT       = pushSubstsTWith' id th s
-  stepT' (DCloT s th) IsDCloT      = pushSubstsTWith' th id s
-  stepT' (E e)        (IsERedex p) = E $ stepE' e p
-
-  export %inline
-  stepE' : (e : Elim d n) -> IsRedexE e -> Elim d n
-  stepE' (E e :# _) IsUpsilonE = e
-  stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam =
-    substScope s arg body :# substScope s arg res
-  stepE' (CloE  e th) IsCloE  = pushSubstsEWith' id th e
-  stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e
-
-export %inline
-stepT : (s : Term d n) -> Either (NotRedexT s) (Term d n)
-stepT s = case isRedexT s of Yes y => Right $ stepT' s y; No n => Left n
-
-export %inline
-stepE : (e : Elim d n) -> Either (NotRedexE e) (Elim d n)
-stepE e = case isRedexE e of Yes y => Right $ stepE' e y; No n => Left n
-
-export covering
-whnfT : Term d n -> NonRedexTerm d n
-whnfT s = case stepT s of
-               Right s'   => whnfT s'
-               Left  done => Element s done
-
-export covering
-whnfE : Elim d n -> NonRedexElim d n
-whnfE e = case stepE e of
-               Right e'   => whnfE e'
-               Left  done => Element e done

lib/Quox/Syntax/Term/Split.idr

@@ -1,82 +0,0 @@
-module Quox.Syntax.Term.Split
-
-import Quox.Syntax.Term.Base
-import Quox.Syntax.Term.Subst
-
-import Data.So
-import Data.Vect
-
-%default total
-
-
-public export %inline
-isLam : Term d n -> Bool
-isLam (Lam {}) = True
-isLam _        = False
-
-public export
-NotLam : Term d n -> Type
-NotLam = So . not . isLam
-
-
-public export %inline
-isApp : Elim d n -> Bool
-isApp ((:@) {}) = True
-isApp _         = False
-
-public export
-NotApp : Elim d n -> Type
-NotApp = So . not . isApp
-
-
-infixl 9 :@@
-||| apply multiple arguments at once
-public export %inline
-(:@@) : Elim d n -> List (Term d n) -> Elim d n
-f :@@ ss = foldl (:@) f ss
-
-public export
-record GetArgs (d, n : Nat) where
-  constructor GotArgs
-  fun      : Elim d n
-  args     : List (Term d n)
-  0 notApp : NotApp fun
-
-export
-getArgs' : Elim d n -> List (Term d n) -> GetArgs d n
-getArgs' fun args with (choose $ isApp fun)
-  getArgs' (f :@ a) args | Left yes = getArgs' f (a :: args)
-  _ | Right no = GotArgs {fun, args, notApp = no}
-
-||| splits an application into its head and arguments. if it's not an
-||| application then the list is just empty
-export %inline
-getArgs : Elim d n -> GetArgs d n
-getArgs e = getArgs' e []
-
-
-infixr 1 :\\
-public export
-(:\\) : Vect m Name -> Term d (m + n) -> Term d n
-[]      :\\ t = t
-x :: xs :\\ t = let t' = replace {p = Term _} (plusSuccRightSucc {}) t in
-                Lam x $ TUsed $ xs :\\ t'
-
-public export
-record GetLams (d, n : Nat) where
-  constructor GotLams
-  names    : Vect lams Name
-  body     : Term d rest
-  0 eq     : lams + n = rest
-  0 notLam : NotLam body
-
-public export
-getLams : Term d n -> GetLams d n
-getLams s with (choose $ isLam s)
-  getLams s@(Lam x body) | Left yes =
-    let inner = getLams $ assert_smaller s $ fromScopeTerm body in
-    GotLams {names  = x :: inner.names,
-             body   = inner.body,
-             eq     = plusSuccRightSucc {} `trans` inner.eq,
-             notLam = inner.notLam}
-  _ | Right no = GotLams {names = [], body = s, eq = Refl, notLam = no}