.gitignore

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

examples/all.quox

@@ -6,5 +6,3 @@ load "nat.quox"
 load "pair.quox"
 load "list.quox"
 load "eta.quox"
-load "fail.quox"
-load "qty.quox"

examples/bool.quox

@@ -18,13 +18,8 @@ def if2 : 0.(A B : ★) → (b : Bool) → ω.A → ω.B → if¹ ★ b A B =
 
 def0 T : Bool → ★ = λ b ⇒ if¹ ★ b True False;
 
-def dup! : (b : Bool) → [ω. Sing Bool b] =
+def boolω : Bool → [ω.Bool] =
-  λ b ⇒ if-dep (λ b ⇒ [ω. Sing Bool b]) b
+  λ b ⇒ if [ω.Bool] b ['true] ['false];
-    [('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;

examples/eta.quox

@@ -18,8 +18,8 @@ def0 pair : (A : ★) → (B : A → ★) → (P : Σ A B → ★) → (e : Σ A
   λ A B P e p ⇒ p
 
 -- not exactly η, but kinda related
-def0 from-false : (A : ★) → (P : (0.False → A) → ★) → (f : 0.False → A) →
+def0 from-false : (A : ★) → (P : (False → A) → ★) → (f : False → A) →
-                  P (void A) → P f =
+                  P (λ x ⇒ void A x) → 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

@@ -24,7 +24,6 @@ def elim : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
         }
     };
 
-#[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 {
@@ -64,7 +63,6 @@ def elim : 0.(A : ★) → 0.(P : List A → ★) →
     };
 
 -- [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) ⇒

examples/misc.quox

@@ -6,7 +6,7 @@ def0 Not : ★ → ★ = λ A ⇒ ω.A → False
 def void : 0.(A : ★) → 0.False → A =
   λ A v ⇒ case0 v return A of { }
 
-def0 All : (A : ★) → (0.A → ★) → ★ =
+def0 All : (A : ★) → (0.A → ★) → ★¹ =
   λ A P ⇒ (x : A) → P x
 
 def0 cong :
@@ -14,11 +14,6 @@ def0 cong :
     (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) =
@@ -37,8 +32,6 @@ def funext :
     (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 }
 
@@ -58,9 +51,6 @@ def0 HEq : (A B : ★) → A → B → ★¹ =
 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 =

examples/nat.quox

@@ -4,27 +4,11 @@ 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 ⇒
+    succ n, 1.d ⇒
       appω (Sing ℕ n) (Sing ℕ (succ n))
         (sing.app ℕ ℕ n (λ n ⇒ succ n)) d
   };
@@ -32,20 +16,18 @@ def dup! : (n : ℕ) → [ω. Sing ℕ n] =
 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
+    succ _, 1.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
+    succ _, 1.t ⇒ plus n t
   };
 
 def times : ℕ → ℕ → ℕ =
@@ -59,14 +41,6 @@ def pred-succ : ω.(n : ℕ) → pred (succ 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 };
@@ -93,7 +67,6 @@ def0 not-succ-self : (m : ℕ) → Not (m ≡ succ m : ℕ) =
   }
 
 
-#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"]
 def eq? : DecEq ℕ =
   λ m ⇒
   caseω m
@@ -121,45 +94,25 @@ def eqb : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ dec.bool (m ≡ n : ℕ) (eq?
 def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ =
   λ m ⇒
   case m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
-    zero        ⇒ δ _ ⇒ 0;
+    zero         ⇒ δ _ ⇒ zero;
-    succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
+    succ _, ω.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 @𝑖)
+    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 ⇒
+    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

@@ -28,7 +28,7 @@ def curry :
   λ A B C f x y ⇒ f (x, y);
 
 def curry' :
-    0.(A B C : ★) → (A × B → C) → A → B → C =
+    0.(A B C : ★) → ((A × B) → C) → A → B → C =
   λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C);
 
 def0 fst-snd :
@@ -54,19 +54,13 @@ 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 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.Σ;

examples/qty.quox

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

exe/CompileMonad.idr

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

exe/Error.idr

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

exe/Main.idr

@@ -1,118 +1,46 @@
 module Main
 
-import Quox.Syntax as Q
+import Quox.Syntax
-import Quox.Definition as Q
-import Quox.Untyped.Syntax as U
 import Quox.Parser
-import Quox.Untyped.Erase
+import Quox.Definition
-import Quox.Untyped.Scheme
 import Quox.Pretty
-import Quox.Log
-import Options
-import Output
-import Error
-import CompileMonad
 
 import System
-import System.File
 import Data.IORef
+import Data.SortedSet
 import Control.Eff
 
-%default total
+private
-
+Opts : LayoutOpts
-%hide Doc.(>>=)
+Opts = Opts 80
-%hide Core.(>>=)
-
-%hide FromParser.Error
-%hide Erase.Error
-%hide Lexer.Error
-%hide Parser.Error
-
 
 private
-Step : Type -> Type -> Type
+putDoc : Doc Opts -> IO ()
-Step a b = OpenFile -> a -> Eff Compile b
+putDoc = putStr . render Opts
 
 private
-step : ConsoleChannel -> Phase -> OutFile -> Step a b -> a -> Eff CompileStop b
+die : Doc Opts -> IO a
-step console phase file act x = do
+die err = do putDoc err; exitFailure
-  opts <- askAt OPTS
-  res  <- withOutFile console file fromError $ \h => lift $ act h x
-  when (opts.until == Just phase) stopHere
-  pure res
-where
-  fromError : String -> FileError -> Eff CompileStop c
-  fromError file err = throw $ WriteError file err
 
+private
+prettySig : Name -> Definition -> Eff Pretty (Doc Opts)
+prettySig name def = do
+  qty  <- prettyQty def.qty.qty
+  name <- prettyFree name
+  type <- prettyTerm [<] [<] def.type
+  hangDSingle (hsep [hcat [qty, !dotD, name], !colonD]) type
 
-private covering
+export
-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
+  seen <- newIORef SortedSet.empty
-  case !(runCompile opts !newState $ traverse_ processFile files) of
+  defs <- newIORef SortedMap.empty
-    Right () => pure ()
+  suf  <- newIORef 0
-    Left  e  => dieError opts e
+  for_ (drop 1 !getArgs) $ \file => do
-
+    putStrLn "checking \{file}"
+    Right res <- fromParserIO ["."] seen suf defs $ loadProcessFile noLoc file
+      | Left err => die $ runPrettyColor $ prettyError True err
+    for_ res $ \(name, def) => putDoc $ runPrettyColor $ prettySig name def
 
 -----------------------------------
 {-
@@ -127,13 +55,6 @@ text _ =
    #" /_/"#,
    ""]
 
---   ["",
---    #" __ _ _  _ _____ __"#,
---    #"/ _` | || / _ \ \ /"#,
---    #"\__, |\_,_\___/_\_\"#,
---    #"   |_|"#,
---    ""]
-
 private
 qtuwu : PrettyOpts -> List String
 qtuwu opts =

exe/Options.idr

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

exe/Output.idr

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

exe/quox.ipkg

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

golden-tests/Tests.idr

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

golden-tests/quox-golden-tests.ipkg

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

golden-tests/run-tests.sh

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

golden-tests/tests/empty/run

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

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

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

golden-tests/tests/eta-singleton/expected

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

golden-tests/tests/eta-singleton/run

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

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

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

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

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

golden-tests/tests/hello/expected

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

golden-tests/tests/hello/hello.quox

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

golden-tests/tests/hello/run

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

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

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

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

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

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

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

golden-tests/tests/isprop-subsing/expected

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

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

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

golden-tests/tests/isprop-subsing/run

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

golden-tests/tests/it-5/expected

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

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

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

golden-tests/tests/it-5/run

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

golden-tests/tests/lib.sh

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

golden-tests/tests/load/expected

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

golden-tests/tests/load/lib.quox

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

golden-tests/tests/load/main.quox

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

golden-tests/tests/load/run

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

golden-tests/tests/regularity/expected

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

golden-tests/tests/regularity/regularity.quox

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

golden-tests/tests/regularity/run

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

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

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

golden-tests/tests/useless-coe/expected

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

golden-tests/tests/useless-coe/run

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

lib/Control/Monad/ST/Extra.idr

@@ -62,21 +62,3 @@ export %inline HasST (STErr e) where liftST = STE . map Right
 export
 stLeft : e -> STErr e s a
 stLeft e = STE $ pure $ Left e
-
-
-parameters {auto _ : HasST m}
-  export %inline
-  newSTRef' : a -> m s (STRef s a)
-  newSTRef' x = liftST $ newSTRef x
-
-  export %inline
-  readSTRef' : STRef s a -> m s a
-  readSTRef' r = liftST $ readSTRef r
-
-  export %inline
-  writeSTRef' : STRef s a -> a -> m s ()
-  writeSTRef' r x = liftST $ writeSTRef r x
-
-  export %inline
-  modifySTRef' : STRef s a -> (a -> a) -> m s ()
-  modifySTRef' r f = liftST $ modifySTRef r f

lib/Quox/BoolExtra.idr

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

lib/Quox/CharExtra.idr

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

lib/Quox/CheckBuiltin.idr

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

lib/Quox/Context.idr

@@ -158,12 +158,12 @@ getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
           Context tm len -> Var len -> tm len
 getWith shft = getShiftWith shft SZ
 
-export infixl 8 !!
+infixl 8 !!
 public export %inline
 (!!) : CanShift tm => Context tm len -> Var len -> tm len
 (!!) = getWith (//)
 
-export infixl 8 !!!
+infixl 8 !!!
 public export %inline
 (!!!) : Context' tm len -> Var len -> tm
 (!!!) = getWith const
@@ -206,7 +206,7 @@ parameters {auto _ : Applicative f}
   traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
   traverse' f = traverse f
 
-  export infixl 3 `app`
+  infixl 3 `app`
   ||| like `(<*>)` but with effects
   export
   app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->

lib/Quox/Definition.idr

@@ -5,9 +5,7 @@ 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
 
 
@@ -29,21 +27,15 @@ record Definition where
   qty   : GQty
   type0 : Term 0 0
   body0 : DefBody
-  scheme : Maybe String
-  isMain : Bool
   loc_  : Loc
 
 public export %inline
-mkPostulate : GQty -> (type0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
+mkPostulate : GQty -> (type0 : Term 0 0) -> Loc -> Definition
-              Definition
+mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_}
-mkPostulate qty type0 scheme isMain loc_ =
-  MkDef {qty, type0, body0 = Postulate, scheme, isMain, loc_}
 
 public export %inline
-mkDef : GQty -> (type0, term0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
+mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition
-        Definition
+mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, loc_}
-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}
@@ -70,18 +62,6 @@ parameters {d, n : Nat}
   toElim : Definition -> Universe -> Maybe $ Elim d n
   toElim def u = pure $ Ann !(def.termAt u) (def.typeAt u) def.loc
 
-public export
-(.typeWith) : Definition -> Singleton d -> Singleton n -> Term d n
-g.typeWith (Val d) (Val n) = g.type
-
-public export
-(.typeWithAt) : Definition -> Singleton d -> Singleton n -> Universe -> Term d n
-g.typeWithAt d n u = displace u $ g.typeWith d n
-
-public export
-(.termWith) : Definition -> Singleton d -> Singleton n -> Maybe (Term d n)
-g.termWith (Val d) (Val n) = g.term
-
 
 public export %inline
 isZero : Definition -> Bool
@@ -89,16 +69,12 @@ isZero g = g.qty == GZero
 
 
 public export
-NDefinition : Type
+data DefEnvTag = DEFS
-NDefinition = (Name, Definition)
 
 public export
 Definitions : Type
 Definitions = SortedMap Name Definition
 
-public export
-data DefEnvTag = DEFS
-
 public export
 DefsReader : Type -> Type
 DefsReader = ReaderL DEFS Definitions
@@ -107,21 +83,7 @@ public export
 DefsState : Type -> Type
 DefsState = StateL DEFS Definitions
 
+
 public export %inline
 lookupElim : {d, n : Nat} -> Name -> Universe -> Definitions -> Maybe (Elim d n)
 lookupElim x u defs = toElim !(lookup x defs) u
-
-public export %inline
-lookupElim0 : Name -> Universe -> Definitions -> Maybe (Elim 0 0)
-lookupElim0 = lookupElim
-
-
-export
-prettyDef : {opts : LayoutOpts} -> Name -> Definition -> Eff Pretty (Doc opts)
-prettyDef name def = withPrec Outer $ do
-  qty   <- prettyQty def.qty.qty
-  dot   <- dotD
-  name  <- prettyFree name
-  colon <- colonD
-  type  <- prettyTerm [<] [<] def.type
-  hangDSingle (hsep [hcat [qty, dot, name], colon]) type

lib/Quox/Displace.idr

@@ -16,7 +16,6 @@ parameters (k : Universe)
 
   namespace Term
     doDisplace (TYPE l loc) = TYPE (k + l) loc
-    doDisplace (IOState loc) = IOState loc
     doDisplace (Pi qty arg res loc) =
       Pi qty (doDisplace arg) (doDisplaceS res) loc
     doDisplace (Lam body loc) = Lam (doDisplaceS body) loc
@@ -27,15 +26,11 @@ parameters (k : Universe)
     doDisplace (Eq ty l r loc) =
       Eq (doDisplaceDS ty) (doDisplace l) (doDisplace r) loc
     doDisplace (DLam body loc) = DLam (doDisplaceDS body) loc
-    doDisplace (NAT loc) = NAT loc
+    doDisplace (Nat loc) = Nat loc
-    doDisplace (Nat n loc) = Nat n loc
+    doDisplace (Zero loc) = Zero loc
     doDisplace (Succ p loc) = Succ (doDisplace p) loc
-    doDisplace (STRING loc) = STRING loc
-    doDisplace (Str s loc) = Str s loc
     doDisplace (BOX qty ty loc) = BOX qty (doDisplace ty) loc
     doDisplace (Box val loc) = Box (doDisplace val) loc
-    doDisplace (Let qty rhs body loc) =
-      Let qty (doDisplace rhs) (doDisplaceS body) loc
     doDisplace (E e) = E (doDisplace e)
     doDisplace (CloT (Sub t th)) =
       CloT (Sub (doDisplace t) (assert_total $ map doDisplace th))

lib/Quox/EffExtra.idr

@@ -36,15 +36,6 @@ 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
@@ -56,6 +47,7 @@ handleStateSTRef r Get     = liftST $ readSTRef r
 handleStateSTRef r (Put s) = liftST $ writeSTRef r s
 
 
+
 public export
 data Length : List a -> Type where
   Z : Length []
@@ -77,23 +69,25 @@ subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
 subsetTail _ = subsetWith S
 
 
+export
+catchMaybeAt : (0 lbl : tag) -> (Has (ExceptL lbl e) fs, Length fs) =>
+               (e -> Eff fs a) -> Eff fs a -> Eff fs a
+catchMaybeAt lbl hnd act =
+  catchAt lbl hnd $ lift @{subsetTail $ ExceptL lbl e} act
+
+export %inline
+catchMaybe : (Has (Except e) fs, Length fs) =>
+             (e -> Eff fs a) -> Eff fs a -> Eff fs a
+catchMaybe = catchMaybeAt ()
 
 export
-rethrowAtWith : (0 lbl : tag) -> Has (ExceptL lbl e') fs =>
+wrapErrAt : (0 lbl : tag) -> (Has (ExceptL lbl e) fs, Length fs) =>
-                (e -> e') -> Either e a -> Eff fs a
+            (e -> e) -> Eff fs a -> Eff fs a
-rethrowAtWith lbl f = rethrowAt lbl . mapFst f
+wrapErrAt lbl wrap = catchMaybeAt lbl (\ex => throwAt lbl $ wrap ex)
 
-export
+export %inline
-rethrowWith : Has (Except e') fs => (e -> e') -> Either e a -> Eff fs a
+wrapErr : (Has (Except e) fs, Length fs) => (e -> e) -> Eff fs a -> Eff fs a
-rethrowWith = rethrowAtWith ()
+wrapErr = wrapErrAt ()
-
-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
@@ -105,10 +99,6 @@ 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

lib/Quox/Equal.idr

@@ -2,13 +2,9 @@ module Quox.Equal
 
 import Quox.BoolExtra
 import public Quox.Typing
-import Quox.FreeVars
-import Quox.Pretty
-import Quox.EffExtra
-
-import Data.List1
 import Data.Maybe
-import Data.Either
+import Quox.EffExtra
+import Quox.FreeVars
 
 %default total
 
@@ -19,21 +15,17 @@ EqModeState = State EqMode
 
 public export
 Equal : List (Type -> Type)
-Equal = [ErrorEff, DefsReader, NameGen, Log]
+Equal = [ErrorEff, DefsReader, NameGen]
 
 public export
 EqualInner : List (Type -> Type)
-EqualInner = [ErrorEff, NameGen, EqModeState, Log]
+EqualInner = [ErrorEff, NameGen, EqModeState]
 
 
 export %inline
 mode : Has EqModeState fs => Eff fs EqMode
 mode = get
 
-private %inline
-withEqual : Has EqModeState fs => Eff fs a -> Eff fs a
-withEqual = local_ Equal
-
 
 parameters (loc : Loc) (ctx : EqContext n)
   private %inline
@@ -55,8 +47,6 @@ sameTyCon : (s, t : Term d n) ->
             Bool
 sameTyCon (TYPE {}) (TYPE {}) = True
 sameTyCon (TYPE {}) _         = False
-sameTyCon (IOState {}) (IOState {}) = True
-sameTyCon (IOState {}) _            = False
 sameTyCon (Pi   {}) (Pi   {}) = True
 sameTyCon (Pi   {}) _         = False
 sameTyCon (Sig  {}) (Sig  {}) = True
@@ -65,10 +55,8 @@ sameTyCon (Enum    {}) (Enum    {}) = True
 sameTyCon (Enum {}) _         = False
 sameTyCon (Eq   {}) (Eq   {}) = True
 sameTyCon (Eq   {}) _         = False
-sameTyCon (NAT     {}) (NAT     {}) = True
+sameTyCon (Nat  {}) (Nat  {}) = True
-sameTyCon (NAT     {}) _            = False
+sameTyCon (Nat  {}) _         = False
-sameTyCon (STRING  {}) (STRING  {}) = True
-sameTyCon (STRING  {}) _            = False
 sameTyCon (BOX  {}) (BOX  {}) = True
 sameTyCon (BOX  {}) _         = False
 sameTyCon (E    {}) (E    {}) = True
@@ -82,43 +70,30 @@ sameTyCon (E       {}) _            = False
 ||| * `[π.A]` is empty if `A` is.
 ||| * that's it.
 public export covering
-isEmpty :
+isEmpty : {n : Nat} -> Definitions -> EqContext n -> SQty -> Term 0 n ->
-  {default 30 logLevel : Nat} -> (0 _ : So (isLogLevel logLevel)) =>
+          Eff EqualInner Bool
-  Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool
+isEmpty defs ctx sg ty0 = do
-
-private covering
-isEmptyNoLog :
-  Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool
-
-isEmpty defs ctx sg ty = do
-  sayMany "equal" ty.loc
-    [logLevel :> "isEmpty",
-     95       :> hsep ["ctx =", runPretty $ prettyEqContext ctx],
-     95       :> hsep ["sg =", runPretty $ prettyQty sg.qty],
-     logLevel :> hsep ["ty =", runPretty $ prettyTerm [<] ctx.tnames ty]]
-  res <- isEmptyNoLog defs ctx sg ty
-  say "equal" logLevel ty.loc $ hsep ["isEmpty ⇝", pshow res]
-  pure res
-
-isEmptyNoLog defs ctx sg ty0 = do
   Element ty0 nc <- whnf defs ctx sg ty0.loc ty0
-  let Left  y = choose $ isTyConE ty0
-    | Right n => pure False
   case ty0 of
     TYPE {} => pure False
-    IOState {} => pure False
     Pi {arg, res, _} => pure False
     Sig {fst, snd, _} =>
-      isEmpty defs ctx sg fst {logLevel = 90} `orM`
+      isEmpty defs ctx sg fst `orM`
-      isEmpty defs (extendTy0 snd.name fst ctx) sg snd.term {logLevel = 90}
+      isEmpty defs (extendTy0 snd.name fst ctx) sg snd.term
     Enum {cases, _} =>
       pure $ null cases
     Eq {} => pure False
-    NAT {} => pure False
+    Nat {} => pure False
-    STRING {} => pure False
+    BOX {ty, _} => isEmpty defs ctx sg ty
-    BOX {ty, _} => isEmpty defs ctx sg ty {logLevel = 90}
+    E (Ann {tm, _}) => isEmpty defs ctx sg tm
     E _ => pure False
-
+    Lam  {} => pure False
+    Pair {} => pure False
+    Tag  {} => pure False
+    DLam {} => pure False
+    Zero {} => pure False
+    Succ {} => pure False
+    Box  {} => pure False
 
 ||| true if a type is known to be a subsingleton purely by its form.
 ||| a subsingleton is a type with only zero or one possible values.
@@ -131,43 +106,32 @@ isEmptyNoLog defs ctx sg ty0 = do
 ||| * an enum type is a subsingleton if it has zero or one tags.
 ||| * a box type is a subsingleton if its content is
 public export covering
-isSubSing :
+isSubSing : {n : Nat} -> Definitions -> EqContext n -> SQty -> Term 0 n ->
-  {default 30 logLevel : Nat} -> (0 _ : So (isLogLevel logLevel)) =>
+            Eff EqualInner Bool
-  Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool
+isSubSing defs ctx sg ty0 = do
-
-private covering
-isSubSingNoLog :
-  Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool
-
-isSubSing defs ctx sg ty = do
-  sayMany "equal" ty.loc
-    [logLevel :> "isSubSing",
-     95       :> hsep ["ctx =", runPretty $ prettyEqContext ctx],
-     95       :> hsep ["sg =", runPretty $ prettyQty sg.qty],
-     logLevel :> hsep ["ty =", runPretty $ prettyTerm [<] ctx.tnames ty]]
-  res <- isSubSingNoLog defs ctx sg ty
-  say "equal" logLevel ty.loc $ hsep ["isSubsing ⇝", pshow res]
-  pure res
-
-isSubSingNoLog defs ctx sg ty0 = do
   Element ty0 nc <- whnf defs ctx sg ty0.loc ty0
-  let Left y = choose $ isTyConE ty0 | _ => pure False
   case ty0 of
     TYPE {} => pure False
-    IOState {} => pure False
     Pi {arg, res, _} =>
-      isEmpty defs ctx sg arg {logLevel = 90} `orM`
+      isEmpty defs ctx sg arg `orM`
-      isSubSing defs (extendTy0 res.name arg ctx) sg res.term {logLevel = 90}
+      isSubSing defs (extendTy0 res.name arg ctx) sg res.term
     Sig {fst, snd, _} =>
-      isSubSing defs ctx sg fst {logLevel = 90} `andM`
+      isSubSing defs ctx sg fst `andM`
-      isSubSing defs (extendTy0 snd.name fst ctx) sg snd.term {logLevel = 90}
+      isSubSing defs (extendTy0 snd.name fst ctx) sg snd.term
     Enum {cases, _} =>
       pure $ length (SortedSet.toList cases) <= 1
     Eq {} => pure True
-    NAT {} => pure False
+    Nat {} => pure False
-    STRING {} => pure False
+    BOX {ty, _} => isSubSing defs ctx sg ty
-    BOX {ty, _} => isSubSing defs ctx sg ty {logLevel = 90}
+    E (Ann {tm, _}) => isSubSing defs ctx sg tm
     E _ => pure False
+    Lam  {} => pure False
+    Pair {} => pure False
+    Tag  {} => pure False
+    DLam {} => pure False
+    Zero {} => pure False
+    Succ {} => pure False
+    Box  {} => pure False
 
 
 ||| the left argument if the current mode is `Super`; otherwise the right one.
@@ -177,21 +141,12 @@ bigger l r = gets $ \case Super => l; _ => r
 
 
 export
-ensureTyCon, ensureTyConNoLog :
+ensureTyCon : Has ErrorEff fs =>
-  (Has Log fs, Has ErrorEff fs) =>
               (loc : Loc) -> (ctx : EqContext n) -> (t : Term 0 n) ->
               Eff fs (So (isTyConE t))
-ensureTyConNoLog loc ctx ty = do
+ensureTyCon loc ctx t = case nchoose $ isTyConE t of
-  case nchoose $ isTyConE ty of
   Left  y => pure y
-    Right n => throw $ NotType loc (toTyContext ctx) (ty // shift0 ctx.dimLen)
+  Right n => throw $ NotType loc (toTyContext ctx) (t // shift0 ctx.dimLen)
-
-ensureTyCon loc ctx ty = do
-  sayMany "equal" ty.loc
-    [60 :> "ensureTyCon",
-     95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx],
-     60 :> hsep ["ty =", runPretty $ prettyTerm [<] ctx.tnames ty]]
-  ensureTyConNoLog loc ctx ty
 
 
 namespace Term
@@ -219,48 +174,30 @@ compareType : Definitions -> EqContext n -> (s, t : Term 0 n) ->
               Eff EqualInner ()
 
 
-private
-0 NotRedexEq : {isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
-               Definitions -> EqContext n -> SQty -> Pred (tm 0 n)
-NotRedexEq defs ctx sg t = NotRedex defs (toWhnfContext ctx) sg t
-
 namespace Term
   private covering
-  compare0' : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) ->
+  compare0' : (defs : Definitions) -> EqContext n -> (sg : SQty) ->
               (ty, s, t : Term 0 n) ->
-              (0 _ : NotRedexEq defs ctx SZero ty) =>
+              (0 _ : NotRedex defs SZero ty) => (0 _ : So (isTyConE ty)) =>
-              (0 _ : So (isTyConE ty)) =>
+              (0 _ : NotRedex defs sg    s)  => (0 _ : NotRedex defs sg t) =>
-              (0 _ : NotRedexEq defs ctx sg s) =>
-              (0 _ : NotRedexEq defs ctx sg t) =>
               Eff EqualInner ()
   compare0' defs ctx sg (TYPE {}) s t = compareType defs ctx s t
 
-  compare0' defs ctx sg ty@(IOState {}) s t =
+  compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = local_ Equal $
-    --   Γ ⊢ e = f ⇒ IOState
-    -- ----------------------
-    --   Γ ⊢ e = f ⇐ IOState
-    --
-    -- (no canonical values, ofc)
-    case (s, t) of
-      (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
-      (E _, _)   => wrongType t.loc ctx ty t
-      _          => wrongType s.loc ctx ty s
-
-  compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = withEqual $
     --              Γ ⊢ A empty
     -- -------------------------------------------
-    --  Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ π.(x : A) → B
+    --  Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) : (π·x : A) → B
-    if !(isEmpty defs ctx sg arg) then pure () else
+    if !(isEmpty' arg) then pure () else
     case (s, t) of
-      --           Γ, x : A ⊢ s = t ⇐ B
+      --           Γ, x : A ⊢ s = t : B
       -- -------------------------------------------
-      --  Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ π.(x : A) → B
+      --  Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) : (π·x : A) → B
       (Lam b1 {}, Lam b2 {}) =>
         compare0 defs ctx' sg res.term b1.term b2.term
 
-      --       Γ, x : A ⊢ s = e x ⇐ B
+      --       Γ, x : A ⊢ s = e x : B
       -- -----------------------------------
-      --  Γ ⊢ (λ x ⇒ s) = e ⇐ π.(x : A) → B
+      --  Γ ⊢ (λ x ⇒ s) = e : (π·x : A) → B
       (E e,      Lam b {}) => eta s.loc e b
       (Lam b {}, E e)      => eta s.loc e b
 
@@ -270,6 +207,9 @@ namespace Term
       (E _,    t) => wrongType t.loc ctx ty t
       (s,      _) => wrongType s.loc ctx ty s
   where
+    isEmpty' : Term 0 n -> Eff EqualInner Bool
+    isEmpty' t = let Val n = ctx.termLen in isEmpty defs ctx sg arg
+
     ctx' : EqContext (S n)
     ctx' = extendTy qty res.name arg ctx
 
@@ -277,18 +217,16 @@ namespace Term
     toLamBody e = E $ App (weakE 1 e) (BVT 0 e.loc) e.loc
 
     eta : Loc -> Elim 0 n -> ScopeTerm 0 n -> Eff EqualInner ()
-    eta loc e (S _ (N b)) =
+    eta loc e (S _ (N _)) = clashT loc ctx ty s t
-      if !(pure (qty /= One) `andM` isSubSing defs ctx sg arg)
+    eta _   e (S _ (Y b)) = compare0 defs ctx' sg res.term (toLamBody e) b
-         then compare0 defs ctx' sg res.term (toLamBody e) (weakT 1 b)
-         else clashT loc ctx ty s t
-    eta _ e (S _ (Y b)) =
-      compare0 defs ctx' sg res.term (toLamBody e) b
 
-  compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = withEqual $
+  compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = local_ Equal $
     case (s, t) of
-      --  Γ ⊢ s₁ = t₁ ⇐ A     Γ ⊢ s₂ = t₂ ⇐ B{s₁/x}
+      --  Γ ⊢ s₁ = t₁ : A     Γ ⊢ s₂ = t₂ : B{s₁/x}
       -- --------------------------------------------
-      --     Γ ⊢ (s₁, t₁) = (s₂,t₂) ⇐ (x : A) × B
+      --     Γ ⊢ (s₁, t₁) = (s₂,t₂) : (x : A) × B
+      --
+      -- [todo] η for π ≥ 0 maybe
       (Pair sFst sSnd {}, Pair tFst tSnd {}) => do
         compare0 defs ctx sg fst sFst tFst
         compare0 defs ctx sg (sub1 snd (Ann sFst fst fst.loc)) sSnd tSnd
@@ -310,15 +248,14 @@ namespace Term
           compare0 defs ctx sg (sub1 snd (Ann s fst s.loc)) (E $ Snd e e.loc) t
         SOne => clashT loc ctx ty s t
 
-  compare0' defs ctx sg ty@(Enum cases _) s t = withEqual $
+  compare0' defs ctx sg ty@(Enum {}) s t = local_ Equal $
-    -- η for empty & singleton enums
-    if length (SortedSet.toList cases) <= 1 then pure () else
     case (s, t) of
       -- --------------------
-      --  Γ ⊢ 't = 't ⇐ {ts}
+      --  Γ ⊢ `t = `t : {ts}
       --
       -- t ∈ ts is in the typechecker, not here, ofc
-      (Tag t1 {}, Tag t2 {}) => unless (t1 == t2) $ clashT s.loc ctx ty s t
+      (Tag t1 {}, Tag t2 {}) =>
+        unless (t1 == t2) $ clashT s.loc ctx ty s t
       (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
 
       (Tag {}, E _)    => clashT s.loc ctx ty s t
@@ -332,59 +269,44 @@ namespace Term
     -- ✨ uip ✨
     --
     -- ----------------------------
-    --  Γ ⊢ e = f ⇐ Eq [i ⇒ A] s t
+    --  Γ ⊢ e = f : Eq [i ⇒ A] s t
     pure ()
 
-  compare0' defs ctx sg nat@(NAT {}) s t = withEqual $
+  compare0' defs ctx sg nat@(Nat {}) s t = local_ Equal $
     case (s, t) of
       -- ---------------
-      --  Γ ⊢ n = n ⇐ ℕ
+      --  Γ ⊢ 0 = 0 : ℕ
-      (Nat x {}, Nat y {}) => unless (x == y) $ clashT s.loc ctx nat s t
+      (Zero {}, Zero {}) => pure ()
 
-      --      Γ ⊢ s = t ⇐ ℕ
+      --      Γ ⊢ s = t : ℕ
       -- -------------------------
-      --  Γ ⊢ succ s = succ t ⇐ ℕ
+      --  Γ ⊢ succ s = succ t : ℕ
       (Succ s' {}, Succ t' {}) => compare0 defs ctx sg nat s' t'
-      (Nat (S x) {}, Succ t'   {}) => compare0 defs ctx sg nat (Nat x s.loc) t'
-      (Succ s'   {}, Nat (S y) {}) => compare0 defs ctx sg nat s' (Nat y t.loc)
 
       (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
 
-      (Nat 0 {}, Succ  {}) => clashT s.loc ctx nat s t
+      (Zero {}, Succ {}) => clashT s.loc ctx nat s t
-      (Nat 0 {}, E _)      => clashT s.loc ctx nat s t
+      (Zero {}, E _)     => clashT s.loc ctx nat s t
-      (Succ  {}, Nat 0 {}) => clashT s.loc ctx nat s t
+      (Succ {}, Zero {}) => clashT s.loc ctx nat s t
       (Succ {}, E _)     => clashT s.loc ctx nat s t
-      (E _,      Nat 0 {}) => clashT s.loc ctx nat s t
+      (E _,     Zero {}) => clashT s.loc ctx nat s t
       (E _,     Succ {}) => clashT s.loc ctx nat s t
 
-      (Nat  {}, t) => wrongType t.loc ctx nat t
+      (Zero {}, t) => wrongType t.loc ctx nat t
       (Succ {}, t) => wrongType t.loc ctx nat t
       (E _,     t) => wrongType t.loc ctx nat t
       (s,       _) => wrongType s.loc ctx nat s
 
-  compare0' defs ctx sg str@(STRING {}) s t = withEqual $
+  compare0' defs ctx sg bty@(BOX q ty {}) s t = local_ Equal $
     case (s, t) of
-      (Str x _, Str y _) => unless (x == y) $ clashT s.loc ctx str s t
+      --     Γ ⊢ s = t : A
-
-      (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f
-
-      (Str {}, E _) => clashT s.loc ctx str s t
-      (E _, Str {}) => clashT s.loc ctx str s t
-
-      (Str {}, _) => wrongType t.loc ctx str t
-      (E _,    _) => wrongType t.loc ctx str t
-      _           => wrongType s.loc ctx str s
-
-  compare0' defs ctx sg bty@(BOX q ty {}) s t = withEqual $
-    case (s, t) of
-      --     Γ ⊢ s = t ⇐ A
       -- -----------------------
-      --  Γ ⊢ [s] = [t] ⇐ [π.A]
+      --  Γ ⊢ [s] = [t] : [π.A]
       (Box s _, Box t _) => compare0 defs ctx sg ty s t
 
-      --   Γ ⊢ σ⨴ρ · s = (case1 e return A of {[x] ⇒ x}) ⇐ A
+      --   Γ ⊢ s = (case1 e return A of {[x] ⇒ x}) ⇐ A
-      -- -----------------------------------------------------
+      -- -----------------------------------------------
-      --               Γ ⊢ σ · [s] = e ⇐ [ρ.A]
+      --            Γ ⊢ [s] = e ⇐ [ρ.A]
       (Box s loc, E f)       => eta s f
       (E e,       Box t loc) => eta t e
 
@@ -398,7 +320,7 @@ namespace Term
     eta s e = do
       nm <- mnb "inner" e.loc
       let e = CaseBox One e (SN ty) (SY [< nm] (BVT 0 nm.loc)) e.loc
-      compare0 defs ctx (sg `subjMult` q) ty s (E e)
+      compare0 defs ctx sg ty s (E e)
 
   compare0' defs ctx sg ty@(E _) s t = do
     -- a neutral type can only be inhabited by neutral values
@@ -409,10 +331,9 @@ namespace Term
 
 
 private covering
-compareType' : (defs : Definitions) -> (ctx : EqContext n) ->
+compareType' : (defs : Definitions) -> EqContext n -> (s, t : Term 0 n) ->
-               (s, t : Term 0 n) ->
+               (0 _ : NotRedex defs SZero s) => (0 _ : So (isTyConE s)) =>
-               (0 _ : NotRedexEq defs ctx SZero s) => (0 _ : So (isTyConE s)) =>
+               (0 _ : NotRedex defs SZero t) => (0 _ : So (isTyConE t)) =>
-               (0 _ : NotRedexEq defs ctx SZero t) => (0 _ : So (isTyConE t)) =>
                (0 _ : So (sameTyCon s t)) =>
                Eff EqualInner ()
 -- equality is the same as subtyping, except with the
@@ -423,15 +344,11 @@ compareType' defs ctx a@(TYPE k {}) (TYPE l {}) =
   --  Γ ⊢ Type 𝓀 <: Type ℓ
   expectModeU a.loc !mode k l
 
-compareType' defs ctx a@(IOState {}) (IOState {}) =
-  -- Γ ⊢ IOState <: IOState
-  pure ()
-
 compareType' defs ctx (Pi {qty = sQty, arg = sArg, res = sRes, loc})
                       (Pi {qty = tQty, arg = tArg, res = tRes, _}) = do
   --   Γ ⊢ A₁ :> A₂    Γ, x : A₁ ⊢ B₁ <: B₂
   -- ----------------------------------------
-  --  Γ ⊢ π.(x : A₁) → B₁ <: π.(x : A₂) → B₂
+  --  Γ ⊢ (π·x : A₁) → B₁ <: (π·x : A₂) → B₂
   expectEqualQ loc sQty tQty
   local flip $ compareType defs ctx sArg tArg -- contra
   compareType defs (extendTy0 sRes.name sArg ctx) sRes.term tRes.term
@@ -453,7 +370,7 @@ compareType' defs ctx (Eq {ty = sTy, l = sl, r = sr, _})
   compareType defs (extendDim sTy.name Zero ctx) sTy.zero tTy.zero
   compareType defs (extendDim sTy.name One  ctx) sTy.one  tTy.one
   ty <- bigger sTy tTy
-  withEqual $ do
+  local_ Equal $ do
     Term.compare0 defs ctx SZero ty.zero sl tl
     Term.compare0 defs ctx SZero ty.one  sr tr
 
@@ -465,16 +382,11 @@ compareType' defs ctx s@(Enum tags1 {}) t@(Enum tags2 {}) = do
   -- a runtime coercion
   unless (tags1 == tags2) $ clashTy s.loc ctx s t
 
-compareType' defs ctx (NAT {}) (NAT {}) =
+compareType' defs ctx (Nat {}) (Nat {}) =
   -- ------------
   --  Γ ⊢ ℕ <: ℕ
   pure ()
 
-compareType' defs ctx (STRING {}) (STRING {}) =
-  -- ------------
-  --  Γ ⊢ String <: String
-  pure ()
-
 compareType' defs ctx (BOX pi a loc) (BOX rh b {}) = do
   expectEqualQ loc pi rh
   compareType defs ctx a b
@@ -490,39 +402,9 @@ lookupFree : Has ErrorEff fs =>
              Definitions -> EqContext n -> Name -> Universe -> Loc ->
              Eff fs (Term 0 n)
 lookupFree defs ctx x u loc =
-  case lookup x defs of
+  let Val n = ctx.termLen in
-    Nothing => throw $ NotInScope loc x
+  maybe (throw $ NotInScope loc x) (\d => pure $ d.typeAt u) $
-    Just d  => pure $ d.typeWithAt [|Z|] ctx.termLen u
+  lookup x defs
-
-
-export
-typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe ->
-              CtxExtension d n (arity k + n)
-typecaseTel k xs u = case k of
-  KTYPE => [<]
-  KIOState => [<]
-  -- A : ★ᵤ, B : 0.A → ★ᵤ
-  KPi =>
-    let [< a, b] = xs in
-    [< (Zero, a, TYPE u a.loc),
-       (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
-  KSig =>
-    let [< a, b] = xs in
-    [< (Zero, a, TYPE u a.loc),
-       (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
-  KEnum => [<]
-  -- A₀ : ★ᵤ, A₁ : ★ᵤ, A : (A₀ ≡ A₁ : ★ᵤ), L : A₀, R : A₀
-  KEq =>
-    let [< a0, a1, a, l, r] = xs in
-    [< (Zero, a0, TYPE u a0.loc),
-       (Zero, a1, TYPE u a1.loc),
-       (Zero, a,  Eq0 (TYPE u a.loc) (BVT 1 a.loc) (BVT 0 a.loc) a.loc),
-       (Zero, l,  BVT 2 l.loc),
-       (Zero, r,  BVT 2 r.loc)]
-  KNat => [<]
-  KString => [<]
-  -- A : ★ᵤ
-  KBOX => let [< a] = xs in [< (Zero, a, TYPE u a.loc)]
 
 
 namespace Elim
@@ -536,29 +418,25 @@ namespace Elim
   EqualElim : List (Type -> Type)
   EqualElim = InnerErrEff :: EqualInner
 
-  private covering %inline
+  private covering
-  computeElimTypeE : (defs : Definitions) -> (ctx : EqContext n) ->
+  computeElimTypeE : (defs : Definitions) -> EqContext n -> (sg : SQty) ->
-                     (sg : SQty) ->
+                     (e : Elim 0 n) -> (0 ne : NotRedex defs sg e) =>
-                     (e : Elim 0 n) -> (0 ne : NotRedexEq defs ctx sg e) =>
                      Eff EqualElim (Term 0 n)
-  computeElimTypeE defs ectx sg e = lift $
+  computeElimTypeE defs ectx sg e =
-    computeElimType defs (toWhnfContext ectx) sg e
+    let Val n = ectx.termLen in
+    lift $ computeElimType defs (toWhnfContext ectx) sg e
 
-  private %inline
+  private
   putError : Has InnerErrEff fs => Error -> Eff fs ()
   putError err = modifyAt InnerErr (<|> Just err)
 
-  private %inline
+  private
   try : Eff EqualInner () -> Eff EqualElim ()
   try act = lift $ catch putError $ lift act {fs' = EqualElim}
 
-  private %inline
-  succeeds : Eff EqualInner a -> Eff EqualElim Bool
-  succeeds act = lift $ map isRight $ runExcept act
-
   private covering %inline
-  clashE : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) ->
+  clashE : (defs : Definitions) -> EqContext n -> (sg : SQty) ->
-           (e, f : Elim 0 n) -> (0 nf : NotRedexEq defs ctx sg f) =>
+           (e, f : Elim 0 n) -> (0 nf : NotRedex defs sg f) =>
            Eff EqualElim (Term 0 n)
   clashE defs ctx sg e f = do
     putError $ ClashE e.loc ctx !mode e f
@@ -575,68 +453,62 @@ namespace Elim
                (def : Term 0 n) ->
                Eff EqualElim ()
   compareArm {b1 = Nothing, b2 = Nothing, _} = pure ()
-  compareArm defs ctx k ret u b1 b2 def = do
+  compareArm defs ctx k ret u b1 b2 def =
-    let def   = SN def
+    let def = SN def in
-        left  = fromMaybe def b1; right = fromMaybe def b2
+    compareArm_ defs ctx k ret u (fromMaybe def b1) (fromMaybe def b2)
-        names = (fromMaybe def $ b1 <|> b2).names
+  where
-    try $ compare0 defs (extendTyN (typecaseTel k names u) ctx)
+    compareArm_ : Definitions -> EqContext n -> (k : TyConKind) ->
-                   SZero (weakT (arity k) ret) left.term right.term
+                  (ret : Term 0 n) -> (u : Universe) ->
+                  (b1, b2 : TypeCaseArmBody k 0 n) ->
+                  Eff EqualElim ()
+    compareArm_ defs ctx KTYPE ret u b1 b2 =
+      try $ Term.compare0 defs ctx SZero ret b1.term b2.term
+
+    compareArm_ defs ctx KPi ret u b1 b2 = do
+      let [< a, b] = b1.names
+          ctx = extendTyN0
+            [< (a, TYPE u a.loc),
+               (b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] ctx
+      try $ Term.compare0 defs ctx SZero (weakT 2 ret) b1.term b2.term
+
+    compareArm_ defs ctx KSig ret u b1 b2 = do
+      let [< a, b] = b1.names
+          ctx = extendTyN0
+            [< (a, TYPE u a.loc),
+               (b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] ctx
+      try $ Term.compare0 defs ctx SZero (weakT 2 ret) b1.term b2.term
+
+    compareArm_ defs ctx KEnum ret u b1 b2 =
+      try $ Term.compare0 defs ctx SZero ret b1.term b2.term
+
+    compareArm_ defs ctx KEq ret u b1 b2 = do
+      let [< a0, a1, a, l, r] = b1.names
+          ctx = extendTyN0
+            [< (a0, TYPE u a0.loc),
+               (a1, TYPE u a1.loc),
+               (a,  Eq0 (TYPE u a.loc) (BVT 1 a0.loc) (BVT 0 a1.loc) a.loc),
+               (l,  BVT 2 a0.loc),
+               (r,  BVT 2 a1.loc)] ctx
+      try $ Term.compare0 defs ctx SZero (weakT 5 ret) b1.term b2.term
+
+    compareArm_ defs ctx KNat ret u b1 b2 =
+      try $ Term.compare0 defs ctx SZero ret b1.term b2.term
+
+    compareArm_ defs ctx KBOX ret u b1 b2 = do
+      let ctx = extendTy0 b1.name (TYPE u b1.name.loc) ctx
+      try $ Term.compare0 defs ctx SZero (weakT 1 ret) b1.term b1.term
+
 
   private covering
   compare0Inner : Definitions -> EqContext n -> (sg : SQty) ->
                   (e, f : Elim 0 n) -> Eff EqualElim (Term 0 n)
 
   private covering
-  compare0Inner' : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) ->
+  compare0Inner' : (defs : Definitions) -> EqContext n -> (sg : SQty) ->
                    (e, f : Elim 0 n) ->
-                   (0 ne : NotRedexEq defs ctx sg e) ->
+                   (0 ne : NotRedex defs sg e) -> (0 nf : NotRedex defs sg f) ->
-                   (0 nf : NotRedexEq defs ctx sg f) ->
                    Eff EqualElim (Term 0 n)
 
-  -- (no neutral dim apps or comps in a closed dctx)
-  compare0Inner' _ _ _ (DApp _ (K {}) _) _ ne _ =
-    void $ absurd $ noOr2 $ noOr2 ne
-  compare0Inner' _ _ _ _ (DApp _ (K {}) _) _ nf =
-    void $ absurd $ noOr2 $ noOr2 nf
-  compare0Inner' _ _ _ (Comp {r = K {}, _}) _ ne _ = void $ absurd $ noOr2 ne
-  compare0Inner' _ _ _ (Comp {r = B i _, _}) _ _ _ = absurd i
-  compare0Inner' _ _ _ _ (Comp {r = K {}, _}) _ nf = void $ absurd $ noOr2 nf
-
-  --  Ψ | Γ ⊢ A‹p₁/𝑖› <: B‹p₂/𝑖›
-  --  Ψ | Γ ⊢ A‹q₁/𝑖› <: B‹q₂/𝑖›
-  --  Ψ | Γ ⊢ s <: t ⇐ B‹p₂/𝑖›
-  -- -----------------------------------------------------------
-  --  Ψ | Γ ⊢ coe [𝑖 ⇒ A] @p₁ @q₁ s
-  --       <: coe [𝑖 ⇒ B] @p₂ @q₂ t ⇒ B‹q₂/𝑖›
-  compare0Inner' defs ctx sg (Coe ty1 p1 q1 val1 _)
-                             (Coe ty2 p2 q2 val2 _) ne nf = do
-    let ty1p = dsub1 ty1 p1; ty2p = dsub1 ty2 p2
-        ty1q = dsub1 ty1 q1; ty2q = dsub1 ty2 q2
-    (ty_p, ty_q) <- bigger (ty1p, ty1q) (ty2p, ty2q)
-    try $ do
-      compareType defs ctx ty1p ty2p
-      compareType defs ctx ty1q ty2q
-      Term.compare0 defs ctx sg ty_p val1 val2
-    pure $ ty_q
-
-  -- an adaptation of the rule
-  --
-  --  Ψ | Γ ⊢ A‹0/𝑖› = A‹1/𝑖› ⇐ ★
-  -- -----------------------------------------------------
-  --  Ψ | Γ ⊢ coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A‹1/𝑖›) ⇒ A‹1/𝑖›
-  --
-  -- it's here so that whnf doesn't have to depend on the equality checker
-  compare0Inner' defs ctx sg (Coe ty p q val loc) f _ _ =
-    if !(succeeds $ withEqual $ compareType defs ctx ty.zero ty.one)
-       then compare0Inner defs ctx sg (Ann val (dsub1 ty q) loc) f
-       else clashE defs ctx sg (Coe ty p q val loc) f
-
-  -- symmetric version of the above
-  compare0Inner' defs ctx sg e (Coe ty p q val loc) _ _ =
-    if !(succeeds $ withEqual $ compareType defs ctx ty.zero ty.one)
-       then compare0Inner defs ctx sg e (Ann val (dsub1 ty q) loc)
-       else clashE defs ctx sg e (Coe ty p q val loc)
-
   compare0Inner' defs ctx sg e@(F {}) f _ _ = do
     if e == f then computeElimTypeE defs ctx sg f
               else clashE defs ctx sg e f
@@ -665,7 +537,7 @@ namespace Elim
   --          = caseπ f return R of { (x, y) ⇒ t } ⇒ Q[e/p]
   compare0Inner' defs ctx sg (CasePair epi e eret ebody eloc)
                              (CasePair fpi f fret fbody floc) ne nf =
-    withEqual $ do
+    local_ Equal $ do
       ety <- compare0Inner defs ctx sg e f
       (fst, snd) <- expectSig defs ctx sg eloc ety
       let [< x, y] = ebody.names
@@ -684,7 +556,7 @@ namespace Elim
   -- ------------------------------
   --  Ψ | Γ ⊢ fst e = fst f ⇒ A
   compare0Inner' defs ctx sg (Fst e eloc) (Fst f floc) ne nf =
-    withEqual $ do
+    local_ Equal $ do
       ety <- compare0Inner defs ctx sg e f
       fst <$> expectSig defs ctx sg eloc ety
   compare0Inner' defs ctx sg e@(Fst {}) f _ _ =
@@ -694,7 +566,7 @@ namespace Elim
   -- ------------------------------------
   --  Ψ | Γ ⊢ snd e = snd f ⇒ B[fst e/x]
   compare0Inner' defs ctx sg (Snd e eloc) (Snd f floc) ne nf =
-    withEqual $ do
+    local_ Equal $ do
       ety <- compare0Inner defs ctx sg e f
       (_, tsnd) <- expectSig defs ctx sg eloc ety
       pure $ sub1 tsnd (Fst e eloc)
@@ -709,7 +581,7 @@ namespace Elim
   --        = caseπ f return R of { '𝐚ᵢ ⇒ tᵢ } ⇒ Q[e/x]
   compare0Inner' defs ctx sg (CaseEnum epi e eret earms eloc)
                              (CaseEnum fpi f fret farms floc) ne nf =
-    withEqual $ do
+    local_ Equal $ do
       ety <- compare0Inner defs ctx sg e f
       try $
         compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term
@@ -732,16 +604,16 @@ namespace Elim
   --        ⇒ Q[e/x]
   compare0Inner' defs ctx sg (CaseNat epi epi' e eret ezer esuc eloc)
                              (CaseNat fpi fpi' f fret fzer fsuc floc) ne nf =
-    withEqual $ do
+    local_ Equal $ do
       ety <- compare0Inner defs ctx sg e f
       let [< p, ih] = esuc.names
       try $ do
         compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term
         Term.compare0 defs ctx sg
-          (sub1 eret (Ann (Zero ezer.loc) (NAT ezer.loc) ezer.loc))
+          (sub1 eret (Ann (Zero ezer.loc) (Nat ezer.loc) ezer.loc))
           ezer fzer
         Term.compare0 defs
-          (extendTyN [< (epi, p, NAT p.loc), (epi', ih, eret.term)] ctx) sg
+          (extendTyN [< (epi, p, Nat p.loc), (epi', ih, eret.term)] ctx) sg
           (substCaseSuccRet esuc.names eret) esuc.term fsuc.term
         expectEqualQ e.loc epi  fpi
         expectEqualQ e.loc epi' fpi'
@@ -756,7 +628,7 @@ namespace Elim
   --        = caseπ f return R of { [x] ⇒ t } ⇒ Q[e/x]
   compare0Inner' defs ctx sg (CaseBox epi e eret ebody eloc)
                              (CaseBox fpi f fret fbody floc) ne nf =
-    withEqual $ do
+    local_ Equal $ do
       ety <- compare0Inner defs ctx sg e f
       (q, ty) <- expectBOX defs ctx sg eloc ety
       try $ do
@@ -768,6 +640,12 @@ namespace Elim
       pure $ sub1 eret e
   compare0Inner' defs ctx sg e@(CaseBox {}) f _ _ = clashE defs ctx sg e f
 
+  -- (no neutral dim apps in a closed dctx)
+  compare0Inner' _ _ _ (DApp _ (K {}) _) _ ne _ =
+    void $ absurd $ noOr2 $ noOr2 ne
+  compare0Inner' _ _ _ _ (DApp _ (K {}) _) _ nf =
+    void $ absurd $ noOr2 $ noOr2 nf
+
   --  Ψ | Γ ⊢ s <: t : B
   -- --------------------------------
   --  Ψ | Γ ⊢ (s ∷ A) <: (t ∷ B) ⇒ B
@@ -778,11 +656,34 @@ namespace Elim
     try $ Term.compare0 defs ctx sg ty s t
     pure ty
 
+  --  Ψ | Γ ⊢ A‹p₁/𝑖› <: B‹p₂/𝑖›
+  --  Ψ | Γ ⊢ A‹q₁/𝑖› <: B‹q₂/𝑖›
+  --  Ψ | Γ ⊢ s <: t ⇐ B‹p₂/𝑖›
+  -- -----------------------------------------------------------
+  --  Ψ | Γ ⊢ coe [𝑖 ⇒ A] @p₁ @q₁ s
+  --       <: coe [𝑖 ⇒ B] @p₂ @q₂ t ⇒ B‹q₂/𝑖›
+  compare0Inner' defs ctx sg (Coe ty1 p1 q1 val1 _)
+                             (Coe ty2 p2 q2 val2 _) ne nf = do
+    let ty1p = dsub1 ty1 p1; ty2p = dsub1 ty2 p2
+        ty1q = dsub1 ty1 q1; ty2q = dsub1 ty2 q2
+    (ty_p, ty_q) <- bigger (ty1p, ty1q) (ty2p, ty2q)
+    try $ do
+      compareType defs ctx ty1p ty2p
+      compareType defs ctx ty1q ty2q
+      Term.compare0 defs ctx sg ty_p val1 val2
+    pure $ ty_q
+  compare0Inner' defs ctx sg e@(Coe {}) f _ _ = clashE defs ctx sg e f
+
+  -- (no neutral compositions in a closed dctx)
+  compare0Inner' _ _ _ (Comp {r = K {}, _}) _ ne _ = void $ absurd $ noOr2 ne
+  compare0Inner' _ _ _ (Comp {r = B i _, _}) _ _ _ = absurd i
+  compare0Inner' _ _ _ _ (Comp {r = K {}, _}) _ nf = void $ absurd $ noOr2 nf
+
   -- (type case equality purely structural)
   compare0Inner' defs ctx sg (TypeCase ty1 ret1 arms1 def1 eloc)
                              (TypeCase ty2 ret2 arms2 def2 floc) ne _ =
     case sg `decEq` SZero of
-      Yes Refl => withEqual $ do
+      Yes Refl => local_ Equal $ do
         ety <- compare0Inner defs ctx SZero ty1 ty2
         u   <- expectTYPE defs ctx SZero eloc ety
         try $ do
@@ -812,6 +713,7 @@ namespace Elim
     clashE defs ctx sg e f
 
   compare0Inner defs ctx sg e f = do
+    let Val n = ctx.termLen
     Element e ne <- whnf defs ctx sg e.loc e
     Element f nf <- whnf defs ctx sg f.loc f
     ty <- compare0Inner' defs ctx sg e f ne nf
@@ -822,84 +724,30 @@ namespace Elim
 
 
 namespace Term
-  export covering %inline
+  compare0 defs ctx sg ty s t =
-  compare0NoLog :
-    Definitions -> EqContext n -> SQty -> (ty, s, t : Term 0 n) ->
-    Eff EqualInner ()
-  compare0NoLog defs ctx sg ty s t =
     wrapErr (WhileComparingT ctx !mode sg ty s t) $ do
+      let Val n = ctx.termLen
       Element ty' _ <- whnf defs ctx SZero ty.loc ty
       Element s'  _ <- whnf defs ctx sg s.loc  s
       Element t'  _ <- whnf defs ctx sg t.loc  t
       tty <- ensureTyCon ty.loc ctx ty'
       compare0' defs ctx sg ty' s' t'
 
-  compare0 defs ctx sg ty s t = do
-    sayMany "equal" s.loc
-      [30 :> "Term.compare0",
-       30 :> hsep ["mode =", pshow !mode],
-       95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx],
-       95 :> hsep ["sg =", runPretty $ prettyQty sg.qty],
-       31 :> hsep ["ty =", runPretty $ prettyTerm [<] ctx.tnames ty],
-       30 :> hsep ["s =", runPretty $ prettyTerm [<] ctx.tnames s],
-       30 :> hsep ["t =", runPretty $ prettyTerm [<] ctx.tnames t]]
-    compare0NoLog defs ctx sg ty s t
-
 namespace Elim
-  export covering %inline
+  compare0 defs ctx sg e f = do
-  compare0NoLog :
-    Definitions -> EqContext n -> SQty -> (e, f : Elim 0 n) ->
-    Eff EqualInner (Term 0 n)
-  compare0NoLog defs ctx sg e f = do
     (ty, err) <- runStateAt InnerErr Nothing $ compare0Inner defs ctx sg e f
     maybe (pure ty) throw err
 
-  compare0 defs ctx sg e f = do
+compareType defs ctx s t = do
-    sayMany "equal" e.loc
+  let Val n = ctx.termLen
-      [30 :> "Elim.compare0",
-       30 :> hsep ["mode =", pshow !mode],
-       95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx],
-       95 :> hsep ["sg =", runPretty $ prettyQty sg.qty],
-       30 :> hsep ["e =", runPretty $ prettyElim [<] ctx.tnames e],
-       30 :> hsep ["f =", runPretty $ prettyElim [<] ctx.tnames f]]
-    ty <- compare0NoLog defs ctx sg e f
-    say "equal" 31 e.loc $
-      hsep ["Elim.compare0 ⇝", runPretty $ prettyTerm [<] ctx.tnames ty]
-    pure ty
-
-export covering %inline
-compareTypeNoLog :
-  Definitions -> EqContext n -> (s, t : Term 0 n) -> Eff EqualInner ()
-compareTypeNoLog defs ctx s t = do
   Element s' _ <- whnf defs ctx SZero s.loc s
   Element t' _ <- whnf defs ctx SZero t.loc t
   ts <- ensureTyCon s.loc ctx s'
   tt <- ensureTyCon t.loc ctx t'
-  let Left _ = choose $ sameTyCon s' t' | _ => clashTy s.loc ctx s' t'
+  st <- either pure (const $ clashTy s.loc ctx s' t') $
+        nchoose $ sameTyCon s' t'
   compareType' defs ctx s' t'
 
-compareType defs ctx s t = do
-  sayMany "equal" s.loc
-    [30 :> "compareType",
-     30 :> hsep ["mode =", pshow !mode],
-     95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx],
-     30 :> hsep ["s =", runPretty $ prettyTerm [<] ctx.tnames s],
-     30 :> hsep ["t =", runPretty $ prettyTerm [<] ctx.tnames t]]
-  compareTypeNoLog defs ctx s t
-
-
-private
-getVars : TyContext d _ -> FreeVars d -> List BindName
-getVars ctx (FV fvs) = case ctx.dctx of
-  ZeroIsOne => []
-  C eqs     => toList $ getVars' ctx.dnames eqs fvs
-where
-  getVars' : BContext d' -> DimEq' d' -> FreeVars' d' -> SnocList BindName
-  getVars' (names :< name) (eqs :< eq) (fvs :< fv) =
-    let rest = getVars' names eqs fvs in
-    case eq of Nothing => rest :< name
-               Just _  => rest
-  getVars' [<] [<] [<] = [<]
 
 parameters (loc : Loc) (ctx : TyContext d n)
   parameters (mode : EqMode)
@@ -908,12 +756,10 @@ parameters (loc : Loc) (ctx : TyContext d n)
     fromInner = lift . map fst . runState mode
 
     private
-    eachCorner : Has Log fs => Loc -> FreeVars d ->
+    eachFace : Applicative f => FreeVars d ->
-                 (EqContext n -> DSubst d 0 -> Eff fs ()) -> Eff fs ()
+               (EqContext n -> DSubst d 0 -> f ()) -> f ()
-    eachCorner loc fvs act = do
+    eachFace fvs act =
-      say "equal" 50 loc $
+      let Val d = ctx.dimLen in
-        let vars = map prettyBind' (getVars ctx fvs) in
-        hsep $ "eachCorner: split on" :: if null vars then ["(none)"] else vars
       for_ (splits loc ctx.dctx fvs) $ \th =>
         act (makeEqContext ctx th) th
 
@@ -923,36 +769,32 @@ parameters (loc : Loc) (ctx : TyContext d n)
       Definitions -> EqContext n -> DSubst d 0 -> Eff EqualInner ()
 
     private
-    runCompare : Loc -> FreeVars d -> CompareAction d n -> Eff Equal ()
+    runCompare : FreeVars d -> CompareAction d n -> Eff Equal ()
-    runCompare loc fvs act = fromInner $ eachCorner loc fvs $ act !(askAt DEFS)
+    runCompare fvs act = fromInner $ eachFace fvs $ act !(askAt DEFS)
 
     private
-    foldMap1 : Semigroup b => (a -> b) -> List1 a -> b
+    fdvAll : HasFreeDVars t => List (t d n) -> FreeVars d
-    foldMap1 f = foldl1By (\x, y => x <+> f y) f
+    fdvAll ts =
-
+      let Val d = ctx.dimLen; Val n = ctx.termLen in foldMap fdv ts
-    private
-    fdvAll : HasFreeDVars t => (xs : List (t d n)) -> (0 _ : NonEmpty xs) =>
-             FreeVars d
-    fdvAll (x :: xs) = foldMap1 (fdvWith ctx.dimLen ctx.termLen) (x ::: xs)
 
     namespace Term
       export covering
       compare : SQty -> (ty, s, t : Term d n) -> Eff Equal ()
-      compare sg ty s t = runCompare s.loc (fdvAll [ty, s, t]) $
+      compare sg ty s t = runCompare (fdvAll [ty, s, t]) $ \defs, ectx, th =>
-        \defs, ectx, th => compare0 defs ectx sg (ty // th) (s // th) (t // th)
+        compare0 defs ectx sg (ty // th) (s // th) (t // th)
 
       export covering
       compareType : (s, t : Term d n) -> Eff Equal ()
-      compareType s t = runCompare s.loc (fdvAll [s, t]) $
+      compareType s t = runCompare (fdvAll [s, t]) $ \defs, ectx, th =>
-        \defs, ectx, th => compareType defs ectx (s // th) (t // th)
+        compareType defs ectx (s // th) (t // th)
 
     namespace Elim
       ||| you don't have to pass the type in but the arguments must still be
       ||| of the same type!!
       export covering
       compare : SQty -> (e, f : Elim d n) -> Eff Equal ()
-      compare sg e f = runCompare e.loc (fdvAll [e, f]) $
+      compare sg e f = runCompare (fdvAll [e, f]) $ \defs, ectx, th =>
-        \defs, ectx, th => ignore $ compare0 defs ectx sg (e // th) (f // th)
+        ignore $ compare0 defs ectx sg (e // th) (f // th)
 
   namespace Term
     export covering %inline

lib/Quox/FreeVars.idr

@@ -93,14 +93,6 @@ 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)
@@ -181,7 +173,6 @@ 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
@@ -190,14 +181,11 @@ HasFreeVars (Term d) where
   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 (Zero  {})            = 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
@@ -229,27 +217,27 @@ HasFreeVars (Elim d) where
 
 
 private
-expandDShift : {d1 : Nat} -> Shift d1 d2 -> Loc -> Context' (Dim d2) d1
+expandDShift : {d1 : Nat} -> Shift d1 d2 -> Context' (Dim d2) d1
-expandDShift by loc = tabulateLT d1 (\i => BV i loc // by)
+expandDShift by = tabulateLT d1 (\i => BV i noLoc // by)
 
 private
-expandDSubst : {d1 : Nat} -> DSubst d1 d2 -> Loc -> Context' (Dim d2) d1
+expandDSubst : {d1 : Nat} -> DSubst d1 d2 -> Context' (Dim d2) d1
-expandDSubst (Shift by) loc = expandDShift by loc
+expandDSubst (Shift by) = expandDShift by
-expandDSubst (t ::: th) loc = expandDSubst th loc :< t
+expandDSubst (t ::: th) = expandDSubst th :< t
 
 
 private
-fdvSubst' : {d1, d2, n : Nat} -> (Located2 tm, HasFreeDVars tm) =>
+fdvSubst' : {d1, d2, n : Nat} -> HasFreeDVars tm =>
             tm d1 n -> DSubst d1 d2 -> FreeVars d2
 fdvSubst' t th =
-  fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th t.loc)
+  fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th)
 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) =>
+fdvSubst : {d, n : Nat} -> HasFreeDVars tm =>
            WithSubst (\d => tm d n) Dim d -> FreeVars d
 fdvSubst (Sub t th) = let Val from = getFrom th in fdvSubst' t th
 
@@ -260,7 +248,6 @@ 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
@@ -269,14 +256,11 @@ HasFreeDVars Term where
   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 (Zero  {})            = 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

lib/Quox/Loc.idr

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

lib/Quox/Log.idr

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

lib/Quox/Name.idr

@@ -2,7 +2,6 @@ module Quox.Name
 
 import Quox.Loc
 import Quox.CharExtra
-import Quox.PrettyValExtra
 import public Data.SnocList
 import Data.List
 import Control.Eff
@@ -24,7 +23,7 @@ data BaseName
 = UN String         -- user-given name
 | MN String NameSuf -- machine-generated name
 | Unused            -- "_"
-%runElab derive "BaseName" [Eq, Ord, PrettyVal]
+%runElab derive "BaseName" [Eq, Ord]
 
 export
 baseStr : BaseName -> String
@@ -43,14 +42,14 @@ Mods = SnocList String
 
 public export
 record Name where
-  constructor MkName
+  constructor MakeName
   mods : Mods
   base : BaseName
 %runElab derive "Name" [Eq, Ord]
 
 public export %inline
 unq : BaseName -> Name
-unq = MkName [<]
+unq = MakeName [<]
 
 ||| add some namespaces to the beginning of a name
 public export %inline
@@ -64,31 +63,31 @@ PBaseName = String
 
 public export
 record PName where
-  constructor MkPName
+  constructor MakePName
   mods : Mods
   base : PBaseName
-%runElab derive "PName" [Eq, Ord, PrettyVal]
+%runElab derive "PName" [Eq, Ord]
 
 export %inline
 fromPName : PName -> Name
-fromPName p = MkName p.mods $ UN p.base
+fromPName p = MakeName p.mods $ UN p.base
 
 export %inline
 toPName : Name -> PName
-toPName p = MkPName p.mods $ baseStr p.base
+toPName p = MakePName p.mods $ baseStr p.base
 
 export %inline
 fromPBaseName : PBaseName -> Name
-fromPBaseName = MkName [<] . UN
+fromPBaseName = MakeName [<] . UN
 
 export
 Show PName where
-  show (MkPName mods base) =
+  show (MakePName mods base) =
     show $ concat $ intersperse "." $ toList $ mods :< base
 
 export Show Name where show = show . toPName
 
-export FromString PName where fromString = MkPName [<]
+export FromString PName where fromString = MakePName [<]
 
 export FromString Name where fromString = fromPBaseName
 
@@ -98,7 +97,7 @@ record BindName where
   constructor BN
   val  : BaseName
   loc_ : Loc
-%runElab derive "BindName" [Eq, Ord, Show, PrettyVal]
+%runElab derive "BindName" [Eq, Ord, Show]
 
 export Located BindName where n.loc = n.loc_
 export Relocatable BindName where setLoc loc (BN x _) = BN x loc
@@ -116,7 +115,7 @@ export
 fromListP : List1 String -> PName
 fromListP (x ::: xs) = go [<] x xs where
   go : SnocList String -> String -> List String -> PName
-  go mods x []        = MkPName mods x
+  go mods x []        = MakePName mods x
   go mods x (y :: ys) = go (mods :< x) y ys
 
 export %inline

lib/Quox/NatExtra.idr

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

lib/Quox/No.idr

@@ -43,7 +43,7 @@ parameters {0 a, b : Bool}
   noOr2 = snd . noOr
 
 
-export infixr 1 `orNo`
+infixr 1 `orNo`
 export %inline
 orNo : No a -> No b -> No (a || b)
 orNo Ah Ah = Ah

lib/Quox/OPE.idr

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

lib/Quox/Parser/FromParser.idr

@@ -3,12 +3,10 @@ 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
@@ -20,7 +18,6 @@ import System.File
 import System.Path
 import Data.IORef
 
-
 %hide Typing.Error
 %hide Lexer.Error
 %hide Parser.Error
@@ -28,55 +25,28 @@ import Data.IORef
 %default total
 
 
+public export
+NDefinition : Type
+NDefinition = (Name, Definition)
+
+
 public export
 data StateTag = NS | SEEN
 
 public export
 FromParserPure : List (Type -> Type)
-FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
+FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen]
 
 public export
 FromParserIO : List (Type -> Type)
-FromParserIO = FromParserPure ++ [LoadFile]
+FromParserIO = LoadFile :: FromParserPure
-
-
-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 $
+  fromBaseName x = maybe (f $ MakePName [<] x) b $
                    Context.find (\y => y.name == Just x) xs
 
   private
@@ -141,9 +111,6 @@ mutual
     TYPE k loc =>
       pure $ TYPE k loc
 
-    IOState loc =>
-      pure $ IOState loc
-
     Pi pi x s t loc =>
       Pi (fromPQty pi)
         <$> fromPTermWith ds ns s
@@ -184,16 +151,13 @@ mutual
       map E $ CaseEnum (fromPQty pi)
         <$> fromPTermElim ds ns tag
         <*> fromPTermTScope ds ns [< r] ret
-        <*> assert_total fromPTermEnumArms loc ds ns arms
+        <*> assert_total fromPTermEnumArms ds ns arms
         <*> pure loc
 
-    NAT loc => pure $ NAT loc
+    Nat loc => pure $ Nat loc
-    Nat n loc => pure $ Nat n loc
+    Zero loc => pure $ Zero loc
     Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|]
 
-    STRING loc => pure $ STRING loc
-    Str str loc => pure $ Str str loc
-
     Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
       map E $ CaseNat (fromPQty pi) (fromPQty pi')
         <$> fromPTermElim ds ns nat
@@ -202,11 +166,12 @@ mutual
         <*> fromPTermTScope ds ns [< s, ih] suc
         <*> pure loc
 
-    Enum strs loc => do
+    Enum strs loc =>
-      let set = SortedSet.fromList strs
+      let set = SortedSet.fromList strs in
-      unless (length strs == length (SortedSet.toList set)) $
+      if length strs == length (SortedSet.toList set) then
-        throw $ DuplicatesInEnumType loc strs
         pure $ Enum set loc
+      else
+        throw $ DuplicatesInEnum loc strs
 
     Tag str loc => pure $ Tag str loc
 
@@ -263,22 +228,13 @@ mutual
         <*> fromPTermDScope ds ns [< j1] val1
         <*> pure loc
 
-    Let (qty, x, rhs) body loc =>
-      Let (fromPQty qty)
-        <$> fromPTermElim ds ns rhs
-        <*> fromPTermTScope ds ns [< x] body
-        <*> pure loc
-
   private
-  fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n ->
+  fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
                       List (PTagVal, PTerm) ->
                       Eff FromParserPure (CaseEnumArms d n)
-  fromPTermEnumArms loc ds ns arms = do
+  fromPTermEnumArms ds ns =
-    res <- SortedMap.fromList <$>
+    map SortedMap.fromList .
-           traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms
+    traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
-    unless (length (keys res) == length arms) $
-      throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms)
-    pure res
 
   private
   fromPTermElim : Context' PatVar d -> Context' PatVar n ->
@@ -297,7 +253,7 @@ mutual
     if all isUnused xs then
       SN <$> fromPTermWith ds ns t
     else
-      SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
+      ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
 
   private
   fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
@@ -305,9 +261,9 @@ mutual
                     Eff FromParserPure (DScopeTermN s d n)
   fromPTermDScope ds ns xs t =
     if all isUnused xs then
-      SN {f = \d => Term d n} <$> fromPTermWith ds ns t
+      SN <$> fromPTermWith ds ns t
     else
-      SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
+      DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
 
 
 export %inline
@@ -316,8 +272,8 @@ fromPTerm = fromPTermWith [<] [<]
 
 
 export
-globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty
+globalPQty : Has (Except Error) fs => (q : Qty) -> Loc -> Eff fs GQty
-globalPQty (PQ pi loc) = case toGlobal pi of
+globalPQty pi loc = case toGlobal pi of
   Just g  => pure g
   Nothing => throw $ QtyNotGlobal loc pi
 
@@ -331,95 +287,51 @@ 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
+addDef : Has DefsState fs => Name -> GQty -> Term 0 0 -> Term 0 0 -> Loc ->
-liftWhnf tc = runEff tc $ with Union.(::)
+         Eff fs NDefinition
-  [handleExcept $ \e => throw $ WrapTypeError e,
+addDef name gqty type term loc = do
-   \g => send g,
+  let def = mkDef gqty type term loc
-   \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
+fromPDef (MkPDef qty pname ptype pterm defLoc) = do
-  name <- fromPBaseNameNS def.name
+  name <- fromPBaseNameNS pname
-  defs <- getAt DEFS
+  gqty <- globalPQty qty.val qty.loc
-  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
+  case type of
     Just type => do
       ignore $ liftTC $ do
         checkTypeC empty type Nothing
         checkC empty sqty term type
-          pure type
+      addDef name gqty type term defLoc
     Nothing => do
       let E elim = term
         | _ => throw $ AnnotationNeeded term.loc empty term
       res <- liftTC $ inferC empty sqty elim
-          pure res.type
+      addDef name gqty res.type term defLoc
-      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) =
+fromPDecl (PDef def) = singleton <$> fromPDef 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
+      Just inp => do
+        tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
+        concat <$> traverse fromPTopLevel tl
       Nothing => pure []
 
   ||| populates the `defs` field of the state
@@ -427,3 +339,32 @@ mutual
   fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
   fromPTopLevel (PD    decl)     = lift $ fromPDecl decl
   fromPTopLevel (PLoad file loc) = loadProcessFile loc file
+
+
+export
+fromParserPure : NameSuf -> Definitions ->
+                 Eff FromParserPure a ->
+                 Either Error (a, NameSuf, Definitions)
+fromParserPure suf defs act = runSTErr $ do
+  suf  <- liftST $ newSTRef suf
+  defs <- liftST $ newSTRef defs
+  res  <- runEff act $ with Union.(::)
+    [handleExcept (\e => stLeft e),
+     handleStateSTRef defs,
+     handleStateSTRef !(liftST $ newSTRef [<]),
+     handleStateSTRef suf]
+  pure (res, !(liftST $ readSTRef suf), !(liftST $ readSTRef defs))
+
+
+export covering
+fromParserIO : (MonadRec io, HasIO io) =>
+               IncludePath -> IORef SeenSet ->
+               IORef NameSuf -> IORef Definitions ->
+               Eff FromParserIO a -> io (Either Error a)
+fromParserIO inc seen suf defs act = liftIO $ fromIOErr $ do
+  runEff act $ with Union.(::)
+    [handleLoadFileIOE LoadError seen inc,
+     handleExcept (\e => ioLeft e),
+     handleStateIORef defs,
+     handleStateIORef !(newIORef [<]),
+     handleStateIORef suf]

lib/Quox/Parser/FromParser/Error.idr

@@ -7,8 +7,6 @@ import System.File
 
 import Quox.Pretty
 
-%default total
-
 %hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)
 
 
@@ -24,34 +22,26 @@ ParseError = Parser.Error
 public export
 data Error =
     AnnotationNeeded Loc (NameContexts d n) (Term d n)
-  | DuplicatesInEnumType Loc (List TagVal)
+  | DuplicatesInEnum 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
+  let loc = makeLoc file (MkBounds line col line col)
   reason <- case reason of
-    Other msg => pure $ text msg
+    EndInput    => pure "unexpected end of input"
-    NoRuleApply => case char of
+    NoRuleApply => pure $ text "unrecognised character: \{show char}"
-      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
@@ -72,23 +62,19 @@ prettyParseError file (ParseError errs) =
     traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
 
 
-parameters {opts : LayoutOpts} (showContext : Bool)
+parameters (showContext : Bool)
   export
-  prettyError : Error -> Eff Pretty (Doc opts)
+  prettyError : {opts : _} -> Error -> Eff Pretty (Doc opts)
   prettyError (AnnotationNeeded loc ctx tm) =
     [|vappend (prettyLoc loc)
         (hangD "type annotation needed on"
                !(prettyTerm ctx.dnames ctx.tnames tm))|]
     -- [todo] print the original PTerm instead
 
-  prettyError (DuplicatesInEnumType loc tags) =
+  prettyError (DuplicatesInEnum loc tags) =
     [|vappend (prettyLoc loc)
         (hangD "duplicate tags in enum type" !(prettyEnum tags))|]
 
-  prettyError (DuplicatesInEnumCase loc tags) =
-    [|vappend (prettyLoc loc)
-        (hangD "duplicate arms in enum case" !(prettyEnum tags))|]
-
   prettyError (DimNotInScope loc i) =
     [|vappend (prettyLoc loc)
         (pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]
@@ -115,32 +101,10 @@ parameters {opts : LayoutOpts} (showContext : Bool)
   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,7 +1,6 @@
 module Quox.Parser.Lexer
 
 import Quox.CharExtra
-import Quox.NatExtra
 import Quox.Name
 import Data.String.Extra
 import Data.SortedMap
@@ -20,7 +19,7 @@ import Derive.Prelude
 ||| @ Reserved reserved token
 ||| @ Name name, possibly qualified
 ||| @ Nat nat literal
-||| @ Str string literal
+||| @ String string literal
 ||| @ Tag tag literal
 ||| @ TYPE "Type" or "★" with ascii nat directly after
 ||| @ Sup superscript or ^ number (displacement, or universe for ★)
@@ -35,27 +34,16 @@ data Token =
   | Sup Nat
 %runElab derive "Token" [Eq, Ord, Show]
 
-||| token or whitespace
+-- 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
+0 TokenW : Type
-%runElab derive "ExtToken" [Eq, Ord, Show]
+TokenW = Maybe Token
 
 
-public export
-data ErrorReason =
-    NoRuleApply
-  | ComposeNotClosing (Int, Int) (Int, Int)
-  | Other String
-%runElab derive "ErrorReason" [Eq, Ord, Show]
-
 public export
 record Error where
   constructor Err
-  reason    : ErrorReason
+  reason    : StopReason
   line, col : Int
   ||| `Nothing` if the error is at the end of the input
   char      : Maybe Char
@@ -64,94 +52,49 @@ record Error where
 
 
 private
-skip : Lexer -> Tokenizer ExtToken
+skip : Lexer -> Tokenizer TokenW
-skip t = match t $ const Skip
+skip t = match t $ const Nothing
 
 private
-tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
+match : Lexer -> (String -> Token) -> Tokenizer TokenW
-tmatch t f = match t (T . f)
+match t f = Tokenizer.match t (Just . f)
+%hide Tokenizer.match
 
 
+private
+name : Tokenizer TokenW
+name = match name $ Name . fromListP . split (== '.') . normalizeNfc
+
+||| [todo] escapes other than `\"` and (accidentally) `\\`
 export
-fromStringLit : (String -> Token) -> String -> ExtToken
+fromStringLit : String -> String
-fromStringLit f str =
+fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where
-  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 ['\\']            = ['\\'] -- i guess???
+  go ('\\' :: c :: cs) = c :: go cs
   go (c :: cs)         = c :: go cs
 
-  decLit =
+private
-    withUnderscores (range '0' '9') <+> reject idContEnd
+string : Tokenizer TokenW
-
+string = match stringLit (Str . fromStringLit)
-  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
+nat : Tokenizer TokenW
-tag = tmatch (is '\'' <+> name)      (Tag . drop 1)
+nat = match (some (range '0' '9')) (Nat . cast)
-  <|>  match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1)
 
+private
+tag : Tokenizer TokenW
+tag = match (is '\'' <+> name)      (Tag . drop 1)
+  <|> match (is '\'' <+> stringLit) (Tag . fromStringLit . drop 1)
+
+
+
+private %inline
+fromSub : Char -> Char
+fromSub c = case c of
+  '₀' => '0'; '₁' => '1'; '₂' => '2'; '₃' => '3'; '₄' => '4'
+  '₅' => '5'; '₆' => '6'; '₇' => '7'; '₈' => '8'; '₉' => '9'; _ => c
 
 private %inline
 fromSup : Char -> Char
@@ -159,23 +102,27 @@ fromSup c = case c of
   '⁰' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '⁴' => '4'
   '⁵' => '5'; '⁶' => '6'; '⁷' => '7'; '⁸' => '8'; '⁹' => '9'; _ => c
 
+private %inline
+subToNat : String -> Nat
+subToNat = cast . pack . map fromSub . unpack
+
 private %inline
 supToNat : String -> Nat
 supToNat = cast . pack . map fromSup . unpack
 
--- ★0, Type0. base ★/Type is a Reserved and ★¹/Type¹ are sequences of two tokens
+-- ★0, Type0. base ★/Type is a Reserved
 private
-universe : Tokenizer ExtToken
+universe : Tokenizer TokenW
 universe = universeWith "★" <|> universeWith "Type" where
-  universeWith : String -> Tokenizer ExtToken
+  universeWith : String -> Tokenizer TokenW
   universeWith pfx =
     let len = length pfx in
-    tmatch (exact pfx <+> digits) (TYPE . cast . drop len)
+    match (exact pfx <+> digits) (TYPE . cast . drop len)
 
 private
-sup : Tokenizer ExtToken
+sup : Tokenizer TokenW
-sup = tmatch (some $ pred isSupDigit) (Sup . supToNat)
+sup = match (some $ pred isSupDigit) (Sup . supToNat)
-  <|> tmatch (is '^' <+> digits)      (Sup . cast . drop 1)
+  <|> match (is '^' <+> digits)      (Sup . cast . drop 1)
 
 
 private %inline
@@ -187,11 +134,9 @@ namespace Reserved
   ||| description of a reserved symbol
   ||| @ Word a reserved word (must not be followed by letters, digits, etc)
   ||| @ Sym a reserved symbol (must not be followed by symbolic chars)
-  ||| @ Punc a character that doesn't show up in names (brackets, etc);
+  ||| @ 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
+  data Reserved1 = Word String | Sym String | Punc Char
   %runElab derive "Reserved1" [Eq, Ord, Show]
 
   ||| description of a token that might have unicode & ascii-only aliases
@@ -200,14 +145,17 @@ namespace Reserved
   %runElab derive "Reserved" [Eq, Ord, Show]
 
   public export
-  Sym1, Word1, Punc1 : String -> Reserved
+  Sym1, Word1 : String -> Reserved
   Sym1 = Only . Sym
   Word1 = Only . Word
+
+  public export
+  Punc1 : Char -> Reserved
   Punc1 = Only . Punc
 
 public export
 resString1 : Reserved1 -> String
-resString1 (Punc x) = x
+resString1 (Punc x) = singleton x
 resString1 (Word w) = w
 resString1 (Sym  s) = s
 
@@ -218,23 +166,17 @@ resString : Reserved -> String
 resString (Only r)   = resString1 r
 resString (r `Or` _) = resString1 r
 
-||| return both representative strings for a token description
-public export
-resString2 : Reserved -> List String
-resString2 (Only r)   = [resString1 r]
-resString2 (r `Or` s) = [resString1 r, resString1 s]
-
 private
-resTokenizer1 : Reserved1 -> String -> Tokenizer ExtToken
+resTokenizer1 : Reserved1 -> String -> Tokenizer TokenW
 resTokenizer1 r str =
   let res : String -> Token := const $ Reserved str in
-  case r of Word w => tmatch (exact w <+> reject idContEnd) res
+  case r of Word w => match (exact w <+> reject idContEnd) res
-            Sym  s => tmatch (exact s <+> reject symCont)   res
+            Sym s  => match (exact s <+> reject symCont)   res
-            Punc x => tmatch (exact x)                      res
+            Punc x => match (is x)                         res
 
 ||| match a reserved token
 export
-resTokenizer : Reserved -> Tokenizer ExtToken
+resTokenizer : Reserved -> Tokenizer TokenW
 resTokenizer (Only r)   = resTokenizer1 r (resString1 r)
 resTokenizer (r `Or` s) =
   resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
@@ -246,8 +188,8 @@ resTokenizer (r `Or` s) =
 public export
 reserved : List Reserved
 reserved =
-  [Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}",
+  [Punc1 '(', Punc1 ')', Punc1 '[', Punc1 ']', Punc1 '{', Punc1 '}',
-   Punc1 ",", Punc1 ";", Punc1 "#[", Punc1 "#![",
+   Punc1 ',', Punc1 ';',
    Sym1 "@",
    Sym1 ":",
    Sym "⇒" `Or` Sym "=>",
@@ -255,15 +197,12 @@ reserved =
    Sym "×" `Or` Sym "**",
    Sym "≡" `Or` Sym "==",
    Sym "∷" `Or` Sym "::",
-   Punc1 ".",
+   Punc1 '.',
    Word1 "case",
    Word1 "case0", Word1 "case1",
    Word "caseω" `Or` Word "case#",
    Word1 "return",
    Word1 "of",
-   Word1 "let", Word1 "in",
-   Word1 "let0", Word1 "let1",
-   Word "letω" `Or` Word "let#",
    Word1 "fst", Word1 "snd",
    Word1 "_",
    Word1 "Eq",
@@ -272,71 +211,35 @@ reserved =
    Word "ω" `Or` Sym "#",
    Sym "★" `Or` Word "Type",
    Word "ℕ" `Or` Word "Nat",
-   Word1 "IOState",
-   Word1 "String",
    Word1 "zero", Word1 "succ",
    Word1 "coe", Word1 "comp",
    Word1 "def",
    Word1 "def0",
    Word "defω" `Or` Word "def#",
-   Word1 "postulate",
-   Word1 "postulate0",
-   Word "postulateω" `Or` Word "postulate#",
    Sym1 "=",
    Word1 "load",
    Word1 "namespace"]
 
-public export
-reservedStrings : List String
-reservedStrings = map resString reserved
-
-public export
-allReservedStrings : List String
-allReservedStrings = foldMap resString2 reserved
-
 ||| `IsReserved str` is true if `Reserved str` might actually show up in
 ||| the token stream
 public export
 IsReserved : String -> Type
-IsReserved str = So (str `elem` reservedStrings)
+IsReserved str = str `Elem` map resString reserved
-
-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 : Tokenizer TokenW
 tokens = choice $
   map skip [pred isWhitespace,
             lineComment (exact "--" <+> reject symCont),
             blockComment (exact "{-") (exact "-}")] <+>
-  [universe] <+>  -- Type<i> takes precedence over bare Type
+  [universe] <+>  -- ★ᵢ takes precedence over bare ★
   map resTokenizer reserved <+>
   [sup, nat, string, tag, name]
 
-export
-check : Alternative f =>
-        WithBounds ExtToken -> Either Error (f (WithBounds Token))
-check (MkBounded val irr bounds@(MkBounds line col _ _)) = case val of
-  Skip            => Right empty
-  T tok           => Right $ pure $ MkBounded tok irr bounds
-  Invalid msg tok => Left  $ Err (Other msg) line col (index 0 tok)
-
-export
-toErrorReason : StopReason -> Maybe ErrorReason
-toErrorReason EndInput                = Nothing
-toErrorReason NoRuleApply             = Just NoRuleApply
-toErrorReason (ComposeNotClosing s e) = Just $ ComposeNotClosing s e
-
 export
 lex : String -> Either Error (List (WithBounds Token))
 lex str =
   let (res, reason, line, col, str) = lex tokens str in
-  case toErrorReason reason of
+  case reason of
-    Nothing => concatMap check res @{MonoidApplicative}
+    EndInput => Right $ mapMaybe sequence res
-    Just e  => Left $ Err {reason = e, line, col, char = index 0 str}
+    _        => Left  $ Err {reason, line, col, char = index 0 str}

lib/Quox/Parser/LoadFile.idr

@@ -1,7 +1,5 @@
 module Quox.Parser.LoadFile
 
-import public Quox.Parser.Syntax
-import Quox.Parser.Parser
 import Quox.Loc
 import Quox.EffExtra
 import Data.IORef
@@ -22,7 +20,7 @@ data LoadFileL : (lbl : k) -> Type -> Type where
   [search lbl]
   Seen    : FilePath -> LoadFileL lbl Bool
   SetSeen : FilePath -> LoadFileL lbl ()
-  DoLoad  : Loc -> FilePath -> LoadFileL lbl PFile
+  DoLoad  : Loc -> FilePath -> LoadFileL lbl String
 
 public export
 LoadFile : Type -> Type
@@ -49,11 +47,11 @@ setSeen = setSeenAt ()
 
 export
 doLoadAt : (0 lbl : k) -> Has (LoadFileL lbl) fs =>
-           Loc -> FilePath -> Eff fs PFile
+           Loc -> FilePath -> Eff fs String
 doLoadAt lbl loc file = send $ DoLoad {lbl} loc file
 
 export %inline
-doLoad : Has LoadFile fs => Loc -> FilePath -> Eff fs PFile
+doLoad : Has LoadFile fs => Loc -> FilePath -> Eff fs String
 doLoad = doLoadAt ()
 
 
@@ -65,6 +63,10 @@ public export
 IncludePath : Type
 IncludePath = List String
 
+public export
+ErrorWrapper : Type -> Type
+ErrorWrapper e = Loc -> FilePath -> FileError -> e
+
 export covering
 readFileFrom : HasIO io => IncludePath -> FilePath ->
                io (Either FileError String)
@@ -74,27 +76,23 @@ readFileFrom inc f =
     Nothing   => pure $ Left $ FileNotFound
 
 export covering
-handleLoadFileIOE : (Loc -> FilePath -> FileError -> e) ->
+handleLoadFileIOE : ErrorWrapper e ->
-                    (FilePath -> Parser.Error -> e) ->
                     IORef SeenSet -> IncludePath ->
                     LoadFileL lbl a -> IOErr e a
-handleLoadFileIOE injf injp seen inc = \case
+handleLoadFileIOE inj seen inc = \case
   Seen    f   => contains f <$> readIORef seen
   SetSeen f   => modifyIORef seen $ insert f
-  DoLoad  l f =>
+  DoLoad  l f => readFileFrom inc f >>= either (ioLeft . inj l f) pure
-    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)
+             Loc -> FilePath -> Eff fs (Maybe String)
 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 : Has LoadFile fs => Loc -> FilePath -> Eff fs (Maybe String)
 loadFile = loadFileAt ()

lib/Quox/Parser/Parser.idr

@@ -124,7 +124,7 @@ qname = terminalMatch "name" `(Name n) `(n)
 ||| unqualified name
 export
 baseName : Grammar True PBaseName
-baseName = terminalMatch "unqualified name" `(Name (MkPName [<] b)) `(b)
+baseName = terminalMatch "unqualified name" `(Name (MakePName [<] b)) `(b)
 
 ||| dimension constant (0 or 1)
 export
@@ -149,12 +149,6 @@ export
 qty : FileName -> Grammar True PQty
 qty fname = withLoc fname [|PQ qtyVal|]
 
-export
-exactName : String -> Grammar True ()
-exactName name = terminal "expected '\{name}'" $ \case
-  Name (MkPName [<] x) => guard $ x == name
-  _                    => Nothing
-
 
 ||| pattern var (unqualified name or _)
 export
@@ -286,81 +280,19 @@ export
 universe1 : Grammar True Universe
 universe1 = universeTok <|> res "★" *> option 0 super
 
-
+||| argument/atomic term: single-token terms, or those with delimiters e.g.
-public export
+||| `[t]`
-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  <$ res "ℕ"
-  <|> Nat 0  <$ res "zero"
+  <|> Zero <$ res "zero"
-  <|> [|Nat nat|]
+  <|> [|fromNat nat|]
-  <|> STRING <$ res "String"
-  <|> [|Str strLit|]
   <|> [|V qname displacement|]
-  <|> const <$> caseTerm fname
   <|> const <$> tupleTerm fname
 
 export
@@ -440,24 +372,11 @@ 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
+resAppTerm fname word f = withLoc fname $
-  head <- withLoc fname $ resC word *> mustWork [|f (termArg fname)|]
+  resC word *> mustWork [|f (termArg fname)|]
-  args <- many $ anyArg fname
-  pure $ \loc => foldl (appArg loc) head args
 
 export
 succTerm : FileName -> Grammar True PTerm
@@ -471,12 +390,21 @@ export
 sndTerm : FileName -> Grammar True PTerm
 sndTerm fname = resAppTerm fname "snd" Snd
 
+||| 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
 normalAppTerm : FileName -> Grammar True PTerm
 normalAppTerm fname = withLoc fname $ do
   head <- termArg fname
   args <- many $ anyArg fname
-  pure $ \loc => foldl (appArg loc) head args
+  pure $ \loc => foldl (ap loc) head args
+where ap : Loc -> PTerm -> Either PDim PTerm -> PTerm
+      ap loc f (Left  p) = DApp f p loc
+      ap loc f (Right s) = App  f s loc
 
 ||| application term `f x @y z`, or other terms that look like application
 ||| like `succ` or `coe`.
@@ -584,284 +512,105 @@ where
   makePi q doms cod loc =
     foldr (\(q, x, s), t => Pi q x s t loc) cod $ toDoms (toQty q) doms
 
+public export
+PCaseArm : Type
+PCaseArm = (PCasePat, PTerm)
 
 export
-letIntro : FileName -> Grammar True (Maybe PQty)
+caseArm : FileName -> Grammar True PCaseArm
-letIntro fname =
+caseArm fname =
-      withLoc fname (Just . PQ Zero <$ res "let0")
+  [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
-  <|> 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
+checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody
-letTerm fname = withLoc fname $ do
+checkCaseArms loc [] = pure $ CaseEnum [] loc
-  qty   <- letIntro fname
+checkCaseArms loc ((PPair x y _, rhs) :: rest) =
-  binds <- sepEndBy1 (res ";") $ assert_total letBinder fname qty
+  if null rest then pure $ CasePair (x, y) rhs loc
-  mustWork $ resC "in"
+  else fatalError "unexpected pattern after pair"
-  body  <- assert_total term fname
+checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do
-  pure $ \loc => foldr (\b, s => Let b s loc) body binds
+  let rest = for rest $ \case
+        (PTag tag _, rhs) => Just (tag, rhs)
+        _                 => Nothing
+  maybe (fatalError "expected all patterns to be tags")
+        (\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest
+checkCaseArms loc ((PZero _, rhs1) :: rest) = do
+  let [(PSucc p q ih _, rhs2)] = rest
+    | _ => fatalError "expected succ pattern after zero"
+  pure $ CaseNat rhs1 (p, q, ih, rhs2) loc
+checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do
+  let [(PZero _, rhs2)] = rest
+    | _ => fatalError "expected zero pattern after succ"
+  pure $ CaseNat rhs2 (p, q, ih, rhs1) loc
+checkCaseArms loc ((PBox x _, rhs) :: rest) =
+  if null rest then pure $ CaseBox x rhs loc
+  else fatalError "unexpected pattern after box"
 
+export
+caseBody : FileName -> Grammar True PCaseBody
+caseBody fname = do
+  body <- bounds $ delimSep "{" "}" ";" $ caseArm fname
+  let loc = makeLoc fname body.bounds
+  checkCaseArms loc body.val
+
+export
+caseReturn : FileName -> Grammar True (PatVar, PTerm)
+caseReturn fname = do
+  x   <- patVar fname <* resC "⇒" <|> unused fname
+  ret <- assert_total term fname
+  pure (x, ret)
+
+export
+caseTerm : FileName -> Grammar True PTerm
+caseTerm fname = withLoc fname $ do
+  qty <- caseIntro fname;                     commit
+  head <- mustWork $ assert_total term fname; needRes "return"
+  ret  <- mustWork $ caseReturn fname;        needRes "of"
+  body <- mustWork $ caseBody fname
+  pure $ Case qty head ret body
+
+-- export
 -- term : FileName -> Grammar True PTerm
 term fname = lamTerm fname
+         <|> caseTerm fname
          <|> piTerm fname
          <|> sigmaTerm fname
-         <|> letTerm fname
-
-
-export
-attr' : FileName -> (o : String) -> (0 _ : IsReserved o) =>
-        Grammar True PAttr
-attr' fname o = withLoc fname $ do
-  resC o
-  name <- baseName
-  args <- many $ termArg fname
-  mustWork $ resC "]"
-  pure $ PA name args
-
-export %inline
-attr : FileName -> Grammar True PAttr
-attr fname = attr' fname "#["
-
-export
-findDups : List PAttr -> List String
-findDups attrs =
-  SortedSet.toList $ snd $ foldl check (empty, empty) attrs
-where
-  Seen = SortedSet String; Dups = SortedSet String
-  check : (Seen, Dups) -> PAttr -> (Seen, Dups)
-  check (seen, dups) (PA a _ _) =
-    (insert a seen, if contains a seen then insert a dups else dups)
-
-export
-noDups : List PAttr -> Grammar False ()
-noDups attrs = do
-  let dups = findDups attrs
-  when (not $ null dups) $
-    fatalError "duplicate attribute names: \{joinBy "," dups}"
-
-export
-attrList : FileName -> Grammar False (List PAttr)
-attrList fname = do
-  res <- many $ attr fname
-  noDups res $> res
-
-public export
-data AttrMatch a =
-    Matched a
-  | NoMatch String (List String)
-  | Malformed String String
-
-export
-Functor AttrMatch where
-  map f (Matched x)     = Matched $ f x
-  map f (NoMatch s w)   = NoMatch s w
-  map f (Malformed a e) = Malformed a e
-
-export
-(<|>) : AttrMatch a -> AttrMatch a -> AttrMatch a
-Matched x     <|> _ = Matched x
-NoMatch {}    <|> y = y
-Malformed a e <|> _ = Malformed a e
-
-export
-isFail : PAttr -> List String -> AttrMatch PFail
-isFail (PA "fail" []        _) _ = Matched PFailAny
-isFail (PA "fail" [Str s _] _) _ = Matched $ PFailMatch s
-isFail (PA "fail" _ _) _ = Malformed "fail" "be absent or a string literal"
-isFail a w = NoMatch a.name w
-
-export
-isMain : PAttr -> List String -> AttrMatch ()
-isMain (PA "main" [] _) _ = Matched ()
-isMain (PA "main" _  _) _ = Malformed "main" "have no arguments"
-isMain a w = NoMatch a.name w
-
-export
-isScheme : PAttr -> List String -> AttrMatch String
-isScheme (PA "compile-scheme" [Str s _] _) _ = Matched s
-isScheme (PA "compile-scheme" _ _) _ =
-  Malformed "compile-scheme" "be a string literal"
-isScheme a w = NoMatch a.name w
-
-export
-matchAttr : String -> AttrMatch a -> Either String a
-matchAttr _ (Matched x) = Right x
-matchAttr d (NoMatch a w) = Left $ unlines
-  ["unrecognised \{d} attribute \{a}", "expected one of: \{show w}"]
-matchAttr _ (Malformed a s) = Left $ unlines
-  ["invalid \{a} attribute", "(should \{s})"]
-
-export
-mkPDef : List PAttr -> PQty -> PBaseName -> PBody ->
-         Either String (Loc -> PDefinition)
-mkPDef attrs qty name body = do
-  let start = MkPDef qty name body PSucceed False Nothing noLoc
-  res <- foldlM addAttr start attrs
-  pure $ \l => {loc_ := l} (the PDefinition res)
-where
-  data PDefAttr = DefFail PFail | DefMain | DefScheme String
-
-  isDefAttr : PAttr -> Either String PDefAttr
-  isDefAttr attr =
-    let defAttrs = ["fail", "main", "compile-scheme"] in
-    matchAttr "definition" $
-        DefFail   <$> isFail attr defAttrs
-    <|> DefMain   <$  isMain attr defAttrs
-    <|> DefScheme <$> isScheme attr defAttrs
-
-  addAttr : PDefinition -> PAttr -> Either String PDefinition
-  addAttr def attr =
-    case !(isDefAttr attr) of
-      DefFail   f   => pure $ {fail := f} def
-      DefMain       => pure $ {main := True} def
-      DefScheme str => pure $ {scheme := Just str} def
-
-export
-mkPNamespace : List PAttr -> Mods -> List PDecl ->
-               Either String (Loc -> PNamespace)
-mkPNamespace attrs name decls = do
-  let start = MkPNamespace name decls PSucceed noLoc
-  res <- foldlM addAttr start attrs
-  pure $ \l => {loc_ := l} (the PNamespace res)
-where
-  isNsAttr a = matchAttr "namespace" $ isFail a ["fail"]
-
-  addAttr : PNamespace -> PAttr -> Either String PNamespace
-  addAttr ns attr = pure $ {fail := !(isNsAttr attr)} ns
-
-||| `def` alone means `defω`; same for `postulate`
-export
-defIntro' : (bare, zero, omega : String) ->
-            (0 _ : IsReserved bare) =>
-            (0 _ : IsReserved zero) =>
-            (0 _ : IsReserved omega) =>
-            FileName -> Grammar True PQty
-defIntro' bare zero omega fname =
-      withLoc fname (PQ Zero <$ resC zero)
-  <|> withLoc fname (PQ Any  <$ resC omega)
-  <|> do pos <- bounds $ resC bare
-         let any = PQ Any $ makeLoc fname pos.bounds
-         option any $ qty fname <* needRes "."
-
-export
-defIntro : FileName -> Grammar True PQty
-defIntro = defIntro' "def" "def0" "defω"
-
-export
-postulateIntro : FileName -> Grammar True PQty
-postulateIntro = defIntro' "postulate" "postulate0" "postulateω"
-
-export
-postulate : FileName -> List PAttr -> Grammar True PDefinition
-postulate fname attrs = withLoc fname $ do
-  qty  <- postulateIntro fname
-  name <- baseName
-  type <- resC ":" *> mustWork (term fname)
-  optRes ";"
-  either fatalError pure $ mkPDef attrs qty name $ PPostulate type
-
-export
-concrete : FileName -> List PAttr -> Grammar True PDefinition
-concrete fname attrs = withLoc fname $ do
-  qty  <- defIntro fname
-  name <- baseName
-  type <- optional $ resC ":" *> mustWork (term fname)
-  term <- needRes "=" *> mustWork (term fname)
-  optRes ";"
-  either fatalError pure $ mkPDef attrs qty name $ PConcrete type term
-
-export
-definition : FileName -> List PAttr -> Grammar True PDefinition
-definition fname attrs =
-  try (postulate fname attrs) <|> concrete fname attrs
-
-export
-nsname : Grammar True Mods
-nsname = do ns <- qname; pure $ ns.mods :< ns.base
-
-export
-pragma : FileName -> Grammar True PPragma
-pragma fname = do
-  a <- attr' fname "#!["
-  either fatalError pure $ case a.name of
-    "log" => logArgs a.args a.loc
-    _     => Left $
-      #"unrecognised pragma "\#{a.name}"\n"# ++
-      #"known pragmas: ["log"]"#
-where
-  levelOOB : Nat -> Either String a
-  levelOOB n = Left $
-    "log level \{show n} out of bounds\n" ++
-    "expected number in range 0–\{show maxLogLevel} inclusive"
-
-  toLevel : Nat -> Either String LogLevel
-  toLevel lvl = maybe (levelOOB lvl) Right $ toLogLevel lvl
-
-  unknownCat : String -> Either String a
-  unknownCat cat = Left $
-    "unknown log category \{show cat}\n" ++
-    "known categories: \{show $ ["all", "default"] ++ logCategories}"
-
-  toCat : String -> Either String LogCategory
-  toCat cat = maybe (unknownCat cat) Right $ toLogCategory cat
-
-  fromPair : PTerm -> Either String (String, Nat)
-  fromPair (Pair (V (MkPName [<] x) Nothing _) (Nat n _) _) = Right (x, n)
-  fromPair _ = Left "invalid argument to log pragma"
-
-  logCatArg : (String, Nat) -> Either String Log.PushArg
-  logCatArg ("default", lvl) = [|SetDefault $ toLevel lvl|]
-  logCatArg ("all",     lvl) = [|SetAll $ toLevel lvl|]
-  logCatArg (cat,       lvl) = [|SetCat (toCat cat) (toLevel lvl)|]
-
-  logArgs : List PTerm -> Loc -> Either String PPragma
-  logArgs [] _ = Left "missing arguments to log pragma"
-  logArgs [V "pop" Nothing _] loc = Right $ PLogPop loc
-  logArgs other loc = do
-    args <- traverse (logCatArg <=< fromPair) other
-    pure $ PLogPush args loc
 
 
 export
 decl : FileName -> Grammar True PDecl
 
+||| `def` alone means `defω`
 export
-namespace_ : FileName -> List PAttr -> Grammar True PNamespace
+defIntro : FileName -> Grammar True PQty
-namespace_ fname attrs = withLoc fname $ do
+defIntro fname =
-  ns    <- resC "namespace" *> nsname; needRes "{"
+      withLoc fname (PQ Zero <$ resC "def0")
-  decls <- nsInner
+  <|> withLoc fname (PQ Any  <$ resC "defω")
-  either fatalError pure $ mkPNamespace attrs ns decls
+  <|> do pos <- bounds $ resC "def"
+         let any = PQ Any $ makeLoc fname pos.bounds
+         option any $ qty fname <* needRes "."
+
+export
+definition : FileName -> Grammar True PDefinition
+definition fname = withLoc fname $ do
+  qty  <- defIntro fname
+  name <- baseName
+  type <- optional $ resC ":" *> mustWork (term fname)
+  term <- needRes "=" *> mustWork (term fname)
+  optRes ";"
+  pure $ MkPDef qty name type term
+
+export
+namespace_ : FileName -> Grammar True PNamespace
+namespace_ fname = withLoc fname $ do
+  ns    <- resC "namespace" *> qname; needRes "{"
+  decls <- nsInner; optRes ";"
+  pure $ MkPNamespace (ns.mods :< ns.base) decls
 where
   nsInner : Grammar True (List PDecl)
   nsInner = [] <$ resC "}"
         <|> [|(assert_total decl fname <* commit) :: assert_total nsInner|]
 
-export
+decl fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|]
-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
@@ -873,7 +622,7 @@ topLevel : FileName -> Grammar True PTopLevel
 topLevel fname = load fname <|> [|PD $ decl fname|]
 
 export
-input : FileName -> Grammar False PFile
+input : FileName -> Grammar False (List PTopLevel)
 input fname = [] <$ eof
           <|> [|(topLevel fname <* commit) :: assert_total input fname|]
 
@@ -882,5 +631,5 @@ lexParseTerm : FileName -> String -> Either Error PTerm
 lexParseTerm = lexParseWith . term
 
 export
-lexParseInput : FileName -> String -> Either Error PFile
+lexParseInput : FileName -> String -> Either Error (List PTopLevel)
 lexParseInput = lexParseWith . input

lib/Quox/Parser/Syntax.idr

@@ -3,8 +3,6 @@ module Quox.Parser.Syntax
 import public Quox.Loc
 import public Quox.Syntax
 import public Quox.Definition
-import Quox.PrettyValExtra
-import public Quox.Log
 
 import Derive.Prelude
 %hide TT.Name
@@ -16,9 +14,9 @@ import Derive.Prelude
 public export
 data PatVar = Unused Loc | PV PBaseName Loc
 %name PatVar v
-%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PatVar" [Eq, Ord, Show]
 
-export %inline
+export
 Located PatVar where
   (Unused loc).loc = loc
   (PV _   loc).loc = loc
@@ -40,17 +38,17 @@ record PQty where
   val  : Qty
   loc_ : Loc
 %name PQty qty
-%runElab derive "PQty" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PQty" [Eq, Ord, Show]
 
-export %inline Located PQty where q.loc = q.loc_
+export Located PQty where q.loc = q.loc_
 
 namespace PDim
   public export
   data PDim = K DimConst Loc | V PBaseName Loc
   %name PDim p, q
-  %runElab derive "PDim" [Eq, Ord, Show, PrettyVal]
+  %runElab derive "PDim" [Eq, Ord, Show]
 
-export %inline
+export
 Located PDim where
   (K _ loc).loc = loc
   (V _ loc).loc = loc
@@ -58,7 +56,7 @@ Located PDim where
 public export
 data PTagVal = PT TagVal Loc
 %name PTagVal tag
-%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PTagVal" [Eq, Ord, Show]
 
 
 namespace PTerm
@@ -68,8 +66,6 @@ namespace PTerm
     data PTerm =
         TYPE Universe Loc
 
-      | IOState Loc
-
       | Pi PQty PatVar PTerm PTerm Loc
       | Lam PatVar PTerm Loc
       | App PTerm PTerm Loc
@@ -86,11 +82,8 @@ namespace PTerm
       | DLam PatVar PTerm Loc
       | DApp PTerm PDim Loc
 
-      | NAT Loc
+      | Nat Loc
-      | Nat Nat Loc | Succ PTerm Loc
+      | Zero Loc | Succ PTerm Loc
-
-      | STRING Loc  -- "String" is a reserved word in idris
-      | Str String Loc
 
       | BOX PQty PTerm Loc
       | Box PTerm Loc
@@ -101,8 +94,6 @@ namespace PTerm
       | Coe (PatVar, PTerm) PDim PDim PTerm Loc
       | Comp (PatVar, PTerm) PDim PDim PTerm PDim
              (PatVar, PTerm) (PatVar, PTerm) Loc
-
-      | Let (PQty, PatVar, PTerm) PTerm Loc
     %name PTerm s, t
 
     public export
@@ -113,16 +104,11 @@ namespace PTerm
       | CaseBox PatVar PTerm Loc
     %name PCaseBody body
 
-  public export %inline
+%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
-  Zero : Loc -> PTerm
-  Zero = Nat 0
 
-%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal]
+export
-
-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
@@ -136,20 +122,17 @@ Located PTerm where
   (Eq   _ _ _         loc).loc = loc
   (DLam _ _           loc).loc = loc
   (DApp _ _           loc).loc = loc
-  (NAT                   loc).loc = loc
+  (Nat                loc).loc = loc
-  (Nat     _             loc).loc = loc
+  (Zero               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
+export
 Located PCaseBody where
   (CasePair _ _ loc).loc = loc
   (CaseEnum _   loc).loc = loc
@@ -157,45 +140,18 @@ Located PCaseBody where
   (CaseBox  _ _ loc).loc = loc
 
 
-public export
-data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm
-%name PBody body
-%runElab derive "PBody" [Eq, Ord, Show, PrettyVal]
-
-
-public export
-data PFail =
-  PSucceed
-| PFailAny
-| PFailMatch String
-%runElab derive "PFail" [Eq, Ord, Show, PrettyVal]
-
 public export
 record PDefinition where
   constructor MkPDef
   qty  : PQty
   name : PBaseName
-  body   : PBody
+  type : Maybe PTerm
-  fail   : PFail
+  term : PTerm
-  main   : Bool
-  scheme : Maybe String
   loc_ : Loc
 %name PDefinition def
-%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
+%runElab derive "PDefinition" [Eq, Ord, Show]
 
-export %inline Located PDefinition where def.loc = def.loc_
+export 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
@@ -203,7 +159,6 @@ mutual
     constructor MkPNamespace
     name  : Mods
     decls : List PDecl
-    fail  : PFail
     loc_  : Loc
   %name PNamespace ns
 
@@ -211,41 +166,28 @@ mutual
   data PDecl =
       PDef PDefinition
     | PNs  PNamespace
-    | PPrag PPragma
   %name PDecl decl
-%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
+%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show]
 
-export %inline Located PNamespace where ns.loc = ns.loc_
+export Located PNamespace where ns.loc = ns.loc_
 
-export %inline
+export
 Located PDecl where
-  (PDef  d).loc    = d.loc
+  (PDef def).loc = def.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]
+%runElab derive "PTopLevel" [Eq, Ord, Show]
 
-export %inline
+export
 Located PTopLevel where
   (PD    decl).loc  = decl.loc
   (PLoad _ loc).loc = loc
 
 
 public export
-record PAttr where
+fromNat : Nat -> Loc -> PTerm
-  constructor PA
+fromNat 0     loc = Zero loc
-  name : PBaseName
+fromNat (S k) loc = Succ (fromNat k loc) loc
-  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

@@ -41,7 +41,7 @@ data HL
 | Dim  | DVar | DVarErr
 | Qty  | Universe
 | Syntax
-| Constant
+| Tag
 %runElab derive "HL" [Eq, Ord, Show]
 
 
@@ -86,38 +86,20 @@ toSGR DVarErr  = [SetForeground BrightGreen, SetStyle SingleUnderline]
 toSGR Qty      = [SetForeground BrightMagenta]
 toSGR Universe = [SetForeground BrightRed]
 toSGR Syntax   = [SetForeground BrightCyan]
-toSGR Constant = [SetForeground BrightRed]
+toSGR Tag      = [SetForeground BrightRed]
 
 export %inline
 highlightSGR : HL -> Highlight
 highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
 
-export %inline
-toClass : HL -> String
-toClass Delim    = "dl"
-toClass Free     = "fr"
-toClass TVar     = "tv"
-toClass TVarErr  = "tv err"
-toClass Dim      = "dc"
-toClass DVar     = "dv"
-toClass DVarErr  = "dv err"
-toClass Qty      = "qt"
-toClass Universe = "un"
-toClass Syntax   = "sy"
-toClass Constant = "co"
-
-export %inline
-highlightHtml : HL -> Highlight
-highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
-
-
-export %inline
-runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
-runPrettyHL f = runPrettyWith Outer Unicode f 2
 
 export %inline
 runPretty : Eff Pretty a -> a
-runPretty = runPrettyHL noHighlight
+runPretty = runPrettyWith Outer Unicode noHighlight 2
+
+export %inline
+runPrettyColor : Eff Pretty a -> a
+runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
 
 
 export %inline
@@ -133,14 +115,11 @@ 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
+hangDSingle d1 d2 =
+  pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2))
 
 
 export
@@ -209,24 +188,11 @@ parameters {opts : LayoutOpts} {auto _ : Foldable t}
   separateTight : Doc opts -> t (Doc opts) -> Doc opts
   separateTight d = sep . exceptLast (<+> d) . toList
 
-  export
-  hseparateTight : Doc opts -> t (Doc opts) -> Doc opts
-  hseparateTight d = hsep . exceptLast (<+> d) . toList
-
-  export
-  vseparateTight : Doc opts -> t (Doc opts) -> Doc opts
-  vseparateTight d = vsep . exceptLast (<+> d) . toList
-
   export
   fillSeparateTight : Doc opts -> t (Doc opts) -> Doc opts
   fillSeparateTight d = fillSep . exceptLast (<+> d) . toList
 
 
-export %inline
-pshow : {opts : LayoutOpts} -> Show a => a -> Doc opts
-pshow = text . show
-
-
 export %inline
 ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a
 ifUnicode uni asc =
@@ -266,51 +232,46 @@ prettyDBind = hl DVar . prettyBind'
 
 
 export %inline
-typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
+typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
-stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD,
+eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
-zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD :
+ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD :
   {opts : LayoutOpts} -> Eff Pretty (Doc opts)
 typeD     = hl Syntax . text =<< ifUnicode "★" "Type"
-ioStateD  = hl Syntax $ text "IOState"
+arrowD    = hl Delim  . text =<< ifUnicode "→" "->"
-arrowD    = hl Syntax . text =<< ifUnicode "→" "->"
+darrowD   = hl Delim  . text =<< ifUnicode "⇒" "=>"
-darrowD   = hl Syntax . text =<< ifUnicode "⇒" "=>"
+timesD    = hl Delim  . text =<< ifUnicode "×" "**"
-timesD    = hl Syntax . text =<< ifUnicode "×" "**"
 lamD      = hl Syntax . text =<< ifUnicode "λ" "fun"
-eqndD     = hl Syntax . text =<< ifUnicode "≡" "=="
+eqndD     = hl Delim  . text =<< ifUnicode "≡" "=="
 dlamD     = hl Syntax . text =<< ifUnicode "δ" "dfun"
-annD      = hl Syntax . text =<< ifUnicode "∷" "::"
+annD      = hl Delim  . text =<< ifUnicode "∷" "::"
 natD      = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
-stringD   = hl Syntax   $ text "String"
 eqD       = hl Syntax $ text "Eq"
-colonD    = hl Syntax   $ text ":"
+colonD    = hl Delim  $ text ":"
-commaD    = hl Syntax   $ text ","
+commaD    = hl Delim  $ 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"
+zeroD     = hl Syntax $ text "zero"
-succD     = hl Constant $ text "succ"
+succD     = hl Syntax $ text "succ"
 coeD      = hl Syntax $ text "coe"
 compD     = hl Syntax $ text "comp"
 undD      = hl Syntax $ text "_"
 cstD      = hl Syntax $ text "="
-pipeD     = hl Delim    $ text "|"
+pipeD     = hl Syntax $ 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)
-    (hsep (f :: args))
+  <|> hsep [f, vsep args]
-    (f <++> vsep args <|> vsep (f :: map (indent ind) args))
+  <|> vsep (f :: map (indent ind) args)
 
 export
 prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
@@ -351,14 +312,4 @@ prettyLoc (L (YesLoc file b)) =
 
 export
 prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
-prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
+prettyTag tag = hl Tag $ text $ "'" ++ quoteTag tag
-
-export
-prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
-prettyStrLit s =
-  let s = concatMap esc1 $ unpack s in
-  hl Constant $ hcat ["\"", text s, "\""]
-where
-  esc1 : Char -> String
-  esc1 '"' = "\""; esc1 '\\' = "\\"
-  esc1 c   = singleton c

lib/Quox/PrettyValExtra.idr

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

lib/Quox/Scoped.idr

@@ -38,22 +38,3 @@ export %inline
 export %inline %hint
 ShowScoped : (forall n. Show (f n)) => Show (Scoped s f n)
 ShowScoped = deriveShow
-
-
-||| scope which ignores all its binders
-public export %inline
-SN : Located1 f => {s : Nat} -> f n -> Scoped s f n
-SN body = S (replicate s $ BN Unused body.loc) $ N body
-
-||| scope which uses its binders
-public export %inline
-SY : BContext s -> f (s + n) -> Scoped s f n
-SY ns = S ns . Y
-
-public export %inline
-name : Scoped 1 f n -> BindName
-name (S [< x] _) = x
-
-public export %inline
-(.name) : Scoped 1 f n -> BindName
-s.name = name s

lib/Quox/Syntax.idr

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

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

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

lib/Quox/Syntax/DimEq.idr

@@ -59,15 +59,10 @@ Traversable (IfConsistent eqs) where
   traverse f Nothing  = pure Nothing
   traverse f (Just x) = Just <$> f x
 
-public export
-ifConsistentElse : Applicative f => (eqs : DimEq d) ->
-                   f a -> f () -> f (IfConsistent eqs a)
-ifConsistentElse ZeroIsOne yes no = Nothing <$  no
-ifConsistentElse (C _)     yes no = Just    <$> yes
-
 public export
 ifConsistent : Applicative f => (eqs : DimEq d) -> f a -> f (IfConsistent eqs a)
-ifConsistent eqs act = ifConsistentElse eqs act (pure ())
+ifConsistent ZeroIsOne act = pure Nothing
+ifConsistent (C _)     act = Just <$> act
 
 public export
 toMaybe : IfConsistent eqs a -> Maybe a
@@ -76,13 +71,13 @@ toMaybe (Just x) = Just x
 
 
 export
-fromGround' : BContext d -> Context' DimConst d -> DimEq' d
+fromGround' : Context' DimConst d -> DimEq' d
-fromGround' [<]       [<]        = [<]
+fromGround' [<]        = [<]
-fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
+fromGround' (ctx :< e) = fromGround' ctx :< Just (K e noLoc)
 
 export
-fromGround : BContext d -> Context' DimConst d -> DimEq d
+fromGround : Context' DimConst d -> DimEq d
-fromGround = C .: fromGround'
+fromGround = C . fromGround'
 
 
 public export %inline
@@ -123,7 +118,7 @@ equal ZeroIsOne p q = True
 equal (C eqs)   p q = get eqs p == get eqs q
 
 
-export infixl 7 :<?
+infixl 7 :<?
 export %inline
 (:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
 ZeroIsOne :<? d = ZeroIsOne
@@ -242,20 +237,9 @@ setSelf (B i _)    (C eqs) with (compareP i i) | (compare i.nat i.nat)
   _ | IsGT gt | GT = absurd gt
 
 
-private %inline
-dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec
-dimEqPrec vars eqs =
-  if length vars <= 1 && maybe True null eqs then Arg else Outer
-
 private
-prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
+prettyDVars : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
-prettyDVars' = traverse prettyDBind . toSnocList'
+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)
@@ -272,16 +256,16 @@ prettyCsts dnames (eqs :< Just q)  =
 
 export
 prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
-prettyDimEq' vars eqs = do
+prettyDimEq' dnames eqs = do
-  vars' <- prettyDVars' vars
+  vars <- prettyDVars dnames
-  eqs'  <- prettyCsts vars eqs
+  eqs  <- prettyCsts dnames eqs
-  parensIfM (dimEqPrec vars (Just eqs)) $
+  let prec = if length vars <= 1 && null eqs then Arg else Outer
-    fillSeparateTight !commaD $ vars' ++ eqs'
+  parensIfM prec $ fillSeparateTight !commaD $ toList vars ++ toList eqs
 
 export
 prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
 prettyDimEq dnames ZeroIsOne = do
-  vars <- prettyDVars' dnames
+  vars <- prettyDVars dnames
   cst  <- prettyCst [<] (K Zero noLoc) (K One noLoc)
   pure $ separateTight !commaD $ vars :< cst
 prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs

lib/Quox/Syntax/Qty.idr

@@ -6,7 +6,6 @@ module Quox.Syntax.Qty
 
 import Quox.Pretty
 import Quox.Decidable
-import Quox.PrettyValExtra
 import Data.DPair
 import Derive.Prelude
 
@@ -21,7 +20,7 @@ import Derive.Prelude
 ||| - ω (or #): don't care. an ω variable *can* also be used 0/1 time
 public export
 data Qty = Zero | One | Any
-%runElab derive "Qty" [Eq, Ord, Show, PrettyVal]
+%runElab derive "Qty" [Eq, Ord, Show]
 %name Qty.Qty pi, rh
 
 
@@ -80,7 +79,7 @@ lub p q = if p == q then p else Any
 ||| 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]
+%runElab derive "SQty" [Eq, Ord, Show]
 %name Qty.SQty sg
 
 ||| "σ ⨴ π"
@@ -97,7 +96,7 @@ subjMult sg _    = sg
 ||| at runtime at all or not
 public export
 data GQty = GZero | GAny
-%runElab derive "GQty" [Eq, Ord, Show, PrettyVal]
+%runElab derive "GQty" [Eq, Ord, Show]
 %name GQty rh
 
 public export

lib/Quox/Syntax/Shift.idr

@@ -227,7 +227,7 @@ compViaNatCorrect by (SS bz) =
 %transform "Shift.(.)" Shift.(.) = compViaNat
 
 
-export infixl 8 //
+infixl 8 //
 public export
 interface CanShift f where
   (//) : f from -> Shift from to -> f to

lib/Quox/Syntax/Subst.idr

@@ -20,7 +20,7 @@ data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
   (:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
 %name Subst th, ph, ps
 
-export infixr 7 !:::
+infixr 7 !:::
 ||| in case the automatic laziness insertion gets confused
 public export
 (!:::) : env to -> Subst env from to -> Subst env (S from) to
@@ -42,7 +42,7 @@ export Ord  (f to) => Ord  (Subst f from to) where compare = compare `on` repr
 export Show (f to) => Show (Subst f from to) where show = show . repr
 
 
-export infixl 8 //
+infixl 8 //
 public export
 interface FromVar term => CanSubstSelf term where
   (//) : term from -> Lazy (Subst term from to) -> term to
@@ -96,18 +96,18 @@ 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 : CanSubstSelf f => Subst f from to -> Subst f (S from) (S to)
-push loc th = fromVarLoc VZ loc ::: (th . shift 1)
+push th = fromVar VZ ::: (th . shift 1)
 
 -- [fixme] a better way to do this?
 public export
-pushN : CanSubstSelf f => (s : Nat) -> Loc ->
+pushN : CanSubstSelf f => (s : Nat) ->
         Subst f from to -> Subst f (s + from) (s + to)
-pushN 0     _   th = th
+pushN 0     th = th
-pushN (S s) loc th =
+pushN (S s) th =
   rewrite plusSuccRightSucc s from in
   rewrite plusSuccRightSucc s to in
-  pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
+  pushN s $ fromVar VZ ::: (th . shift 1)
 
 public export
 drop1 : Subst f (S from) to -> Subst f from to

lib/Quox/Syntax/Term.idr

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

lib/Quox/Syntax/Term/Base.idr

@@ -47,6 +47,8 @@ TagVal : Type
 TagVal = String
 
 
+infixl 8 :#
+infixl 9 :@, :%
 mutual
   public export
   TSubst : TSubstLike
@@ -59,10 +61,6 @@ mutual
     ||| type of types
     TYPE : (l : Universe) -> (loc : Loc) -> Term d n
 
-    ||| IO state token. this is a builtin because otherwise #[main] being a
-    ||| builtin makes no sense
-    IOState : (loc : Loc) -> Term d n
-
     ||| function type
     Pi  : (qty : Qty) -> (arg : Term d n) ->
           (res : ScopeTerm d n) -> (loc : Loc) -> Term d n
@@ -85,21 +83,15 @@ mutual
     DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
 
     ||| natural numbers (temporary until 𝐖 gets added)
-    NAT : (loc : Loc) -> Term d n
+    Nat  : (loc : Loc) -> Term d n
-    Nat : (val : Nat) -> (loc : Loc) -> Term d n
+    -- [todo] can these be elims?
+    Zero : (loc : Loc) -> Term d n
     Succ : (p : Term d n) -> (loc : Loc) -> Term d n
 
-    ||| strings
-    STRING : (loc : Loc) -> Term d n
-    Str    : (str : String) -> (loc : Loc) -> Term d n
-
     ||| "box" (package a value up with a certain quantity)
     BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
     Box : (val : Term d n) -> (loc : Loc) -> Term d n
 
-    Let : (qty : Qty) -> (rhs : Elim d n) ->
-          (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
-
     ||| elimination
     E : (e : Elim d n) -> Term d n
 
@@ -234,123 +226,23 @@ mutual
   ShowElim : Show (Elim d n)
   ShowElim = assert_total {a = Show (Elim d n)} deriveShow
 
+||| scope which ignores all its binders
+public export %inline
+SN : {s : Nat} -> f n -> Scoped s f n
+SN = S (replicate s $ BN Unused noLoc) . N
 
-export
+||| scope which uses its binders
-Located (Elim d n) where
+public export %inline
-  (F _ _ loc).loc               = loc
+SY : BContext s -> f (s + n) -> Scoped s f n
-  (B _ loc).loc                 = loc
+SY ns = S ns . Y
-  (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
+public export %inline
-Located (Term d n) where
+name : Scoped 1 f n -> BindName
-  (TYPE _ loc).loc      = loc
+name (S [< x] _) = x
-  (IOState loc).loc     = loc
-  (Pi _ _ _ loc).loc    = loc
-  (Lam _ loc).loc       = loc
-  (Sig _ _ loc).loc     = loc
-  (Pair _ _ loc).loc    = loc
-  (Enum _ loc).loc      = loc
-  (Tag _ loc).loc       = loc
-  (Eq _ _ _ loc).loc    = loc
-  (DLam _ loc).loc      = loc
-  (NAT loc).loc         = loc
-  (Nat _ loc).loc       = loc
-  (STRING loc).loc      = loc
-  (Str _ loc).loc       = loc
-  (Succ _ loc).loc      = loc
-  (BOX _ _ loc).loc     = loc
-  (Box _ loc).loc       = loc
-  (Let _ _ _ loc).loc   = loc
-  (E e).loc             = e.loc
-  (CloT (Sub t _)).loc  = t.loc
-  (DCloT (Sub t _)).loc = t.loc
-
-export
-Located1 f => Located (ScopedBody s f n) where
-  (Y t).loc = t.loc
-  (N t).loc = t.loc
-
-export
-Located1 f => Located (Scoped s f n) where
-  t.loc = t.body.loc
-
-
-export
-Relocatable (Elim d n) where
-  setLoc loc (F x u _) = F x u loc
-  setLoc loc (B i _) = B i loc
-  setLoc loc (App fun arg _) = App fun arg loc
-  setLoc loc (CasePair qty pair ret body _) =
-    CasePair qty pair ret body loc
-  setLoc loc (Fst pair _) = Fst pair loc
-  setLoc loc (Snd pair _) = Fst pair loc
-  setLoc loc (CaseEnum qty tag ret arms _) =
-    CaseEnum qty tag ret arms loc
-  setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
-    CaseNat qty qtyIH nat ret zero succ loc
-  setLoc loc (CaseBox qty box ret body _) =
-    CaseBox qty box ret body loc
-  setLoc loc (DApp fun arg _) =
-    DApp fun arg loc
-  setLoc loc (Ann tm ty _) =
-    Ann tm ty loc
-  setLoc loc (Coe ty p q val _) =
-    Coe ty p q val loc
-  setLoc loc (Comp ty p q val r zero one _) =
-    Comp ty p q val r zero one loc
-  setLoc loc (TypeCase ty ret arms def _) =
-    TypeCase ty ret arms def loc
-  setLoc loc (CloE (Sub term subst)) =
-    CloE $ Sub (setLoc loc term) subst
-  setLoc loc (DCloE (Sub term subst)) =
-    DCloE $ Sub (setLoc loc term) subst
-
-export
-Relocatable (Term d n) where
-  setLoc loc (TYPE l _) = TYPE l loc
-  setLoc loc (IOState _) = IOState loc
-  setLoc loc (Pi qty arg res _) = Pi qty arg res loc
-  setLoc loc (Lam body _) = Lam body loc
-  setLoc loc (Sig fst snd _) = Sig fst snd loc
-  setLoc loc (Pair fst snd _) = Pair fst snd loc
-  setLoc loc (Enum cases _) = Enum cases loc
-  setLoc loc (Tag tag _) = Tag tag loc
-  setLoc loc (Eq ty l r _) = Eq ty l r loc
-  setLoc loc (DLam body _) = DLam body loc
-  setLoc loc (NAT _) = NAT loc
-  setLoc loc (Nat n _) = Nat n loc
-  setLoc loc (Succ p _) = Succ p loc
-  setLoc loc (STRING _) = STRING loc
-  setLoc loc (Str s _) = Str s loc
-  setLoc loc (BOX qty ty _) = BOX qty ty loc
-  setLoc loc (Box val _) = Box val loc
-  setLoc loc (Let qty rhs body _) = Let qty rhs body loc
-  setLoc loc (E e) = E $ setLoc loc e
-  setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
-  setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
-
-export
-Relocatable1 f => Relocatable (ScopedBody s f n) where
-  setLoc loc (Y body) = Y $ setLoc loc body
-  setLoc loc (N body) = N $ setLoc loc body
-
-export
-Relocatable1 f => Relocatable (Scoped s f n) where
-  setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
 
+public export %inline
+(.name) : Scoped 1 f n -> BindName
+s.name = name s
 
 ||| more convenient Pi
 public export %inline
@@ -398,12 +290,6 @@ public export %inline
 DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
 DLamN {body, loc} = DLam {body = SN body, loc}
 
-||| more convenient Coe
-public export %inline
-CoeY : (i : BindName) -> (ty : Term (S d) n) ->
-       (p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
-CoeY {i, ty, p, q, val, loc} = Coe {ty = SY [< i] ty, p, q, val, loc}
-
 ||| non dependent equality type
 public export %inline
 Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
@@ -430,9 +316,10 @@ 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
+public export
-Zero : Loc -> Term d n
+makeNat : Nat -> Loc -> Term d n
-Zero = Nat 0
+makeNat 0 loc = Zero loc
+makeNat (S k) loc = Succ (makeNat k loc) loc
 
 public export %inline
 enum : List TagVal -> Loc -> Term d n
@@ -447,6 +334,115 @@ public export %inline
 typeCase1Y : Elim d n -> Term d n ->
              (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
              (loc : Loc) ->
-             {default (NAT loc) def : Term d n} ->
+             {default (Nat loc) def : Term d n} ->
              Elim d n
 typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc
+
+
+export
+Located (Elim d n) where
+  (F _ _ loc).loc               = loc
+  (B _ loc).loc                 = loc
+  (App _ _ loc).loc             = loc
+  (CasePair _ _ _ _ loc).loc    = loc
+  (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
+  (Pi _ _ _ loc).loc    = loc
+  (Lam _ loc).loc       = loc
+  (Sig _ _ loc).loc     = loc
+  (Pair _ _ loc).loc    = loc
+  (Enum _ loc).loc      = loc
+  (Tag _ loc).loc       = loc
+  (Eq _ _ _ loc).loc    = loc
+  (DLam _ loc).loc      = loc
+  (Nat loc).loc         = loc
+  (Zero loc).loc        = loc
+  (Succ _ loc).loc      = loc
+  (BOX _ _ loc).loc     = loc
+  (Box _ loc).loc       = loc
+  (E e).loc             = e.loc
+  (CloT (Sub t _)).loc  = t.loc
+  (DCloT (Sub t _)).loc = t.loc
+
+export
+Located1 f => Located (ScopedBody s f n) where
+  (Y t).loc = t.loc
+  (N t).loc = t.loc
+
+export
+Located1 f => Located (Scoped s f n) where
+  t.loc = t.body.loc
+
+
+export
+Relocatable (Elim d n) where
+  setLoc loc (F x u _) = F x u loc
+  setLoc loc (B i _) = B i loc
+  setLoc loc (App fun arg _) = App fun arg loc
+  setLoc loc (CasePair qty pair ret body _) =
+    CasePair qty pair ret body loc
+  setLoc loc (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 (Pi qty arg res _) = Pi qty arg res loc
+  setLoc loc (Lam body _) = Lam body loc
+  setLoc loc (Sig fst snd _) = Sig fst snd loc
+  setLoc loc (Pair fst snd _) = Pair fst snd loc
+  setLoc loc (Enum cases _) = Enum cases loc
+  setLoc loc (Tag tag _) = Tag tag loc
+  setLoc loc (Eq ty l r _) = Eq ty l r loc
+  setLoc loc (DLam body _) = DLam body loc
+  setLoc loc (Nat _) = Nat loc
+  setLoc loc (Zero _) = Zero loc
+  setLoc loc (Succ p _) = Succ p loc
+  setLoc loc (BOX qty ty _) = BOX qty ty loc
+  setLoc loc (Box val _) = Box val loc
+  setLoc loc (E e) = E $ setLoc loc e
+  setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
+  setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
+
+export
+Relocatable1 f => Relocatable (ScopedBody s f n) where
+  setLoc loc (Y body) = Y $ setLoc loc body
+  setLoc loc (N body) = N $ setLoc loc body
+
+export
+Relocatable1 f => Relocatable (Scoped s f n) where
+  setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)

lib/Quox/Syntax/Term/Pretty.idr

@@ -30,6 +30,14 @@ BTelescope : Nat -> Nat -> Type
 BTelescope = Telescope' BindName
 
 
+private
+subscript : String -> String
+subscript = pack . map sub . unpack where
+  sub : Char -> Char
+  sub c = case c of
+    '0' => '₀'; '1' => '₁'; '2' => '₂'; '3' => '₃'; '4' => '₄'
+    '5' => '₅'; '6' => '₆'; '7' => '₇'; '8' => '₈'; '9' => '₉'; _ => c
+
 private
 superscript : String -> String
 superscript = pack . map sup . unpack where
@@ -201,7 +209,8 @@ prettyTArg dnames tnames s =
 
 private
 prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
-prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
+prettyDArg dnames p =
+  map (text "@" <+>) $ withPrec Arg $ prettyDim dnames p
 
 private
 splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
@@ -229,6 +238,7 @@ prettyDTApps dnames tnames f xs = do
 private
 record CaseArm opts d n where
   constructor MkCaseArm
+  {0 dinner, ninner : Nat}
   pat    : Doc opts
   dbinds : BTelescope d dinner -- 🍴
   tbinds : BTelescope n ninner
@@ -241,11 +251,12 @@ parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
     body <- withPrec Outer $ assert_total
             prettyTerm (dnames . dbinds) (tnames . tbinds) body
     header <- (pat <++>) <$> darrowD
-    pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
+    pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
 
   private
-  prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts))
+  prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (Doc opts)
-  prettyCaseBody xs = traverse prettyCaseArm xs
+  prettyCaseBody xs =
+    braces . separateTight !semiD =<< traverse prettyCaseArm xs
 
 private
 prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts)
@@ -277,7 +288,7 @@ prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
 prettyEnum cases =
   tightBraces =<<
   fillSeparateTight !commaD <$>
-  traverse (hl Constant . Doc.text . quoteTag) cases
+  traverse (hl Tag . Doc.text . quoteTag) cases
 
 private
 prettyCaseRet : {opts : _} ->
@@ -288,7 +299,7 @@ prettyCaseRet dnames tnames body = withPrec Outer $ case body of
   S [< x] (Y tm) => do
     header <- [|prettyTBind x <++> darrowD|]
     body   <- assert_total prettyTerm dnames (tnames :< x) tm
-    hangDSingle header body
+    pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
 
 private
 prettyCase_ : {opts : _} ->
@@ -296,16 +307,10 @@ prettyCase_ : {opts : _} ->
               Doc opts -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) ->
               Eff Pretty (Doc opts)
 prettyCase_ dnames tnames intro head ret body = do
-  head   <- withPrec Outer $ assert_total prettyElim dnames tnames head
+  head <- assert_total prettyElim dnames tnames head
   ret  <- prettyCaseRet dnames tnames ret
-  bodys  <- prettyCaseBody dnames tnames body
+  body <- prettyCaseBody dnames tnames body
-  return <- returnD; of_ <- ofD
+  parensIfM Outer $ sep [intro <++> head, !returnD <++> ret, !ofD <++> body]
-  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 : _} ->
@@ -316,62 +321,6 @@ prettyCase dnames tnames qty head ret body =
   prettyCase_ dnames tnames ![|caseD <+> prettyQty qty|] head ret body
 
 
-private
-LetBinder : Nat -> Nat -> Type
-LetBinder d n = (Qty, BindName, Elim d n)
-
-private
-LetExpr : Nat -> Nat -> Nat -> Type
-LetExpr d n n' = (Telescope (LetBinder d) n n', Term d n')
-
--- [todo] factor out this and the untyped version somehow
-export
-splitLet : Telescope (LetBinder d) n n' -> Term d n' -> Exists (LetExpr d n)
-splitLet ys t@(Let qty rhs body _) =
-  splitLet (ys :< (qty, body.name, rhs)) (assert_smaller t body.term)
-splitLet ys t =
-  Evidence _ (ys, t)
-
-private covering
-prettyLets : {opts : LayoutOpts} ->
-             BContext d -> BContext a -> Telescope (LetBinder d) a b ->
-             Eff Pretty (SnocList (Doc opts))
-prettyLets dnames xs lets = snd <$> go lets where
-  peelAnn : forall d, n. Elim d n -> Maybe (Term d n, Term d n)
-  peelAnn (Ann tm ty _) = Just (tm, ty)
-  peelAnn e             = Nothing
-
-  letHeader : Qty -> BindName -> Eff Pretty (Doc opts)
-  letHeader qty x = do
-    lett <- [|letD <+> prettyQty qty|]
-    x    <- prettyTBind x
-    pure $ lett <++> x
-
-  letBody : forall n. BContext n ->
-            Doc opts -> Elim d n -> Eff Pretty (Doc opts)
-  letBody tnames hdr e = case peelAnn e of
-    Just (tm, ty) => do
-      ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty
-      tm <- withPrec Outer $ assert_total prettyTerm dnames tnames tm
-      colon <- colonD; eq <- cstD; d <- askAt INDENT
-      pure $ hangSingle d (hangSingle d hdr (colon <++> ty)) (eq <++> tm)
-    Nothing => do
-      e <- withPrec Outer $ assert_total prettyElim dnames tnames e
-      eq <- cstD; d <- askAt INDENT
-      inn <- inD
-      pure $ ifMultiline
-        (hsep [hdr, eq, e, inn])
-        (vsep [hdr, indent d $ hsep [eq, e, inn]])
-
-  go : forall b. Telescope (LetBinder d) a b ->
-       Eff Pretty (BContext b, SnocList (Doc opts))
-  go [<] = pure (xs, [<])
-  go (lets :< (qty, x, rhs)) = do
-    (ys, docs) <- go lets
-    doc        <- letBody ys !(letHeader qty x) rhs
-    pure (ys :< x, docs :< doc)
-
-
 private
 isDefaultDir : Dim d -> Dim d -> Bool
 isDefaultDir (K Zero _) (K One _) = True
@@ -389,7 +338,6 @@ prettyTyCasePat : {opts : _} ->
                   (k : TyConKind) -> BContext (arity k) ->
                   Eff Pretty (Doc opts)
 prettyTyCasePat KTYPE [<] = typeD
-prettyTyCasePat KIOState [<] = ioStateD
 prettyTyCasePat KPi [< a, b] =
   parens . hsep =<< sequence [prettyTBind a, arrowD, prettyTBind b]
 prettyTyCasePat KSig [< a, b] =
@@ -398,7 +346,6 @@ prettyTyCasePat KEnum [<] = hl Syntax $ text "{}"
 prettyTyCasePat KEq [< a0, a1, a, l, r] =
   hsep <$> sequence (eqD :: map prettyTBind [a0, a1, a, l, r])
 prettyTyCasePat KNat [<] = natD
-prettyTyCasePat KString [<] = stringD
 prettyTyCasePat KBOX [< a] = bracks =<< prettyTBind a
 
 
@@ -432,13 +379,13 @@ prettyDisp u = map Just $ hl Universe =<<
   ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
 
 
-prettyTerm dnames tnames (TYPE l _) = do
+prettyTerm dnames tnames (TYPE l _) =
-  type  <- hl Syntax . text =<< ifUnicode "★" "Type"
+  case !(askAt FLAVOR) of
-  level <- prettyDisp l
+    Unicode => do
-  pure $ maybe type (type <+>) level
+      star  <- hl Syntax "★"
-
+      level <- hl Universe $ text $ superscript $ show l
-prettyTerm dnames tnames (IOState _) =
+      pure $ hcat [star, level]
-  ioStateD
+    Ascii   => [|hl Syntax "Type" <++> hl Universe (text $ show l)|]
 
 prettyTerm dnames tnames (Pi qty arg res _) =
   parensIfM Outer =<< do
@@ -483,7 +430,7 @@ prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) =
     pure $ sep [l <++> !eqndD, r <++> !colonD, ty]
 
 prettyTerm dnames tnames (Eq ty l r _) =
-  parensIfM App =<< do
+  parensIfM Arg =<< do
     ty <- prettyTypeLine dnames tnames ty
     l  <- withPrec Arg $ prettyTerm dnames tnames l
     r  <- withPrec Arg $ prettyTerm dnames tnames r
@@ -492,14 +439,20 @@ prettyTerm dnames tnames (Eq ty l r _) =
 prettyTerm dnames tnames s@(DLam {}) =
   prettyLambda dnames tnames s
 
-prettyTerm dnames tnames (NAT _) = natD
+prettyTerm dnames tnames (Nat _) = natD
-prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n
+prettyTerm dnames tnames (Zero _) = hl Syntax "0"
-prettyTerm dnames tnames (Succ p _) =
+prettyTerm dnames tnames (Succ p _) = do
-  parensIfM App =<<
+  succD <- succD
-  prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)]
+  let succ : Doc opts -> Eff Pretty (Doc opts)
-
+      succ t = prettyAppD succD [t]
-prettyTerm dnames tnames (STRING _) = stringD
+      toNat : Term d n -> Eff Pretty (Either (Doc opts) Nat)
-prettyTerm dnames tnames (Str s _) = prettyStrLit s
+      toNat s with (pushSubsts' s)
+        _ | Zero _   = pure $ Right 0
+        _ | Succ d _ = bitraverse succ (pure . S) =<<
+                       toNat (assert_smaller s d)
+        _ | s'       = map Left . withPrec Arg $
+                       prettyTerm dnames tnames $ assert_smaller s s'
+  either succ (hl Syntax . text . show . S) =<< toNat p
 
 prettyTerm dnames tnames (BOX qty ty _) =
   bracks . hcat =<<
@@ -509,18 +462,7 @@ prettyTerm dnames tnames (BOX qty ty _) =
 prettyTerm dnames tnames (Box val _) =
   bracks =<< withPrec Outer (prettyTerm dnames tnames val)
 
-prettyTerm dnames tnames (Let qty rhs body _) = do
+prettyTerm dnames tnames (E e) = prettyElim dnames tnames e
-  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
@@ -583,12 +525,9 @@ prettyElim dnames tnames e@(DApp {}) =
   prettyDTApps dnames tnames f xs
 
 prettyElim dnames tnames (Ann tm ty _) =
-  case the (Term d n) (pushSubsts' tm) of
+  parensIfM Outer =<<
-    E e => assert_total prettyElim dnames tnames e
+    hangDSingle !(withPrec AnnL  [|prettyTerm dnames tnames tm <++> annD|])
-    _   => do
+                !(withPrec Outer (prettyTerm dnames tnames ty))
-      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
@@ -600,7 +539,7 @@ prettyElim dnames tnames (Coe ty p q val _) =
 
 prettyElim dnames tnames e@(Comp ty p q val r zero one _) =
   parensIfM App =<< do
-    ty   <- assert_total $ prettyTypeLine dnames tnames $ SN ty
+    ty   <- prettyTypeLine dnames tnames $ assert_smaller e $ SN ty
     pq   <- sep <$> sequence [prettyDArg dnames p, prettyDArg dnames q]
     val  <- prettyTArg dnames tnames val
     r    <- prettyDArg dnames r

lib/Quox/Syntax/Term/Subst.idr

@@ -56,12 +56,12 @@ namespace DSubst.DScopeTermN
   (//) : {s : Nat} ->
          DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
          DScopeTermN s d2 n
-  S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
+  S ns (Y body) // th = S ns $ Y $ body // pushN s 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
+export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
 
 
 ||| does the minimal reasonable work:
@@ -104,7 +104,7 @@ namespace ScopeTermN
   (//) : {s : Nat} ->
          ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
          ScopeTermN s d n2
-  S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
+  S ns (Y body) // th = S ns $ Y $ body // pushN s th
   S ns (N body) // th = S ns $ N $ body // th
 
 namespace DScopeTermN
@@ -134,15 +134,6 @@ 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
@@ -152,15 +143,6 @@ 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
@@ -207,11 +189,11 @@ dsub1 t p = dsubN t [< p]
 
 
 public export %inline
-(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
+(.zero) : DScopeTerm d n -> {default noLoc 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
+(.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
 body.one = dsub1 body $ K One loc
 
 
@@ -267,8 +249,46 @@ mutual
   isCloE (DCloE {}) = True
   isCloE _          = False
 
-export
+mutual
-PushSubsts Elim Subst.isCloE where
+  export
+  PushSubsts Term Subst.isCloT where
+    pushSubstsWith th ph (TYPE l loc) =
+      nclo $ TYPE l loc
+    pushSubstsWith th ph (Pi qty a body loc) =
+      nclo $ Pi qty (a // th // ph) (body // th // ph) loc
+    pushSubstsWith th ph (Lam body loc) =
+      nclo $ Lam (body // th // ph) loc
+    pushSubstsWith th ph (Sig a b loc) =
+      nclo $ Sig (a // th // ph) (b // th // ph) loc
+    pushSubstsWith th ph (Pair s t loc) =
+      nclo $ Pair (s // th // ph) (t // th // ph) loc
+    pushSubstsWith th ph (Enum tags loc) =
+      nclo $ Enum tags loc
+    pushSubstsWith th ph (Tag tag loc) =
+      nclo $ Tag tag loc
+    pushSubstsWith th ph (Eq ty l r loc) =
+      nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
+    pushSubstsWith th ph (DLam body loc) =
+      nclo $ DLam (body // th // ph) loc
+    pushSubstsWith _ _ (Nat loc) =
+      nclo $ Nat loc
+    pushSubstsWith _ _ (Zero loc) =
+      nclo $ Zero loc
+    pushSubstsWith th ph (Succ n loc) =
+      nclo $ Succ (n // th // ph) loc
+    pushSubstsWith th ph (BOX pi ty loc) =
+      nclo $ BOX pi (ty // th // ph) loc
+    pushSubstsWith th ph (Box val loc) =
+      nclo $ Box (val // th // ph) loc
+    pushSubstsWith th ph (E e) =
+      let Element e nc = pushSubstsWith th ph e in nclo $ E e
+    pushSubstsWith th ph (CloT (Sub s ps)) =
+      pushSubstsWith th (comp th ps ph) s
+    pushSubstsWith th ph (DCloT (Sub s ps)) =
+      pushSubstsWith (ps . th) ph s
+
+  export
+  PushSubsts Elim Subst.isCloE where
     pushSubstsWith th ph (F x u loc) =
       nclo $ F x u loc
     pushSubstsWith th ph (B i loc) =
@@ -309,76 +329,3 @@ PushSubsts Elim Subst.isCloE where
       pushSubstsWith th (comp th ps ph) e
     pushSubstsWith th ph (DCloE (Sub e ps)) =
       pushSubstsWith (ps . th) ph e
-
-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
-
-
-||| heterogeneous comp, in terms of Comp and Coe
-public export %inline
-CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-         (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
-CompH' {ty, p, q, val, r, zero, one, loc} =
-  let ty' = SY ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
-  Comp {
-    ty = dsub1 ty q, p, q,
-    val = E $ Coe ty p q val val.loc, r,
-    zero = SY zero.names $ E $
-      Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
-    one = SY one.names $ E $
-      Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
-    loc
-  }
-
-||| heterogeneous comp, in terms of Comp and Coe
-public export %inline
-CompH : (i : BindName) -> (ty : Term (S d) n) ->
-        (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
-        (j0 : BindName) -> (zero : Term (S d) n) ->
-        (j1 : BindName) -> (one : Term (S d) n) ->
-        (loc : Loc) -> Elim d n
-CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
-  CompH' {ty = SY [< i] ty, p, q, val, r,
-          zero = SY [< j0] zero, one = SY [< j1] one, loc}

lib/Quox/Syntax/Term/Tighten.idr

@@ -0,0 +1,361 @@
+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 (Pi qty arg res loc) =
+    Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc
+  tightenT' p (Lam body loc) =
+    Lam <$> tightenS p body <*> pure loc
+  tightenT' p (Sig fst snd loc) =
+    Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc
+  tightenT' p (Pair fst snd loc) =
+    Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc
+  tightenT' p (Enum cases loc) =
+    pure $ Enum cases loc
+  tightenT' p (Tag tag loc) =
+    pure $ Tag tag loc
+  tightenT' p (Eq ty l r loc) =
+    Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc
+  tightenT' p (DLam body loc) =
+    DLam <$> tightenDS p body <*> pure loc
+  tightenT' p (Nat loc) =
+    pure $ Nat loc
+  tightenT' p (Zero loc) =
+    pure $ Zero loc
+  tightenT' p (Succ s loc) =
+    Succ <$> tightenT p s <*> pure loc
+  tightenT' p (BOX qty ty loc) =
+    BOX qty <$> tightenT p ty <*> pure loc
+  tightenT' p (Box val loc) =
+    Box <$> tightenT p val <*> pure loc
+  tightenT' p (E e) =
+    assert_total $ E <$> tightenE p e
+
+  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 (Pi qty arg res loc) =
+    Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc
+  dtightenT' p (Lam body loc) =
+    Lam <$> dtightenS p body <*> pure loc
+  dtightenT' p (Sig fst snd loc) =
+    Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc
+  dtightenT' p (Pair fst snd loc) =
+    Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc
+  dtightenT' p (Enum cases loc) =
+    pure $ Enum cases loc
+  dtightenT' p (Tag tag loc) =
+    pure $ Tag tag loc
+  dtightenT' p (Eq ty l r loc) =
+    Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc
+  dtightenT' p (DLam body loc) =
+    DLam <$> dtightenDS p body <*> pure loc
+  dtightenT' p (Nat loc) =
+    pure $ Nat loc
+  dtightenT' p (Zero loc) =
+    pure $ Zero loc
+  dtightenT' p (Succ s loc) =
+    Succ <$> dtightenT p s <*> pure loc
+  dtightenT' p (BOX qty ty loc) =
+    BOX qty <$> dtightenT p ty <*> pure loc
+  dtightenT' p (Box val loc) =
+    Box <$> dtightenT p val <*> pure loc
+  dtightenT' p (E e) =
+    assert_total $ E <$> dtightenE p e
+
+  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}

lib/Quox/Syntax/Term/TyConKind.idr

@@ -9,8 +9,7 @@ import Generics.Derive
 
 
 public export
-data TyConKind =
+data TyConKind = KTYPE | KPi | KSig | KEnum | KEq | KNat | KBOX
-  KTYPE | KIOState | KPi | KSig | KEnum | KEq | KNat | KString | KBOX
 %name TyConKind k
 %runElab derive "TyConKind" [Eq.Eq, Ord.Ord, Show.Show, Generic, Meta, DecEq]
 
@@ -27,11 +26,9 @@ allKinds = %runElab do
 public export %inline
 arity : TyConKind -> Nat
 arity KTYPE = 0
-arity KIOState = 0
 arity KPi   = 2
 arity KSig  = 2
 arity KEnum = 0
 arity KEq   = 5
 arity KNat  = 0
-arity KString  = 0
 arity KBOX  = 1

lib/Quox/Typechecker.idr

@@ -3,7 +3,6 @@ module Quox.Typechecker
 import public Quox.Typing
 import public Quox.Equal
 import Quox.Displace
-import Quox.Pretty
 
 import Data.List
 import Data.SnocVect
@@ -15,7 +14,7 @@ import Quox.EffExtra
 
 public export
 0 TC : List (Type -> Type)
-TC = [ErrorEff, DefsReader, NameGen, Log]
+TC = [ErrorEff, DefsReader, NameGen]
 
 
 parameters (loc : Loc)
@@ -42,24 +41,34 @@ lubs ctx []        = zeroFor ctx
 lubs ctx (x :: xs) = lubs1 $ x ::: xs
 
 
-private
+export
-prettyTermTC : {opts : LayoutOpts} ->
+typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe ->
-               TyContext d n -> Term d n -> Eff Pretty (Doc opts)
+              CtxExtension d n (arity k + n)
-prettyTermTC ctx s = prettyTerm ctx.dnames ctx.tnames s
+typecaseTel k xs u = case k of
+  KTYPE => [<]
+  -- A : ★ᵤ, B : 0.A → ★ᵤ
+  KPi =>
+    let [< a, b] = xs in
+    [< (Zero, a, TYPE u a.loc),
+       (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
+  KSig =>
+    let [< a, b] = xs in
+    [< (Zero, a, TYPE u a.loc),
+       (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
+  KEnum => [<]
+  -- A₀ : ★ᵤ, A₁ : ★ᵤ, A : (A₀ ≡ A₁ : ★ᵤ), L : A₀, R : A₀
+  KEq =>
+    let [< a0, a1, a, l, r] = xs in
+    [< (Zero, a0, TYPE u a0.loc),
+       (Zero, a1, TYPE u a1.loc),
+       (Zero, a,  Eq0 (TYPE u a.loc) (BVT 1 a.loc) (BVT 0 a.loc) a.loc),
+       (Zero, l,  BVT 2 l.loc),
+       (Zero, r,  BVT 2 r.loc)]
+  KNat => [<]
+  -- A : ★ᵤ
+  KBOX => let [< a] = xs in [< (Zero, a, TYPE u a.loc)]
 
 
-private
-checkLogs : String -> TyContext d n -> SQty ->
-            Term d n -> Maybe (Term d n) -> Eff TC ()
-checkLogs fun ctx sg subj ty = do
-  let tyDoc = delay $ maybe (text "none") (runPretty . prettyTermTC ctx) ty
-  sayMany "check" subj.loc
-    [10 :> text fun,
-     95 :> hsep ["ctx =",  runPretty $ prettyTyContext ctx],
-     95 :> hsep ["sg =",   runPretty $ prettyQty sg.qty],
-     10 :> hsep ["subj =", runPretty $ prettyTermTC ctx subj],
-     10 :> hsep ["ty =",   tyDoc]]
-
 mutual
   ||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ"
   |||
@@ -72,11 +81,7 @@ mutual
   export covering %inline
   check : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
           Eff TC (CheckResult ctx.dctx n)
-  check ctx sg subj ty =
+  check ctx sg subj ty = ifConsistent ctx.dctx $ checkC ctx sg subj ty
-    ifConsistentElse ctx.dctx
-      (do checkLogs "check" ctx sg subj (Just ty)
-          checkC ctx sg subj ty)
-      (say "check" 20 subj.loc "check: 0=1")
 
   ||| "Ψ | Γ ⊢₀ s ⇐ A"
   |||
@@ -107,12 +112,7 @@ mutual
   ||| universe doesn't matter, only that a term is _a_ type, so it is optional.
   export covering %inline
   checkType : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
-  checkType ctx subj l = do
+  checkType ctx subj l = ignore $ ifConsistent ctx.dctx $ checkTypeC ctx subj l
-    let univ = TYPE <$> l <*> pure noLoc
-    ignore $ ifConsistentElse ctx.dctx
-      (do checkLogs "checkType" ctx SZero subj univ
-          checkTypeC ctx subj l)
-      (say "check" 20 subj.loc "checkType: 0=1")
 
   export covering %inline
   checkTypeC : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
@@ -135,11 +135,7 @@ mutual
   export covering %inline
   infer : (ctx : TyContext d n) -> SQty -> Elim d n ->
           Eff TC (InferResult ctx.dctx d n)
-  infer ctx sg subj = do
+  infer ctx sg subj = ifConsistent ctx.dctx $ inferC ctx sg subj
-    ifConsistentElse ctx.dctx
-      (do checkLogs "infer" ctx sg (E subj) Nothing
-          inferC ctx sg subj)
-      (say "check" 20 subj.loc "infer: 0=1")
 
   ||| `infer`, assuming the dimension context is consistent
   export covering %inline
@@ -168,8 +164,6 @@ mutual
 
   check' ctx sg t@(TYPE {}) ty = toCheckType ctx sg t ty
 
-  check' ctx sg t@(IOState {}) ty = toCheckType ctx sg t ty
-
   check' ctx sg t@(Pi {}) ty = toCheckType ctx sg t ty
 
   check' ctx sg (Lam body loc) ty = do
@@ -220,39 +214,25 @@ mutual
     -- then Ψ | Γ ⊢ σ · (δ i ⇒ t) ⇐ Eq [i ⇒ A] l r ⊳ Σ
     pure qout
 
-  check' ctx sg t@(NAT {}) ty = toCheckType ctx sg t ty
+  check' ctx sg t@(Nat {}) ty = toCheckType ctx sg t ty
 
-  check' ctx sg (Nat {}) ty = do
+  check' ctx sg (Zero {}) ty = do
-    expectNAT !(askAt DEFS) ctx SZero ty.loc ty
+    expectNat !(askAt DEFS) ctx SZero ty.loc ty
     pure $ zeroFor ctx
 
   check' ctx sg (Succ n {}) ty = do
-    expectNAT !(askAt DEFS) ctx SZero ty.loc ty
+    expectNat !(askAt DEFS) ctx SZero ty.loc ty
     checkC ctx sg n ty
 
-  check' ctx sg t@(STRING {}) ty = toCheckType ctx sg t ty
-
-  check' ctx sg t@(Str s {}) ty = do
-    expectSTRING !(askAt DEFS) ctx SZero ty.loc ty
-    pure $ zeroFor ctx
-
   check' ctx sg t@(BOX {}) ty = toCheckType ctx sg t ty
 
   check' ctx sg (Box val loc) ty = do
     (q, ty) <- expectBOX !(askAt DEFS) ctx SZero ty.loc ty
-    -- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ
+    -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
-    valout <- checkC ctx (subjMult sg q) val ty
+    valout <- checkC ctx sg val ty
     -- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ
     pure $ q * valout
 
-  check' ctx sg (Let qty rhs body loc) ty = do
-    eres <- inferC ctx (subjMult sg qty) rhs
-    let sqty = sg.qty * qty
-    qout <- checkC (extendTyLet sqty body.name eres.type (E rhs) ctx)
-              sg body.term (weakT 1 ty)
-        >>= popQ loc sqty
-    pure $ qty * eres.qout + qout
-
   check' ctx sg (E e) ty = do
     -- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ
     infres <- inferC ctx sg e
@@ -272,9 +252,6 @@ mutual
       Just l  => unless (k < l) $ throw $ BadUniverse loc k l
       Nothing => pure ()
 
-  checkType' ctx (IOState loc) u = pure ()
-    -- Ψ | Γ ⊢₀ IOState ⇒ Type ℓ
-
   checkType' ctx (Pi qty arg res _) u = do
     -- if Ψ | Γ ⊢₀ A ⇐ Type ℓ
     checkTypeC ctx arg u
@@ -315,28 +292,19 @@ mutual
   checkType' ctx t@(DLam {}) u =
     throw $ NotType t.loc ctx t
 
-  checkType' ctx (NAT {}) u = pure ()
+  checkType' ctx (Nat {}) u = pure ()
-  checkType' ctx t@(Nat {}) u = throw $ NotType t.loc ctx t
+  checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t
   checkType' ctx t@(Succ {}) u = throw $ NotType t.loc ctx t
 
-  checkType' ctx (STRING loc) u = pure ()
-    -- Ψ | Γ ⊢₀ STRING ⇒ Type ℓ
-  checkType' ctx t@(Str {}) u = throw $ NotType t.loc ctx t
-
   checkType' ctx (BOX q ty _) u = checkType ctx ty u
   checkType' ctx t@(Box {}) u = throw $ NotType t.loc ctx t
 
-  checkType' ctx (Let qty rhs body loc) u = do
-    expectEqualQ loc qty Zero
-    ety <- inferC ctx SZero rhs
-    checkType (extendTy Zero body.name ety.type ctx) body.term u
-
   checkType' ctx (E e) u = do
     -- if Ψ | Γ ⊢₀ E ⇒ Type ℓ
     infres <- inferC ctx SZero e
     -- if Ψ | Γ ⊢ Type ℓ <: Type 𝓀
     case u of
-      Just u  => lift $ subtype e.loc ctx infres.type (TYPE u e.loc)
+      Just u  => lift $ subtype e.loc ctx infres.type (TYPE u noLoc)
       Nothing => ignore $ expectTYPE !(askAt DEFS) ctx SZero e.loc infres.type
     -- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀
 
@@ -360,10 +328,8 @@ mutual
     -- if σ ≤ π
     expectCompatQ loc sg.qty g.qty.qty
     -- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
-    pure $ InfRes {
+    let Val d = ctx.dimLen; Val n = ctx.termLen
-      type = g.typeWithAt ctx.dimLen ctx.termLen u,
+    pure $ InfRes {type = g.typeAt u, qout = zeroFor ctx}
-      qout = zeroFor ctx
-    }
 
   infer' ctx sg (B i _) =
     -- if x : A ∈ Γ
@@ -371,8 +337,8 @@ mutual
     pure $ lookupBound sg.qty i ctx.tctx
   where
     lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n
-    lookupBound pi VZ (ctx :< var) =
+    lookupBound pi VZ (ctx :< type) =
-      InfRes {type = weakT 1 var.type, qout = zeroFor ctx :< pi}
+      InfRes {type = weakT 1 type, qout = zeroFor ctx :< pi}
     lookupBound pi (VS i) (ctx :< _) =
       let InfRes {type, qout} = lookupBound pi i ctx in
       InfRes {type = weakT 1 type, qout = qout :< Zero}
@@ -460,43 +426,39 @@ mutual
     -- if Ψ | Γ ⊢ σ · n ⇒ ℕ ⊳ Σn
     nres <- inferC ctx sg n
     let nat = nres.type
-    expectNAT !(askAt DEFS) ctx SZero n.loc nat
+    expectNat !(askAt DEFS) ctx SZero n.loc nat
     -- if Ψ | Γ, n : ℕ ⊢₀ A ⇐ Type
     checkTypeC (extendTy Zero ret.name nat ctx) ret.term Nothing
     -- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ ℕ/n] ⊳ Σz
     zerout <- checkC ctx sg zer $ sub1 ret $ Ann (Zero zer.loc) nat zer.loc
-    -- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ.p, ς.ih
+    -- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ₁.p, ρ₂.ih
-    -- with ς ≤ π'σ, (ρ + ς) ≤ πσ
+    -- with ρ₂ ≤ π'σ, (ρ₁ + ρ₂) ≤ πσ
     let [< p, ih] = suc.names
         pisg      = pi * sg.qty
-        sucCtx    = extendTyN [< (pisg, p, NAT p.loc), (pi', ih, ret.term)] ctx
+        sucCtx    = extendTyN [< (pisg, p, Nat p.loc), (pi', ih, ret.term)] ctx
         sucType   = substCaseSuccRet suc.names ret
     sucout :< qp :< qih <- checkC sucCtx sg suc.term sucType
     expectCompatQ loc qih (pi' * sg.qty)
     -- [fixme] better error here
     expectCompatQ loc (qp + qih) pisg
-    -- if ς = 0, then Σb = lubs(Σz, Σs), otherwise Σb = Σz + ωςΣs
+    -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σz + ωΣs
-    let bodyout = case qih of
-          Zero => lubs ctx [zerout, sucout]
-          _    => zerout + Any * sucout
-    -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σb
     pure $ InfRes {
       type = sub1 ret n,
-      qout = pi * nres.qout + bodyout
+      qout = pi * nres.qout + zerout + Any * sucout
     }
 
   infer' ctx sg (CaseBox pi box ret body loc) = do
     -- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁
     boxres <- inferC ctx sg box
-    (rh, ty) <- expectBOX !(askAt DEFS) ctx SZero box.loc boxres.type
+    (q, ty) <- expectBOX !(askAt DEFS) ctx SZero box.loc boxres.type
     -- if Ψ | Γ, x : [ρ.A] ⊢₀ R ⇐ Type
     checkTypeC (extendTy Zero ret.name boxres.type ctx) ret.term Nothing
-    -- if Ψ | Γ, x : A ⊢ σ · t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x
+    -- if Ψ | Γ, x : A ⊢ t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x
     --   with ς ≤ ρπσ
-    let rhpisg   = rh * pi * sg.qty
+    let qpisg    = q * pi * sg.qty
-        bodyCtx  = extendTy rhpisg body.name ty ctx
+        bodyCtx  = extendTy qpisg body.name ty ctx
         bodyType = substCaseBoxRet body.name ty ret
-    bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc rhpisg
+    bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc qpisg
     -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ R[b/x] ⊳ Σ₁ + Σ₂
     pure $ InfRes {
       type = sub1 ret box,
@@ -511,34 +473,23 @@ mutual
     pure $ InfRes {type = dsub1 ty dim, qout}
 
   infer' ctx sg (Coe ty p q val loc) = do
-    -- if Ψ, 𝑖 | Γ ⊢₀ A ⇐ Type _
     checkType (extendDim ty.name ctx) ty.term Nothing
-    -- if Ψ | Γ ⊢ σ · s ⇐ A‹p/𝑖› ⊳ Σ
     qout <- checkC ctx sg val $ dsub1 ty p
-    -- then Ψ | Γ ⊢ σ · coe (𝑖 ⇒ A) @p @q s ⇒ A‹q/𝑖› ⊳ Σ
     pure $ InfRes {type = dsub1 ty q, qout}
 
   infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1) loc) = do
-    -- if Ψ | Γ ⊢₀ A ⇐ Type _
     checkType ctx ty Nothing
-    -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
     qout <- checkC ctx sg val ty
-    -- if Ψ, 𝑗, 𝑖=0      | Γ ⊢ σ · t₀ ⇐ A ⊳ Σ₀
-    --    Ψ, 𝑗, 𝑖=0, 𝑗=p | Γ ⊢ t₀ = s ⇐ A
     let ty'  = dweakT 1 ty; val' = dweakT 1 val; p' = weakD 1 p
         ctx0 = extendDim j0 $ eqDim r (K Zero j0.loc) ctx
         val0 = getTerm val0
     qout0 <- check ctx0 sg val0 ty'
     lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) sg ty' val0 val'
-    -- if Ψ, 𝑗, 𝑖=1      | Γ ⊢ σ · t₁ ⇐ A ⊳ Σ₁
-    --    Ψ, 𝑗, 𝑖=1, 𝑗=p | Γ ⊢ t₁ = s ⇐ A
     let ctx1 = extendDim j1 $ eqDim r (K One j1.loc) ctx
         val1  = getTerm val1
     qout1 <- check ctx1 sg val1 ty'
-    -- if Σ = Σ₀ = Σ₁
     lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) sg ty' val1 val'
     let qouts  = qout :: catMaybes [toMaybe qout0, toMaybe qout1]
-    -- then Ψ | Γ ⊢ comp A @p @q s @r {0 𝑗 ⇒ t₀; 1 𝑗 ⇒ t₁} ⇒ A ⊳ Σ
     pure $ InfRes {type = ty, qout = lubs ctx qouts}
 
   infer' ctx sg (TypeCase ty ret arms def loc) = do

lib/Quox/Typing.idr

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

lib/Quox/Typing/Context.idr

@@ -14,41 +14,9 @@ public export
 QContext : Nat -> Type
 QContext = Context' Qty
 
-public export
-record LocalVar d n where
-  constructor MkLocal
-  type : Term d n
-  term : Maybe (Term d n) -- if from a `let`
-%runElab deriveIndexed "LocalVar" [Show]
-
-namespace LocalVar
-  export %inline
-  letVar : (type, term : Term d n) -> LocalVar d n
-  letVar type term = MkLocal {type, term = Just term}
-
-  export %inline
-  lamVar : (type : Term d n) -> LocalVar d n
-  lamVar type = MkLocal {type, term = Nothing}
-
-  export %inline
-  mapVar : (Term d n -> Term d' n') -> LocalVar d n -> LocalVar d' n'
-  mapVar f = {type $= f, term $= map f}
-
-  export %inline
-  subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n
-  subD th = mapVar (// th)
-
-  export %inline
-  weakD : LocalVar d n -> LocalVar (S d) n
-  weakD = subD $ shift 1
-
-export %inline CanShift  (LocalVar d) where l // by = mapVar (// by) l
-export %inline CanDSubst LocalVar     where l // by = mapVar (// by) l
-export %inline CanTSubst LocalVar     where l // by = mapVar (// by) l
-
 public export
 TContext : TermLike
-TContext d = Context (LocalVar d)
+TContext d = Context (Term d)
 
 public export
 QOutput : Nat -> Type
@@ -65,7 +33,7 @@ record TyContext d n where
   {auto dimLen  : Singleton d}
   {auto termLen : Singleton n}
   dctx   : DimEq d
-  dnames : BContext d -- only used for printing
+  dnames : BContext d
   tctx   : TContext d n
   tnames : BContext n -- only used for printing
   qtys   : QContext n -- only used for printing
@@ -90,8 +58,6 @@ record EqContext n where
 public export
 record WhnfContext d n where
   constructor MkWhnfContext
-  {auto dimLen  : Singleton d}
-  {auto termLen : Singleton n}
   dnames : BContext d
   tnames : BContext n
   tctx   : TContext d n
@@ -99,11 +65,15 @@ record WhnfContext d n where
 %runElab deriveIndexed "WhnfContext" [Show]
 
 namespace TContext
+  export %inline
+  pushD : TContext d n -> TContext (S d) n
+  pushD tel = map (// shift 1) tel
+
   export %inline
   zeroFor : Context tm n -> QOutput n
   zeroFor ctx = Zero <$ ctx
 
-public export
+private
 extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
 extendLen [<]        x = x
 extendLen (tel :< _) x = [|S $ extendLen tel x|]
@@ -117,54 +87,32 @@ public export
 CtxExtension0 : Nat -> Nat -> Nat -> Type
 CtxExtension0 d = Telescope ((BindName,) . Term d)
 
-public export
-CtxExtensionLet : Nat -> Nat -> Nat -> Type
-CtxExtensionLet d = Telescope ((Qty, BindName,) . LocalVar d)
-
-public export
-CtxExtensionLet0 : Nat -> Nat -> Nat -> Type
-CtxExtensionLet0 d = Telescope ((BindName,) . LocalVar d)
-
 namespace TyContext
   public export %inline
   empty : TyContext 0 0
-  empty = MkTyContext {
+  empty =
-    dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]
+    MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
-  }
 
   public export %inline
   null : TyContext d n -> Bool
   null ctx = null ctx.dnames && null ctx.tnames
 
   export %inline
-  extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2
+  extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
-  extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
+  extendTyN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
-    let (qs, xs, ls) = unzip3 xss in
+    let (qs, xs, ss) = unzip3 xss in
     MkTyContext {
       dctx, dnames,
       termLen = extendLen xss termLen,
-      tctx    = tctx . ls,
+      tctx    = tctx . ss,
       tnames  = tnames . xs,
       qtys    = qtys . qs
     }
 
-  export %inline
-  extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
-  extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
-
-  export %inline
-  extendTyLetN0 : CtxExtensionLet0 d n1 n2 -> TyContext d n1 -> TyContext d n2
-  extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
-
   export %inline
   extendTyN0 : CtxExtension0 d n1 n2 -> TyContext d n1 -> TyContext d n2
   extendTyN0 xss = extendTyN (map (Zero,) xss)
 
-  export %inline
-  extendTyLet : Qty -> BindName -> Term d n -> Term d n ->
-                TyContext d n -> TyContext d (S n)
-  extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
-
   export %inline
   extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
   extendTy q x s = extendTyN [< (q, x, s)]
@@ -180,7 +128,7 @@ namespace TyContext
       dctx   = dctx :<? Nothing,
       dnames = dnames :< x,
       dimLen = [|S dimLen|],
-      tctx   = map weakD tctx,
+      tctx   = pushD tctx,
       tnames, qtys
     }
 
@@ -219,7 +167,7 @@ makeEqContext' ctx th = MkEqContext {
   termLen = ctx.termLen,
   dassign = makeDAssign th,
   dnames  = ctx.dnames,
-  tctx    = map (subD th) ctx.tctx,
+  tctx    = map (// th) ctx.tctx,
   tnames  = ctx.tnames,
   qtys    = ctx.qtys
 }
@@ -241,34 +189,21 @@ namespace EqContext
   null ctx = null ctx.dnames && null ctx.tnames
 
   export %inline
-  extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2
+  extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
-  extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
+  extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
-    let (qs, xs, ls) = unzip3 xss in
+    let (qs, xs, ss) = unzip3 xss in
     MkEqContext {
       termLen = extendLen xss termLen,
-      tctx    = tctx . ls,
+      tctx    = tctx . ss,
       tnames  = tnames . xs,
       qtys    = qtys . qs,
       dassign, dnames
     }
 
-  export %inline
-  extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
-  extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
-
-  export %inline
-  extendTyLetN0 : CtxExtensionLet0 0 n1 n2 -> EqContext n1 -> EqContext n2
-  extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
-
   export %inline
   extendTyN0 : CtxExtension0 0 n1 n2 -> EqContext n1 -> EqContext n2
   extendTyN0 xss = extendTyN (map (Zero,) xss)
 
-  export %inline
-  extendTyLet : Qty -> BindName -> Term 0 n -> Term 0 n ->
-                EqContext n -> EqContext (S n)
-  extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
-
   export %inline
   extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
   extendTy q x s = extendTyN [< (q, x, s)]
@@ -287,8 +222,8 @@ namespace EqContext
   toTyContext : (e : EqContext n) -> TyContext e.dimLen n
   toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
     MkTyContext {
-      dctx = fromGround dnames dassign,
+      dctx = fromGround dassign,
-      tctx = map (subD $ shift0 dimLen) tctx,
+      tctx = map (// shift0 dimLen) tctx,
       dnames, tnames, qtys
     }
 
@@ -297,44 +232,18 @@ namespace EqContext
   toWhnfContext (MkEqContext {tnames, tctx, _}) =
     MkWhnfContext {dnames = [<], tnames, tctx}
 
-  export
-  injElim : WhnfContext d n -> Elim 0 0 -> Elim d n
-  injElim ctx e =
-    let Val d = ctx.dimLen; Val n = ctx.termLen in
-    e // shift0 d // shift0 n
-
 namespace WhnfContext
   public export %inline
   empty : WhnfContext 0 0
   empty = MkWhnfContext [<] [<] [<]
 
-  export
-  extendTy' : BindName -> LocalVar d n -> WhnfContext d n -> WhnfContext d (S n)
-  extendTy' x var (MkWhnfContext {termLen, dnames, tnames, tctx}) =
-    MkWhnfContext {
-      dnames,
-      termLen = [|S termLen|],
-      tnames  = tnames :< x,
-      tctx    = tctx   :< var
-    }
-
-  export %inline
-  extendTy : BindName -> Term d n -> WhnfContext d n -> WhnfContext d (S n)
-  extendTy x ty ctx = extendTy' x (lamVar ty) ctx
-
-  export %inline
-  extendTyLet : BindName -> (type, term : Term d n) ->
-                WhnfContext d n -> WhnfContext d (S n)
-  extendTyLet x type term ctx = extendTy' x (letVar {type, term}) ctx
-
   export
   extendDimN : {s : Nat} -> BContext s -> WhnfContext d n ->
                WhnfContext (s + d) n
-  extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) =
+  extendDimN ns (MkWhnfContext {dnames, tnames, tctx}) =
     MkWhnfContext {
-      dimLen = [|Val s + dimLen|],
       dnames = dnames ++ toSnocVect' ns,
-      tctx   = map (subD $ shift s) tctx,
+      tctx   = dweakT s <$> tctx,
       tnames
     }
 
@@ -346,25 +255,14 @@ namespace WhnfContext
 private
 prettyTContextElt : {opts : _} ->
                     BContext d -> BContext n ->
-                    Doc opts -> BindName -> LocalVar d n ->
+                    Qty -> BindName -> Term d n -> Eff Pretty (Doc opts)
-                    Eff Pretty (Doc opts)
+prettyTContextElt dnames tnames q x s =
-prettyTContextElt dnames tnames q x s = do
+  pure $ hsep [hcat [!(prettyQty q), !dotD, !(prettyTBind x)], !colonD,
-  dot <- dotD
+               !(withPrec Outer $ prettyTerm dnames tnames s)]
-  x  <- prettyTBind x; colon <- colonD
-  ty <- withPrec Outer $ prettyTerm dnames tnames s.type; eq <- cstD
-  tm <- traverse (withPrec Outer . prettyTerm dnames tnames) s.term
-  d  <- askAt INDENT
-  let qx = hcat [q, dot, x]
-  pure $ case tm of
-    Nothing =>
-      ifMultiline (hsep [qx, colon, ty]) (vsep [qx, indent d $ colon <++> ty])
-    Just tm =>
-      ifMultiline (hsep [qx, colon, ty, eq, tm])
-                  (vsep [qx, indent d $ colon <++> ty, indent d $ eq <++> tm])
 
 private
 prettyTContext' : {opts : _} ->
-                  BContext d -> Context' (Doc opts) n -> BContext n ->
+                  BContext d -> QContext n -> BContext n ->
                   TContext d n -> Eff Pretty (SnocList (Doc opts))
 prettyTContext' _ [<] [<] [<] = pure [<]
 prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
@@ -375,11 +273,8 @@ export
 prettyTContext : {opts : _} ->
                  BContext d -> QContext n -> BContext n ->
                  TContext d n -> Eff Pretty (Doc opts)
-prettyTContext dnames qtys tnames tys = do
+prettyTContext dnames qtys tnames tys =
-  comma <- commaD
+  separateTight !commaD <$> prettyTContext' dnames qtys tnames tys
-  qtys <- traverse prettyQty qtys
-  sepSingle . exceptLast (<+> comma) . toList <$>
-    prettyTContext' dnames qtys tnames tys
 
 export
 prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
@@ -387,16 +282,9 @@ prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
   case dctx of
     C [<] => prettyTContext dnames qtys tnames tctx
     _     => pure $
-      sepSingle [!(prettyDimEq dnames dctx) <++> !pipeD,
+      sep [!(prettyDimEq dnames dctx) <++> !pipeD,
            !(prettyTContext dnames qtys tnames tctx)]
 
 export
 prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts)
 prettyEqContext ctx = prettyTyContext $ toTyContext ctx
-
-export
-prettyWhnfContext : {opts : _} -> WhnfContext d n -> Eff Pretty (Doc opts)
-prettyWhnfContext ctx =
-  let Val n = ctx.termLen in
-  sepSingle . exceptLast (<+> comma) . toList <$>
-    prettyTContext' ctx.dnames (replicate n "_") ctx.tnames ctx.tctx

lib/Quox/Typing/Error.idr

@@ -2,7 +2,6 @@ module Quox.Typing.Error
 
 import Quox.Loc
 import Quox.Syntax
-import Quox.Syntax.Builtin
 import Quox.Typing.Context
 import Quox.Typing.EqMode
 import Quox.Pretty
@@ -14,8 +13,6 @@ import Derive.Prelude
 %language ElabReflection
 %hide TT.Name
 
-%default total
-
 
 public export
 record NameContexts d n where
@@ -68,10 +65,8 @@ data Error
 | ExpectedSig  Loc (NameContexts d n) (Term d n)
 | ExpectedEnum Loc (NameContexts d n) (Term d n)
 | ExpectedEq   Loc (NameContexts d n) (Term d n)
-| ExpectedNAT     Loc (NameContexts d n) (Term d n)
+| ExpectedNat  Loc (NameContexts d n) (Term d n)
-| ExpectedSTRING  Loc (NameContexts d n) (Term d n)
 | ExpectedBOX  Loc (NameContexts d n) (Term d n)
-| ExpectedIOState Loc (NameContexts d n) (Term d n)
 | BadUniverse  Loc Universe Universe
 | TagNotIn     Loc TagVal (SortedSet TagVal)
 | BadCaseEnum  Loc (SortedSet TagVal) (SortedSet TagVal)
@@ -88,9 +83,6 @@ data Error
 | NotType Loc (TyContext d n) (Term d n)
 | WrongType Loc (EqContext n) (Term 0 n) (Term 0 n)
 
-| WrongBuiltinType Builtin Error
-| ExpectedSingleEnum Loc (NameContexts d n) (Term d n)
-
 | MissingEnumArm Loc TagVal (List TagVal)
 
 -- extra context
@@ -132,10 +124,8 @@ Located Error where
   (ExpectedSig     loc _ _).loc         = loc
   (ExpectedEnum    loc _ _).loc         = loc
   (ExpectedEq      loc _ _).loc         = loc
-  (ExpectedNAT      loc _ _).loc        = loc
+  (ExpectedNat     loc _ _).loc         = loc
-  (ExpectedSTRING   loc _ _).loc        = loc
   (ExpectedBOX     loc _ _).loc         = loc
-  (ExpectedIOState  loc _ _).loc        = loc
   (BadUniverse     loc _ _).loc         = loc
   (TagNotIn        loc _ _).loc         = loc
   (BadCaseEnum     loc _ _).loc         = loc
@@ -148,8 +138,6 @@ Located Error where
   (NotInScope      loc _).loc           = loc
   (NotType         loc _ _).loc         = loc
   (WrongType       loc _ _ _).loc       = loc
-  (WrongBuiltinType _ err).loc          = err.loc
-  (ExpectedSingleEnum loc _ _).loc      = loc
   (MissingEnumArm  loc _ _).loc         = loc
   (WhileChecking   _ _ _ _ err).loc     = err.loc
   (WhileCheckingTy _ _ _ err).loc       = err.loc
@@ -258,26 +246,10 @@ where
      hangDSingle "with quantities" $
       separateTight !commaD $ toSnocList' !(traverse prettyQty qs)]
 
-parameters {opts : LayoutOpts} (showContext : Bool)
+export
-  export
+prettyErrorNoLoc : {opts : _} -> (showContext : Bool) -> Error ->
-  inContext' : Bool -> a -> (a -> Eff Pretty (Doc opts)) ->
+                   Eff Pretty (Doc opts)
-               Doc opts -> Eff Pretty (Doc opts)
+prettyErrorNoLoc showContext = \case
-  inContext' null ctx f doc =
-    if showContext && not null then
-      vappend doc <$> hangDSingle "in context" !(f ctx)
-    else pure doc
-
-  export %inline
-  inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
-  inTContext ctx = inContext' (null ctx) ctx prettyTyContext
-
-  export %inline
-  inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
-  inEContext ctx = inContext' (null ctx) ctx prettyEqContext
-
-  export
-  prettyErrorNoLoc : Error -> Eff Pretty (Doc opts)
-  prettyErrorNoLoc err0 = case err0 of
   ExpectedTYPE _ ctx s =>
     hangDSingle "expected a type universe, but got"
       !(prettyTerm ctx.dnames ctx.tnames s)
@@ -295,29 +267,19 @@ parameters {opts : LayoutOpts} (showContext : Bool)
       !(prettyTerm ctx.dnames ctx.tnames s)
 
   ExpectedEq _ ctx s =>
-      hangDSingle "expected an equality type, but got"
+    hangDSingle "expected an enumeration type, but got"
       !(prettyTerm ctx.dnames ctx.tnames s)
 
-    ExpectedNAT _ ctx s =>
+  ExpectedNat _ ctx s =>
     hangDSingle
       ("expected the type" <++>
-          !(prettyTerm [<] [<] $ NAT noLoc) <+> ", but got")
+        !(prettyTerm [<] [<] $ Nat noLoc) <+> ", but got")
-        !(prettyTerm ctx.dnames ctx.tnames s)
-
-    ExpectedSTRING _ ctx s =>
-      hangDSingle
-        ("expected the type" <++>
-          !(prettyTerm [<] [<] $ STRING noLoc) <+> ", but got")
       !(prettyTerm ctx.dnames ctx.tnames s)
 
   ExpectedBOX _ ctx s =>
     hangDSingle "expected a box type, but got"
       !(prettyTerm ctx.dnames ctx.tnames s)
 
-    ExpectedIOState _ ctx s =>
-      hangDSingle "expected IOState, but got"
-        !(prettyTerm ctx.dnames ctx.tnames s)
-
   BadUniverse _ k l => pure $
     sep ["the universe level" <++> !(prettyUniverse k),
          "is not strictly less than" <++> !(prettyUniverse l)]
@@ -376,16 +338,6 @@ parameters {opts : LayoutOpts} (showContext : Bool)
     [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s),
      hangDSingle "cannot have type" !(prettyTerm [<] ctx.tnames ty)]
 
-    WrongBuiltinType b err => pure $
-      vappend
-        (sep [sep ["when checking", text $ builtinDesc b],
-              sep ["has type", !(builtinTypeDoc b)]])
-        !(prettyErrorNoLoc err)
-
-    ExpectedSingleEnum _ ctx s =>
-      hangDSingle "expected an enumeration type with one case, but got"
-        !(prettyTerm ctx.dnames ctx.tnames s)
-
   MissingEnumArm _ tag tags => pure $
     sep [hsep ["the tag", !(prettyTag tag), "is not contained in"],
          !(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)]
@@ -396,14 +348,14 @@ parameters {opts : LayoutOpts} (showContext : Bool)
           [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
            hangDSingle "has type"       !(prettyTerm ctx.dnames ctx.tnames a),
            hangDSingle "with quantity"  !(prettyQty sg.qty)])
-          (prettyErrorNoLoc err)|]
+        (prettyErrorNoLoc showContext err)|]
 
   WhileCheckingTy ctx a k err =>
     [|vappendBlank
         (inTContext ctx . sep =<< sequence
           [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a),
            pure $ text $ isTypeInUniverse k])
-          (prettyErrorNoLoc err)|]
+        (prettyErrorNoLoc showContext err)|]
 
   WhileInferring ctx sg e err =>
     [|vappendBlank
@@ -411,7 +363,7 @@ parameters {opts : LayoutOpts} (showContext : Bool)
           [hangDSingle "while inferring the type of"
               !(prettyElim ctx.dnames ctx.tnames e),
            hangDSingle "with quantity" !(prettyQty sg.qty)])
-          (prettyErrorNoLoc err)|]
+        (prettyErrorNoLoc showContext err)|]
 
   WhileComparingT ctx mode sg a s t err =>
     [|vappendBlank
@@ -421,7 +373,7 @@ parameters {opts : LayoutOpts} (showContext : Bool)
               !(prettyTerm [<] ctx.tnames t),
            hangDSingle "at type" !(prettyTerm [<] ctx.tnames a),
            hangDSingle "with quantity" !(prettyQty sg.qty)])
-          (prettyErrorNoLoc err)|]
+        (prettyErrorNoLoc showContext err)|]
 
   WhileComparingE ctx mode sg e f err =>
     [|vappendBlank
@@ -430,14 +382,26 @@ parameters {opts : LayoutOpts} (showContext : Bool)
            hangDSingle (text "is \{prettyMode mode}")
               !(prettyElim [<] ctx.tnames f),
            hangDSingle "with quantity" !(prettyQty sg.qty)])
-          (prettyErrorNoLoc err)|]
+        (prettyErrorNoLoc showContext err)|]
 
-  where
+where
   vappendBlank : Doc opts -> Doc opts -> Doc opts
   vappendBlank a b = flush a `vappend` b
 
-  export
+  inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
-  prettyError : Error -> Eff Pretty (Doc opts)
+  inTContext ctx doc =
-  prettyError err = hangDSingle
+    if showContext && not (null ctx) then
-    !(prettyLoc err.loc)
+      pure $ vappend doc (sep ["in context", !(prettyTyContext ctx)])
-    !(indentD =<< prettyErrorNoLoc err)
+    else pure doc
+
+  inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
+  inEContext ctx doc =
+    if showContext && not (null ctx) then
+      pure $ vappend doc (sep ["in context", !(prettyEqContext ctx)])
+    else pure doc
+
+export
+prettyError : {opts : _} -> (showContext : Bool) ->
+              Error -> Eff Pretty (Doc opts)
+prettyError showContext err = sep <$> sequence
+  [prettyLoc err.loc, indentD =<< prettyErrorNoLoc showContext err]

lib/Quox/Untyped/Erase.idr

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

lib/Quox/Untyped/Scheme.idr

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

lib/Quox/Untyped/Syntax.idr

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

lib/Quox/Var.idr

@@ -2,6 +2,7 @@ module Quox.Var
 
 import public Quox.Loc
 import public Quox.Name
+import Quox.OPE
 
 import Data.Nat
 import Data.List
@@ -140,6 +141,9 @@ weakIsSpec p i = toNatInj $ trans (weakCorrect p i) (sym $ weakSpecCorrect p i)
 public export
 interface FromVar f where %inline fromVarLoc : Var n -> Loc -> f n
 
+public export %inline
+fromVar : FromVar f => Var n -> {default noLoc loc : Loc} -> f n
+fromVar x = fromVarLoc x loc
 
 public export FromVar Var where fromVarLoc x _ = x
 
@@ -289,3 +293,12 @@ decEqFromBool i j =
 %transform "Var.decEq" varDecEq = decEqFromBool
 
 public export %inline DecEq (Var n) where decEq = varDecEq
+
+
+export
+Tighten Var where
+  tighten Id       i      = Just i
+  tighten (Drop p) VZ     = Nothing
+  tighten (Drop p) (VS i) = tighten p i
+  tighten (Keep p) VZ     = Just VZ
+  tighten (Keep p) (VS i) = VS <$> tighten p i

lib/Quox/Whnf/Coercion.idr

@@ -14,7 +14,7 @@ coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc ->
 coeScoped ty p q loc (S names (N body)) =
   S names $ N $ E $ Coe ty p q body loc
 coeScoped ty p q loc (S names (Y body)) =
-  SY names $ E $ Coe (weakDS s ty) p q body loc
+  ST names $ E $ Coe (weakDS s ty) p q body loc
 where
   weakDS : (by : Nat) -> DScopeTerm d n -> DScopeTerm d (by + n)
   weakDS by (S names (Y body)) = S names $ Y $ weakT by body
@@ -23,12 +23,12 @@ where
 
 parameters {auto _ : CanWhnf Term Interface.isRedexT}
            {auto _ : CanWhnf Elim Interface.isRedexE}
-           (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty)
+           {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty)
   ||| reduce a function application `App (Coe ty p q val) s loc`
   export covering
   piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
           (val, s : Term d n) -> Loc ->
-          Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+          Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg))
   piCoe sty@(S [< i] ty) p q val s loc = do
     -- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝
     -- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›)
@@ -38,18 +38,18 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
     let ctx1 = extendDim i ctx
     Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
     (arg, res) <- tycasePi defs ctx1 ty
-    let s0   = CoeY i arg q p s s.loc
+    let s0   = CoeT i arg q p s s.loc
         body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc
-        s1   = CoeY i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
+        s1   = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
                     (s // shift 1) s.loc
-    whnf defs ctx sg $ CoeY i (sub1 res s1) p q body loc
+    whnf defs ctx sg $ CoeT i (sub1 res s1) p q body loc
 
   ||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc`
   export covering
   sigCoe : (qty : Qty) ->
            (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
            (ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> Loc ->
-           Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+           Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg))
   sigCoe qty sty@(S [< i] ty) p q val ret body loc = do
     -- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e }
     --   ⇝
@@ -63,18 +63,18 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
     Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
     (tfst, tsnd) <- tycaseSig defs ctx1 ty
     let [< x, y] = body.names
-        a' = CoeY i (weakT 2 tfst) p q (BVT 1 x.loc) x.loc
+        a' = CoeT i (weakT 2 tfst) p q (BVT 1 noLoc) x.loc
         tsnd' = tsnd.term //
-          (CoeY i (weakT 2 $ tfst // (B VZ tsnd.loc ::: shift 2))
+          (CoeT i (weakT 2 $ tfst // (B VZ noLoc ::: shift 2))
-            (weakD 1 p) (B VZ i.loc) (BVT 1 tsnd.loc) y.loc ::: shift 2)
+            (weakD 1 p) (B VZ noLoc) (BVT 1 noLoc) y.loc ::: shift 2)
-        b' = CoeY i tsnd' p q (BVT 0 y.loc) y.loc
+        b' = CoeT i tsnd' p q (BVT 0 noLoc) y.loc
     whnf defs ctx sg $ CasePair qty (Ann val (ty // one p) val.loc) ret
-      (SY body.names $ body.term // (a' ::: b' ::: shift 2)) loc
+      (ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc
 
   ||| reduce a pair projection `Fst (Coe ty p q val) loc`
   export covering
   fstCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-           Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+           Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg))
   fstCoe sty@(S [< i] ty) p q val loc = do
     -- fst (coe (𝑖 ⇒ (x : A) × B) @p @q s)
     --   ⇝
@@ -85,13 +85,13 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
     Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
     (tfst, _) <- tycaseSig defs ctx1 ty
     whnf defs ctx sg $
-      Coe (SY [< i] tfst) p q
+      Coe (ST [< i] tfst) p q
           (E (Fst (Ann val (ty // one p) val.loc) val.loc)) loc
 
   ||| reduce a pair projection `Snd (Coe ty p q val) loc`
   export covering
   sndCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-           Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+           Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg))
   sndCoe sty@(S [< i] ty) p q val loc = do
     -- snd (coe (𝑖 ⇒ (x : A) × B) @p @q s)
     --   ⇝
@@ -103,8 +103,8 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
     Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
     (tfst, tsnd) <- tycaseSig defs ctx1 ty
     whnf defs ctx sg $
-      Coe (SY [< i] $ sub1 tsnd $
+      Coe (ST [< i] $ sub1 tsnd $
-            Coe (SY [< !(fresh i)] $ tfst // (BV 0 i.loc ::: shift 2))
+            Coe (ST [< !(fresh i)] $ tfst // (BV 0 i.loc ::: shift 2))
                 (weakD 1 p) (BV 0 loc)
                 (E (Fst (Ann (dweakT 1 val) ty val.loc) val.loc)) loc)
           p q
@@ -115,11 +115,11 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
   export covering
   eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
           (r : Dim d) -> Loc ->
-          Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+          Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg))
   eqCoe sty@(S [< j] ty) p q val r loc = do
     -- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r
     --   ⇝
-    -- comp [j ⇒ A‹r/i›] @p @q ((eq ∷ (Eq [i ⇒ A] L R)‹p/j›) @r)
+    -- comp [j ⇒ A‹r/i›] @p @q (eq ∷ (Eq [i ⇒ A] L R)‹p/j›)
     --   @r { 0 j ⇒ L; 1 j ⇒ R }
     let ctx1 = extendDim j ctx
     Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
@@ -133,7 +133,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
   boxCoe : (qty : Qty) ->
            (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
            (ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> Loc ->
-           Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg))
+           Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg))
   boxCoe qty sty@(S [< i] ty) p q val ret body loc = do
     -- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e }
     --   ⇝
@@ -141,48 +141,34 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
     let ctx1 = extendDim i ctx
     Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
     ta <- tycaseBOX defs ctx1 ty
-    let xloc = body.name.loc
+    let a' = CoeT i (weakT 1 ta) p q (BVT 0 noLoc) body.name.loc
-    let a' = CoeY i (weakT 1 ta) p q (BVT 0 xloc) xloc
     whnf defs ctx sg $ CaseBox qty (Ann val (ty // one p) val.loc) ret
-      (SY body.names $ body.term // (a' ::: shift 1)) loc
+      (ST body.names $ body.term // (a' ::: shift 1)) loc
 
 
--- new params block to call the above functions at different `n`
-parameters {auto _ : CanWhnf Term Interface.isRedexT}
-           {auto _ : CanWhnf Elim Interface.isRedexE}
-           (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty)
   ||| pushes a coercion inside a whnf-ed term
   export covering
   pushCoe : BindName ->
             (ty : Term (S d) n) -> (p, q : Dim d) -> (s : Term d n) -> Loc ->
             (0 pc : So (canPushCoe sg ty s)) =>
-            Eff Whnf (NonRedex Elim d n defs ctx sg)
+            Eff Whnf (NonRedex Elim d n defs sg)
   pushCoe i ty p q s loc =
     case ty of
       -- (coe ★ᵢ @_ @_ s) ⇝ (s ∷ ★ᵢ)
       TYPE l tyLoc =>
         whnf defs ctx sg $ Ann s (TYPE l tyLoc) loc
 
-      -- (coe IOState @_ @_ s) ⇝ (s ∷ IOState)
+      -- η expand it so that whnf for App can deal with it
-      IOState tyLoc =>
-        whnf defs ctx sg $ Ann s (IOState tyLoc) loc
-
-      -- η expand, then simplify the Coe/App in the body
       --
       -- (coe (𝑖 ⇒ π.(x : A) → B) @p @q s)
       --   ⇝
       -- (λ y ⇒ (coe (𝑖 ⇒ π.(x : A) → B) @p @q s) y) ∷ (π.(x : A) → B)‹q/𝑖›
-      --   ⇝     ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
+      Pi {} =>
-      -- (λ y ⇒ ⋯) ∷ (π.(x : A) → B)‹q/𝑖›   -- see `piCoe`
+        let inner = Coe (SY [< i] ty) p q s loc in
-      --
-      -- do the piCoe step here because otherwise equality checking keeps
-      -- doing the η forever
-      Pi {arg, res = S [< x] _, _} => do
-        let ctx' = extendTy x (arg // one p) ctx
-        body <- piCoe defs ctx' sg
-          (weakDS 1 $ SY [< i] ty) p q (weakT 1 s) (BVT 0 loc) loc
         whnf defs ctx sg $
-          Ann (LamY x (E body.fst) loc) (ty // one q) loc
+          Ann (LamY !(mnb "y" loc)
+                  (E $ App (weakE 1 inner) (BVT 0 loc) loc) loc)
+              (ty // one q) loc
 
       -- no η!!!
       -- push into a pair constructor, otherwise still stuck
@@ -195,12 +181,12 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
       --     ∷ ((x : A) × B)‹q/𝑖›
       Sig tfst tsnd tyLoc => do
         let Pair fst snd sLoc = s
-            fst' = CoeY i tfst p q fst fst.loc
+            fst' = CoeT i tfst p q fst fst.loc
             fstInSnd =
-              CoeY !(fresh i)
+              CoeT !(fresh i)
                    (tfst // (BV 0 loc ::: shift 2))
-                   (weakD 1 p) (BV 0 loc) (dweakT 1 fst) fst.loc
+                   (weakD 1 p) (BV 0 loc) (dweakT 1 s) fst.loc
-            snd' = CoeY i (sub1 tsnd fstInSnd) p q snd snd.loc
+            snd' = CoeT i (sub1 tsnd fstInSnd) p q snd snd.loc
         whnf defs ctx sg $
           Ann (Pair (E fst') (E snd') sLoc) (ty // one q) loc
 
@@ -208,45 +194,35 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
       Enum cases tyLoc =>
         whnf defs ctx sg $ Ann s (Enum cases tyLoc) loc
 
-      -- η expand/simplify, same as for Π
+      -- η expand, same as for Π
       --
       -- (coe (𝑖 ⇒ Eq (𝑗 ⇒ A) l r) @p @q s)
       --   ⇝
       -- (δ 𝑘 ⇒ (coe (𝑖 ⇒ Eq (𝑗 ⇒ A) l r) @p @q s) @𝑘) ∷ (Eq (𝑗 ⇒ A) l r)‹q/𝑖›
-      --   ⇝     ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
+      Eq {} =>
-      -- (δ 𝑘 ⇒ ⋯) ∷ (Eq (𝑗 ⇒ A) l r)‹q/𝑖›   -- see `eqCoe`
+        let inner = Coe (SY [< i] ty) p q s loc in
-      --
-      -- do the eqCoe step here because otherwise equality checking keeps
-      -- doing the η forever
-      Eq {ty = S [< j] _, _} => do
-        let ctx' = extendDim j ctx
-        body <- eqCoe defs ctx' sg
-          (dweakDS 1 $ S [< i] $ Y ty) (weakD 1 p) (weakD 1 q)
-          (dweakT 1 s) (BV 0 loc) loc
         whnf defs ctx sg $
-          Ann (DLamY i (E body.fst) loc) (ty // one q) loc
+          Ann (DLamY !(mnb "k" loc)
+                  (E $ DApp (dweakE 1 inner) (BV 0 loc) loc) loc)
+              (ty // one q) loc
 
       -- (coe ℕ @_ @_ s) ⇝ (s ∷ ℕ)
-      NAT tyLoc =>
+      Nat tyLoc =>
-        whnf defs ctx sg $ Ann s (NAT tyLoc) loc
+        whnf defs ctx sg $ Ann s (Nat tyLoc) loc
 
-      -- (coe String @_ @_ s) ⇝ (s ∷ String)
+      -- η expand
-      STRING tyLoc =>
-        whnf defs ctx sg $ Ann s (STRING tyLoc) loc
-
-      -- η expand/simplify
       --
-      -- (coe (𝑖 ⇒ [π.A]) @p @q s)
+      -- (coe (𝑖 ⇒ [π. A]) @p @q s)
       --   ⇝
-      -- [case coe (𝑖 ⇒ [π.A]) @p @q s return A‹q/𝑖› of {[x] ⇒ x}]
+      -- [case1 coe (𝑖 ⇒ [π. A]) @p @q s return A‹q/𝑖› of {[x] ⇒ x}]
-      --   ⇝
+      --   ∷ [π. A]‹q/𝑖›
-      -- [case1 s ∷ [π.A]‹p/𝑖› ⋯] ∷ [π.A]‹q/𝑖›   -- see `boxCoe`
+      BOX qty inner tyLoc =>
-      --
+        let inner = CaseBox {
-      -- do the eqCoe step here because otherwise equality checking keeps
+              qty  = One,
-      -- doing the η forever
+              box  = Coe (SY [< i] ty) p q s loc,
-      BOX qty inner tyLoc => do
+              ret  = SN $ ty // one q,
-        body <- boxCoe defs ctx sg qty
+              body = SY [< !(mnb "x" loc)] $ BVT 0 loc,
-          (SY [< i] ty) p q s
+              loc
-          (SN $ inner // one q)
+            }
-          (SY [< !(mnb "inner" loc)] (BVT 0 loc)) loc
+        in
-        whnf defs ctx sg $ Ann (Box (E body.fst) loc) (ty // one q) loc
+        whnf defs ctx sg $ Ann (Box (E inner) loc) (ty // one q) loc

lib/Quox/Whnf/ComputeElimType.idr

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