more peano, fixed bug in checking ascriptions of definitions

examples/peano.pg

@@ -151,7 +151,7 @@ def suc_or_zero : forall (n : nat), szc n :=
 -- 1) Q 0 z and
 -- 2) forall (x : nat) (y : A), Q x y -> Q (suc x) (fS x y),
 -- Q x y.
--- In more math lingo, we take R to be the intersection of every relation
+-- In more mathy lingo, we take R to be the intersection of every relation
 -- satisfying 1 and 2. From there we will, with much effort, prove that R is
 -- actually a function satisfying the equations we want it to.
 
@@ -383,213 +383,259 @@ def R2_functional (A : *) (z : A) (fS : nat -> A -> A) : fl nat A (rec_rel_alt A
             end)
     end;
 
+def R_functional (A : *) (z : A) (fS : nat -> A -> A) : fl nat A (rec_rel A z fS) :=
+    let (R   := rec_rel A z fS)
+        (sub := R_sub_R2 A z fS)
+    in
+        fun (n : nat) (y1 y2 : A) (h1 : R n y1) (h2 : R n y2) =>
+            R2_functional A z fS n y1 y2 (sub n y1 h1) (sub n y2 h2)
+    end;
+
 -- }}}
 
+-- {{{ Actually defining the function
+
 def rec_def (A : *) (z : A) (fS : nat -> A -> A) (x : nat) : A :=
     exists_elim A A (rec_rel A z fS x) (rec_rel_total A z fS x)
         (fun (y : A) (_ : rec_rel A z fS x y) => y);
 
 -- }}}
 
--- -- For any such equations, there exists a function.
+-- {{{ It satisfies the properties we want it to
--- rec_def (A : *) (fzero : A) (fsuc : nat -> A -> A) : nat -> A := axiom;
+
---
+-- Kind of stupidly, we still need one more axiom. Due to how existentials are
--- -- Here's equation one.
+-- defined, even though rec_def n is defined to be the y such that R n y, we
--- rec_cond_zero (A : *) (fzero : A) (fsuc : nat -> A -> A) (f : nat -> A) := 
+-- can't actually conclude that R n (rec_def n).
---   eq A (f zero) fzero;
+
---
+-- We need to assert that, even if you "forget" that a value came from an
--- -- And equation two.
+-- existential, it still satisfies the property it definitionally is supposed
--- rec_cond_suc (A : *) (fzero : A) (fsuc : nat -> A -> A) (f : nat -> A) :=
+-- to satisfy. This annoying problem would be subverted with proper Σ-types,
---   forall (n : nat) (y : A),
+-- provided they had η-equality.
---     eq A (f n) y -> eq A (f (suc n)) (fsuc n y);
+axiom definite_description (A : *) (P : A -> *) (h : exists A P) :
---
+    P (exists_elim A A P h (fun (x : A) (_ : P x) => x));
--- -- Said function satisfies the equations.
+
--- -- It satisfies equation one.
+-- Now we can use this axiom to prove that R n (rec_def n).
--- rec_def_sat_zero (A : *) (fzero : A) (fsuc : nat -> A -> A) :
+def rec_def_sat (A : *) (z : A) (fS : nat -> A -> A) (x : nat) : rec_rel A z fS x (rec_def A z fS x) :=
---   rec_cond_zero A fzero fsuc (rec_def A fzero fsuc) := axiom;
+    definite_description A (rec_rel A z fS x) (rec_rel_total A z fS x);
---
+
--- -- And two.
+def eq1 (A : *) (z : A) (f : nat -> A) := eq A (f zero) z;
--- rec_def_sat_suc (A : *) (fzero : A) (fsuc : nat -> A -> A) :
+
---   rec_cond_suc A fzero fsuc (rec_def A fzero fsuc) := axiom;
+def eq2 (A : *) (z : A) (fS : nat -> A -> A) (f : nat -> A) := forall (n : nat), eq A (f (suc n)) (fS n (f n));
---
+
--- -- And, finally, this function is unique in the sense that if any other function
+-- f zero = z
--- -- also satisfies the equations, it takes the same values as rec_def.
+def rec_def_sat_zero (A : *) (z : A) (fS : nat -> A -> A) : eq1 A z (rec_def A z fS) :=
--- rec_def_unique (A : *) (fzero : A) (fsuc : nat -> A -> A) (f g : nat -> A) :
+    let (f := rec_def A z fS) in
---   rec_cond_zero A fzero fsuc f ->
+        R_functional A z fS zero (f zero) z
---   rec_cond_suc  A fzero fsuc f ->
+        (rec_def_sat A z fS zero)
---   rec_cond_zero A fzero fsuc g ->
+        (rec_rel_cond1 A z fS)
---   rec_cond_suc  A fzero fsuc g ->
+    end;
---   forall (x : nat), eq A (f x) (g x) := axiom;
+
---
+-- f n = y -> f (suc n) = fS n y
--- -- Now we can safely define addition.
+def rec_def_sat_suc (A : *) (z : A) (fS : nat -> A -> A) : eq2 A z fS (rec_def A z fS) :=
---
+    fun (n : nat) =>
--- -- First, here's the RHS of equation 2 as a function, since it will show up
+        let (R     := rec_rel A z fS)
--- -- multiple times.
+            (f     := rec_def A z fS)
--- psuc (_ r : nat) := suc r;
+            (y     := f n)
---
+            (Rf    := rec_def_sat A z fS)
--- -- And here's plus!
+            (RSnfy := rec_rel_cond2 A z fS n y (Rf n))
--- plus (n : nat) : nat -> nat := rec_def nat n psuc;
+        in
---
+            R_functional A z fS (suc n) (f (suc n)) (fS n y) (Rf (suc n)) RSnfy 
--- -- The first equation manifests itself as the familiar
+        end;
--- --      n + 0 = 0.
+
--- plus_0_r (n : nat) : eq nat (plus n zero) n :=
+-- }}}
---   rec_def_sat_zero nat n psuc;
+
---
+-- {{{ The function satisfying these equations is unique
--- -- The second equation, after a bit of massaging, manifests itself as the
+
--- -- likewise familiar
+def rec_def_unique (A : *) (z : A) (fS : nat -> A -> A) (f g : nat -> A)
--- --      n + suc m = suc (n + m).
+    (h1f : eq1 A z f) (h2f : eq2 A z fS f) (h1g : eq1 A z g) (h2g : eq2 A z fS g)
--- plus_s_r (n m : nat) : eq nat (plus n (suc m)) (suc (plus n m)) :=
+    : forall (n : nat), eq A (f n) (g n) :=
---   rec_def_sat_suc nat n psuc m (plus n m) (eq_refl nat (plus n m));
+        nat_ind (fun (n : nat) => eq A (f n) (g n))
---
+        -- base case: f 0 = g 0
+        (eq_trans A (f zero) z (g zero) h1f (eq_sym A (g zero) z h1g))
+
+        -- Inductive step
+        (fun (n : nat) (IH : eq A (f n) (g n)) =>
+            -- f (suc n) = fS n (f n)
+            --           = fS n (g n)
+            --           = g (suc n)
+            eq_trans A (f (suc n)) (fS n (f n)) (g (suc n))
+            -- f (suc n) = fS n (f n)
+            (h2f n)
+            -- fS n (f n) = g (suc n)
+            (eq_trans A (fS n (f n)) (fS n (g n)) (g (suc n))
+                -- fS n (f n) = fS n (g n)
+                (eq_cong A A (f n) (g n) (fS n) IH)
+                -- fS n (g n) = g (suc n)
+                (eq_sym A (g (suc n)) (fS n (g n)) (h2g n))));
+
+-- }}}
+
+-- }}}
+
+-- Now we can safely define addition.
+
+-- First, here's the RHS of equation 2 as a function, since it will show up
+-- multiple times.
+def psuc (_ r : nat) := suc r;
+
+-- And here's plus!
+def plus (n : nat) : nat -> nat := rec_def nat n psuc;
+
+-- The first equation manifests itself as the familiar
+--      n + 0 = 0.
+def plus_0_r (n : nat) : eq nat (plus n zero) n :=
+  rec_def_sat_zero nat n psuc;
+
+-- The second equation, after a bit of massaging, manifests itself as the
+-- likewise familiar
+--      n + suc m = suc (n + m).
+def plus_s_r (n m : nat) : eq nat (plus n (suc m)) (suc (plus n m)) :=
+  rec_def_sat_suc nat n psuc m;
+
 -- -- We can now prove 1 + 1 = 2!
--- one_plus_one_two : eq nat (plus one one) two :=
+def one_plus_one_two : eq nat (plus one one) two :=
---   -- 1 + (suc zero) = suc (1 + zero) = suc one
+  -- 1 + (suc zero) = suc (1 + zero) = suc one
---   eq_trans nat (plus one one) (suc (plus one zero)) two
+  eq_trans nat (plus one one) (suc (plus one zero)) two
+
+  -- 1 + (suc zero) = suc (1 + zero)
+  (plus_s_r one zero)
+
+  -- suc (1 + zero) = suc one
+  (eq_cong nat nat (plus one zero) one suc (plus_0_r one));
+
+-- We have successfully defined addition! Note that evaluating 1 + 1 to 2
+-- requires a proof, unfortunately, since this computation isn't visible to
+-- perga.
 --
---   -- 1 + (suc zero) = suc (1 + zero)
+-- We will now prove a couple standard properties of addition.
---   (plus_s_r one zero)
+
---
+-- First, associativity, namely that n + (m + p) = (n + m) + p.
---   -- suc (1 + zero) = suc one
+def plus_assoc : assoc nat plus := fun (n m : nat) =>
---   (eq_cong nat nat (plus one zero) one suc (plus_0_r one));
+  -- We prove this via induction on p for any fixed n and m.
---
+  nat_ind
--- -- 
+    (fun (p : nat) => eq nat (plus n (plus m p)) (plus (plus n m) p))
--- -- We have successfully defined addition! Note that evaluating 1 + 1 to 2
+
--- -- requires a proof, unfortunately, since this computation isn't visible to
+    -- Base case: p = 0
--- -- perga.
+    -- WTS n + (m + 0) = (n + m) + 0
--- -- 
+    -- n + (m + 0) = n + m = (n + m) + 0
--- -- We will now prove a couple standard properties of addition.
+    (eq_trans nat (plus n (plus m zero)) (plus n m) (plus (plus n m) zero)
--- -- 
+      -- n + (m + 0) = n + m
---
+      (eq_cong nat nat (plus m zero) m (fun (p : nat) => plus n p) (plus_0_r m))
--- -- First, associativity, namely that n + (m + p) = (n + m) + p.
+
--- plus_assoc : assoc nat plus := 
+      -- n + m = (n + m) + 0
---   -- We prove this via induction on p.
+      (eq_sym nat (plus (plus n m) zero) (plus n m) (plus_0_r (plus n m))))
---   nat_ind
+
---     (fun (p : nat) =>
+    -- Inductive step: IH = n + (m + p) = (n + m) + p
---       forall (n m : nat),
+    (fun (p : nat) (IH : eq nat (plus n (plus m p)) (plus (plus n m) p)) =>
---         eq nat (plus n (plus m p)) (plus (plus n m) p))
+      -- WTS n + (m + suc p) = (n + m) + suc p
---
+      -- n + (m + suc p) = n + suc (m + p)
---     -- Base case: p = 0
+      --                 = suc (n + (m + p))
---     -- WTS n + (m + 0) = (n + m) + 0
+      --                 = suc ((n + m) + p)
---     (fun (n m : nat) =>
+      --                 = (n + m) + suc p
---       -- n + (m + 0) = n + m = (n + m) + 0
+      eq_trans nat (plus n (plus m (suc p))) (plus n (suc (plus m p))) (plus (plus n m) (suc p))
---       (eq_trans nat (plus n (plus m zero)) (plus n m) (plus (plus n m) zero)
+
---         -- n + (m + 0) = n + m
+      -- n + (m + suc p) = n + suc (m + p)
---         (eq_cong nat nat (plus m zero) m (fun (p : nat) => plus n p) (plus_0_r m))
+      (eq_cong nat nat (plus m (suc p)) (suc (plus m p)) (fun (a : nat) => (plus n a)) (plus_s_r m p))
---
+
---         -- n + m = (n + m) + 0
+      -- n + suc (m + p) = (n + m) + suc p
---         (eq_sym nat (plus (plus n m) zero) (plus n m) (plus_0_r (plus n m)))))
+      (eq_trans nat (plus n (suc (plus m p))) (suc (plus n (plus m p))) (plus (plus n m) (suc p))
---
+        -- n + suc (m + p) = suc (n + (m + p))
---     -- Inductive step: IH = n + (m + p) = (n + m) + p
+        (plus_s_r n (plus m p))
---     (fun (p : nat) (IH : forall (n m : nat), eq nat (plus n (plus m p)) (plus (plus n m) p)) (n m : nat) =>
+
---       -- WTS n + (m + suc p) = (n + m) + suc p
+        -- suc (n + (m + p)) = (n + m) + suc p
---       -- n + (m + suc p) = n + suc (m + p)
+        (eq_trans nat (suc (plus n (plus m p))) (suc (plus (plus n m) p)) (plus (plus n m) (suc p))
---       --                 = suc (n + (m + p))
+          -- suc (n + (m + p)) = suc ((n + m) + p)
---       --                 = suc ((n + m) + p)
+          (eq_cong nat nat (plus n (plus m p)) (plus (plus n m) p) suc IH)
---       --                 = (n + m) + suc p
+
---       eq_trans nat (plus n (plus m (suc p))) (plus n (suc (plus m p))) (plus (plus n m) (suc p))
+          -- suc ((n + m) + p) = (n + m) + suc p
---
+          (eq_sym nat (plus (plus n m) (suc p)) (suc (plus (plus n m) p))
---       -- n + (m + suc p) = n + suc (m + p)
+            (plus_s_r (plus n m) p)))));
---       (eq_cong nat nat (plus m (suc p)) (suc (plus m p)) (fun (a : nat) => (plus n a)) (plus_s_r m p))
+
---
+-- Up next is commutativity, but we will need a couple lemmas first.
---       -- n + suc (m + p) = (n + m) + suc p
+
---       (eq_trans nat (plus n (suc (plus m p))) (suc (plus n (plus m p))) (plus (plus n m) (suc p))
+-- First, we will show that 0 + n = n.
---         -- n + suc (m + p) = suc (n + (m + p))
+def plus_0_l : forall (n : nat), eq nat (plus zero n) n :=
---         (plus_s_r n (plus m p))
+  -- We prove this by induction on n.
---
+  nat_ind (fun (n : nat) => eq nat (plus zero n) n)
---         -- suc (n + (m + p)) = (n + m) + suc p
+    -- base case: WTS 0 + 0 = 0
---         (eq_trans nat (suc (plus n (plus m p))) (suc (plus (plus n m) p)) (plus (plus n m) (suc p))
+    -- This is just plus_0_r 0
---           -- suc (n + (m + p)) = suc ((n + m) + p)
+    (plus_0_r zero)
---           (eq_cong nat nat (plus n (plus m p)) (plus (plus n m) p) suc (IH n m))
+
---
+    -- inductive case
---           -- suc ((n + m) + p) = (n + m) + suc p
+    (fun (n : nat) (IH : eq nat (plus zero n) n) =>
---           (eq_sym nat (plus (plus n m) (suc p)) (suc (plus (plus n m) p))
+      -- WTS 0 + (suc n) = suc n
---             (plus_s_r (plus n m) p)))));
+      -- 0 + (suc n) = suc (0 + n) = suc n
---
+      eq_trans nat (plus zero (suc n)) (suc (plus zero n)) (suc n)
--- -- Up next is commutativity, but we will need a couple lemmas first.
+      -- 0 + (suc n) = suc (0 + n)
---
+      (plus_s_r zero n)
--- -- First, we will show that 0 + n = n.
+
--- plus_0_l : forall (n : nat), eq nat (plus zero n) n :=
+      -- suc (0 + n) = suc n
---   -- We prove this by induction on n.
+      (eq_cong nat nat (plus zero n) n suc IH));
---   nat_ind (fun (n : nat) => eq nat (plus zero n) n)
+
---     -- base case: WTS 0 + 0 = 0
+-- Next, we will show that (suc n) + m = suc (n + m).
---     -- This is just plus_0_r 0
+def plus_s_l (n : nat) : forall (m : nat), eq nat (plus (suc n) m) (suc (plus n m)) :=
---     (plus_0_r zero)
+  -- We proceed by induction on m.
---
+  nat_ind (fun (m : nat) => eq nat (plus (suc n) m) (suc (plus n m)))
---     -- inductive case
+    -- base case: (suc n) + 0 = suc (n + 0)
---     (fun (n : nat) (IH : eq nat (plus zero n) n) =>
+    -- (suc n) + 0 = suc n = suc (n + 0)
---       -- WTS 0 + (suc n) = suc n
+    (eq_trans nat (plus (suc n) zero) (suc n) (suc (plus n zero))
---       -- 0 + (suc n) = suc (0 + n) = suc n
+      -- (suc n) + 0 = suc n
---       eq_trans nat (plus zero (suc n)) (suc (plus zero n)) (suc n)
+      (plus_0_r (suc n))
---       -- 0 + (suc n) = suc (0 + n)
+
---       (plus_s_r zero n)
+      -- suc n = suc (n + 0)
---
+      (eq_cong nat nat n (plus n zero) suc
---       -- suc (0 + n) = suc n
+        -- n = n + 0
---       (eq_cong nat nat (plus zero n) n suc IH));
+        (eq_sym nat (plus n zero) n (plus_0_r n))))
---
+
--- -- Next, we will show that (suc n) + m = suc (n + m).
+    -- inductive case
--- plus_s_l (n : nat) : forall (m : nat), eq nat (plus (suc n) m) (suc (plus n m)) :=
+    -- IH = suc n + m = suc (n + m)
---   -- We proceed by induction on m.
+    (fun (m : nat) (IH : eq nat (plus (suc n) m) (suc (plus n m))) =>
---   nat_ind (fun (m : nat) => eq nat (plus (suc n) m) (suc (plus n m)))
+        -- WTS suc n + suc m = suc (n + suc m)
---     -- base case: (suc n) + 0 = suc (n + 0)
+        -- suc n + suc m = suc (suc n + m)
---     -- (suc n) + 0 = suc n = suc (n + 0)
+        --               = suc (suc (n + m))
---     (eq_trans nat (plus (suc n) zero) (suc n) (suc (plus n zero))
+        --               = suc (n + suc m)
---       -- (suc n) + 0 = suc n
+        (eq_trans nat (plus (suc n) (suc m)) (suc (plus (suc n) m)) (suc (plus n (suc m)))
---       (plus_0_r (suc n))
+          -- suc n + suc m = suc (suc n + m)
---
+          (plus_s_r (suc n) m)
---       -- suc n = suc (n + 0)
+
---       (eq_cong nat nat n (plus n zero) suc
+          -- suc (suc n + m) = suc (n + suc m)
---         -- n = n + 0
+          (eq_trans nat (suc (plus (suc n) m)) (suc (suc (plus n m))) (suc (plus n (suc m)))
---         (eq_sym nat (plus n zero) n (plus_0_r n))))
+            -- suc (suc n + m) = suc (suc (n + m))
---
+            (eq_cong nat nat (plus (suc n) m) (suc (plus n m)) suc IH)
---     -- inductive case
+
---     -- IH = suc n + m = suc (n + m)
+            -- suc (suc (n + m)) = suc (n + suc m)
---     (fun (m : nat) (IH : eq nat (plus (suc n) m) (suc (plus n m))) =>
+            (eq_cong nat nat (suc (plus n m)) (plus n (suc m)) suc
---         -- WTS suc n + suc m = suc (n + suc m)
+              -- suc (n + m) = n + suc m
---         -- suc n + suc m = suc (suc n + m)
+              (eq_sym nat (plus n (suc m)) (suc (plus n m)) (plus_s_r n m))))));
---         --               = suc (suc (n + m))
+
---         --               = suc (n + suc m)
+-- Finally, we can prove commutativity.
---         (eq_trans nat (plus (suc n) (suc m)) (suc (plus (suc n) m)) (suc (plus n (suc m)))
+def plus_comm (n : nat) : forall (m : nat), eq nat (plus n m) (plus m n) :=
---           -- suc n + suc m = suc (suc n + m)
+  -- As usual, we proceed by induction.
---           (plus_s_r (suc n) m)
+  nat_ind (fun (m : nat) => eq nat (plus n m) (plus m n))
---
+
---           -- suc (suc n + m) = suc (n + suc m)
+  -- Base case: WTS n + 0 = 0 + n
---           (eq_trans nat (suc (plus (suc n) m)) (suc (suc (plus n m))) (suc (plus n (suc m)))
+  -- n + 0 = n = 0 + n
---             -- suc (suc n + m) = suc (suc (n + m))
+  (eq_trans nat (plus n zero) n (plus zero n)
---             (eq_cong nat nat (plus (suc n) m) (suc (plus n m)) suc IH)
+    -- n + 0 = n
---
+    (plus_0_r n)
---             -- suc (suc (n + m)) = suc (n + suc m)
+
---             (eq_cong nat nat (suc (plus n m)) (plus n (suc m)) suc
+    -- n = 0 + n
---               -- suc (n + m) = n + suc m
+    (eq_sym nat (plus zero n) n (plus_0_l n)))
---               (eq_sym nat (plus n (suc m)) (suc (plus n m)) (plus_s_r n m))))));
+
---
+  -- Inductive step:
--- -- Finally, we can prove commutativity.
+  (fun (m : nat) (IH : eq nat (plus n m) (plus m n)) =>
--- plus_comm (n : nat) : forall (m : nat), eq nat (plus n m) (plus m n) :=
+    -- WTS n + suc m = suc m + n
---   -- As usual, we proceed by induction.
+    -- n + suc m = suc (n + m)
---   nat_ind (fun (m : nat) => eq nat (plus n m) (plus m n))
+    --           = suc (m + n)
---
+    --           = suc m + n
---   -- Base case: WTS n + 0 = 0 + n
+    (eq_trans nat (plus n (suc m)) (suc (plus n m)) (plus (suc m) n)
---   -- n + 0 = n = 0 + n
+      -- n + suc m = suc (n + m)
---   (eq_trans nat (plus n zero) n (plus zero n)
+      (plus_s_r n m)
---     -- n + 0 = n
+
---     (plus_0_r n)
+      -- suc (n + m) = suc m + n
---
+      (eq_trans nat (suc (plus n m)) (suc (plus m n)) (plus (suc m) n)
---     -- n = 0 + n
+        -- suc (n + m) = suc (m + n)
---     (eq_sym nat (plus zero n) n (plus_0_l n)))
+        (eq_cong nat nat (plus n m) (plus m n) suc IH)
---
+
---   -- Inductive step:
+        -- suc (m + n) = suc m + n
---   (fun (m : nat) (IH : eq nat (plus n m) (plus m n)) =>
+        (eq_sym nat (plus (suc m) n) (suc (plus m n)) (plus_s_l m n)))));
---     -- WTS n + suc m = suc m + n
---     -- n + suc m = suc (n + m)
---     --           = suc (m + n)
---     --           = suc m + n
---     (eq_trans nat (plus n (suc m)) (suc (plus n m)) (plus (suc m) n)
---       -- n + suc m = suc (n + m)
---       (plus_s_r n m)
---
---       -- suc (n + m) = suc m + n
---       (eq_trans nat (suc (plus n m)) (suc (plus m n)) (plus (suc m) n)
---         -- suc (n + m) = suc (m + n)
---         (eq_cong nat nat (plus n m) (plus m n) suc IH)
---
---         -- suc (m + n) = suc m + n
---         (eq_sym nat (plus (suc m) n) (suc (plus m n)) (plus_s_l m n)))));

lib/Errors.hs

@@ -3,8 +3,7 @@ module Errors where
 import Expr
 
 data Error
-    = SquareUntyped
+    = UnboundVariable Text
-    | UnboundVariable Text
     | NotASort Expr Expr
     | ExpectedPiType Expr Expr
     | NotEquivalent Expr Expr Expr
@@ -13,7 +12,6 @@ data Error
     deriving (Eq, Ord)
 
 instance ToText Error where
-    toText SquareUntyped = "□ does not have a type"
     toText (UnboundVariable x) = "Unbound variable: '" <> x <> "'"
     toText (NotASort x t) = "Expected '" <> pretty x <> "' to have type * or □, instead found '" <> pretty t <> "'"
     toText (ExpectedPiType x t) = "'" <> pretty x <> "' : '" <> pretty t <> "' is not a function"

lib/Program.hs

@@ -30,6 +30,7 @@ handleDef (Def name Nothing irBody) = do
 handleDef (Def name (Just irTy) irBody) = do
     env <- get
     ty' <- liftEither $ checkType env body
+    _ <- liftEither $ checkType env ty
     liftEither $ checkBeta env ty ty' body
     modify $ insertDef name ty' body
   where