bit mask OPE stuff

.gitignore

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

CREDITS.md

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

Makefile

@@ -0,0 +1,38 @@
+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 extensional(ish) type theory
+# ![](qtuwu.png) quantitative observational 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

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

examples/all.quox

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

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

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

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

examples/fail.quox

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

examples/hello.quox

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

examples/io.quox

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

examples/list.quox

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

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

examples/misc.quox

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

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

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

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

exe/CompileMonad.idr

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

exe/Error.idr

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

exe/Main.idr

@@ -1,121 +1,16 @@
 module Main
 
-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 CompileMonad
+import public Quox.Name
+import public Quox.Syntax
+import public Quox.Equal
+import public Quox.Pretty
+import public Quox.Typechecker
 
-import System
-import System.File
-import Data.IORef
-import Control.Eff
+import Data.Nat
+import Data.Vect
+import Data.List
+import Control.ANSI
 
-%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
@@ -127,29 +22,22 @@ text _ =
    #" /_/"#,
    ""]
 
---   ["",
---    #" __ _ _  _ _____ __"#,
---    #"/ _` | || / _ \ \ /"#,
---    #"\__, |\_,_\___/_\_\"#,
---    #"   |_|"#,
---    ""]
-
 private
 qtuwu : PrettyOpts -> List String
 qtuwu opts =
   if opts.unicode then
     [#"      ___,-´⎠  "#,
      #"(·`──´ ◡    -´⎠"#,
-     #" \/\/──´⎞/`──´ "#,
-     #"  ⎜⎟───,-₎   ⎞ "#,
-     #"  ⎝⎠  (‾‾)   ⎟ "#,
+     #" \⋀/───´⎞/`──´ "#,
+     #"  ⋃────,-₎   ⎞ "#,
+     #"      (‾‾)   ⎟ "#,
      #"     (‾‾‾)   ⎟ "#]
   else
     [#"      ___,-´/  "#,
      #"(.`--´ u    -´/"#,
      #" \/\/--´|/`--´ "#,
-     #"  ||---,-,   \ "#,
-     #"  `´  (--)   | "#,
+     #"  U----,-,   \ "#,
+     #"      (--)   | "#,
      #"     (---)   | "#]
 
 private
@@ -163,4 +51,16 @@ 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

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

exe/Output.idr

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

exe/quox.ipkg

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

flake.lock

@@ -0,0 +1,605 @@
+{
+  "nodes": {
+    "Prettier": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1641402353,
+        "narHash": "sha256-gUE4aoLfXC4FTZWqCj5fAk6PTy/2Z/NihSuspRrDaOk=",
+        "owner": "Z-snails",
+        "repo": "prettier",
+        "rev": "0222ada0be5f6abf5528c8513181f2f4ad117b4b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "Z-snails",
+        "repo": "prettier",
+        "type": "github"
+      }
+    },
+    "algae": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1663891753,
+        "narHash": "sha256-J8tJDJ5xeIMBnTH1Otk/K/ZJJroG8GYUpUMRi0FWuJ8=",
+        "owner": "avidela",
+        "repo": "algebraic-data",
+        "rev": "9b998adc729c4521a3744aa7ba6b1d698d89f588",
+        "type": "gitlab"
+      },
+      "original": {
+        "owner": "avidela",
+        "repo": "algebraic-data",
+        "type": "gitlab"
+      }
+    },
+    "collie": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1642687104,
+        "narHash": "sha256-0GziqzEUDs1tFd5yiu5NECV0nP1aMPe2QxS9oqhmW6I=",
+        "owner": "ohad",
+        "repo": "collie",
+        "rev": "46bff04a8d9a1598fec9b19f515541df16dc64ef",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ohad",
+        "repo": "collie",
+        "type": "github"
+      }
+    },
+    "comonad": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1654185277,
+        "narHash": "sha256-+/sVUjGBU81VKDbZM/Ot4Xi/AqPSFbHQvj29jkYV5aM=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-comonad",
+        "rev": "35a6e7c2243e73e9c63340e532adaf3197cea3d3",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stefan-hoeck",
+        "repo": "idris2-comonad",
+        "type": "github"
+      }
+    },
+    "dom": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1655723854,
+        "narHash": "sha256-eeKcB+rd0cgp0XRrKKI+Io5nW0Ld45DQu6EOnmCzsR4=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-dom",
+        "rev": "7916d7a744fa3ec39c4d547de659e0740c98407c",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stefan-hoeck",
+        "repo": "idris2-dom",
+        "type": "github"
+      }
+    },
+    "dot-parse": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1653991491,
+        "narHash": "sha256-zZjgdCHYK8AoDupWjio21uYI1XeupVyhL+V/kzgi/qw=",
+        "owner": "CodingCellist",
+        "repo": "idris2-dot-parse",
+        "rev": "121a46b72f886b52314c858eddda05fbe56a78ac",
+        "type": "github"
+      },
+      "original": {
+        "owner": "CodingCellist",
+        "repo": "idris2-dot-parse",
+        "type": "github"
+      }
+    },
+    "effect": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1652479904,
+        "narHash": "sha256-52rVYBfly6bRY6l48INum+l5kLIHBvoDpCc1veyofaw=",
+        "owner": "russoul",
+        "repo": "idris2-effect",
+        "rev": "b76dce14b79a5f743243a294c3474c6f113f8e3a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "russoul",
+        "repo": "idris2-effect",
+        "type": "github"
+      }
+    },
+    "elab-util": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1663162336,
+        "narHash": "sha256-D7p5CRJ02t/6h4ybnwzPZ8JKzuver+zUrw9tjmFelRI=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-elab-util",
+        "rev": "e2b9dc3ac5f75286089e48f34223022f2a12d332",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stefan-hoeck",
+        "repo": "idris2-elab-util",
+        "type": "github"
+      }
+    },
+    "flake-utils": {
+      "locked": {
+        "lastModified": 1667077288,
+        "narHash": "sha256-bdC8sFNDpT0HK74u9fUkpbf1MEzVYJ+ka7NXCdgBoaA=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "6ee9ebb6b1ee695d2cacc4faa053a7b9baa76817",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "frex": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1651873603,
+        "narHash": "sha256-5+SL2WrwfA3P2pIAih7W3+nAPcawbkl0VSFG1JUjRWY=",
+        "owner": "frex-project",
+        "repo": "idris-frex",
+        "rev": "3c39392d088acda901c83af4d75cb3933b2427f9",
+        "type": "github"
+      },
+      "original": {
+        "owner": "frex-project",
+        "repo": "idris-frex",
+        "type": "github"
+      }
+    },
+    "fvect": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1651523510,
+        "narHash": "sha256-h09sQOa2Vn3VQPVRlGi+ze+qShz8M0zoZdGlPbKBHyM=",
+        "owner": "mattpolzin",
+        "repo": "idris-fvect",
+        "rev": "d84969fce38ff8a10b9d261458f4d495e6e0f1ca",
+        "type": "github"
+      },
+      "original": {
+        "owner": "mattpolzin",
+        "repo": "idris-fvect",
+        "type": "github"
+      }
+    },
+    "hashable": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1663865679,
+        "narHash": "sha256-dHRifrvrjSSVypJiKXrJNdl1pzxrfWKrG0EWKCPxDzo=",
+        "owner": "z-snails",
+        "repo": "idris2-hashable",
+        "rev": "5615bd4627fedcb6122e902ea3d4d18575459ceb",
+        "type": "github"
+      },
+      "original": {
+        "owner": "z-snails",
+        "repo": "idris2-hashable",
+        "type": "github"
+      }
+    },
+    "hedgehog": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1655715979,
+        "narHash": "sha256-p0LwUmcxF2whqmku4q0YUYUoDZtutvYni1FbU4HzoWw=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-hedgehog",
+        "rev": "289c02636ea7a4510320077c81ec72743803a821",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stefan-hoeck",
+        "repo": "idris2-hedgehog",
+        "type": "github"
+      }
+    },
+    "idrall": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1661451973,
+        "narHash": "sha256-q3F55PCJpQu6s3vYzz6M9eP/Yp4mBS0wZRhdER+8Wkc=",
+        "owner": "alexhumphreys",
+        "repo": "idrall",
+        "rev": "86e43e48e5edfe2bafbccd1544777a6bea5eec59",
+        "type": "github"
+      },
+      "original": {
+        "owner": "alexhumphreys",
+        "repo": "idrall",
+        "type": "github"
+      }
+    },
+    "idris2": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1667035002,
+        "narHash": "sha256-0jnBxLMj9b9rac19jIgo9RXkGl2Z0zUalfredKIX1NU=",
+        "owner": "idris-lang",
+        "repo": "idris2",
+        "rev": "c2bcc14e00794b19a7fc7ecc600f5a79b849f031",
+        "type": "github"
+      },
+      "original": {
+        "owner": "idris-lang",
+        "repo": "idris2",
+        "type": "github"
+      }
+    },
+    "idris2-pkgs": {
+      "inputs": {
+        "Prettier": "Prettier",
+        "algae": "algae",
+        "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",
+        "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",
+        "recombine": "recombine",
+        "rhone": "rhone",
+        "rhone-js": "rhone-js",
+        "snocvect": "snocvect",
+        "sop": "sop",
+        "tailrec": "tailrec",
+        "xml": "xml"
+      },
+      "locked": {
+        "lastModified": 1667146379,
+        "narHash": "sha256-qGDHORfRc8aamv2fdTqTlR1e6vLxctAfy3hXiUzqTcE=",
+        "owner": "lizard-business",
+        "repo": "idris2-pkgs",
+        "rev": "7f318b3f771e92bc306637dc54e9b0848b6ab244",
+        "type": "github"
+      },
+      "original": {
+        "owner": "lizard-business",
+        "ref": "idris0.6.0",
+        "repo": "idris2-pkgs",
+        "type": "github"
+      }
+    },
+    "indexed": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1659316146,
+        "narHash": "sha256-xySH74mX3i0Xi7EjXpfr/IUWl8kyB5svV34FVuK3uEk=",
+        "owner": "mattpolzin",
+        "repo": "idris-indexed",
+        "rev": "eb1a019dddcf90412fa8ada1e14574b37a3539c3",
+        "type": "github"
+      },
+      "original": {
+        "owner": "mattpolzin",
+        "repo": "idris-indexed",
+        "type": "github"
+      }
+    },
+    "inigo": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1667143799,
+        "narHash": "sha256-50AGHZ5B2tNaOGjNPt+32khudJxTxkGQ0/Vq4MCwsqE=",
+        "owner": "lizard-business",
+        "repo": "Inigo",
+        "rev": "8bae2a0c02cd88e6e27b98ea10953c86a383033f",
+        "type": "github"
+      },
+      "original": {
+        "owner": "lizard-business",
+        "ref": "idrall-update",
+        "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": 1662978011,
+        "narHash": "sha256-G2jKYYZHp1bfM0XrS/f9Er/MGMtMq2VSQetC18VlTLI=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-json",
+        "rev": "23b925a6b68ba8bd2d0298fc4b94e5cb78242e80",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stefan-hoeck",
+        "repo": "idris2-json",
+        "type": "github"
+      }
+    },
+    "katla": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1661665759,
+        "narHash": "sha256-A+hLAdt6H5igJwooGSoIXm8Jq+iEQTdoNrQnajtdZ9A=",
+        "owner": "idris-community",
+        "repo": "katla",
+        "rev": "a7f9f6c5c605dda745c6a9d847e5cf728b011e6b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "idris-community",
+        "repo": "katla",
+        "type": "github"
+      }
+    },
+    "lsp": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1667002591,
+        "narHash": "sha256-pLh5qBKoi1phvoiaCbpgxs38xaXM1VfD5lQI70I5F38=",
+        "owner": "idris-community",
+        "repo": "idris2-lsp",
+        "rev": "a2603b83124818eedca072269e8883cf8b7a3223",
+        "type": "github"
+      },
+      "original": {
+        "owner": "idris-community",
+        "repo": "idris2-lsp",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1667055375,
+        "narHash": "sha256-xfSTHYxuKRiqF4dcuAFdti1OUvrC2lHpQqCHWUK5/JA=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "7f9be6a505a31f88499c5d20d11f98accf5ae6ba",
+        "type": "github"
+      },
+      "original": {
+        "id": "nixpkgs",
+        "type": "indirect"
+      }
+    },
+    "odf": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1643726384,
+        "narHash": "sha256-uIqsQXA/Aoat2snaQJaFqjhCs9gYH28UMS5Emc7Ipk0=",
+        "owner": "madman-bob",
+        "repo": "idris2-odf",
+        "rev": "5eb388c6a19534f9aa1bd24a3b5c42b4ebc1ad44",
+        "type": "github"
+      },
+      "original": {
+        "owner": "madman-bob",
+        "repo": "idris2-odf",
+        "type": "github"
+      }
+    },
+    "pretty-show": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1660710482,
+        "narHash": "sha256-zctFDeFs4a6n3i/QzD+3263tMzJe9nZJQc69ustdfs0=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-pretty-show",
+        "rev": "f7383c098418e875b6896cd061861a5301bd67c2",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stefan-hoeck",
+        "repo": "idris2-pretty-show",
+        "type": "github"
+      }
+    },
+    "python": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1659367107,
+        "narHash": "sha256-KCc/8907hkJXs0GTKF6IIhss9He8qiClL7wZvyF87cM=",
+        "owner": "madman-bob",
+        "repo": "idris2-python",
+        "rev": "201eb3013600e14484585ba1aeca41936972d957",
+        "type": "github"
+      },
+      "original": {
+        "owner": "madman-bob",
+        "repo": "idris2-python",
+        "type": "github"
+      }
+    },
+    "recombine": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1654557256,
+        "narHash": "sha256-EIatN8eunmLIemEnYCzTKO/sVla5N/OPs6nsB+JvHEw=",
+        "owner": "avidela",
+        "repo": "recombine",
+        "rev": "5ef9613d8df64d3886ded6a4052a0c4c8bc89c93",
+        "type": "gitlab"
+      },
+      "original": {
+        "owner": "avidela",
+        "repo": "recombine",
+        "type": "gitlab"
+      }
+    },
+    "rhone": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1655717433,
+        "narHash": "sha256-ex5Rs6qA8hPD2NAokQtIQWVjsejuWWuruSvs5NmUOeU=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-rhone",
+        "rev": "a12fa1c65bbfb072e0a4e76e40cd0097d3c4c2e1",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stefan-hoeck",
+        "repo": "idris2-rhone",
+        "type": "github"
+      }
+    },
+    "rhone-js": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1666895711,
+        "narHash": "sha256-DdFrEWZk35VYlNMGAiiERzkDOlkQMAaJTzqjNxJ3EvM=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-rhone-js",
+        "rev": "528b9fd32ea632346764b1e70bebd3f50881330e",
+        "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": 1651518488,
+        "narHash": "sha256-oIFb2yKKxIDHNCdr0ZkHPuV7KeX0m6m9xBwRFPqz7iw=",
+        "owner": "mattpolzin",
+        "repo": "idris-snocvect",
+        "rev": "f6148c3d06c7a9989062a2425f925fc844468215",
+        "type": "github"
+      },
+      "original": {
+        "owner": "mattpolzin",
+        "repo": "idris-snocvect",
+        "type": "github"
+      }
+    },
+    "sop": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1660672216,
+        "narHash": "sha256-HO05C8KLmx9FIQDQ1IpSUZIDxL4oLPJNinbmCXgBZlk=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-sop",
+        "rev": "7b4c1189c8c9df5b34e5b4aec3aecef43dc8aa3c",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stefan-hoeck",
+        "repo": "idris2-sop",
+        "type": "github"
+      }
+    },
+    "tailrec": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1654185733,
+        "narHash": "sha256-ONcY1MFWtctuVM8RtIl6ikIOgqfdeV+ECJiNf1FfytM=",
+        "owner": "stefan-hoeck",
+        "repo": "idris2-tailrec",
+        "rev": "ae27e2ed09ef3d880801899cfc26f470f5b71332",
+        "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

@@ -0,0 +1,59 @@
+{ description = "quox: quantitative extensional type theory";
+
+  inputs = {
+    nixpkgs.url = "nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+
+    idris2-pkgs = {
+      url = "github:lizard-business/idris2-pkgs?ref=idris0.6.0"; # [fixme]
+      # 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

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

golden-tests/quox-golden-tests.ipkg

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

golden-tests/run-tests.sh

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

golden-tests/tests/empty/run

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

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

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

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

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

golden-tests/tests/hello/expected

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

golden-tests/tests/hello/hello.quox

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

golden-tests/tests/hello/run

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

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

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

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

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

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

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

golden-tests/tests/it-5/expected

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

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

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

golden-tests/tests/it-5/run

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

golden-tests/tests/lib.sh

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

golden-tests/tests/load/expected

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

golden-tests/tests/load/lib.quox

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

golden-tests/tests/load/main.quox

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

golden-tests/tests/load/run

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

golden-tests/tests/regularity/expected

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

golden-tests/tests/regularity/regularity.quox

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

golden-tests/tests/regularity/run

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

lib/Control/Monad/ST/Extra.idr

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

lib/Quox/BoolExtra.idr

@@ -1,12 +0,0 @@
-module Quox.BoolExtra
-
-import public Data.Bool
-
-
-infixr 5 `andM`
-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

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

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

lib/Quox/Context.idr

@@ -2,19 +2,17 @@ module Quox.Context
 
 import Quox.Syntax.Shift
 import Quox.Pretty
-import Quox.Name
+import public Quox.NatExtra
 
 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.
@@ -37,111 +35,40 @@ 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 = fst . unsnoc
+tail (tel :< _) = tel
 
-
-parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
-  export
-  toSnocListWith : Telescope tm _ _ -> SnocList a
-  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
+export
 toSnocList : Telescope tm _ _ -> SnocList (Exists tm)
-toSnocList = toSnocListWith (Evidence _)
+toSnocList [<]        = [<]
+toSnocList (tel :< t) = toSnocList tel :< Evidence _ t
 
-export %inline
-toSnocList' : Telescope' a _ _ -> SnocList a
-toSnocList' = toSnocListWith id
+private
+toListAcc : Telescope tm _ _ -> List (Exists tm) -> List (Exists tm)
+toListAcc [<]        acc = acc
+toListAcc (tel :< t) acc = toListAcc tel (Evidence _ t :: acc)
 
 export %inline
 toList : Telescope tm _ _ -> List (Exists tm)
-toList = toListWith (Evidence _)
+toList tel = toListAcc tel []
+
+export %inline
+toSnocList' : Telescope' a _ _ -> SnocList a
+toSnocList' = map snd . toSnocList
 
 export %inline
 toList' : Telescope' a _ _ -> List a
-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
+toList' = map snd . toList
 
 
+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) ->
@@ -159,7 +86,6 @@ getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
 getWith shft = getShiftWith shft SZ
 
 infixl 8 !!
-public export %inline
 (!!) : CanShift tm => Context tm len -> Var len -> tm len
 (!!) = getWith (//)
 
@@ -168,12 +94,16 @@ public export %inline
 (!!!) : Context' tm len -> Var len -> tm
 (!!!) = getWith const
 
-public export
-find : Alternative f =>
-       (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)
 
+||| 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
+Triangle = Context . Context
+
+public export
+Triangle' : Type -> (len : Nat) -> Type
+Triangle' a = Context $ Context (\_ => a)
 
 export
 0 telescopeLTE : Telescope _ from to -> from `LTE` to
@@ -189,12 +119,6 @@ export %hint
 succGT = LTESucc reflexive
 
 
-public export
-drop : (m : Nat) -> Context term (m + n) -> Context term n
-drop 0     ctx        = ctx
-drop (S m) (ctx :< _) = drop m ctx
-
-
 parameters {auto _ : Applicative f}
   export
   traverse : (forall n. tm1 n -> f (tm2 n)) ->
@@ -202,10 +126,6 @@ parameters {auto _ : Applicative f}
   traverse f [<]        = pure [<]
   traverse f (tel :< x) = [|traverse f tel :< f x|]
 
-  export %inline
-  traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
-  traverse' f = traverse f
-
   infixl 3 `app`
   ||| like `(<*>)` but with effects
   export
@@ -220,7 +140,6 @@ 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
@@ -231,17 +150,33 @@ 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 %inline
-(<$) : (forall n. tm1 n) -> Telescope tm2 from to -> Telescope tm1 from to
-x <$ tel = const x <$> tel
+export
+teleLte' : Telescope tm from to -> from `LTE'` to
+teleLte' [<]        = LTERefl
+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
@@ -250,6 +185,14 @@ 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) ->
@@ -257,43 +200,32 @@ zipWithLazy : forall tm1, tm2, tm3.
               Telescope (\n => Lazy (tm3 n)) from to
 zipWithLazy f = zipWith $ delay .: f
 
-export
-unzip : Telescope (\n => (tm1 n, tm2 n)) from to ->
-        (Telescope tm1 from to, Telescope tm2 from to)
-unzip [<]             = ([<], [<])
-unzip (tel :< (x, y)) = let (xs, ys) = unzip tel in (xs :< x, ys :< y)
+export %inline
+zipWith3Lazy : forall tm1, tm2, tm3, tm4.
+               (forall n. tm1 n -> tm2 n -> tm3 n -> tm4 n) ->
+               Telescope tm1 from to ->
+               Telescope tm2 from to ->
+               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 -> Singleton to
+lengthPrf0 : Context _ to -> Subset Nat (\len => len = to)
 lengthPrf0 ctx =
-  let Element len prf = lengthPrf ctx in
-  rewrite sym prf `trans` plusZeroRightNeutral len in
-  [|len|]
+  let len = lengthPrf ctx in
+  Element len.fst (rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
 
 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} ->
@@ -302,10 +234,6 @@ foldl : {0 acc : Nat -> Type} ->
 foldl f z [<]        = z
 foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
 
-export %inline
-foldl_ : (acc -> tm -> acc) -> acc -> Telescope' tm from to -> acc
-foldl_ f z tel = foldl f z tel
-
 export %inline
 foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
 foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
@@ -321,48 +249,41 @@ foldLazy = foldMap force
 
 
 export %inline
-all, any : (forall n. tm n -> Bool) -> Telescope tm from to -> Bool
-all p = foldMap @{All} p
-any p = foldMap @{Any} p
+and : Telescope' (Lazy Bool) _ _ -> Bool
+and = force . fold @{All}
+
+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
-  (==) = foldLazy @{All} .: zipWithLazy (==)
+  (==) = all2 (==)
 
 export %inline
 (forall n. Ord (tm n)) => Ord (Telescope tm from to) where
   compare = foldLazy .: zipWithLazy compare
 
 export %inline
-(forall n. Show (tm n)) => Show (Telescope tm from to) where
-  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) [<]
+(forall n. PrettyHL (tm n)) => PrettyHL (Telescope tm from to) where
+  prettyM tel = separate (hl Delim ";") <$> traverse prettyM (toList tel)

lib/Quox/Decidable.idr

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

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

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

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

lib/Quox/Lexer.idr

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

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

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

@@ -1,10 +1,11 @@
 module Quox.NatExtra
 
 import public Data.Nat
-import Data.Nat.Division
+import public Data.Nat.Properties
+import public Data.Nat.Division
+import Data.DPair
 import Data.SnocList
 import Data.Vect
-import Data.String
 
 %default total
 
@@ -53,42 +54,115 @@ parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char)
   showAtBase : Nat -> String
   showAtBase = pack . showAtBase' []
 
-namespace Nat
-  export
-  showHex : Nat -> String
-  showHex = showAtBase $ fromList $ unpack "0123456789abcdef"
-
-namespace Int
-  export
-  showHex : Int -> String
-  showHex x =
-    if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x)
+export
+showHex : Nat -> String
+showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
 
 
-namespace Int
-  export
-  fromHexit : Char -> Maybe Int
-  fromHexit c =
-    if      c >= '0' && c <= '9' then Just $ ord c - ord '0'
-    else if c >= 'a' && c <= 'f' then Just $ ord c - ord 'a' + 10
-    else if c >= 'A' && c <= 'F' then Just $ ord c - ord 'A' + 10
-    else Nothing
+n2i = natToInteger
+i2n = fromInteger {ty = Nat}
 
-  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)
+private partial %inline
+divNatViaInteger : (m, n : Nat) -> Nat
+divNatViaInteger m n = i2n $ n2i m `div` n2i n
+%transform "divNat" divNat = divNatViaInteger
 
-  export %inline
-  fromHex : String -> Maybe Int
-  fromHex str = do guard $ str /= ""; fromHex' 0 str
+private %inline
+divNatViaIntegerNZ : (m, n : Nat) -> (0 _ : NonZero n) -> Nat
+divNatViaIntegerNZ m n _ = assert_total divNatViaInteger m n
+%transform "divNatNZ" divNatNZ = divNatViaIntegerNZ
 
-namespace Nat
-  export
-  fromHexit : Char -> Maybe Nat
-  fromHexit = map cast . Int.fromHexit
+private partial %inline
+modNatViaInteger : (m, n : Nat) -> Nat
+modNatViaInteger m n = i2n $ n2i m `mod` n2i n
+%transform "modNat" modNat = modNatViaInteger
 
-  export %inline
-  fromHex : String -> Maybe Nat
-  fromHex = map cast . Int.fromHex
+private %inline
+modNatViaIntegerNZ : (m, n : Nat) -> (0 _ : NonZero n) -> Nat
+modNatViaIntegerNZ m n _ = assert_total modNatViaInteger m n
+%transform "modNatNZ" modNatNZ = modNatViaIntegerNZ
+
+
+public export
+data ViewLsb : Nat -> Type where
+  Lsb0 : (n : Nat) -> (0 eq : n' =    2 * n)  -> ViewLsb n'
+  Lsb1 : (n : Nat) -> (0 eq : n' = S (2 * n)) -> ViewLsb n'
+%name ViewLsb p, q
+
+public export data IsLsb0 : ViewLsb n -> Type where ItIsLsb0 : IsLsb0 (Lsb0 n eq)
+public export data IsLsb1 : ViewLsb n -> Type where ItIsLsb1 : IsLsb1 (Lsb1 n eq)
+
+export
+0 lsbMutex : n = (2 * a) -> n = S (2 * b) -> Void
+lsbMutex ev od {n = 0} impossible
+lsbMutex ev od {n = 1} {a = S a} {b = 0} =
+  let ev = injective ev in
+  let s  = sym $ plusSuccRightSucc a (a + 0) in
+  absurd $ trans ev s
+lsbMutex ev od {n = S (S n)} {a = S a} {b = S b} =
+  let ev = injective $
+           trans (injective ev) (sym $ plusSuccRightSucc a (a + 0)) in
+  let od = trans (injective $ injective od)
+                 (sym $ plusSuccRightSucc b (b + 0)) in
+  lsbMutex ev od
+
+public export %hint
+doubleIsLsb0 : (p : ViewLsb (2 * n)) -> IsLsb0 p
+doubleIsLsb0 (Lsb0 k eq) = ItIsLsb0
+doubleIsLsb0 (Lsb1 k eq) = void $ absurd $ lsbMutex Refl eq
+
+public export %hint
+sDoubleIsLsb1 : (p : ViewLsb (S (2 * n))) -> IsLsb1 p
+sDoubleIsLsb1 (Lsb1 k eq) = ItIsLsb1
+sDoubleIsLsb1 (Lsb0 k eq) = void $ absurd $ lsbMutex Refl (sym eq)
+
+
+export
+fromLsb0 : (p : ViewLsb n) -> (0 _ : IsLsb0 p) =>
+           Subset Nat (\n' => n = 2 * n')
+fromLsb0 (Lsb0 n' eq) @{ItIsLsb0} = Element n' eq
+
+export
+fromLsb1 : (p : ViewLsb n) -> (0 _ : IsLsb1 p) =>
+           Subset Nat (\n' => n = S (2 * n'))
+fromLsb1 (Lsb1 n' eq) @{ItIsLsb1} = Element n' eq
+
+
+private
+viewLsb' : (m, d : Nat) -> (0 _ : m `LT` 2) -> ViewLsb (m + 2 * d)
+viewLsb' 0 d p = Lsb0 d Refl
+viewLsb' 1 d p = Lsb1 d Refl
+viewLsb' (S (S _)) _ (LTESucc p) = void $ absurd p
+
+export
+viewLsb : (n : Nat) -> ViewLsb n
+viewLsb n =
+  let 0 nz : NonZero 2 = %search in
+  rewrite DivisionTheorem n 2 nz nz in
+  rewrite multCommutative (divNatNZ n 2 nz) 2 in
+  viewLsb' (modNatNZ n 2 nz) (divNatNZ n 2 nz) (boundModNatNZ n 2 nz)
+
+export
+0 doubleInj : {m, n : Nat} -> 2 * m = 2 * n -> m = n
+doubleInj eq =
+  multRightCancel m n 2 %search $
+    trans (multCommutative m 2) $ trans eq (multCommutative 2 n)
+
+export
+0 sDoubleInj : {m, n : Nat} -> S (2 * m) = S (2 * n) -> m = n
+sDoubleInj eq = doubleInj $ injective eq
+
+
+export
+0 lsbOdd : (n : Nat) -> (eq ** viewLsb (S (2 * n)) = Lsb1 n eq)
+lsbOdd n with (viewLsb (S (2 * n)))
+  _ | Lsb0 _  eq = void $ absurd $ lsbMutex Refl (sym eq)
+  _ | Lsb1 n' eq with (sDoubleInj eq)
+    lsbOdd n | (Lsb1 n eq) | Refl = (eq ** Refl)
+
+export
+0 lsbEven : (n : Nat) -> (eq ** viewLsb (2 * n) = Lsb0 n eq)
+lsbEven n with (viewLsb (2 * n))
+  _ | Lsb1 _  eq = void $ absurd $ lsbMutex Refl eq
+  _ | Lsb0 n' eq with (doubleInj eq)
+    lsbEven n | Lsb0 n eq | Refl = (eq ** Refl)

lib/Quox/No.idr

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

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

lib/Quox/OPE/Basics.idr

@@ -0,0 +1,11 @@
+module Quox.OPE.Basics
+
+%default total
+
+public export
+Scope : Type -> Type
+Scope = SnocList
+
+public export
+Scoped : Type -> Type
+Scoped a = Scope a -> Type

lib/Quox/OPE/Comp.idr

@@ -0,0 +1,153 @@
+module Quox.OPE.Comp
+
+import Quox.OPE.Basics
+import Quox.OPE.Length
+import Quox.OPE.Sub
+import Data.DPair
+
+import Control.Function
+import Data.Nat
+
+%default total
+
+
+public export
+data Comp' : ys `Sub'` zs -> xs `Sub'` ys -> xs `Sub'` zs -> Type where
+  CEE : Comp' End End End
+  CKK : Comp' p q pq -> Comp' (Keep p) (Keep q) (Keep pq)
+  CKD : Comp' p q pq -> Comp' (Keep p) (Drop q) (Drop pq)
+  CD0 : Comp' p q pq -> Comp' (Drop p) q        (Drop pq)
+
+public export
+record Comp {a : Type} {xs, ys, zs : Scope a}
+            (p : ys `Sub` zs) (q : xs `Sub` ys) (pq : xs `Sub` zs) where
+  constructor MkComp
+  0 comp : Comp' p.lte q.lte pq.lte
+
+
+export
+compPrf' : (p : ys `Sub'` zs) -> (q : xs `Sub'` ys) -> Comp' p q (p . q)
+compPrf' End      End      = CEE
+compPrf' (Keep p) (Keep q) = CKK $ compPrf' p q
+compPrf' (Keep p) (Drop q) = CKD $ compPrf' p q
+compPrf' (Drop p) q        = CD0 $ compPrf' p q
+
+export
+0 compOk' : Comp' p q r -> r = (p . q)
+compOk' CEE     = Refl
+compOk' (CKK z) = cong Keep $ compOk' z
+compOk' (CKD z) = cong Drop $ compOk' z
+compOk' (CD0 z) = cong Drop $ compOk' z
+
+
+export %inline
+compPrf : (0 sy : Length ys) => (0 sz : Length zs) =>
+       (p : ys `Sub` zs) -> (q : xs `Sub` ys) ->
+       Comp p q ((p . q) @{sy} @{sz})
+compPrf p q = MkComp $
+  replace {p = Comp' p.lte q.lte} (sym $ compLte p q) $
+    compPrf' p.lte q.lte
+
+
+export
+compZero' : (sx : Length xs) => (sy : Length ys) =>
+            (p : xs `Sub'` ys) -> Comp' p (zero' @{sx}) (zero' @{sy})
+compZero' {sx = Z,   sy = Z}   End      = CEE
+compZero' {sx = S _, sy = S _} (Keep p) = CKD (compZero' p)
+compZero'           {sy = S _} (Drop p) = CD0 (compZero' p)
+
+export %inline
+compZero : (sx : Length xs) => (sy : Length ys) =>
+           (p : xs `Sub` ys) -> Comp p (zero @{sx}) (zero @{sy})
+compZero p = MkComp $
+  rewrite zeroLte {sx} in
+  rewrite zeroLte {sx = sy} in
+  compZero' {}
+
+export
+compIdLeft' : (sy : Length ys) =>
+              (p : xs `Sub'` ys) -> Comp' (refl' @{sy}) p p
+compIdLeft' {sy = Z}   End      = CEE
+compIdLeft' {sy = S _} (Keep p) = CKK (compIdLeft' p)
+compIdLeft' {sy = S _} (Drop p) = CKD (compIdLeft' p)
+
+export %inline
+compIdLeft : (sy : Length ys) =>
+             (p : xs `Sub` ys) -> Comp (refl @{sy}) p p
+compIdLeft {sy} p = MkComp $
+  rewrite reflLte {sx = sy} in compIdLeft' {}
+
+export
+compIdRight' : (sx : Length xs) =>
+               (p : xs `Sub'` ys) -> Comp' p (refl' @{sx}) p
+compIdRight' {sx = Z}   End      = CEE
+compIdRight' {sx = S _} (Keep p) = CKK (compIdRight' p)
+compIdRight'            (Drop p) = CD0 (compIdRight' p)
+
+export %inline
+compIdRight : (sx : Length xs) =>
+              (p : xs `Sub` ys) -> Comp p (refl @{sx}) p
+compIdRight {sx} p = MkComp $ rewrite reflLte {sx} in compIdRight' {}
+
+export
+0 compAssoc' : (p : ys `Sub'` zs) -> (q : xs `Sub'` ys) -> (r : ws `Sub'` xs) ->
+               p . (q . r) = (p . q) . r
+compAssoc' End      End      End      = Refl
+compAssoc' (Keep p) (Keep q) (Keep r) = cong Keep $ compAssoc' p q r
+compAssoc' (Keep p) (Keep q) (Drop r) = cong Drop $ compAssoc' p q r
+compAssoc' (Keep p) (Drop q) r        = cong Drop $ compAssoc' p q r
+compAssoc' (Drop p) q        r        = cong Drop $ compAssoc' p q r
+compAssoc' End (Drop _) _ impossible
+
+export %inline
+0 compAssoc : (sx : Length xs) => (sy : Length ys) => (sz : Length zs) =>
+              (p : ys `Sub` zs) -> (q : xs `Sub` ys) -> (r : ws `Sub` xs) ->
+              comp @{sy} @{sz} p (comp @{sx} @{sy} q r) =
+                comp @{sx} @{sz} (comp @{sy} @{sz} p q) r
+compAssoc p q r = lteEq $
+  trans (transLte {}) $
+  trans (cong (p.lte .) (transLte {})) $
+  sym $
+  trans (transLte {}) $
+  trans (cong (. r.lte) (transLte {})) $
+  sym $ compAssoc' {}
+
+public export
+0 Subscope : Scope a -> Type
+Subscope ys = Exists (`Sub` ys)
+
+public export
+record SubMap' {a : Type} {xs, ys, zs : Scope a}
+               (p : xs `Sub'` zs) (q : ys `Sub'` zs) where
+  constructor SM'
+  thin : xs `Sub'` ys
+  0 comp : Comp' q thin p
+
+public export
+record SubMap {a : Type} {xs, ys, zs : Scope a}
+              (p : xs `Sub` zs) (q : ys `Sub` zs) where
+  constructor SM
+  thin : xs `Sub` ys
+  0 comp : Comp q thin p
+
+export
+0 submap' : SubMap p q -> SubMap' p.lte q.lte
+submap' (SM thin comp) = SM' {thin = thin.lte, comp = comp.comp}
+
+parameters (p : xs `Sub'` ys)
+  export
+  subId' : SubMap' p p
+  subId' = SM' refl' (compIdRight' p)
+
+  export
+  subZero' : SubMap' Sub.zero' p
+  subZero' = SM' zero' (compZero' p)
+
+parameters {auto sx : Length xs} (p : xs `Sub` ys)
+  export
+  subId : SubMap p p
+  subId = SM refl (compIdRight p)
+
+  export
+  subZero : SubMap Sub.zero p
+  subZero = SM zero (compZero p)

lib/Quox/OPE/Cover.idr

@@ -0,0 +1,90 @@
+module Quox.OPE.Cover
+
+import Quox.OPE.Basics
+import Quox.OPE.Length
+import Quox.OPE.Sub
+
+%default total
+
+
+public export
+data Cover'_ : (overlap : Bool) -> xs `Sub'` zs -> ys `Sub'` zs -> Type where
+  CE : Cover'_ ov End End
+  CL : Cover'_ ov p q -> Cover'_ ov   (Keep p) (Drop q)
+  CR : Cover'_ ov p q -> Cover'_ ov   (Drop p) (Keep q)
+  C2 : Cover'_ ov p q -> Cover'_ True (Keep p) (Keep q)
+
+parameters (p : xs `Sub'` zs) (q : ys `Sub'` zs)
+  public export
+  0 Cover' : Type
+  Cover' = Cover'_ True p q
+
+  public export
+  0 Partition' : Type
+  Partition' = Cover'_ False p q
+
+
+public export
+record Cover_ {a : Type} {xs, ys, zs : Scope a} (overlap : Bool)
+              (p : xs `Sub` zs) (q : ys `Sub` zs) where
+  constructor MkCover
+  0 cover : Cover'_ overlap p.lte q.lte
+
+parameters (p : xs `Sub` zs) (q : ys `Sub` zs)
+  public export
+  0 Cover : Type
+  Cover = Cover_ True p q
+
+  public export
+  0 Partition : Type
+  Partition = Cover_ False p q
+
+
+private %inline
+covCast' : {0 p, p' : xs `Sub'` zs} -> {0 q, q' : ys `Sub'` zs} ->
+           (0 pe : p = p') -> (0 qe : q = q') ->
+           Cover'_ overlap p' q' -> Cover'_ overlap p q
+covCast' pe qe c = replace {p = id} (sym $ cong2 (Cover'_ overlap) pe qe) c
+
+
+parameters {0 overlap : Bool} {0 p : xs `Sub` zs} {0 q : ys `Sub` zs}
+  export %inline
+  left : Cover_ overlap p q -> Cover_ overlap (keep p) (drop q)
+  left (MkCover cover) = MkCover $ covCast' (keepLte p) (dropLte q) $ CL cover
+
+  export %inline
+  right : Cover_ overlap p q -> Cover_ overlap (drop p) (keep q)
+  right (MkCover cover) = MkCover $ covCast' (dropLte p) (keepLte q) $ CR cover
+
+  export %inline
+  both : Cover_ overlap p q -> Cover (keep p) (keep q)
+  both (MkCover cover) = MkCover $ covCast' (keepLte p) (keepLte q) $ C2 cover
+
+
+export
+allLeft' : (sx : Length xs) => Partition' (refl' @{sx}) (zero' @{sx})
+allLeft' {sx = Z}   = CE
+allLeft' {sx = S s} = CL allLeft'
+
+export
+allRight' : (sx : Length xs) => Partition' (zero' @{sx}) (refl' @{sx})
+allRight' {sx = Z}   = CE
+allRight' {sx = S s} = CR allRight'
+
+export
+both' : (sx : Length xs) => Cover' (refl' @{sx}) (refl' @{sx})
+both' {sx = Z}   = CE
+both' {sx = S s} = C2 both'
+
+
+export %inline
+allLeft : (sx : Length xs) => Partition (refl @{sx}) (zero @{sx})
+allLeft = MkCover $ rewrite reflLte {sx} in rewrite zeroLte {sx} in allLeft'
+
+export %inline
+allRight : (sx : Length xs) => Partition (zero @{sx}) (refl @{sx})
+allRight = MkCover $ rewrite reflLte {sx} in rewrite zeroLte {sx} in allRight'
+
+export %inline
+allBoth : (sx : Length xs) => Cover (refl @{sx}) (refl @{sx})
+allBoth = MkCover $ rewrite reflLte {sx} in both'

lib/Quox/OPE/Length.idr

@@ -0,0 +1,39 @@
+module Quox.OPE.Length
+
+import Quox.OPE.Basics
+
+%default total
+
+
+public export
+data Length : Scope a -> Type where
+  Z : Length [<]
+  S : (s : Length xs) -> Length (xs :< x)
+%name Length s
+%builtin Natural Length
+
+public export
+(.nat) : Length xs -> Nat
+(Z).nat   = Z
+(S s).nat = S s.nat
+%transform "Length.nat" Length.(.nat) xs = believe_me xs
+
+export
+0 ok : (s : Length xs) -> s.nat = length xs
+ok Z     = Refl
+ok (S s) = cong S $ ok s
+
+public export %hint
+toLength : (xs : Scope a) -> Length xs
+toLength [<]       = Z
+toLength (sx :< x) = S (toLength sx)
+
+public export %hint
+lengthApp : Length xs -> Length ys -> Length (xs ++ ys)
+lengthApp sx Z      = sx
+lengthApp sx (S sy) = S (lengthApp sx sy)
+
+public export
+0 lengthIrrel : (sx1, sx2 : Length xs) -> sx1 = sx2
+lengthIrrel Z       Z       = Refl
+lengthIrrel (S sx1) (S sx2) = cong S $ lengthIrrel sx1 sx2

lib/Quox/OPE/Split.idr

@@ -0,0 +1,37 @@
+module Quox.OPE.Split
+
+import Quox.OPE.Basics
+import Quox.OPE.Length
+import Quox.OPE.Sub
+
+%default total
+
+
+public export
+record Split {a : Type} (xs, ys, zs : Scope a) (p : xs `Sub` ys ++ zs) where
+  constructor MkSplit
+  {0 leftSub, rightSub : Scope a}
+  leftThin : leftSub `Sub` ys
+  rightThin : rightSub `Sub` zs
+  0 eqScope : xs = leftSub ++ rightSub
+  0 eqThin : p ~=~ leftThin ++ rightThin
+
+export
+split : Length ys =>
+        (zs : Scope a) -> (p : xs `Sub` ys ++ zs) -> Split xs ys zs p
+split [<] p = MkSplit p zero Refl (endRight p)
+split (zs :< z) p @{ys} with (p.view @{S (lengthApp ys %search)})
+  split (zs :< z) (SubM (S (2 * n)) (Keep p) v0) | (KEEP v Refl) =
+    case split zs (sub v) of
+      MkSplit l r Refl t =>
+        MkSplit l (keep r) Refl $
+          rewrite viewIrrel v0 (KEEP v Refl) in
+          trans (cong keep {a = sub v} t) $
+          sym $ keepAppRight l r
+  split (zs :< z) (SubM (2 * n) (Drop p) v0) | (DROP v Refl) =
+    case split zs (sub v) of
+      MkSplit l r Refl t =>
+        MkSplit l (drop r) Refl $
+          rewrite viewIrrel v0 (DROP v Refl) in
+          trans (cong drop {a = sub v} t) $
+          sym $ dropAppRight l r

lib/Quox/OPE/Sub.idr

@@ -0,0 +1,572 @@
+module Quox.OPE.Sub
+
+import Quox.OPE.Basics
+import Quox.OPE.Length
+import Quox.NatExtra
+import Data.DPair
+import Data.SnocList.Elem
+import Data.SnocList.Quantifiers
+
+%default total
+
+infix 0 `Sub'`, `Sub`
+
+public export
+data Sub' : Scope a -> Scope a -> Type where
+  End  : [<] `Sub'` [<]
+  Keep : xs `Sub'` ys -> xs :< z `Sub'` ys :< z
+  Drop : xs `Sub'` ys -> xs      `Sub'` ys :< z
+%name Sub' p, q
+
+export
+keepInjective : Keep p = Keep q -> p = q
+keepInjective Refl = Refl
+
+export
+dropInjective : Drop p = Drop q -> p = q
+dropInjective Refl = Refl
+
+-- these need to be `public export` so that
+-- `id`, `zero`, and maybe others can reduce
+public export %hint
+lengthLeft : xs `Sub'` ys -> Length xs
+lengthLeft End      = Z
+lengthLeft (Keep p) = S (lengthLeft p)
+lengthLeft (Drop p) = lengthLeft p
+
+public export %hint
+lengthRight : xs `Sub'` ys -> Length ys
+lengthRight End      = Z
+lengthRight (Keep p) = S (lengthRight p)
+lengthRight (Drop p) = S (lengthRight p)
+
+
+export %inline
+dropLast' : (xs :< x) `Sub'` ys -> xs `Sub'` ys
+dropLast' (Keep p) = Drop p
+dropLast' (Drop p) = Drop $ dropLast' p
+
+export
+Uninhabited (xs :< x `Sub'` [<]) where uninhabited _ impossible
+
+export
+Uninhabited (xs :< x `Sub'` xs) where
+  uninhabited (Keep p) = uninhabited p
+  uninhabited (Drop p) = uninhabited $ dropLast' p
+
+
+export
+0 lteLen : xs `Sub'` ys -> length xs `LTE` length ys
+lteLen End      = LTEZero
+lteLen (Keep p) = LTESucc $ lteLen p
+lteLen (Drop p) = lteSuccRight $ lteLen p
+
+export
+0 lteNilRight : xs `Sub'` [<] -> xs = [<]
+lteNilRight End = Refl
+
+
+
+public export
+refl' : Length xs => xs `Sub'` xs
+refl' @{Z}   = End
+refl' @{S s} = Keep refl'
+
+public export
+zero' : Length xs => [<] `Sub'` xs
+zero' @{Z}   = End
+zero' @{S s} = Drop zero'
+
+public export
+single' : Length xs => x `Elem` xs -> [< x] `Sub'` xs
+single' @{S _} Here      = Keep zero'
+single' @{S _} (There p) = Drop $ single' p
+
+
+namespace Sub
+  public export
+  (.) : ys `Sub'` zs -> xs `Sub'` ys -> xs `Sub'` zs
+  End      . End      = End
+  (Keep p) . (Keep q) = Keep $ p . q
+  (Keep p) . (Drop q) = Drop $ p . q
+  (Drop p) . q        = Drop $ p . q
+
+public export
+comp' : ys `Sub'` zs -> xs `Sub'` ys -> xs `Sub'` zs
+comp' = (.)
+
+public export %inline
+trans' : xs `Sub'` ys -> ys `Sub'` zs -> xs `Sub'` zs
+trans' = flip (.)
+
+public export
+app' : xs1 `Sub'` ys1 -> xs2 `Sub'` ys2 -> (xs1 ++ xs2) `Sub'` (ys1 ++ ys2)
+app' p End      = p
+app' p (Keep q) = Keep $ app' p q
+app' p (Drop q) = Drop $ app' p q
+
+
+||| if `p` holds for all elements of the main list,
+||| it holds for all elements of the sublist
+public export
+subAll' : xs `Sub'` ys -> All p ys -> All p xs
+subAll' End      [<]       = [<]
+subAll' (Keep q) (ps :< x) = subAll' q ps :< x
+subAll' (Drop q) (ps :< x) = subAll' q ps
+
+||| if `p` holds for one element of the sublist,
+||| it holds for one element of the main list
+public export
+subAny' : xs `Sub'` ys -> Any p xs -> Any p ys
+subAny' (Keep q) (Here  x) = Here x
+subAny' (Keep q) (There x) = There (subAny' q x)
+subAny' (Drop q) x         = There (subAny' q x)
+
+
+public export
+data SubView : (lte : xs `Sub'` ys) -> (mask : Nat) -> Type where
+  [search lte]
+  END  : (0 eq : n = 0) -> SubView End n
+  KEEP : {n : Nat} -> {0 p : xs `Sub'` ys} ->
+         (0 v : SubView p n) -> (0 eq : n' = S (2 * n)) ->
+         SubView (Keep {z} p) n'
+  DROP : {n : Nat} -> {0 p : xs `Sub'` ys} ->
+         (0 v : SubView p n) -> (0 eq : n' = 2 * n) ->
+         SubView (Drop {z} p) n'
+%name SubView v
+
+public export
+record Sub {a : Type} (xs, ys : Scope a) where
+  constructor SubM
+  mask : Nat
+  0 lte : xs `Sub'` ys
+  0 view0 : SubView lte mask
+%name Sub sub
+
+public export %inline
+sub : {mask : Nat} -> {0 lte : xs `Sub'` ys} -> (0 view0 : SubView lte mask) ->
+      xs `Sub` ys
+sub v = SubM _ _ v
+
+
+private
+0 uip : (p, q : a = b) -> p = q
+uip Refl Refl = Refl
+
+export
+0 viewIrrel : Length ys =>
+              {m : Nat} -> {lte : xs `Sub'` ys} ->
+              (v1, v2 : SubView lte m) -> v1 === v2
+viewIrrel (END eq1) (END eq2) = rewrite uip eq1 eq2 in Refl
+viewIrrel (KEEP v1 eq1) (KEEP v2 eq2) with (sDoubleInj $ trans (sym eq1) eq2)
+  _ | Refl = rewrite viewIrrel v1 v2 in rewrite uip eq1 eq2 in Refl
+viewIrrel (DROP v1 eq1) (DROP v2 eq2) with (doubleInj $ trans (sym eq1) eq2)
+  _ | Refl = rewrite viewIrrel v1 v2 in rewrite uip eq1 eq2 in Refl
+
+export
+0 viewLteEq : {p, q : xs `Sub'` ys} -> SubView p m -> SubView q m -> p = q
+viewLteEq (END _) (END _) = Refl
+viewLteEq (KEEP {n = m} pv pe) (KEEP {n} qv qe) =
+  let eq = sDoubleInj {m, n} $ trans (sym pe) qe in
+  rewrite viewLteEq pv (rewrite eq in qv) in Refl
+viewLteEq (KEEP pv pe) (DROP qv qe) = absurd $ lsbMutex qe pe
+viewLteEq (DROP pv pe) (KEEP qv qe) = absurd $ lsbMutex pe qe
+viewLteEq (DROP {n = m} pv pe) (DROP {n} qv qe) =
+  let eq = doubleInj {m, n} $ trans (sym pe) qe in
+  rewrite viewLteEq pv (rewrite eq in qv) in Refl
+
+private
+0 lteEq' : (p : xs `Sub'` ys) ->
+           (v1 : SubView p m1) -> (v2 : SubView p m2) ->
+           SubM m1 p v1 = SubM m2 p v2
+lteEq' End (END Refl) (END Refl) = Refl
+lteEq' {m1 = S (2 * n)} {m2 = S (2 * n)} (Keep p) (KEEP v1 Refl) (KEEP v2 Refl) =
+  cong (\v => SubM (S (2 * n)) (Keep p) (KEEP v Refl)) $
+    case lteEq' p v1 v2 of Refl => Refl
+lteEq' {m1 = 2 * n} {m2 = 2 * n} (Drop p) (DROP v1 Refl) (DROP v2 Refl) =
+  cong (\v => SubM (2 * n) (Drop p) (DROP v Refl)) $
+    case lteEq' p v1 v2 of Refl => Refl
+lteEq' {m1 = _} {m2 = S _} _ _ (END _) impossible
+lteEq' {m1 = Z} {m2 = _} _ (KEEP _ _) _ impossible
+lteEq' {m1 = _} {m2 = Z} _ _ (KEEP _ _) impossible
+
+export
+0 lteEq : {p, q : xs `Sub` ys} -> p.lte = q.lte -> p = q
+lteEq {p = SubM pm pl pv} {q = SubM qm ql qv} eq =
+  rewrite eq in lteEq' ql (rewrite sym eq in pv) qv
+
+
+public export %inline
+end : [<] `Sub` [<]
+end = SubM 0 End (END Refl)
+
+public export %inline
+keep : xs `Sub` ys -> xs :< z `Sub` ys :< z
+keep (SubM mask lte view0) = SubM (S (2 * mask)) (Keep lte) (KEEP view0 Refl)
+
+public export %inline
+drop : xs `Sub` ys -> xs `Sub` ys :< z
+drop (SubM mask lte view0) = SubM (2 * mask) (Drop lte) (DROP view0 Refl)
+
+
+export
+0 keepLte : (p : xs `Sub` ys) -> (keep p).lte = Keep p.lte
+keepLte (SubM mask lte view0) = Refl
+
+export
+0 dropLte : (p : xs `Sub` ys) -> (drop p).lte = Drop p.lte
+dropLte (SubM mask lte view0) = Refl
+
+
+public export
+data Eqv : {xs, ys : Scope a} -> (p, q : xs `Sub` ys) -> Type where
+  EQV : {0 p, q : xs `Sub` ys} -> p.mask = q.mask -> p `Eqv` q
+%name Eqv eqv
+
+export
+Reflexive (xs `Sub` ys) Eqv where
+  reflexive = EQV Refl
+
+export
+Symmetric (xs `Sub` ys) Eqv where
+  symmetric (EQV eq) = EQV $ sym eq
+
+export
+Transitive (xs `Sub` ys) Eqv where
+  transitive (EQV eq1) (EQV eq2) = EQV $ trans eq1 eq2
+
+export
+0 eqvToEq : {p, q : xs `Sub` ys} -> p `Eqv` q -> p = q
+eqvToEq {p = SubM _ _ pv} {q = SubM _ _ qv} (EQV Refl) with (viewLteEq pv qv)
+  _ | Refl = rewrite viewIrrel pv qv in Refl
+
+export
+0 eqToEqv : {p, q : xs `Sub` ys} -> p = q -> p `Eqv` q
+eqToEqv Refl = reflexive
+
+
+export
+getMask : SubView lte mask -> Subset Nat (Equal mask)
+getMask (END Refl)  = Element 0 Refl
+getMask (KEEP v eq) = Element _ eq
+getMask (DROP v eq) = Element _ eq
+
+
+private
+splitExEq : {0 f, g : a -> b} ->
+            (0 p : (x : a ** f x = g x)) -> Exists (\x => f x = g x)
+splitExEq p = Evidence p.fst (irr p.snd)
+  where irr : forall a, b. (0 eq : a = b) -> a = b
+        irr Refl = Refl
+
+private
+0 lteNil2End : (p : [<] `Sub'` [<]) -> p = End
+lteNil2End End = Refl
+
+private
+0 ltemEnd : SubView p n -> p = End -> n = 0
+ltemEnd (END eq) Refl = eq
+
+private
+0 ltemEvenDrop : {p : xs `Sub'` (ys :< y)} ->
+                 n = 2 * n' -> SubView p n -> (q ** p = Drop q)
+ltemEvenDrop eq (KEEP _ eq') = absurd $ lsbMutex eq eq'
+ltemEvenDrop eq (DROP {})    = (_ ** Refl)
+
+private
+0 fromDROP : {lte : xs `Sub'` ys :< z} -> n = 2 * n' -> lte = Drop lte' ->
+             SubView lte n -> SubView lte' n'
+fromDROP eq Refl (DROP {n} p Refl) =
+  let eq = doubleInj eq {m = n, n = n'} in
+  rewrite sym eq in p
+
+private
+0 ltemOddKeep : {p : (xs :< x) `Sub'` (ys :< x)} -> {n' : Nat} ->
+                n = S (2 * n') -> SubView p n -> (q ** p = Keep q)
+ltemOddKeep eq (KEEP {})    = (_ ** Refl)
+ltemOddKeep eq (DROP _ eq') = absurd $ lsbMutex eq' eq
+ltemOddKeep eq (END _) impossible
+
+private
+0 ltemOddLeft : {0 n, n' : Nat} -> {lte : xs `Sub'` ys :< z} ->
+                n = S (2 * n') -> SubView lte n ->
+                (xs' ** xs = xs' :< z)
+ltemOddLeft eq {lte = Keep p} _ = (_ ** Refl)
+ltemOddLeft eq {lte = Drop p} (DROP n' eq') = void $ lsbMutex eq' eq
+
+private
+0 fromKEEP : {lte : xs :< z `Sub'` ys :< z} ->
+             n = S (2 * n') -> lte = Keep lte' ->
+             SubView lte n -> SubView lte' n'
+fromKEEP eq Refl (KEEP {n} p Refl) =
+  let eq = sDoubleInj eq {m = n, n = n'} in
+  rewrite sym eq in p
+
+
+export
+view : Length ys => (m : Sub xs ys) -> SubView m.lte m.mask
+view @{Z} (SubM mask lte view0) with 0 (lteNilRight lte)
+  _ | Refl =
+    rewrite lteNil2End lte in
+    rewrite ltemEnd view0 (lteNil2End lte) in
+    END Refl
+view @{S sy} (SubM mask lte view0) {ys = ys :< z} with (viewLsb mask)
+  _ | Lsb0 n eqn with (splitExEq $ ltemEvenDrop eqn view0)
+    _ | Evidence lte' eql =
+      rewrite eqn in rewrite eql in
+      DROP (fromDROP eqn eql view0) Refl
+  _ | Lsb1 n eqn with (splitExEq $ ltemOddLeft eqn view0)
+    _ | Evidence xs' Refl =
+      let Evidence q eqq = splitExEq $ ltemOddKeep eqn view0 in
+      rewrite eqn in rewrite eqq in
+      KEEP (fromKEEP eqn eqq view0) Refl
+
+public export %inline
+(.view) : Length ys => (m : Sub xs ys) -> SubView m.lte m.mask
+(.view) = view
+
+public export %inline
+review : Length ys => {m : Nat} -> {0 lte : xs `Sub'` ys} ->
+         (0 _ : SubView lte m) -> SubView lte m
+review v = view $ sub v
+
+
+
+export
+ltemLen : (sy : Length ys) => xs `Sub` ys -> length xs `LTE` sy.nat
+ltemLen (SubM mask lte view0) {sy} with (review view0)
+  ltemLen (SubM _ _ _)            | END eq    = LTEZero
+  ltemLen (SubM _ _ _) {sy = S _} | KEEP v eq = LTESucc $ ltemLen $ sub v
+  ltemLen (SubM _ _ _) {sy = S _} | DROP v eq = lteSuccRight $ ltemLen $ sub v
+
+export
+ltemNilRight : xs `Sub` [<] -> xs = [<]
+ltemNilRight m = irrelevantEq $ lteNilRight m.lte
+
+
+export %inline
+dropLast : Length ys => (xs :< x) `Sub` ys -> xs `Sub` ys
+dropLast (SubM _ _ view0) @{sy} with (review view0)
+  dropLast (SubM _ _ _)        | KEEP v _ = drop $ sub v
+  dropLast (SubM _ _ _) @{S _} | DROP v _ = drop $ dropLast $ sub v
+
+
+export
+Uninhabited (xs :< x `Sub` [<]) where
+  uninhabited sub = void $ uninhabited sub.lte
+
+export
+Length xs => Uninhabited (xs :< x `Sub` xs) where
+  uninhabited (SubM _ _ view0) @{sx} with (review view0)
+    uninhabited (SubM _ _ _) @{S _} | KEEP v _ = uninhabited $ sub v
+    uninhabited (SubM _ _ _) @{S _} | DROP v _ = uninhabited $ dropLast $ sub v
+
+
+export
+refl : Length xs => xs `Sub` xs
+refl @{Z}   = end
+refl @{S s} = keep refl
+
+export
+0 reflLte : {sx : Length xs} -> (refl @{sx}).lte = refl' @{sx}
+reflLte {sx = Z}   = Refl
+reflLte {sx = S s} = trans (keepLte _) $ cong Keep reflLte
+
+public export %inline
+Reflexive (Scope a) Sub where reflexive = refl
+
+mutual
+  private
+  antisym_ : Length xs => Length ys =>
+             {0 p : xs `Sub'` ys} -> {0 q : ys `Sub'` xs} ->
+             SubView p m1 -> SubView q m2 -> xs = ys
+  antisym_ (END _)  (END _) = Refl
+  antisym_ (KEEP v1 _) (KEEP v2 _ {z}) @{S sx} @{S sy} =
+    cong (:< z) $ antisym (SubM _ _ v1) (SubM _ _ v2)
+  antisym_ (KEEP {}) (DROP {}) {p = Keep p} {q = Drop q} =
+    void $ succNotLTEpred $ lteLen q `transitive` lteLen p
+  antisym_ (DROP {}) (KEEP {}) {p = Drop p} {q = Keep q} =
+    void $ succNotLTEpred $ lteLen p `transitive` lteLen q
+  antisym_ (DROP {}) (DROP {}) {p = Drop p} {q = Drop q} =
+    void $ succNotLTEpred $ lteLen p `transitive` lteSuccLeft (lteLen q)
+
+  export
+  antisym : Length xs => Length ys => xs `Sub` ys -> ys `Sub` xs -> xs = ys
+  antisym v1 v2 = antisym_ v1.view v2.view
+
+public export %inline
+Antisymmetric (Scope a) Sub where
+  antisymmetric p q = antisym p q
+
+
+mutual
+  private
+  trans_ : Length ys => Length zs =>
+           {0 p : xs `Sub'` ys} -> {0 q : ys `Sub'` zs} ->
+           SubView p m1 -> SubView q m2 -> xs `Sub` zs
+  trans_ (END _) (END _) = end
+  trans_ (KEEP v1 _) (KEEP v2 _) @{S sy} @{S sz} = keep $ sub v1 `trans` sub v2
+  trans_ (DROP v1 _) (KEEP v2 _) @{S sy} @{S sz} = drop $ sub v1 `trans` sub v2
+  trans_ v1 (DROP v2 _) @{sy} @{S sz} =
+    let Element m1' eq = getMask v1 in
+    drop $ SubM m1' _ (rewrite sym eq in v1) `trans` sub v2
+
+  export
+  trans : Length ys => Length zs => xs `Sub` ys -> ys `Sub` zs -> xs `Sub` zs
+  trans p q = trans_ p.view q.view
+
+public export %inline
+(.) : Length ys => Length zs => ys `Sub` zs -> xs `Sub` ys -> xs `Sub` zs
+(.) = flip trans
+
+public export %inline
+comp : Length ys => Length zs => ys `Sub` zs -> xs `Sub` ys -> xs `Sub` zs
+comp = (.)
+
+public export %inline
+Transitive (Scope a) Sub where
+  transitive p q = q . p
+
+
+public export
+zero : Length xs => [<] `Sub` xs
+zero @{Z}   = end
+zero @{S s} = drop zero
+
+export
+0 zeroLte : {sx : Length xs} -> (zero @{sx}).lte = zero' @{sx}
+zeroLte {sx = Z}   = Refl
+zeroLte {sx = S s} = trans (dropLte zero) $ cong Drop zeroLte
+
+public export
+single : Length xs => x `Elem` xs -> [< x] `Sub` xs
+single @{S sx} Here      = keep zero
+single @{S sx} (There p) = drop $ single p
+
+export
+0 singleLte : {sx : Length xs} -> (p : x `Elem` xs) ->
+              (single p @{sx}).lte = single' p @{sx}
+singleLte {sx = S s} Here      = trans (keepLte zero) $ cong Keep zeroLte
+singleLte {sx = S s} (There p) = trans (dropLte _) $ cong Drop $ singleLte p
+
+
+mutual
+  private
+  app0 : Length ys2 =>
+         (l : xs1 `Sub` ys1) ->
+         {rm : Nat} -> {0 rl : xs2 `Sub'` ys2} -> (rv : SubView rl rm) ->
+         (xs1 ++ xs2) `Sub` (ys1 ++ ys2)
+  app0 l (END eq)              = l
+  app0 l (KEEP v Refl) @{S sy} = keep $ l ++ sub v
+  app0 l (DROP v Refl) @{S sy} = drop $ l ++ sub v
+
+  export
+  app : Length ys2 =>
+        xs1 `Sub` ys1 -> xs2 `Sub` ys2 -> (xs1 ++ xs2) `Sub` (ys1 ++ ys2)
+  app l r = app0 l r.view
+
+  public export %inline
+  (++) : Length ys2 =>
+         xs1 `Sub` ys1 -> xs2 `Sub` ys2 -> (xs1 ++ xs2) `Sub` (ys1 ++ ys2)
+  (++) = app
+
+export
+0 appLte : {sy : Length ys2} ->
+           (l : xs1 `Sub` ys1) -> (r : xs2 `Sub` ys2) ->
+           (app l r @{sy}).lte = app' l.lte r.lte
+appLte l r@(SubM 0 End (END Refl)) =
+  cong (\v => (app0 l v).lte) (viewIrrel (view end) (END Refl))
+appLte l r@(SubM (S (2 * n)) (Keep p) (KEEP v Refl)) {sy = S sy} =
+  trans (cong (\v => (app0 l v @{S sy}).lte) (viewIrrel _ (KEEP v Refl))) $
+  trans (keepLte _) $
+  cong Keep $ appLte l (sub v)
+appLte l r@(SubM 0 (Drop p) (DROP {n = 0} v Refl)) {sy = S sy} =
+  trans (cong (\v => (app0 l v @{S sy}).lte) (viewIrrel _ (DROP v Refl))) $
+  trans (dropLte _) $
+  cong Drop $ appLte l (sub v)
+appLte l r@(SubM (2 * S n) (Drop p) (DROP {n = S n} v Refl)) {sy = S sy} =
+  trans (cong (\v => (app0 l v @{S sy}).lte) (viewIrrel _ (DROP v Refl))) $
+  trans (dropLte _) $
+  cong Drop $ appLte l (sub v)
+appLte {xs2 = _ :< _, ys2 = [<]} _ (SubM _ _ _) impossible
+
+export
+0 keepAppRight : {sy : Length ys2} ->
+                 (l : xs1 `Sub` ys1) -> (r : xs2 `Sub` ys2) ->
+                 (l ++ keep r) @{S sy} = keep ((l ++ r) @{sy})
+keepAppRight l (SubM mask _ _) = rewrite (lsbOdd mask).snd in Refl
+
+export
+0 dropAppRight : (l : xs1 `Sub` ys1) -> (r : xs2 `Sub` ys2) ->
+                 (l ++ drop r) @{S sy} = drop ((l ++ r) @{sy})
+dropAppRight l r = lteEq $
+  trans (appLte l (drop r)) $
+  trans (cong (app' l.lte) (dropLte r)) $
+  trans (cong Drop (sym (appLte l r))) $
+  sym $ dropLte (l ++ r)
+
+
+export
+0 endRight : {xs, ys : Scope a} -> (sub : xs `Sub` ys) -> sub = (sub ++ Sub.end)
+endRight sub = Refl
+
+
+private
+0 transDrop_ : {p : xs `Sub'` ys} -> {q : ys `Sub'` zs} ->
+               (pv : SubView p m1) -> (qv : SubView q m2) ->
+               trans_ pv (DROP qv qe) @{sy} @{S sz} =
+                 drop (trans_ pv qv @{sy} @{sz})
+transDrop_ {sy = Z} {sz = sz} (END Refl) qv =
+  cong (\v => drop $ trans_ {m2, q} (END Refl) v) $ viewIrrel {}
+transDrop_ {sy = S sy} {sz = sz} (KEEP pv Refl) qv {p = Keep p} =
+  cong2 (\x, y => drop (trans_ @{S sy} x y)) (viewIrrel {}) (viewIrrel {})
+transDrop_ {sy = S sy} {sz = S sz} (DROP pv Refl) qv =
+  cong2 (\x, y => drop (trans_ @{S sy} @{S sz} x y))
+    (viewIrrel {}) (viewIrrel {})
+transDrop_ {ys = _ :< _, zs = [<]} _ _ impossible
+
+private
+0 transLte_ : {p : xs `Sub'` ys} -> {q : ys `Sub'` zs} ->
+              (pv : SubView p m1) -> (qv : SubView q m2) ->
+              (trans_ pv qv @{sy} @{sz}).lte = trans' p q
+transLte_ (END _) (END _) = Refl
+transLte_ (KEEP pv pe) (KEEP qv qe) {sy = S _} {sz = S _} =
+  trans (keepLte _) $ cong Keep $ transLte_ {}
+transLte_ (DROP pv pe) (KEEP qv qe) {sy = S _} {sz = S _} =
+  trans (dropLte _) $ cong Drop $ transLte_ {}
+transLte_ pv (DROP qv qe) {sz = S _} =
+  trans (cong lte $ transDrop_ pv qv) $
+  trans (dropLte _) $ cong Drop $ transLte_ pv qv
+transLte_ {ys = _ :< _, zs = [<]} _ _ impossible
+
+export
+0 transLte : {sy : Length ys} -> {sz : Length zs} ->
+             (p : xs `Sub` ys) -> (q : ys `Sub` zs) ->
+             (trans p q @{sy} @{sz}).lte = trans' p.lte q.lte
+transLte p q = transLte_ p.view q.view
+
+public export
+0 compLte : {sy : Length ys} -> {sz : Length zs} ->
+            (q : ys `Sub` zs) -> (p : xs `Sub` ys) ->
+            ((q . p) @{sy} @{sz}).lte = q.lte . p.lte 
+compLte q p = transLte p q
+
+
+||| if `p` holds for all elements of the main list,
+||| it holds for all elements of the sublist
+export
+subAll : Length ys => xs `Sub` ys -> All prop ys -> All prop xs
+subAll (SubM _ _ v) ps @{sy} with (review v)
+  subAll (SubM _ _ _) [<]               | END    _ = [<]
+  subAll (SubM _ _ _) (ps :< p) @{S sy} | KEEP v _ = subAll (sub v) ps :< p
+  subAll (SubM _ _ _) (ps :< p) @{S sy} | DROP v _ = subAll (sub v) ps
+
+
+||| if `p` holds for one element of the sublist,
+||| it holds for one element of the main list
+export
+subAny : Length ys => xs `Sub` ys -> Any prop xs -> Any prop ys
+subAny (SubM _ _ v) p @{sy} with (review v)
+  subAny (SubM _ _ _) (Here  p)         | KEEP v _ = Here p
+  subAny (SubM _ _ _) (There p) @{S sy} | KEEP v _ = There $ subAny (sub v) p
+  subAny (SubM _ _ _) p         @{S sy} | DROP v _ = There $ subAny (sub v) p

lib/Quox/Parser.idr

@@ -1,6 +1,159 @@
 module Quox.Parser
 
-import public Quox.Parser.Syntax
-import public Quox.Parser.Lexer
-import public Quox.Parser.Parser
-import public Quox.Parser.FromParser
+import Quox.Syntax
+import Quox.Token
+import Quox.Lexer
+
+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

@@ -1,429 +0,0 @@
-||| 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
-      ST (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
-      DST (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

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

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

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

lib/Quox/Parser/Parser.idr

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

@@ -1,251 +0,0 @@
-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,18 +1,16 @@
 module Quox.Pretty
 
-import Quox.Loc
 import Quox.Name
 
-import Control.Monad.ST.Extra
-import public Text.PrettyPrint.Bernardy
-import public Text.PrettyPrint.Bernardy.Core.Decorate
-import public Quox.EffExtra
+import public Text.PrettyPrint.Prettyprinter.Doc
+import Text.PrettyPrint.Prettyprinter.Render.String
+import Text.PrettyPrint.Prettyprinter.Render.Terminal
 import public Data.String
-import Control.ANSI.SGR
-
 import Data.DPair
-import Data.SnocList
-import Derive.Prelude
+
+import public Control.Monad.Identity
+import public Control.Monad.Reader
+import Generics.Derive
 
 %default total
 %language ElabReflection
@@ -21,17 +19,13 @@ import Derive.Prelude
 
 
 public export
-data PPrec
-= Outer
-| Times   -- "_ × _"
-| InTimes -- arguments of ×
-| AnnL    -- left of "∷"
-| Eq      -- "_ ≡ _ : _"
-| InEq    -- arguments of ≡
-  -- ...
-| App  -- term/dimension application
-| Arg  -- argument to nonfix function
-%runElab derive "PPrec" [Eq, Ord, Show]
+record PrettyOpts where
+  constructor MakePrettyOpts
+  unicode, color : Bool
+
+public export
+defPrettyOpts : PrettyOpts
+defPrettyOpts = MakePrettyOpts {unicode = True, color = True}
 
 
 public export
@@ -39,326 +33,168 @@ data HL
 = Delim
 | Free | TVar | TVarErr
 | Dim  | DVar | DVarErr
-| Qty  | Universe
+| Qty
 | Syntax
-| Constant
-%runElab derive "HL" [Eq, Ord, Show]
-
+%runElab derive "HL" [Generic, Meta, Eq, Ord, DecEq, Show]
 
 public export
-data Flavor = Unicode | Ascii
-%runElab derive "Flavor" [Eq, Ord, Show]
-
-export %inline
-noHighlight : HL -> Highlight
-noHighlight _ = MkHighlight "" ""
-
-
-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]
+data PPrec
+= Outer
+| Ann  -- right of "::"
+| AnnL -- left  of "::"
+  -- ...
+| App  -- term/dimension application
+| SApp -- substitution application
+| Arg  -- argument to nonfix function
+%runElab derive "PPrec" [Generic, Meta, Eq, Ord, DecEq, Show]
 
 
 export %inline
-toSGR : HL -> List SGR
-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]
+hl : HL -> Doc HL -> Doc HL
+hl = annotate
 
 export %inline
-highlightSGR : HL -> Highlight
-highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
+hl' : HL -> Doc HL -> Doc HL
+hl' h = hl h . unAnnotate
 
 export %inline
-toClass : HL -> String
-toClass Delim    = "dl"
-toClass Free     = "fr"
-toClass TVar     = "tv"
-toClass TVarErr  = "tv err"
-toClass Dim      = "dc"
-toClass DVar     = "dv"
-toClass DVarErr  = "dv err"
-toClass Qty      = "qt"
-toClass Universe = "un"
-toClass Syntax   = "sy"
-toClass Constant = "co"
+hlF : Functor f => HL -> f (Doc HL) -> f (Doc HL)
+hlF = map . hl
 
 export %inline
-highlightHtml : HL -> Highlight
-highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
+hlF' : Functor f => HL -> f (Doc HL) -> f (Doc HL)
+hlF' = map . hl'
 
 
 export %inline
-runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
-runPrettyHL f = runPrettyWith Outer Unicode f 2
+parens : Doc HL -> Doc HL
+parens doc = hl Delim "(" <+> doc <+> hl Delim ")"
 
 export %inline
-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 : Bool -> Doc HL -> Doc HL
 parensIf True  = parens
-parensIf False = pure
+parensIf False = id
 
 
-||| 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
+separate' : Doc a -> List (Doc a) -> List (Doc a)
+separate' s []        = []
+separate' s [x]       = [x]
+separate' s (x :: xs) = x <+> s :: separate' s xs
+
+export %inline
+separate : Doc a -> List (Doc a) -> Doc a
+separate s = sep . separate' s
+
+export %inline
+hseparate : Doc a -> List (Doc a) -> Doc a
+hseparate s = hsep . separate' s
+
+export %inline
+vseparate : Doc a -> List (Doc a) -> Doc a
+vseparate s = vsep . separate' s
+
+
+public export
+record PrettyEnv where
+  constructor MakePrettyEnv
+  ||| names of bound dimension variables
+  dnames  : List Name
+  ||| names of bound term variables
+  tnames  : List Name
+  ||| use non-ascii characters for syntax
+  unicode : Bool
+  ||| surrounding precedence level
+  prec    : PPrec
+
+public export
+HasEnv : (Type -> Type) -> Type
+HasEnv = MonadReader PrettyEnv
+
+export %inline
+ifUnicode : HasEnv m => (uni, asc : Lazy a) -> m a
+ifUnicode uni asc = if (!ask).unicode then [|uni|] else [|asc|]
+
+export %inline
+parensIfM : HasEnv m => PPrec -> Doc HL -> m (Doc HL)
+parensIfM d doc = pure $ parensIf ((!ask).prec > d) doc
+
+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
-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
+(forall a. PrettyHL (f a)) => PrettyHL (Exists f) where
+  prettyM x = prettyM x.snd
 
-parameters {opts : LayoutOpts} {auto _ : Foldable t}
-  export
-  separateLoose : Doc opts -> t (Doc opts) -> Doc opts
-  separateLoose d = sep . exceptLast (<++> d) . toList
+export
+PrettyHL a => PrettyHL (Subset a b) where
+  prettyM x = prettyM x.fst
 
-  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 PrettyHL BaseName where prettyM = pure . pretty . baseStr
+export PrettyHL Name     where prettyM = pure . pretty . toDots
 
 
 export %inline
-pshow : {opts : LayoutOpts} -> Show a => a -> Doc opts
-pshow = text . show
+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
+termHL Delim   = color BrightBlack
+termHL TVar    = color BrightYellow
+termHL TVarErr = color BrightYellow  <+> underline
+termHL Dim     = color BrightGreen   <+> bold
+termHL DVar    = color BrightGreen
+termHL DVarErr = color BrightGreen   <+> underline
+termHL Qty     = color BrightMagenta <+> bold
+termHL Free    = color BrightWhite
+termHL Syntax  = color BrightCyan
+
 export %inline
-ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a
-ifUnicode uni asc =
-  asksAt FLAVOR $ \case
-    Unicode => uni
-    Ascii   => asc
+prettyTerm : PrettyOpts -> PrettyHL a => a -> IO Unit
+prettyTerm opts x =
+  let reann = if opts.color then map termHL else unAnnotate in
+  Terminal.putDoc $ reann $ pretty0 opts.unicode x
 
 export %inline
-parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
-parensIfM d doc = parensIf (!(getAt PREC) > d) doc
+prettyTermDef : PrettyHL a => a -> IO Unit
+prettyTermDef = prettyTerm defPrettyOpts
 
+
+infixr 6 <//>
 export %inline
-withPrec : PPrec -> Eff Pretty a -> Eff Pretty a
-withPrec = localAt_ PREC
-
-
-export
-prettyName : Name -> Doc opts
-prettyName = text . toDots
-
-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'
-
-
+(<//>) : Doc a -> Doc a -> Doc a
+a <//> b = sep [a, b]
 
+infixr 6 </>
 export %inline
-typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
-stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD,
-zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD :
-  {opts : LayoutOpts} -> Eff Pretty (Doc opts)
-typeD     = hl Syntax . text =<< ifUnicode "★" "Type"
-ioStateD  = hl Syntax $ text "IOState"
-arrowD    = hl Syntax . text =<< ifUnicode "→" "->"
-darrowD   = hl Syntax . text =<< ifUnicode "⇒" "=>"
-timesD    = hl Syntax . text =<< ifUnicode "×" "**"
-lamD      = hl Syntax . text =<< ifUnicode "λ" "fun"
-eqndD     = hl Syntax . text =<< ifUnicode "≡" "=="
-dlamD     = hl Syntax . text =<< ifUnicode "δ" "dfun"
-annD      = hl Syntax . text =<< ifUnicode "∷" "::"
-natD      = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
-stringD   = hl Syntax   $ text "String"
-eqD       = hl Syntax   $ text "Eq"
-colonD    = hl Syntax   $ text ":"
-commaD    = hl Syntax   $ text ","
-semiD     = hl Delim    $ text ";"
-atD       = hl Delim    $ text "@"
-caseD     = hl Syntax   $ text "case"
-typecaseD = hl Syntax   $ text "type-case"
-ofD       = hl Syntax   $ text "of"
-returnD   = hl Syntax   $ text "return"
-dotD      = hl Delim    $ text "."
-zeroD     = hl Constant $ text "zero"
-succD     = hl Constant $ text "succ"
-coeD      = hl Syntax   $ text "coe"
-compD     = hl Syntax   $ text "comp"
-undD      = hl Syntax   $ text "_"
-cstD      = hl Syntax   $ text "="
-pipeD     = hl Delim    $ text "|"
-fstD      = hl Syntax   $ text "fst"
-sndD      = hl Syntax   $ text "snd"
-letD      = hl Syntax   $ text "let"
-inD       = hl Syntax   $ text "in"
-
-
-export
-prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
-            List (Doc opts) -> Doc opts
-prettyApp ind f args =
-  ifMultiline
-    (hsep (f :: args))
-    (f <++> vsep args <|> vsep (f :: map (indent ind) args))
-
-export
-prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
-             Eff Pretty (Doc opts)
-prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
-
-
-export
-escapeString : String -> String
-escapeString = concatMap esc1 . unpack where
-  esc1 : Char -> String
-  esc1 '"'  = #"\""#
-  esc1 '\\' = #"\\"#
-  esc1 '\n' = #"\n"#
-  esc1 c    = singleton c
-
-export
-quoteTag : String -> String
-quoteTag tag =
-  if isName tag then tag else
-  "\"" ++ escapeString tag ++ "\""
-
-export
-prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
-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]
-
-export
-prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
-prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
-
-export
-prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
-prettyStrLit s =
-  let s = concatMap esc1 $ unpack s in
-  hl Constant $ hcat ["\"", text s, "\""]
-where
-  esc1 : Char -> String
-  esc1 '"' = "\""; esc1 '\\' = "\\"
-  esc1 c   = singleton c
+(</>) : Doc a -> Doc a -> Doc a
+a </> b = cat [a, b]

lib/Quox/PrettyValExtra.idr

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

lib/Quox/Scope.idr

@@ -0,0 +1,94 @@
+module Quox.Scope
+
+import public Quox.OPE
+
+
+public export
+record Sub {a : Type} (t : Scoped a) (xs : Scope a) where
+  constructor Su
+  {0 support : Scope a}
+  term : t support
+  thin : support `LTE` xs
+
+public export
+CoverS : Sub s xs -> Sub t xs -> Type
+CoverS ss tt = Cover ss.thin tt.thin
+
+export %inline
+inj : Length xs => t xs -> Sub t xs
+inj x = Su x id
+
+export %inline
+flat : Sub (Sub t) xs -> Sub t xs
+flat (Su (Su x q) p) = Su x (p . q)
+
+export %inline
+thinSub : xs `LTE` ys -> Sub t xs -> Sub t ys
+thinSub p x = flat $ Su x p
+
+export %inline
+map : (forall x. s x -> t x) -> Sub s x -> Sub t x
+map f = {term $= f}
+
+public export
+data Unit : Scoped a where
+  Nil : Unit [<]
+
+export %inline
+unit : Length xs => Sub Unit xs
+unit = Su [] zero
+
+public export
+record Coprod {a : Type} {xs, ys, zs : Scope a}
+              (p : xs `LTE` zs) (q : ys `LTE` zs) where
+  constructor Cop
+  {0 scope : Scope a}
+  {thin : scope `LTE` zs}
+  {thinP : xs `LTE` scope}
+  {thinQ : ys `LTE` scope}
+  compP : Comp thin thinP p
+  compQ : Comp thin thinQ q
+  0 cover : Cover thinP thinQ
+
+export
+coprod : (p : xs `LTE` zs) -> (q : ys `LTE` zs) -> Coprod p q
+coprod End      End      = %search
+coprod (Keep p) (Keep q) = let Cop {} = coprod p q in %search
+coprod (Keep p) (Drop q) = let Cop {} = coprod p q in %search
+coprod (Drop p) (Keep q) = let Cop {} = coprod p q in %search
+coprod (Drop p) (Drop q) =
+  -- idk why this one is harder to solve
+  let Cop compP compQ cover = coprod p q in
+  Cop (CD0 compP) (CD0 compQ) cover
+
+public export
+record Pair {a : Type} (s, t : Scoped a) (zs : Scope a) where
+  constructor MkPair
+  fst : Sub s zs
+  snd : Sub t zs
+  0 cover : CoverS fst snd
+
+export
+pair : Sub s xs -> Sub t xs -> Sub (Pair s t) xs
+pair (Su x p) (Su y q) =
+  let c = coprod p q in
+  Su (MkPair (Su x c.thinP) (Su y c.thinQ) c.cover) c.thin
+
+
+public export
+data Var : a -> Scope a -> Type where
+  Only : Var x [< x]
+
+export %inline
+var : (0 x : a) -> [< x] `LTE` xs => Sub (Var x) xs
+var x @{p} = Su Only p
+
+
+infix 0 \\\, \\
+public export
+data Bind : (t : Scoped a) -> (new, old : Scope a) -> Type where
+  (\\\) : new' `LTE` new -> t (old ++ new') -> Bind t new old
+
+(\\) : (new : Scope a) -> Sub t (old ++ new) -> Sub (Bind t new) old
+vs \\ Su term p with (split vs p)
+  vs \\ Su term (l ++ r) | MkSplit l r Refl Refl = Su (r \\\ term) l

lib/Quox/Scoped.idr

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

lib/Quox/Syntax.idr

@@ -6,5 +6,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.Builtin
-import public Quox.Var
+import public Quox.Syntax.Universe
+import public Quox.Syntax.Var

lib/Quox/Syntax/Builtin.idr

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

lib/Quox/Syntax/Dim.idr

@@ -1,35 +1,94 @@
 module Quox.Syntax.Dim
 
-import Quox.Loc
-import Quox.Name
-import Quox.Var
+import Quox.Syntax.Var
 import Quox.Syntax.Subst
 import Quox.Pretty
-import Quox.Context
-import Quox.PrettyValExtra
 
 import Decidable.Equality
 import Control.Function
-import Derive.Prelude
+import Generics.Derive
 
 %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]
 
-||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
+%runElab derive "DimConst" [Generic, Meta, Eq, Ord, DecEq, Show]
+
+
 public export
-ends : Lazy a -> Lazy a -> DimConst -> a
-ends l r Zero = l
-ends l r One  = r
+data Dim : Nat -> Type where
+  K : DimConst -> Dim d
+  B : Var d -> Dim d
+%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
@@ -37,104 +96,13 @@ DecEq DimConst where
   decEq One  Zero = No absurd
   decEq One  One  = Yes Refl
 
-
 public export
-data Dim : Nat -> Type where
-  K : DimConst -> Loc -> Dim d
-  B : Var d -> Loc -> Dim d
-%name Dim.Dim p, q
-%runElab deriveIndexed "Dim" [Eq, Ord, Show]
-
-
-||| `endsOr l r x p` returns `ends l r ε` if `p` is a constant ε, and
-||| `x` otherwise.
-public export
-endsOr : Lazy a -> Lazy a -> Lazy a -> Dim n -> a
-endsOr l r x (K e _) = ends l r e
-endsOr l r x (B _ _) = x
-
-
-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
+DecEq (Dim d) where
+  decEq (K e) (K f) with (decEq e f)
+    _ | Yes prf    = Yes $ cong K prf
+    _ | No  contra = No  $ contra . injective
+  decEq (K e) (B j) = No absurd
+  decEq (B i) (K f) = No absurd
+  decEq (B i) (B j) with (decEq i j)
+    _ | Yes prf    = Yes $ cong B prf
+    _ | No  contra = No  $ contra . injective

lib/Quox/Syntax/DimEq.idr

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

lib/Quox/Syntax/Qty.idr

@@ -1,154 +1,84 @@
-||| 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 Quox.PrettyValExtra
-import Data.DPair
-import Derive.Prelude
+
+import Data.Fin
+import Generics.Derive
 
 %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
-prettyQty : {opts : _} -> Qty -> Eff Pretty (Doc opts)
-prettyQty Zero = hl Qty $ text "0"
-prettyQty One  = hl Qty $ text "1"
-prettyQty Any  = hl Qty =<< ifUnicode (text "ω") (text "#")
+PrettyHL Qty where
+  prettyM pi = hl Qty <$>
+    case pi of
+      Zero => ifUnicode "𝟬" "0"
+      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
-prettySuffix : {opts : _} -> Qty -> Eff Pretty (Doc opts)
-prettySuffix = prettyQty
+plus : Qty -> Qty -> Qty
+plus Zero rh   = rh
+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
-(+) : Qty -> Qty -> Qty
-Zero + rh   = rh
-pi   + Zero = pi
-_    + _    = Any
+times : Qty -> Qty -> Qty
+times Zero _    = Zero
+times _    Zero = Zero
+times One  rh   = rh
+times pi   One  = pi
+times Any  Any  = Any
 
-||| 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 π.
+infix 6 <=.
 public export
 compat : Qty -> Qty -> Bool
-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
+compat pi rh = rh == Any || pi == rh
 
 
 public export
-DecEq Qty where
-  decEq Zero Zero = Yes Refl
-  decEq Zero One  = No $ \case _ impossible
-  decEq Zero Any  = No $ \case _ impossible
-  decEq One  Zero = No $ \case _ impossible
-  decEq One  One  = Yes Refl
-  decEq One  Any  = No $ \case _ impossible
-  decEq Any  Zero = No $ \case _ impossible
-  decEq Any  One  = No $ \case _ impossible
-  decEq Any  Any  = Yes Refl
+interface IsQty q where
+  zero, one : q
+  (+),  (*) : q -> q -> q
+  (<=.)     : q -> q -> Bool
 
 public export
-DecEq SQty where
-  decEq SZero SZero = Yes Refl
-  decEq SZero SOne  = No $ \case _ impossible
-  decEq SOne  SZero = No $ \case _ impossible
-  decEq SOne  SOne  = Yes Refl
+IsQty Qty where
+  zero  = Zero; one = One
+  (+)   = plus; (*) = times
+  (<=.) = compat
+
 
 public export
-DecEq GQty where
-  decEq GZero GZero = Yes Refl
-  decEq GZero GAny  = No $ \case _ impossible
-  decEq GAny  GZero = No $ \case _ impossible
-  decEq GAny  GAny  = Yes Refl
+data IsSubj : Qty -> Type where
+  SZero : IsSubj Zero
+  SOne  : IsSubj One
 
+export Uninhabited (IsSubj Any) where uninhabited _ impossible
 
-namespace SQty
-  public export %inline
-  (.qty) : SQty -> Qty
-  (SZero).qty = Zero
-  (SOne).qty  = One
+public export
+data IsGlobal : Qty -> Type where
+  GZero : IsGlobal Zero
+  GAny  : IsGlobal Any
 
-namespace GQty
-  public export %inline
-  (.qty) : GQty -> Qty
-  (GZero).qty = Zero
-  (GAny).qty  = Any
+export Uninhabited (IsGlobal One) where uninhabited _ impossible

lib/Quox/Syntax/Shift.idr

@@ -1,18 +1,17 @@
 module Quox.Syntax.Shift
 
-import public Quox.Var
+import public Quox.Syntax.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 : (from, to : Nat) -> Type where
+data Shift : (0 from, to : Nat) -> Type where
   SZ : Shift from from
   SS : Shift from to -> Shift from (S to)
 %name Shift by, bz
@@ -36,28 +35,20 @@ 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 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
-
+%name Eqv e
 
+||| two equivalent shifts are equal if they have the same indices.
 export
-cmpLen : Shift from1 to -> Shift from2 to -> Either Ordering (from1 = from2)
-cmpLen SZ      SZ      = Right Refl
-cmpLen SZ      (SS by) = Left LT
-cmpLen (SS by) SZ      = Left GT
-cmpLen (SS by) (SS bz) = cmpLen by bz
+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
+
 
 export
 0 shiftDiff : (by : Shift from to) -> to = by.nat + from
@@ -129,44 +120,6 @@ ssDownViaNat by =
 %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
 shift : Shift from to -> Var from -> Var to
 shift SZ      i = i
@@ -191,6 +144,7 @@ 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
@@ -199,12 +153,15 @@ by . SS bz = SS $ by . bz
 private
 0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
                  to = by.nat + bz.nat + from
-compNatProof by bz = Calc $
-  |~ to
-  ~~ bz.nat + mid             ...(shiftDiff {})
-  ~~ bz.nat + (by.nat + from) ...(cong (bz.nat +) (shiftDiff {}))
-  ~~ bz.nat + by.nat + from   ...(plusAssociative {})
-  ~~ by.nat + bz.nat + from   ...(cong (+ from) (plusCommutative {}))
+compNatProof by bz =
+  shiftDiff bz                       >>>
+  cong (bz.nat +) (shiftDiff by)     >>>
+  plusAssociative bz.nat by.nat from >>>
+  cong (+ from) (plusCommutative bz.nat by.nat)
+ where
+  infixr 0 >>>
+  0 (>>>) : a = b -> b = c -> a = c
+  x >>> y = trans x y
 
 private %inline
 compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
@@ -227,6 +184,24 @@ compViaNatCorrect by (SS bz) =
 %transform "Shift.(.)" Shift.(.) = compViaNat
 
 
+||| `prettyShift bnd unicode prec by` pretty-prints the shift `by`, with the
+||| 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

lib/Quox/Syntax/Subst.idr

@@ -1,31 +1,22 @@
 module Quox.Syntax.Subst
 
 import public Quox.Syntax.Shift
-import Quox.Var
+import Quox.Syntax.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
 
-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
@@ -37,26 +28,30 @@ repr (Shift by) = ([], by.nat)
 repr (t ::: th) = let (ts, i) = repr th in (t::ts, i)
 
 
-export Eq   (f to) => Eq   (Subst f from to) where (==) = (==) `on` repr
-export Ord  (f to) => Ord  (Subst f from to) where compare = compare `on` repr
-export Show (f to) => Show (Subst f from to) where show = show . repr
+export 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
 
 
 infixl 8 //
 public export
-interface FromVar term => CanSubstSelf term where
-  (//) : term from -> Lazy (Subst term from to) -> term to
+interface FromVar env => CanSubst env term where
+  (//) : term from -> Lazy (Subst env 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
-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
+CanSubst Var Var where
   i    // Shift by   = shift by i
   VZ   // (t ::: th) = t
   VS i // (t ::: th) = i // th
@@ -66,13 +61,10 @@ 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
-(.) : CanSubstSelf f => Subst f from mid -> Subst f mid to -> Subst f from to
+(.) : CanSubst1 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
@@ -82,13 +74,6 @@ 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
@@ -96,18 +81,8 @@ map f (t ::: th) = f t ::: map f th
 
 
 public export %inline
-push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
-push loc th = fromVarLoc VZ loc ::: (th . shift 1)
-
--- [fixme] a better way to do this?
-public export
-pushN : CanSubstSelf f => (s : Nat) -> Loc ->
-        Subst f from to -> Subst f (s + from) (s + to)
-pushN 0     _   th = th
-pushN (S s) loc th =
-  rewrite plusSuccRightSucc s from in
-  rewrite plusSuccRightSucc s to in
-  pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
+push : CanSubst1 f => Subst f from to -> Subst f (S from) (S to)
+push th = fromVar VZ ::: (th . shift 1)
 
 public export
 drop1 : Subst f (S from) to -> Subst f from to
@@ -115,55 +90,40 @@ drop1 (Shift by) = Shift $ ssDown by
 drop1 (t ::: th) = th
 
 
-public export
-fromSnocVect : SnocVect s (f n) -> Subst f (s + n) n
-fromSnocVect [<]       = id
-fromSnocVect (xs :< x) = x ::: fromSnocVect xs
-
 public export %inline
 one : f n -> Subst f (S n) n
-one x = fromSnocVect [< x]
+one x = x ::: id
 
 
+||| `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
-getFrom : {to : Nat} -> Subst _ from to -> Singleton from
-getFrom (Shift by) = getFrom by
-getFrom (t ::: th) = [|S $ getFrom th|]
+prettySubstM : Pretty.HasEnv m =>
+               (pr : f to -> m (Doc HL)) ->
+               (names : List Name) -> (bnd : HL) -> (op, cl : Doc HL) ->
+               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|]
 
-||| 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
+||| prints with [square brackets] and the `TVar` highlight for variables
 export
-cmpShape : Subst env from1 to -> Subst env from2 to ->
-           Either Ordering (from1 = from2)
-cmpShape (Shift by) (Shift bz) = cmpLen by bz
-cmpShape (Shift _)  (_ ::: _)  = Left LT
-cmpShape (_ ::: _)  (Shift _)  = Left GT
-cmpShape (_ ::: th) (_ ::: ph) = map (\x => cong S x) $ cmpShape th ph
-
-
-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
+PrettyHL (f to) => PrettyHL (Subst f from to) where
+  prettyM th = prettySubstM prettyM (!ask).tnames TVar "[" "]" th

lib/Quox/Syntax/Term.idr

@@ -1,6 +1,7 @@
 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
-import public Quox.Syntax.Term.Tighten

lib/Quox/Syntax/Term/Base.idr

@@ -1,15 +1,13 @@
 module Quox.Syntax.Term.Base
 
-import public Quox.Var
-import public Quox.Scoped
+import public Quox.Syntax.Var
 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.Loc
-import public Quox.Context
+import public Quox.OPE
 
 import Quox.Pretty
 
@@ -19,430 +17,94 @@ import Data.Maybe
 import Data.Nat
 import public Data.So
 import Data.String
-import public Data.SortedMap
-import public Data.SortedMap.Dependent
-import public Data.SortedSet
-import Derive.Prelude
+import Data.Vect
 
 %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 :@, :%
+infixl 9 :@
 mutual
   public export
-  TSubst : TSubstLike
-  TSubst d = Subst $ \n => Elim d n
+  TSubst : Nat -> Nat -> Nat -> Type
+  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) -> (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
+    TYPE : (l : Universe) -> Term d n
 
     ||| function type
-    Pi  : (qty : Qty) -> (arg : Term d n) ->
-          (res : ScopeTerm d n) -> (loc : Loc) -> Term d n
+    Pi  : (qty : Qty) -> (x : Name) ->
+          (arg : Term d n) -> (res : ScopeTerm d n) -> Term d n
     ||| function term
-    Lam : (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
-
-    ||| pair type
-    Sig : (fst : Term d n) -> (snd : ScopeTerm d n) -> (loc : Loc) -> Term d n
-    ||| pair value
-    Pair : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
-
-    ||| enumeration type
-    Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term d n
-    ||| enumeration value
-    Tag : (tag : TagVal) -> (loc : Loc) -> Term d n
-
-    ||| equality type
-    Eq : (ty : DScopeTerm d n) -> (l, r : Term d n) -> (loc : Loc) -> Term d n
-    ||| equality term
-    DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
-
-    ||| natural numbers (temporary until 𝐖 gets added)
-    NAT : (loc : Loc) -> Term d n
-    Nat : (val : Nat) -> (loc : Loc) -> Term d n
-    Succ : (p : Term d n) -> (loc : Loc) -> Term d n
-
-    ||| strings
-    STRING : (loc : Loc) -> Term d n
-    Str    : (str : String) -> (loc : Loc) -> Term d n
-
-    ||| "box" (package a value up with a certain quantity)
-    BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
-    Box : (val : Term d n) -> (loc : Loc) -> Term d n
-
-    Let : (qty : Qty) -> (rhs : Elim d n) ->
-          (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
+    Lam : (x : Name) -> (body : ScopeTerm d n) -> Term d n
 
     ||| elimination
     E : (e : Elim d n) -> Term d n
 
     ||| term closure/suspended substitution
-    CloT  : WithSubst (Term d) (Elim d) n -> Term d n
+    CloT  : (tm : Term d from)  -> (th : Lazy (TSubst d from to)) -> Term d to
     ||| dimension closure/suspended substitution
-    DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
-  %name Term s, t, r
+    DCloT : (tm : Term dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Term dto n
 
   ||| first argument `d` is dimension scope size, second `n` is term scope size
   public export
   data Elim : (d, n : Nat) -> Type where
-    ||| free variable, possibly with a displacement (see @crude, or @mugen for a
-    ||| more abstract and formalised take)
-    |||
-    ||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
-    F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim d n
+    ||| free variable
+    F : (x : Name) -> Elim d n
     ||| bound variable
-    B : (i : Var n) -> (loc : Loc) -> Elim d n
+    B : (i : Var n) -> Elim d n
 
     ||| term application
-    App : (fun : Elim d n) -> (arg : Term d n) -> (loc : Loc) -> Elim d n
-
-    ||| pair destruction
-    |||
-    ||| `CasePair 𝜋 𝑒 ([𝑟], 𝐴) ([𝑥, 𝑦], 𝑡)` is
-    ||| `𝐜𝐚𝐬𝐞 𝜋 · 𝑒 𝐫𝐞𝐭𝐮𝐫𝐧 𝑟 ⇒ 𝐴 𝐨𝐟 { (𝑥, 𝑦) ⇒ 𝑡 }`
-    CasePair : (qty : Qty) -> (pair : Elim d n) ->
-               (ret : ScopeTerm d n) ->
-               (body : ScopeTermN 2 d n) ->
-               (loc : Loc) ->
-               Elim d n
-
-    ||| first element of a pair. only works in non-linear contexts.
-    Fst : (pair : Elim d n) -> (loc : Loc) -> Elim d n
-
-    ||| second element of a pair. only works in non-linear contexts.
-    Snd : (pair : Elim d n) -> (loc : Loc) -> Elim d n
-
-    ||| enum matching
-    CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
-               (ret : ScopeTerm d n) ->
-               (arms : CaseEnumArms d n) ->
-               (loc : Loc) ->
-               Elim d n
-
-    ||| nat matching
-    CaseNat : (qty, qtyIH : Qty) -> (nat : Elim d n) ->
-              (ret : ScopeTerm d n) ->
-              (zero : Term d n) ->
-              (succ : ScopeTermN 2 d n) ->
-              (loc : Loc) ->
-              Elim d n
-
-    ||| unboxing
-    CaseBox : (qty : Qty) -> (box : Elim d n) ->
-              (ret : ScopeTerm d n) ->
-              (body : ScopeTerm d n) ->
-              (loc : Loc) ->
-              Elim d n
-
-    ||| dim application
-    DApp : (fun : Elim d n) -> (arg : Dim d) -> (loc : Loc) -> Elim d n
+    (:@) : (fun : Elim d n) -> (arg : Term d n) -> Elim d n
 
     ||| type-annotated term
-    Ann : (tm, ty : Term d n) -> (loc : Loc) -> Elim d n
-
-    ||| coerce a value along a type equality, or show its coherence
-    ||| [@xtt; §2.1.1]
-    Coe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
-          (val : Term d n) -> (loc : Loc) -> Elim d n
-
-    ||| "generalised composition" [@xtt; §2.1.2]
-    Comp : (ty : Term d n) -> (p, q : Dim d) ->
-           (val : Term d n) -> (r : Dim d) ->
-           (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
-
-    ||| match on types. needed for b.s. of coercions [@xtt; §2.2]
-    TypeCase : (ty : Elim d n) -> (ret : Term d n) ->
-               (arms : TypeCaseArms d n) -> (def : Term d n) ->
-               (loc : Loc) ->
-               Elim d n
+    (:#) : (tm, ty : Term d n) -> Elim d n
 
     ||| term closure/suspended substitution
-    CloE  : WithSubst (Elim d) (Elim d) n -> Elim d n
+    CloE  : (el : Elim d from)  -> (th : Lazy (TSubst d from to)) -> Elim d to
     ||| dimension closure/suspended substitution
-    DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
-  %name Elim e, f
+    DCloE : (el : Elim dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Elim dto n
 
+  ||| a scope with one more bound variable
   public export
-  CaseEnumArms : TermLike
-  CaseEnumArms d n = SortedMap TagVal (Term d n)
+  data ScopeTerm : (d, n : Nat) -> Type where
+    ||| variable is used
+    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
-  TypeCaseArms : TermLike
-  TypeCaseArms d n = SortedDMap TyConKind (\k => TypeCaseArmBody k d n)
+  data DScopeTerm : (d, n : Nat) -> Type where
+    ||| variable is used
+    DUsed : (body : Term (S d) n) -> DScopeTerm d n
+    ||| variable is unused
+    DUnused : (body : Term d n) -> DScopeTerm d n
 
-  public export
-  TypeCaseArm : TermLike
-  TypeCaseArm d n = (k ** TypeCaseArmBody k d n)
-
-  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}
+%name Term s, t, r
+%name Elim e, f
+%name ScopeTerm body
+%name DScopeTerm body
 
 public export %inline
-LamN : (body : Term d n) -> (loc : Loc) -> Term d n
-LamN {body, loc} = Lam {body = SN body, loc}
-
-||| non dependent function type
-public export %inline
-Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n
-Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}
-
-||| more convenient Sig
-public export %inline
-SigY : (x : BindName) -> (fst : Term d n) ->
-       (snd : Term d (S n)) -> (loc : Loc) -> Term d n
-SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}
-
-||| non dependent pair type
-public export %inline
-And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
-And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}
-
-||| more convenient Eq
-public export %inline
-EqY : (i : BindName) -> (ty : Term (S d) n) ->
-      (l, r : Term d n) -> (loc : Loc) -> Term d n
-EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}
-
-||| more convenient DLam
-public export %inline
-DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
-DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}
-
-public export %inline
-DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
-DLamN {body, loc} = DLam {body = SN body, loc}
-
-||| non dependent equality type
-public export %inline
-Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
-Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
+Arr : (qty : Qty) -> (arg, res : Term d n) -> Term d n
+Arr {qty, arg, res} = Pi {qty, x = "_", arg, res = TUnused res}
 
 ||| same as `F` but as a term
 public export %inline
-FT : Name -> Universe -> Loc -> Term d n
-FT x u loc = E $ F x u loc
-
-||| same as `B` but as a term
-public export %inline
-BT : Var n -> (loc : Loc) -> Term d n
-BT i loc = E $ B i loc
+FT : Name -> Term d n
+FT = E . F
 
 ||| abbreviation for a bound variable like `BV 4` instead of
 ||| `B (VS (VS (VS (VS VZ))))`
 public export %inline
-BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n
-BV i loc = B (V i) loc
+BV : (i : Nat) -> (0 _ : LT i n) => Elim d n
+BV i = B $ V i
 
 ||| same as `BV` but as a term
 public export %inline
-BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
-BVT i loc = E $ BV i loc
-
-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
+BVT : (i : Nat) -> (0 _ : LT i n) => Term d n
+BVT i = E $ BV i

lib/Quox/Syntax/Term/Pretty.idr

@@ -1,623 +1,86 @@
 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
 
 
-export
-prettyUniverse : {opts : _} -> Universe -> Eff Pretty (Doc opts)
-prettyUniverse = hl Universe . text . show
-
-
-export
-prettyTerm : {opts : _} -> BContext d -> BContext n -> Term d n ->
-             Eff Pretty (Doc opts)
-
-export
-prettyElim : {opts : _} -> BContext d -> BContext n -> Elim d n ->
-             Eff Pretty (Doc opts)
-
-private
-BTelescope : Nat -> Nat -> Type
-BTelescope = Telescope' BindName
-
-
-private
-superscript : String -> String
-superscript = pack . map sup . unpack where
-  sup : Char -> Char
-  sup c = case c of
-    '0' => '⁰'; '1' => '¹'; '2' => '²'; '3' => '³'; '4' => '⁴'
-    '5' => '⁵'; '6' => '⁶'; '7' => '⁷'; '8' => '⁸'; '9' => '⁹'; _ => c
-
-
-private
-PiBind : Nat -> Nat -> Type
-PiBind d n = (Qty, BindName, Term d n)
-
-private
-pbname : PiBind d n -> BindName
-pbname (_, x, _) = x
-
-private
-record SplitPi d n where
-  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
+parameters {auto _ : Pretty.HasEnv m}
+  private %inline arrowD : m (Doc HL)
+  arrowD = hlF Syntax $ ifUnicode "→" "->"
+
+  private %inline lamD : m (Doc HL)
+  lamD = hlF Syntax $ ifUnicode "λ" "fun"
+
+  private %inline annD : m (Doc HL)
+  annD = hlF Syntax $ ifUnicode "⦂" "::"
+
+private %inline typeD : Doc HL
+typeD = hl Syntax "Type"
+
+private %inline colonD : Doc HL
+colonD = hl Syntax ":"
+
+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
+  PrettyHL (Elim d n) where
+    prettyM (F x) =
+      hl' Free <$> prettyM x
+    prettyM (B i) =
+      prettyVar TVar TVarErr (!ask).tnames i
+    prettyM (e :@ s) =
+      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
+  prettyTSubst : Pretty.HasEnv m => TSubst d from to -> m (Doc HL)
+  prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s
+
+  export covering
+  prettyBinder : Pretty.HasEnv m => List Qty -> Name -> Term d n -> m (Doc HL)
+  prettyBinder pis x a =
+    pure $ parens $ hang 2 $
+      hsep [hl TVar !(prettyM x),
+            sep [!(prettyQtyBinds pis),
+                 hsep [colonD, !(withPrec Outer $ prettyM a)]]]

lib/Quox/Syntax/Term/Reduce.idr

@@ -0,0 +1,301 @@
+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
+
+
+{- [todo] remove these probably?
+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

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

lib/Quox/Syntax/Term/Subst.idr

@@ -1,88 +1,27 @@
 module Quox.Syntax.Term.Subst
 
-import Quox.No
 import Quox.Syntax.Term.Base
-import Data.SnocVect
 
 %default total
 
-namespace CanDSubst
-  public export
-  interface CanDSubst (0 tm : TermLike) where
-    (//) : tm d1 n -> Lazy (DSubst d1 d2) -> tm d2 n
+
+export FromVar (Elim d) where fromVar = B
+export FromVar (Term d) where fromVar = E . fromVar
 
 ||| does the minimal reasonable work:
-||| - deletes the closure around an atomic constant like `TYPE`
-||| - deletes an identity substitution
-||| - composes (lazily) with an existing top-level dim-closure
-||| - otherwise, wraps in a new closure
-export
-CanDSubst Term where
-  s                // Shift SZ = s
-  TYPE l loc       // _        = TYPE l loc
-  DCloT (Sub s ph) // th       = DCloT $ Sub s $ ph . th
-  s                // th       = DCloT $ Sub s th
-
-private
-subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
-subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
-subDArgs e              th = DCloE $ Sub e th
-
-||| does the minimal reasonable work:
-||| - deletes the closure around a term variable
-||| - deletes an identity substitution
-||| - composes (lazily) with an existing top-level dim-closure
-||| - immediately looks up bound variables in a
-|||   top-level sequence of dimension applications
-||| - otherwise, wraps in a new closure
-export
-CanDSubst Elim where
-  e                // Shift SZ = e
-  F x u loc        // _        = F x u loc
-  B i loc          // _        = B i loc
-  e@(DApp {})      // th       = subDArgs e th
-  DCloE (Sub e ph) // th       = DCloE $ Sub e $ ph . th
-  e                // th       = DCloE $ Sub e th
-
-namespace DSubst.ScopeTermN
-  export %inline
-  (//) : ScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
-         ScopeTermN s d2 n
-  S ns (Y body) // th = S ns $ Y $ body // th
-  S ns (N body) // th = S ns $ N $ body // th
-
-namespace DSubst.DScopeTermN
-  export %inline
-  (//) : {s : Nat} ->
-         DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
-         DScopeTermN s d2 n
-  S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
-  S ns (N body) // th = S ns $ N $ body // th
-
-
-export %inline FromVar (Elim d) where fromVarLoc = B
-export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
-
-
-||| does the minimal reasonable work:
-||| - deletes the closure around a *free* name
+||| - deletes the closure around a free name since it doesn't do anything
 ||| - deletes an identity substitution
 ||| - composes (lazily) with an existing top-level closure
 ||| - immediately looks up a bound variable
 ||| - otherwise, wraps in a new closure
 export
-CanSubstSelf (Elim d) where
-  F x u loc       // _  = F x u loc
-  B i loc         // th = getLoc th i loc
-  CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th
-  e               // th = case force th of
-                               Shift SZ => e
-                               th       => CloE $ Sub e th
-
-namespace CanTSubst
-  public export
-  interface CanTSubst (0 tm : TermLike) where
-    (//) : tm d n1 -> Lazy (TSubst d n1 n2) -> tm d n2
+CanSubst (Elim d) (Elim d) where
+  F x       // _  = F x
+  B i       // th = th !! i
+  CloE e ph // th = assert_total CloE e $ ph . th
+  e         // th = case force th of
+                         Shift SZ => e
+                         th       => CloE e th
 
 ||| does the minimal reasonable work:
 ||| - deletes the closure around an atomic constant like `TYPE`
@@ -91,266 +30,106 @@ namespace CanTSubst
 ||| - goes inside `E` in case it is a simple variable or something
 ||| - otherwise, wraps in a new closure
 export
-CanTSubst Term where
-  TYPE l loc      // _  = TYPE l loc
-  E e             // th = E $ e // th
-  CloT (Sub s ph) // th = CloT $ Sub s $ ph . th
-  s               // th = case force th of
-                               Shift SZ => s
-                               th       => CloT $ Sub s th
+CanSubst (Elim d) (Term d) where
+  TYPE l    // _  = TYPE l
+  E e       // th = E $ e // th
+  CloT s ph // th = CloT s $ ph . th
+  s         // th = case force th of
+                         Shift SZ => s
+                         th       => CloT s th
 
-namespace ScopeTermN
-  export %inline
-  (//) : {s : Nat} ->
-         ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
-         ScopeTermN s d n2
-  S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
-  S ns (N body) // th = S ns $ N $ body // th
+export
+CanSubst (Elim d) (ScopeTerm d) where
+  TUsed   body // th = TUsed   $ body // push th
+  TUnused body // th = TUnused $ body // th
 
-namespace DScopeTermN
-  export %inline
-  (//) : {s : Nat} ->
-         DScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> DScopeTermN s d n2
-  S ns (Y body) // th = S ns $ Y $ body // map (// shift s) th
-  S ns (N body) // th = S ns $ N $ body // th
-
-export %inline CanShift (Term d) where s // by = s // Shift by
-export %inline CanShift (Elim d) where e // by = e // Shift by
-
-export %inline CanShift (flip Term n) where s // by = s // Shift by
-export %inline CanShift (flip Elim n) where e // by = e // Shift by
-
-export %inline
-{s : Nat} -> CanShift (ScopeTermN s d) where
-  b // by = b // Shift by
+export CanSubst Var (Term      d) where s // th = s // map (B {d}) th
+export CanSubst Var (Elim      d) where e // th = e // map (B {d}) th
+export CanSubst Var (ScopeTerm d) where s // th = s // map (B {d}) th
 
 
-export %inline
-comp : DSubst d1 d2 -> TSubst d1 n1 mid -> TSubst d2 mid n2 -> TSubst d2 n1 n2
-comp th ps ph = map (// th) ps . ph
-
-
-public export %inline
-dweakT : (by : Nat) -> Term d n -> Term (by + d) n
-dweakT by t = t // shift by
-
-public export %inline
-dweakS : (by : Nat) -> ScopeTermN s d n -> ScopeTermN s (by + d) n
-dweakS by t = t // shift by
-
-public export %inline
-dweakDS : {s : Nat} -> (by : Nat) ->
-          DScopeTermN s d n -> DScopeTermN s (by + d) n
-dweakDS by t = t // shift by
-
-public export %inline
-dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
-dweakE by t = t // shift by
-
-
-public export %inline
-weakT : (by : Nat) -> Term d n -> Term d (by + n)
-weakT by t = t // shift by
-
-public export %inline
-weakS : {s : Nat} -> (by : Nat) -> ScopeTermN s d n -> ScopeTermN s d (by + n)
-weakS by t = t // shift by
-
-public export %inline
-weakDS : {s : Nat} -> (by : Nat) ->
-         DScopeTermN s d n -> DScopeTermN s d (by + n)
-weakDS by t = t // shift by
-
-public export %inline
-weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
-weakE by t = t // shift by
-
-
-parameters {auto _ : CanShift f} {s : Nat}
-  export %inline
-  getTerm : ScopedBody s f n -> f (s + n)
-  getTerm (Y b) = b
-  getTerm (N b) = b // fromNat s
-
-  export %inline
-  (.term) : Scoped s f n -> f (s + n)
-  t.term = getTerm t.body
-
-namespace ScopeTermBody
-  export %inline
-  getTerm0 : ScopedBody 0 f n -> f n
-  getTerm0 (Y b) = b
-  getTerm0 (N b) = b
-
-namespace ScopeTermN
-  export %inline
-  (.term0) : Scoped 0 f n -> f n
-  t.term0 = getTerm0 t.body
-
-export %inline
-subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
-subN (S _ (Y body)) es = body // fromSnocVect es
-subN (S _ (N body)) _  = body
-
-export %inline
-sub1 : ScopeTerm d n -> Elim d n -> Term d n
-sub1 t e = subN t [< e]
-
-export %inline
-dsubN : DScopeTermN s d n -> SnocVect s (Dim d) -> Term d n
-dsubN (S _ (Y body)) ps = body // fromSnocVect ps
-dsubN (S _ (N body)) _  = body
-
-export %inline
-dsub1 : DScopeTerm d n -> Dim d -> Term d n
-dsub1 t p = dsubN t [< p]
-
-
-public export %inline
-(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
-body.zero = dsub1 body $ K Zero loc
-
-public export %inline
-(.one) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
-body.one = dsub1 body $ K One loc
-
-
-public export
-0 CloTest : TermLike -> Type
-CloTest tm = forall d, n. tm d n -> Bool
-
-public export
-interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
-  pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
-                   tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
-
-public export
-0 NotClo : {isClo : CloTest tm} -> PushSubsts tm isClo => Pred (tm d n)
-NotClo = No . isClo
-
-public export
-0 NonClo : (tm : TermLike) -> {isClo : CloTest tm} ->
-           PushSubsts tm isClo => TermLike
-NonClo tm d n = Subset (tm d n) NotClo
-
-public export %inline
-nclo : {isClo : CloTest tm} -> (0 _ : PushSubsts tm isClo) =>
-       (t : tm d n) -> (0 nc : NotClo t) => NonClo tm d n
-nclo t = Element t nc
-
-parameters {0 isClo : CloTest tm} {auto _ : PushSubsts tm isClo}
-  ||| if the input term has any top-level closures, push them under one layer of
-  ||| syntax
-  export %inline
-  pushSubsts : tm d n -> NonClo tm d n
-  pushSubsts s = pushSubstsWith id id s
-
-  export %inline
-  pushSubstsWith' : DSubst d1 d2 -> TSubst d2 n1 n2 -> tm d1 n1 -> tm d2 n2
-  pushSubstsWith' th ph x = fst $ pushSubstsWith th ph x
-
-  export %inline
-  pushSubsts' : tm d n -> tm d n
-  pushSubsts' s = fst $ pushSubsts s
-
+infixl 8 //., ///
 mutual
-  public export
-  isCloT : CloTest Term
-  isCloT (CloT  {}) = True
-  isCloT (DCloT {}) = True
-  isCloT (E e)      = isCloE e
-  isCloT _          = False
+  namespace Term
+    ||| applies a term substitution with a less ambiguous type
+    export
+    (//.) : Term d from -> TSubst d from to -> Term d to
+    t //. th = t // th
+
+    ||| applies a dimension substitution with the same behaviour as `(//)`
+    ||| above
+    export
+    (///) : Term dfrom n -> DSubst dfrom dto -> Term dto n
+    TYPE l     /// _        = TYPE l
+    E e        /// th       = E $ e /// th
+    DCloT s ph /// th       = DCloT s $ ph . th
+    s          /// Shift SZ = s
+    s          /// th       = DCloT s th
+
+    ||| applies a term and dimension substitution
+    public export %inline
+    subs : Term dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
+           Term dto to
+    subs s th ph = s /// th // ph
+
+  namespace Elim
+    ||| applies a term substitution with a less ambiguous type
+    export
+    (//.) : Elim d from -> TSubst d from to -> Elim d to
+    e //. th = e // th
+
+    ||| applies a dimension substitution with the same behaviour as `(//)`
+    ||| above
+    export
+    (///) : Elim dfrom n -> DSubst dfrom dto -> Elim dto n
+    F x        /// _        = F x
+    B i        /// _        = B i
+    DCloE e ph /// th       = DCloE e $ ph . th
+    e          /// Shift SZ = e
+    e          /// th       = DCloE e th
+
+    ||| applies a term and dimension substitution
+    public export %inline
+    subs : Elim dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
+           Elim dto to
+    subs e th ph = e /// th // ph
+
+  namespace ScopeTerm
+    ||| applies a term substitution with a less ambiguous type
+    export
+    (//.) : ScopeTerm d from -> TSubst d from to -> ScopeTerm d to
+    body //. th = body // th
+
+    ||| applies a dimension substitution with the same behaviour as `(//)`
+    ||| above
+    export
+    (///) : ScopeTerm dfrom n -> DSubst dfrom dto -> ScopeTerm dto n
+    TUsed   body /// th = TUsed   $ body /// th
+    TUnused body /// th = TUnused $ body /// th
+
+    ||| applies a term and dimension substitution
+    public export %inline
+    subs : ScopeTerm dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
+           ScopeTerm dto to
+    subs body th ph = body /// th // ph
+
+export CanShift (Term      d) where s // by = s //. Shift by
+export CanShift (Elim      d) where e // by = e //. Shift by
+export CanShift (ScopeTerm d) where s // by = s //. Shift by
+
+
+export %inline
+comp' : DSubst dfrom dto -> TSubst dfrom from mid -> TSubst dto mid to ->
+        TSubst dto from to
+comp' th ps ph = map (/// th) ps . ph
 
-  public export
-  isCloE : CloTest Elim
-  isCloE (CloE  {}) = True
-  isCloE (DCloE {}) = True
-  isCloE _          = False
 
 export
-PushSubsts Elim Subst.isCloE where
-  pushSubstsWith th ph (F x u loc) =
-    nclo $ F x u loc
-  pushSubstsWith th ph (B i loc) =
-    let res = getLoc ph i loc in
-    case nchoose $ isCloE res of
-      Left  yes => assert_total pushSubsts res
-      Right no  => Element res no
-  pushSubstsWith th ph (App f s loc) =
-    nclo $ App (f // th // ph) (s // th // ph) loc
-  pushSubstsWith th ph (CasePair pi p r b loc) =
-    nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
-  pushSubstsWith th ph (Fst pair loc) =
-    nclo $ Fst (pair // th // ph) loc
-  pushSubstsWith th ph (Snd pair loc) =
-    nclo $ Snd (pair // th // ph) loc
-  pushSubstsWith th ph (CaseEnum pi t r arms loc) =
-    nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
-             (map (\b => b // th // ph) arms) loc
-  pushSubstsWith th ph (CaseNat pi pi' n r z s loc) =
-    nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph)
-             (z // th // ph) (s // th // ph) loc
-  pushSubstsWith th ph (CaseBox pi x r b loc) =
-    nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc
-  pushSubstsWith th ph (DApp f d loc) =
-    nclo $ DApp (f // th // ph) (d // th) loc
-  pushSubstsWith th ph (Ann s a loc) =
-    nclo $ Ann (s // th // ph) (a // th // ph) loc
-  pushSubstsWith th ph (Coe ty p q val loc) =
-    nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc
-  pushSubstsWith th ph (Comp ty p q val r zero one loc) =
-    nclo $ Comp (ty // th // ph) (p // th) (q // th)
-                (val // th // ph) (r // th)
-                (zero // th // ph) (one // th // ph) loc
-  pushSubstsWith th ph (TypeCase ty ret arms def loc) =
-    nclo $ TypeCase (ty // th // ph) (ret  // th // ph)
-      (map (\t => t // th // ph) arms) (def // th // ph) loc
-  pushSubstsWith th ph (CloE (Sub e ps)) =
-    pushSubstsWith th (comp th ps ph) e
-  pushSubstsWith th ph (DCloE (Sub e ps)) =
-    pushSubstsWith (ps . th) ph e
+fromDScopeTerm : DScopeTerm d n -> Term (S d) n
+fromDScopeTerm (DUsed   body) = body
+fromDScopeTerm (DUnused body) = body /// shift 1
 
 export
-PushSubsts Term Subst.isCloT where
-  pushSubstsWith th ph (TYPE l loc) =
-    nclo $ TYPE l loc
-  pushSubstsWith th ph (IOState loc) =
-    nclo $ IOState loc
-  pushSubstsWith th ph (Pi qty a body loc) =
-    nclo $ Pi qty (a // th // ph) (body // th // ph) loc
-  pushSubstsWith th ph (Lam body loc) =
-    nclo $ Lam (body // th // ph) loc
-  pushSubstsWith th ph (Sig a b loc) =
-    nclo $ Sig (a // th // ph) (b // th // ph) loc
-  pushSubstsWith th ph (Pair s t loc) =
-    nclo $ Pair (s // th // ph) (t // th // ph) loc
-  pushSubstsWith th ph (Enum tags loc) =
-    nclo $ Enum tags loc
-  pushSubstsWith th ph (Tag tag loc) =
-    nclo $ Tag tag loc
-  pushSubstsWith th ph (Eq ty l r loc) =
-    nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
-  pushSubstsWith th ph (DLam body loc) =
-    nclo $ DLam (body // th // ph) loc
-  pushSubstsWith _ _ (NAT loc) =
-    nclo $ NAT loc
-  pushSubstsWith _ _ (Nat n loc) =
-    nclo $ Nat n loc
-  pushSubstsWith th ph (Succ n loc) =
-    nclo $ Succ (n // th // ph) loc
-  pushSubstsWith _ _ (STRING loc) =
-    nclo $ STRING loc
-  pushSubstsWith _ _ (Str s loc) =
-    nclo $ Str s loc
-  pushSubstsWith th ph (BOX pi ty loc) =
-    nclo $ BOX pi (ty // th // ph) loc
-  pushSubstsWith th ph (Box val loc) =
-    nclo $ Box (val // th // ph) loc
-  pushSubstsWith th ph (E e) =
-    let Element e nc = pushSubstsWith th ph e in nclo $ E e
-  pushSubstsWith th ph (Let qty rhs body loc) =
-    nclo $ Let qty (rhs // th // ph) (body // th // ph) loc
-  pushSubstsWith th ph (CloT (Sub s ps)) =
-    pushSubstsWith th (comp th ps ph) s
-  pushSubstsWith th ph (DCloT (Sub s ps)) =
-    pushSubstsWith (ps . th) ph s
+fromScopeTerm : ScopeTerm d n -> Term d (S n)
+fromScopeTerm (TUsed   body) = body
+fromScopeTerm (TUnused body) = body //. shift 1

lib/Quox/Syntax/Term/Tighten.idr

@@ -1,376 +0,0 @@
-module Quox.Syntax.Term.Tighten
-
-import Quox.Syntax.Term.Base
-import Quox.Syntax.Term.Subst
-import public Quox.OPE
-import Quox.No
-
-%default total
-
-
-export
-Tighten Dim where
-  tighten p (K e loc) = pure $ K e loc
-  tighten p (B i loc) = B <$> tighten p i <*> pure loc
-
-export
-tightenScope : (forall m, n. OPE m n -> f n -> Maybe (f m)) ->
-               {s : Nat} -> OPE m n -> Scoped s f n -> Maybe (Scoped s f m)
-tightenScope f p (S names (Y body)) = SY names <$> f (keepN s p) body
-tightenScope f p (S names (N body)) = S names . N <$> f p body
-
-export
-tightenDScope : {0 f : Nat -> Nat -> Type} ->
-                (forall m, n, k. OPE m n -> f n k -> Maybe (f m k)) ->
-                OPE m n -> Scoped s (f n) k -> Maybe (Scoped s (f m) k)
-tightenDScope f p (S names (Y body)) = SY names <$> f p body
-tightenDScope f p (S names (N body)) = S names . N <$> f p body
-
-
-mutual
-  private
-  tightenT : OPE n1 n2 -> Term d n2 -> Maybe (Term d n1)
-  tightenT p s =
-    let Element s' _ = pushSubsts s in
-    tightenT' p $ assert_smaller s s'
-
-  private
-  tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
-  tightenE p e =
-    let Element e' _ = pushSubsts e in
-    tightenE' p $ assert_smaller e e'
-
-  private
-  tightenT' : OPE n1 n2 -> (t : Term d n2) -> (0 nt : NotClo t) =>
-              Maybe (Term d n1)
-  tightenT' p (TYPE l loc) = pure $ TYPE l loc
-  tightenT' p (IOState loc) = pure $ IOState loc
-  tightenT' p (Pi qty arg res loc) =
-    Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc
-  tightenT' p (Lam body loc) =
-    Lam <$> tightenS p body <*> pure loc
-  tightenT' p (Sig fst snd loc) =
-    Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc
-  tightenT' p (Pair fst snd loc) =
-    Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc
-  tightenT' p (Enum cases loc) =
-    pure $ Enum cases loc
-  tightenT' p (Tag tag loc) =
-    pure $ Tag tag loc
-  tightenT' p (Eq ty l r loc) =
-    Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc
-  tightenT' p (DLam body loc) =
-    DLam <$> tightenDS p body <*> pure loc
-  tightenT' p (NAT loc) =
-    pure $ NAT loc
-  tightenT' p (Nat n loc) =
-    pure $ Nat n loc
-  tightenT' p (Succ s loc) =
-    Succ <$> tightenT p s <*> pure loc
-  tightenT' p (STRING loc) =
-    pure $ STRING loc
-  tightenT' p (Str s loc) =
-    pure $ Str s loc
-  tightenT' p (BOX qty ty loc) =
-    BOX qty <$> tightenT p ty <*> pure loc
-  tightenT' p (Box val loc) =
-    Box <$> tightenT p val <*> pure loc
-  tightenT' p (Let qty rhs body loc) =
-    Let qty <$> assert_total tightenE p rhs <*> tightenS p body <*> pure loc
-  tightenT' p (E e) =
-    E <$> assert_total tightenE p e
-
-  private
-  tightenE' : OPE n1 n2 -> (e : Elim d n2) -> (0 ne : NotClo e) =>
-              Maybe (Elim d n1)
-  tightenE' p (F x u loc) =
-    pure $ F x u loc
-  tightenE' p (B i loc) =
-    B <$> tighten p i <*> pure loc
-  tightenE' p (App fun arg loc) =
-    App <$> tightenE p fun <*> tightenT p arg <*> pure loc
-  tightenE' p (CasePair qty pair ret body loc) =
-    CasePair qty <$> tightenE p pair
-                 <*> tightenS p ret
-                 <*> tightenS p body
-                 <*> pure loc
-  tightenE' p (Fst pair loc) =
-    Fst <$> tightenE p pair <*> pure loc
-  tightenE' p (Snd pair loc) =
-    Snd <$> tightenE p pair <*> pure loc
-  tightenE' p (CaseEnum qty tag ret arms loc) =
-    CaseEnum qty <$> tightenE p tag
-                 <*> tightenS p ret
-                 <*> traverse (tightenT p) arms
-                 <*> pure loc
-  tightenE' p (CaseNat qty qtyIH nat ret zero succ loc) =
-    CaseNat qty qtyIH
-      <$> tightenE p nat
-      <*> tightenS p ret
-      <*> tightenT p zero
-      <*> tightenS p succ
-      <*> pure loc
-  tightenE' p (CaseBox qty box ret body loc) =
-    CaseBox qty <$> tightenE p box
-                <*> tightenS p ret
-                <*> tightenS p body
-                <*> pure loc
-  tightenE' p (DApp fun arg loc) =
-    DApp <$> tightenE p fun <*> pure arg <*> pure loc
-  tightenE' p (Ann tm ty loc) =
-    Ann <$> tightenT p tm <*> tightenT p ty <*> pure loc
-  tightenE' p (Coe ty q0 q1 val loc) =
-    Coe <$> tightenDS p ty
-        <*> pure q0 <*> pure q1
-        <*> tightenT p val
-        <*> pure loc
-  tightenE' p (Comp ty q0 q1 val r zero one loc) =
-    Comp <$> tightenT p ty
-         <*> pure q0 <*> pure q1
-         <*> tightenT p val
-         <*> pure r
-         <*> tightenDS p zero
-         <*> tightenDS p one
-         <*> pure loc
-  tightenE' p (TypeCase ty ret arms def loc) =
-    TypeCase <$> tightenE p ty
-             <*> tightenT p ret
-             <*> traverse (tightenS p) arms
-             <*> tightenT p def
-             <*> pure loc
-
-  export
-  tightenS : {s : Nat} -> OPE m n ->
-             ScopeTermN s f n -> Maybe (ScopeTermN s f m)
-  tightenS = assert_total $ tightenScope tightenT
-
-  export
-  tightenDS : OPE m n -> DScopeTermN s f n -> Maybe (DScopeTermN s f m)
-  tightenDS = assert_total $ tightenDScope tightenT {f = \n, d => Term d n}
-
-export Tighten (Elim d) where tighten p e = tightenE p e
-export Tighten (Term d) where tighten p t = tightenT p t
-
-
-mutual
-  export
-  dtightenT : OPE d1 d2 -> Term d2 n -> Maybe (Term d1 n)
-  dtightenT p s =
-    let Element s' _ = pushSubsts s in
-    dtightenT' p $ assert_smaller s s'
-
-  export
-  dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
-  dtightenE p e =
-    let Element e' _ = pushSubsts e in
-    dtightenE' p $ assert_smaller e e'
-
-  private
-  dtightenT' : OPE d1 d2 -> (t : Term d2 n) -> (0 nt : NotClo t) =>
-               Maybe (Term d1 n)
-  dtightenT' p (TYPE l loc) =
-    pure $ TYPE l loc
-  dtightenT' p (IOState loc) =
-    pure $ IOState loc
-  dtightenT' p (Pi qty arg res loc) =
-    Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc
-  dtightenT' p (Lam body loc) =
-    Lam <$> dtightenS p body <*> pure loc
-  dtightenT' p (Sig fst snd loc) =
-    Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc
-  dtightenT' p (Pair fst snd loc) =
-    Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc
-  dtightenT' p (Enum cases loc) =
-    pure $ Enum cases loc
-  dtightenT' p (Tag tag loc) =
-    pure $ Tag tag loc
-  dtightenT' p (Eq ty l r loc) =
-    Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc
-  dtightenT' p (DLam body loc) =
-    DLam <$> dtightenDS p body <*> pure loc
-  dtightenT' p (NAT loc) =
-    pure $ NAT loc
-  dtightenT' p (Nat n loc) =
-    pure $ Nat n loc
-  dtightenT' p (Succ s loc) =
-    Succ <$> dtightenT p s <*> pure loc
-  dtightenT' p (STRING loc) =
-    pure $ STRING loc
-  dtightenT' p (Str s loc) =
-    pure $ Str s loc
-  dtightenT' p (BOX qty ty loc) =
-    BOX qty <$> dtightenT p ty <*> pure loc
-  dtightenT' p (Box val loc) =
-    Box <$> dtightenT p val <*> pure loc
-  dtightenT' p (Let qty rhs body loc) =
-    Let qty <$> assert_total dtightenE p rhs <*> dtightenS p body <*> pure loc
-  dtightenT' p (E e) =
-    E <$> assert_total dtightenE p e
-
-  export
-  dtightenE' : OPE d1 d2 -> (e : Elim d2 n) -> (0 ne : NotClo e) =>
-               Maybe (Elim d1 n)
-  dtightenE' p (F x u loc) =
-    pure $ F x u loc
-  dtightenE' p (B i loc) =
-    pure $ B i loc
-  dtightenE' p (App fun arg loc) =
-    App <$> dtightenE p fun <*> dtightenT p arg <*> pure loc
-  dtightenE' p (CasePair qty pair ret body loc) =
-    CasePair qty <$> dtightenE p pair
-                 <*> dtightenS p ret
-                 <*> dtightenS p body
-                 <*> pure loc
-  dtightenE' p (Fst pair loc) =
-    Fst <$> dtightenE p pair <*> pure loc
-  dtightenE' p (Snd pair loc) =
-    Snd <$> dtightenE p pair <*> pure loc
-  dtightenE' p (CaseEnum qty tag ret arms loc) =
-    CaseEnum qty <$> dtightenE p tag
-                 <*> dtightenS p ret
-                 <*> traverse (dtightenT p) arms
-                 <*> pure loc
-  dtightenE' p (CaseNat qty qtyIH nat ret zero succ loc) =
-    CaseNat qty qtyIH
-      <$> dtightenE p nat
-      <*> dtightenS p ret
-      <*> dtightenT p zero
-      <*> dtightenS p succ
-      <*> pure loc
-  dtightenE' p (CaseBox qty box ret body loc) =
-    CaseBox qty <$> dtightenE p box
-                <*> dtightenS p ret
-                <*> dtightenS p body
-                <*> pure loc
-  dtightenE' p (DApp fun arg loc) =
-    DApp <$> dtightenE p fun <*> tighten p arg <*> pure loc
-  dtightenE' p (Ann tm ty loc) =
-    Ann <$> dtightenT p tm <*> dtightenT p ty <*> pure loc
-  dtightenE' p (Coe ty q0 q1 val loc) =
-    [|Coe (dtightenDS p ty) (tighten p q0) (tighten p q1) (dtightenT p val)
-          (pure loc)|]
-  dtightenE' p (Comp ty q0 q1 val r zero one loc) =
-    [|Comp (dtightenT p ty) (tighten p q0) (tighten p q1)
-           (dtightenT p val) (tighten p r)
-           (dtightenDS p zero) (dtightenDS p one) (pure loc)|]
-  dtightenE' p (TypeCase ty ret arms def loc) =
-    [|TypeCase (dtightenE p ty) (dtightenT p ret)
-               (traverse (dtightenS p) arms) (dtightenT p def) (pure loc)|]
-
-  export
-  dtightenS : OPE d1 d2 -> ScopeTermN s d2 n -> Maybe (ScopeTermN s d1 n)
-  dtightenS = assert_total $ tightenDScope dtightenT {f = Term}
-
-  export
-  dtightenDS : {s : Nat} -> OPE d1 d2 ->
-               DScopeTermN s d2 n -> Maybe (DScopeTermN s d1 n)
-  dtightenDS = assert_total $ tightenScope dtightenT
-
-
-export Tighten (\d => Term d n) where tighten p t = dtightenT p t
-export Tighten (\d => Elim d n) where tighten p e = dtightenE p e
-
-
-parameters {auto _ : Tighten f} {s : Nat}
-  export
-  squeeze : Scoped s f n -> (BContext s, Either (f (s + n)) (f n))
-  squeeze (S ns (N t)) = (ns, Right t)
-  squeeze (S ns (Y t)) = (ns, maybe (Left t) Right $ tightenN s t)
-
-  export
-  squeeze' : Scoped s f n -> Scoped s f n
-  squeeze' t = let (ns, res) = squeeze t in S ns $ either Y N res
-
-parameters {0 f : Nat -> Nat -> Type}
-           {auto tt : Tighten (\d => f d n)} {s : Nat}
-  export
-  dsqueeze : Scoped s (\d => f d n) d ->
-             (BContext s, Either (f (s + d) n) (f d n))
-  dsqueeze = squeeze
-
-  export
-  dsqueeze' : Scoped s (\d => f d n) d -> Scoped s (\d => f d n) d
-  dsqueeze' = squeeze'
-
-
--- versions of SY, etc, that try to tighten and use SN automatically
-
-public export %inline
-ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n
-ST names body = squeeze' $ SY names body
-
-public export %inline
-DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n
-DST names body = dsqueeze' {f = Term} $ SY names body
-
-public export %inline
-PiT : (qty : Qty) -> (x : BindName) ->
-      (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
-PiT {qty, x, arg, res, loc} = Pi {qty, arg, res = ST [< x] res, loc}
-
-public export %inline
-LamT : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
-LamT {x, body, loc} = Lam {body = ST [< x] body, loc}
-
-public export %inline
-SigT : (x : BindName) -> (fst : Term d n) ->
-       (snd : Term d (S n)) -> (loc : Loc) -> Term d n
-SigT {x, fst, snd, loc} = Sig {fst, snd = ST [< x] snd, loc}
-
-public export %inline
-EqT : (i : BindName) -> (ty : Term (S d) n) ->
-      (l, r : Term d n) -> (loc : Loc) -> Term d n
-EqT {i, ty, l, r, loc} = Eq {ty = DST [< i] ty, l, r, loc}
-
-public export %inline
-DLamT : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
-DLamT {i, body, loc} = DLam {body = DST [< i] body, loc}
-
-public export %inline
-CoeT : (i : BindName) -> (ty : Term (S d) n) ->
-       (p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
-CoeT {i, ty, p, q, val, loc} = Coe {ty = DST [< i] ty, p, q, val, loc}
-
-public export %inline
-typeCase1T : Elim d n -> Term d n ->
-             (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
-             (loc : Loc) ->
-             {default (NAT loc) def : Term d n} ->
-             Elim d n
-typeCase1T ty ret k ns body loc {def} =
-  typeCase ty ret [(k ** ST ns body)] def loc
-
-
-public export %inline
-CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-         (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
-CompH' {ty, p, q, val, r, zero, one, loc} =
-  let ty' = DST ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
-  Comp {
-    ty = dsub1 ty q, p, q,
-    val = E $ Coe ty p q val val.loc, r,
-    zero = DST zero.names $ E $
-      Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
-    one = DST one.names $ E $
-      Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
-    loc
-  }
-
-||| heterogeneous composition, using Comp and Coe (and subst)
-|||
-||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ }
-||| ≔
-||| comp [A‹q/i›] @p @q (coe [i ⇒ A] @p @q s) @r {
-|||   0 j ⇒ coe [i ⇒ A] @j @q t₀;
-|||   1 j ⇒ coe [i ⇒ A] @j @q t₁
-||| }
-public export %inline
-CompH : (i : BindName) -> (ty : Term (S d) n) ->
-        (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
-        (j0 : BindName) -> (zero : Term (S d) n) ->
-        (j1 : BindName) -> (one : Term (S d) n) ->
-        (loc : Loc) ->
-        Elim d n
-CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
-  CompH' {ty = DST [< i] ty, p, q, val, r,
-          zero = DST [< j0] zero, one = DST [< j1] one, loc}