Compare commits
185 commits
Author | SHA1 | Date | |
---|---|---|---|
3ab8669404 | |||
2bfe3250cf | |||
f00c802336 | |||
68c414a941 | |||
7b3ccfc45a | |||
519cc4779a | |||
3e23929b5f | |||
01e16e20e5 | |||
5bf40755b5 | |||
863849e4c4 | |||
8fae67d4d5 | |||
d276a66abd | |||
b556c2f099 | |||
d2a117fe61 | |||
c9f66bb6af | |||
7f72ed56fb | |||
67c825ab39 | |||
ddc2422ffb | |||
3f7031c613 | |||
8823154973 | |||
b7dc5ffdc4 | |||
dd697ba56e | |||
32b9fe124f | |||
95a0b38d74 | |||
7883a3cae7 | |||
a1d8fd4ab5 | |||
9d60f366cf | |||
f56f594839 | |||
fca75377a0 | |||
11b0ab6a25 | |||
7a0bc73d25 | |||
567176e076 | |||
3b6ae36e4e | |||
861bd55f94 | |||
e6ad16813e | |||
78555711ce | |||
ec839a1d48 | |||
727f968afb | |||
41c8a92c97 | |||
efddb1aea1 | |||
8cba73f741 | |||
582666a254 | |||
a9e8f14ad5 | |||
a8ac6f11f7 | |||
b67162bda1 | |||
24ae5b85a2 | |||
325e128063 | |||
642ac25a71 | |||
05a688d49e | |||
1c8c50f3e2 | |||
f337625801 | |||
1f01cec322 | |||
103f019dbd | |||
2cafb35bc1 | |||
47069a9316 | |||
fb14b756c7 | |||
81783dbae0 | |||
a14c4ca1cb | |||
b7074720ad | |||
48a050491c | |||
aa4ead592a | |||
54db7e27ef | |||
7afcbfe258 | |||
0fdd4741be | |||
03c197bd04 | |||
cdf1ec6deb | |||
08a8c694b1 | |||
8b8129027d | |||
e48f03a61c | |||
415a823dec | |||
b1699ce022 | |||
68d8019f00 | |||
59e7a457a6 | |||
4291afd51b | |||
e2ad18ff1f | |||
310822ffa5 | |||
d115672d49 | |||
cc78ccd940 | |||
50984aa1aa | |||
246d80eea2 | |||
c48b7be559 | |||
040a1862c3 | |||
bf8cced888 | |||
04af7ae942 | |||
d9cdf1306d | |||
6c8ebfb804 | |||
da3cd404f3 | |||
f58fa5218f | |||
580fbc8fd8 | |||
e211887a34 | |||
3b9a339e5e | |||
2f8a2d2cd2 | |||
b6c435049d | |||
90cdcfe4da | |||
d4639a35c6 | |||
b7e1f37b5b | |||
5dfefe443c | |||
0514fff481 | |||
fa7f82ae5a | |||
e0ed37720f | |||
4cc50c6bcd | |||
050346e344 | |||
cc0bade747 | |||
cd08a0fd98 | |||
1f14e4ab9e | |||
314e7f036d | |||
6ab9637ab5 | |||
b6fd1e921e | |||
f4a45b6c52 | |||
8e0d66cab8 | |||
ea74c148b7 | |||
83ab871d61 | |||
421eb220fd | |||
fbb862c88b | |||
b651ed5447 | |||
d6985cad55 | |||
52e54dcc3c | |||
0c1df54d62 | |||
2e9183bc14 | |||
428397f42b | |||
0b7bd0ef46 | |||
9cbd998d6f | |||
6896c8fcc4 | |||
be8797a3ef | |||
bf605486f0 | |||
69f032584e | |||
9ecaaf72bd | |||
f04c4619ef | |||
d4de74eab6 | |||
bcfb0d81b8 | |||
8395bec4cb | |||
6153b4f7f8 | |||
d4cfbd4045 | |||
ea674503c0 | |||
b1eefb0f4d | |||
ee22486e97 | |||
08fb686bf6 | |||
cf3ed604a4 | |||
4704dd0441 | |||
dc076b636d | |||
80b1b3581a | |||
ebde478adc | |||
bb8d2464af | |||
e6c06a5c81 | |||
3fe9b96f05 | |||
244b33d786 | |||
b85dcb5402 | |||
e1257560b7 | |||
ac518472ad | |||
4c88918ade | |||
7bd959e919 | |||
8221d71416 | |||
7b53d56072 | |||
fa14ce1a02 | |||
9973f8d07b | |||
1e8932690b | |||
d5d30ee198 | |||
add2eb400c | |||
6f9d31aa0a | |||
6dcd3332c1 | |||
32f6e5a3b1 | |||
72609bc12f | |||
3e3bf1b67f | |||
387d44431a | |||
2340b14407 | |||
edfe30ff63 | |||
ba77c45c64 | |||
f3f74d581a | |||
22db2724ce | |||
0bcb8c24db | |||
a221380d61 | |||
4b6b3853a1 | |||
8264a1bb81 | |||
a24ebe0702 | |||
688204f1a4 | |||
09e39d6224 | |||
00d92d3f25 | |||
c6006682ca | |||
cf9bfc2159 | |||
f6b8a12fab | |||
932469a91e | |||
349cf2f477 | |||
3c0989dcb2 | |||
b6264f388d | |||
612fb33663 |
147 changed files with 11657 additions and 4637 deletions
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -5,3 +5,5 @@ result
|
|||
*~
|
||||
quox
|
||||
quox-tests
|
||||
golden-tests/tests/*/output
|
||||
golden-tests/tests/*/*.ss
|
||||
|
|
4
CREDITS.md
Normal file
4
CREDITS.md
Normal file
|
@ -0,0 +1,4 @@
|
|||
the "logo" is an edit of [an emoji] made by [khr].
|
||||
|
||||
[an emoji]: https://github.com/chr-1x/dragn-emoji
|
||||
[khr]: https://dragon.monster
|
|
@ -1,6 +1,10 @@
|
|||
load "misc.quox"
|
||||
load "bool.quox"
|
||||
load "either.quox"
|
||||
load "maybe.quox"
|
||||
load "nat.quox"
|
||||
load "pair.quox"
|
||||
load "list.quox"
|
||||
load "eta.quox"
|
||||
load "fail.quox"
|
||||
load "qty.quox"
|
||||
|
|
|
@ -4,24 +4,35 @@ namespace bool {
|
|||
|
||||
def0 Bool : ★ = {true, false};
|
||||
|
||||
def boolω : 1.Bool → [ω.Bool] =
|
||||
λ b ⇒ case1 b return [ω.Bool] of { 'true ⇒ ['true]; 'false ⇒ ['false] };
|
||||
def if-dep : 0.(P : Bool → ★) → (b : Bool) → ω.(P 'true) → ω.(P 'false) → P b =
|
||||
λ P b t f ⇒ case b return b' ⇒ P b' of { 'true ⇒ t; 'false ⇒ f };
|
||||
|
||||
def if : 0.(A : ★) → 1.Bool → ω.A → ω.A → A =
|
||||
λ A b t f ⇒ case1 b return A of { 'true ⇒ t; 'false ⇒ f };
|
||||
def if : 0.(A : ★) → (b : Bool) → ω.A → ω.A → A =
|
||||
λ A ⇒ if-dep (λ _ ⇒ A);
|
||||
|
||||
def0 If : 1.Bool → 0.★ → 0.★ → ★ =
|
||||
λ b T F ⇒ case1 b return ★ of { 'true ⇒ T; 'false ⇒ F };
|
||||
def0 if-same : (A : ★) → (b : Bool) → (x : A) → if A b x x ≡ x : A =
|
||||
λ A b x ⇒ if-dep (λ b' ⇒ if A b' x x ≡ x : A) b (δ _ ⇒ x) (δ _ ⇒ x);
|
||||
|
||||
def0 T : ω.Bool → ★ = λ b ⇒ If b True False;
|
||||
def if2 : 0.(A B : ★) → (b : Bool) → ω.A → ω.B → if¹ ★ b A B =
|
||||
λ A B ⇒ if-dep (λ b ⇒ if-dep¹ (λ _ ⇒ ★) b A B);
|
||||
|
||||
def0 T : Bool → ★ = λ b ⇒ if¹ ★ b True False;
|
||||
|
||||
def dup! : (b : Bool) → [ω. Sing Bool b] =
|
||||
λ b ⇒ if-dep (λ b ⇒ [ω. Sing Bool b]) b
|
||||
[('true, [δ _ ⇒ 'true])]
|
||||
[('false, [δ _ ⇒ 'false])];
|
||||
|
||||
def dup : Bool → [ω. Bool] =
|
||||
λ b ⇒ appω (Sing Bool b) Bool (sing.val Bool b) (dup! b);
|
||||
|
||||
def true-not-false : Not ('true ≡ 'false : Bool) =
|
||||
λ eq ⇒ coe (i ⇒ T (eq @i)) 'true;
|
||||
λ eq ⇒ coe (𝑖 ⇒ T (eq @𝑖)) 'true;
|
||||
|
||||
|
||||
-- [todo] infix
|
||||
def and : 1.Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
|
||||
def or : 1.Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
|
||||
def and : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
|
||||
def or : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
|
||||
|
||||
}
|
||||
|
||||
|
|
|
@ -5,35 +5,35 @@ namespace either {
|
|||
|
||||
def0 Tag : ★ = {left, right};
|
||||
|
||||
def0 Payload : 0.★ → 0.★ → 1.Tag → ★ =
|
||||
λ A B tag ⇒ case1 tag return ★ of { 'left ⇒ A; 'right ⇒ B };
|
||||
def0 Payload : ★ → ★ → Tag → ★ =
|
||||
λ A B tag ⇒ case tag return ★ of { 'left ⇒ A; 'right ⇒ B };
|
||||
|
||||
def0 Either : 0.★ → 0.★ → ★ =
|
||||
def0 Either : ★ → ★ → ★ =
|
||||
λ A B ⇒ (tag : Tag) × Payload A B tag;
|
||||
|
||||
def Left : 0.(A B : ★) → 1.A → Either A B =
|
||||
def Left : 0.(A B : ★) → A → Either A B =
|
||||
λ A B x ⇒ ('left, x);
|
||||
|
||||
def Right : 0.(A B : ★) → 1.B → Either A B =
|
||||
def Right : 0.(A B : ★) → B → Either A B =
|
||||
λ A B x ⇒ ('right, x);
|
||||
|
||||
def elim' :
|
||||
0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
|
||||
ω.(1.(x : A) → P (Left A B x)) →
|
||||
ω.(1.(x : B) → P (Right A B x)) →
|
||||
1.(t : Tag) → 1.(a : Payload A B t) → P (t, a) =
|
||||
ω.((x : A) → P (Left A B x)) →
|
||||
ω.((x : B) → P (Right A B x)) →
|
||||
(t : Tag) → (a : Payload A B t) → P (t, a) =
|
||||
λ A B P f g t ⇒
|
||||
case1 t
|
||||
return t' ⇒ 1.(a : Payload A B t') → P (t', a)
|
||||
case t
|
||||
return t' ⇒ (a : Payload A B t') → P (t', a)
|
||||
of { 'left ⇒ f; 'right ⇒ g };
|
||||
|
||||
def elim :
|
||||
0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
|
||||
ω.(1.(x : A) → P (Left A B x)) →
|
||||
ω.(1.(x : B) → P (Right A B x)) →
|
||||
1.(x : Either A B) → P x =
|
||||
ω.((x : A) → P (Left A B x)) →
|
||||
ω.((x : B) → P (Right A B x)) →
|
||||
(x : Either A B) → P x =
|
||||
λ A B P f g e ⇒
|
||||
case1 e return e' ⇒ P e' of { (t, a) ⇒ elim' A B P f g t a };
|
||||
case e return e' ⇒ P e' of { (t, a) ⇒ elim' A B P f g t a };
|
||||
|
||||
|
||||
}
|
||||
|
@ -45,25 +45,25 @@ def Right = either.Right;
|
|||
|
||||
namespace dec {
|
||||
|
||||
def0 Dec : 0.★ → ★ = λ A ⇒ Either [0.A] [0.Not A];
|
||||
def0 Dec : ★ → ★ = λ A ⇒ Either [0.A] [0.Not A];
|
||||
|
||||
def Yes : 0.(A : ★) → 0.A → Dec A = λ A y ⇒ Left [0.A] [0.Not A] [y];
|
||||
def No : 0.(A : ★) → 0.(Not A) → Dec A = λ A n ⇒ Right [0.A] [0.Not A] [n];
|
||||
|
||||
def0 DecEq : 0.★ → ★ =
|
||||
def0 DecEq : ★ → ★ =
|
||||
λ A ⇒ ω.(x : A) → ω.(y : A) → Dec (x ≡ y : A);
|
||||
|
||||
def elim :
|
||||
0.(A : ★) → 0.(P : 0.(Dec A) → ★) →
|
||||
ω.(0.(y : A) → P (Yes A y)) →
|
||||
ω.(0.(n : Not A) → P (No A n)) →
|
||||
1.(x : Dec A) → P x =
|
||||
(x : Dec A) → P x =
|
||||
λ A P f g ⇒
|
||||
either.elim [0.A] [0.Not A] P
|
||||
(λ y ⇒ case0 y return y' ⇒ P (Left [0.A] [0.Not A] y') of {[y'] ⇒ f y'})
|
||||
(λ n ⇒ case0 n return n' ⇒ P (Right [0.A] [0.Not A] n') of {[n'] ⇒ g n'});
|
||||
|
||||
def bool : 0.(A : ★) → 1.(Dec A) → Bool =
|
||||
def bool : 0.(A : ★) → Dec A → Bool =
|
||||
λ A ⇒ elim A (λ _ ⇒ Bool) (λ _ ⇒ 'true) (λ _ ⇒ 'false);
|
||||
|
||||
}
|
||||
|
|
25
examples/eta.quox
Normal file
25
examples/eta.quox
Normal file
|
@ -0,0 +1,25 @@
|
|||
load "misc.quox"
|
||||
|
||||
namespace eta {
|
||||
|
||||
def0 Π : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) → B x
|
||||
def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x
|
||||
|
||||
def0 function : (A : ★) → (B : A → Type) → (P : Π A B → ★) → (f : Π A B) →
|
||||
P (λ x ⇒ f x) → P f =
|
||||
λ A B P f p ⇒ p
|
||||
|
||||
def0 box : (A : ★) → (P : [ω.A] → ★) → (e : [ω.A]) →
|
||||
P [case1 e return A of {[x] ⇒ x}] → P e =
|
||||
λ A P e p ⇒ p
|
||||
|
||||
def0 pair : (A : ★) → (B : A → ★) → (P : Σ A B → ★) → (e : Σ A B) →
|
||||
P (fst e, snd e) → P e =
|
||||
λ A B P e p ⇒ p
|
||||
|
||||
-- not exactly η, but kinda related
|
||||
def0 from-false : (A : ★) → (P : (0.False → A) → ★) → (f : 0.False → A) →
|
||||
P (void A) → P f =
|
||||
λ A P f p ⇒ p
|
||||
|
||||
}
|
16
examples/fail.quox
Normal file
16
examples/fail.quox
Normal file
|
@ -0,0 +1,16 @@
|
|||
#[fail "but cases for"]
|
||||
def missing-b : {a, b} → {a} =
|
||||
λ x ⇒ case x return {a} of { 'a ⇒ 'a }
|
||||
|
||||
#[fail "duplicate arms"]
|
||||
def repeat-enum-case : {a} → {a} =
|
||||
λ x ⇒ case x return {a} of { 'a ⇒ 'a; 'a ⇒ 'a }
|
||||
|
||||
#[fail "duplicate tags"]
|
||||
def repeat-enum-type : {a, a} = 'a
|
||||
|
||||
#[fail "double-def.X has already been defined"]
|
||||
namespace double-def {
|
||||
def0 X : ★ = {a}
|
||||
def0 X : ★ = {a}
|
||||
}
|
26
examples/hello.quox
Normal file
26
examples/hello.quox
Normal file
|
@ -0,0 +1,26 @@
|
|||
def0 Unit : ★ = {tt}
|
||||
|
||||
def drop-unit : 0.(A : ★) → Unit → A → A =
|
||||
λ A u x ⇒ case u return A of {'tt ⇒ x}
|
||||
|
||||
def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
|
||||
|
||||
def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B =
|
||||
λ A B m k s0 ⇒
|
||||
case m s0 return B × IOState of { (x, s1) ⇒ k x s1 }
|
||||
|
||||
def seq : IO Unit → IO Unit → IO Unit =
|
||||
λ a b ⇒ bind Unit Unit a (λ u ⇒ drop-unit (IO Unit) u b)
|
||||
|
||||
#[compile-scheme "(lambda (n) (builtin-io (printf \"~d~n\" n) 'tt))"]
|
||||
postulate print-ℕ : ℕ → IO Unit
|
||||
|
||||
#[compile-scheme "(lambda (s) (builtin-io (printf \"~s~n\" s) 'tt))"]
|
||||
postulate print : String → IO Unit
|
||||
|
||||
load "nat.quox"
|
||||
|
||||
#[main]
|
||||
def main : IO Unit =
|
||||
let1 sixty-nine = nat.plus 60 9 in
|
||||
seq (print-ℕ sixty-nine) (print "(nice)")
|
31
examples/io.quox
Normal file
31
examples/io.quox
Normal file
|
@ -0,0 +1,31 @@
|
|||
load "misc.quox"
|
||||
|
||||
namespace io {
|
||||
|
||||
def0 IORes : ★ → ★ = λ A ⇒ A × IOState
|
||||
|
||||
def0 IO : ★ → ★ = λ A ⇒ IOState → IORes A
|
||||
|
||||
def pure : 0.(A : ★) → A → IO A = λ A x s ⇒ (x, s)
|
||||
|
||||
def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B =
|
||||
λ A B m k s0 ⇒
|
||||
case m s0 return IORes B of { (x, s1) ⇒ k x s1 }
|
||||
|
||||
def seq : 0.(B : ★) → IO True → IO B → IO B =
|
||||
λ B x y ⇒ bind True B x (λ u ⇒ case u return IO B of { 'true ⇒ y })
|
||||
|
||||
def seq' : IO True → IO True → IO True = seq True
|
||||
|
||||
#[compile-scheme "(lambda (str) (builtin-io (display str) 'true))"]
|
||||
postulate print : String → IO True
|
||||
|
||||
def newline = print "\n"
|
||||
|
||||
def println : String → IO True =
|
||||
λ str ⇒ seq' (print str) newline
|
||||
|
||||
#[compile-scheme "(builtin-io (get-line (current-input-port)))"]
|
||||
postulate readln : IO String
|
||||
|
||||
}
|
|
@ -1,41 +1,91 @@
|
|||
load "nat.quox";
|
||||
|
||||
namespace list {
|
||||
namespace vec {
|
||||
|
||||
def0 Vec : 0.ℕ → 0.★ → ★ =
|
||||
def0 Vec : ℕ → ★ → ★ =
|
||||
λ n A ⇒
|
||||
caseω n return ★ of {
|
||||
zero ⇒ {nil};
|
||||
succ _, 0.Tail ⇒ A × Tail
|
||||
};
|
||||
|
||||
def0 List : 0.★ → ★ =
|
||||
λ A ⇒ (len : ℕ) × Vec len A;
|
||||
|
||||
def nil : 0.(A : ★) → List A =
|
||||
λ A ⇒ (0, 'nil);
|
||||
|
||||
def cons : 0.(A : ★) → 1.A → 1.(List A) → List A =
|
||||
λ A x xs ⇒ case1 xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
|
||||
|
||||
def foldr' : 0.(A B : ★) →
|
||||
1.B → ω.(1.A → 1.B → B) → 1.(n : ℕ) → 1.(Vec n A) → B =
|
||||
λ A B z c n ⇒
|
||||
case1 n return n' ⇒ 1.(Vec n' A) → B of {
|
||||
zero ⇒
|
||||
λ nil ⇒ case1 nil return B of { 'nil ⇒ z };
|
||||
succ n, 1.ih ⇒
|
||||
λ cons ⇒ case1 cons return B of { (first, rest) ⇒ c first (ih rest) }
|
||||
def elim : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
|
||||
P 0 'nil →
|
||||
ω.((x : A) → 0.(n : ℕ) → 0.(xs : Vec n A) →
|
||||
P n xs → P (succ n) (x, xs)) →
|
||||
(n : ℕ) → (xs : Vec n A) → P n xs =
|
||||
λ A P pn pc n ⇒
|
||||
case n return n' ⇒ (xs' : Vec n' A) → P n' xs' of {
|
||||
zero ⇒ λ n ⇒
|
||||
case n return n' ⇒ P 0 n' of { 'nil ⇒ pn };
|
||||
succ n, ih ⇒ λ c ⇒
|
||||
case c return c' ⇒ P (succ n) c' of {
|
||||
(first, rest) ⇒ pc first n rest (ih rest)
|
||||
}
|
||||
};
|
||||
|
||||
def foldr : 0.(A B : ★) → 1.B → ω.(1.A → 1.B → B) → 1.(List A) → B =
|
||||
λ A B z c xs ⇒
|
||||
case1 xs return B of { (len, elems) ⇒ foldr' A B z c len elems };
|
||||
|
||||
def sum : 1.(List ℕ) → ℕ = foldr ℕ ℕ 0 nat.plus;
|
||||
|
||||
def numbers : List ℕ = (5, (0, 1, 2, 3, 4, 'nil));
|
||||
|
||||
def number-sum : sum numbers ≡ 10 : ℕ = δ _ ⇒ 10;
|
||||
#[compile-scheme "(lambda% (n xs) xs)"]
|
||||
def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A =
|
||||
λ A n ⇒
|
||||
case n return n' ⇒ Vec n' A → Vec¹ n' A of {
|
||||
zero ⇒ λ xs ⇒
|
||||
case xs return Vec¹ 0 A of { 'nil ⇒ 'nil };
|
||||
succ n', f' ⇒ λ xs ⇒
|
||||
case xs return Vec¹ (succ n') A of {
|
||||
(first, rest) ⇒ (first, f' rest)
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
def0 Vec = vec.Vec;
|
||||
|
||||
|
||||
namespace list {
|
||||
|
||||
def0 List : ★ → ★ =
|
||||
λ A ⇒ (len : ℕ) × Vec len A;
|
||||
|
||||
def Nil : 0.(A : ★) → List A =
|
||||
λ A ⇒ (0, 'nil);
|
||||
|
||||
def Cons : 0.(A : ★) → A → List A → List A =
|
||||
λ A x xs ⇒ case xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
|
||||
|
||||
def elim : 0.(A : ★) → 0.(P : List A → ★) →
|
||||
P (Nil A) →
|
||||
ω.((x : A) → 0.(xs : List A) → P xs → P (Cons A x xs)) →
|
||||
(xs : List A) → P xs =
|
||||
λ A P pn pc xs ⇒
|
||||
case xs return xs' ⇒ P xs' of { (len, elems) ⇒
|
||||
vec.elim A (λ n xs ⇒ P (n, xs))
|
||||
pn (λ x n xs ih ⇒ pc x (n, xs) ih)
|
||||
len elems
|
||||
};
|
||||
|
||||
-- [fixme] List A <: List¹ A should be automatic, imo
|
||||
#[compile-scheme "(lambda (xs) xs)"]
|
||||
def up : 0.(A : ★) → List A → List¹ A =
|
||||
λ A xs ⇒
|
||||
case xs return List¹ A of { (len, elems) ⇒
|
||||
case nat.dup! len return List¹ A of { [p] ⇒
|
||||
caseω p return List¹ A of { (lenω, eq0) ⇒
|
||||
case eq0 return List¹ A of { [eq] ⇒
|
||||
(lenω, vec.up A lenω (coe (𝑖 ⇒ Vec (eq @𝑖) A) @1 @0 elems))
|
||||
}
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
def foldr : 0.(A B : ★) → B → ω.(A → B → B) → List A → B =
|
||||
λ A B z f xs ⇒ elim A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs;
|
||||
|
||||
def map : 0.(A B : ★) → ω.(A → B) → List A → List B =
|
||||
λ A B f ⇒ foldr A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys);
|
||||
|
||||
def0 All : (A : ★) → (P : A → ★) → List A → ★ =
|
||||
λ A P xs ⇒ foldr¹ A ★ True (λ x ps ⇒ P x × ps) (up A xs);
|
||||
|
||||
}
|
||||
|
||||
def0 List = list.List;
|
||||
|
|
68
examples/maybe.quox
Normal file
68
examples/maybe.quox
Normal file
|
@ -0,0 +1,68 @@
|
|||
load "misc.quox"
|
||||
load "either.quox"
|
||||
|
||||
namespace maybe {
|
||||
|
||||
def0 Tag : ★ = {nothing, just}
|
||||
|
||||
def0 Payload : Tag → ★ → ★ =
|
||||
λ tag A ⇒ case tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
|
||||
|
||||
def0 Maybe : ★ → ★ =
|
||||
λ A ⇒ (t : Tag) × Payload t A
|
||||
|
||||
def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
|
||||
λ _ x ⇒ caseω x return Tag of { (tag, _) ⇒ tag }
|
||||
|
||||
def Nothing : 0.(A : ★) → Maybe A =
|
||||
λ _ ⇒ ('nothing, 'true)
|
||||
|
||||
def Just : 0.(A : ★) → A → Maybe A =
|
||||
λ _ x ⇒ ('just, x)
|
||||
|
||||
def0 IsJustTag : Tag → ★ =
|
||||
λ t ⇒ case t return ★ of { 'just ⇒ True; 'nothing ⇒ False }
|
||||
|
||||
def0 IsJust : (A : ★) → Maybe A → ★ =
|
||||
λ A x ⇒ IsJustTag (tag A x)
|
||||
|
||||
def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
|
||||
λ A x ⇒
|
||||
caseω tag A x return t ⇒ Dec (IsJustTag t) of {
|
||||
'just ⇒ Yes True 'true;
|
||||
'nothing ⇒ No False (λ x ⇒ x)
|
||||
}
|
||||
|
||||
def0 nothing-unique :
|
||||
(A : ★) → (x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
|
||||
λ A x ⇒
|
||||
case x return x' ⇒ ('nothing, x') ≡ Nothing A : Maybe A of {
|
||||
'true ⇒ δ _ ⇒ ('nothing, 'true)
|
||||
}
|
||||
|
||||
def elim :
|
||||
0.(A : ★) →
|
||||
0.(P : Maybe A → ★) →
|
||||
ω.(P (Nothing A)) →
|
||||
ω.((x : A) → P (Just A x)) →
|
||||
(x : Maybe A) → P x =
|
||||
λ A P n j x ⇒
|
||||
case x return x' ⇒ P x' of { (tag, payload) ⇒
|
||||
(case tag
|
||||
return t ⇒
|
||||
0.(eq : tag ≡ t : Tag) → P (t, coe (i ⇒ Payload (eq @i) A) payload)
|
||||
of {
|
||||
'nothing ⇒
|
||||
λ eq ⇒
|
||||
case coe (i ⇒ Payload (eq @i) A) payload
|
||||
return p ⇒ P ('nothing, p)
|
||||
of { 'true ⇒ n };
|
||||
'just ⇒ λ eq ⇒ j (coe (i ⇒ Payload (eq @i) A) payload)
|
||||
}) (δ _ ⇒ tag)
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
def0 Maybe = maybe.Maybe
|
||||
def0 Just = maybe.Just
|
||||
def0 Nothing = maybe.Nothing
|
|
@ -1,36 +1,83 @@
|
|||
def0 True : ★ = {true};
|
||||
def0 True : ★ = {true}
|
||||
|
||||
def0 False : ★ = {};
|
||||
def0 Not : 0.★ → ★ = λ A ⇒ ω.A → False;
|
||||
def0 False : ★ = {}
|
||||
def0 Not : ★ → ★ = λ A ⇒ ω.A → False
|
||||
|
||||
def void : 0.(A : ★) → 0.False → A =
|
||||
λ A v ⇒ case0 v return A of { };
|
||||
λ A v ⇒ case0 v return A of { }
|
||||
|
||||
def0 Pred : 0.★ → ★¹ = λ A ⇒ 0.A → ★;
|
||||
def0 All : (A : ★) → (0.A → ★) → ★ =
|
||||
λ A P ⇒ (x : A) → P x
|
||||
|
||||
def0 All : 0.(A : ★) → 0.(Pred A) → ★¹ =
|
||||
λ A P ⇒ 1.(x : A) → P x;
|
||||
def0 cong :
|
||||
(A : ★) → (P : 0.A → ★) → (p : All A P) →
|
||||
(x y : A) → (xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) =
|
||||
λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖)
|
||||
|
||||
def0 cong' :
|
||||
(A B : ★) → (f : A → B) →
|
||||
(x y : A) → (xy : x ≡ y : A) → f x ≡ f y : B =
|
||||
λ A B ⇒ cong A (λ _ ⇒ B)
|
||||
|
||||
def0 coherence :
|
||||
(A B : ★) → (AB : A ≡ B : ★) → (x : A) →
|
||||
Eq (𝑖 ⇒ AB @𝑖) x (coe (𝑖 ⇒ AB @𝑖) x) =
|
||||
λ A B AB x ⇒
|
||||
δ 𝑗 ⇒ coe (𝑖 ⇒ AB @𝑖) @0 @𝑗 x
|
||||
|
||||
def cong :
|
||||
0.(A : ★) → 0.(P : Pred A) → 1.(p : All A P) →
|
||||
0.(x y : A) → 1.(xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) =
|
||||
λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖);
|
||||
|
||||
def0 eq-f :
|
||||
0.(A : ★) → 0.(P : Pred A) →
|
||||
0.(A : ★) → 0.(P : 0.A → ★) →
|
||||
0.(p : All A P) → 0.(q : All A P) →
|
||||
0.A → ★ =
|
||||
λ A P p q x ⇒ p x ≡ q x : P x;
|
||||
λ A P p q x ⇒ p x ≡ q x : P x
|
||||
|
||||
def funext :
|
||||
0.(A : ★) → 0.(P : Pred A) → 0.(p q : All A P) →
|
||||
1.(All A (eq-f A P p q)) → p ≡ q : All A P =
|
||||
λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖;
|
||||
0.(A : ★) → 0.(P : 0.A → ★) → 0.(p q : All A P) →
|
||||
(All A (eq-f A P p q)) → p ≡ q : All A P =
|
||||
λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖
|
||||
|
||||
def sym : 0.(A : ★) → 0.(x y : A) → 1.(x ≡ y : A) → y ≡ x : A =
|
||||
λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 };
|
||||
def refl : 0.(A : ★) → (x : A) → x ≡ x : A = λ A x ⇒ δ _ ⇒ x
|
||||
|
||||
def sym : 0.(A : ★) → 0.(x y : A) → (x ≡ y : A) → y ≡ x : A =
|
||||
λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 }
|
||||
|
||||
def trans : 0.(A : ★) → 0.(x y z : A) →
|
||||
ω.(x ≡ y : A) → ω.(y ≡ z : A) → x ≡ z : A =
|
||||
λ A x y z eq1 eq2 ⇒ δ 𝑖 ⇒
|
||||
comp A (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 };
|
||||
comp A (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 }
|
||||
|
||||
def appω : 0.(A B : ★) → ω.(f : A → B) → [ω.A] → [ω.B] =
|
||||
λ A B f x ⇒
|
||||
case x return [ω.B] of { [x'] ⇒ [f x'] }
|
||||
|
||||
def0 HEq : (A B : ★) → A → B → ★¹ =
|
||||
λ A B x y ⇒ (AB : A ≡ B : ★) × Eq (𝑖 ⇒ AB @𝑖) x y
|
||||
|
||||
|
||||
def0 Sing : (A : ★) → A → ★ =
|
||||
λ A x ⇒ (val : A) × [0. val ≡ x : A]
|
||||
|
||||
def sing : 0.(A : ★) → (x : A) → Sing A x =
|
||||
λ A x ⇒ (x, [δ _ ⇒ x])
|
||||
|
||||
namespace sing {
|
||||
|
||||
def val : 0.(A : ★) → 0.(x : A) → Sing A x → A =
|
||||
λ A _ sg ⇒
|
||||
case sg return A of { (x, eq) ⇒ case eq return A of { [_] ⇒ x } }
|
||||
|
||||
def0 proof : (A : ★) → (x : A) → (sg : Sing A x) → val A x sg ≡ x : A =
|
||||
λ A x sg ⇒
|
||||
case sg return sg' ⇒ val A x sg' ≡ x : A of { (x', eq) ⇒
|
||||
case eq return eq' ⇒ val A x (x', eq') ≡ x : A of { [eq'] ⇒ eq' }
|
||||
}
|
||||
|
||||
def app : 0.(A B : ★) → 0.(x : A) →
|
||||
(f : A → B) → Sing A x → Sing B (f x) =
|
||||
λ A B x f sg ⇒
|
||||
case sg return Sing B (f x) of { (x_, eq) ⇒
|
||||
case eq return Sing B (f x) of { [eq] ⇒ (f x_, [δ 𝑖 ⇒ f (eq @𝑖)]) }
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
@ -4,41 +4,72 @@ load "either.quox";
|
|||
|
||||
namespace nat {
|
||||
|
||||
def dup : 1.ℕ → [ω.ℕ] =
|
||||
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 ⇒
|
||||
case1 n return [ω.ℕ] of {
|
||||
zero ⇒ [zero];
|
||||
succ _, 1.d ⇒ case1 d return [ω.ℕ] of { [d] ⇒ [succ d] }
|
||||
case n return n' ⇒ [ω. Sing ℕ n'] of {
|
||||
zero ⇒ [(zero, [δ _ ⇒ zero])];
|
||||
succ n, d ⇒
|
||||
appω (Sing ℕ n) (Sing ℕ (succ n))
|
||||
(sing.app ℕ ℕ n (λ n ⇒ succ n)) d
|
||||
};
|
||||
|
||||
def plus : 1.ℕ → 1.ℕ → ℕ =
|
||||
def dup : ℕ → [ω.ℕ] =
|
||||
λ n ⇒ appω (Sing ℕ n) ℕ (sing.val ℕ n) (dup! n);
|
||||
|
||||
#[compile-scheme "(lambda% (m n) (+ m n))"]
|
||||
def plus : ℕ → ℕ → ℕ =
|
||||
λ m n ⇒
|
||||
case1 m return ℕ of {
|
||||
case m return ℕ of {
|
||||
zero ⇒ n;
|
||||
succ _, 1.p ⇒ succ p
|
||||
succ _, p ⇒ succ p
|
||||
};
|
||||
|
||||
def timesω : 1.ℕ → ω.ℕ → ℕ =
|
||||
#[compile-scheme "(lambda% (m n) (* m n))"]
|
||||
def timesω : ℕ → ω.ℕ → ℕ =
|
||||
λ m n ⇒
|
||||
case1 m return ℕ of {
|
||||
case m return ℕ of {
|
||||
zero ⇒ zero;
|
||||
succ _, 1.t ⇒ plus n t
|
||||
succ _, t ⇒ plus n t
|
||||
};
|
||||
|
||||
def times : 1.ℕ → 1.ℕ → ℕ =
|
||||
λ m n ⇒ case1 dup n return ℕ of { [n] ⇒ timesω m n };
|
||||
def times : ℕ → ℕ → ℕ =
|
||||
λ m n ⇒ case dup n return ℕ of { [n] ⇒ timesω m n };
|
||||
|
||||
def pred : 1.ℕ → ℕ = λ n ⇒ case1 n return ℕ of { zero ⇒ zero; succ n ⇒ n };
|
||||
def pred : ℕ → ℕ = λ n ⇒ case n return ℕ of { zero ⇒ zero; succ n ⇒ n };
|
||||
|
||||
def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ =
|
||||
λ n ⇒ δ 𝑖 ⇒ n;
|
||||
|
||||
def0 succ-inj : 0.(m n : ℕ) → 0.(succ m ≡ succ n : ℕ) → m ≡ 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 : 0.ℕ → ★ =
|
||||
λ n ⇒ caseω n return ★ of { zero ⇒ False; succ _ ⇒ True };
|
||||
|
||||
def0 IsSucc : ℕ → ★ =
|
||||
λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True };
|
||||
|
||||
def isSucc? : ω.(n : ℕ) → Dec (IsSucc n) =
|
||||
λ n ⇒
|
||||
|
@ -54,14 +85,15 @@ def succ-not-zero : 0.(m : ℕ) → Not (succ m ≡ zero : ℕ) =
|
|||
λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true;
|
||||
|
||||
|
||||
def0 not-succ-self : 0.(m : ℕ) → Not (m ≡ succ m : ℕ) =
|
||||
def0 not-succ-self : (m : ℕ) → Not (m ≡ succ m : ℕ) =
|
||||
λ m ⇒
|
||||
caseω m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
|
||||
case m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
|
||||
zero ⇒ zero-not-succ 0;
|
||||
succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq)
|
||||
}
|
||||
|
||||
|
||||
#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"]
|
||||
def eq? : DecEq ℕ =
|
||||
λ m ⇒
|
||||
caseω m
|
||||
|
@ -86,28 +118,48 @@ def eq? : DecEq ℕ =
|
|||
def eqb : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ dec.bool (m ≡ n : ℕ) (eq? m n);
|
||||
|
||||
|
||||
def0 plus-zero : 0.(m : ℕ) → m ≡ plus m 0 : ℕ =
|
||||
def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ =
|
||||
λ m ⇒
|
||||
caseω m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
|
||||
zero ⇒ δ _ ⇒ zero;
|
||||
succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
|
||||
case m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
|
||||
zero ⇒ δ _ ⇒ 0;
|
||||
succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
|
||||
};
|
||||
|
||||
def0 plus-succ : 0.(m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ =
|
||||
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 {
|
||||
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 : 0.(m n : ℕ) → plus m n ≡ plus n m : ℕ =
|
||||
def0 plus-comm : (m n : ℕ) → plus m n ≡ plus n m : ℕ =
|
||||
λ m n ⇒
|
||||
caseω m return m' ⇒ plus m' n ≡ plus n m' : ℕ of {
|
||||
case m return m' ⇒ plus m' n ≡ plus n m' : ℕ of {
|
||||
zero ⇒ plus-zero n;
|
||||
succ m', ω.ih ⇒
|
||||
succ m', ih ⇒
|
||||
trans ℕ (succ (plus m' n)) (succ (plus n m')) (plus n (succ m'))
|
||||
(δ 𝑖 ⇒ succ (ih @𝑖))
|
||||
(plus-succ n m')
|
||||
};
|
||||
|
||||
def0 times-zero : (m : ℕ) → 0 ≡ timesω m 0 : ℕ =
|
||||
λ m ⇒
|
||||
case m return m' ⇒ 0 ≡ timesω m' 0 : ℕ of {
|
||||
zero ⇒ δ _ ⇒ zero;
|
||||
succ m', ih ⇒ ih
|
||||
};
|
||||
|
||||
{-
|
||||
-- unfinished
|
||||
def0 times-succ : (m n : ℕ) → plus m (timesω m n) ≡ timesω m (succ n) : ℕ =
|
||||
λ m n ⇒
|
||||
case m
|
||||
return m' ⇒ plus m' (timesω m' n) ≡ timesω m' (succ n) : ℕ
|
||||
of {
|
||||
zero ⇒ δ _ ⇒ 0;
|
||||
succ m', ih ⇒
|
||||
δ 𝑖 ⇒ plus (succ n) (ih @𝑖)
|
||||
};
|
||||
-}
|
||||
|
||||
}
|
||||
|
|
|
@ -1,55 +1,74 @@
|
|||
namespace pair {
|
||||
|
||||
def0 Σ : 0.(A : ★) → 0.(0.A → ★) → ★ = λ A B ⇒ (x : A) × B x;
|
||||
def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x;
|
||||
|
||||
def fst : 0.(A : ★) → 0.(B : 0.A → ★) → ω.(Σ A B) → A =
|
||||
{-
|
||||
-- now builtins
|
||||
def fst : 0.(A : ★) → 0.(B : A → ★) → ω.(Σ A B) → A =
|
||||
λ A B p ⇒ caseω p return A of { (x, _) ⇒ x };
|
||||
|
||||
def snd : 0.(A : ★) → 0.(B : 0.A → ★) → ω.(p : Σ A B) → B (fst A B p) =
|
||||
def snd : 0.(A : ★) → 0.(B : A → ★) → ω.(p : Σ A B) → B (fst A B p) =
|
||||
λ A B p ⇒ caseω p return p' ⇒ B (fst A B p') of { (_, y) ⇒ y };
|
||||
-}
|
||||
|
||||
def uncurry :
|
||||
0.(A : ★) → 0.(B : 0.A → ★) → 0.(C : 0.(x : A) → 0.(B x) → ★) →
|
||||
1.(f : 1.(x : A) → 1.(y : B x) → C x y) →
|
||||
1.(p : Σ A B) → C (fst A B p) (snd A B p) =
|
||||
0.(A : ★) → 0.(B : A → ★) → 0.(C : (x : A) → (B x) → ★) →
|
||||
(f : (x : A) → (y : B x) → C x y) →
|
||||
(p : Σ A B) → C (fst p) (snd p) =
|
||||
λ A B C f p ⇒
|
||||
case1 p return p' ⇒ C (fst A B p') (snd A B p') of { (x, y) ⇒ f x y };
|
||||
case p return p' ⇒ C (fst p') (snd p') of { (x, y) ⇒ f x y };
|
||||
|
||||
def uncurry' :
|
||||
0.(A B C : ★) → 1.(1.A → 1.B → C) → 1.(A × B) → C =
|
||||
0.(A B C : ★) → (A → B → C) → (A × B) → C =
|
||||
λ A B C ⇒ uncurry A (λ _ ⇒ B) (λ _ _ ⇒ C);
|
||||
|
||||
def curry :
|
||||
0.(A : ★) → 0.(B : 0.A → ★) → 0.(C : 0.(Σ A B) → ★) →
|
||||
1.(f : 1.(p : Σ A B) → C p) → 1.(x : A) → 1.(y : B x) → C (x, y) =
|
||||
0.(A : ★) → 0.(B : A → ★) → 0.(C : (Σ A B) → ★) →
|
||||
(f : (p : Σ A B) → C p) → (x : A) → (y : B x) → C (x, y) =
|
||||
λ A B C f x y ⇒ f (x, y);
|
||||
|
||||
def curry' :
|
||||
0.(A B C : ★) → 1.(1.(A × B) → C) → 1.A → 1.B → C =
|
||||
0.(A B C : ★) → (A × B → C) → A → B → C =
|
||||
λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C);
|
||||
|
||||
def0 fst-snd :
|
||||
0.(A : ★) → 0.(B : 0.A → ★) →
|
||||
1.(p : Σ A B) → p ≡ (fst A B p, snd A B p) : Σ A B =
|
||||
(A : ★) → (B : A → ★) →
|
||||
(p : Σ A B) → p ≡ (fst p, snd p) : Σ A B =
|
||||
λ A B p ⇒
|
||||
case1 p
|
||||
return p' ⇒ p' ≡ (fst A B p', snd A B p') : Σ A B
|
||||
case p
|
||||
return p' ⇒ p' ≡ (fst p', snd p') : Σ A B
|
||||
of { (x, y) ⇒ δ 𝑖 ⇒ (x, y) };
|
||||
|
||||
def0 fst-eq :
|
||||
(A : ★) → (B : A → ★) →
|
||||
(p q : Σ A B) → p ≡ q : Σ A B → fst p ≡ fst q : A =
|
||||
λ A B p q eq ⇒ δ 𝑖 ⇒ fst (eq @𝑖);
|
||||
|
||||
def0 snd-eq :
|
||||
(A : ★) → (B : A → ★) →
|
||||
(p q : Σ A B) → (eq : p ≡ q : Σ A B) →
|
||||
Eq (𝑖 ⇒ B (fst-eq A B p q eq @𝑖)) (snd p) (snd q) =
|
||||
λ A B p q eq ⇒ δ 𝑖 ⇒ snd (eq @𝑖);
|
||||
|
||||
def map :
|
||||
0.(A A' : ★) →
|
||||
0.(B : 0.A → ★) → 0.(B' : 0.A' → ★) →
|
||||
1.(f : 1.A → A') → 1.(g : 0.(x : A) → 1.(B x) → B' (f x)) →
|
||||
1.(Σ A B) → Σ A' B' =
|
||||
0.(B : A → ★) → 0.(B' : A' → ★) →
|
||||
(f : A → A') → (g : 0.(x : A) → (B x) → B' (f x)) →
|
||||
Σ A B → Σ A' B' =
|
||||
λ A A' B B' f g p ⇒
|
||||
case1 p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
|
||||
case p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
|
||||
|
||||
def map' : 0.(A A' B B' : ★) →
|
||||
1.(1.A → A') → 1.(1.B → B') → 1.(A × B) → A' × B' =
|
||||
def map' : 0.(A A' B B' : ★) → (A → A') → (B → B') → (A × B) → A' × B' =
|
||||
λ A A' B B' f g ⇒ map A A' (λ _ ⇒ B) (λ _ ⇒ B') f (λ _ ⇒ g);
|
||||
|
||||
def map-fst : 0.(A A' B : ★) → (A → A') → A × B → A' × B =
|
||||
λ A A' B f ⇒ map' A A' B B f (λ x ⇒ x);
|
||||
|
||||
def map-snd : 0.(A B B' : ★) → (B → B') → A × B → A × B' =
|
||||
λ A B B' f ⇒ map' A A B B' (λ x ⇒ x) f;
|
||||
|
||||
}
|
||||
|
||||
def0 Σ = pair.Σ;
|
||||
def fst = pair.fst;
|
||||
def snd = pair.snd;
|
||||
-- def fst = pair.fst;
|
||||
-- def snd = pair.snd;
|
||||
|
|
77
examples/qty.quox
Normal file
77
examples/qty.quox
Normal file
|
@ -0,0 +1,77 @@
|
|||
def0 Qty : ★ = {"zero", one, any}
|
||||
|
||||
def dup : Qty → [ω.Qty] =
|
||||
λ π ⇒ case π return [ω.Qty] of {
|
||||
'zero ⇒ ['zero];
|
||||
'one ⇒ ['one];
|
||||
'any ⇒ ['any];
|
||||
}
|
||||
|
||||
def drop : 0.(A : ★) → Qty → A → A =
|
||||
λ A π x ⇒ case π return A of {
|
||||
'zero ⇒ x;
|
||||
'one ⇒ x;
|
||||
'any ⇒ x;
|
||||
}
|
||||
|
||||
def if-zero : 0.(A : ★) → Qty → ω.A → ω.A → A =
|
||||
λ A π z nz ⇒
|
||||
case π return A of { 'zero ⇒ z; 'one ⇒ nz; 'any ⇒ nz }
|
||||
|
||||
def plus : Qty → Qty → Qty =
|
||||
λ π ρ ⇒
|
||||
case π return Qty of {
|
||||
'zero ⇒ ρ;
|
||||
'one ⇒ if-zero Qty ρ 'one 'any;
|
||||
'any ⇒ drop Qty ρ 'any;
|
||||
}
|
||||
|
||||
def times : Qty → Qty → Qty =
|
||||
λ π ρ ⇒
|
||||
case π return Qty of {
|
||||
'zero ⇒ drop Qty ρ 'zero;
|
||||
'one ⇒ ρ;
|
||||
'any ⇒ if-zero Qty ρ 'zero 'any;
|
||||
}
|
||||
|
||||
def0 FUN : Qty → (A : ★) → (A → ★) → ★ =
|
||||
λ π A B ⇒
|
||||
case π return ★ of {
|
||||
'zero ⇒ 0.(x : A) → B x;
|
||||
'one ⇒ 1.(x : A) → B x;
|
||||
'any ⇒ ω.(x : A) → B x;
|
||||
}
|
||||
|
||||
def0 Fun : Qty → ★ → ★ → ★ =
|
||||
λ π A B ⇒ FUN π A (λ _ ⇒ B)
|
||||
|
||||
def0 Box : Qty → ★ → ★ =
|
||||
λ π A ⇒
|
||||
case π return ★ of {
|
||||
'zero ⇒ [0.A];
|
||||
'one ⇒ [1.A];
|
||||
'any ⇒ [ω.A];
|
||||
}
|
||||
|
||||
def0 unbox : (π : Qty) → (A : ★) → Box π A → A =
|
||||
λ π A ⇒
|
||||
case π return π' ⇒ Box π' A → A of {
|
||||
'zero ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
|
||||
'one ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
|
||||
'any ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
|
||||
}
|
||||
|
||||
def0 unbox0 = unbox 'zero
|
||||
def0 unbox1 = unbox 'one
|
||||
def0 unboxω = unbox 'any
|
||||
|
||||
def apply : (π : Qty) → 0.(A : ★) → 0.(B : A → ★) →
|
||||
FUN π A B → (x : Box π A) → B (unbox π A x) =
|
||||
λ π A B ⇒
|
||||
case π
|
||||
return π' ⇒ FUN π' A B → (x : Box π' A) → B (unbox π' A x)
|
||||
of {
|
||||
'zero ⇒ λ f x ⇒ case x return x' ⇒ B (unbox0 A x') of { [x] ⇒ f x };
|
||||
'one ⇒ λ f x ⇒ case x return x' ⇒ B (unbox1 A x') of { [x] ⇒ f x };
|
||||
'any ⇒ λ f x ⇒ case x return x' ⇒ B (unboxω A x') of { [x] ⇒ f x };
|
||||
}
|
164
exe/CompileMonad.idr
Normal file
164
exe/CompileMonad.idr
Normal file
|
@ -0,0 +1,164 @@
|
|||
module CompileMonad
|
||||
|
||||
import Quox.Syntax as Q
|
||||
import Quox.Definition as Q
|
||||
import Quox.Untyped.Syntax as U
|
||||
import Quox.Parser
|
||||
import Quox.Untyped.Erase
|
||||
import Quox.Untyped.Scheme
|
||||
import Quox.Pretty
|
||||
import Quox.Log
|
||||
import Options
|
||||
import Output
|
||||
import Error
|
||||
|
||||
import System.File
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Control.Eff
|
||||
|
||||
%default total
|
||||
|
||||
%hide Doc.(>>=)
|
||||
%hide Core.(>>=)
|
||||
|
||||
%hide FromParser.Error
|
||||
%hide Erase.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
|
||||
public export
|
||||
record State where
|
||||
constructor MkState
|
||||
seen : IORef SeenSet
|
||||
defs : IORef Q.Definitions
|
||||
ns : IORef Mods
|
||||
suf : IORef NameSuf
|
||||
%name CompileMonad.State state
|
||||
|
||||
export %inline
|
||||
newState : HasIO io => io State
|
||||
newState = pure $ MkState {
|
||||
seen = !(newIORef empty),
|
||||
defs = !(newIORef empty),
|
||||
ns = !(newIORef [<]),
|
||||
suf = !(newIORef 0)
|
||||
}
|
||||
|
||||
|
||||
public export
|
||||
data CompileTag = OPTS | STATE
|
||||
|
||||
public export
|
||||
Compile : List (Type -> Type)
|
||||
Compile =
|
||||
[Except Error,
|
||||
ReaderL STATE State, ReaderL OPTS Options, Log,
|
||||
LoadFile, IO]
|
||||
|
||||
|
||||
export %inline
|
||||
handleLog : IORef LevelStack -> OpenFile -> LogL x a -> IOErr Error a
|
||||
handleLog ref f l = case f of
|
||||
OConsole ch => handleLogIO (const $ pure ()) ref (consoleHandle ch) l
|
||||
OFile _ h => handleLogIO (const $ pure ()) ref h l
|
||||
ONone => do
|
||||
lvls <- readIORef ref
|
||||
lenRef <- newIORef (length lvls)
|
||||
res <- handleLogDiscardIO lenRef l
|
||||
writeIORef ref $ fixupDiscardedLog !(readIORef lenRef) lvls
|
||||
pure res
|
||||
|
||||
private %inline
|
||||
withLogFile : Options ->
|
||||
(IORef LevelStack -> OpenFile -> IO (Either Error a)) ->
|
||||
IO (Either Error a)
|
||||
withLogFile opts act = do
|
||||
lvlStack <- newIORef $ singleton opts.logLevels
|
||||
withOutFile CErr opts.logFile fromError $ act lvlStack
|
||||
where
|
||||
fromError : String -> FileError -> IO (Either Error a)
|
||||
fromError file err = pure $ Left $ WriteError file err
|
||||
|
||||
export covering %inline
|
||||
runCompile : Options -> State -> Eff Compile a -> IO (Either Error a)
|
||||
runCompile opts state act = do
|
||||
withLogFile opts $ \lvls, logFile =>
|
||||
fromIOErr $ runEff act $ with Union.(::)
|
||||
[handleExcept (\e => ioLeft e),
|
||||
handleReaderConst state,
|
||||
handleReaderConst opts,
|
||||
handleLog lvls logFile,
|
||||
handleLoadFileIOE loadError ParseError state.seen opts.include,
|
||||
liftIO]
|
||||
|
||||
private %inline
|
||||
rethrowFileC : String -> Either FileError a -> Eff Compile a
|
||||
rethrowFileC f = rethrow . mapFst (WriteError f)
|
||||
|
||||
|
||||
export %inline
|
||||
outputStr : OpenFile -> Lazy String -> Eff Compile ()
|
||||
outputStr ONone _ = pure ()
|
||||
outputStr (OConsole COut) str = putStr str
|
||||
outputStr (OConsole CErr) str = fPutStr stderr str >>= rethrowFileC "<stderr>"
|
||||
outputStr (OFile f h) str = fPutStr h str >>= rethrowFileC f
|
||||
|
||||
export %inline
|
||||
outputDocs : OpenFile ->
|
||||
({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) ->
|
||||
Eff Compile ()
|
||||
outputDocs file docs = do
|
||||
opts <- askAt OPTS
|
||||
for_ (runPretty opts (toOutFile file) docs) $ \x =>
|
||||
outputStr file $ render (Opts opts.width) x
|
||||
|
||||
export %inline
|
||||
outputDoc : OpenFile ->
|
||||
({opts : LayoutOpts} -> Eff Pretty (Doc opts)) -> Eff Compile ()
|
||||
outputDoc file doc = outputDocs file $ singleton <$> doc
|
||||
|
||||
|
||||
public export
|
||||
data StopTag = STOP
|
||||
|
||||
public export
|
||||
CompileStop : List (Type -> Type)
|
||||
CompileStop = FailL STOP :: Compile
|
||||
|
||||
export %inline
|
||||
withEarlyStop : Eff CompileStop () -> Eff Compile ()
|
||||
withEarlyStop = ignore . runFailAt STOP
|
||||
|
||||
export %inline
|
||||
stopHere : Has (FailL STOP) fs => Eff fs ()
|
||||
stopHere = failAt STOP
|
||||
|
||||
|
||||
export %inline
|
||||
liftFromParser : Eff FromParserIO a -> Eff Compile a
|
||||
liftFromParser act =
|
||||
runEff act $ with Union.(::)
|
||||
[handleExcept $ \err => throw $ FromParserError err,
|
||||
handleStateIORef !(asksAt STATE defs),
|
||||
handleStateIORef !(asksAt STATE ns),
|
||||
handleStateIORef !(asksAt STATE suf),
|
||||
\g => send g,
|
||||
\g => send g]
|
||||
|
||||
export %inline
|
||||
liftErase : Q.Definitions -> Eff Erase a -> Eff Compile a
|
||||
liftErase defs act =
|
||||
runEff act
|
||||
[handleExcept $ \err => throw $ EraseError err,
|
||||
handleStateIORef !(asksAt STATE suf),
|
||||
\g => send g]
|
||||
|
||||
export %inline
|
||||
liftScheme : Eff Scheme a -> Eff Compile (a, List Id)
|
||||
liftScheme act = do
|
||||
runEff [|MkPair act (getAt MAIN)|]
|
||||
[handleStateIORef !(newIORef empty),
|
||||
handleStateIORef !(newIORef [])]
|
49
exe/Error.idr
Normal file
49
exe/Error.idr
Normal file
|
@ -0,0 +1,49 @@
|
|||
module Error
|
||||
|
||||
import Quox.Pretty
|
||||
import Quox.Parser
|
||||
import Quox.Untyped.Erase
|
||||
import Quox.Untyped.Scheme
|
||||
import Options
|
||||
import Output
|
||||
|
||||
import System.File
|
||||
|
||||
|
||||
public export
|
||||
data Error =
|
||||
ParseError String Parser.Error
|
||||
| FromParserError FromParser.Error
|
||||
| EraseError Erase.Error
|
||||
| WriteError FilePath FileError
|
||||
| NoMain
|
||||
| MultipleMains (List Scheme.Id)
|
||||
|
||||
%hide FromParser.Error
|
||||
%hide Erase.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
export
|
||||
loadError : Loc -> FilePath -> FileError -> Error
|
||||
loadError loc file err = FromParserError $ LoadError loc file err
|
||||
|
||||
export
|
||||
prettyError : {opts : LayoutOpts} -> Error -> Eff Pretty (Doc opts)
|
||||
prettyError (ParseError file e) = prettyParseError file e
|
||||
prettyError (FromParserError e) = FromParser.prettyError True e
|
||||
prettyError (EraseError e) = Erase.prettyError True e
|
||||
prettyError NoMain = pure "no #[main] function given"
|
||||
prettyError (MultipleMains xs) =
|
||||
pure $ sep ["multiple #[main] functions given:",
|
||||
separateLoose "," !(traverse prettyId xs)]
|
||||
prettyError (WriteError file e) = pure $
|
||||
hangSingle 2 (text "couldn't write file \{file}:") (pshow e)
|
||||
|
||||
export
|
||||
dieError : Options -> Error -> IO a
|
||||
dieError opts e =
|
||||
die (Opts opts.width) $
|
||||
runPretty ({outFile := Console} opts) Console $
|
||||
prettyError e
|
131
exe/Main.idr
131
exe/Main.idr
|
@ -1,46 +1,118 @@
|
|||
module Main
|
||||
|
||||
import Quox.Syntax
|
||||
import Quox.Syntax as Q
|
||||
import Quox.Definition as Q
|
||||
import Quox.Untyped.Syntax as U
|
||||
import Quox.Parser
|
||||
import Quox.Definition
|
||||
import Quox.Untyped.Erase
|
||||
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
|
||||
|
||||
private
|
||||
Opts : LayoutOpts
|
||||
Opts = Opts 80
|
||||
%default total
|
||||
|
||||
%hide Doc.(>>=)
|
||||
%hide Core.(>>=)
|
||||
|
||||
%hide FromParser.Error
|
||||
%hide Erase.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
private
|
||||
putDoc : Doc Opts -> IO ()
|
||||
putDoc = putStr . render Opts
|
||||
Step : Type -> Type -> Type
|
||||
Step a b = OpenFile -> a -> Eff Compile b
|
||||
|
||||
private
|
||||
die : Doc Opts -> IO a
|
||||
die err = do putDoc err; exitFailure
|
||||
step : ConsoleChannel -> Phase -> OutFile -> Step a b -> a -> Eff CompileStop b
|
||||
step console phase file act x = do
|
||||
opts <- askAt OPTS
|
||||
res <- withOutFile console file fromError $ \h => lift $ act h x
|
||||
when (opts.until == Just phase) stopHere
|
||||
pure res
|
||||
where
|
||||
fromError : String -> FileError -> Eff CompileStop c
|
||||
fromError file err = throw $ WriteError file err
|
||||
|
||||
private
|
||||
prettySig : {opts : _} -> Name -> Definition -> Eff Pretty (Doc opts)
|
||||
prettySig name def = do
|
||||
qty <- prettyQty def.qty.fst
|
||||
name <- prettyFree name
|
||||
type <- prettyTerm [<] [<] def.type
|
||||
hangDSingle (hsep [hcat [qty, !dotD, name], !colonD]) type
|
||||
|
||||
export
|
||||
private covering
|
||||
parse : Step String PFile
|
||||
parse h file = do
|
||||
Just ast <- loadFile noLoc file
|
||||
| Nothing => pure []
|
||||
outputStr h $ show ast
|
||||
pure ast
|
||||
|
||||
private covering
|
||||
check : Step PFile (List Q.NDefinition)
|
||||
check h decls =
|
||||
map concat $ for decls $ \decl => do
|
||||
defs <- liftFromParser $ fromPTopLevel decl
|
||||
outputDocs h $ traverse (\(x, d) => prettyDef x d) defs
|
||||
pure defs
|
||||
|
||||
private covering
|
||||
erase : Step (List Q.NDefinition) (List U.NDefinition)
|
||||
erase h defList =
|
||||
for defList $ \(x, def) => do
|
||||
def <- liftErase defs $ eraseDef defs x def
|
||||
outputDoc h $ U.prettyDef x def
|
||||
pure (x, def)
|
||||
where defs = SortedMap.fromList defList
|
||||
|
||||
private covering
|
||||
scheme : Step (List U.NDefinition) (List Sexp, List Id)
|
||||
scheme h defs = do
|
||||
sexps' <- for defs $ \(x, d) => do
|
||||
(msexp, mains) <- liftScheme $ defToScheme x d
|
||||
outputDoc h $ case msexp of
|
||||
Just s => prettySexp s
|
||||
Nothing => pure $ hsep [";;", prettyName x, "erased"]
|
||||
pure (msexp, mains)
|
||||
pure $ bimap catMaybes concat $ unzip sexps'
|
||||
|
||||
private covering
|
||||
output : Step (List Sexp, List Id) ()
|
||||
output h (sexps, mains) = do
|
||||
main <- case mains of
|
||||
[m] => pure m
|
||||
[] => throw NoMain
|
||||
_ => throw $ MultipleMains mains
|
||||
lift $ outputDocs h $ do
|
||||
res <- traverse prettySexp sexps
|
||||
runner <- makeRunMain main
|
||||
pure $ text Scheme.prelude :: res ++ [runner]
|
||||
|
||||
private covering
|
||||
processFile : String -> Eff Compile ()
|
||||
processFile file = withEarlyStop $ pipeline !(askAt OPTS) file where
|
||||
pipeline : Options -> String -> Eff CompileStop ()
|
||||
pipeline opts =
|
||||
step CErr Parse opts.dump.parse Main.parse >=>
|
||||
step CErr Check opts.dump.check Main.check >=>
|
||||
step CErr Erase opts.dump.erase Main.erase >=>
|
||||
step CErr Scheme opts.dump.scheme Main.scheme >=>
|
||||
step COut End opts.outFile Main.output
|
||||
|
||||
|
||||
export covering
|
||||
main : IO ()
|
||||
main = do
|
||||
seen <- newIORef SortedSet.empty
|
||||
defs <- newIORef SortedMap.empty
|
||||
suf <- newIORef $ the Nat 0
|
||||
for_ (drop 1 !getArgs) $ \file => do
|
||||
putStrLn "checking \{file}"
|
||||
Right res <- fromParserIO ["."] seen suf defs $ loadProcessFile noLoc file
|
||||
| Left err => die $ runPrettyColor $ prettyError True err
|
||||
for_ res $ \(name, def) => putDoc $ runPrettyColor $ prettySig name def
|
||||
(_, opts, files) <- options
|
||||
case !(runCompile opts !newState $ traverse_ processFile files) of
|
||||
Right () => pure ()
|
||||
Left e => dieError opts e
|
||||
|
||||
|
||||
-----------------------------------
|
||||
{-
|
||||
|
@ -55,6 +127,13 @@ text _ =
|
|||
#" /_/"#,
|
||||
""]
|
||||
|
||||
-- ["",
|
||||
-- #" __ _ _ _ _____ __"#,
|
||||
-- #"/ _` | || / _ \ \ /"#,
|
||||
-- #"\__, |\_,_\___/_\_\"#,
|
||||
-- #" |_|"#,
|
||||
-- ""]
|
||||
|
||||
private
|
||||
qtuwu : PrettyOpts -> List String
|
||||
qtuwu opts =
|
||||
|
|
258
exe/Options.idr
Normal file
258
exe/Options.idr
Normal file
|
@ -0,0 +1,258 @@
|
|||
module Options
|
||||
|
||||
import Quox.Pretty
|
||||
import Quox.Log
|
||||
import Data.DPair
|
||||
import Data.SortedMap
|
||||
import System
|
||||
import System.Console.GetOpt
|
||||
import System.File
|
||||
import System.Term
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
public export
|
||||
data OutFile = File String | Console | NoOut
|
||||
%name OutFile f
|
||||
%runElab derive "OutFile" [Eq, Show]
|
||||
|
||||
public export
|
||||
data Phase = Parse | Check | Erase | Scheme | End
|
||||
%name Phase p
|
||||
%runElab derive "Phase" [Eq, Show]
|
||||
|
||||
||| a list of all intermediate `Phase`s (excluding `End`)
|
||||
public export %inline
|
||||
allPhases : List Phase
|
||||
allPhases = %runElab do
|
||||
cs <- getCons $ fst !(lookupName "Phase")
|
||||
traverse (check . var) $ fromMaybe [] $ init' cs
|
||||
|
||||
||| `Guess` is `Term` for a terminal and `NoHL` for a file
|
||||
public export
|
||||
data HLType = Guess | NoHL | Term | Html
|
||||
%runElab derive "HLType" [Eq, Show]
|
||||
|
||||
public export
|
||||
record Dump where
|
||||
constructor MkDump
|
||||
parse, check, erase, scheme : OutFile
|
||||
%name Dump dump
|
||||
%runElab derive "Dump" [Show]
|
||||
|
||||
public export
|
||||
record Options where
|
||||
constructor MkOpts
|
||||
include : List String
|
||||
dump : Dump
|
||||
outFile : OutFile
|
||||
until : Maybe Phase
|
||||
hlType : HLType
|
||||
flavor : Pretty.Flavor
|
||||
width : Nat
|
||||
logLevels : LogLevels
|
||||
logFile : OutFile
|
||||
%name Options opts
|
||||
%runElab derive "Options" [Show]
|
||||
|
||||
export
|
||||
defaultWidth : IO Nat
|
||||
defaultWidth = do
|
||||
w <- cast {to = Nat} <$> getTermCols
|
||||
pure $ if w == 0 then 80 else w
|
||||
|
||||
export
|
||||
defaultOpts : IO Options
|
||||
defaultOpts = pure $ MkOpts {
|
||||
include = ["."],
|
||||
dump = MkDump NoOut NoOut NoOut NoOut,
|
||||
outFile = Console,
|
||||
until = Nothing,
|
||||
hlType = Guess,
|
||||
flavor = Unicode,
|
||||
width = !defaultWidth,
|
||||
logLevels = defaultLogLevels,
|
||||
logFile = Console
|
||||
}
|
||||
|
||||
private
|
||||
data HelpType = Common | All
|
||||
|
||||
private
|
||||
data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options)
|
||||
%name OptAction act
|
||||
|
||||
private
|
||||
toOutFile : String -> OutFile
|
||||
toOutFile "" = NoOut
|
||||
toOutFile "-" = Console
|
||||
toOutFile f = File f
|
||||
|
||||
private
|
||||
toPhase : String -> OptAction
|
||||
toPhase str =
|
||||
let lstr = toLower str in
|
||||
case find (\p => toLower (show p) == lstr) allPhases of
|
||||
Just p => Ok $ setPhase p
|
||||
Nothing => Err "unknown phase name \{show str}\nphases: \{phaseNames}"
|
||||
where
|
||||
phaseNames = joinBy ", " $ map (toLower . show) allPhases
|
||||
|
||||
defConsole : OutFile -> OutFile
|
||||
defConsole NoOut = Console
|
||||
defConsole f = f
|
||||
|
||||
setPhase : Phase -> Options -> Options
|
||||
setPhase Parse = {until := Just Parse, dump.parse $= defConsole}
|
||||
setPhase Check = {until := Just Check, dump.check $= defConsole}
|
||||
setPhase Erase = {until := Just Erase, dump.erase $= defConsole}
|
||||
setPhase Scheme = {until := Just Scheme, dump.scheme $= defConsole}
|
||||
setPhase End = id
|
||||
|
||||
private
|
||||
toWidth : String -> OptAction
|
||||
toWidth s = case parsePositive s of
|
||||
Just n => Ok {width := n}
|
||||
Nothing => Err "invalid width: \{show s}"
|
||||
|
||||
private
|
||||
toHLType : String -> OptAction
|
||||
toHLType str = case toLower str of
|
||||
"none" => Ok {hlType := NoHL}
|
||||
"term" => Ok {hlType := Term}
|
||||
"html" => Ok {hlType := Html}
|
||||
_ => Err "unknown highlighting type \{show str}\ntypes: term, html, none"
|
||||
|
||||
||| like ghc, `-i ""` clears the search path;
|
||||
||| `-i a:b:c` adds `a`, `b`, `c` to the end
|
||||
private
|
||||
dirListFlag : String -> List String -> List String
|
||||
dirListFlag "" val = []
|
||||
dirListFlag dirs val = val ++ toList (split (== ':') dirs)
|
||||
|
||||
private
|
||||
splitLogFlag : String -> Either String (List (Maybe LogCategory, LogLevel))
|
||||
splitLogFlag = traverse flag1 . toList . split (== ':') where
|
||||
parseLogCategory : String -> Either String LogCategory
|
||||
parseLogCategory cat = do
|
||||
let Just cat = toLogCategory cat
|
||||
| _ => let catList = joinBy ", " logCategories in
|
||||
Left "unknown log category. categories are:\n\{catList}"
|
||||
pure cat
|
||||
|
||||
parseLogLevel : String -> Either String LogLevel
|
||||
parseLogLevel lvl = do
|
||||
let Just lvl = parsePositive lvl
|
||||
| _ => Left "log level \{lvl} not a number"
|
||||
let Just lvl = toLogLevel lvl
|
||||
| _ => Left "log level \{show lvl} out of range 0–\{show maxLogLevel}"
|
||||
pure lvl
|
||||
|
||||
flag1 : String -> Either String (Maybe LogCategory, LogLevel)
|
||||
flag1 str = do
|
||||
let (first, second) = break (== '=') str
|
||||
case strM second of
|
||||
StrCons '=' lvl => do
|
||||
cat <- parseLogCategory first
|
||||
lvl <- parseLogLevel lvl
|
||||
pure (Just cat, lvl)
|
||||
StrNil => (Nothing,) <$> parseLogLevel first
|
||||
_ => Left "invalid log flag \{str}"
|
||||
|
||||
private
|
||||
setLogFlag : LogLevels -> (Maybe LogCategory, LogLevel) -> LogLevels
|
||||
setLogFlag lvls (Nothing, lvl) = {defLevel := lvl} lvls
|
||||
setLogFlag lvls (Just name, lvl) = {levels $= ((name, lvl) ::)} lvls
|
||||
|
||||
private
|
||||
logFlag : String -> OptAction
|
||||
logFlag str = case splitLogFlag str of
|
||||
Left err => Err err
|
||||
Right flags => Ok $ \o => {logLevels := foldl setLogFlag o.logLevels flags} o
|
||||
|
||||
private
|
||||
commonOptDescrs' : List (OptDescr OptAction)
|
||||
commonOptDescrs' = [
|
||||
MkOpt ['i'] ["include"]
|
||||
(ReqArg (\is => Ok {include $= dirListFlag is}) "<dir>:<dir>...")
|
||||
"add directories to look for source files",
|
||||
MkOpt ['o'] ["output"] (ReqArg (\s => Ok {outFile := toOutFile s}) "<file>")
|
||||
"output file (\"-\" for stdout, \"\" for no output)",
|
||||
MkOpt ['P'] ["phase"] (ReqArg toPhase "<phase>")
|
||||
"stop after the given phase",
|
||||
MkOpt ['l'] ["log"] (ReqArg logFlag "[<cat>=]<n>:...")
|
||||
"set log level",
|
||||
MkOpt ['L'] ["log-file"] (ReqArg (\s => Ok {logFile := toOutFile s}) "<file>")
|
||||
"set log output file"
|
||||
]
|
||||
|
||||
private
|
||||
extraOptDescrs : List (OptDescr OptAction)
|
||||
extraOptDescrs = [
|
||||
MkOpt [] ["unicode"] (NoArg $ Ok {flavor := Unicode})
|
||||
"use unicode syntax when printing (default)",
|
||||
MkOpt [] ["ascii"] (NoArg $ Ok {flavor := Ascii})
|
||||
"use ascii syntax when printing",
|
||||
MkOpt [] ["width"] (ReqArg toWidth "<width>")
|
||||
"max output width (defaults to terminal width)",
|
||||
MkOpt [] ["color", "colour"] (ReqArg toHLType "<type>")
|
||||
"select highlighting type",
|
||||
|
||||
MkOpt [] ["dump-parse"]
|
||||
(ReqArg (\s => Ok {dump.parse := toOutFile s}) "<file>")
|
||||
"dump AST",
|
||||
MkOpt [] ["dump-check"]
|
||||
(ReqArg (\s => Ok {dump.check := toOutFile s}) "<file>")
|
||||
"dump typechecker output",
|
||||
MkOpt [] ["dump-erase"]
|
||||
(ReqArg (\s => Ok {dump.erase := toOutFile s}) "<file>")
|
||||
"dump erasure output",
|
||||
MkOpt [] ["dump-scheme"]
|
||||
(ReqArg (\s => Ok {dump.scheme := toOutFile s}) "<file>")
|
||||
"dump scheme output (without prelude)"
|
||||
]
|
||||
|
||||
private
|
||||
helpOptDescrs : List (OptDescr OptAction)
|
||||
helpOptDescrs = [
|
||||
MkOpt ['h'] ["help"] (NoArg $ ShowHelp Common) "show common options",
|
||||
MkOpt [] ["help-all"] (NoArg $ ShowHelp All) "show all options"
|
||||
]
|
||||
|
||||
commonOptDescrs = commonOptDescrs' ++ helpOptDescrs
|
||||
allOptDescrs = commonOptDescrs' ++ extraOptDescrs ++ helpOptDescrs
|
||||
|
||||
export
|
||||
usageHeader : String
|
||||
usageHeader = trim """
|
||||
quox [options] [file.quox ...]
|
||||
rawr
|
||||
"""
|
||||
|
||||
export
|
||||
usage : List (OptDescr _) -> IO a
|
||||
usage ds = do
|
||||
ignore $ fPutStr stderr $ usageInfo usageHeader ds
|
||||
exitSuccess
|
||||
|
||||
private
|
||||
applyAction : Options -> OptAction -> IO Options
|
||||
applyAction opts (ShowHelp Common) = usage commonOptDescrs
|
||||
applyAction opts (ShowHelp All) = usage allOptDescrs
|
||||
applyAction opts (Err err) = die err
|
||||
applyAction opts (Ok f) = pure $ f opts
|
||||
|
||||
export
|
||||
options : IO (String, Options, List String)
|
||||
options = do
|
||||
app :: args <- getArgs
|
||||
| [] => die "couldn't get command line arguments"
|
||||
let res = getOpt Permute allOptDescrs args
|
||||
unless (null res.errors) $
|
||||
die $ trim $ concat res.errors
|
||||
unless (null res.unrecognized) $
|
||||
die "unrecognised options: \{joinBy ", " res.unrecognized}"
|
||||
opts <- foldlM applyAction !defaultOpts res.options
|
||||
pure (app, opts, res.nonOptions)
|
59
exe/Output.idr
Normal file
59
exe/Output.idr
Normal file
|
@ -0,0 +1,59 @@
|
|||
module Output
|
||||
|
||||
import Quox.Pretty
|
||||
import Options
|
||||
|
||||
import System.File
|
||||
import System
|
||||
|
||||
public export
|
||||
data ConsoleChannel = COut | CErr
|
||||
|
||||
export
|
||||
consoleHandle : ConsoleChannel -> File
|
||||
consoleHandle COut = stdout
|
||||
consoleHandle CErr = stderr
|
||||
|
||||
public export
|
||||
data OpenFile = OConsole ConsoleChannel | OFile String File | ONone
|
||||
|
||||
export
|
||||
toOutFile : OpenFile -> OutFile
|
||||
toOutFile (OConsole _) = Console
|
||||
toOutFile (OFile f _) = File f
|
||||
toOutFile ONone = NoOut
|
||||
|
||||
export
|
||||
withFile : HasIO m => String -> (String -> FileError -> m a) ->
|
||||
(OpenFile -> m a) -> m a
|
||||
withFile f catch act = Prelude.do
|
||||
res <- withFile f WriteTruncate pure (Prelude.map Right . act . OFile f)
|
||||
either (catch f) pure res
|
||||
|
||||
export
|
||||
withOutFile : HasIO m => ConsoleChannel -> OutFile ->
|
||||
(String -> FileError -> m a) -> (OpenFile -> m a) -> m a
|
||||
withOutFile _ (File f) catch act = withFile f catch act
|
||||
withOutFile ch Console catch act = act $ OConsole ch
|
||||
withOutFile _ NoOut catch act = act ONone
|
||||
|
||||
|
||||
|
||||
private
|
||||
hlFor : HLType -> OutFile -> HL -> Highlight
|
||||
hlFor Guess Console = highlightSGR
|
||||
hlFor Guess _ = noHighlight
|
||||
hlFor NoHL _ = noHighlight
|
||||
hlFor Term _ = highlightSGR
|
||||
hlFor Html _ = highlightHtml
|
||||
|
||||
export
|
||||
runPretty : Options -> OutFile -> Eff Pretty a -> a
|
||||
runPretty opts file act =
|
||||
runPrettyWith Outer opts.flavor (hlFor opts.hlType file) 2 act
|
||||
|
||||
export
|
||||
die : HasIO io => (opts : LayoutOpts) -> Doc opts -> io a
|
||||
die opts err = do
|
||||
ignore $ fPutStr stderr $ render opts err
|
||||
exitFailure
|
|
@ -1,7 +1,7 @@
|
|||
package quox
|
||||
version = 0
|
||||
|
||||
depends = base, contrib, elab-util, sop, quox-lib
|
||||
depends = base, contrib, elab-util, pretty-show, quox-lib
|
||||
|
||||
executable = quox
|
||||
main = Main
|
||||
|
|
15
golden-tests/Tests.idr
Normal file
15
golden-tests/Tests.idr
Normal file
|
@ -0,0 +1,15 @@
|
|||
module Tests
|
||||
|
||||
import Test.Golden
|
||||
import Language.Reflection
|
||||
import System
|
||||
import System.Path
|
||||
|
||||
%language ElabReflection
|
||||
|
||||
projDir = %runElab idrisDir ProjectDir
|
||||
testDir = projDir </> "tests"
|
||||
|
||||
tests = testsInDir { poolName = "quox golden tests", dirName = testDir }
|
||||
|
||||
main = runner [!tests]
|
4
golden-tests/quox-golden-tests.ipkg
Normal file
4
golden-tests/quox-golden-tests.ipkg
Normal file
|
@ -0,0 +1,4 @@
|
|||
package quox-golden-tests
|
||||
depends = quox, contrib, test
|
||||
executable = quox-golden-tests
|
||||
main = Tests
|
10
golden-tests/run-tests.sh
Executable file
10
golden-tests/run-tests.sh
Executable file
|
@ -0,0 +1,10 @@
|
|||
#!/bin/bash
|
||||
|
||||
set -e
|
||||
|
||||
quox="$PWD/../exe/build/exec/quox"
|
||||
run_tests="$PWD/build/exec/quox-golden-tests"
|
||||
test -f "$quox" || pack build quox
|
||||
test -f "$run_tests" || pack build quox-golden-tests
|
||||
|
||||
"$run_tests" "$quox" "$@"
|
0
golden-tests/tests/empty/empty.quox
Normal file
0
golden-tests/tests/empty/empty.quox
Normal file
0
golden-tests/tests/empty/expected
Normal file
0
golden-tests/tests/empty/expected
Normal file
2
golden-tests/tests/empty/run
Normal file
2
golden-tests/tests/empty/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
scheme "$1" empty.quox
|
33
golden-tests/tests/eta-singleton/eta-sing.quox
Normal file
33
golden-tests/tests/eta-singleton/eta-sing.quox
Normal file
|
@ -0,0 +1,33 @@
|
|||
-- inspired by https://github.com/agda/agda/issues/2556
|
||||
|
||||
postulate0 A : ★
|
||||
|
||||
def0 ZZ : ★ = 0 ≡ 0 : ℕ
|
||||
|
||||
def reflZ : ZZ = δ _ ⇒ 0
|
||||
|
||||
|
||||
namespace erased {
|
||||
def0 ZZA : ★ = 0.ZZ → A
|
||||
|
||||
def propeq : (x : ZZA) → x ≡ (λ _ ⇒ x reflZ) : ZZA =
|
||||
λ x ⇒ δ _ ⇒ x
|
||||
|
||||
def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
|
||||
λ P x p ⇒ p
|
||||
}
|
||||
|
||||
namespace unrestricted {
|
||||
def0 ZZA : ★ = ω.ZZ → A
|
||||
|
||||
def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
|
||||
λ P x p ⇒ p
|
||||
}
|
||||
|
||||
namespace linear {
|
||||
def0 ZZA : ★ = 1.ZZ → A
|
||||
|
||||
#[fail "λ _ ⇒ x reflZ is not equal to x"]
|
||||
def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
|
||||
λ P x p ⇒ p
|
||||
}
|
9
golden-tests/tests/eta-singleton/expected
Normal file
9
golden-tests/tests/eta-singleton/expected
Normal file
|
@ -0,0 +1,9 @@
|
|||
0.A : ★
|
||||
0.ZZ : ★
|
||||
ω.reflZ : ZZ
|
||||
0.erased.ZZA : ★
|
||||
ω.erased.propeq : 1.(x : erased.ZZA) → x ≡ (λ _ ⇒ x reflZ) : erased.ZZA
|
||||
ω.erased.defeq : 0.(P : 1.erased.ZZA → ★) → 0.(x : erased.ZZA) → 1.(P (λ _ ⇒ (x reflZ))) → P x
|
||||
0.unrestricted.ZZA : ★
|
||||
ω.unrestricted.defeq : 0.(P : 1.unrestricted.ZZA → ★) → 0.(x : unrestricted.ZZA) → 1.(P (λ _ ⇒ (x reflZ))) → P x
|
||||
0.linear.ZZA : ★
|
2
golden-tests/tests/eta-singleton/run
Normal file
2
golden-tests/tests/eta-singleton/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" eta-sing.quox
|
3
golden-tests/tests/file-not-found/expected
Normal file
3
golden-tests/tests/file-not-found/expected
Normal file
|
@ -0,0 +1,3 @@
|
|||
no location:
|
||||
couldn't load file nonexistent.quox
|
||||
File Not Found
|
2
golden-tests/tests/file-not-found/run
Normal file
2
golden-tests/tests/file-not-found/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" nonexistent.quox
|
12
golden-tests/tests/hello/expected
Normal file
12
golden-tests/tests/hello/expected
Normal file
|
@ -0,0 +1,12 @@
|
|||
0.IO : 1.★ → ★
|
||||
ω.print : 1.String → IO {ok}
|
||||
ω.main : IO {ok}
|
||||
IO = □
|
||||
print = scheme:(lambda (str) (builtin-io (display str) (newline)))
|
||||
#[main] main = print "hello 🐉"
|
||||
;; IO erased
|
||||
(define print
|
||||
(lambda (str) (builtin-io (display str) (newline))))
|
||||
(define main
|
||||
(print "hello \x1f409;"))
|
||||
hello 🐉
|
7
golden-tests/tests/hello/hello.quox
Normal file
7
golden-tests/tests/hello/hello.quox
Normal file
|
@ -0,0 +1,7 @@
|
|||
def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
|
||||
|
||||
#[compile-scheme "(lambda (str) (builtin-io (display str) (newline)))"]
|
||||
postulate print : String → IO {ok}
|
||||
|
||||
#[main]
|
||||
def main = print "hello 🐉"
|
2
golden-tests/tests/hello/run
Normal file
2
golden-tests/tests/hello/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
compile_run "$1" hello.quox hello.ss
|
3
golden-tests/tests/ill-typed-main/expected
Normal file
3
golden-tests/tests/ill-typed-main/expected
Normal file
|
@ -0,0 +1,3 @@
|
|||
ill-typed-main.quox:1:11-1:12:
|
||||
when checking a function declared as #[main] has type 1.IOState → {𝑎} × IOState
|
||||
expected a function type, but got ℕ
|
2
golden-tests/tests/ill-typed-main/ill-typed-main.quox
Normal file
2
golden-tests/tests/ill-typed-main/ill-typed-main.quox
Normal file
|
@ -0,0 +1,2 @@
|
|||
#[main]
|
||||
def main : ℕ = 5
|
2
golden-tests/tests/ill-typed-main/run
Normal file
2
golden-tests/tests/ill-typed-main/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" ill-typed-main.quox
|
2
golden-tests/tests/isprop-subsing/expected
Normal file
2
golden-tests/tests/isprop-subsing/expected
Normal file
|
@ -0,0 +1,2 @@
|
|||
0.IsProp : 1.★ → ★
|
||||
0.feq : 1.(A : ★) → 1.(f : IsProp A) → 1.(g : IsProp A) → f ≡ g : IsProp A
|
4
golden-tests/tests/isprop-subsing/isprop-subsing.quox
Normal file
4
golden-tests/tests/isprop-subsing/isprop-subsing.quox
Normal file
|
@ -0,0 +1,4 @@
|
|||
def0 IsProp : ★ → ★ = λ A ⇒ (x y : A) → x ≡ y : A
|
||||
|
||||
def0 feq : (A : ★) → (f g : IsProp A) → f ≡ g : IsProp A =
|
||||
λ A f g ⇒ δ _ ⇒ f
|
2
golden-tests/tests/isprop-subsing/run
Normal file
2
golden-tests/tests/isprop-subsing/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" isprop-subsing.quox
|
4
golden-tests/tests/it-5/expected
Normal file
4
golden-tests/tests/it-5/expected
Normal file
|
@ -0,0 +1,4 @@
|
|||
ω.five : ℕ
|
||||
five = 5
|
||||
(define five
|
||||
5)
|
1
golden-tests/tests/it-5/five.quox
Normal file
1
golden-tests/tests/it-5/five.quox
Normal file
|
@ -0,0 +1 @@
|
|||
def five : ℕ = 5
|
2
golden-tests/tests/it-5/run
Normal file
2
golden-tests/tests/it-5/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
scheme "$1" five.quox
|
18
golden-tests/tests/lib.sh
Normal file
18
golden-tests/tests/lib.sh
Normal file
|
@ -0,0 +1,18 @@
|
|||
FLAGS="--dump-check - --dump-erase - --dump-scheme - --color=none --width=100000"
|
||||
|
||||
check() {
|
||||
$1 $FLAGS "$2" -P check 2>&1
|
||||
}
|
||||
|
||||
erase() {
|
||||
$1 $FLAGS "$2" -P erase 2>&1
|
||||
}
|
||||
|
||||
scheme() {
|
||||
$1 $FLAGS "$2" -P scheme 2>&1
|
||||
}
|
||||
|
||||
compile_run() {
|
||||
$1 $FLAGS "$2" -o "$3" 2>&1
|
||||
chezscheme --program "$3"
|
||||
}
|
16
golden-tests/tests/load/expected
Normal file
16
golden-tests/tests/load/expected
Normal file
|
@ -0,0 +1,16 @@
|
|||
0.lib.IO : 1.★ → ★
|
||||
ω.lib.print : 1.String → lib.IO {ok}
|
||||
ω.lib.main : lib.IO {ok}
|
||||
ω.main : lib.IO {ok}
|
||||
lib.IO = □
|
||||
lib.print = scheme:(lambda (str) (builtin-io (display str) (newline)))
|
||||
lib.main = lib.print "hello 🐉"
|
||||
#[main] main = lib.main
|
||||
;; lib.IO erased
|
||||
(define lib.print
|
||||
(lambda (str) (builtin-io (display str) (newline))))
|
||||
(define lib.main
|
||||
(lib.print "hello \x1f409;"))
|
||||
(define main
|
||||
lib.main)
|
||||
hello 🐉
|
8
golden-tests/tests/load/lib.quox
Normal file
8
golden-tests/tests/load/lib.quox
Normal file
|
@ -0,0 +1,8 @@
|
|||
namespace lib {
|
||||
def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
|
||||
|
||||
#[compile-scheme "(lambda (str) (builtin-io (display str) (newline)))"]
|
||||
postulate print : String → IO {ok}
|
||||
|
||||
def main = print "hello 🐉"
|
||||
}
|
4
golden-tests/tests/load/main.quox
Normal file
4
golden-tests/tests/load/main.quox
Normal file
|
@ -0,0 +1,4 @@
|
|||
load "lib.quox"
|
||||
|
||||
#[main]
|
||||
def main = lib.main
|
2
golden-tests/tests/load/run
Normal file
2
golden-tests/tests/load/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
compile_run "$1" main.quox load.ss
|
1
golden-tests/tests/regularity/expected
Normal file
1
golden-tests/tests/regularity/expected
Normal file
|
@ -0,0 +1 @@
|
|||
0.reggie : 1.(A : ★) → 1.(AA : A ≡ A : ★) → 1.(s : A) → 1.(P : 1.A → ★) → 1.(P (coe (𝑖 ⇒ AA @𝑖) @0 @1 s)) → P s
|
12
golden-tests/tests/regularity/regularity.quox
Normal file
12
golden-tests/tests/regularity/regularity.quox
Normal file
|
@ -0,0 +1,12 @@
|
|||
-- this definition depends on coercion regularity in xtt. which is this
|
||||
-- (adapted to quox):
|
||||
--
|
||||
-- Ψ | Γ ⊢ 0 · A‹0/𝑖› = A‹1/𝑖› ⇐ ★
|
||||
-- ---------------------------------------------------------
|
||||
-- Ψ | Γ ⊢ π · coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A‹1/𝑖›) ⇒ A‹1/𝑖›
|
||||
--
|
||||
-- otherwise, the types P (coe ⋯ s) and P s are incompatible
|
||||
|
||||
def0 reggie : (A : ★) → (AA : A ≡ A : ★) → (s : A) →
|
||||
(P : A → ★) → P (coe (𝑖 ⇒ AA @𝑖) s) → P s =
|
||||
λ A AA s P p ⇒ p
|
2
golden-tests/tests/regularity/run
Normal file
2
golden-tests/tests/regularity/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" regularity.quox
|
9
golden-tests/tests/useless-coe/coe.quox
Normal file
9
golden-tests/tests/useless-coe/coe.quox
Normal file
|
@ -0,0 +1,9 @@
|
|||
-- non-dependent coe should reduce to its body
|
||||
|
||||
def five : ℕ = 5
|
||||
def five? : ℕ = coe ℕ 5
|
||||
|
||||
def eq : five ≡ five? : ℕ = δ _ ⇒ 5
|
||||
|
||||
def subst1 : 0.(P : ℕ → ★) → P five → P five? = λ P p ⇒ p
|
||||
def subst2 : 0.(P : ℕ → ★) → P five? → P five = λ P p ⇒ p
|
5
golden-tests/tests/useless-coe/expected
Normal file
5
golden-tests/tests/useless-coe/expected
Normal file
|
@ -0,0 +1,5 @@
|
|||
ω.five : ℕ
|
||||
ω.five? : ℕ
|
||||
ω.eq : five ≡ five? : ℕ
|
||||
ω.subst1 : 0.(P : 1.ℕ → ★) → 1.(P five) → P five?
|
||||
ω.subst2 : 0.(P : 1.ℕ → ★) → 1.(P five?) → P five
|
2
golden-tests/tests/useless-coe/run
Normal file
2
golden-tests/tests/useless-coe/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" coe.quox
|
82
lib/Control/Monad/ST/Extra.idr
Normal file
82
lib/Control/Monad/ST/Extra.idr
Normal file
|
@ -0,0 +1,82 @@
|
|||
module Control.Monad.ST.Extra
|
||||
|
||||
import public Control.Monad.ST
|
||||
import Data.IORef
|
||||
import Control.MonadRec
|
||||
|
||||
%default total
|
||||
|
||||
export %inline
|
||||
MonadRec (ST s) where
|
||||
tailRecM seed (Access rec) st f = MkST $ do
|
||||
let MkST io = f seed st
|
||||
case !io of
|
||||
Done res => pure res
|
||||
Cont seed2 prf vst =>
|
||||
let MkST io = tailRecM seed2 (rec seed2 prf) vst f in io
|
||||
|
||||
|
||||
public export
|
||||
interface HasST (0 m : Type -> Type -> Type) where
|
||||
liftST : ST s a -> m s a
|
||||
|
||||
export %inline HasST ST where liftST = id
|
||||
|
||||
|
||||
public export
|
||||
record STErr e s a where
|
||||
constructor STE
|
||||
fromSTErr : ST s (Either e a)
|
||||
|
||||
export
|
||||
Functor (STErr e s) where
|
||||
map f (STE e) = STE $ map f <$> e
|
||||
|
||||
export
|
||||
Applicative (STErr e s) where
|
||||
pure x = STE $ pure $ pure x
|
||||
STE f <*> STE x = STE [|f <*> x|]
|
||||
|
||||
export
|
||||
Monad (STErr e s) where
|
||||
STE m >>= k = STE $ do
|
||||
case !m of
|
||||
Left err => pure $ Left err
|
||||
Right x => fromSTErr $ k x
|
||||
|
||||
export
|
||||
MonadRec (STErr e s) where
|
||||
tailRecM s (Access r) x k = STE $ do
|
||||
let STE m = k s x
|
||||
case !m of
|
||||
Left err => pure $ Left err
|
||||
Right (Cont s' p y) => fromSTErr $ tailRecM s' (r s' p) y k
|
||||
Right (Done y) => pure $ Right y
|
||||
|
||||
export
|
||||
runSTErr : (forall s. STErr e s a) -> Either e a
|
||||
runSTErr ste = runST $ fromSTErr ste
|
||||
|
||||
export %inline HasST (STErr e) where liftST = STE . map Right
|
||||
|
||||
export
|
||||
stLeft : e -> STErr e s a
|
||||
stLeft e = STE $ pure $ Left e
|
||||
|
||||
|
||||
parameters {auto _ : HasST m}
|
||||
export %inline
|
||||
newSTRef' : a -> m s (STRef s a)
|
||||
newSTRef' x = liftST $ newSTRef x
|
||||
|
||||
export %inline
|
||||
readSTRef' : STRef s a -> m s a
|
||||
readSTRef' r = liftST $ readSTRef r
|
||||
|
||||
export %inline
|
||||
writeSTRef' : STRef s a -> a -> m s ()
|
||||
writeSTRef' r x = liftST $ writeSTRef r x
|
||||
|
||||
export %inline
|
||||
modifySTRef' : STRef s a -> (a -> a) -> m s ()
|
||||
modifySTRef' r f = liftST $ modifySTRef r f
|
|
@ -3,8 +3,8 @@ module Quox.BoolExtra
|
|||
import public Data.Bool
|
||||
|
||||
|
||||
infixr 5 `andM`
|
||||
infixr 4 `orM`
|
||||
export infixr 5 `andM`
|
||||
export infixr 4 `orM`
|
||||
|
||||
public export
|
||||
andM, orM : Monad m => m Bool -> m Bool -> m Bool
|
||||
|
|
|
@ -166,3 +166,10 @@ 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)
|
||||
|
|
33
lib/Quox/CheckBuiltin.idr
Normal file
33
lib/Quox/CheckBuiltin.idr
Normal file
|
@ -0,0 +1,33 @@
|
|||
||| check that special functions (e.g. `main`) have the expected type
|
||||
module Quox.CheckBuiltin
|
||||
|
||||
import Quox.Syntax
|
||||
import Quox.Typing
|
||||
import Quox.Whnf
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
export covering
|
||||
expectSingleEnum : Definitions -> TyContext d n -> SQty -> Loc ->
|
||||
Term d n -> Eff Whnf ()
|
||||
expectSingleEnum defs ctx sg loc s = do
|
||||
let err = delay $ ExpectedSingleEnum loc ctx.names s
|
||||
cases <- wrapErr (const err) $ expectEnum defs ctx sg loc s
|
||||
unless (length (SortedSet.toList cases) == 1) $ throw err
|
||||
|
||||
||| `main` should have a type `1.IOState → {𝑎} × IOState`,
|
||||
||| for some (single) tag `𝑎`
|
||||
export covering
|
||||
expectMainType : Definitions -> Term 0 0 -> Eff Whnf ()
|
||||
expectMainType defs ty =
|
||||
wrapErr (WrongBuiltinType Main) $ do
|
||||
let ctx = TyContext.empty
|
||||
(qty, arg, res) <- expectPi defs ctx SZero ty.loc ty
|
||||
expectEqualQ ty.loc qty One
|
||||
expectIOState defs ctx SZero arg.loc arg
|
||||
let ctx = extendTy qty res.name arg ctx
|
||||
(ret, st) <- expectSig defs ctx SZero res.loc res.term
|
||||
expectSingleEnum defs ctx SZero ret.loc ret
|
||||
let ctx = extendTy qty st.name ret ctx
|
||||
expectIOState defs ctx SZero st.loc st.term
|
|
@ -6,6 +6,7 @@ import Quox.Name
|
|||
|
||||
import Data.DPair
|
||||
import Data.Nat
|
||||
import Data.Singleton
|
||||
import Data.SnocList
|
||||
import Data.SnocVect
|
||||
import Data.Vect
|
||||
|
@ -57,6 +58,7 @@ public export
|
|||
tail : Context tm (S n) -> Context tm n
|
||||
tail = fst . unsnoc
|
||||
|
||||
|
||||
parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
|
||||
export
|
||||
toSnocListWith : Telescope tm _ _ -> SnocList a
|
||||
|
@ -107,10 +109,17 @@ fromSnocVect [<] = [<]
|
|||
fromSnocVect (sx :< x) = fromSnocVect sx :< x
|
||||
|
||||
|
||||
public export
|
||||
tabulateLT : (n : Nat) -> ((i : Nat) -> (0 p : i `LT` n) => tm i) ->
|
||||
Context tm n
|
||||
tabulateLT 0 f = [<]
|
||||
tabulateLT (S k) f =
|
||||
tabulateLT k (\i => f i @{lteSuccRight %search}) :< f k @{reflexive}
|
||||
|
||||
public export
|
||||
tabulate : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
|
||||
tabulate f 0 = [<]
|
||||
tabulate f (S k) = tabulate f k :< f k
|
||||
tabulate f n = tabulateLT n (\i => f i)
|
||||
-- [todo] fixup argument order lol
|
||||
|
||||
public export
|
||||
replicate : (n : Nat) -> a -> Context' a n
|
||||
|
@ -149,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
|
||||
|
||||
infixl 8 !!
|
||||
export infixl 8 !!
|
||||
public export %inline
|
||||
(!!) : CanShift tm => Context tm len -> Var len -> tm len
|
||||
(!!) = getWith (//)
|
||||
|
||||
infixl 8 !!!
|
||||
export infixl 8 !!!
|
||||
public export %inline
|
||||
(!!!) : Context' tm len -> Var len -> tm
|
||||
(!!!) = getWith const
|
||||
|
@ -180,6 +189,12 @@ export %hint
|
|||
succGT = LTESucc reflexive
|
||||
|
||||
|
||||
public export
|
||||
drop : (m : Nat) -> Context term (m + n) -> Context term n
|
||||
drop 0 ctx = ctx
|
||||
drop (S m) (ctx :< _) = drop m ctx
|
||||
|
||||
|
||||
parameters {auto _ : Applicative f}
|
||||
export
|
||||
traverse : (forall n. tm1 n -> f (tm2 n)) ->
|
||||
|
@ -191,7 +206,7 @@ parameters {auto _ : Applicative f}
|
|||
traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
|
||||
traverse' f = traverse f
|
||||
|
||||
infixl 3 `app`
|
||||
export infixl 3 `app`
|
||||
||| like `(<*>)` but with effects
|
||||
export
|
||||
app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
|
||||
|
@ -258,16 +273,17 @@ unzip3 (tel :< (x, y, z)) =
|
|||
|
||||
|
||||
public export
|
||||
lengthPrf : Telescope _ from to -> (len ** len + from = to)
|
||||
lengthPrf [<] = (0 ** Refl)
|
||||
lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
|
||||
lengthPrf [<] = Element 0 Refl
|
||||
lengthPrf (tel :< _) =
|
||||
let len = lengthPrf tel in (S len.fst ** cong S len.snd)
|
||||
let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
|
||||
|
||||
export
|
||||
lengthPrf0 : Context _ to -> (len ** len = to)
|
||||
lengthPrf0 : Context _ to -> Singleton to
|
||||
lengthPrf0 ctx =
|
||||
let len = lengthPrf ctx in
|
||||
(len.fst ** rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
|
||||
let Element len prf = lengthPrf ctx in
|
||||
rewrite sym prf `trans` plusZeroRightNeutral len in
|
||||
[|len|]
|
||||
|
||||
public export %inline
|
||||
length : Telescope {} -> Nat
|
||||
|
@ -286,6 +302,10 @@ foldl : {0 acc : Nat -> Type} ->
|
|||
foldl f z [<] = z
|
||||
foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
|
||||
|
||||
export %inline
|
||||
foldl_ : (acc -> tm -> acc) -> acc -> Telescope' tm from to -> acc
|
||||
foldl_ f z tel = foldl f z tel
|
||||
|
||||
export %inline
|
||||
foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
|
||||
foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
|
||||
|
@ -345,4 +365,4 @@ parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
|
|||
namespace BContext
|
||||
export
|
||||
toNames : BContext n -> SnocList BaseName
|
||||
toNames = foldl (\xs, x => xs :< x.name) [<]
|
||||
toNames = foldl (\xs, x => xs :< x.val) [<]
|
||||
|
|
|
@ -2,9 +2,12 @@ module Quox.Definition
|
|||
|
||||
import public Quox.No
|
||||
import public Quox.Syntax
|
||||
import Quox.Displace
|
||||
import public Data.SortedMap
|
||||
import public Quox.Loc
|
||||
import Quox.Pretty
|
||||
import Control.Eff
|
||||
import Data.Singleton
|
||||
import Decidable.Decidable
|
||||
|
||||
|
||||
|
@ -26,15 +29,21 @@ 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) -> Loc -> Definition
|
||||
mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_}
|
||||
mkPostulate : GQty -> (type0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
|
||||
Definition
|
||||
mkPostulate qty type0 scheme isMain loc_ =
|
||||
MkDef {qty, type0, body0 = Postulate, scheme, isMain, loc_}
|
||||
|
||||
public export %inline
|
||||
mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition
|
||||
mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, loc_}
|
||||
mkDef : GQty -> (type0, term0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
|
||||
Definition
|
||||
mkDef qty type0 term0 scheme isMain loc_ =
|
||||
MkDef {qty, type0, body0 = Concrete term0, scheme, isMain, loc_}
|
||||
|
||||
export Located Definition where def.loc = def.loc_
|
||||
export Relocatable Definition where setLoc loc = {loc_ := loc}
|
||||
|
@ -45,27 +54,51 @@ parameters {d, n : Nat}
|
|||
(.type) : Definition -> Term d n
|
||||
g.type = g.type0 // shift0 d // shift0 n
|
||||
|
||||
public export %inline
|
||||
(.typeAt) : Definition -> Universe -> Term d n
|
||||
g.typeAt u = displace u g.type
|
||||
|
||||
public export %inline
|
||||
(.term) : Definition -> Maybe (Term d n)
|
||||
g.term = g.body0.term0 <&> \t => t // shift0 d // shift0 n
|
||||
|
||||
public export %inline
|
||||
toElim : Definition -> Maybe $ Elim d n
|
||||
toElim def = pure $ Ann !def.term def.type def.loc
|
||||
(.termAt) : Definition -> Universe -> Maybe (Term d n)
|
||||
g.termAt u = displace u <$> g.term
|
||||
|
||||
public export %inline
|
||||
toElim : Definition -> Universe -> Maybe $ Elim d n
|
||||
toElim def u = pure $ Ann !(def.termAt u) (def.typeAt u) def.loc
|
||||
|
||||
public export
|
||||
(.typeWith) : Definition -> Singleton d -> Singleton n -> Term d n
|
||||
g.typeWith (Val d) (Val n) = g.type
|
||||
|
||||
public export
|
||||
(.typeWithAt) : Definition -> Singleton d -> Singleton n -> Universe -> Term d n
|
||||
g.typeWithAt d n u = displace u $ g.typeWith d n
|
||||
|
||||
public export
|
||||
(.termWith) : Definition -> Singleton d -> Singleton n -> Maybe (Term d n)
|
||||
g.termWith (Val d) (Val n) = g.term
|
||||
|
||||
|
||||
public export %inline
|
||||
isZero : Definition -> Bool
|
||||
isZero g = g.qty.fst == Zero
|
||||
isZero g = g.qty == GZero
|
||||
|
||||
|
||||
public export
|
||||
data DefEnvTag = DEFS
|
||||
NDefinition : Type
|
||||
NDefinition = (Name, Definition)
|
||||
|
||||
public export
|
||||
Definitions : Type
|
||||
Definitions = SortedMap Name Definition
|
||||
|
||||
public export
|
||||
data DefEnvTag = DEFS
|
||||
|
||||
public export
|
||||
DefsReader : Type -> Type
|
||||
DefsReader = ReaderL DEFS Definitions
|
||||
|
@ -74,7 +107,21 @@ 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
|
||||
lookupElim : {d, n : Nat} -> Name -> Definitions -> Maybe (Elim d n)
|
||||
lookupElim x defs = toElim !(lookup x defs)
|
||||
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
|
||||
|
|
|
@ -2,6 +2,8 @@ module Quox.Displace
|
|||
|
||||
import Quox.Syntax
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
parameters (k : Universe)
|
||||
namespace Term
|
||||
|
@ -14,6 +16,7 @@ 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
|
||||
|
@ -24,14 +27,18 @@ 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 (Zero loc) = Zero loc
|
||||
doDisplace (NAT loc) = NAT loc
|
||||
doDisplace (Nat n loc) = Nat n loc
|
||||
doDisplace (Succ p loc) = Succ (doDisplace p) loc
|
||||
doDisplace (STRING loc) = STRING loc
|
||||
doDisplace (Str s loc) = Str s loc
|
||||
doDisplace (BOX qty ty loc) = BOX qty (doDisplace ty) loc
|
||||
doDisplace (Box val loc) = Box (doDisplace val) loc
|
||||
doDisplace (Let qty rhs body loc) =
|
||||
Let qty (doDisplace rhs) (doDisplaceS body) loc
|
||||
doDisplace (E e) = E (doDisplace e)
|
||||
doDisplace (CloT (Sub t th)) =
|
||||
CloT (Sub (doDisplace t) (map doDisplace th))
|
||||
CloT (Sub (doDisplace t) (assert_total $ map doDisplace th))
|
||||
doDisplace (DCloT (Sub t th)) =
|
||||
DCloT (Sub (doDisplace t) th)
|
||||
|
||||
|
@ -47,8 +54,11 @@ parameters (k : Universe)
|
|||
doDisplace (App fun arg loc) = App (doDisplace fun) (doDisplace arg) loc
|
||||
doDisplace (CasePair qty pair ret body loc) =
|
||||
CasePair qty (doDisplace pair) (doDisplaceS ret) (doDisplaceS body) loc
|
||||
doDisplace (Fst pair loc) = Fst (doDisplace pair) loc
|
||||
doDisplace (Snd pair loc) = Snd (doDisplace pair) loc
|
||||
doDisplace (CaseEnum qty tag ret arms loc) =
|
||||
CaseEnum qty (doDisplace tag) (doDisplaceS ret) (map doDisplace arms) loc
|
||||
CaseEnum qty (doDisplace tag) (doDisplaceS ret)
|
||||
(assert_total $ map doDisplace arms) loc
|
||||
doDisplace (CaseNat qty qtyIH nat ret zero succ loc) =
|
||||
CaseNat qty qtyIH (doDisplace nat) (doDisplaceS ret)
|
||||
(doDisplace zero) (doDisplaceS succ) loc
|
||||
|
@ -65,9 +75,9 @@ parameters (k : Universe)
|
|||
(doDisplaceDS zero) (doDisplaceDS one) loc
|
||||
doDisplace (TypeCase ty ret arms def loc) =
|
||||
TypeCase (doDisplace ty) (doDisplace ret)
|
||||
(map doDisplaceS arms) (doDisplace def) loc
|
||||
(assert_total $ map doDisplaceS arms) (doDisplace def) loc
|
||||
doDisplace (CloE (Sub e th)) =
|
||||
CloE (Sub (doDisplace e) (map doDisplace th))
|
||||
CloE (Sub (doDisplace e) (assert_total $ map doDisplace th))
|
||||
doDisplace (DCloE (Sub e th)) =
|
||||
DCloE (Sub (doDisplace e) th)
|
||||
|
||||
|
|
|
@ -2,6 +2,7 @@ module Quox.EffExtra
|
|||
|
||||
import public Control.Eff
|
||||
|
||||
import Control.Monad.ST.Extra
|
||||
import Data.IORef
|
||||
|
||||
|
||||
|
@ -26,48 +27,40 @@ local_ : Has (State s) fs => s -> Eff fs a -> Eff fs a
|
|||
local_ = localAt_ ()
|
||||
|
||||
|
||||
export
|
||||
hasDrop : (0 neq : Not (a = b)) ->
|
||||
(ha : Has a fs) => (hb : Has b fs) =>
|
||||
Has a (drop fs hb)
|
||||
hasDrop neq {ha = Z} {hb = Z} = void $ neq Refl
|
||||
hasDrop neq {ha = S ha} {hb = Z} = ha
|
||||
hasDrop neq {ha = Z} {hb = S hb} = Z
|
||||
hasDrop neq {ha = S ha} {hb = S hb} = S $ hasDrop neq {ha, hb}
|
||||
export %inline
|
||||
getsAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> a) -> Eff fs a
|
||||
getsAt lbl f = f <$> getAt lbl
|
||||
|
||||
export %inline
|
||||
gets : Has (State s) fs => (s -> a) -> Eff fs a
|
||||
gets = getsAt ()
|
||||
|
||||
|
||||
export %inline
|
||||
stateAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> (a, s)) -> Eff fs a
|
||||
stateAt lbl f = do (res, x) <- getsAt lbl f; putAt lbl x $> res
|
||||
|
||||
export %inline
|
||||
state : Has (State s) fs => (s -> (a, s)) -> Eff fs a
|
||||
state = stateAt ()
|
||||
|
||||
private
|
||||
0 ioNotState : Not (IO = StateL _ _)
|
||||
ioNotState Refl impossible
|
||||
|
||||
export
|
||||
runStateIORefAt : (0 lbl : tag) -> (Has IO fs, Has (StateL lbl s) fs) =>
|
||||
IORef s -> Eff fs a -> Eff (fs - StateL lbl s) a
|
||||
runStateIORefAt lbl ref act = do
|
||||
let hh : Has IO (fs - StateL lbl s) := hasDrop ioNotState
|
||||
(val, st) <- runStateAt lbl !(readIORef ref) act
|
||||
writeIORef ref st $> val
|
||||
|
||||
export %inline
|
||||
runStateIORef : (Has IO fs, Has (State s) fs) =>
|
||||
IORef s -> Eff fs a -> Eff (fs - State s) a
|
||||
runStateIORef = runStateIORefAt ()
|
||||
|
||||
|
||||
export %inline
|
||||
evalStateAt : (0 lbl : tag) -> Has (StateL lbl s) fs =>
|
||||
s -> Eff fs a -> Eff (fs - StateL lbl s) a
|
||||
evalStateAt lbl s act = map fst $ runStateAt lbl s act
|
||||
|
||||
export %inline
|
||||
evalState : Has (State s) fs => s -> Eff fs a -> Eff (fs - State s) a
|
||||
evalState = evalStateAt ()
|
||||
handleStateIORef : HasIO m => IORef st -> StateL lbl st a -> m a
|
||||
handleStateIORef r Get = readIORef r
|
||||
handleStateIORef r (Put s) = writeIORef r s
|
||||
|
||||
export
|
||||
handleStateSTRef : HasST m => STRef s st -> StateL lbl st a -> m s a
|
||||
handleStateSTRef r Get = liftST $ readSTRef r
|
||||
handleStateSTRef r (Put s) = liftST $ writeSTRef r s
|
||||
|
||||
|
||||
public export
|
||||
data Length : List a -> Type where
|
||||
Z : Length []
|
||||
S : Length xs -> Length (x :: xs)
|
||||
%builtin Natural Length
|
||||
|
||||
export
|
||||
subsetWith : Length xs => (forall z. Has z xs -> Has z ys) ->
|
||||
|
@ -80,23 +73,77 @@ subsetSelf : Length xs => Subset xs xs
|
|||
subsetSelf = subsetWith id
|
||||
|
||||
export
|
||||
subsetTail : Length xs => Subset xs (x :: xs)
|
||||
subsetTail = subsetWith S
|
||||
subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
|
||||
subsetTail _ = subsetWith S
|
||||
|
||||
|
||||
|
||||
-- [fixme] allow the error to be anywhere in the effect list
|
||||
export
|
||||
wrapErrAt : Length fs => (0 lbl : tag) -> (e -> e) ->
|
||||
Eff (ExceptL lbl e :: fs) a -> Eff (ExceptL lbl e :: fs) a
|
||||
wrapErrAt lbl f act =
|
||||
rethrowAt lbl . mapFst f =<< lift @{subsetTail} (runExceptAt lbl act)
|
||||
rethrowAtWith : (0 lbl : tag) -> Has (ExceptL lbl e') fs =>
|
||||
(e -> e') -> Either e a -> Eff fs a
|
||||
rethrowAtWith lbl f = rethrowAt lbl . mapFst f
|
||||
|
||||
export
|
||||
rethrowWith : Has (Except e') fs => (e -> e') -> Either e a -> Eff fs a
|
||||
rethrowWith = rethrowAtWith ()
|
||||
|
||||
export
|
||||
wrapErr : Length fs => (e -> e') ->
|
||||
Eff (ExceptL lbl e :: fs) a ->
|
||||
Eff (ExceptL lbl e' :: fs) a
|
||||
wrapErr f act =
|
||||
catchAt lbl (throwAt lbl . f) @{S Z} $
|
||||
lift @{subsetTail _} act
|
||||
|
||||
|
||||
export
|
||||
handleExcept : Functor m => (forall c. e -> m c) -> ExceptL lbl e a -> m a
|
||||
handleExcept thr (Err e) = thr e
|
||||
|
||||
|
||||
export
|
||||
handleReaderConst : Applicative m => r -> ReaderL lbl r a -> m a
|
||||
handleReaderConst x Ask = pure x
|
||||
|
||||
export
|
||||
handleWriterSTRef : HasST m => STRef s (SnocList w) -> WriterL lbl w a -> m s a
|
||||
handleWriterSTRef ref (Tell w) = liftST $ modifySTRef ref (:< w)
|
||||
|
||||
|
||||
public export
|
||||
record IOErr e a where
|
||||
constructor IOE
|
||||
fromIOErr : IO (Either e a)
|
||||
|
||||
export
|
||||
Functor (IOErr e) where
|
||||
map f (IOE e) = IOE $ map f <$> e
|
||||
|
||||
export
|
||||
Applicative (IOErr e) where
|
||||
pure x = IOE $ pure $ pure x
|
||||
IOE f <*> IOE x = IOE [|f <*> x|]
|
||||
|
||||
export
|
||||
Monad (IOErr e) where
|
||||
IOE m >>= k = IOE $ do
|
||||
case !m of
|
||||
Left err => pure $ Left err
|
||||
Right x => fromIOErr $ k x
|
||||
|
||||
export
|
||||
MonadRec (IOErr e) where
|
||||
tailRecM s (Access r) x k = IOE $ do
|
||||
let IOE m = k s x
|
||||
case !m of
|
||||
Left err => pure $ Left err
|
||||
Right (Cont s' p y) => fromIOErr $ tailRecM s' (r s' p) y k
|
||||
Right (Done y) => pure $ Right y
|
||||
|
||||
export
|
||||
HasIO (IOErr e) where
|
||||
liftIO = IOE . map Right
|
||||
|
||||
export %inline
|
||||
wrapErr : Length fs => (e -> e) ->
|
||||
Eff (Except e :: fs) a -> Eff (Except e :: fs) a
|
||||
wrapErr = wrapErrAt ()
|
||||
|
||||
|
||||
export %inline
|
||||
runIO : (MonadRec io, HasIO io) => Eff [IO] a -> io a
|
||||
runIO act = runEff act [liftIO]
|
||||
ioLeft : e -> IOErr e a
|
||||
ioLeft = IOE . pure . Left
|
||||
|
|
1038
lib/Quox/Equal.idr
1038
lib/Quox/Equal.idr
File diff suppressed because it is too large
Load diff
310
lib/Quox/FreeVars.idr
Normal file
310
lib/Quox/FreeVars.idr
Normal file
|
@ -0,0 +1,310 @@
|
|||
module Quox.FreeVars
|
||||
|
||||
import Quox.Syntax.Term.Base
|
||||
import Data.Maybe
|
||||
import Data.Nat
|
||||
import Data.Singleton
|
||||
import Data.SortedSet
|
||||
import Derive.Prelude
|
||||
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
public export
|
||||
FreeVars' : Nat -> Type
|
||||
FreeVars' n = Context' Bool n
|
||||
|
||||
public export
|
||||
record FreeVars n where
|
||||
constructor FV
|
||||
vars : FreeVars' n
|
||||
%name FreeVars xs
|
||||
|
||||
%runElab deriveIndexed "FreeVars" [Eq, Ord, Show]
|
||||
|
||||
|
||||
export %inline
|
||||
(||) : FreeVars n -> FreeVars n -> FreeVars n
|
||||
FV s || FV t = FV $ zipWith (\x, y => x || y) s t
|
||||
|
||||
export %inline
|
||||
(&&) : FreeVars n -> FreeVars n -> FreeVars n
|
||||
FV s && FV t = FV $ zipWith (\x, y => x && y) s t
|
||||
|
||||
export %inline Semigroup (FreeVars n) where (<+>) = (||)
|
||||
|
||||
export %inline [AndS] Semigroup (FreeVars n) where (<+>) = (&&)
|
||||
|
||||
export
|
||||
only : {n : Nat} -> Var n -> FreeVars n
|
||||
only i = FV $ only' i where
|
||||
only' : {n' : Nat} -> Var n' -> FreeVars' n'
|
||||
only' VZ = replicate (pred n') False :< True
|
||||
only' (VS i) = only' i :< False
|
||||
|
||||
export %inline
|
||||
all : {n : Nat} -> FreeVars n
|
||||
all = FV $ replicate n True
|
||||
|
||||
export %inline
|
||||
none : {n : Nat} -> FreeVars n
|
||||
none = FV $ replicate n False
|
||||
|
||||
|
||||
export %inline
|
||||
uncons : FreeVars (S n) -> (FreeVars n, Bool)
|
||||
uncons (FV (xs :< x)) = (FV xs, x)
|
||||
|
||||
|
||||
export %inline {n : Nat} -> Monoid (FreeVars n) where neutral = none
|
||||
export %inline [AndM] {n : Nat} -> Monoid (FreeVars n) where neutral = all
|
||||
|
||||
|
||||
private
|
||||
self : {n : Nat} -> Context' (FreeVars n) n
|
||||
self = tabulate (\i => FV $ tabulate (== i) n) n
|
||||
|
||||
export
|
||||
shift : forall from, to. Shift from to -> FreeVars from -> FreeVars to
|
||||
shift by (FV xs) = FV $ shift' by xs where
|
||||
shift' : Shift from' to' -> FreeVars' from' -> FreeVars' to'
|
||||
shift' SZ ctx = ctx
|
||||
shift' (SS by) ctx = shift' by ctx :< False
|
||||
|
||||
|
||||
export
|
||||
fromSet : {n : Nat} -> SortedSet (Var n) -> FreeVars n
|
||||
fromSet vs = FV $ tabulateLT n $ \i => contains (V i) vs
|
||||
|
||||
export
|
||||
toSet : {n : Nat} -> FreeVars n -> SortedSet (Var n)
|
||||
toSet (FV vs) =
|
||||
foldl_ (\s, i => maybe s (\i => insert i s) i) empty $
|
||||
zipWith (\i, b => guard b $> i) (tabulateLT n V) vs
|
||||
|
||||
|
||||
public export
|
||||
interface HasFreeVars (0 tm : Nat -> Type) where
|
||||
constructor HFV
|
||||
fv : {n : Nat} -> tm n -> FreeVars n
|
||||
|
||||
public export
|
||||
interface HasFreeDVars (0 tm : TermLike) where
|
||||
constructor HFDV
|
||||
fdv : {d, n : Nat} -> tm d n -> FreeVars d
|
||||
|
||||
public export %inline
|
||||
fvWith : HasFreeVars tm => Singleton n -> tm n -> FreeVars n
|
||||
fvWith (Val n) = fv
|
||||
|
||||
public export %inline
|
||||
fdvWith : HasFreeDVars tm => Singleton d -> Singleton n -> tm d n -> FreeVars d
|
||||
fdvWith (Val d) (Val n) = fdv
|
||||
|
||||
export
|
||||
Fdv : (0 tm : TermLike) -> {n : Nat} ->
|
||||
HasFreeDVars tm => HasFreeVars (\d => tm d n)
|
||||
Fdv tm @{HFDV fdv} = HFV fdv
|
||||
|
||||
|
||||
export
|
||||
fvEach : {n1, n2 : Nat} -> HasFreeVars env =>
|
||||
Subst env n1 n2 -> Context' (Lazy (FreeVars n2)) n1
|
||||
fvEach (Shift by) = map (delay . shift by) self
|
||||
fvEach (t ::: th) = fvEach th :< fv t
|
||||
|
||||
export
|
||||
fdvEach : {d, n1, n2 : Nat} -> HasFreeDVars env =>
|
||||
Subst (env d) n1 n2 -> Context' (Lazy (FreeVars d)) n1
|
||||
fdvEach (Shift by) = replicate n1 none
|
||||
fdvEach (t ::: th) = fdvEach th :< fdv t
|
||||
|
||||
|
||||
export
|
||||
HasFreeVars Dim where
|
||||
fv (K _ _) = none
|
||||
fv (B i _) = only i
|
||||
|
||||
|
||||
export
|
||||
{s : Nat} -> HasFreeVars tm => HasFreeVars (Scoped s tm) where
|
||||
fv (S _ (Y body)) = FV $ drop s (fv body).vars
|
||||
fv (S _ (N body)) = fv body
|
||||
|
||||
export
|
||||
implementation [DScope]
|
||||
{s : Nat} -> HasFreeDVars tm =>
|
||||
HasFreeDVars (\d, n => Scoped s (\d' => tm d' n) d)
|
||||
where
|
||||
fdv (S _ (Y body)) = FV $ drop s (fdv body).vars
|
||||
fdv (S _ (N body)) = fdv body
|
||||
|
||||
export
|
||||
fvD : {0 tm : TermLike} -> {n : Nat} -> (forall d. HasFreeVars (tm d)) =>
|
||||
Scoped s (\d => tm d n) d -> FreeVars n
|
||||
fvD (S _ (Y body)) = fv body
|
||||
fvD (S _ (N body)) = fv body
|
||||
|
||||
export
|
||||
fdvT : HasFreeDVars tm => {s, d, n : Nat} -> Scoped s (tm d) n -> FreeVars d
|
||||
fdvT (S _ (Y body)) = fdv body
|
||||
fdvT (S _ (N body)) = fdv body
|
||||
|
||||
|
||||
private
|
||||
guardM : Monoid a => Bool -> Lazy a -> a
|
||||
guardM b x = if b then x else neutral
|
||||
|
||||
export
|
||||
implementation
|
||||
(HasFreeVars tm, HasFreeVars env) =>
|
||||
HasFreeVars (WithSubst tm env)
|
||||
where
|
||||
fv (Sub term subst) =
|
||||
let Val from = getFrom subst in
|
||||
foldMap (uncurry guardM) $ zipWith (,) (fv term).vars (fvEach subst)
|
||||
|
||||
export
|
||||
implementation [WithSubst]
|
||||
((forall d. HasFreeVars (tm d)), HasFreeDVars tm, HasFreeDVars env) =>
|
||||
HasFreeDVars (\d => WithSubst (tm d) (env d))
|
||||
where
|
||||
fdv (Sub term subst) =
|
||||
let Val from = getFrom subst in
|
||||
fdv term <+>
|
||||
foldMap (uncurry guardM) (zipWith (,) (fv term).vars (fdvEach subst))
|
||||
|
||||
|
||||
export HasFreeVars (Term d)
|
||||
export HasFreeVars (Elim d)
|
||||
|
||||
export
|
||||
HasFreeVars (Term d) where
|
||||
fv (TYPE {}) = none
|
||||
fv (IOState {}) = none
|
||||
fv (Pi {arg, res, _}) = fv arg <+> fv res
|
||||
fv (Lam {body, _}) = fv body
|
||||
fv (Sig {fst, snd, _}) = fv fst <+> fv snd
|
||||
fv (Pair {fst, snd, _}) = fv fst <+> fv snd
|
||||
fv (Enum {}) = none
|
||||
fv (Tag {}) = none
|
||||
fv (Eq {ty, l, r, _}) = fvD ty <+> fv l <+> fv r
|
||||
fv (DLam {body, _}) = fvD body
|
||||
fv (NAT {}) = none
|
||||
fv (Nat {}) = none
|
||||
fv (Succ {p, _}) = fv p
|
||||
fv (STRING {}) = none
|
||||
fv (Str {}) = none
|
||||
fv (BOX {ty, _}) = fv ty
|
||||
fv (Box {val, _}) = fv val
|
||||
fv (Let {rhs, body, _}) = fv rhs <+> fv body
|
||||
fv (E e) = fv e
|
||||
fv (CloT s) = fv s
|
||||
fv (DCloT s) = fv s.term
|
||||
|
||||
export
|
||||
HasFreeVars (Elim d) where
|
||||
fv (F {}) = none
|
||||
fv (B i _) = only i
|
||||
fv (App {fun, arg, _}) = fv fun <+> fv arg
|
||||
fv (CasePair {pair, ret, body, _}) = fv pair <+> fv ret <+> fv body
|
||||
fv (Fst pair _) = fv pair
|
||||
fv (Snd pair _) = fv pair
|
||||
fv (CaseEnum {tag, ret, arms, _}) =
|
||||
fv tag <+> fv ret <+> foldMap fv (values arms)
|
||||
fv (CaseNat {nat, ret, zero, succ, _}) =
|
||||
fv nat <+> fv ret <+> fv zero <+> fv succ
|
||||
fv (CaseBox {box, ret, body, _}) =
|
||||
fv box <+> fv ret <+> fv body
|
||||
fv (DApp {fun, _}) = fv fun
|
||||
fv (Ann {tm, ty, _}) = fv tm <+> fv ty
|
||||
fv (Coe {ty, val, _}) = fvD ty <+> fv val
|
||||
fv (Comp {ty, val, zero, one, _}) =
|
||||
fv ty <+> fv val <+> fvD zero <+> fvD one
|
||||
fv (TypeCase {ty, ret, arms, def, _}) =
|
||||
fv ty <+> fv ret <+> fv def <+> foldMap (\x => fv x.snd) (toList arms)
|
||||
fv (CloE s) = fv s
|
||||
fv (DCloE s) = fv s.term
|
||||
|
||||
|
||||
|
||||
private
|
||||
expandDShift : {d1 : Nat} -> Shift d1 d2 -> Loc -> Context' (Dim d2) d1
|
||||
expandDShift by loc = tabulateLT d1 (\i => BV i loc // by)
|
||||
|
||||
private
|
||||
expandDSubst : {d1 : Nat} -> DSubst d1 d2 -> Loc -> Context' (Dim d2) d1
|
||||
expandDSubst (Shift by) loc = expandDShift by loc
|
||||
expandDSubst (t ::: th) loc = expandDSubst th loc :< t
|
||||
|
||||
|
||||
private
|
||||
fdvSubst' : {d1, d2, n : Nat} -> (Located2 tm, HasFreeDVars tm) =>
|
||||
tm d1 n -> DSubst d1 d2 -> FreeVars d2
|
||||
fdvSubst' t th =
|
||||
fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th t.loc)
|
||||
where
|
||||
maybeOnly : {d : Nat} -> Bool -> Dim d -> FreeVars d
|
||||
maybeOnly True (B i _) = only i
|
||||
maybeOnly _ _ = none
|
||||
|
||||
private
|
||||
fdvSubst : {d, n : Nat} -> (Located2 tm, HasFreeDVars tm) =>
|
||||
WithSubst (\d => tm d n) Dim d -> FreeVars d
|
||||
fdvSubst (Sub t th) = let Val from = getFrom th in fdvSubst' t th
|
||||
|
||||
|
||||
export HasFreeDVars Term
|
||||
export HasFreeDVars Elim
|
||||
|
||||
export
|
||||
HasFreeDVars Term where
|
||||
fdv (TYPE {}) = none
|
||||
fdv (IOState {}) = none
|
||||
fdv (Pi {arg, res, _}) = fdv arg <+> fdvT res
|
||||
fdv (Lam {body, _}) = fdvT body
|
||||
fdv (Sig {fst, snd, _}) = fdv fst <+> fdvT snd
|
||||
fdv (Pair {fst, snd, _}) = fdv fst <+> fdv snd
|
||||
fdv (Enum {}) = none
|
||||
fdv (Tag {}) = none
|
||||
fdv (Eq {ty, l, r, _}) = fdv @{DScope} ty <+> fdv l <+> fdv r
|
||||
fdv (DLam {body, _}) = fdv @{DScope} body
|
||||
fdv (NAT {}) = none
|
||||
fdv (Nat {}) = none
|
||||
fdv (Succ {p, _}) = fdv p
|
||||
fdv (STRING {}) = none
|
||||
fdv (Str {}) = none
|
||||
fdv (BOX {ty, _}) = fdv ty
|
||||
fdv (Box {val, _}) = fdv val
|
||||
fdv (Let {rhs, body, _}) = fdv rhs <+> fdvT body
|
||||
fdv (E e) = fdv e
|
||||
fdv (CloT s) = fdv s @{WithSubst}
|
||||
fdv (DCloT s) = fdvSubst s
|
||||
|
||||
export
|
||||
HasFreeDVars Elim where
|
||||
fdv (F {}) = none
|
||||
fdv (B {}) = none
|
||||
fdv (App {fun, arg, _}) = fdv fun <+> fdv arg
|
||||
fdv (CasePair {pair, ret, body, _}) = fdv pair <+> fdvT ret <+> fdvT body
|
||||
fdv (Fst pair _) = fdv pair
|
||||
fdv (Snd pair _) = fdv pair
|
||||
fdv (CaseEnum {tag, ret, arms, _}) =
|
||||
fdv tag <+> fdvT ret <+> foldMap fdv (values arms)
|
||||
fdv (CaseNat {nat, ret, zero, succ, _}) =
|
||||
fdv nat <+> fdvT ret <+> fdv zero <+> fdvT succ
|
||||
fdv (CaseBox {box, ret, body, _}) =
|
||||
fdv box <+> fdvT ret <+> fdvT body
|
||||
fdv (DApp {fun, arg, _}) =
|
||||
fdv fun <+> fv arg
|
||||
fdv (Ann {tm, ty, _}) =
|
||||
fdv tm <+> fdv ty
|
||||
fdv (Coe {ty, p, q, val, _}) =
|
||||
fdv @{DScope} ty <+> fv p <+> fv q <+> fdv val
|
||||
fdv (Comp {ty, p, q, val, r, zero, one, _}) =
|
||||
fdv ty <+> fv p <+> fv q <+> fdv val <+>
|
||||
fv r <+> fdv @{DScope} zero <+> fdv @{DScope} one
|
||||
fdv (TypeCase {ty, ret, arms, def, _}) =
|
||||
fdv ty <+> fdv ret <+> fdv def <+> foldMap (\x => fdvT x.snd) (toList arms)
|
||||
fdv (CloE s) = fdv s @{WithSubst}
|
||||
fdv (DCloE s) = fdvSubst s
|
|
@ -1,6 +1,7 @@
|
|||
||| file locations
|
||||
module Quox.Loc
|
||||
|
||||
import Quox.PrettyValExtra
|
||||
import public Text.Bounded
|
||||
import Data.SortedMap
|
||||
import Derive.Prelude
|
||||
|
@ -12,12 +13,12 @@ public export
|
|||
FileName : Type
|
||||
FileName = String
|
||||
|
||||
%runElab derive "Bounds" [Ord]
|
||||
%runElab derive "Bounds" [Ord, PrettyVal]
|
||||
|
||||
public export
|
||||
data Loc_ = NoLoc | YesLoc FileName Bounds
|
||||
%name Loc_ loc
|
||||
%runElab derive "Loc_" [Eq, Ord, Show]
|
||||
%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
|
||||
||| a wrapper for locations which are always considered equal
|
||||
|
@ -39,6 +40,18 @@ 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_
|
||||
|
@ -95,7 +108,7 @@ extendL : Loc -> Loc -> Loc
|
|||
extendL l1 l2 = l1 `extend'` l2.bounds
|
||||
|
||||
|
||||
infixr 1 `or_`, `or`
|
||||
export infixr 1 `or_`, `or`
|
||||
export %inline
|
||||
or_ : Loc_ -> Loc_ -> Loc_
|
||||
or_ l1@(YesLoc {}) _ = l1
|
||||
|
@ -105,6 +118,11 @@ 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
|
||||
|
@ -113,9 +131,22 @@ 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
|
||||
|
|
317
lib/Quox/Log.idr
Normal file
317
lib/Quox/Log.idr
Normal file
|
@ -0,0 +1,317 @@
|
|||
module Quox.Log
|
||||
|
||||
import Quox.Loc
|
||||
import Quox.Pretty
|
||||
import Quox.PrettyValExtra
|
||||
|
||||
import Data.So
|
||||
import Data.DPair
|
||||
import Data.Maybe
|
||||
import Data.List1
|
||||
import Control.Eff
|
||||
import Control.Monad.ST.Extra
|
||||
import Data.IORef
|
||||
import System.File
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
public export %inline
|
||||
maxLogLevel : Nat
|
||||
maxLogLevel = 100
|
||||
|
||||
public export %inline
|
||||
logCategories : List String
|
||||
logCategories = ["whnf", "equal", "check"]
|
||||
|
||||
public export %inline
|
||||
isLogLevel : Nat -> Bool
|
||||
isLogLevel l = l <= maxLogLevel
|
||||
|
||||
public export
|
||||
IsLogLevel : Nat -> Type
|
||||
IsLogLevel l = So $ isLogLevel l
|
||||
|
||||
public export %inline
|
||||
isLogCategory : String -> Bool
|
||||
isLogCategory cat = cat `elem` logCategories
|
||||
|
||||
public export
|
||||
IsLogCategory : String -> Type
|
||||
IsLogCategory cat = So $ isLogCategory cat
|
||||
|
||||
-- Q: why are you using `So` instead of `LT` and `Elem`
|
||||
-- A: ① proof search gives up before finding a proof of e.g. ``99 `LT` 100``
|
||||
-- (i.e. `LTESucc⁹⁹ LTEZero`)
|
||||
-- ② the proofs aren't looked at in any way, i just wanted to make sure the
|
||||
-- list of categories was consistent everywhere
|
||||
|
||||
|
||||
||| a verbosity level from 0–100. higher is noisier. each log entry has a
|
||||
||| verbosity level above which it will be printed, chosen, uh, based on vibes.
|
||||
public export
|
||||
LogLevel : Type
|
||||
LogLevel = Subset Nat IsLogLevel
|
||||
|
||||
||| a logging category, like "check" (type checking), "whnf", or whatever.
|
||||
public export
|
||||
LogCategory : Type
|
||||
LogCategory = Subset String IsLogCategory
|
||||
|
||||
|
||||
public export %inline
|
||||
toLogLevel : Nat -> Maybe LogLevel
|
||||
toLogLevel l =
|
||||
case choose $ isLogLevel l of
|
||||
Left y => Just $ Element l y
|
||||
Right _ => Nothing
|
||||
|
||||
public export %inline
|
||||
toLogCategory : String -> Maybe LogCategory
|
||||
toLogCategory c =
|
||||
case choose $ isLogCategory c of
|
||||
Left y => Just $ Element c y
|
||||
Right _ => Nothing
|
||||
|
||||
|
||||
||| verbosity levels for each category, if they differ from the default
|
||||
public export
|
||||
LevelMap : Type
|
||||
LevelMap = List (LogCategory, LogLevel)
|
||||
|
||||
-- Q: why `List` instead of `SortedMap`
|
||||
-- A: oof ouch my constant factors (maybe this one was more obvious)
|
||||
|
||||
|
||||
public export
|
||||
record LogLevels where
|
||||
constructor MkLogLevels
|
||||
defLevel : LogLevel
|
||||
levels : LevelMap
|
||||
%name LogLevels lvls
|
||||
%runElab derive "LogLevels" [Eq, Show, PrettyVal]
|
||||
|
||||
public export
|
||||
LevelStack : Type
|
||||
LevelStack = List LogLevels
|
||||
|
||||
public export %inline
|
||||
defaultLevel : LogLevel
|
||||
defaultLevel = Element 0 Oh
|
||||
|
||||
export %inline
|
||||
defaultLogLevels : LogLevels
|
||||
defaultLogLevels = MkLogLevels defaultLevel []
|
||||
|
||||
export %inline
|
||||
initStack : LevelStack
|
||||
initStack = []
|
||||
|
||||
export %inline
|
||||
getLevel1 : LogCategory -> LogLevels -> LogLevel
|
||||
getLevel1 cat (MkLogLevels def lvls) = fromMaybe def $ lookup cat lvls
|
||||
|
||||
export %inline
|
||||
getLevel : LogCategory -> LevelStack -> LogLevel
|
||||
getLevel cat (lvls :: _) = getLevel1 cat lvls
|
||||
getLevel cat [] = defaultLevel
|
||||
|
||||
export %inline
|
||||
getCurLevels : LevelStack -> LogLevels
|
||||
getCurLevels (lvls :: _) = lvls
|
||||
getCurLevels [] = defaultLogLevels
|
||||
|
||||
|
||||
public export
|
||||
LogDoc : Type
|
||||
LogDoc = Doc (Opts {lineLength = 80})
|
||||
|
||||
|
||||
private %inline
|
||||
replace : Eq a => a -> b -> List (a, b) -> List (a, b)
|
||||
replace k v kvs = (k, v) :: filter (\y => fst y /= k) kvs
|
||||
|
||||
private %inline
|
||||
mergeLeft : Eq a => List (a, b) -> List (a, b) -> List (a, b)
|
||||
mergeLeft l r = foldl (\lst, (k, v) => replace k v lst) r l
|
||||
|
||||
|
||||
public export
|
||||
data PushArg =
|
||||
SetDefault LogLevel
|
||||
| SetCat LogCategory LogLevel
|
||||
| SetAll LogLevel
|
||||
%runElab derive "PushArg" [Eq, Ord, Show, PrettyVal]
|
||||
%name PushArg push
|
||||
|
||||
export %inline
|
||||
applyPush : LogLevels -> PushArg -> LogLevels
|
||||
applyPush lvls (SetDefault def) = {defLevel := def} lvls
|
||||
applyPush lvls (SetCat cat lvl) = {levels $= replace cat lvl} lvls
|
||||
applyPush lvls (SetAll lvl) = MkLogLevels lvl []
|
||||
|
||||
export %inline
|
||||
fromPush : PushArg -> LogLevels
|
||||
fromPush = applyPush defaultLogLevels
|
||||
|
||||
|
||||
public export
|
||||
record LogMsg where
|
||||
constructor (:>)
|
||||
level : Nat
|
||||
{auto 0 levelOk : IsLogLevel level}
|
||||
message : Lazy LogDoc
|
||||
export infix 0 :>
|
||||
%name Log.LogMsg msg
|
||||
|
||||
public export
|
||||
data LogL : (lbl : tag) -> Type -> Type where
|
||||
||| print some log messages
|
||||
SayMany : (cat : LogCategory) -> (loc : Loc) ->
|
||||
(msgs : List LogMsg) -> LogL lbl ()
|
||||
||| set some verbosity levels
|
||||
Push : (push : List PushArg) -> LogL lbl ()
|
||||
||| restore the previous verbosity levels.
|
||||
||| returns False if the stack was already empty
|
||||
Pop : LogL lbl Bool
|
||||
||| returns the current verbosity levels
|
||||
CurLevels : LogL lbl LogLevels
|
||||
|
||||
public export
|
||||
Log : Type -> Type
|
||||
Log = LogL ()
|
||||
|
||||
parameters (0 lbl : tag) {auto _ : Has (LogL lbl) fs}
|
||||
public export %inline
|
||||
sayManyAt : (cat : String) -> (0 catOk : IsLogCategory cat) =>
|
||||
Loc -> List LogMsg -> Eff fs ()
|
||||
sayManyAt cat loc msgs {catOk} =
|
||||
send $ SayMany {lbl} (Element cat catOk) loc msgs
|
||||
|
||||
public export %inline
|
||||
sayAt : (cat : String) -> (0 catOk : IsLogCategory cat) =>
|
||||
(lvl : Nat) -> (0 lvlOk : IsLogLevel lvl) =>
|
||||
Loc -> Lazy LogDoc -> Eff fs ()
|
||||
sayAt cat lvl loc msg = sayManyAt cat loc [lvl :> msg]
|
||||
|
||||
public export %inline
|
||||
pushAt : List PushArg -> Eff fs ()
|
||||
pushAt lvls = send $ Push {lbl} lvls
|
||||
|
||||
public export %inline
|
||||
push1At : PushArg -> Eff fs ()
|
||||
push1At lvl = pushAt [lvl]
|
||||
|
||||
public export %inline
|
||||
popAt : Eff fs Bool
|
||||
popAt = send $ Pop {lbl}
|
||||
|
||||
public export %inline
|
||||
curLevelsAt : Eff fs LogLevels
|
||||
curLevelsAt = send $ CurLevels {lbl}
|
||||
|
||||
parameters {auto _ : Has Log fs}
|
||||
public export %inline
|
||||
sayMany : (cat : String) -> (0 catOk : IsLogCategory cat) =>
|
||||
Loc -> List LogMsg -> Eff fs ()
|
||||
sayMany = sayManyAt ()
|
||||
|
||||
public export %inline
|
||||
say : (cat : String) -> (0 _ : IsLogCategory cat) =>
|
||||
(lvl : Nat) -> (0 _ : IsLogLevel lvl) =>
|
||||
Loc -> Lazy LogDoc -> Eff fs ()
|
||||
say = sayAt ()
|
||||
|
||||
public export %inline
|
||||
push : List PushArg -> Eff fs ()
|
||||
push = pushAt ()
|
||||
|
||||
public export %inline
|
||||
push1 : PushArg -> Eff fs ()
|
||||
push1 = push1At ()
|
||||
|
||||
public export %inline
|
||||
pop : Eff fs Bool
|
||||
pop = popAt ()
|
||||
|
||||
public export %inline
|
||||
curLevels : Eff fs LogLevels
|
||||
curLevels = curLevelsAt ()
|
||||
|
||||
|
||||
||| handles a `Log` effect with an existing `State` and `Writer`
|
||||
export %inline
|
||||
handleLogSW : (0 s : ts) -> (0 w : tw) ->
|
||||
Has (StateL s LevelStack) fs => Has (WriterL w LogDoc) fs =>
|
||||
LogL tag a -> Eff fs a
|
||||
handleLogSW s w = \case
|
||||
Push push => modifyAt s $ \lst =>
|
||||
foldl applyPush (fromMaybe defaultLogLevels (head' lst)) push :: lst
|
||||
Pop => stateAt s $ maybe (False, []) (True,) . tail'
|
||||
SayMany cat loc msgs => do
|
||||
catLvl <- getsAt s $ fst . getLevel cat
|
||||
let loc = runPretty $ prettyLoc loc
|
||||
for_ msgs $ \(lvl :> msg) => when (lvl <= catLvl) $ tellAt w $
|
||||
hcat [loc, text cat.fst, "@", pshow lvl, ":"] <++> msg
|
||||
CurLevels =>
|
||||
getsAt s getCurLevels
|
||||
|
||||
export %inline
|
||||
handleLogSW_ : LogL tag a -> Eff [State LevelStack, Writer LogDoc] a
|
||||
handleLogSW_ = handleLogSW () ()
|
||||
|
||||
export %inline
|
||||
handleLogIO : HasIO m => MonadRec m =>
|
||||
(FileError -> m ()) -> IORef LevelStack -> File ->
|
||||
LogL tag a -> m a
|
||||
handleLogIO th lvls h act =
|
||||
runEff (handleLogSW_ act) [handleStateIORef lvls, handleWriter {m} printMsg]
|
||||
where printMsg : LogDoc -> m ()
|
||||
printMsg msg = fPutStr h (render _ msg) >>= either th pure
|
||||
|
||||
export %inline
|
||||
handleLogST : HasST m => MonadRec (m s) =>
|
||||
STRef s (SnocList LogDoc) -> STRef s LevelStack ->
|
||||
LogL tag a -> m s a
|
||||
handleLogST docs lvls act =
|
||||
runEff (handleLogSW_ act) [handleStateSTRef lvls, handleWriterSTRef docs]
|
||||
|
||||
export %inline
|
||||
handleLogDiscard : (0 s : ts) -> Has (StateL s Nat) fs =>
|
||||
LogL tag a -> Eff fs a
|
||||
handleLogDiscard s = \case
|
||||
Push _ => modifyAt s S
|
||||
Pop => stateAt s $ \k => (k > 0, pred k)
|
||||
SayMany {} => pure ()
|
||||
CurLevels => pure defaultLogLevels
|
||||
|
||||
export %inline
|
||||
handleLogDiscard_ : LogL tag a -> Eff [State Nat] a
|
||||
handleLogDiscard_ = handleLogDiscard ()
|
||||
|
||||
export %inline
|
||||
handleLogDiscardST : HasST m => MonadRec (m s) => STRef s Nat ->
|
||||
LogL tag a -> m s a
|
||||
handleLogDiscardST ref act =
|
||||
runEff (handleLogDiscard_ act) [handleStateSTRef ref]
|
||||
|
||||
export %inline
|
||||
handleLogDiscardIO : HasIO m => MonadRec m => IORef Nat ->
|
||||
LogL tag a -> m a
|
||||
handleLogDiscardIO ref act =
|
||||
runEff (handleLogDiscard_ act) [handleStateIORef ref]
|
||||
|
||||
|
||||
||| approximate the push/pop effects in a discarded log by trimming a stack or
|
||||
||| repeating its most recent element
|
||||
export %inline
|
||||
fixupDiscardedLog : Nat -> LevelStack -> LevelStack
|
||||
fixupDiscardedLog want lvls =
|
||||
let len = length lvls in
|
||||
case compare len want of
|
||||
EQ => lvls
|
||||
GT => drop (len `minus` want) lvls
|
||||
LT => let new = fromMaybe defaultLogLevels $ head' lvls in
|
||||
replicate (want `minus` len) new ++ lvls
|
|
@ -2,6 +2,7 @@ module Quox.Name
|
|||
|
||||
import Quox.Loc
|
||||
import Quox.CharExtra
|
||||
import Quox.PrettyValExtra
|
||||
import public Data.SnocList
|
||||
import Data.List
|
||||
import Control.Eff
|
||||
|
@ -23,7 +24,7 @@ data BaseName
|
|||
= UN String -- user-given name
|
||||
| MN String NameSuf -- machine-generated name
|
||||
| Unused -- "_"
|
||||
%runElab derive "BaseName" [Eq, Ord]
|
||||
%runElab derive "BaseName" [Eq, Ord, PrettyVal]
|
||||
|
||||
export
|
||||
baseStr : BaseName -> String
|
||||
|
@ -42,14 +43,14 @@ Mods = SnocList String
|
|||
|
||||
public export
|
||||
record Name where
|
||||
constructor MakeName
|
||||
constructor MkName
|
||||
mods : Mods
|
||||
base : BaseName
|
||||
%runElab derive "Name" [Eq, Ord]
|
||||
|
||||
public export %inline
|
||||
unq : BaseName -> Name
|
||||
unq = MakeName [<]
|
||||
unq = MkName [<]
|
||||
|
||||
||| add some namespaces to the beginning of a name
|
||||
public export %inline
|
||||
|
@ -63,31 +64,31 @@ PBaseName = String
|
|||
|
||||
public export
|
||||
record PName where
|
||||
constructor MakePName
|
||||
constructor MkPName
|
||||
mods : Mods
|
||||
base : PBaseName
|
||||
%runElab derive "PName" [Eq, Ord]
|
||||
%runElab derive "PName" [Eq, Ord, PrettyVal]
|
||||
|
||||
export %inline
|
||||
fromPName : PName -> Name
|
||||
fromPName p = MakeName p.mods $ UN p.base
|
||||
fromPName p = MkName p.mods $ UN p.base
|
||||
|
||||
export %inline
|
||||
toPName : Name -> PName
|
||||
toPName p = MakePName p.mods $ baseStr p.base
|
||||
toPName p = MkPName p.mods $ baseStr p.base
|
||||
|
||||
export %inline
|
||||
fromPBaseName : PBaseName -> Name
|
||||
fromPBaseName = MakeName [<] . UN
|
||||
fromPBaseName = MkName [<] . UN
|
||||
|
||||
export
|
||||
Show PName where
|
||||
show (MakePName mods base) =
|
||||
show (MkPName mods base) =
|
||||
show $ concat $ intersperse "." $ toList $ mods :< base
|
||||
|
||||
export Show Name where show = show . toPName
|
||||
|
||||
export FromString PName where fromString = MakePName [<]
|
||||
export FromString PName where fromString = MkPName [<]
|
||||
|
||||
export FromString Name where fromString = fromPBaseName
|
||||
|
||||
|
@ -95,9 +96,9 @@ export FromString Name where fromString = fromPBaseName
|
|||
public export
|
||||
record BindName where
|
||||
constructor BN
|
||||
name : BaseName
|
||||
val : BaseName
|
||||
loc_ : Loc
|
||||
%runElab derive "BindName" [Eq, Ord, Show]
|
||||
%runElab derive "BindName" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export Located BindName where n.loc = n.loc_
|
||||
export Relocatable BindName where setLoc loc (BN x _) = BN x loc
|
||||
|
@ -115,7 +116,7 @@ export
|
|||
fromListP : List1 String -> PName
|
||||
fromListP (x ::: xs) = go [<] x xs where
|
||||
go : SnocList String -> String -> List String -> PName
|
||||
go mods x [] = MakePName mods x
|
||||
go mods x [] = MkPName mods x
|
||||
go mods x (y :: ys) = go (mods :< x) y ys
|
||||
|
||||
export %inline
|
||||
|
@ -169,14 +170,6 @@ public export
|
|||
NameGen : Type -> Type
|
||||
NameGen = StateL GEN NameSuf
|
||||
|
||||
export
|
||||
runNameGenWith : Has NameGen fs =>
|
||||
NameSuf -> Eff fs a -> Eff (fs - NameGen) (a, NameSuf)
|
||||
runNameGenWith = runStateAt GEN
|
||||
|
||||
export
|
||||
runNameGen : Has NameGen fs => Eff fs a -> Eff (fs - NameGen) a
|
||||
runNameGen = map fst . runNameGenWith 0
|
||||
|
||||
||| generate a fresh name with the given base
|
||||
export
|
||||
|
@ -186,15 +179,13 @@ mn base = do
|
|||
modifyAt GEN S
|
||||
pure $ MN base i
|
||||
|
||||
||| generate a fresh binding name with the given base and
|
||||
||| (optionally) location `loc`
|
||||
||| generate a fresh binding name with the given base and location `loc`
|
||||
export
|
||||
mnb : Has NameGen fs =>
|
||||
PBaseName -> {default noLoc loc : Loc} -> Eff fs BindName
|
||||
mnb base = pure $ BN !(mn base) loc
|
||||
mnb : Has NameGen fs => PBaseName -> Loc -> Eff fs BindName
|
||||
mnb base loc = pure $ BN !(mn base) loc
|
||||
|
||||
export
|
||||
fresh : Has NameGen fs => BindName -> Eff fs BindName
|
||||
fresh (BN (UN str) loc) = mnb str {loc}
|
||||
fresh (BN (MN str k) loc) = mnb str {loc}
|
||||
fresh (BN Unused loc) = mnb "x" {loc}
|
||||
fresh (BN (UN str) loc) = mnb str loc
|
||||
fresh (BN (MN str k) loc) = mnb str loc
|
||||
fresh (BN Unused loc) = mnb "x" loc
|
||||
|
|
|
@ -4,6 +4,7 @@ import public Data.Nat
|
|||
import Data.Nat.Division
|
||||
import Data.SnocList
|
||||
import Data.Vect
|
||||
import Data.String
|
||||
|
||||
%default total
|
||||
|
||||
|
@ -52,6 +53,42 @@ parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char)
|
|||
showAtBase : Nat -> String
|
||||
showAtBase = pack . showAtBase' []
|
||||
|
||||
export
|
||||
showHex : Nat -> String
|
||||
showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
|
||||
namespace Nat
|
||||
export
|
||||
showHex : Nat -> String
|
||||
showHex = showAtBase $ fromList $ unpack "0123456789abcdef"
|
||||
|
||||
namespace Int
|
||||
export
|
||||
showHex : Int -> String
|
||||
showHex x =
|
||||
if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x)
|
||||
|
||||
|
||||
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
|
||||
|
|
|
@ -43,7 +43,7 @@ parameters {0 a, b : Bool}
|
|||
noOr2 = snd . noOr
|
||||
|
||||
|
||||
infixr 1 `orNo`
|
||||
export infixr 1 `orNo`
|
||||
export %inline
|
||||
orNo : No a -> No b -> No (a || b)
|
||||
orNo Ah Ah = Ah
|
||||
|
@ -52,3 +52,8 @@ export %inline
|
|||
nchoose : (b : Bool) -> Either (So b) (No b)
|
||||
nchoose True = Left Oh
|
||||
nchoose False = Right Ah
|
||||
|
||||
export
|
||||
0 notYesNo : {f : Dec p} -> Not p -> No (isYes f)
|
||||
notYesNo {f = Yes y} g = absurd $ g y
|
||||
notYesNo {f = No n} g = Ah
|
||||
|
|
|
@ -1,76 +0,0 @@
|
|||
||| "order preserving embeddings", for recording a correspondence between
|
||||
||| a smaller scope and part of a larger one.
|
||||
module Quox.OPE
|
||||
|
||||
import Quox.NatExtra
|
||||
import Data.Nat
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data OPE : Nat -> Nat -> Type where
|
||||
Id : OPE n n
|
||||
Drop : OPE m n -> OPE m (S n)
|
||||
Keep : OPE m n -> OPE (S m) (S n)
|
||||
%name OPE p, q
|
||||
|
||||
public export %inline Injective Drop where injective Refl = Refl
|
||||
public export %inline Injective Keep where injective Refl = Refl
|
||||
|
||||
public export
|
||||
opeZero : {n : Nat} -> OPE 0 n
|
||||
opeZero {n = 0} = Id
|
||||
opeZero {n = S n} = Drop opeZero
|
||||
|
||||
public export
|
||||
(.) : OPE m n -> OPE n p -> OPE m p
|
||||
p . Id = p
|
||||
Id . q = q
|
||||
p . Drop q = Drop $ p . q
|
||||
Drop p . Keep q = Drop $ p . q
|
||||
Keep p . Keep q = Keep $ p . q
|
||||
|
||||
public export
|
||||
toLTE : {m : Nat} -> OPE m n -> m `LTE` n
|
||||
toLTE Id = reflexive
|
||||
toLTE (Drop p) = lteSuccRight $ toLTE p
|
||||
toLTE (Keep p) = LTESucc $ toLTE p
|
||||
|
||||
|
||||
public export
|
||||
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
|
|
@ -1,39 +1,31 @@
|
|||
||| take freshly-parsed input, scope check, type check, add to env
|
||||
module Quox.Parser.FromParser
|
||||
|
||||
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
|
||||
|
||||
import Quox.Pretty
|
||||
import Quox.Parser.Syntax
|
||||
import Quox.Parser.Parser
|
||||
import public Quox.Parser.LoadFile
|
||||
import Quox.Typechecker
|
||||
import Quox.CheckBuiltin
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.SnocVect
|
||||
import Quox.EffExtra
|
||||
import Control.Monad.ST.Extra
|
||||
|
||||
import System.File
|
||||
import System.Path
|
||||
import Data.IORef
|
||||
|
||||
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
|
||||
|
||||
%default total
|
||||
|
||||
%hide Typing.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
public export
|
||||
NDefinition : Type
|
||||
NDefinition = (Name, Definition)
|
||||
|
||||
public export
|
||||
IncludePath : Type
|
||||
IncludePath = List String
|
||||
|
||||
public export
|
||||
SeenFiles : Type
|
||||
SeenFiles = SortedSet String
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
|
@ -41,27 +33,50 @@ data StateTag = NS | SEEN
|
|||
|
||||
public export
|
||||
FromParserPure : List (Type -> Type)
|
||||
FromParserPure =
|
||||
[Except Error, DefsState, StateL NS Mods, NameGen]
|
||||
|
||||
public export
|
||||
LoadFile' : List (Type -> Type)
|
||||
LoadFile' = [IO, StateL SEEN SeenFiles, Reader IncludePath]
|
||||
|
||||
public export
|
||||
LoadFile : List (Type -> Type)
|
||||
LoadFile = LoadFile' ++ [Except Error]
|
||||
FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
|
||||
|
||||
public export
|
||||
FromParserIO : List (Type -> Type)
|
||||
FromParserIO = FromParserPure ++ LoadFile'
|
||||
FromParserIO = FromParserPure ++ [LoadFile]
|
||||
|
||||
|
||||
public export
|
||||
record PureParserResult a where
|
||||
constructor MkPureParserResult
|
||||
val : a
|
||||
suf : NameSuf
|
||||
defs : Definitions
|
||||
log : SnocList LogDoc
|
||||
logLevels : LevelStack
|
||||
|
||||
export
|
||||
fromParserPure : Mods -> NameSuf -> Definitions -> LevelStack ->
|
||||
Eff FromParserPure a -> Either Error (PureParserResult a)
|
||||
fromParserPure ns suf defs lvls act = runSTErr $ do
|
||||
suf <- newSTRef' suf
|
||||
defs <- newSTRef' defs
|
||||
log <- newSTRef' [<]
|
||||
lvls <- newSTRef' lvls
|
||||
res <- runEff act $ with Union.(::)
|
||||
[handleExcept $ \e => stLeft e,
|
||||
handleStateSTRef defs,
|
||||
handleStateSTRef !(newSTRef' ns),
|
||||
handleStateSTRef suf,
|
||||
handleLogST log lvls]
|
||||
pure $ MkPureParserResult {
|
||||
val = res,
|
||||
suf = !(readSTRef' suf),
|
||||
defs = !(readSTRef' defs),
|
||||
log = !(readSTRef' log),
|
||||
logLevels = !(readSTRef' lvls)
|
||||
}
|
||||
|
||||
|
||||
parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
|
||||
(xs : Context' PatVar n)
|
||||
private
|
||||
fromBaseName : PBaseName -> m a
|
||||
fromBaseName x = maybe (f $ MakePName [<] x) b $
|
||||
fromBaseName x = maybe (f $ MkPName [<] x) b $
|
||||
Context.find (\y => y.name == Just x) xs
|
||||
|
||||
private
|
||||
|
@ -113,11 +128,10 @@ fromV : Context' PatVar d -> Context' PatVar n ->
|
|||
PName -> Maybe Universe -> Loc -> Eff FromParserPure (Term d n)
|
||||
fromV ds ns x u loc = fromName bound free ns x where
|
||||
bound : Var n -> Eff FromParserPure (Term d n)
|
||||
bound i = do whenJust u $ \u => throw $ DisplacedBoundVar loc x
|
||||
pure $ E $ B i loc
|
||||
bound i = unless (isNothing u) (throw $ DisplacedBoundVar loc x) $> BT i loc
|
||||
|
||||
free : PName -> Eff FromParserPure (Term d n)
|
||||
free x = do x <- avoidDim ds loc x
|
||||
resolveName !(getAt NS) loc x u
|
||||
free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
|
||||
|
||||
mutual
|
||||
export
|
||||
|
@ -127,6 +141,9 @@ 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
|
||||
|
@ -157,17 +174,26 @@ mutual
|
|||
<*> fromPTermTScope ds ns [< x, y] body
|
||||
<*> pure loc
|
||||
|
||||
Fst pair loc =>
|
||||
map E $ Fst <$> fromPTermElim ds ns pair <*> pure loc
|
||||
|
||||
Snd pair loc =>
|
||||
map E $ Snd <$> fromPTermElim ds ns pair <*> pure loc
|
||||
|
||||
Case pi tag (r, ret) (CaseEnum arms _) loc =>
|
||||
map E $ CaseEnum (fromPQty pi)
|
||||
<$> fromPTermElim ds ns tag
|
||||
<*> fromPTermTScope ds ns [< r] ret
|
||||
<*> assert_total fromPTermEnumArms ds ns arms
|
||||
<*> assert_total fromPTermEnumArms loc ds ns arms
|
||||
<*> pure loc
|
||||
|
||||
Nat loc => pure $ Nat loc
|
||||
Zero loc => pure $ Zero loc
|
||||
NAT loc => pure $ NAT loc
|
||||
Nat n loc => pure $ Nat n loc
|
||||
Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|]
|
||||
|
||||
STRING loc => pure $ STRING loc
|
||||
Str str loc => pure $ Str str loc
|
||||
|
||||
Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
|
||||
map E $ CaseNat (fromPQty pi) (fromPQty pi')
|
||||
<$> fromPTermElim ds ns nat
|
||||
|
@ -176,12 +202,11 @@ mutual
|
|||
<*> fromPTermTScope ds ns [< s, ih] suc
|
||||
<*> pure loc
|
||||
|
||||
Enum strs loc =>
|
||||
let set = SortedSet.fromList strs in
|
||||
if length strs == length (SortedSet.toList set) then
|
||||
Enum strs loc => do
|
||||
let set = SortedSet.fromList strs
|
||||
unless (length strs == length (SortedSet.toList set)) $
|
||||
throw $ DuplicatesInEnumType loc strs
|
||||
pure $ Enum set loc
|
||||
else
|
||||
throw $ DuplicatesInEnum loc strs
|
||||
|
||||
Tag str loc => pure $ Tag str loc
|
||||
|
||||
|
@ -238,13 +263,22 @@ 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 : Context' PatVar d -> Context' PatVar n ->
|
||||
fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n ->
|
||||
List (PTagVal, PTerm) ->
|
||||
Eff FromParserPure (CaseEnumArms d n)
|
||||
fromPTermEnumArms ds ns =
|
||||
map SortedMap.fromList .
|
||||
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
|
||||
fromPTermEnumArms loc ds ns arms = do
|
||||
res <- SortedMap.fromList <$>
|
||||
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms
|
||||
unless (length (keys res) == length arms) $
|
||||
throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms)
|
||||
pure res
|
||||
|
||||
private
|
||||
fromPTermElim : Context' PatVar d -> Context' PatVar n ->
|
||||
|
@ -263,7 +297,7 @@ mutual
|
|||
if all isUnused xs then
|
||||
SN <$> fromPTermWith ds ns t
|
||||
else
|
||||
ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
|
||||
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
|
||||
|
||||
private
|
||||
fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
|
||||
|
@ -271,9 +305,9 @@ mutual
|
|||
Eff FromParserPure (DScopeTermN s d n)
|
||||
fromPTermDScope ds ns xs t =
|
||||
if all isUnused xs then
|
||||
SN <$> fromPTermWith ds ns t
|
||||
SN {f = \d => Term d n} <$> fromPTermWith ds ns t
|
||||
else
|
||||
DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
|
||||
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
|
||||
|
||||
|
||||
export %inline
|
||||
|
@ -282,72 +316,110 @@ fromPTerm = fromPTermWith [<] [<]
|
|||
|
||||
|
||||
export
|
||||
globalPQty : Loc -> (q : Qty) -> Eff [Except Error] (So $ isGlobal q)
|
||||
globalPQty loc pi = case choose $ isGlobal pi of
|
||||
Left y => pure y
|
||||
Right _ => throw $ QtyNotGlobal loc pi
|
||||
|
||||
globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty
|
||||
globalPQty (PQ pi loc) = case toGlobal pi of
|
||||
Just g => pure g
|
||||
Nothing => throw $ QtyNotGlobal loc pi
|
||||
|
||||
export
|
||||
fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name
|
||||
fromPBaseNameNS : Has (StateL NS Mods) fs => PBaseName -> Eff fs Name
|
||||
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
|
||||
|
||||
|
||||
private
|
||||
liftTC : TC a -> Eff FromParserPure a
|
||||
liftTC act = do
|
||||
res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act
|
||||
rethrow $ mapFst WrapTypeError res
|
||||
liftTC : Eff TC a -> Eff FromParserPure a
|
||||
liftTC tc = runEff tc $ with Union.(::)
|
||||
[handleExcept $ \e => throw $ WrapTypeError e,
|
||||
handleReaderConst !(getAt DEFS),
|
||||
\g => send g,
|
||||
\g => send g]
|
||||
|
||||
private
|
||||
liftWhnf : Eff Whnf a -> Eff FromParserPure a
|
||||
liftWhnf tc = runEff tc $ with Union.(::)
|
||||
[handleExcept $ \e => throw $ WrapTypeError e,
|
||||
\g => send g,
|
||||
\g => send g]
|
||||
|
||||
private
|
||||
addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition
|
||||
addDef name def = do
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
|
||||
|
||||
export covering
|
||||
fromPDef : PDefinition -> Eff FromParserPure NDefinition
|
||||
fromPDef (MkPDef qty pname ptype pterm defLoc) = do
|
||||
name <- lift $ fromPBaseNameNS pname
|
||||
qtyGlobal <- lift $ globalPQty qty.loc qty.val
|
||||
let gqty = Element qty.val qtyGlobal
|
||||
sqty = globalToSubj gqty
|
||||
type <- lift $ traverse fromPTerm ptype
|
||||
term <- lift $ fromPTerm pterm
|
||||
case type of
|
||||
fromPDef def = do
|
||||
name <- fromPBaseNameNS def.name
|
||||
defs <- getAt DEFS
|
||||
when (isJust $ lookup name defs) $ do
|
||||
throw $ AlreadyExists def.loc name
|
||||
gqty <- globalPQty def.qty
|
||||
let sqty = globalToSubj gqty
|
||||
case def.body of
|
||||
PConcrete ptype pterm => do
|
||||
type <- traverse fromPTerm ptype
|
||||
term <- fromPTerm pterm
|
||||
type <- case type of
|
||||
Just type => do
|
||||
liftTC $ checkTypeC empty type Nothing
|
||||
liftTC $ ignore $ checkC empty sqty term type
|
||||
let def = mkDef gqty type term defLoc
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
ignore $ liftTC $ do
|
||||
checkTypeC empty type Nothing
|
||||
checkC empty sqty term type
|
||||
pure type
|
||||
Nothing => do
|
||||
let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term
|
||||
let E elim = term
|
||||
| _ => throw $ AnnotationNeeded term.loc empty term
|
||||
res <- liftTC $ inferC empty sqty elim
|
||||
let def = mkDef gqty res.type term defLoc
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
pure res.type
|
||||
when def.main $ liftWhnf $ expectMainType defs type
|
||||
addDef name $ mkDef gqty type term def.scheme def.main def.loc
|
||||
PPostulate ptype => do
|
||||
type <- fromPTerm ptype
|
||||
addDef name $ mkPostulate gqty type def.scheme def.main def.loc
|
||||
|
||||
|
||||
public export
|
||||
data HasFail = NoFail | AnyFail | FailWith String
|
||||
|
||||
export covering
|
||||
expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error
|
||||
expectFail loc act = do
|
||||
gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels
|
||||
case fromParserPure ns gen defs (singleton lvl) act of
|
||||
Left err => pure err
|
||||
Right _ => throw $ ExpectedFail loc
|
||||
|
||||
export covering
|
||||
maybeFail : Monoid a =>
|
||||
PFail -> Loc -> Eff FromParserPure a -> Eff FromParserPure a
|
||||
maybeFail PSucceed _ act = act
|
||||
maybeFail PFailAny loc act = expectFail loc act $> neutral
|
||||
maybeFail (PFailMatch str) loc act = do
|
||||
err <- expectFail loc act
|
||||
let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e
|
||||
if str `isInfixOf` renderInfinite msg
|
||||
then pure neutral
|
||||
else throw $ WrongFail str err loc
|
||||
|
||||
export covering
|
||||
fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
|
||||
fromPDecl (PDef def) = singleton <$> fromPDef def
|
||||
fromPDecl (PDef def) =
|
||||
maybeFail def.fail def.loc $ singleton <$> fromPDef def
|
||||
fromPDecl (PNs ns) =
|
||||
maybeFail ns.fail ns.loc $
|
||||
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
||||
|
||||
|
||||
export covering
|
||||
loadFile : Loc -> String -> Eff LoadFile (Maybe String)
|
||||
loadFile loc file =
|
||||
if contains file !(getAt SEEN) then
|
||||
pure Nothing
|
||||
else do
|
||||
Just ifile <- firstExists (map (</> file) !ask)
|
||||
| Nothing => throw $ LoadError loc file FileNotFound
|
||||
case !(readFile ifile) of
|
||||
Right res => modifyAt SEEN (insert file) $> Just res
|
||||
Left err => throw $ LoadError loc ifile err
|
||||
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 !(lift $ loadFile loc file) of
|
||||
Just inp => do
|
||||
tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
|
||||
concat <$> traverse fromPTopLevel tl
|
||||
case !(loadFile loc file) of
|
||||
Just tl => concat <$> traverse fromPTopLevel tl
|
||||
Nothing => pure []
|
||||
|
||||
||| populates the `defs` field of the state
|
||||
|
@ -355,28 +427,3 @@ mutual
|
|||
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
|
||||
fromPTopLevel (PD decl) = lift $ fromPDecl decl
|
||||
fromPTopLevel (PLoad file loc) = loadProcessFile loc file
|
||||
|
||||
export
|
||||
fromParserPure : NameSuf -> Definitions ->
|
||||
Eff FromParserPure a ->
|
||||
(Either Error (a, Definitions), NameSuf)
|
||||
fromParserPure suf defs act =
|
||||
extract $
|
||||
runStateAt GEN suf $
|
||||
runExcept $
|
||||
evalStateAt NS [<] $
|
||||
runStateAt DEFS defs act
|
||||
|
||||
export
|
||||
fromParserIO : (MonadRec io, HasIO io) =>
|
||||
IncludePath ->
|
||||
IORef SeenFiles -> IORef NameSuf -> IORef Definitions ->
|
||||
Eff FromParserIO a -> io (Either Error a)
|
||||
fromParserIO inc seen suf defs act =
|
||||
runIO $
|
||||
runStateIORefAt GEN suf $
|
||||
runExcept $
|
||||
evalStateAt NS [<] $
|
||||
runStateIORefAt SEEN seen $
|
||||
runStateIORefAt DEFS defs $
|
||||
runReader inc act
|
||||
|
|
|
@ -1,11 +1,14 @@
|
|||
module Quox.Parser.FromParser.Error
|
||||
|
||||
import Quox.Parser.Parser
|
||||
import Quox.Parser.LoadFile
|
||||
import Quox.Typing
|
||||
import System.File
|
||||
|
||||
import Quox.Pretty
|
||||
|
||||
%default total
|
||||
|
||||
%hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)
|
||||
|
||||
|
||||
|
@ -21,26 +24,34 @@ ParseError = Parser.Error
|
|||
public export
|
||||
data Error =
|
||||
AnnotationNeeded Loc (NameContexts d n) (Term d n)
|
||||
| DuplicatesInEnum Loc (List TagVal)
|
||||
| DuplicatesInEnumType Loc (List TagVal)
|
||||
| DuplicatesInEnumCase Loc (List TagVal)
|
||||
| TermNotInScope Loc Name
|
||||
| DimNotInScope Loc PBaseName
|
||||
| QtyNotGlobal Loc Qty
|
||||
| DimNameInTerm Loc PBaseName
|
||||
| DisplacedBoundVar Loc PName
|
||||
| WrapTypeError TypeError
|
||||
| LoadError Loc String FileError
|
||||
| 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
|
||||
EndInput => pure "unexpected end of input"
|
||||
NoRuleApply => pure $ text "unrecognised character: \{show char}"
|
||||
Other msg => pure $ text msg
|
||||
NoRuleApply => case char of
|
||||
Just char => pure $ text "unrecognised character: \{show char}"
|
||||
Nothing => pure $ text "unexpected end of input"
|
||||
ComposeNotClosing (sl, sc) (el, ec) => pure $
|
||||
hsep ["unterminated token at", !(prettyBounds (MkBounds sl sc el ec))]
|
||||
let loc = makeLoc file (MkBounds line col line col)
|
||||
pure $ vappend !(prettyLoc loc) reason
|
||||
|
||||
export
|
||||
|
@ -61,19 +72,23 @@ prettyParseError file (ParseError errs) =
|
|||
traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
|
||||
|
||||
|
||||
parameters (showContext : Bool)
|
||||
parameters {opts : LayoutOpts} (showContext : Bool)
|
||||
export
|
||||
prettyError : {opts : _} -> Error -> Eff Pretty (Doc opts)
|
||||
prettyError : Error -> Eff Pretty (Doc opts)
|
||||
prettyError (AnnotationNeeded loc ctx tm) =
|
||||
[|vappend (prettyLoc loc)
|
||||
(hangD "type annotation needed on"
|
||||
!(prettyTerm ctx.dnames ctx.tnames tm))|]
|
||||
-- [todo] print the original PTerm instead
|
||||
|
||||
prettyError (DuplicatesInEnum loc tags) =
|
||||
prettyError (DuplicatesInEnumType loc tags) =
|
||||
[|vappend (prettyLoc loc)
|
||||
(hangD "duplicate tags in enum type" !(prettyEnum tags))|]
|
||||
|
||||
prettyError (DuplicatesInEnumCase loc tags) =
|
||||
[|vappend (prettyLoc loc)
|
||||
(hangD "duplicate arms in enum case" !(prettyEnum tags))|]
|
||||
|
||||
prettyError (DimNotInScope loc i) =
|
||||
[|vappend (prettyLoc loc)
|
||||
(pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]
|
||||
|
@ -100,10 +115,32 @@ parameters (showContext : Bool)
|
|||
prettyError (WrapTypeError err) =
|
||||
Typing.prettyError showContext $ trimContext 2 err
|
||||
|
||||
prettyError (LoadError loc str err) = pure $
|
||||
prettyError (AlreadyExists loc name) = pure $
|
||||
vsep [!(prettyLoc loc),
|
||||
"couldn't load file" <++> text str,
|
||||
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
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
module Quox.Parser.Lexer
|
||||
|
||||
import Quox.CharExtra
|
||||
import Quox.NatExtra
|
||||
import Quox.Name
|
||||
import Data.String.Extra
|
||||
import Data.SortedMap
|
||||
|
@ -19,7 +20,7 @@ import Derive.Prelude
|
|||
||| @ Reserved reserved token
|
||||
||| @ Name name, possibly qualified
|
||||
||| @ Nat nat literal
|
||||
||| @ String string literal
|
||||
||| @ Str string literal
|
||||
||| @ Tag tag literal
|
||||
||| @ TYPE "Type" or "★" with ascii nat directly after
|
||||
||| @ Sup superscript or ^ number (displacement, or universe for ★)
|
||||
|
@ -34,16 +35,27 @@ 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
|
||||
0 TokenW : Type
|
||||
TokenW = Maybe Token
|
||||
data ExtToken = Skip | Invalid String String | T Token
|
||||
%runElab derive "ExtToken" [Eq, Ord, Show]
|
||||
|
||||
|
||||
public export
|
||||
data ErrorReason =
|
||||
NoRuleApply
|
||||
| ComposeNotClosing (Int, Int) (Int, Int)
|
||||
| Other String
|
||||
%runElab derive "ErrorReason" [Eq, Ord, Show]
|
||||
|
||||
public export
|
||||
record Error where
|
||||
constructor Err
|
||||
reason : StopReason
|
||||
reason : ErrorReason
|
||||
line, col : Int
|
||||
||| `Nothing` if the error is at the end of the input
|
||||
char : Maybe Char
|
||||
|
@ -52,49 +64,94 @@ record Error where
|
|||
|
||||
|
||||
private
|
||||
skip : Lexer -> Tokenizer TokenW
|
||||
skip t = match t $ const Nothing
|
||||
skip : Lexer -> Tokenizer ExtToken
|
||||
skip t = match t $ const Skip
|
||||
|
||||
private
|
||||
match : Lexer -> (String -> Token) -> Tokenizer TokenW
|
||||
match t f = Tokenizer.match t (Just . f)
|
||||
%hide Tokenizer.match
|
||||
tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
|
||||
tmatch t f = match t (T . f)
|
||||
|
||||
|
||||
private
|
||||
name : Tokenizer TokenW
|
||||
name = match name $ Name . fromListP . split (== '.') . normalizeNfc
|
||||
|
||||
||| [todo] escapes other than `\"` and (accidentally) `\\`
|
||||
export
|
||||
fromStringLit : String -> String
|
||||
fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where
|
||||
fromStringLit : (String -> Token) -> String -> ExtToken
|
||||
fromStringLit f str =
|
||||
case go $ unpack $ drop 1 $ dropLast 1 str of
|
||||
Left err => Invalid err str
|
||||
Right ok => T $ f $ pack ok
|
||||
where
|
||||
Interpolation Char where interpolate = singleton
|
||||
|
||||
go, hexEscape : List Char -> Either String (List Char)
|
||||
|
||||
go [] = Right []
|
||||
go ['\\'] = Left "string ends with \\"
|
||||
go ('\\' :: 'n' :: cs) = ('\n' ::) <$> go cs
|
||||
go ('\\' :: 't' :: cs) = ('\t' ::) <$> go cs
|
||||
go ('\\' :: 'x' :: cs) = hexEscape cs
|
||||
go ('\\' :: 'X' :: cs) = hexEscape cs
|
||||
go ('\\' :: '\\' :: cs) = ('\\' ::) <$> go cs
|
||||
go ('\\' :: '"' :: cs) = ('"' ::) <$> go cs
|
||||
-- [todo] others
|
||||
go ('\\' :: c :: _) = Left "unknown escape '\{c}'"
|
||||
go (c :: cs) = (c ::) <$> go cs
|
||||
|
||||
hexEscape cs =
|
||||
case break (== ';') cs of
|
||||
(hs, ';' :: rest) => do
|
||||
let hs = pack hs
|
||||
let Just c = Int.fromHex hs
|
||||
| Nothing => Left #"invalid hex string "\#{hs}" in escape"#
|
||||
if isCodepoint c
|
||||
then (chr c ::) <$> go (assert_smaller cs rest)
|
||||
else Left "codepoint \{hs} out of range"
|
||||
_ => Left "unterminated hex escape"
|
||||
|
||||
private
|
||||
string : Tokenizer ExtToken
|
||||
string = match stringLit $ fromStringLit Str
|
||||
|
||||
|
||||
%hide binLit
|
||||
%hide octLit
|
||||
%hide hexLit
|
||||
|
||||
private
|
||||
nat : Tokenizer ExtToken
|
||||
nat = match hexLit fromHexLit
|
||||
<|> tmatch decLit fromDecLit
|
||||
where
|
||||
withUnderscores : Lexer -> Lexer
|
||||
withUnderscores l = l <+> many (opt (is '_') <+> l)
|
||||
|
||||
withoutUnderscores : String -> String
|
||||
withoutUnderscores = pack . go . unpack where
|
||||
go : List Char -> List Char
|
||||
go [] = []
|
||||
go ['\\'] = ['\\'] -- i guess???
|
||||
go ('\\' :: c :: cs) = c :: go cs
|
||||
go ('_' :: cs) = go cs
|
||||
go (c :: cs) = c :: go cs
|
||||
|
||||
private
|
||||
string : Tokenizer TokenW
|
||||
string = match stringLit (Str . fromStringLit)
|
||||
decLit =
|
||||
withUnderscores (range '0' '9') <+> reject idContEnd
|
||||
|
||||
hexLit =
|
||||
approx "0x" <+>
|
||||
withUnderscores (range '0' '9' <|> range 'a' 'f' <|> range 'A' 'F') <+>
|
||||
reject idContEnd
|
||||
|
||||
fromDecLit : String -> Token
|
||||
fromDecLit = Nat . cast . withoutUnderscores
|
||||
|
||||
fromHexLit : String -> ExtToken
|
||||
fromHexLit str =
|
||||
maybe (Invalid "invalid hex sequence" str) (T . Nat) $
|
||||
fromHex $ withoutUnderscores $ drop 2 str
|
||||
|
||||
|
||||
private
|
||||
nat : Tokenizer TokenW
|
||||
nat = match (some (range '0' '9')) (Nat . cast)
|
||||
tag : Tokenizer ExtToken
|
||||
tag = tmatch (is '\'' <+> name) (Tag . drop 1)
|
||||
<|> 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
|
||||
|
@ -102,27 +159,23 @@ 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
|
||||
-- ★0, Type0. base ★/Type is a Reserved and ★¹/Type¹ are sequences of two tokens
|
||||
private
|
||||
universe : Tokenizer TokenW
|
||||
universe : Tokenizer ExtToken
|
||||
universe = universeWith "★" <|> universeWith "Type" where
|
||||
universeWith : String -> Tokenizer TokenW
|
||||
universeWith : String -> Tokenizer ExtToken
|
||||
universeWith pfx =
|
||||
let len = length pfx in
|
||||
match (exact pfx <+> digits) (TYPE . cast . drop len)
|
||||
tmatch (exact pfx <+> digits) (TYPE . cast . drop len)
|
||||
|
||||
private
|
||||
sup : Tokenizer TokenW
|
||||
sup = match (some $ pred isSupDigit) (Sup . supToNat)
|
||||
<|> match (is '^' <+> digits) (Sup . cast . drop 1)
|
||||
sup : Tokenizer ExtToken
|
||||
sup = tmatch (some $ pred isSupDigit) (Sup . supToNat)
|
||||
<|> tmatch (is '^' <+> digits) (Sup . cast . drop 1)
|
||||
|
||||
|
||||
private %inline
|
||||
|
@ -134,9 +187,11 @@ 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 Char
|
||||
data Reserved1 = Word String | Sym String | Punc String
|
||||
%runElab derive "Reserved1" [Eq, Ord, Show]
|
||||
|
||||
||| description of a token that might have unicode & ascii-only aliases
|
||||
|
@ -145,17 +200,14 @@ namespace Reserved
|
|||
%runElab derive "Reserved" [Eq, Ord, Show]
|
||||
|
||||
public export
|
||||
Sym1, Word1 : String -> Reserved
|
||||
Sym1, Word1, Punc1 : String -> Reserved
|
||||
Sym1 = Only . Sym
|
||||
Word1 = Only . Word
|
||||
|
||||
public export
|
||||
Punc1 : Char -> Reserved
|
||||
Punc1 = Only . Punc
|
||||
|
||||
public export
|
||||
resString1 : Reserved1 -> String
|
||||
resString1 (Punc x) = singleton x
|
||||
resString1 (Punc x) = x
|
||||
resString1 (Word w) = w
|
||||
resString1 (Sym s) = s
|
||||
|
||||
|
@ -166,17 +218,23 @@ 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 TokenW
|
||||
resTokenizer1 : Reserved1 -> String -> Tokenizer ExtToken
|
||||
resTokenizer1 r str =
|
||||
let res : String -> Token := const $ Reserved str in
|
||||
case r of Word w => match (exact w <+> reject idContEnd) res
|
||||
Sym s => match (exact s <+> reject symCont) res
|
||||
Punc x => match (is x) res
|
||||
case r of Word w => tmatch (exact w <+> reject idContEnd) res
|
||||
Sym s => tmatch (exact s <+> reject symCont) res
|
||||
Punc x => tmatch (exact x) res
|
||||
|
||||
||| match a reserved token
|
||||
export
|
||||
resTokenizer : Reserved -> Tokenizer TokenW
|
||||
resTokenizer : Reserved -> Tokenizer ExtToken
|
||||
resTokenizer (Only r) = resTokenizer1 r (resString1 r)
|
||||
resTokenizer (r `Or` s) =
|
||||
resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
|
||||
|
@ -188,8 +246,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 "=>",
|
||||
|
@ -197,12 +255,16 @@ reserved =
|
|||
Sym "×" `Or` Sym "**",
|
||||
Sym "≡" `Or` Sym "==",
|
||||
Sym "∷" `Or` Sym "::",
|
||||
Punc1 '.',
|
||||
Punc1 ".",
|
||||
Word1 "case",
|
||||
Word1 "case0", Word1 "case1",
|
||||
Word "caseω" `Or` Word "case#",
|
||||
Word1 "return",
|
||||
Word1 "of",
|
||||
Word1 "let", Word1 "in",
|
||||
Word1 "let0", Word1 "let1",
|
||||
Word "letω" `Or` Word "let#",
|
||||
Word1 "fst", Word1 "snd",
|
||||
Word1 "_",
|
||||
Word1 "Eq",
|
||||
Word "λ" `Or` Word "fun",
|
||||
|
@ -210,35 +272,71 @@ 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 = str `Elem` map resString reserved
|
||||
IsReserved str = So (str `elem` reservedStrings)
|
||||
|
||||
private
|
||||
name : Tokenizer ExtToken
|
||||
name =
|
||||
match name $ \str =>
|
||||
let parts = split (== '.') $ normalizeNfc str in
|
||||
case find (`elem` allReservedStrings) (toList parts) of
|
||||
Nothing => T $ Name $ fromListP parts
|
||||
Just w => Invalid "reserved word '\{w}' inside name \{str}" str
|
||||
|
||||
export
|
||||
tokens : Tokenizer TokenW
|
||||
tokens : Tokenizer ExtToken
|
||||
tokens = choice $
|
||||
map skip [pred isWhitespace,
|
||||
lineComment (exact "--" <+> reject symCont),
|
||||
blockComment (exact "{-") (exact "-}")] <+>
|
||||
[universe] <+> -- ★ᵢ takes precedence over bare ★
|
||||
[universe] <+> -- Type<i> takes precedence over bare Type
|
||||
map resTokenizer reserved <+>
|
||||
[sup, nat, string, tag, name]
|
||||
|
||||
export
|
||||
check : Alternative f =>
|
||||
WithBounds ExtToken -> Either Error (f (WithBounds Token))
|
||||
check (MkBounded val irr bounds@(MkBounds line col _ _)) = case val of
|
||||
Skip => Right empty
|
||||
T tok => Right $ pure $ MkBounded tok irr bounds
|
||||
Invalid msg tok => Left $ Err (Other msg) line col (index 0 tok)
|
||||
|
||||
export
|
||||
toErrorReason : StopReason -> Maybe ErrorReason
|
||||
toErrorReason EndInput = Nothing
|
||||
toErrorReason NoRuleApply = Just NoRuleApply
|
||||
toErrorReason (ComposeNotClosing s e) = Just $ ComposeNotClosing s e
|
||||
|
||||
export
|
||||
lex : String -> Either Error (List (WithBounds Token))
|
||||
lex str =
|
||||
let (res, reason, line, col, str) = lex tokens str in
|
||||
case reason of
|
||||
EndInput => Right $ mapMaybe sequence res
|
||||
_ => Left $ Err {reason, line, col, char = index 0 str}
|
||||
case toErrorReason reason of
|
||||
Nothing => concatMap check res @{MonoidApplicative}
|
||||
Just e => Left $ Err {reason = e, line, col, char = index 0 str}
|
||||
|
|
100
lib/Quox/Parser/LoadFile.idr
Normal file
100
lib/Quox/Parser/LoadFile.idr
Normal file
|
@ -0,0 +1,100 @@
|
|||
module Quox.Parser.LoadFile
|
||||
|
||||
import public Quox.Parser.Syntax
|
||||
import Quox.Parser.Parser
|
||||
import Quox.Loc
|
||||
import Quox.EffExtra
|
||||
import Data.IORef
|
||||
import Data.SortedSet
|
||||
import System.File
|
||||
import System.Path
|
||||
|
||||
|
||||
%default total
|
||||
|
||||
public export
|
||||
FilePath : Type
|
||||
FilePath = String
|
||||
|
||||
|
||||
public export
|
||||
data LoadFileL : (lbl : k) -> Type -> Type where
|
||||
[search lbl]
|
||||
Seen : FilePath -> LoadFileL lbl Bool
|
||||
SetSeen : FilePath -> LoadFileL lbl ()
|
||||
DoLoad : Loc -> FilePath -> LoadFileL lbl PFile
|
||||
|
||||
public export
|
||||
LoadFile : Type -> Type
|
||||
LoadFile = LoadFileL ()
|
||||
|
||||
|
||||
export
|
||||
seenAt : (0 lbl : k) -> Has (LoadFileL lbl) fs => FilePath -> Eff fs Bool
|
||||
seenAt lbl file = send $ Seen {lbl} file
|
||||
|
||||
export %inline
|
||||
seen : Has LoadFile fs => FilePath -> Eff fs Bool
|
||||
seen = seenAt ()
|
||||
|
||||
|
||||
export
|
||||
setSeenAt : (0 lbl : k) -> Has (LoadFileL lbl) fs => FilePath -> Eff fs ()
|
||||
setSeenAt lbl file = send $ SetSeen {lbl} file
|
||||
|
||||
export %inline
|
||||
setSeen : Has LoadFile fs => FilePath -> Eff fs ()
|
||||
setSeen = setSeenAt ()
|
||||
|
||||
|
||||
export
|
||||
doLoadAt : (0 lbl : k) -> Has (LoadFileL lbl) fs =>
|
||||
Loc -> FilePath -> Eff fs PFile
|
||||
doLoadAt lbl loc file = send $ DoLoad {lbl} loc file
|
||||
|
||||
export %inline
|
||||
doLoad : Has LoadFile fs => Loc -> FilePath -> Eff fs PFile
|
||||
doLoad = doLoadAt ()
|
||||
|
||||
|
||||
public export
|
||||
SeenSet : Type
|
||||
SeenSet = SortedSet FilePath
|
||||
|
||||
public export
|
||||
IncludePath : Type
|
||||
IncludePath = List String
|
||||
|
||||
export covering
|
||||
readFileFrom : HasIO io => IncludePath -> FilePath ->
|
||||
io (Either FileError String)
|
||||
readFileFrom inc f =
|
||||
case !(firstExists $ map (</> f) inc) of
|
||||
Just path => readFile path
|
||||
Nothing => pure $ Left $ FileNotFound
|
||||
|
||||
export covering
|
||||
handleLoadFileIOE : (Loc -> FilePath -> FileError -> e) ->
|
||||
(FilePath -> Parser.Error -> e) ->
|
||||
IORef SeenSet -> IncludePath ->
|
||||
LoadFileL lbl a -> IOErr e a
|
||||
handleLoadFileIOE injf injp seen inc = \case
|
||||
Seen f => contains f <$> readIORef seen
|
||||
SetSeen f => modifyIORef seen $ insert f
|
||||
DoLoad l f =>
|
||||
case !(readFileFrom inc f) of
|
||||
Left err => ioLeft $ injf l f err
|
||||
Right str => either (ioLeft . injp f) pure $ lexParseInput f str
|
||||
|
||||
|
||||
export
|
||||
loadFileAt : (0 lbl : k) -> Has (LoadFileL lbl) fs =>
|
||||
Loc -> FilePath -> Eff fs (Maybe PFile)
|
||||
loadFileAt lbl loc file =
|
||||
if !(seenAt lbl file)
|
||||
then pure Nothing
|
||||
else Just <$> doLoadAt lbl loc file <* setSeenAt lbl file
|
||||
|
||||
export
|
||||
loadFile : Has LoadFile fs => Loc -> FilePath -> Eff fs (Maybe PFile)
|
||||
loadFile = loadFileAt ()
|
|
@ -124,7 +124,7 @@ qname = terminalMatch "name" `(Name n) `(n)
|
|||
||| unqualified name
|
||||
export
|
||||
baseName : Grammar True PBaseName
|
||||
baseName = terminalMatch "unqualified name" `(Name (MakePName [<] b)) `(b)
|
||||
baseName = terminalMatch "unqualified name" `(Name (MkPName [<] b)) `(b)
|
||||
|
||||
||| dimension constant (0 or 1)
|
||||
export
|
||||
|
@ -149,6 +149,12 @@ 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
|
||||
|
@ -198,18 +204,21 @@ export
|
|||
enumType : Grammar True (List TagVal)
|
||||
enumType = delimSep "{" "}" "," bareTag
|
||||
|
||||
||| e.g. `case` or `case 1.`
|
||||
||| e.g. `case1` or `case 1.`
|
||||
export
|
||||
caseIntro : FileName -> Grammar True PQty
|
||||
caseIntro fname =
|
||||
withLoc fname (PQ Zero <$ res "case0")
|
||||
<|> withLoc fname (PQ One <$ res "case1")
|
||||
<|> withLoc fname (PQ Any <$ res "caseω")
|
||||
<|> delim "case" "." (qty fname)
|
||||
<|> do resC "case"
|
||||
qty fname <* needRes "." <|> defLoc fname (PQ One)
|
||||
|
||||
export
|
||||
qtyPatVar : FileName -> Grammar True (PQty, PatVar)
|
||||
qtyPatVar fname = [|(,) (qty fname) (needRes "." *> patVar fname)|]
|
||||
qtyPatVar fname =
|
||||
[|(,) (qty fname) (needRes "." *> patVar fname)|]
|
||||
<|> [|(,) (defLoc fname $ PQ One) (patVar fname)|]
|
||||
|
||||
|
||||
export
|
||||
|
@ -277,19 +286,81 @@ export
|
|||
universe1 : Grammar True Universe
|
||||
universe1 = universeTok <|> res "★" *> option 0 super
|
||||
|
||||
||| argument/atomic term: single-token terms, or those with delimiters e.g.
|
||||
||| `[t]`
|
||||
|
||||
public export
|
||||
PCaseArm : Type
|
||||
PCaseArm = (PCasePat, PTerm)
|
||||
|
||||
export
|
||||
caseArm : FileName -> Grammar True PCaseArm
|
||||
caseArm fname =
|
||||
[|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
|
||||
|
||||
export
|
||||
checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody
|
||||
checkCaseArms loc [] = pure $ CaseEnum [] loc
|
||||
checkCaseArms loc ((PPair x y _, rhs) :: rest) =
|
||||
if null rest then pure $ CasePair (x, y) rhs loc
|
||||
else fatalError "unexpected pattern after pair"
|
||||
checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do
|
||||
let rest = for rest $ \case
|
||||
(PTag tag _, rhs) => Just (tag, rhs)
|
||||
_ => Nothing
|
||||
maybe (fatalError "expected all patterns to be tags")
|
||||
(\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest
|
||||
checkCaseArms loc ((PZero _, rhs1) :: rest) = do
|
||||
let [(PSucc p q ih _, rhs2)] = rest
|
||||
| _ => fatalError "expected succ pattern after zero"
|
||||
pure $ CaseNat rhs1 (p, q, ih, rhs2) loc
|
||||
checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do
|
||||
let [(PZero _, rhs2)] = rest
|
||||
| _ => fatalError "expected zero pattern after succ"
|
||||
pure $ CaseNat rhs2 (p, q, ih, rhs1) loc
|
||||
checkCaseArms loc ((PBox x _, rhs) :: rest) =
|
||||
if null rest then pure $ CaseBox x rhs loc
|
||||
else fatalError "unexpected pattern after box"
|
||||
|
||||
export
|
||||
caseBody : FileName -> Grammar True PCaseBody
|
||||
caseBody fname = do
|
||||
body <- bounds $ delimSep "{" "}" ";" $ caseArm fname
|
||||
let loc = makeLoc fname body.bounds
|
||||
checkCaseArms loc body.val
|
||||
|
||||
export
|
||||
caseReturn : FileName -> Grammar True (PatVar, PTerm)
|
||||
caseReturn fname = do
|
||||
x <- patVar fname <* resC "⇒" <|> unused fname
|
||||
ret <- assert_total term fname
|
||||
pure (x, ret)
|
||||
|
||||
export
|
||||
caseTerm : FileName -> Grammar True PTerm
|
||||
caseTerm fname = withLoc fname $ do
|
||||
qty <- caseIntro fname; commit
|
||||
head <- mustWork $ assert_total term fname; needRes "return"
|
||||
ret <- mustWork $ caseReturn fname; needRes "of"
|
||||
body <- mustWork $ caseBody fname
|
||||
pure $ Case qty head ret body
|
||||
|
||||
|
||||
||| argument/atomic term: single-token terms, or those with delimiters
|
||||
||| e.g. `[t]`. includes `case` because the end delimiter is the `}`.
|
||||
export
|
||||
termArg : FileName -> Grammar True PTerm
|
||||
termArg fname = withLoc fname $
|
||||
[|TYPE universe1|]
|
||||
<|> IOState <$ res "IOState"
|
||||
<|> [|Enum enumType|]
|
||||
<|> [|Tag tag|]
|
||||
<|> const <$> boxTerm fname
|
||||
<|> Nat <$ res "ℕ"
|
||||
<|> Zero <$ res "zero"
|
||||
<|> [|fromNat nat|]
|
||||
<|> NAT <$ res "ℕ"
|
||||
<|> Nat 0 <$ res "zero"
|
||||
<|> [|Nat nat|]
|
||||
<|> STRING <$ res "String"
|
||||
<|> [|Str strLit|]
|
||||
<|> [|V qname displacement|]
|
||||
<|> const <$> caseTerm fname
|
||||
<|> const <$> tupleTerm fname
|
||||
|
||||
export
|
||||
|
@ -369,10 +440,10 @@ eqTerm : FileName -> Grammar True PTerm
|
|||
eqTerm fname = withLoc fname $
|
||||
resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (termArg fname)|]
|
||||
|
||||
export
|
||||
succTerm : FileName -> Grammar True PTerm
|
||||
succTerm fname = withLoc fname $
|
||||
resC "succ" *> mustWork [|Succ (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
|
||||
|
@ -380,15 +451,32 @@ export
|
|||
anyArg : FileName -> Grammar True (Either PDim PTerm)
|
||||
anyArg fname = dimArg fname <||> termArg fname
|
||||
|
||||
export
|
||||
resAppTerm : FileName -> (word : String) -> (0 _ : IsReserved word) =>
|
||||
(PTerm -> Loc -> PTerm) -> Grammar True PTerm
|
||||
resAppTerm fname word f = withLoc fname $ do
|
||||
head <- withLoc fname $ resC word *> mustWork [|f (termArg fname)|]
|
||||
args <- many $ anyArg fname
|
||||
pure $ \loc => foldl (appArg loc) head args
|
||||
|
||||
export
|
||||
succTerm : FileName -> Grammar True PTerm
|
||||
succTerm fname = resAppTerm fname "succ" Succ
|
||||
|
||||
export
|
||||
fstTerm : FileName -> Grammar True PTerm
|
||||
fstTerm fname = resAppTerm fname "fst" Fst
|
||||
|
||||
export
|
||||
sndTerm : FileName -> Grammar True PTerm
|
||||
sndTerm fname = resAppTerm fname "snd" Snd
|
||||
|
||||
export
|
||||
normalAppTerm : FileName -> Grammar True PTerm
|
||||
normalAppTerm fname = withLoc fname $ do
|
||||
head <- termArg fname
|
||||
args <- many $ anyArg fname
|
||||
pure $ \loc => foldl (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
|
||||
pure $ \loc => foldl (appArg loc) head args
|
||||
|
||||
||| application term `f x @y z`, or other terms that look like application
|
||||
||| like `succ` or `coe`.
|
||||
|
@ -400,6 +488,8 @@ appTerm fname =
|
|||
<|> splitUniverseTerm fname
|
||||
<|> eqTerm fname
|
||||
<|> succTerm fname
|
||||
<|> fstTerm fname
|
||||
<|> sndTerm fname
|
||||
<|> normalAppTerm fname
|
||||
|
||||
export
|
||||
|
@ -438,18 +528,6 @@ properBinders fname = assert_total $ do
|
|||
t <- term fname; needRes ")"
|
||||
pure (xs, t)
|
||||
|
||||
export
|
||||
piTerm : FileName -> Grammar True PTerm
|
||||
piTerm fname = withLoc fname $ do
|
||||
q <- qty fname; resC "."
|
||||
dom <- piBinder; needRes "→"
|
||||
cod <- assert_total term fname; commit
|
||||
pure $ \loc => foldr (\x, t => Pi q x (snd dom) t loc) cod (fst dom)
|
||||
where
|
||||
piBinder : Grammar True (List1 PatVar, PTerm)
|
||||
piBinder = properBinders fname
|
||||
<|> [|(,) [|singleton $ unused fname|] (termArg fname)|]
|
||||
|
||||
export
|
||||
sigmaTerm : FileName -> Grammar True PTerm
|
||||
sigmaTerm fname =
|
||||
|
@ -470,105 +548,320 @@ where
|
|||
rest <- optional $ resC "×" *> sepBy1 (res "×") (annTerm fname)
|
||||
pure $ foldr1 cross $ fst ::: maybe [] toList rest
|
||||
|
||||
public export
|
||||
PCaseArm : Type
|
||||
PCaseArm = (PCasePat, PTerm)
|
||||
export
|
||||
piTerm : FileName -> Grammar True PTerm
|
||||
piTerm fname = withLoc fname $ do
|
||||
q <- [|GivenQ $ qty fname <* resC "."|] <|> defLoc fname DefaultQ
|
||||
dom <- [|Dep $ properBinders fname|] <|> [|Nondep $ ndDom q fname|]
|
||||
cod <- optional $ do resC "→"; assert_total term fname <* commit
|
||||
when (needCod q dom && isNothing cod) $ fail "missing function type result"
|
||||
pure $ maybe (const $ toTerm dom) (makePi q dom) cod
|
||||
where
|
||||
data PiQty = GivenQ PQty | DefaultQ Loc
|
||||
data PiDom = Dep (List1 PatVar, PTerm) | Nondep PTerm
|
||||
|
||||
ndDom : PiQty -> FileName -> Grammar True PTerm
|
||||
ndDom (GivenQ _) = termArg -- 「1.(List A)」, not 「1.List A」
|
||||
ndDom (DefaultQ _) = sigmaTerm
|
||||
|
||||
needCod : PiQty -> PiDom -> Bool
|
||||
needCod (DefaultQ _) (Nondep _) = False
|
||||
needCod _ _ = True
|
||||
|
||||
toTerm : PiDom -> PTerm
|
||||
toTerm (Dep (_, s)) = s
|
||||
toTerm (Nondep s) = s
|
||||
|
||||
toQty : PiQty -> PQty
|
||||
toQty (GivenQ qty) = qty
|
||||
toQty (DefaultQ loc) = PQ One loc
|
||||
|
||||
toDoms : PQty -> PiDom -> List1 (PQty, PatVar, PTerm)
|
||||
toDoms qty (Dep (xs, s)) = [(qty, x, s) | x <- xs]
|
||||
toDoms qty (Nondep s) = singleton (qty, Unused s.loc, s)
|
||||
|
||||
makePi : PiQty -> PiDom -> PTerm -> Loc -> PTerm
|
||||
makePi q doms cod loc =
|
||||
foldr (\(q, x, s), t => Pi q x s t loc) cod $ toDoms (toQty q) doms
|
||||
|
||||
|
||||
export
|
||||
caseArm : FileName -> Grammar True PCaseArm
|
||||
caseArm fname =
|
||||
[|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
|
||||
letIntro : FileName -> Grammar True (Maybe PQty)
|
||||
letIntro fname =
|
||||
withLoc fname (Just . PQ Zero <$ res "let0")
|
||||
<|> withLoc fname (Just . PQ One <$ res "let1")
|
||||
<|> withLoc fname (Just . PQ Any <$ res "letω")
|
||||
<|> Nothing <$ resC "let"
|
||||
|
||||
private
|
||||
letBinder : FileName -> Maybe PQty -> Grammar True (PQty, PatVar, PTerm)
|
||||
letBinder fname mq = do
|
||||
qty <- letQty fname mq
|
||||
x <- patVar fname
|
||||
type <- optional $ resC ":" *> term fname
|
||||
rhs <- resC "=" *> term fname
|
||||
pure (qty, x, makeLetRhs rhs type)
|
||||
where
|
||||
letQty : FileName -> Maybe PQty -> Grammar False PQty
|
||||
letQty fname Nothing = qty fname <* mustWork (resC ".") <|> defLoc fname (PQ One)
|
||||
letQty fname (Just q) = pure q
|
||||
|
||||
makeLetRhs : PTerm -> Maybe PTerm -> PTerm
|
||||
makeLetRhs tm ty = maybe tm (\t => Ann tm t (extendL tm.loc t.loc)) ty
|
||||
|
||||
export
|
||||
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"
|
||||
letTerm : FileName -> Grammar True PTerm
|
||||
letTerm fname = withLoc fname $ do
|
||||
qty <- letIntro fname
|
||||
binds <- sepEndBy1 (res ";") $ assert_total letBinder fname qty
|
||||
mustWork $ resC "in"
|
||||
body <- assert_total term fname
|
||||
pure $ \loc => foldr (\b, s => Let b s loc) body binds
|
||||
|
||||
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
|
||||
decl : FileName -> Grammar True PDecl
|
||||
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 "#["
|
||||
|
||||
||| `def` alone means `defω`
|
||||
export
|
||||
defIntro : FileName -> Grammar True PQty
|
||||
defIntro fname =
|
||||
withLoc fname (PQ Zero <$ resC "def0")
|
||||
<|> withLoc fname (PQ Any <$ resC "defω")
|
||||
<|> do pos <- bounds $ resC "def"
|
||||
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
|
||||
definition : FileName -> Grammar True PDefinition
|
||||
definition fname = withLoc fname $ do
|
||||
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 ";"
|
||||
pure $ MkPDef qty name type term
|
||||
either fatalError pure $ mkPDef attrs qty name $ PConcrete 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
|
||||
definition : FileName -> List PAttr -> Grammar True PDefinition
|
||||
definition fname attrs =
|
||||
try (postulate fname attrs) <|> concrete fname attrs
|
||||
|
||||
export
|
||||
nsname : Grammar True Mods
|
||||
nsname = do ns <- qname; pure $ ns.mods :< ns.base
|
||||
|
||||
export
|
||||
pragma : FileName -> Grammar True PPragma
|
||||
pragma fname = do
|
||||
a <- attr' fname "#!["
|
||||
either fatalError pure $ case a.name of
|
||||
"log" => logArgs a.args a.loc
|
||||
_ => Left $
|
||||
#"unrecognised pragma "\#{a.name}"\n"# ++
|
||||
#"known pragmas: ["log"]"#
|
||||
where
|
||||
levelOOB : Nat -> Either String a
|
||||
levelOOB n = Left $
|
||||
"log level \{show n} out of bounds\n" ++
|
||||
"expected number in range 0–\{show maxLogLevel} inclusive"
|
||||
|
||||
toLevel : Nat -> Either String LogLevel
|
||||
toLevel lvl = maybe (levelOOB lvl) Right $ toLogLevel lvl
|
||||
|
||||
unknownCat : String -> Either String a
|
||||
unknownCat cat = Left $
|
||||
"unknown log category \{show cat}\n" ++
|
||||
"known categories: \{show $ ["all", "default"] ++ logCategories}"
|
||||
|
||||
toCat : String -> Either String LogCategory
|
||||
toCat cat = maybe (unknownCat cat) Right $ toLogCategory cat
|
||||
|
||||
fromPair : PTerm -> Either String (String, Nat)
|
||||
fromPair (Pair (V (MkPName [<] x) Nothing _) (Nat n _) _) = Right (x, n)
|
||||
fromPair _ = Left "invalid argument to log pragma"
|
||||
|
||||
logCatArg : (String, Nat) -> Either String Log.PushArg
|
||||
logCatArg ("default", lvl) = [|SetDefault $ toLevel lvl|]
|
||||
logCatArg ("all", lvl) = [|SetAll $ toLevel lvl|]
|
||||
logCatArg (cat, lvl) = [|SetCat (toCat cat) (toLevel lvl)|]
|
||||
|
||||
logArgs : List PTerm -> Loc -> Either String PPragma
|
||||
logArgs [] _ = Left "missing arguments to log pragma"
|
||||
logArgs [V "pop" Nothing _] loc = Right $ PLogPop loc
|
||||
logArgs other loc = do
|
||||
args <- traverse (logCatArg <=< fromPair) other
|
||||
pure $ PLogPush args loc
|
||||
|
||||
|
||||
export
|
||||
decl : FileName -> Grammar True PDecl
|
||||
|
||||
export
|
||||
namespace_ : FileName -> List PAttr -> Grammar True PNamespace
|
||||
namespace_ fname attrs = withLoc fname $ do
|
||||
ns <- resC "namespace" *> nsname; needRes "{"
|
||||
decls <- nsInner
|
||||
either fatalError pure $ mkPNamespace attrs ns decls
|
||||
where
|
||||
nsInner : Grammar True (List PDecl)
|
||||
nsInner = [] <$ resC "}"
|
||||
<|> [|(assert_total decl fname <* commit) :: assert_total nsInner|]
|
||||
|
||||
decl fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|]
|
||||
export
|
||||
declBody : FileName -> List PAttr -> Grammar True PDecl
|
||||
declBody fname attrs =
|
||||
[|PDef $ definition fname attrs|] <|> [|PNs $ namespace_ fname attrs|]
|
||||
|
||||
-- decl : FileName -> Grammar True PDecl
|
||||
decl fname =
|
||||
(attrList fname >>= declBody fname)
|
||||
<|> PPrag <$> pragma fname
|
||||
|
||||
export
|
||||
load : FileName -> Grammar True PTopLevel
|
||||
|
@ -580,7 +873,7 @@ topLevel : FileName -> Grammar True PTopLevel
|
|||
topLevel fname = load fname <|> [|PD $ decl fname|]
|
||||
|
||||
export
|
||||
input : FileName -> Grammar False (List PTopLevel)
|
||||
input : FileName -> Grammar False PFile
|
||||
input fname = [] <$ eof
|
||||
<|> [|(topLevel fname <* commit) :: assert_total input fname|]
|
||||
|
||||
|
@ -589,5 +882,5 @@ lexParseTerm : FileName -> String -> Either Error PTerm
|
|||
lexParseTerm = lexParseWith . term
|
||||
|
||||
export
|
||||
lexParseInput : FileName -> String -> Either Error (List PTopLevel)
|
||||
lexParseInput : FileName -> String -> Either Error PFile
|
||||
lexParseInput = lexParseWith . input
|
||||
|
|
|
@ -3,6 +3,8 @@ 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
|
||||
|
@ -14,9 +16,9 @@ import Derive.Prelude
|
|||
public export
|
||||
data PatVar = Unused Loc | PV PBaseName Loc
|
||||
%name PatVar v
|
||||
%runElab derive "PatVar" [Eq, Ord, Show]
|
||||
%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PatVar where
|
||||
(Unused loc).loc = loc
|
||||
(PV _ loc).loc = loc
|
||||
|
@ -38,17 +40,17 @@ record PQty where
|
|||
val : Qty
|
||||
loc_ : Loc
|
||||
%name PQty qty
|
||||
%runElab derive "PQty" [Eq, Ord, Show]
|
||||
%runElab derive "PQty" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export Located PQty where q.loc = q.loc_
|
||||
export %inline Located PQty where q.loc = q.loc_
|
||||
|
||||
namespace PDim
|
||||
public export
|
||||
data PDim = K DimConst Loc | V PBaseName Loc
|
||||
%name PDim p, q
|
||||
%runElab derive "PDim" [Eq, Ord, Show]
|
||||
%runElab derive "PDim" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PDim where
|
||||
(K _ loc).loc = loc
|
||||
(V _ loc).loc = loc
|
||||
|
@ -56,7 +58,7 @@ Located PDim where
|
|||
public export
|
||||
data PTagVal = PT TagVal Loc
|
||||
%name PTagVal tag
|
||||
%runElab derive "PTagVal" [Eq, Ord, Show]
|
||||
%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
|
||||
namespace PTerm
|
||||
|
@ -66,6 +68,8 @@ namespace PTerm
|
|||
data PTerm =
|
||||
TYPE Universe Loc
|
||||
|
||||
| IOState Loc
|
||||
|
||||
| Pi PQty PatVar PTerm PTerm Loc
|
||||
| Lam PatVar PTerm Loc
|
||||
| App PTerm PTerm Loc
|
||||
|
@ -73,6 +77,7 @@ namespace PTerm
|
|||
| Sig PatVar PTerm PTerm Loc
|
||||
| Pair PTerm PTerm Loc
|
||||
| Case PQty PTerm (PatVar, PTerm) PCaseBody Loc
|
||||
| Fst PTerm Loc | Snd PTerm Loc
|
||||
|
||||
| Enum (List TagVal) Loc
|
||||
| Tag TagVal Loc
|
||||
|
@ -81,8 +86,11 @@ namespace PTerm
|
|||
| DLam PatVar PTerm Loc
|
||||
| DApp PTerm PDim Loc
|
||||
|
||||
| Nat Loc
|
||||
| Zero Loc | Succ PTerm Loc
|
||||
| NAT Loc
|
||||
| Nat Nat Loc | Succ PTerm Loc
|
||||
|
||||
| STRING Loc -- "String" is a reserved word in idris
|
||||
| Str String Loc
|
||||
|
||||
| BOX PQty PTerm Loc
|
||||
| Box PTerm Loc
|
||||
|
@ -93,6 +101,8 @@ 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
|
||||
|
@ -103,33 +113,43 @@ namespace PTerm
|
|||
| CaseBox PatVar PTerm Loc
|
||||
%name PCaseBody body
|
||||
|
||||
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
|
||||
public export %inline
|
||||
Zero : Loc -> PTerm
|
||||
Zero = Nat 0
|
||||
|
||||
export
|
||||
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export %inline
|
||||
Located PTerm where
|
||||
(TYPE _ loc).loc = loc
|
||||
(IOState loc).loc = loc
|
||||
(Pi _ _ _ _ loc).loc = loc
|
||||
(Lam _ _ loc).loc = loc
|
||||
(App _ _ loc).loc = loc
|
||||
(Sig _ _ _ loc).loc = loc
|
||||
(Pair _ _ loc).loc = loc
|
||||
(Fst _ loc).loc = loc
|
||||
(Snd _ loc).loc = loc
|
||||
(Case _ _ _ _ loc).loc = loc
|
||||
(Enum _ loc).loc = loc
|
||||
(Tag _ loc).loc = loc
|
||||
(Eq _ _ _ loc).loc = loc
|
||||
(DLam _ _ loc).loc = loc
|
||||
(DApp _ _ loc).loc = loc
|
||||
(Nat loc).loc = loc
|
||||
(Zero loc).loc = loc
|
||||
(NAT loc).loc = loc
|
||||
(Nat _ loc).loc = loc
|
||||
(Succ _ loc).loc = loc
|
||||
(STRING loc).loc = loc
|
||||
(Str _ loc).loc = loc
|
||||
(BOX _ _ loc).loc = loc
|
||||
(Box _ loc).loc = loc
|
||||
(V _ _ loc).loc = loc
|
||||
(Ann _ _ loc).loc = loc
|
||||
(Coe _ _ _ _ loc).loc = loc
|
||||
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
||||
(Let _ _ loc).loc = loc
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PCaseBody where
|
||||
(CasePair _ _ loc).loc = loc
|
||||
(CaseEnum _ loc).loc = loc
|
||||
|
@ -137,18 +157,45 @@ 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
|
||||
type : Maybe PTerm
|
||||
term : PTerm
|
||||
body : PBody
|
||||
fail : PFail
|
||||
main : Bool
|
||||
scheme : Maybe String
|
||||
loc_ : Loc
|
||||
%name PDefinition def
|
||||
%runElab derive "PDefinition" [Eq, Ord, Show]
|
||||
%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export Located PDefinition where def.loc = def.loc_
|
||||
export %inline Located PDefinition where def.loc = def.loc_
|
||||
|
||||
public export
|
||||
data PPragma =
|
||||
PLogPush (List Log.PushArg) Loc
|
||||
| PLogPop Loc
|
||||
%name PPragma prag
|
||||
%runElab derive "PPragma" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export %inline
|
||||
Located PPragma where
|
||||
(PLogPush _ loc).loc = loc
|
||||
(PLogPop loc).loc = loc
|
||||
|
||||
mutual
|
||||
public export
|
||||
|
@ -156,6 +203,7 @@ mutual
|
|||
constructor MkPNamespace
|
||||
name : Mods
|
||||
decls : List PDecl
|
||||
fail : PFail
|
||||
loc_ : Loc
|
||||
%name PNamespace ns
|
||||
|
||||
|
@ -163,28 +211,41 @@ mutual
|
|||
data PDecl =
|
||||
PDef PDefinition
|
||||
| PNs PNamespace
|
||||
| PPrag PPragma
|
||||
%name PDecl decl
|
||||
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show]
|
||||
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export Located PNamespace where ns.loc = ns.loc_
|
||||
export %inline Located PNamespace where ns.loc = ns.loc_
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PDecl where
|
||||
(PDef def).loc = def.loc
|
||||
(PDef d).loc = d.loc
|
||||
(PNs ns).loc = ns.loc
|
||||
(PPrag prag).loc = prag.loc
|
||||
|
||||
public export
|
||||
data PTopLevel = PD PDecl | PLoad String Loc
|
||||
%name PTopLevel t
|
||||
%runElab derive "PTopLevel" [Eq, Ord, Show]
|
||||
%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PTopLevel where
|
||||
(PD decl).loc = decl.loc
|
||||
(PLoad _ loc).loc = loc
|
||||
|
||||
|
||||
public export
|
||||
fromNat : Nat -> Loc -> PTerm
|
||||
fromNat 0 loc = Zero loc
|
||||
fromNat (S k) loc = Succ (fromNat k loc) loc
|
||||
record PAttr where
|
||||
constructor PA
|
||||
name : PBaseName
|
||||
args : List PTerm
|
||||
loc_ : Loc
|
||||
%name PAttr attr
|
||||
%runElab derive "PAttr" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export %inline Located PAttr where attr.loc = attr.loc_
|
||||
|
||||
|
||||
public export
|
||||
PFile : Type
|
||||
PFile = List PTopLevel
|
||||
|
|
|
@ -3,6 +3,7 @@ module Quox.Pretty
|
|||
import Quox.Loc
|
||||
import Quox.Name
|
||||
|
||||
import Control.Monad.ST.Extra
|
||||
import public Text.PrettyPrint.Bernardy
|
||||
import public Text.PrettyPrint.Bernardy.Core.Decorate
|
||||
import public Quox.EffExtra
|
||||
|
@ -40,7 +41,7 @@ data HL
|
|||
| Dim | DVar | DVarErr
|
||||
| Qty | Universe
|
||||
| Syntax
|
||||
| Tag
|
||||
| Constant
|
||||
%runElab derive "HL" [Eq, Ord, Show]
|
||||
|
||||
|
||||
|
@ -65,11 +66,12 @@ export %inline
|
|||
runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
|
||||
Eff Pretty a -> a
|
||||
runPrettyWith prec flavor highlight indent act =
|
||||
extract $
|
||||
evalStateAt PREC prec $
|
||||
runReaderAt FLAVOR flavor $
|
||||
runReaderAt HIGHLIGHT highlight $
|
||||
runReaderAt INDENT indent act
|
||||
runST $ do
|
||||
runEff act $ with Union.(::)
|
||||
[handleStateSTRef !(newSTRef prec),
|
||||
handleReaderConst flavor,
|
||||
handleReaderConst highlight,
|
||||
handleReaderConst indent]
|
||||
|
||||
|
||||
export %inline
|
||||
|
@ -84,43 +86,65 @@ toSGR DVarErr = [SetForeground BrightGreen, SetStyle SingleUnderline]
|
|||
toSGR Qty = [SetForeground BrightMagenta]
|
||||
toSGR Universe = [SetForeground BrightRed]
|
||||
toSGR Syntax = [SetForeground BrightCyan]
|
||||
toSGR Tag = [SetForeground BrightRed]
|
||||
toSGR Constant = [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 = runPrettyWith Outer Unicode noHighlight 2
|
||||
|
||||
export %inline
|
||||
runPrettyColor : Eff Pretty a -> a
|
||||
runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
|
||||
runPretty = runPrettyHL noHighlight
|
||||
|
||||
|
||||
export %inline
|
||||
hl : {opts : _} -> HL -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hl : {opts : LayoutOpts} -> HL -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hl h doc = asksAt HIGHLIGHT $ \f => decorate (f h) doc
|
||||
|
||||
|
||||
export %inline
|
||||
indentD : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
indentD : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
indentD doc = pure $ indent !(askAt INDENT) doc
|
||||
|
||||
export %inline
|
||||
hangD : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hangD : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
|
||||
|
||||
export %inline
|
||||
hangDSingle : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hangDSingle d1 d2 =
|
||||
pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2))
|
||||
hangSingle : {opts : LayoutOpts} -> Nat -> Doc opts -> Doc opts -> Doc opts
|
||||
hangSingle n d1 d2 = ifMultiline (d1 <++> d2) (vappend d1 (indent n d2))
|
||||
|
||||
export %inline
|
||||
hangDSingle : {opts : LayoutOpts} -> Doc opts -> Doc opts ->
|
||||
Eff Pretty (Doc opts)
|
||||
hangDSingle d1 d2 = pure $ hangSingle !(askAt INDENT) d1 d2
|
||||
|
||||
|
||||
export
|
||||
tightDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
|
||||
tightDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
|
||||
Eff Pretty (Doc opts)
|
||||
tightDelims l r inner = do
|
||||
l <- hl Delim $ text l
|
||||
|
@ -128,7 +152,7 @@ tightDelims l r inner = do
|
|||
pure $ hcat [l, inner, r]
|
||||
|
||||
export
|
||||
looseDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
|
||||
looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
|
||||
Eff Pretty (Doc opts)
|
||||
looseDelims l r inner = do
|
||||
l <- hl Delim $ text l
|
||||
|
@ -138,39 +162,39 @@ looseDelims l r inner = do
|
|||
pure $ ifMultiline short long
|
||||
|
||||
export %inline
|
||||
parens : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parens = tightDelims "(" ")"
|
||||
|
||||
export %inline
|
||||
bracks : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
bracks = tightDelims "[" "]"
|
||||
|
||||
export %inline
|
||||
braces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
braces = looseDelims "{" "}"
|
||||
|
||||
export %inline
|
||||
tightBraces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
tightBraces = tightDelims "{" "}"
|
||||
|
||||
export %inline
|
||||
parensIf : {opts : _} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parensIf : {opts : LayoutOpts} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parensIf True = parens
|
||||
parensIf False = pure
|
||||
|
||||
|
||||
||| uses hsep only if the whole list fits on one line
|
||||
export
|
||||
sepSingle : {opts : _} -> List (Doc opts) -> Doc opts
|
||||
sepSingle : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
|
||||
sepSingle xs = ifMultiline (hsep xs) (vsep xs)
|
||||
|
||||
export
|
||||
fillSep : {opts : _} -> List (Doc opts) -> Doc opts
|
||||
fillSep : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
|
||||
fillSep [] = empty
|
||||
fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
|
||||
|
||||
export
|
||||
exceptLast : {opts : _} -> (Doc opts -> Doc opts) ->
|
||||
exceptLast : {opts : LayoutOpts} -> (Doc opts -> Doc opts) ->
|
||||
List (Doc opts) -> List (Doc opts)
|
||||
exceptLast f [] = []
|
||||
exceptLast f [x] = [x]
|
||||
|
@ -185,11 +209,24 @@ 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 =
|
||||
|
@ -198,7 +235,7 @@ ifUnicode uni asc =
|
|||
Ascii => asc
|
||||
|
||||
export %inline
|
||||
parensIfM : {opts : _} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parensIfM d doc = parensIf (!(getAt PREC) > d) doc
|
||||
|
||||
export %inline
|
||||
|
@ -211,64 +248,73 @@ prettyName : Name -> Doc opts
|
|||
prettyName = text . toDots
|
||||
|
||||
export
|
||||
prettyFree : {opts : _} -> Name -> Eff Pretty (Doc opts)
|
||||
prettyFree : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts)
|
||||
prettyFree = hl Free . prettyName
|
||||
|
||||
export
|
||||
prettyBind' : BindName -> Doc opts
|
||||
prettyBind' = text . baseStr . name
|
||||
prettyBind' = text . baseStr . val
|
||||
|
||||
export
|
||||
prettyTBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
|
||||
prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
|
||||
prettyTBind = hl TVar . prettyBind'
|
||||
|
||||
export
|
||||
prettyDBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
|
||||
prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
|
||||
prettyDBind = hl DVar . prettyBind'
|
||||
|
||||
|
||||
|
||||
export %inline
|
||||
typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
|
||||
eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
|
||||
ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD :
|
||||
{opts : _} -> Eff Pretty (Doc opts)
|
||||
typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
|
||||
stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD,
|
||||
zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD :
|
||||
{opts : LayoutOpts} -> Eff Pretty (Doc opts)
|
||||
typeD = hl Syntax . text =<< ifUnicode "★" "Type"
|
||||
arrowD = hl Delim . text =<< ifUnicode "→" "->"
|
||||
darrowD = hl Delim . text =<< ifUnicode "⇒" "=>"
|
||||
timesD = hl Delim . text =<< ifUnicode "×" "**"
|
||||
ioStateD = hl Syntax $ text "IOState"
|
||||
arrowD = hl Syntax . text =<< ifUnicode "→" "->"
|
||||
darrowD = hl Syntax . text =<< ifUnicode "⇒" "=>"
|
||||
timesD = hl Syntax . text =<< ifUnicode "×" "**"
|
||||
lamD = hl Syntax . text =<< ifUnicode "λ" "fun"
|
||||
eqndD = hl Delim . text =<< ifUnicode "≡" "=="
|
||||
eqndD = hl Syntax . text =<< ifUnicode "≡" "=="
|
||||
dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun"
|
||||
annD = hl Delim . text =<< ifUnicode "∷" "::"
|
||||
annD = hl Syntax . text =<< ifUnicode "∷" "::"
|
||||
natD = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
|
||||
stringD = hl Syntax $ text "String"
|
||||
eqD = hl Syntax $ text "Eq"
|
||||
colonD = hl Delim $ text ":"
|
||||
commaD = hl Delim $ text ","
|
||||
colonD = hl Syntax $ text ":"
|
||||
commaD = hl Syntax $ text ","
|
||||
semiD = hl Delim $ text ";"
|
||||
atD = hl Delim $ text "@"
|
||||
caseD = hl Syntax $ text "case"
|
||||
typecaseD = hl Syntax $ text "type-case"
|
||||
ofD = hl Syntax $ text "of"
|
||||
returnD = hl Syntax $ text "return"
|
||||
dotD = hl Delim $ text "."
|
||||
zeroD = hl Syntax $ text "zero"
|
||||
succD = hl Syntax $ text "succ"
|
||||
zeroD = hl Constant $ text "zero"
|
||||
succD = hl Constant $ text "succ"
|
||||
coeD = hl Syntax $ text "coe"
|
||||
compD = hl Syntax $ text "comp"
|
||||
undD = hl Syntax $ text "_"
|
||||
cstD = hl Syntax $ text "="
|
||||
pipeD = hl Syntax $ text "|"
|
||||
pipeD = hl Delim $ text "|"
|
||||
fstD = hl Syntax $ text "fst"
|
||||
sndD = hl Syntax $ text "snd"
|
||||
letD = hl Syntax $ text "let"
|
||||
inD = hl Syntax $ text "in"
|
||||
|
||||
|
||||
export
|
||||
prettyApp : {opts : _} -> Nat -> Doc opts -> List (Doc opts) -> Doc opts
|
||||
prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
|
||||
List (Doc opts) -> Doc opts
|
||||
prettyApp ind f args =
|
||||
hsep (f :: args)
|
||||
<|> hsep [f, vsep args]
|
||||
<|> vsep (f :: map (indent ind) args)
|
||||
ifMultiline
|
||||
(hsep (f :: args))
|
||||
(f <++> vsep args <|> vsep (f :: map (indent ind) args))
|
||||
|
||||
export
|
||||
prettyAppD : {opts : _} -> Doc opts -> List (Doc opts) -> Eff Pretty (Doc opts)
|
||||
prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
|
||||
Eff Pretty (Doc opts)
|
||||
prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
|
||||
|
||||
|
||||
|
@ -288,7 +334,7 @@ quoteTag tag =
|
|||
"\"" ++ escapeString tag ++ "\""
|
||||
|
||||
export
|
||||
prettyBounds : {opts : _} -> Bounds -> Eff Pretty (Doc opts)
|
||||
prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
|
||||
prettyBounds (MkBounds l1 c1 l2 c2) =
|
||||
hcat <$> sequence
|
||||
[hl TVar $ text $ show l1, colonD,
|
||||
|
@ -297,8 +343,22 @@ prettyBounds (MkBounds l1 c1 l2 c2) =
|
|||
hl DVar $ text $ show c2, colonD]
|
||||
|
||||
export
|
||||
prettyLoc : {opts : _} -> Loc -> Eff Pretty (Doc opts)
|
||||
prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
|
||||
prettyLoc (L NoLoc) =
|
||||
hcat <$> sequence [hl TVarErr "no location", colonD]
|
||||
prettyLoc (L (YesLoc file b)) =
|
||||
hcat <$> sequence [hl Free $ text file, colonD, prettyBounds b]
|
||||
|
||||
export
|
||||
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
|
||||
prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
|
||||
|
||||
export
|
||||
prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
|
||||
prettyStrLit s =
|
||||
let s = concatMap esc1 $ unpack s in
|
||||
hl Constant $ hcat ["\"", text s, "\""]
|
||||
where
|
||||
esc1 : Char -> String
|
||||
esc1 '"' = "\""; esc1 '\\' = "\\"
|
||||
esc1 c = singleton c
|
||||
|
|
20
lib/Quox/PrettyValExtra.idr
Normal file
20
lib/Quox/PrettyValExtra.idr
Normal file
|
@ -0,0 +1,20 @@
|
|||
module Quox.PrettyValExtra
|
||||
|
||||
import Data.DPair
|
||||
import Derive.Prelude
|
||||
import public Text.Show.Value
|
||||
import public Text.Show.PrettyVal
|
||||
import public Text.Show.PrettyVal.Derive
|
||||
|
||||
%language ElabReflection
|
||||
|
||||
%runElab derive "SnocList" [PrettyVal]
|
||||
|
||||
|
||||
export %inline
|
||||
PrettyVal a => PrettyVal (Subset a p) where
|
||||
prettyVal (Element x _) = Con "Element" [prettyVal x, Con "_" []]
|
||||
|
||||
export %inline
|
||||
(forall x. PrettyVal (p x)) => PrettyVal (Exists p) where
|
||||
prettyVal (Evidence _ p) = Con "Evidence" [Con "_" [], prettyVal p]
|
|
@ -1,751 +0,0 @@
|
|||
module Quox.Reduce
|
||||
|
||||
import Quox.No
|
||||
import Quox.Syntax
|
||||
import Quox.Definition
|
||||
import Quox.Displace
|
||||
import Quox.Typing.Context
|
||||
import Quox.Typing.Error
|
||||
import Data.SnocVect
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import Control.Eff
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
Whnf : List (Type -> Type)
|
||||
Whnf = [NameGen, Except Error]
|
||||
|
||||
export
|
||||
runWhnfWith : NameSuf -> Eff Whnf a -> (Either Error a, NameSuf)
|
||||
runWhnfWith suf act = extract $ runStateAt GEN suf $ runExcept act
|
||||
|
||||
export
|
||||
runWhnf : Eff Whnf a -> Either Error a
|
||||
runWhnf = fst . runWhnfWith 0
|
||||
|
||||
|
||||
public export
|
||||
0 RedexTest : TermLike -> Type
|
||||
RedexTest tm = {d, n : Nat} -> Definitions -> tm d n -> Bool
|
||||
|
||||
public export
|
||||
interface CanWhnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm
|
||||
where
|
||||
whnf : {d, n : Nat} -> (defs : Definitions) ->
|
||||
(ctx : WhnfContext d n) ->
|
||||
tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs))
|
||||
|
||||
public export %inline
|
||||
whnf0 : {d, n : Nat} -> {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
|
||||
(defs : Definitions) -> WhnfContext d n -> tm d n -> Eff Whnf (tm d n)
|
||||
whnf0 defs ctx t = fst <$> whnf defs ctx t
|
||||
|
||||
public export
|
||||
0 IsRedex, NotRedex : {isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
|
||||
Definitions -> Pred (tm d n)
|
||||
IsRedex defs = So . isRedex defs
|
||||
NotRedex defs = No . isRedex defs
|
||||
|
||||
public export
|
||||
0 NonRedex : (tm : TermLike) -> {isRedex : RedexTest tm} ->
|
||||
CanWhnf tm isRedex => (d, n : Nat) -> (defs : Definitions) -> Type
|
||||
NonRedex tm d n defs = Subset (tm d n) (NotRedex defs)
|
||||
|
||||
public export %inline
|
||||
nred : {0 isRedex : RedexTest tm} -> (0 _ : CanWhnf tm isRedex) =>
|
||||
(t : tm d n) -> (0 nr : NotRedex defs t) => NonRedex tm d n defs
|
||||
nred t = Element t nr
|
||||
|
||||
|
||||
public export %inline
|
||||
isLamHead : Elim {} -> Bool
|
||||
isLamHead (Ann (Lam {}) (Pi {}) _) = True
|
||||
isLamHead (Coe {}) = True
|
||||
isLamHead _ = False
|
||||
|
||||
public export %inline
|
||||
isDLamHead : Elim {} -> Bool
|
||||
isDLamHead (Ann (DLam {}) (Eq {}) _) = True
|
||||
isDLamHead (Coe {}) = True
|
||||
isDLamHead _ = False
|
||||
|
||||
public export %inline
|
||||
isPairHead : Elim {} -> Bool
|
||||
isPairHead (Ann (Pair {}) (Sig {}) _) = True
|
||||
isPairHead (Coe {}) = True
|
||||
isPairHead _ = False
|
||||
|
||||
public export %inline
|
||||
isTagHead : Elim {} -> Bool
|
||||
isTagHead (Ann (Tag {}) (Enum {}) _) = True
|
||||
isTagHead (Coe {}) = True
|
||||
isTagHead _ = False
|
||||
|
||||
public export %inline
|
||||
isNatHead : Elim {} -> Bool
|
||||
isNatHead (Ann (Zero {}) (Nat {}) _) = True
|
||||
isNatHead (Ann (Succ {}) (Nat {}) _) = True
|
||||
isNatHead (Coe {}) = True
|
||||
isNatHead _ = False
|
||||
|
||||
public export %inline
|
||||
isBoxHead : Elim {} -> Bool
|
||||
isBoxHead (Ann (Box {}) (BOX {}) _) = True
|
||||
isBoxHead (Coe {}) = True
|
||||
isBoxHead _ = False
|
||||
|
||||
public export %inline
|
||||
isE : Term {} -> Bool
|
||||
isE (E {}) = True
|
||||
isE _ = False
|
||||
|
||||
public export %inline
|
||||
isAnn : Elim {} -> Bool
|
||||
isAnn (Ann {}) = True
|
||||
isAnn _ = False
|
||||
|
||||
||| true if a term is syntactically a type.
|
||||
public export %inline
|
||||
isTyCon : Term {} -> Bool
|
||||
isTyCon (TYPE {}) = True
|
||||
isTyCon (Pi {}) = True
|
||||
isTyCon (Lam {}) = False
|
||||
isTyCon (Sig {}) = True
|
||||
isTyCon (Pair {}) = False
|
||||
isTyCon (Enum {}) = True
|
||||
isTyCon (Tag {}) = False
|
||||
isTyCon (Eq {}) = True
|
||||
isTyCon (DLam {}) = False
|
||||
isTyCon (Nat {}) = True
|
||||
isTyCon (Zero {}) = False
|
||||
isTyCon (Succ {}) = False
|
||||
isTyCon (BOX {}) = True
|
||||
isTyCon (Box {}) = False
|
||||
isTyCon (E {}) = False
|
||||
isTyCon (CloT {}) = False
|
||||
isTyCon (DCloT {}) = False
|
||||
|
||||
||| true if a term is syntactically a type, or a neutral.
|
||||
public export %inline
|
||||
isTyConE : Term {} -> Bool
|
||||
isTyConE s = isTyCon s || isE s
|
||||
|
||||
||| true if a term is syntactically a type.
|
||||
public export %inline
|
||||
isAnnTyCon : Elim {} -> Bool
|
||||
isAnnTyCon (Ann ty (TYPE {}) _) = isTyCon ty
|
||||
isAnnTyCon _ = False
|
||||
|
||||
public export %inline
|
||||
isK : Dim d -> Bool
|
||||
isK (K {}) = True
|
||||
isK _ = False
|
||||
|
||||
|
||||
mutual
|
||||
public export
|
||||
isRedexE : RedexTest Elim
|
||||
isRedexE defs (F {x, _}) {d, n} =
|
||||
isJust $ lookupElim x defs {d, n}
|
||||
isRedexE _ (B {}) = False
|
||||
isRedexE defs (App {fun, _}) =
|
||||
isRedexE defs fun || isLamHead fun
|
||||
isRedexE defs (CasePair {pair, _}) =
|
||||
isRedexE defs pair || isPairHead pair
|
||||
isRedexE defs (CaseEnum {tag, _}) =
|
||||
isRedexE defs tag || isTagHead tag
|
||||
isRedexE defs (CaseNat {nat, _}) =
|
||||
isRedexE defs nat || isNatHead nat
|
||||
isRedexE defs (CaseBox {box, _}) =
|
||||
isRedexE defs box || isBoxHead box
|
||||
isRedexE defs (DApp {fun, arg, _}) =
|
||||
isRedexE defs fun || isDLamHead fun || isK arg
|
||||
isRedexE defs (Ann {tm, ty, _}) =
|
||||
isE tm || isRedexT defs tm || isRedexT defs ty
|
||||
isRedexE defs (Coe {val, _}) =
|
||||
isRedexT defs val || not (isE val)
|
||||
isRedexE defs (Comp {ty, r, _}) =
|
||||
isRedexT defs ty || isK r
|
||||
isRedexE defs (TypeCase {ty, ret, _}) =
|
||||
isRedexE defs ty || isRedexT defs ret || isAnnTyCon ty
|
||||
isRedexE _ (CloE {}) = True
|
||||
isRedexE _ (DCloE {}) = True
|
||||
|
||||
public export
|
||||
isRedexT : RedexTest Term
|
||||
isRedexT _ (CloT {}) = True
|
||||
isRedexT _ (DCloT {}) = True
|
||||
isRedexT defs (E {e, _}) = isAnn e || isRedexE defs e
|
||||
isRedexT _ _ = False
|
||||
|
||||
|
||||
public export
|
||||
tycaseRhs : (k : TyConKind) -> TypeCaseArms d n ->
|
||||
Maybe (ScopeTermN (arity k) d n)
|
||||
tycaseRhs k arms = lookupPrecise k arms
|
||||
|
||||
public export
|
||||
tycaseRhsDef : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
|
||||
ScopeTermN (arity k) d n
|
||||
tycaseRhsDef def k arms = fromMaybe (SN def) $ tycaseRhs k arms
|
||||
|
||||
public export
|
||||
tycaseRhs0 : (k : TyConKind) -> TypeCaseArms d n ->
|
||||
(0 eq : arity k = 0) => Maybe (Term d n)
|
||||
tycaseRhs0 k arms {eq} with (tycaseRhs k arms) | (arity k)
|
||||
tycaseRhs0 k arms {eq = Refl} | res | 0 = map (.term) res
|
||||
|
||||
public export
|
||||
tycaseRhsDef0 : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
|
||||
(0 eq : arity k = 0) => Term d n
|
||||
tycaseRhsDef0 def k arms = fromMaybe def $ tycaseRhs0 k arms
|
||||
|
||||
|
||||
|
||||
private
|
||||
weakDS : (by : Nat) -> DScopeTerm d n -> DScopeTerm d (by + n)
|
||||
weakDS by (S names (Y body)) = S names $ Y $ weakT by body
|
||||
weakDS by (S names (N body)) = S names $ N $ weakT by body
|
||||
|
||||
private
|
||||
dweakS : (by : Nat) -> ScopeTerm d n -> ScopeTerm (by + d) n
|
||||
dweakS by (S names (Y body)) = S names $ Y $ dweakT by body
|
||||
dweakS by (S names (N body)) = S names $ N $ dweakT by body
|
||||
|
||||
private
|
||||
coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc ->
|
||||
ScopeTermN s d n -> ScopeTermN s d n
|
||||
coeScoped ty p q loc (S names (Y body)) =
|
||||
S names $ Y $ E $ Coe (weakDS s ty) p q body loc
|
||||
coeScoped ty p q loc (S names (N body)) =
|
||||
S names $ N $ E $ Coe ty p q body loc
|
||||
|
||||
|
||||
export covering
|
||||
CanWhnf Term Reduce.isRedexT
|
||||
|
||||
export covering
|
||||
CanWhnf Elim Reduce.isRedexE
|
||||
|
||||
parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
|
||||
||| performs the minimum work required to recompute the type of an elim.
|
||||
|||
|
||||
||| ⚠ **assumes the elim is already typechecked.** ⚠
|
||||
export covering
|
||||
computeElimType : (e : Elim d n) -> (0 ne : No (isRedexE defs e)) =>
|
||||
Eff Whnf (Term d n)
|
||||
computeElimType (F {x, u, loc}) = do
|
||||
let Just def = lookup x defs | Nothing => throw $ NotInScope loc x
|
||||
pure $ displace u def.type
|
||||
computeElimType (B {i, _}) = pure $ ctx.tctx !! i
|
||||
computeElimType (App {fun = f, arg = s, loc}) {ne} = do
|
||||
Pi {arg, res, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne}
|
||||
| t => throw $ ExpectedPi loc ctx.names t
|
||||
pure $ sub1 res $ Ann s arg loc
|
||||
computeElimType (CasePair {pair, ret, _}) = pure $ sub1 ret pair
|
||||
computeElimType (CaseEnum {tag, ret, _}) = pure $ sub1 ret tag
|
||||
computeElimType (CaseNat {nat, ret, _}) = pure $ sub1 ret nat
|
||||
computeElimType (CaseBox {box, ret, _}) = pure $ sub1 ret box
|
||||
computeElimType (DApp {fun = f, arg = p, loc}) {ne} = do
|
||||
Eq {ty, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne}
|
||||
| t => throw $ ExpectedEq loc ctx.names t
|
||||
pure $ dsub1 ty p
|
||||
computeElimType (Ann {ty, _}) = pure ty
|
||||
computeElimType (Coe {ty, q, _}) = pure $ dsub1 ty q
|
||||
computeElimType (Comp {ty, _}) = pure ty
|
||||
computeElimType (TypeCase {ret, _}) = pure ret
|
||||
|
||||
parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext (S d) n)
|
||||
||| for π.(x : A) → B, returns (A, B);
|
||||
||| for an elim returns a pair of type-cases that will reduce to that;
|
||||
||| for other intro forms error
|
||||
private covering
|
||||
tycasePi : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
|
||||
Eff Whnf (Term (S d) n, ScopeTerm (S d) n)
|
||||
tycasePi (Pi {arg, res, _}) = pure (arg, res)
|
||||
tycasePi (E e) {tnf} = do
|
||||
ty <- computeElimType defs ctx e @{noOr2 tnf}
|
||||
let loc = e.loc
|
||||
narg = mnb "Arg"; nret = mnb "Ret"
|
||||
arg = E $ typeCase1Y e ty KPi [< !narg, !nret] (BVT 1 loc) loc
|
||||
res' = typeCase1Y e (Arr Zero arg ty loc) KPi [< !narg, !nret]
|
||||
(BVT 0 loc) loc
|
||||
res = SY [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc
|
||||
pure (arg, res)
|
||||
tycasePi t = throw $ ExpectedPi t.loc ctx.names t
|
||||
|
||||
||| for (x : A) × B, returns (A, B);
|
||||
||| for an elim returns a pair of type-cases that will reduce to that;
|
||||
||| for other intro forms error
|
||||
private covering
|
||||
tycaseSig : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
|
||||
Eff Whnf (Term (S d) n, ScopeTerm (S d) n)
|
||||
tycaseSig (Sig {fst, snd, _}) = pure (fst, snd)
|
||||
tycaseSig (E e) {tnf} = do
|
||||
ty <- computeElimType defs ctx e @{noOr2 tnf}
|
||||
let loc = e.loc
|
||||
nfst = mnb "Fst"; nsnd = mnb "Snd"
|
||||
fst = E $ typeCase1Y e ty KSig [< !nfst, !nsnd] (BVT 1 loc) loc
|
||||
snd' = typeCase1Y e (Arr Zero fst ty loc) KSig [< !nfst, !nsnd]
|
||||
(BVT 0 loc) loc
|
||||
snd = SY [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc
|
||||
pure (fst, snd)
|
||||
tycaseSig t = throw $ ExpectedSig t.loc ctx.names t
|
||||
|
||||
||| for [π. A], returns A;
|
||||
||| for an elim returns a type-case that will reduce to that;
|
||||
||| for other intro forms error
|
||||
private covering
|
||||
tycaseBOX : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
|
||||
Eff Whnf (Term (S d) n)
|
||||
tycaseBOX (BOX {ty, _}) = pure ty
|
||||
tycaseBOX (E e) {tnf} = do
|
||||
ty <- computeElimType defs ctx e @{noOr2 tnf}
|
||||
pure $ E $ typeCase1Y e ty KBOX [< !(mnb "Ty")] (BVT 0 e.loc) e.loc
|
||||
tycaseBOX t = throw $ ExpectedBOX t.loc ctx.names t
|
||||
|
||||
||| for Eq [i ⇒ A] l r, returns (A‹0/i›, A‹1/i›, A, l, r);
|
||||
||| for an elim returns five type-cases that will reduce to that;
|
||||
||| for other intro forms error
|
||||
private covering
|
||||
tycaseEq : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
|
||||
Eff Whnf (Term (S d) n, Term (S d) n, DScopeTerm (S d) n,
|
||||
Term (S d) n, Term (S d) n)
|
||||
tycaseEq (Eq {ty, l, r, _}) = pure (ty.zero, ty.one, ty, l, r)
|
||||
tycaseEq (E e) {tnf} = do
|
||||
ty <- computeElimType defs ctx e @{noOr2 tnf}
|
||||
let loc = e.loc
|
||||
names = traverse' (\x => mnb x) [< "A0", "A1", "A", "L", "R"]
|
||||
a0 = E $ typeCase1Y e ty KEq !names (BVT 4 loc) loc
|
||||
a1 = E $ typeCase1Y e ty KEq !names (BVT 3 loc) loc
|
||||
a' = typeCase1Y e (Eq0 ty a0 a1 loc) KEq !names (BVT 2 loc) loc
|
||||
a = SY [< !(mnb "i")] $ E $ DApp (dweakE 1 a') (B VZ loc) loc
|
||||
l = E $ typeCase1Y e a0 KEq !names (BVT 1 loc) loc
|
||||
r = E $ typeCase1Y e a1 KEq !names (BVT 0 loc) loc
|
||||
pure (a0, a1, a, l, r)
|
||||
tycaseEq t = throw $ ExpectedEq t.loc ctx.names t
|
||||
|
||||
-- new block because the functions below might pass a different ctx
|
||||
-- into the ones above
|
||||
parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
|
||||
||| reduce a function application `App (Coe ty p q val) s loc`
|
||||
private covering
|
||||
piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
|
||||
(val, s : Term d n) -> Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
piCoe sty@(S [< i] ty) p q val s loc = do
|
||||
-- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝
|
||||
-- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›)
|
||||
-- where 𝒔‹j› ≔ coe [i ⇒ A] @q @j s
|
||||
--
|
||||
-- type-case is used to expose A,B if the type is neutral
|
||||
let ctx1 = extendDim i ctx
|
||||
Element ty tynf <- whnf defs ctx1 ty.term
|
||||
(arg, res) <- tycasePi defs ctx1 ty
|
||||
let s0 = CoeT i arg q p s s.loc
|
||||
body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc
|
||||
s1 = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
|
||||
(s // shift 1) s.loc
|
||||
whnf defs ctx $ CoeT i (sub1 res s1) p q body loc
|
||||
|
||||
||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc`
|
||||
private covering
|
||||
sigCoe : (qty : Qty) ->
|
||||
(ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
(ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
sigCoe qty sty@(S [< i] ty) p q val ret body loc = do
|
||||
-- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e }
|
||||
-- ⇝
|
||||
-- caseπ s ∷ ((x : A) × B)‹p/i› return z ⇒ C
|
||||
-- of { (a, b) ⇒
|
||||
-- e[(coe [i ⇒ A] @p @q a)/a,
|
||||
-- (coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i a)/x]] @p @q b)/b] }
|
||||
--
|
||||
-- type-case is used to expose A,B if the type is neutral
|
||||
let ctx1 = extendDim i ctx
|
||||
Element ty tynf <- whnf defs ctx1 ty.term
|
||||
(tfst, tsnd) <- tycaseSig defs ctx1 ty
|
||||
let [< x, y] = body.names
|
||||
a' = CoeT i (weakT 2 tfst) p q (BVT 1 noLoc) x.loc
|
||||
tsnd' = tsnd.term //
|
||||
(CoeT i (weakT 2 $ tfst // (B VZ noLoc ::: shift 2))
|
||||
(weakD 1 p) (B VZ noLoc) (BVT 1 noLoc) y.loc ::: shift 2)
|
||||
b' = CoeT i tsnd' p q (BVT 0 noLoc) y.loc
|
||||
whnf defs ctx $ CasePair qty (Ann val (ty // one p) val.loc) ret
|
||||
(ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc
|
||||
|
||||
||| reduce a dimension application `DApp (Coe ty p q val) r loc`
|
||||
private covering
|
||||
eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
(r : Dim d) -> Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
eqCoe sty@(S [< j] ty) p q val r loc = do
|
||||
-- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r
|
||||
-- ⇝
|
||||
-- comp [j ⇒ A‹r/i›] @p @q (eq ∷ (Eq [i ⇒ A] L R)‹p/j›)
|
||||
-- @r { 0 j ⇒ L; 1 j ⇒ R }
|
||||
let ctx1 = extendDim j ctx
|
||||
Element ty tynf <- whnf defs ctx1 ty.term
|
||||
(a0, a1, a, s, t) <- tycaseEq defs ctx1 ty
|
||||
let a' = dsub1 a (weakD 1 r)
|
||||
val' = E $ DApp (Ann val (ty // one p) val.loc) r loc
|
||||
whnf defs ctx $ CompH j a' p q val' r j s j t loc
|
||||
|
||||
||| reduce a pair elimination `CaseBox pi (Coe ty p q val) ret body`
|
||||
private covering
|
||||
boxCoe : (qty : Qty) ->
|
||||
(ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
(ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
boxCoe qty sty@(S [< i] ty) p q val ret body loc = do
|
||||
-- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e }
|
||||
-- ⇝
|
||||
-- caseπ s ∷ [ρ. A]‹p/i› return z ⇒ C
|
||||
-- of { [a] ⇒ e[(coe [i ⇒ A] p q a)/a] }
|
||||
let ctx1 = extendDim i ctx
|
||||
Element ty tynf <- whnf defs ctx1 ty.term
|
||||
ta <- tycaseBOX defs ctx1 ty
|
||||
let a' = CoeT i (weakT 1 ta) p q (BVT 0 noLoc) body.name.loc
|
||||
whnf defs ctx $ CaseBox qty (Ann val (ty // one p) val.loc) ret
|
||||
(ST body.names $ body.term // (a' ::: shift 1)) loc
|
||||
|
||||
|
||||
||| reduce a type-case applied to a type constructor
|
||||
private covering
|
||||
reduceTypeCase : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
|
||||
(ty : Term d n) -> (u : Universe) -> (ret : Term d n) ->
|
||||
(arms : TypeCaseArms d n) -> (def : Term d n) ->
|
||||
(0 _ : So (isTyCon ty)) => Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
reduceTypeCase defs ctx ty u ret arms def loc = case ty of
|
||||
-- (type-case ★ᵢ ∷ _ return Q of { ★ ⇒ s; ⋯ }) ⇝ s ∷ Q
|
||||
TYPE {} =>
|
||||
whnf defs ctx $ Ann (tycaseRhsDef0 def KTYPE arms) ret loc
|
||||
|
||||
-- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝
|
||||
-- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
|
||||
Pi {arg, res, loc = piLoc, _} =>
|
||||
let arg' = Ann arg (TYPE u noLoc) arg.loc
|
||||
res' = Ann (Lam res res.loc)
|
||||
(Arr Zero arg (TYPE u noLoc) arg.loc) res.loc
|
||||
in
|
||||
whnf defs ctx $
|
||||
Ann (subN (tycaseRhsDef def KPi arms) [< arg', res']) ret loc
|
||||
|
||||
-- (type-case (x : A) × B ∷ ★ᵢ return Q of { (a × b) ⇒ s; ⋯ }) ⇝
|
||||
-- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
|
||||
Sig {fst, snd, loc = sigLoc, _} =>
|
||||
let fst' = Ann fst (TYPE u noLoc) fst.loc
|
||||
snd' = Ann (Lam snd snd.loc)
|
||||
(Arr Zero fst (TYPE u noLoc) fst.loc) snd.loc
|
||||
in
|
||||
whnf defs ctx $
|
||||
Ann (subN (tycaseRhsDef def KSig arms) [< fst', snd']) ret loc
|
||||
|
||||
-- (type-case {⋯} ∷ _ return Q of { {} ⇒ s; ⋯ }) ⇝ s ∷ Q
|
||||
Enum {} =>
|
||||
whnf defs ctx $ Ann (tycaseRhsDef0 def KEnum arms) ret loc
|
||||
|
||||
-- (type-case Eq [i ⇒ A] L R ∷ ★ᵢ return Q
|
||||
-- of { Eq a₀ a₁ a l r ⇒ s; ⋯ }) ⇝
|
||||
-- s[(A‹0/i› ∷ ★ᵢ)/a₀, (A‹1/i› ∷ ★ᵢ)/a₁,
|
||||
-- ((δ i ⇒ A) ∷ Eq [★ᵢ] A‹0/i› A‹1/i›)/a,
|
||||
-- (L ∷ A‹0/i›)/l, (R ∷ A‹1/i›)/r] ∷ Q
|
||||
Eq {ty = a, l, r, loc = eqLoc, _} =>
|
||||
let a0 = a.zero; a1 = a.one in
|
||||
whnf defs ctx $ Ann
|
||||
(subN (tycaseRhsDef def KEq arms)
|
||||
[< Ann a0 (TYPE u noLoc) a.loc, Ann a1 (TYPE u noLoc) a.loc,
|
||||
Ann (DLam a a.loc) (Eq0 (TYPE u noLoc) a0 a1 a.loc) a.loc,
|
||||
Ann l a0 l.loc, Ann r a1 r.loc])
|
||||
ret loc
|
||||
|
||||
-- (type-case ℕ ∷ _ return Q of { ℕ ⇒ s; ⋯ }) ⇝ s ∷ Q
|
||||
Nat {} =>
|
||||
whnf defs ctx $ Ann (tycaseRhsDef0 def KNat arms) ret loc
|
||||
|
||||
-- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q
|
||||
BOX {ty = a, loc = boxLoc, _} =>
|
||||
whnf defs ctx $ Ann
|
||||
(sub1 (tycaseRhsDef def KBOX arms) (Ann a (TYPE u noLoc) a.loc))
|
||||
ret loc
|
||||
|
||||
|
||||
||| pushes a coercion inside a whnf-ed term
|
||||
private covering
|
||||
pushCoe : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
|
||||
BindName ->
|
||||
(ty : Term (S d) n) -> (0 tynf : No (isRedexT defs ty)) =>
|
||||
Dim d -> Dim d ->
|
||||
(s : Term d n) -> (0 snf : No (isRedexT defs s)) => Loc ->
|
||||
Eff Whnf (NonRedex Elim d n defs)
|
||||
pushCoe defs ctx i ty p q s loc =
|
||||
if p == q then whnf defs ctx $ Ann s (ty // one q) loc else
|
||||
case s of
|
||||
-- (coe [_ ⇒ ★ᵢ] @_ @_ ty) ⇝ (ty ∷ ★ᵢ)
|
||||
TYPE {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Pi {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Sig {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Enum {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Eq {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Nat {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
BOX {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
|
||||
-- just η expand it. then whnf for App will handle it later
|
||||
-- this is how @xtt does it
|
||||
--
|
||||
-- (coe [i ⇒ A] @p @q (λ x ⇒ s)) ⇝
|
||||
-- (λ y ⇒ (coe [i ⇒ A] @p @q (λ x ⇒ s)) y) ∷ A‹q/i› ⇝ ⋯
|
||||
lam@(Lam {body, _}) => do
|
||||
let lam' = CoeT i ty p q lam loc
|
||||
term' = LamY !(fresh body.name)
|
||||
(E $ App (weakE 1 lam') (BVT 0 noLoc) loc) loc
|
||||
type' = ty // one q
|
||||
whnf defs ctx $ Ann term' type' loc
|
||||
|
||||
-- (coe [i ⇒ (x : A) × B] @p @q (s, t)) ⇝
|
||||
-- (coe [i ⇒ A] @p @q s,
|
||||
-- coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i s)/x]] @p @q t)
|
||||
-- ∷ (x : A‹q/i›) × B‹q/i›
|
||||
--
|
||||
-- can't use η here because... it doesn't exist
|
||||
Pair {fst, snd, loc = pairLoc} => do
|
||||
let Sig {fst = tfst, snd = tsnd, loc = sigLoc} = ty
|
||||
| _ => throw $ ExpectedSig ty.loc (extendDim i ctx.names) ty
|
||||
let fst' = E $ CoeT i tfst p q fst fst.loc
|
||||
tfst' = tfst // (B VZ noLoc ::: shift 2)
|
||||
tsnd' = sub1 tsnd $
|
||||
CoeT !(fresh i) tfst' (weakD 1 p) (B VZ noLoc)
|
||||
(dweakT 1 fst) fst.loc
|
||||
snd' = E $ CoeT i tsnd' p q snd snd.loc
|
||||
pure $
|
||||
Element (Ann (Pair fst' snd' pairLoc)
|
||||
(Sig (tfst // one q) (tsnd // one q) sigLoc) loc) Ah
|
||||
|
||||
-- η expand, like for Lam
|
||||
--
|
||||
-- (coe [i ⇒ A] @p @q (δ j ⇒ s)) ⇝
|
||||
-- (δ k ⇒ (coe [i ⇒ A] @p @q (δ j ⇒ s)) @k) ∷ A‹q/i› ⇝ ⋯
|
||||
dlam@(DLam {body, _}) => do
|
||||
let dlam' = CoeT i ty p q dlam loc
|
||||
term' = DLamY !(mnb "j")
|
||||
(E $ DApp (dweakE 1 dlam') (B VZ noLoc) loc) loc
|
||||
type' = ty // one q
|
||||
whnf defs ctx $ Ann term' type' loc
|
||||
|
||||
-- (coe [_ ⇒ {⋯}] @_ @_ t) ⇝ (t ∷ {⋯})
|
||||
Tag {tag, loc = tagLoc} => do
|
||||
let Enum {cases, loc = enumLoc} = ty
|
||||
| _ => throw $ ExpectedEnum ty.loc (extendDim i ctx.names) ty
|
||||
pure $ Element (Ann (Tag tag tagLoc) (Enum cases enumLoc) loc) Ah
|
||||
|
||||
-- (coe [_ ⇒ ℕ] @_ @_ n) ⇝ (n ∷ ℕ)
|
||||
Zero {loc = zeroLoc} => do
|
||||
pure $ Element (Ann (Zero zeroLoc) (Nat ty.loc) loc) Ah
|
||||
Succ {p = pred, loc = succLoc} => do
|
||||
pure $ Element (Ann (Succ pred succLoc) (Nat ty.loc) loc) Ah
|
||||
|
||||
-- (coe [i ⇒ [π.A]] @p @q [s]) ⇝
|
||||
-- [coe [i ⇒ A] @p @q s] ∷ [π. A‹q/i›]
|
||||
Box {val, loc = boxLoc} => do
|
||||
let BOX {qty, ty = a, loc = tyLoc} = ty
|
||||
| _ => throw $ ExpectedBOX ty.loc (extendDim i ctx.names) ty
|
||||
pure $ Element
|
||||
(Ann (Box (E $ CoeT i a p q val val.loc) boxLoc)
|
||||
(BOX qty (a // one q) tyLoc) loc)
|
||||
Ah
|
||||
|
||||
E e => pure $ Element (CoeT i ty p q (E e) e.loc) (snf `orNo` Ah)
|
||||
where
|
||||
unwrapTYPE : Term (S d) n -> Eff Whnf Universe
|
||||
unwrapTYPE (TYPE {l, _}) = pure l
|
||||
unwrapTYPE ty = throw $ ExpectedTYPE ty.loc (extendDim i ctx.names) ty
|
||||
|
||||
|
||||
export covering
|
||||
CanWhnf Elim Reduce.isRedexE where
|
||||
whnf defs ctx (F x u loc) with (lookupElim x defs) proof eq
|
||||
_ | Just y = whnf defs ctx $ setLoc loc $ displace u y
|
||||
_ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah
|
||||
|
||||
whnf _ _ (B i loc) = pure $ nred $ B i loc
|
||||
|
||||
-- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x]
|
||||
whnf defs ctx (App f s appLoc) = do
|
||||
Element f fnf <- whnf defs ctx f
|
||||
case nchoose $ isLamHead f of
|
||||
Left _ => case f of
|
||||
Ann (Lam {body, _}) (Pi {arg, res, _}) floc =>
|
||||
let s = Ann s arg s.loc in
|
||||
whnf defs ctx $ Ann (sub1 body s) (sub1 res s) appLoc
|
||||
Coe ty p q val _ => piCoe defs ctx ty p q val s appLoc
|
||||
Right nlh => pure $ Element (App f s appLoc) $ fnf `orNo` nlh
|
||||
|
||||
-- case (s, t) ∷ (x : A) × B return p ⇒ C of { (a, b) ⇒ u } ⇝
|
||||
-- u[s∷A/a, t∷B[s∷A/x]] ∷ C[(s, t)∷((x : A) × B)/p]
|
||||
whnf defs ctx (CasePair pi pair ret body caseLoc) = do
|
||||
Element pair pairnf <- whnf defs ctx pair
|
||||
case nchoose $ isPairHead pair of
|
||||
Left _ => case pair of
|
||||
Ann (Pair {fst, snd, _}) (Sig {fst = tfst, snd = tsnd, _}) pairLoc =>
|
||||
let fst = Ann fst tfst fst.loc
|
||||
snd = Ann snd (sub1 tsnd fst) snd.loc
|
||||
in
|
||||
whnf defs ctx $ Ann (subN body [< fst, snd]) (sub1 ret pair) caseLoc
|
||||
Coe ty p q val _ => do
|
||||
sigCoe defs ctx pi ty p q val ret body caseLoc
|
||||
Right np =>
|
||||
pure $ Element (CasePair pi pair ret body caseLoc) $ pairnf `orNo` np
|
||||
|
||||
-- case 'a ∷ {a,…} return p ⇒ C of { 'a ⇒ u } ⇝
|
||||
-- u ∷ C['a∷{a,…}/p]
|
||||
whnf defs ctx (CaseEnum pi tag ret arms caseLoc) = do
|
||||
Element tag tagnf <- whnf defs ctx tag
|
||||
case nchoose $ isTagHead tag of
|
||||
Left _ => case tag of
|
||||
Ann (Tag t _) (Enum ts _) _ =>
|
||||
let ty = sub1 ret tag in
|
||||
case lookup t arms of
|
||||
Just arm => whnf defs ctx $ Ann arm ty arm.loc
|
||||
Nothing => throw $ MissingEnumArm caseLoc t (keys arms)
|
||||
Coe ty p q val _ =>
|
||||
-- there is nowhere an equality can be hiding inside an enum type
|
||||
whnf defs ctx $
|
||||
CaseEnum pi (Ann val (dsub1 ty q) val.loc) ret arms caseLoc
|
||||
Right nt =>
|
||||
pure $ Element (CaseEnum pi tag ret arms caseLoc) $ tagnf `orNo` nt
|
||||
|
||||
-- case zero ∷ ℕ return p ⇒ C of { zero ⇒ u; … } ⇝
|
||||
-- u ∷ C[zero∷ℕ/p]
|
||||
--
|
||||
-- case succ n ∷ ℕ return p ⇒ C of { succ n', π.ih ⇒ u; … } ⇝
|
||||
-- u[n∷ℕ/n', (case n ∷ ℕ ⋯)/ih] ∷ C[succ n ∷ ℕ/p]
|
||||
whnf defs ctx (CaseNat pi piIH nat ret zer suc caseLoc) = do
|
||||
Element nat natnf <- whnf defs ctx nat
|
||||
case nchoose $ isNatHead nat of
|
||||
Left _ =>
|
||||
let ty = sub1 ret nat in
|
||||
case nat of
|
||||
Ann (Zero _) (Nat _) _ =>
|
||||
whnf defs ctx $ Ann zer ty zer.loc
|
||||
Ann (Succ n succLoc) (Nat natLoc) _ =>
|
||||
let nn = Ann n (Nat natLoc) succLoc
|
||||
tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc]
|
||||
in
|
||||
whnf defs ctx $ Ann tm ty caseLoc
|
||||
Coe ty p q val _ =>
|
||||
-- same deal as Enum
|
||||
whnf defs ctx $
|
||||
CaseNat pi piIH (Ann val (dsub1 ty q) val.loc) ret zer suc caseLoc
|
||||
Right nn => pure $
|
||||
Element (CaseNat pi piIH nat ret zer suc caseLoc) $ natnf `orNo` nn
|
||||
|
||||
-- case [t] ∷ [π.A] return p ⇒ C of { [x] ⇒ u } ⇝
|
||||
-- u[t∷A/x] ∷ C[[t] ∷ [π.A]/p]
|
||||
whnf defs ctx (CaseBox pi box ret body caseLoc) = do
|
||||
Element box boxnf <- whnf defs ctx box
|
||||
case nchoose $ isBoxHead box of
|
||||
Left _ => case box of
|
||||
Ann (Box val boxLoc) (BOX q bty tyLoc) _ =>
|
||||
let ty = sub1 ret box in
|
||||
whnf defs ctx $ Ann (sub1 body (Ann val bty val.loc)) ty caseLoc
|
||||
Coe ty p q val _ =>
|
||||
boxCoe defs ctx pi ty p q val ret body caseLoc
|
||||
Right nb =>
|
||||
pure $ Element (CaseBox pi box ret body caseLoc) $ boxnf `orNo` nb
|
||||
|
||||
-- e : Eq (𝑗 ⇒ A) t u ⊢ e @0 ⇝ t ∷ A‹0/𝑗›
|
||||
-- e : Eq (𝑗 ⇒ A) t u ⊢ e @1 ⇝ u ∷ A‹1/𝑗›
|
||||
--
|
||||
-- ((δ 𝑖 ⇒ s) ∷ Eq (𝑗 ⇒ A) t u) @𝑘 ⇝ s‹𝑘/𝑖› ∷ A‹𝑘/𝑗›
|
||||
whnf defs ctx (DApp f p appLoc) = do
|
||||
Element f fnf <- whnf defs ctx f
|
||||
case nchoose $ isDLamHead f of
|
||||
Left _ => case f of
|
||||
Ann (DLam {body, _}) (Eq {ty, l, r, _}) _ =>
|
||||
whnf defs ctx $
|
||||
Ann (endsOr (setLoc appLoc l) (setLoc appLoc r) (dsub1 body p) p)
|
||||
(dsub1 ty p) appLoc
|
||||
Coe ty p' q' val _ =>
|
||||
eqCoe defs ctx ty p' q' val p appLoc
|
||||
Right ndlh => case p of
|
||||
K e _ => do
|
||||
Eq {l, r, ty, _} <- whnf0 defs ctx =<< computeElimType defs ctx f
|
||||
| ty => throw $ ExpectedEq ty.loc ctx.names ty
|
||||
whnf defs ctx $
|
||||
ends (Ann (setLoc appLoc l) ty.zero appLoc)
|
||||
(Ann (setLoc appLoc r) ty.one appLoc) e
|
||||
B {} => pure $ Element (DApp f p appLoc) $ fnf `orNo` ndlh `orNo` Ah
|
||||
|
||||
-- e ∷ A ⇝ e
|
||||
whnf defs ctx (Ann s a annLoc) = do
|
||||
Element s snf <- whnf defs ctx s
|
||||
case nchoose $ isE s of
|
||||
Left _ => let E e = s in pure $ Element e $ noOr2 snf
|
||||
Right ne => do
|
||||
Element a anf <- whnf defs ctx a
|
||||
pure $ Element (Ann s a annLoc) $ ne `orNo` snf `orNo` anf
|
||||
|
||||
whnf defs ctx (Coe (S _ (N ty)) _ _ val coeLoc) =
|
||||
whnf defs ctx $ Ann val ty coeLoc
|
||||
whnf defs ctx (Coe (S [< i] ty) p q val coeLoc) = do
|
||||
Element ty tynf <- whnf defs (extendDim i ctx) ty.term
|
||||
Element val valnf <- whnf defs ctx val
|
||||
pushCoe defs ctx i ty p q val coeLoc
|
||||
|
||||
whnf defs ctx (Comp ty p q val r zero one compLoc) =
|
||||
-- comp [A] @p @p s { ⋯ } ⇝ s ∷ A
|
||||
if p == q then whnf defs ctx $ Ann val ty compLoc else
|
||||
case nchoose (isK r) of
|
||||
-- comp [A] @p @q s @0 { 0 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A
|
||||
-- comp [A] @p @q s @1 { 1 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A
|
||||
Left y => case r of
|
||||
K Zero _ => whnf defs ctx $ Ann (dsub1 zero q) ty compLoc
|
||||
K One _ => whnf defs ctx $ Ann (dsub1 one q) ty compLoc
|
||||
Right nk => do
|
||||
Element ty tynf <- whnf defs ctx ty
|
||||
pure $ Element (Comp ty p q val r zero one compLoc) $ tynf `orNo` nk
|
||||
|
||||
whnf defs ctx (TypeCase ty ret arms def tcLoc) = do
|
||||
Element ty tynf <- whnf defs ctx ty
|
||||
Element ret retnf <- whnf defs ctx ret
|
||||
case nchoose $ isAnnTyCon ty of
|
||||
Left y =>
|
||||
let Ann ty (TYPE u _) _ = ty in
|
||||
reduceTypeCase defs ctx ty u ret arms def tcLoc
|
||||
Right nt => pure $
|
||||
Element (TypeCase ty ret arms def tcLoc) (tynf `orNo` retnf `orNo` nt)
|
||||
|
||||
whnf defs ctx (CloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' id th el
|
||||
whnf defs ctx (DCloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' th id el
|
||||
|
||||
export covering
|
||||
CanWhnf Term Reduce.isRedexT where
|
||||
whnf _ _ t@(TYPE {}) = pure $ nred t
|
||||
whnf _ _ t@(Pi {}) = pure $ nred t
|
||||
whnf _ _ t@(Lam {}) = pure $ nred t
|
||||
whnf _ _ t@(Sig {}) = pure $ nred t
|
||||
whnf _ _ t@(Pair {}) = pure $ nred t
|
||||
whnf _ _ t@(Enum {}) = pure $ nred t
|
||||
whnf _ _ t@(Tag {}) = pure $ nred t
|
||||
whnf _ _ t@(Eq {}) = pure $ nred t
|
||||
whnf _ _ t@(DLam {}) = pure $ nred t
|
||||
whnf _ _ t@(Nat {}) = pure $ nred t
|
||||
whnf _ _ t@(Zero {}) = pure $ nred t
|
||||
whnf _ _ t@(Succ {}) = pure $ nred t
|
||||
whnf _ _ t@(BOX {}) = pure $ nred t
|
||||
whnf _ _ t@(Box {}) = pure $ nred t
|
||||
|
||||
-- s ∷ A ⇝ s (in term context)
|
||||
whnf defs ctx (E e) = do
|
||||
Element e enf <- whnf defs ctx e
|
||||
case nchoose $ isAnn e of
|
||||
Left _ => let Ann {tm, _} = e in pure $ Element tm $ noOr1 $ noOr2 enf
|
||||
Right na => pure $ Element (E e) $ na `orNo` enf
|
||||
|
||||
whnf defs ctx (CloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' id th tm
|
||||
whnf defs ctx (DCloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' th id tm
|
59
lib/Quox/Scoped.idr
Normal file
59
lib/Quox/Scoped.idr
Normal file
|
@ -0,0 +1,59 @@
|
|||
module Quox.Scoped
|
||||
|
||||
import public Quox.Var
|
||||
import public Quox.Context
|
||||
|
||||
import Derive.Prelude
|
||||
|
||||
%language ElabReflection
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data ScopedBody : Nat -> (Nat -> Type) -> Nat -> Type where
|
||||
Y : (body : f (s + n)) -> ScopedBody s f n
|
||||
N : (body : f n) -> ScopedBody s f n
|
||||
%name ScopedBody body
|
||||
|
||||
export %inline %hint
|
||||
EqScopedBody : (forall n. Eq (f n)) => Eq (ScopedBody s f n)
|
||||
EqScopedBody = deriveEq
|
||||
|
||||
export %inline %hint
|
||||
ShowScopedBody : (forall n. Show (f n)) => Show (ScopedBody s f n)
|
||||
ShowScopedBody = deriveShow
|
||||
|
||||
||| a scoped term with names
|
||||
public export
|
||||
record Scoped (s : Nat) (f : Nat -> Type) (n : Nat) where
|
||||
constructor S
|
||||
names : BContext s
|
||||
body : ScopedBody s f n
|
||||
%name Scoped body
|
||||
|
||||
export %inline
|
||||
(forall n. Eq (f n)) => Eq (Scoped s f n) where
|
||||
s == t = s.body == t.body
|
||||
|
||||
export %inline %hint
|
||||
ShowScoped : (forall n. Show (f n)) => Show (Scoped s f n)
|
||||
ShowScoped = deriveShow
|
||||
|
||||
|
||||
||| scope which ignores all its binders
|
||||
public export %inline
|
||||
SN : Located1 f => {s : Nat} -> f n -> Scoped s f n
|
||||
SN body = S (replicate s $ BN Unused body.loc) $ N body
|
||||
|
||||
||| scope which uses its binders
|
||||
public export %inline
|
||||
SY : BContext s -> f (s + n) -> Scoped s f n
|
||||
SY ns = S ns . Y
|
||||
|
||||
public export %inline
|
||||
name : Scoped 1 f n -> BindName
|
||||
name (S [< x] _) = x
|
||||
|
||||
public export %inline
|
||||
(.name) : Scoped 1 f n -> BindName
|
||||
s.name = name s
|
|
@ -6,4 +6,5 @@ import public Quox.Syntax.Qty
|
|||
import public Quox.Syntax.Shift
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Syntax.Term
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Syntax.Builtin
|
||||
import public Quox.Var
|
||||
|
|
27
lib/Quox/Syntax/Builtin.idr
Normal file
27
lib/Quox/Syntax/Builtin.idr
Normal file
|
@ -0,0 +1,27 @@
|
|||
module Quox.Syntax.Builtin
|
||||
|
||||
import Derive.Prelude
|
||||
import Quox.PrettyValExtra
|
||||
import Quox.Pretty
|
||||
import Quox.Syntax.Term
|
||||
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
public export
|
||||
data Builtin
|
||||
= Main
|
||||
%runElab derive "Builtin" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
public export
|
||||
builtinDesc : Builtin -> String
|
||||
builtinDesc Main = "a function declared as #[main]"
|
||||
|
||||
public export
|
||||
builtinTypeDoc : {opts : LayoutOpts} -> Builtin -> Eff Pretty (Doc opts)
|
||||
builtinTypeDoc Main =
|
||||
prettyTerm [<] [<] $
|
||||
Pi One (IOState noLoc)
|
||||
(SN $ Sig (Enum (fromList [!(ifUnicode "𝑎" "a")]) noLoc)
|
||||
(SN (IOState noLoc)) noLoc) noLoc
|
|
@ -2,10 +2,11 @@ module Quox.Syntax.Dim
|
|||
|
||||
import Quox.Loc
|
||||
import Quox.Name
|
||||
import Quox.Syntax.Var
|
||||
import Quox.Var
|
||||
import Quox.Syntax.Subst
|
||||
import Quox.Pretty
|
||||
import Quox.Context
|
||||
import Quox.PrettyValExtra
|
||||
|
||||
import Decidable.Equality
|
||||
import Control.Function
|
||||
|
@ -18,7 +19,7 @@ import Derive.Prelude
|
|||
public export
|
||||
data DimConst = Zero | One
|
||||
%name DimConst e
|
||||
%runElab derive "DimConst" [Eq, Ord, Show]
|
||||
%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
|
||||
public export
|
||||
|
|
|
@ -1,11 +1,12 @@
|
|||
module Quox.Syntax.DimEq
|
||||
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Var
|
||||
import public Quox.Syntax.Dim
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Context
|
||||
import Quox.Pretty
|
||||
import Quox.Name
|
||||
import Quox.FreeVars
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Nat
|
||||
|
@ -58,10 +59,15 @@ 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 ZeroIsOne act = pure Nothing
|
||||
ifConsistent (C _) act = Just <$> act
|
||||
ifConsistent eqs act = ifConsistentElse eqs act (pure ())
|
||||
|
||||
public export
|
||||
toMaybe : IfConsistent eqs a -> Maybe a
|
||||
|
@ -70,13 +76,13 @@ toMaybe (Just x) = Just x
|
|||
|
||||
|
||||
export
|
||||
fromGround' : Context' DimConst d -> DimEq' d
|
||||
fromGround' [<] = [<]
|
||||
fromGround' (ctx :< e) = fromGround' ctx :< Just (K e noLoc)
|
||||
fromGround' : BContext d -> Context' DimConst d -> DimEq' d
|
||||
fromGround' [<] [<] = [<]
|
||||
fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
|
||||
|
||||
export
|
||||
fromGround : Context' DimConst d -> DimEq d
|
||||
fromGround = C . fromGround'
|
||||
fromGround : BContext d -> Context' DimConst d -> DimEq d
|
||||
fromGround = C .: fromGround'
|
||||
|
||||
|
||||
public export %inline
|
||||
|
@ -117,7 +123,7 @@ equal ZeroIsOne p q = True
|
|||
equal (C eqs) p q = get eqs p == get eqs q
|
||||
|
||||
|
||||
infixl 7 :<?
|
||||
export infixl 7 :<?
|
||||
export %inline
|
||||
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
|
||||
ZeroIsOne :<? d = ZeroIsOne
|
||||
|
@ -185,20 +191,28 @@ split1 e loc eqs = case setConst VZ e loc eqs of
|
|||
C (eqs :< _) => Just (eqs, K e loc ::: id)
|
||||
|
||||
export %inline
|
||||
split : Loc -> DimEq' (S d) -> List (Split d)
|
||||
split loc eqs = toList (split1 Zero loc eqs) <+> toList (split1 One loc eqs)
|
||||
split1' : DimConst -> Loc -> DimEq' (S d) -> List (Split d)
|
||||
split1' e loc eqs = toList $ split1 e loc eqs
|
||||
|
||||
export %inline
|
||||
split : Loc -> DimEq' (S d) -> Bool -> List (Split d)
|
||||
split loc eqs False = split1' Zero loc eqs
|
||||
split loc eqs True = split1' Zero loc eqs <+> split1' One loc eqs
|
||||
|
||||
export
|
||||
splits' : Loc -> DimEq' d -> List (DSubst d 0)
|
||||
splits' _ [<] = [id]
|
||||
splits' loc eqs@(_ :< _) =
|
||||
[th . ph | (eqs', th) <- split loc eqs, ph <- splits' loc eqs']
|
||||
splits' : Loc -> DimEq' d -> FreeVars d -> List (DSubst d 0)
|
||||
splits' _ [<] _ = [id]
|
||||
splits' loc eqs@(_ :< _) us = do
|
||||
let (us, u) = uncons us
|
||||
(eqs', th) <- split loc eqs u
|
||||
ph <- splits' loc eqs' us
|
||||
pure $ th . ph
|
||||
|
||||
||| the Loc is put into each of the DimConsts
|
||||
export %inline
|
||||
splits : Loc -> DimEq d -> List (DSubst d 0)
|
||||
splits _ ZeroIsOne = []
|
||||
splits loc (C eqs) = splits' loc eqs
|
||||
splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
|
||||
splits _ ZeroIsOne _ = []
|
||||
splits loc (C eqs) fvs = splits' loc eqs fvs
|
||||
|
||||
|
||||
private
|
||||
|
@ -228,9 +242,20 @@ 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 = traverse prettyDBind . toSnocList'
|
||||
prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
|
||||
prettyDVars' = traverse prettyDBind . toSnocList'
|
||||
|
||||
export
|
||||
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
|
||||
prettyDVars vars =
|
||||
parensIfM (dimEqPrec vars Nothing) $
|
||||
fillSeparateTight !commaD $ !(prettyDVars' vars)
|
||||
|
||||
private
|
||||
prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
|
||||
|
@ -247,16 +272,16 @@ prettyCsts dnames (eqs :< Just q) =
|
|||
|
||||
export
|
||||
prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
|
||||
prettyDimEq' dnames eqs = do
|
||||
vars <- prettyDVars dnames
|
||||
eqs <- prettyCsts dnames eqs
|
||||
let prec = if length vars <= 1 && null eqs then Arg else Outer
|
||||
parensIfM prec $ fillSeparateTight !commaD $ toList vars ++ toList eqs
|
||||
prettyDimEq' vars eqs = do
|
||||
vars' <- prettyDVars' vars
|
||||
eqs' <- prettyCsts vars eqs
|
||||
parensIfM (dimEqPrec vars (Just eqs)) $
|
||||
fillSeparateTight !commaD $ vars' ++ eqs'
|
||||
|
||||
export
|
||||
prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
|
||||
prettyDimEq dnames ZeroIsOne = do
|
||||
vars <- prettyDVars dnames
|
||||
vars <- prettyDVars' dnames
|
||||
cst <- prettyCst [<] (K Zero noLoc) (K One noLoc)
|
||||
pure $ separateTight !commaD $ vars :< cst
|
||||
prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
|
||||
|
|
|
@ -6,6 +6,7 @@ module Quox.Syntax.Qty
|
|||
|
||||
import Quox.Pretty
|
||||
import Quox.Decidable
|
||||
import Quox.PrettyValExtra
|
||||
import Data.DPair
|
||||
import Derive.Prelude
|
||||
|
||||
|
@ -20,7 +21,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]
|
||||
%runElab derive "Qty" [Eq, Ord, Show, PrettyVal]
|
||||
%name Qty.Qty pi, rh
|
||||
|
||||
|
||||
|
@ -78,26 +79,16 @@ lub p q = if p == q then p else Any
|
|||
||| to maintain subject reduction, only 0 or 1 can occur
|
||||
||| for the subject of a typing judgment. see @qtt, §2.3 for more detail
|
||||
public export
|
||||
isSubj : Qty -> Bool
|
||||
isSubj Zero = True
|
||||
isSubj One = True
|
||||
isSubj Any = False
|
||||
|
||||
public export
|
||||
SQty : Type
|
||||
SQty = Subset Qty $ So . isSubj
|
||||
|
||||
public export %inline
|
||||
szero, sone : SQty
|
||||
szero = Element Zero Oh
|
||||
sone = Element One Oh
|
||||
data SQty = SZero | SOne
|
||||
%runElab derive "SQty" [Eq, Ord, Show, PrettyVal]
|
||||
%name Qty.SQty sg
|
||||
|
||||
||| "σ ⨴ π"
|
||||
|||
|
||||
||| σ ⨭ π is 0 if either of σ or π are, otherwise it is σ.
|
||||
||| σ ⨴ π is 0 if either of σ or π are, otherwise it is σ.
|
||||
public export
|
||||
subjMult : SQty -> Qty -> SQty
|
||||
subjMult _ Zero = szero
|
||||
subjMult _ Zero = SZero
|
||||
subjMult sg _ = sg
|
||||
|
||||
|
||||
|
@ -105,23 +96,59 @@ subjMult sg _ = sg
|
|||
||| quantity of 1, so the only distinction is whether it is present
|
||||
||| at runtime at all or not
|
||||
public export
|
||||
isGlobal : Qty -> Bool
|
||||
isGlobal Zero = True
|
||||
isGlobal One = False
|
||||
isGlobal Any = True
|
||||
data GQty = GZero | GAny
|
||||
%runElab derive "GQty" [Eq, Ord, Show, PrettyVal]
|
||||
%name GQty rh
|
||||
|
||||
public export
|
||||
GQty : Type
|
||||
GQty = Subset Qty $ So . isGlobal
|
||||
|
||||
public export
|
||||
gzero, gany : GQty
|
||||
gzero = Element Zero Oh
|
||||
gany = Element Any Oh
|
||||
toGlobal : Qty -> Maybe GQty
|
||||
toGlobal Zero = Just GZero
|
||||
toGlobal Any = Just GAny
|
||||
toGlobal One = Nothing
|
||||
|
||||
||| when checking a definition, a 0 definition is checked at 0,
|
||||
||| but an ω definition is checked at 1 since ω isn't a subject quantity
|
||||
public export %inline
|
||||
globalToSubj : GQty -> SQty
|
||||
globalToSubj (Element Zero _) = szero
|
||||
globalToSubj (Element Any _) = sone
|
||||
globalToSubj GZero = SZero
|
||||
globalToSubj GAny = SOne
|
||||
|
||||
|
||||
public export
|
||||
DecEq Qty where
|
||||
decEq Zero Zero = Yes Refl
|
||||
decEq Zero One = No $ \case _ impossible
|
||||
decEq Zero Any = No $ \case _ impossible
|
||||
decEq One Zero = No $ \case _ impossible
|
||||
decEq One One = Yes Refl
|
||||
decEq One Any = No $ \case _ impossible
|
||||
decEq Any Zero = No $ \case _ impossible
|
||||
decEq Any One = No $ \case _ impossible
|
||||
decEq Any Any = Yes Refl
|
||||
|
||||
public export
|
||||
DecEq SQty where
|
||||
decEq SZero SZero = Yes Refl
|
||||
decEq SZero SOne = No $ \case _ impossible
|
||||
decEq SOne SZero = No $ \case _ impossible
|
||||
decEq SOne SOne = Yes Refl
|
||||
|
||||
public export
|
||||
DecEq GQty where
|
||||
decEq GZero GZero = Yes Refl
|
||||
decEq GZero GAny = No $ \case _ impossible
|
||||
decEq GAny GZero = No $ \case _ impossible
|
||||
decEq GAny GAny = Yes Refl
|
||||
|
||||
|
||||
namespace SQty
|
||||
public export %inline
|
||||
(.qty) : SQty -> Qty
|
||||
(SZero).qty = Zero
|
||||
(SOne).qty = One
|
||||
|
||||
namespace GQty
|
||||
public export %inline
|
||||
(.qty) : GQty -> Qty
|
||||
(GZero).qty = Zero
|
||||
(GAny).qty = Any
|
||||
|
|
|
@ -1,9 +1,11 @@
|
|||
module Quox.Syntax.Shift
|
||||
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Var
|
||||
|
||||
import Data.Nat
|
||||
import Data.So
|
||||
import Data.Singleton
|
||||
import Syntax.PreorderReasoning
|
||||
|
||||
%default total
|
||||
|
||||
|
@ -146,6 +148,25 @@ weakViaNat s by =
|
|||
%transform "Shift.weak" Shift.weak = weakViaNat
|
||||
|
||||
|
||||
export
|
||||
getFrom : {to : Nat} -> Shift from to -> Singleton from
|
||||
getFrom SZ = Val to
|
||||
getFrom (SS by) = getFrom by
|
||||
|
||||
private
|
||||
0 getFromViaNatProof : (by : Shift from to) -> from = to `minus` by.nat
|
||||
getFromViaNatProof by = Calc $
|
||||
|~ from
|
||||
~~ minus (by.nat + from) by.nat ..<(minusPlus {})
|
||||
~~ minus to by.nat ..<(cong (flip minus by.nat) (shiftDiff by))
|
||||
|
||||
private
|
||||
getFromViaNat : {to : Nat} -> Shift from to -> Singleton from
|
||||
getFromViaNat by = rewrite getFromViaNatProof by in Val _
|
||||
|
||||
%transform "Shift.getFrom" Shift.getFrom = getFromViaNat
|
||||
|
||||
|
||||
public export
|
||||
shift : Shift from to -> Var from -> Var to
|
||||
shift SZ i = i
|
||||
|
@ -178,11 +199,12 @@ by . SS bz = SS $ by . bz
|
|||
private
|
||||
0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||
to = by.nat + bz.nat + from
|
||||
compNatProof by bz =
|
||||
trans (shiftDiff bz) $
|
||||
trans (cong (bz.nat +) (shiftDiff by)) $
|
||||
trans (plusAssociative bz.nat by.nat from) $
|
||||
cong (+ from) (plusCommutative bz.nat by.nat)
|
||||
compNatProof by bz = Calc $
|
||||
|~ to
|
||||
~~ bz.nat + mid ...(shiftDiff {})
|
||||
~~ bz.nat + (by.nat + from) ...(cong (bz.nat +) (shiftDiff {}))
|
||||
~~ bz.nat + by.nat + from ...(plusAssociative {})
|
||||
~~ by.nat + bz.nat + from ...(cong (+ from) (plusCommutative {}))
|
||||
|
||||
private %inline
|
||||
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||
|
@ -205,7 +227,7 @@ compViaNatCorrect by (SS bz) =
|
|||
%transform "Shift.(.)" Shift.(.) = compViaNat
|
||||
|
||||
|
||||
infixl 8 //
|
||||
export infixl 8 //
|
||||
public export
|
||||
interface CanShift f where
|
||||
(//) : f from -> Shift from to -> f to
|
||||
|
|
|
@ -1,12 +1,13 @@
|
|||
module Quox.Syntax.Subst
|
||||
|
||||
import public Quox.Syntax.Shift
|
||||
import Quox.Syntax.Var
|
||||
import Quox.Var
|
||||
import Quox.Name
|
||||
|
||||
import Data.Nat
|
||||
import Data.List
|
||||
import Data.SnocVect
|
||||
import Data.Singleton
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
|
@ -19,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
|
||||
|
||||
infixr 7 !:::
|
||||
export infixr 7 !:::
|
||||
||| in case the automatic laziness insertion gets confused
|
||||
public export
|
||||
(!:::) : env to -> Subst env from to -> Subst env (S from) to
|
||||
|
@ -41,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
|
||||
|
||||
|
||||
infixl 8 //
|
||||
export infixl 8 //
|
||||
public export
|
||||
interface FromVar term => CanSubstSelf term where
|
||||
(//) : term from -> Lazy (Subst term from to) -> term to
|
||||
|
@ -95,18 +96,18 @@ map f (t ::: th) = f t ::: map f th
|
|||
|
||||
|
||||
public export %inline
|
||||
push : CanSubstSelf f => Subst f from to -> Subst f (S from) (S to)
|
||||
push th = fromVar VZ ::: (th . shift 1)
|
||||
push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
|
||||
push loc th = fromVarLoc VZ loc ::: (th . shift 1)
|
||||
|
||||
-- [fixme] a better way to do this?
|
||||
public export
|
||||
pushN : CanSubstSelf f => (s : Nat) ->
|
||||
pushN : CanSubstSelf f => (s : Nat) -> Loc ->
|
||||
Subst f from to -> Subst f (s + from) (s + to)
|
||||
pushN 0 th = th
|
||||
pushN (S s) th =
|
||||
pushN 0 _ th = th
|
||||
pushN (S s) loc th =
|
||||
rewrite plusSuccRightSucc s from in
|
||||
rewrite plusSuccRightSucc s to in
|
||||
pushN s $ fromVar VZ ::: (th . shift 1)
|
||||
pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
|
||||
|
||||
public export
|
||||
drop1 : Subst f (S from) to -> Subst f from to
|
||||
|
@ -124,6 +125,12 @@ one : f n -> Subst f (S n) n
|
|||
one x = fromSnocVect [< x]
|
||||
|
||||
|
||||
export
|
||||
getFrom : {to : Nat} -> Subst _ from to -> Singleton from
|
||||
getFrom (Shift by) = getFrom by
|
||||
getFrom (t ::: th) = [|S $ getFrom th|]
|
||||
|
||||
|
||||
||| whether two substitutions with the same codomain have the same shape
|
||||
||| (the same number of terms and the same shift at the end). if so, they
|
||||
||| also have the same domain
|
||||
|
@ -133,7 +140,7 @@ cmpShape : Subst env from1 to -> Subst env from2 to ->
|
|||
cmpShape (Shift by) (Shift bz) = cmpLen by bz
|
||||
cmpShape (Shift _) (_ ::: _) = Left LT
|
||||
cmpShape (_ ::: _) (Shift _) = Left GT
|
||||
cmpShape (_ ::: th) (_ ::: ph) = cong S <$> cmpShape th ph
|
||||
cmpShape (_ ::: th) (_ ::: ph) = map (\x => cong S x) $ cmpShape th ph
|
||||
|
||||
|
||||
public export
|
||||
|
|
|
@ -3,4 +3,3 @@ 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
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
module Quox.Syntax.Term.Base
|
||||
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Var
|
||||
import public Quox.Scoped
|
||||
import public Quox.Syntax.Shift
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Syntax.Qty
|
||||
|
@ -46,39 +47,6 @@ TagVal : Type
|
|||
TagVal = String
|
||||
|
||||
|
||||
public export
|
||||
data ScopedBody : Nat -> (Nat -> Type) -> Nat -> Type where
|
||||
Y : (body : f (s + n)) -> ScopedBody s f n
|
||||
N : (body : f n) -> ScopedBody s f n
|
||||
%name ScopedBody body
|
||||
|
||||
export %inline %hint
|
||||
EqScopedBody : (forall n. Eq (f n)) => Eq (ScopedBody s f n)
|
||||
EqScopedBody = deriveEq
|
||||
|
||||
export %inline %hint
|
||||
ShowScopedBody : (forall n. Show (f n)) => Show (ScopedBody s f n)
|
||||
ShowScopedBody = deriveShow
|
||||
|
||||
||| a scoped term with names
|
||||
public export
|
||||
record Scoped (s : Nat) (f : Nat -> Type) (n : Nat) where
|
||||
constructor S
|
||||
names : BContext s
|
||||
body : ScopedBody s f n
|
||||
%name Scoped body
|
||||
|
||||
export %inline
|
||||
(forall n. Eq (f n)) => Eq (Scoped s f n) where
|
||||
s == t = s.body == t.body
|
||||
|
||||
export %inline %hint
|
||||
ShowScoped : (forall n. Show (f n)) => Show (Scoped s f n)
|
||||
ShowScoped = deriveShow
|
||||
|
||||
|
||||
infixl 8 :#
|
||||
infixl 9 :@, :%
|
||||
mutual
|
||||
public export
|
||||
TSubst : TSubstLike
|
||||
|
@ -91,6 +59,10 @@ 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
|
||||
|
@ -113,15 +85,21 @@ mutual
|
|||
DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| natural numbers (temporary until 𝐖 gets added)
|
||||
Nat : (loc : Loc) -> Term d n
|
||||
-- [todo] can these be elims?
|
||||
Zero : (loc : Loc) -> Term d n
|
||||
NAT : (loc : Loc) -> Term d n
|
||||
Nat : (val : Nat) -> (loc : Loc) -> Term d n
|
||||
Succ : (p : Term d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| strings
|
||||
STRING : (loc : Loc) -> Term d n
|
||||
Str : (str : String) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| "box" (package a value up with a certain quantity)
|
||||
BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
|
||||
Box : (val : Term d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
Let : (qty : Qty) -> (rhs : Elim d n) ->
|
||||
(body : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| elimination
|
||||
E : (e : Elim d n) -> Term d n
|
||||
|
||||
|
@ -155,6 +133,12 @@ mutual
|
|||
(loc : Loc) ->
|
||||
Elim d n
|
||||
|
||||
||| first element of a pair. only works in non-linear contexts.
|
||||
Fst : (pair : Elim d n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| second element of a pair. only works in non-linear contexts.
|
||||
Snd : (pair : Elim d n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| enum matching
|
||||
CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
|
||||
(ret : ScopeTerm d n) ->
|
||||
|
@ -250,23 +234,123 @@ 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
|
||||
|
||||
||| scope which uses its binders
|
||||
public export %inline
|
||||
SY : BContext s -> f (s + n) -> Scoped s f n
|
||||
SY ns = S ns . Y
|
||||
export
|
||||
Located (Elim d n) where
|
||||
(F _ _ loc).loc = loc
|
||||
(B _ loc).loc = loc
|
||||
(App _ _ loc).loc = loc
|
||||
(CasePair _ _ _ _ loc).loc = loc
|
||||
(Fst _ loc).loc = loc
|
||||
(Snd _ loc).loc = loc
|
||||
(CaseEnum _ _ _ _ loc).loc = loc
|
||||
(CaseNat _ _ _ _ _ _ loc).loc = loc
|
||||
(CaseBox _ _ _ _ loc).loc = loc
|
||||
(DApp _ _ loc).loc = loc
|
||||
(Ann _ _ loc).loc = loc
|
||||
(Coe _ _ _ _ loc).loc = loc
|
||||
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
||||
(TypeCase _ _ _ _ loc).loc = loc
|
||||
(CloE (Sub e _)).loc = e.loc
|
||||
(DCloE (Sub e _)).loc = e.loc
|
||||
|
||||
public export %inline
|
||||
name : Scoped 1 f n -> BindName
|
||||
name (S [< x] _) = x
|
||||
export
|
||||
Located (Term d n) where
|
||||
(TYPE _ loc).loc = loc
|
||||
(IOState loc).loc = loc
|
||||
(Pi _ _ _ loc).loc = loc
|
||||
(Lam _ loc).loc = loc
|
||||
(Sig _ _ loc).loc = loc
|
||||
(Pair _ _ loc).loc = loc
|
||||
(Enum _ loc).loc = loc
|
||||
(Tag _ loc).loc = loc
|
||||
(Eq _ _ _ loc).loc = loc
|
||||
(DLam _ loc).loc = loc
|
||||
(NAT loc).loc = loc
|
||||
(Nat _ loc).loc = loc
|
||||
(STRING loc).loc = loc
|
||||
(Str _ loc).loc = loc
|
||||
(Succ _ loc).loc = loc
|
||||
(BOX _ _ loc).loc = loc
|
||||
(Box _ loc).loc = loc
|
||||
(Let _ _ _ loc).loc = loc
|
||||
(E e).loc = e.loc
|
||||
(CloT (Sub t _)).loc = t.loc
|
||||
(DCloT (Sub t _)).loc = t.loc
|
||||
|
||||
export
|
||||
Located1 f => Located (ScopedBody s f n) where
|
||||
(Y t).loc = t.loc
|
||||
(N t).loc = t.loc
|
||||
|
||||
export
|
||||
Located1 f => Located (Scoped s f n) where
|
||||
t.loc = t.body.loc
|
||||
|
||||
|
||||
export
|
||||
Relocatable (Elim d n) where
|
||||
setLoc loc (F x u _) = F x u loc
|
||||
setLoc loc (B i _) = B i loc
|
||||
setLoc loc (App fun arg _) = App fun arg loc
|
||||
setLoc loc (CasePair qty pair ret body _) =
|
||||
CasePair qty pair ret body loc
|
||||
setLoc loc (Fst pair _) = Fst pair loc
|
||||
setLoc loc (Snd pair _) = Fst pair loc
|
||||
setLoc loc (CaseEnum qty tag ret arms _) =
|
||||
CaseEnum qty tag ret arms loc
|
||||
setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
|
||||
CaseNat qty qtyIH nat ret zero succ loc
|
||||
setLoc loc (CaseBox qty box ret body _) =
|
||||
CaseBox qty box ret body loc
|
||||
setLoc loc (DApp fun arg _) =
|
||||
DApp fun arg loc
|
||||
setLoc loc (Ann tm ty _) =
|
||||
Ann tm ty loc
|
||||
setLoc loc (Coe ty p q val _) =
|
||||
Coe ty p q val loc
|
||||
setLoc loc (Comp ty p q val r zero one _) =
|
||||
Comp ty p q val r zero one loc
|
||||
setLoc loc (TypeCase ty ret arms def _) =
|
||||
TypeCase ty ret arms def loc
|
||||
setLoc loc (CloE (Sub term subst)) =
|
||||
CloE $ Sub (setLoc loc term) subst
|
||||
setLoc loc (DCloE (Sub term subst)) =
|
||||
DCloE $ Sub (setLoc loc term) subst
|
||||
|
||||
export
|
||||
Relocatable (Term d n) where
|
||||
setLoc loc (TYPE l _) = TYPE l loc
|
||||
setLoc loc (IOState _) = IOState loc
|
||||
setLoc loc (Pi qty arg res _) = Pi qty arg res loc
|
||||
setLoc loc (Lam body _) = Lam body loc
|
||||
setLoc loc (Sig fst snd _) = Sig fst snd loc
|
||||
setLoc loc (Pair fst snd _) = Pair fst snd loc
|
||||
setLoc loc (Enum cases _) = Enum cases loc
|
||||
setLoc loc (Tag tag _) = Tag tag loc
|
||||
setLoc loc (Eq ty l r _) = Eq ty l r loc
|
||||
setLoc loc (DLam body _) = DLam body loc
|
||||
setLoc loc (NAT _) = NAT loc
|
||||
setLoc loc (Nat n _) = Nat n loc
|
||||
setLoc loc (Succ p _) = Succ p loc
|
||||
setLoc loc (STRING _) = STRING loc
|
||||
setLoc loc (Str s _) = Str s loc
|
||||
setLoc loc (BOX qty ty _) = BOX qty ty loc
|
||||
setLoc loc (Box val _) = Box val loc
|
||||
setLoc loc (Let qty rhs body _) = Let qty rhs body loc
|
||||
setLoc loc (E e) = E $ setLoc loc e
|
||||
setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
|
||||
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
|
||||
|
||||
export
|
||||
Relocatable1 f => Relocatable (ScopedBody s f n) where
|
||||
setLoc loc (Y body) = Y $ setLoc loc body
|
||||
setLoc loc (N body) = N $ setLoc loc body
|
||||
|
||||
export
|
||||
Relocatable1 f => Relocatable (Scoped s f n) where
|
||||
setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
|
||||
|
||||
public export %inline
|
||||
(.name) : Scoped 1 f n -> BindName
|
||||
s.name = name s
|
||||
|
||||
||| more convenient Pi
|
||||
public export %inline
|
||||
|
@ -314,6 +398,12 @@ 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
|
||||
|
@ -324,6 +414,11 @@ public export %inline
|
|||
FT : Name -> Universe -> Loc -> Term d n
|
||||
FT x u loc = E $ F x u loc
|
||||
|
||||
||| same as `B` but as a term
|
||||
public export %inline
|
||||
BT : Var n -> (loc : Loc) -> Term d n
|
||||
BT i loc = E $ B i loc
|
||||
|
||||
||| abbreviation for a bound variable like `BV 4` instead of
|
||||
||| `B (VS (VS (VS (VS VZ))))`
|
||||
public export %inline
|
||||
|
@ -335,10 +430,9 @@ public export %inline
|
|||
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
|
||||
BVT i loc = E $ BV i loc
|
||||
|
||||
public export
|
||||
makeNat : Nat -> Loc -> Term d n
|
||||
makeNat 0 loc = Zero loc
|
||||
makeNat (S k) loc = Succ (makeNat k loc) loc
|
||||
public export %inline
|
||||
Zero : Loc -> Term d n
|
||||
Zero = Nat 0
|
||||
|
||||
public export %inline
|
||||
enum : List TagVal -> Loc -> Term d n
|
||||
|
@ -353,111 +447,6 @@ 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
|
||||
(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 (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)
|
||||
|
|
|
@ -30,14 +30,6 @@ 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
|
||||
|
@ -209,8 +201,7 @@ prettyTArg dnames tnames s =
|
|||
|
||||
private
|
||||
prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
|
||||
prettyDArg dnames p =
|
||||
map (text "@" <+>) $ withPrec Arg $ prettyDim dnames p
|
||||
prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
|
||||
|
||||
private
|
||||
splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
|
||||
|
@ -238,7 +229,6 @@ 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
|
||||
|
@ -251,12 +241,11 @@ parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
|
|||
body <- withPrec Outer $ assert_total
|
||||
prettyTerm (dnames . dbinds) (tnames . tbinds) body
|
||||
header <- (pat <++>) <$> darrowD
|
||||
pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
|
||||
pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
|
||||
|
||||
private
|
||||
prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (Doc opts)
|
||||
prettyCaseBody xs =
|
||||
braces . separateTight !semiD =<< traverse prettyCaseArm xs
|
||||
prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts))
|
||||
prettyCaseBody xs = traverse prettyCaseArm xs
|
||||
|
||||
private
|
||||
prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts)
|
||||
|
@ -283,16 +272,12 @@ layoutComp typq val r arms = do
|
|||
[typq, [val, r <++> lb], map (indent ind) arms, [rb]])
|
||||
|
||||
|
||||
export
|
||||
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
|
||||
prettyTag tag = hl Tag $ text $ "'" ++ quoteTag tag
|
||||
|
||||
export
|
||||
prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
|
||||
prettyEnum cases =
|
||||
tightBraces =<<
|
||||
fillSeparateTight !commaD <$>
|
||||
traverse (hl Tag . Doc.text . quoteTag) cases
|
||||
traverse (hl Constant . Doc.text . quoteTag) cases
|
||||
|
||||
private
|
||||
prettyCaseRet : {opts : _} ->
|
||||
|
@ -303,7 +288,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
|
||||
pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
|
||||
hangDSingle header body
|
||||
|
||||
private
|
||||
prettyCase_ : {opts : _} ->
|
||||
|
@ -311,10 +296,16 @@ 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 <- assert_total prettyElim dnames tnames head
|
||||
head <- withPrec Outer $ assert_total prettyElim dnames tnames head
|
||||
ret <- prettyCaseRet dnames tnames ret
|
||||
body <- prettyCaseBody dnames tnames body
|
||||
parensIfM Outer $ sep [intro <++> head, !returnD <++> ret, !ofD <++> body]
|
||||
bodys <- prettyCaseBody dnames tnames body
|
||||
return <- returnD; of_ <- ofD
|
||||
lb <- hl Delim "{"; rb <- hl Delim "}"; semi <- semiD
|
||||
ind <- askAt INDENT
|
||||
parensIfM Outer $ ifMultiline
|
||||
(hsep [intro, head, return, ret, of_, lb, hseparateTight semi bodys, rb])
|
||||
(vsep [intro <++> head, return <++> ret, of_ <++> lb,
|
||||
indent ind $ vseparateTight semi bodys, rb])
|
||||
|
||||
private
|
||||
prettyCase : {opts : _} ->
|
||||
|
@ -325,6 +316,62 @@ 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
|
||||
|
@ -342,6 +389,7 @@ 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] =
|
||||
|
@ -350,6 +398,7 @@ 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
|
||||
|
||||
|
||||
|
@ -383,13 +432,13 @@ prettyDisp u = map Just $ hl Universe =<<
|
|||
ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
|
||||
|
||||
|
||||
prettyTerm dnames tnames (TYPE l _) =
|
||||
case !(askAt FLAVOR) of
|
||||
Unicode => do
|
||||
star <- hl Syntax "★"
|
||||
level <- hl Universe $ text $ superscript $ show l
|
||||
pure $ hcat [star, level]
|
||||
Ascii => [|hl Syntax "Type" <++> hl Universe (text $ show l)|]
|
||||
prettyTerm dnames tnames (TYPE l _) = do
|
||||
type <- hl Syntax . text =<< ifUnicode "★" "Type"
|
||||
level <- prettyDisp l
|
||||
pure $ maybe type (type <+>) level
|
||||
|
||||
prettyTerm dnames tnames (IOState _) =
|
||||
ioStateD
|
||||
|
||||
prettyTerm dnames tnames (Pi qty arg res _) =
|
||||
parensIfM Outer =<< do
|
||||
|
@ -426,13 +475,15 @@ prettyTerm dnames tnames (Enum cases _) =
|
|||
prettyTerm dnames tnames (Tag tag _) =
|
||||
prettyTag tag
|
||||
|
||||
prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) = do
|
||||
prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) =
|
||||
parensIfM Eq =<< do
|
||||
l <- withPrec InEq $ prettyTerm dnames tnames l
|
||||
r <- withPrec InEq $ prettyTerm dnames tnames r
|
||||
ty <- withPrec InEq $ prettyTerm dnames tnames ty
|
||||
pure $ sep [l <++> !eqndD, r <++> !colonD, ty]
|
||||
|
||||
prettyTerm dnames tnames (Eq ty l r _) = do
|
||||
prettyTerm dnames tnames (Eq ty l r _) =
|
||||
parensIfM App =<< do
|
||||
ty <- prettyTypeLine dnames tnames ty
|
||||
l <- withPrec Arg $ prettyTerm dnames tnames l
|
||||
r <- withPrec Arg $ prettyTerm dnames tnames r
|
||||
|
@ -441,20 +492,14 @@ prettyTerm dnames tnames (Eq ty l r _) = do
|
|||
prettyTerm dnames tnames s@(DLam {}) =
|
||||
prettyLambda dnames tnames s
|
||||
|
||||
prettyTerm dnames tnames (Nat _) = natD
|
||||
prettyTerm dnames tnames (Zero _) = hl Syntax "0"
|
||||
prettyTerm dnames tnames (Succ p _) = do
|
||||
succD <- succD
|
||||
let succ : Doc opts -> Eff Pretty (Doc opts)
|
||||
succ t = prettyAppD succD [t]
|
||||
toNat : Term d n -> Eff Pretty (Either (Doc opts) Nat)
|
||||
toNat s with (pushSubsts' s)
|
||||
_ | Zero _ = pure $ Right 0
|
||||
_ | Succ d _ = bitraverse succ (pure . S) =<<
|
||||
toNat (assert_smaller s d)
|
||||
_ | s' = map Left . withPrec Arg $
|
||||
prettyTerm dnames tnames $ assert_smaller s s'
|
||||
either succ (hl Syntax . text . show . S) =<< toNat p
|
||||
prettyTerm dnames tnames (NAT _) = natD
|
||||
prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n
|
||||
prettyTerm dnames tnames (Succ p _) =
|
||||
parensIfM App =<<
|
||||
prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)]
|
||||
|
||||
prettyTerm dnames tnames (STRING _) = stringD
|
||||
prettyTerm dnames tnames (Str s _) = prettyStrLit s
|
||||
|
||||
prettyTerm dnames tnames (BOX qty ty _) =
|
||||
bracks . hcat =<<
|
||||
|
@ -464,7 +509,18 @@ prettyTerm dnames tnames (BOX qty ty _) =
|
|||
prettyTerm dnames tnames (Box val _) =
|
||||
bracks =<< withPrec Outer (prettyTerm dnames tnames val)
|
||||
|
||||
prettyTerm dnames tnames (E e) = prettyElim dnames tnames e
|
||||
prettyTerm dnames tnames (Let qty rhs body _) = do
|
||||
let Evidence _ (lets, body) = splitLet [< (qty, body.name, rhs)] body.term
|
||||
heads <- prettyLets dnames tnames lets
|
||||
let tnames = tnames . map (\(_, x, _) => x) lets
|
||||
body <- withPrec Outer $ assert_total prettyTerm dnames tnames body
|
||||
let lines = toList $ heads :< body
|
||||
pure $ ifMultiline (hsep lines) (vsep lines)
|
||||
|
||||
prettyTerm dnames tnames (E e) =
|
||||
case the (Elim d n) (pushSubsts' e) of
|
||||
Ann tm _ _ => assert_total prettyTerm dnames tnames tm
|
||||
_ => assert_total prettyElim dnames tnames e
|
||||
|
||||
prettyTerm dnames tnames t0@(CloT (Sub t ph)) =
|
||||
prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' id ph t
|
||||
|
@ -491,6 +547,16 @@ prettyElim dnames tnames (CasePair qty pair ret body _) = do
|
|||
prettyCase dnames tnames qty pair ret
|
||||
[MkCaseArm pat [<] [< x, y] body.term]
|
||||
|
||||
prettyElim dnames tnames (Fst pair _) =
|
||||
parensIfM App =<< do
|
||||
pair <- prettyTArg dnames tnames (E pair)
|
||||
prettyAppD !fstD [pair]
|
||||
|
||||
prettyElim dnames tnames (Snd pair _) =
|
||||
parensIfM App =<< do
|
||||
pair <- prettyTArg dnames tnames (E pair)
|
||||
prettyAppD !sndD [pair]
|
||||
|
||||
prettyElim dnames tnames (CaseEnum qty tag ret arms _) = do
|
||||
arms <- for (SortedMap.toList arms) $ \(tag, body) =>
|
||||
pure $ MkCaseArm !(prettyTag tag) [<] [<] body
|
||||
|
@ -501,7 +567,7 @@ prettyElim dnames tnames (CaseNat qty qtyIH nat ret zero succ _) = do
|
|||
[< p, ih] = succ.names
|
||||
spat0 <- [|succD <++> prettyTBind p|]
|
||||
ihpat0 <- map hcat $ sequence [prettyQty qtyIH, dotD, prettyTBind ih]
|
||||
spat <- if ih.name == Unused
|
||||
spat <- if ih.val == Unused
|
||||
then pure spat0
|
||||
else pure $ hsep [spat0 <+> !commaD, ihpat0]
|
||||
let sarm = MkCaseArm spat [<] [< p, ih] succ.term
|
||||
|
@ -517,17 +583,15 @@ prettyElim dnames tnames e@(DApp {}) =
|
|||
prettyDTApps dnames tnames f xs
|
||||
|
||||
prettyElim dnames tnames (Ann tm ty _) =
|
||||
parensIfM Outer =<<
|
||||
hangDSingle !(withPrec AnnL [|prettyTerm dnames tnames tm <++> annD|])
|
||||
!(withPrec Outer (prettyTerm dnames tnames ty))
|
||||
case the (Term d n) (pushSubsts' tm) of
|
||||
E e => assert_total prettyElim dnames tnames e
|
||||
_ => do
|
||||
tm <- withPrec AnnL $ assert_total prettyTerm dnames tnames tm
|
||||
ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty
|
||||
parensIfM Outer =<< hangDSingle (tm <++> !annD) ty
|
||||
|
||||
prettyElim dnames tnames (Coe ty p q val _) =
|
||||
parensIfM App =<<
|
||||
if isDefaultDir p q then do
|
||||
ty <- prettyTypeLine dnames tnames ty
|
||||
val <- prettyTArg dnames tnames val
|
||||
prettyAppD !coeD [ty, val]
|
||||
else do
|
||||
parensIfM App =<< do
|
||||
ty <- prettyTypeLine dnames tnames ty
|
||||
p <- prettyDArg dnames p
|
||||
q <- prettyDArg dnames q
|
||||
|
@ -536,16 +600,14 @@ prettyElim dnames tnames (Coe ty p q val _) =
|
|||
|
||||
prettyElim dnames tnames e@(Comp ty p q val r zero one _) =
|
||||
parensIfM App =<< do
|
||||
ty <- prettyTypeLine dnames tnames $ assert_smaller e $ SN ty
|
||||
ty <- assert_total $ prettyTypeLine dnames tnames $ SN ty
|
||||
pq <- sep <$> sequence [prettyDArg dnames p, prettyDArg dnames q]
|
||||
val <- prettyTArg dnames tnames val
|
||||
r <- prettyDArg dnames r
|
||||
arm0 <- [|prettyCompArm dnames tnames Zero zero <+> semiD|]
|
||||
arm1 <- prettyCompArm dnames tnames One one
|
||||
ind <- askAt INDENT
|
||||
if isDefaultDir p q
|
||||
then layoutComp [ty] val r [arm0, arm1]
|
||||
else layoutComp [ty, pq] val r [arm0, arm1]
|
||||
layoutComp [ty, pq] val r [arm0, arm1]
|
||||
|
||||
prettyElim dnames tnames (TypeCase ty ret arms def _) = do
|
||||
arms <- for (toList arms) $ \(k ** body) => do
|
||||
|
|
|
@ -2,7 +2,6 @@ module Quox.Syntax.Term.Subst
|
|||
|
||||
import Quox.No
|
||||
import Quox.Syntax.Term.Base
|
||||
import Quox.Syntax.Term.Tighten
|
||||
import Data.SnocVect
|
||||
|
||||
%default total
|
||||
|
@ -57,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 th
|
||||
S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
|
||||
S ns (N body) // th = S ns $ N $ body // th
|
||||
|
||||
|
||||
export %inline FromVar (Elim d) where fromVarLoc = B
|
||||
export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
|
||||
export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
|
||||
|
||||
|
||||
||| does the minimal reasonable work:
|
||||
|
@ -105,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 th
|
||||
S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
|
||||
S ns (N body) // th = S ns $ N $ body // th
|
||||
|
||||
namespace DScopeTermN
|
||||
|
@ -118,6 +117,9 @@ namespace DScopeTermN
|
|||
export %inline CanShift (Term d) where s // by = s // Shift by
|
||||
export %inline CanShift (Elim d) where e // by = e // Shift by
|
||||
|
||||
export %inline CanShift (flip Term n) where s // by = s // Shift by
|
||||
export %inline CanShift (flip Elim n) where e // by = e // Shift by
|
||||
|
||||
export %inline
|
||||
{s : Nat} -> CanShift (ScopeTermN s d) where
|
||||
b // by = b // Shift by
|
||||
|
@ -132,6 +134,15 @@ 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
|
||||
|
@ -141,34 +152,40 @@ public export %inline
|
|||
weakT : (by : Nat) -> Term d n -> Term d (by + n)
|
||||
weakT by t = t // shift by
|
||||
|
||||
public export %inline
|
||||
weakS : {s : Nat} -> (by : Nat) -> ScopeTermN s d n -> ScopeTermN s d (by + n)
|
||||
weakS by t = t // shift by
|
||||
|
||||
public export %inline
|
||||
weakDS : {s : Nat} -> (by : Nat) ->
|
||||
DScopeTermN s d n -> DScopeTermN s d (by + n)
|
||||
weakDS by t = t // shift by
|
||||
|
||||
public export %inline
|
||||
weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
|
||||
weakE by t = t // shift by
|
||||
|
||||
|
||||
parameters {s : Nat}
|
||||
namespace ScopeTermBody
|
||||
parameters {auto _ : CanShift f} {s : Nat}
|
||||
export %inline
|
||||
(.term) : ScopedBody s (Term d) n -> Term d (s + n)
|
||||
(Y b).term = b
|
||||
(N b).term = weakT s b
|
||||
getTerm : ScopedBody s f n -> f (s + n)
|
||||
getTerm (Y b) = b
|
||||
getTerm (N b) = b // fromNat s
|
||||
|
||||
namespace ScopeTermN
|
||||
export %inline
|
||||
(.term) : ScopeTermN s d n -> Term d (s + n)
|
||||
t.term = t.body.term
|
||||
(.term) : Scoped s f n -> f (s + n)
|
||||
t.term = getTerm t.body
|
||||
|
||||
namespace DScopeTermBody
|
||||
namespace ScopeTermBody
|
||||
export %inline
|
||||
(.term) : ScopedBody s (\d => Term d n) d -> Term (s + d) n
|
||||
(Y b).term = b
|
||||
(N b).term = dweakT s b
|
||||
getTerm0 : ScopedBody 0 f n -> f n
|
||||
getTerm0 (Y b) = b
|
||||
getTerm0 (N b) = b
|
||||
|
||||
namespace DScopeTermN
|
||||
namespace ScopeTermN
|
||||
export %inline
|
||||
(.term) : DScopeTermN s d n -> Term (s + d) n
|
||||
t.term = t.body.term
|
||||
|
||||
(.term0) : Scoped 0 f n -> f n
|
||||
t.term0 = getTerm0 t.body
|
||||
|
||||
export %inline
|
||||
subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
|
||||
|
@ -190,11 +207,11 @@ dsub1 t p = dsubN t [< p]
|
|||
|
||||
|
||||
public export %inline
|
||||
(.zero) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
|
||||
(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
|
||||
body.zero = dsub1 body $ K Zero loc
|
||||
|
||||
public export %inline
|
||||
(.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
|
||||
(.one) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
|
||||
body.one = dsub1 body $ K One loc
|
||||
|
||||
|
||||
|
@ -202,6 +219,7 @@ public export
|
|||
0 CloTest : TermLike -> Type
|
||||
CloTest tm = forall d, n. tm d n -> Bool
|
||||
|
||||
public export
|
||||
interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
|
||||
pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
|
||||
tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
|
||||
|
@ -249,46 +267,8 @@ mutual
|
|||
isCloE (DCloE {}) = True
|
||||
isCloE _ = False
|
||||
|
||||
mutual
|
||||
export
|
||||
PushSubsts Term Subst.isCloT where
|
||||
pushSubstsWith th ph (TYPE l loc) =
|
||||
nclo $ TYPE l loc
|
||||
pushSubstsWith th ph (Pi qty a body loc) =
|
||||
nclo $ Pi qty (a // th // ph) (body // th // ph) loc
|
||||
pushSubstsWith th ph (Lam body loc) =
|
||||
nclo $ Lam (body // th // ph) loc
|
||||
pushSubstsWith th ph (Sig a b loc) =
|
||||
nclo $ Sig (a // th // ph) (b // th // ph) loc
|
||||
pushSubstsWith th ph (Pair s t loc) =
|
||||
nclo $ Pair (s // th // ph) (t // th // ph) loc
|
||||
pushSubstsWith th ph (Enum tags loc) =
|
||||
nclo $ Enum tags loc
|
||||
pushSubstsWith th ph (Tag tag loc) =
|
||||
nclo $ Tag tag loc
|
||||
pushSubstsWith th ph (Eq ty l r loc) =
|
||||
nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
|
||||
pushSubstsWith th ph (DLam body loc) =
|
||||
nclo $ DLam (body // th // ph) loc
|
||||
pushSubstsWith _ _ (Nat loc) =
|
||||
nclo $ Nat loc
|
||||
pushSubstsWith _ _ (Zero loc) =
|
||||
nclo $ Zero loc
|
||||
pushSubstsWith th ph (Succ n loc) =
|
||||
nclo $ Succ (n // th // ph) loc
|
||||
pushSubstsWith th ph (BOX pi ty loc) =
|
||||
nclo $ BOX pi (ty // th // ph) loc
|
||||
pushSubstsWith th ph (Box val loc) =
|
||||
nclo $ Box (val // th // ph) loc
|
||||
pushSubstsWith th ph (E e) =
|
||||
let Element e nc = pushSubstsWith th ph e in nclo $ E e
|
||||
pushSubstsWith th ph (CloT (Sub s ps)) =
|
||||
pushSubstsWith th (comp th ps ph) s
|
||||
pushSubstsWith th ph (DCloT (Sub s ps)) =
|
||||
pushSubstsWith (ps . th) ph s
|
||||
|
||||
export
|
||||
PushSubsts Elim Subst.isCloE where
|
||||
export
|
||||
PushSubsts Elim Subst.isCloE where
|
||||
pushSubstsWith th ph (F x u loc) =
|
||||
nclo $ F x u loc
|
||||
pushSubstsWith th ph (B i loc) =
|
||||
|
@ -300,6 +280,10 @@ mutual
|
|||
nclo $ App (f // th // ph) (s // th // ph) loc
|
||||
pushSubstsWith th ph (CasePair pi p r b loc) =
|
||||
nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
|
||||
pushSubstsWith th ph (Fst pair loc) =
|
||||
nclo $ Fst (pair // th // ph) loc
|
||||
pushSubstsWith th ph (Snd pair loc) =
|
||||
nclo $ Snd (pair // th // ph) loc
|
||||
pushSubstsWith th ph (CaseEnum pi t r arms loc) =
|
||||
nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
|
||||
(map (\b => b // th // ph) arms) loc
|
||||
|
@ -326,16 +310,61 @@ mutual
|
|||
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
|
||||
|
||||
private %inline
|
||||
CompHY : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
|
||||
||| 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
|
||||
CompHY {ty, p, q, val, r, zero, one, loc} =
|
||||
let ty' = SY ty.names $ ty.term // (B VZ ty.loc ::: shift 2) in
|
||||
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,
|
||||
-- [fixme] better locations for these vars?
|
||||
zero = SY zero.names $ E $
|
||||
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
|
||||
one = SY one.names $ E $
|
||||
|
@ -343,33 +372,13 @@ CompHY {ty, p, q, val, r, zero, one, loc} =
|
|||
loc
|
||||
}
|
||||
|
||||
public export %inline
|
||||
CompH' : (ty : DScopeTerm d n) ->
|
||||
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
|
||||
(zero : DScopeTerm d n) ->
|
||||
(one : DScopeTerm d n) ->
|
||||
(loc : Loc) ->
|
||||
Elim d n
|
||||
CompH' {ty, p, q, val, r, zero, one, loc} =
|
||||
case dsqueeze ty of
|
||||
S _ (N ty) => Comp {ty, p, q, val, r, zero, one, loc}
|
||||
S _ (Y _) => CompHY {ty, p, q, val, r, zero, one, loc}
|
||||
|
||||
||| heterogeneous composition, using Comp and Coe (and subst)
|
||||
|||
|
||||
||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ }
|
||||
||| ≔
|
||||
||| comp [A‹q/i›] @p @q (coe [i ⇒ A] @p @q s) @r {
|
||||
||| 0 j ⇒ coe [i ⇒ A] @j @q t₀;
|
||||
||| 1 j ⇒ coe [i ⇒ A] @j @q t₁
|
||||
||| }
|
||||
||| 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
|
||||
(loc : Loc) -> Elim d n
|
||||
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
|
||||
CompH' {ty = SY [< i] ty, p, q, val, r,
|
||||
zero = SY [< j0] zero, one = SY [< j0] one, loc}
|
||||
zero = SY [< j0] zero, one = SY [< j1] one, loc}
|
||||
|
|
|
@ -1,334 +0,0 @@
|
|||
module Quox.Syntax.Term.Tighten
|
||||
|
||||
import Quox.Syntax.Term.Base
|
||||
import Quox.Syntax.Subst
|
||||
import public Quox.OPE
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
export
|
||||
Tighten (Shift f) where
|
||||
-- `OPE m n` is a spicy `m ≤ n`,
|
||||
-- and `Shift f n` is a (different) spicy `f ≤ n`
|
||||
-- so the value is `f ≤ m` (as a `Shift`), if that is the case
|
||||
tighten _ SZ = Nothing
|
||||
tighten Id by = Just by
|
||||
tighten (Drop p) (SS by) = tighten p by
|
||||
tighten (Keep p) (SS by) = [|SS $ tighten p by|]
|
||||
|
||||
|
||||
export
|
||||
Tighten Dim where
|
||||
tighten p (K e loc) = pure $ K e loc
|
||||
tighten p (B i loc) = B <$> tighten p i <*> pure loc
|
||||
|
||||
|
||||
export
|
||||
tightenSub : (forall m, n. OPE m n -> env n -> Maybe (env m)) ->
|
||||
OPE t1 t2 -> Subst env f t2 -> Maybe (Subst env f t1)
|
||||
tightenSub f p (Shift by) = [|Shift $ tighten p by|]
|
||||
tightenSub f p (t ::: th) = [|f p t !::: tightenSub f p th|]
|
||||
|
||||
export
|
||||
Tighten env => Tighten (Subst env f) where
|
||||
tighten p th = tightenSub tighten p th
|
||||
|
||||
|
||||
export
|
||||
tightenScope : (forall m, n. OPE m n -> f n -> Maybe (f m)) ->
|
||||
{s : Nat} -> OPE m n -> Scoped s f n -> Maybe (Scoped s f m)
|
||||
tightenScope f p (S names (Y body)) = SY names <$> f (keepN s p) body
|
||||
tightenScope f p (S names (N body)) = S names . N <$> f p body
|
||||
|
||||
export
|
||||
tightenDScope : {0 f : Nat -> Nat -> Type} ->
|
||||
(forall m, n, k. OPE m n -> f n k -> Maybe (f m k)) ->
|
||||
OPE m n -> Scoped s (f n) k -> Maybe (Scoped s (f m) k)
|
||||
tightenDScope f p (S names (Y body)) = SY names <$> f p body
|
||||
tightenDScope f p (S names (N body)) = S names . N <$> f p body
|
||||
|
||||
|
||||
mutual
|
||||
private
|
||||
tightenT : OPE n1 n2 -> Term d n2 -> Maybe (Term d n1)
|
||||
tightenT p (TYPE l loc) = pure $ TYPE l loc
|
||||
tightenT p (Pi qty arg res loc) =
|
||||
Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc
|
||||
tightenT p (Lam body loc) =
|
||||
Lam <$> tightenS p body <*> pure loc
|
||||
tightenT p (Sig fst snd loc) =
|
||||
Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc
|
||||
tightenT p (Pair fst snd loc) =
|
||||
Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc
|
||||
tightenT p (Enum cases loc) =
|
||||
pure $ Enum cases loc
|
||||
tightenT p (Tag tag loc) =
|
||||
pure $ Tag tag loc
|
||||
tightenT p (Eq ty l r loc) =
|
||||
Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc
|
||||
tightenT p (DLam body loc) =
|
||||
DLam <$> tightenDS p body <*> pure loc
|
||||
tightenT p (Nat loc) =
|
||||
pure $ Nat loc
|
||||
tightenT p (Zero loc) =
|
||||
pure $ Zero loc
|
||||
tightenT p (Succ s loc) =
|
||||
Succ <$> tightenT p s <*> pure loc
|
||||
tightenT p (BOX qty ty loc) =
|
||||
BOX qty <$> tightenT p ty <*> pure loc
|
||||
tightenT p (Box val loc) =
|
||||
Box <$> tightenT p val <*> pure loc
|
||||
tightenT p (E e) =
|
||||
assert_total $ E <$> tightenE p e
|
||||
tightenT p (CloT (Sub tm th)) = do
|
||||
th <- assert_total $ tightenSub tightenE p th
|
||||
pure $ CloT $ Sub tm th
|
||||
tightenT p (DCloT (Sub tm th)) = do
|
||||
tm <- tightenT p tm
|
||||
pure $ DCloT $ Sub tm th
|
||||
|
||||
private
|
||||
tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
|
||||
tightenE p (F x u loc) =
|
||||
pure $ F x u loc
|
||||
tightenE p (B i loc) =
|
||||
B <$> tighten p i <*> pure loc
|
||||
tightenE p (App fun arg loc) =
|
||||
App <$> tightenE p fun <*> tightenT p arg <*> pure loc
|
||||
tightenE p (CasePair qty pair ret body loc) =
|
||||
CasePair qty <$> tightenE p pair
|
||||
<*> tightenS p ret
|
||||
<*> tightenS p body
|
||||
<*> pure loc
|
||||
tightenE p (CaseEnum qty tag ret arms loc) =
|
||||
CaseEnum qty <$> tightenE p tag
|
||||
<*> tightenS p ret
|
||||
<*> traverse (tightenT p) arms
|
||||
<*> pure loc
|
||||
tightenE p (CaseNat qty qtyIH nat ret zero succ loc) =
|
||||
CaseNat qty qtyIH
|
||||
<$> tightenE p nat
|
||||
<*> tightenS p ret
|
||||
<*> tightenT p zero
|
||||
<*> tightenS p succ
|
||||
<*> pure loc
|
||||
tightenE p (CaseBox qty box ret body loc) =
|
||||
CaseBox qty <$> tightenE p box
|
||||
<*> tightenS p ret
|
||||
<*> tightenS p body
|
||||
<*> pure loc
|
||||
tightenE p (DApp fun arg loc) =
|
||||
DApp <$> tightenE p fun <*> pure arg <*> pure loc
|
||||
tightenE p (Ann tm ty loc) =
|
||||
Ann <$> tightenT p tm <*> tightenT p ty <*> pure loc
|
||||
tightenE p (Coe ty q0 q1 val loc) =
|
||||
Coe <$> tightenDS p ty
|
||||
<*> pure q0 <*> pure q1
|
||||
<*> tightenT p val
|
||||
<*> pure loc
|
||||
tightenE p (Comp ty q0 q1 val r zero one loc) =
|
||||
Comp <$> tightenT p ty
|
||||
<*> pure q0 <*> pure q1
|
||||
<*> tightenT p val
|
||||
<*> pure r
|
||||
<*> tightenDS p zero
|
||||
<*> tightenDS p one
|
||||
<*> pure loc
|
||||
tightenE p (TypeCase ty ret arms def loc) =
|
||||
TypeCase <$> tightenE p ty
|
||||
<*> tightenT p ret
|
||||
<*> traverse (tightenS p) arms
|
||||
<*> tightenT p def
|
||||
<*> pure loc
|
||||
tightenE p (CloE (Sub el th)) = do
|
||||
th <- assert_total $ tightenSub tightenE p th
|
||||
pure $ CloE $ Sub el th
|
||||
tightenE p (DCloE (Sub el th)) = do
|
||||
el <- tightenE p el
|
||||
pure $ DCloE $ Sub el th
|
||||
|
||||
export
|
||||
tightenS : {s : Nat} -> OPE m n ->
|
||||
ScopeTermN s f n -> Maybe (ScopeTermN s f m)
|
||||
tightenS = assert_total $ tightenScope tightenT
|
||||
|
||||
export
|
||||
tightenDS : OPE m n -> DScopeTermN s f n -> Maybe (DScopeTermN s f m)
|
||||
tightenDS = assert_total $ tightenDScope tightenT {f = \n, d => Term d n}
|
||||
|
||||
export Tighten (Elim d) where tighten p e = tightenE p e
|
||||
export Tighten (Term d) where tighten p t = tightenT p t
|
||||
|
||||
|
||||
mutual
|
||||
export
|
||||
dtightenT : OPE d1 d2 -> Term d2 n -> Maybe (Term d1 n)
|
||||
dtightenT p (TYPE l loc) =
|
||||
pure $ TYPE l loc
|
||||
dtightenT p (Pi qty arg res loc) =
|
||||
Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc
|
||||
dtightenT p (Lam body loc) =
|
||||
Lam <$> dtightenS p body <*> pure loc
|
||||
dtightenT p (Sig fst snd loc) =
|
||||
Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc
|
||||
dtightenT p (Pair fst snd loc) =
|
||||
Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc
|
||||
dtightenT p (Enum cases loc) =
|
||||
pure $ Enum cases loc
|
||||
dtightenT p (Tag tag loc) =
|
||||
pure $ Tag tag loc
|
||||
dtightenT p (Eq ty l r loc) =
|
||||
Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc
|
||||
dtightenT p (DLam body loc) =
|
||||
DLam <$> dtightenDS p body <*> pure loc
|
||||
dtightenT p (Nat loc) =
|
||||
pure $ Nat loc
|
||||
dtightenT p (Zero loc) =
|
||||
pure $ Zero loc
|
||||
dtightenT p (Succ s loc) =
|
||||
Succ <$> dtightenT p s <*> pure loc
|
||||
dtightenT p (BOX qty ty loc) =
|
||||
BOX qty <$> dtightenT p ty <*> pure loc
|
||||
dtightenT p (Box val loc) =
|
||||
Box <$> dtightenT p val <*> pure loc
|
||||
dtightenT p (E e) =
|
||||
assert_total $ E <$> dtightenE p e
|
||||
dtightenT p (CloT (Sub tm th)) = do
|
||||
tm <- dtightenT p tm
|
||||
th <- assert_total $ traverse (dtightenE p) th
|
||||
pure $ CloT $ Sub tm th
|
||||
dtightenT p (DCloT (Sub tm th)) = do
|
||||
th <- tighten p th
|
||||
pure $ DCloT $ Sub tm th
|
||||
|
||||
export
|
||||
dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
|
||||
dtightenE p (F x u loc) =
|
||||
pure $ F x u loc
|
||||
dtightenE p (B i loc) =
|
||||
pure $ B i loc
|
||||
dtightenE p (App fun arg loc) =
|
||||
App <$> dtightenE p fun <*> dtightenT p arg <*> pure loc
|
||||
dtightenE p (CasePair qty pair ret body loc) =
|
||||
CasePair qty <$> dtightenE p pair
|
||||
<*> dtightenS p ret
|
||||
<*> dtightenS p body
|
||||
<*> pure loc
|
||||
dtightenE p (CaseEnum qty tag ret arms loc) =
|
||||
CaseEnum qty <$> dtightenE p tag
|
||||
<*> dtightenS p ret
|
||||
<*> traverse (dtightenT p) arms
|
||||
<*> pure loc
|
||||
dtightenE p (CaseNat qty qtyIH nat ret zero succ loc) =
|
||||
CaseNat qty qtyIH
|
||||
<$> dtightenE p nat
|
||||
<*> dtightenS p ret
|
||||
<*> dtightenT p zero
|
||||
<*> dtightenS p succ
|
||||
<*> pure loc
|
||||
dtightenE p (CaseBox qty box ret body loc) =
|
||||
CaseBox qty <$> dtightenE p box
|
||||
<*> dtightenS p ret
|
||||
<*> dtightenS p body
|
||||
<*> pure loc
|
||||
dtightenE p (DApp fun arg loc) =
|
||||
DApp <$> dtightenE p fun <*> tighten p arg <*> pure loc
|
||||
dtightenE p (Ann tm ty loc) =
|
||||
Ann <$> dtightenT p tm <*> dtightenT p ty <*> pure loc
|
||||
dtightenE p (Coe ty q0 q1 val loc) =
|
||||
[|Coe (dtightenDS p ty) (tighten p q0) (tighten p q1) (dtightenT p val)
|
||||
(pure loc)|]
|
||||
dtightenE p (Comp ty q0 q1 val r zero one loc) =
|
||||
[|Comp (dtightenT p ty) (tighten p q0) (tighten p q1)
|
||||
(dtightenT p val) (tighten p r)
|
||||
(dtightenDS p zero) (dtightenDS p one) (pure loc)|]
|
||||
dtightenE p (TypeCase ty ret arms def loc) =
|
||||
[|TypeCase (dtightenE p ty) (dtightenT p ret)
|
||||
(traverse (dtightenS p) arms) (dtightenT p def) (pure loc)|]
|
||||
dtightenE p (CloE (Sub el th)) = do
|
||||
el <- dtightenE p el
|
||||
th <- assert_total $ traverse (dtightenE p) th
|
||||
pure $ CloE $ Sub el th
|
||||
dtightenE p (DCloE (Sub el th)) = do
|
||||
th <- tighten p th
|
||||
pure $ DCloE $ Sub el th
|
||||
|
||||
export
|
||||
dtightenS : OPE d1 d2 -> ScopeTermN s d2 n -> Maybe (ScopeTermN s d1 n)
|
||||
dtightenS = assert_total $ tightenDScope dtightenT {f = Term}
|
||||
|
||||
export
|
||||
dtightenDS : {s : Nat} -> OPE d1 d2 ->
|
||||
DScopeTermN s d2 n -> Maybe (DScopeTermN s d1 n)
|
||||
dtightenDS = assert_total $ tightenScope dtightenT
|
||||
|
||||
|
||||
export [TermD] Tighten (\d => Term d n) where tighten p t = dtightenT p t
|
||||
export [ElimD] Tighten (\d => Elim d n) where tighten p e = dtightenE p e
|
||||
|
||||
|
||||
-- versions of SY, etc, that try to tighten and use SN automatically
|
||||
|
||||
public export
|
||||
ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n
|
||||
ST names body =
|
||||
case tightenN s body of
|
||||
Just body => S names $ N body
|
||||
Nothing => S names $ Y body
|
||||
|
||||
public export
|
||||
DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n
|
||||
DST names body =
|
||||
case tightenN @{TermD} s body of
|
||||
Just body => S names $ N body
|
||||
Nothing => S names $ Y body
|
||||
|
||||
public export %inline
|
||||
PiT : (qty : Qty) -> (x : BindName) ->
|
||||
(arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
PiT {qty, x, arg, res, loc} = Pi {qty, arg, res = ST [< x] res, loc}
|
||||
|
||||
public export %inline
|
||||
LamT : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
LamT {x, body, loc} = Lam {body = ST [< x] body, loc}
|
||||
|
||||
public export %inline
|
||||
SigT : (x : BindName) -> (fst : Term d n) ->
|
||||
(snd : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
SigT {x, fst, snd, loc} = Sig {fst, snd = ST [< x] snd, loc}
|
||||
|
||||
public export %inline
|
||||
EqT : (i : BindName) -> (ty : Term (S d) n) ->
|
||||
(l, r : Term d n) -> (loc : Loc) -> Term d n
|
||||
EqT {i, ty, l, r, loc} = Eq {ty = DST [< i] ty, l, r, loc}
|
||||
|
||||
public export %inline
|
||||
DLamT : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
|
||||
DLamT {i, body, loc} = DLam {body = DST [< i] body, loc}
|
||||
|
||||
public export %inline
|
||||
CoeT : (i : BindName) -> (ty : Term (S d) n) ->
|
||||
(p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
|
||||
CoeT {i, ty, p, q, val, loc} = Coe {ty = DST [< i] ty, p, q, val, loc}
|
||||
|
||||
public export %inline
|
||||
typeCase1T : Elim d n -> Term d n ->
|
||||
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
|
||||
(loc : Loc) ->
|
||||
{default (Nat loc) def : Term d n} ->
|
||||
Elim d n
|
||||
typeCase1T ty ret k ns body loc {def} =
|
||||
typeCase ty ret [(k ** ST ns body)] def loc
|
||||
|
||||
|
||||
export
|
||||
squeeze : {s : Nat} -> ScopeTermN s d n -> ScopeTermN s d n
|
||||
squeeze (S names (Y body)) = S names $ maybe (Y body) N $ tightenN s body
|
||||
squeeze (S names (N body)) = S names $ N body
|
||||
|
||||
export
|
||||
dsqueeze : {s : Nat} -> DScopeTermN s d n -> DScopeTermN s d n
|
||||
dsqueeze (S names (Y body)) =
|
||||
S names $ maybe (Y body) N $ tightenN s body @{TermD}
|
||||
dsqueeze (S names (N body)) = S names $ N body
|
|
@ -9,7 +9,8 @@ import Generics.Derive
|
|||
|
||||
|
||||
public export
|
||||
data TyConKind = KTYPE | KPi | KSig | KEnum | KEq | KNat | KBOX
|
||||
data TyConKind =
|
||||
KTYPE | KIOState | KPi | KSig | KEnum | KEq | KNat | KString | KBOX
|
||||
%name TyConKind k
|
||||
%runElab derive "TyConKind" [Eq.Eq, Ord.Ord, Show.Show, Generic, Meta, DecEq]
|
||||
|
||||
|
@ -26,9 +27,11 @@ 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
|
||||
|
|
|
@ -3,6 +3,7 @@ module Quox.Typechecker
|
|||
import public Quox.Typing
|
||||
import public Quox.Equal
|
||||
import Quox.Displace
|
||||
import Quox.Pretty
|
||||
|
||||
import Data.List
|
||||
import Data.SnocVect
|
||||
|
@ -13,25 +14,14 @@ import Quox.EffExtra
|
|||
|
||||
|
||||
public export
|
||||
0 TCEff : List (Type -> Type)
|
||||
TCEff = [ErrorEff, DefsReader, NameGen]
|
||||
|
||||
public export
|
||||
0 TC : Type -> Type
|
||||
TC = Eff TCEff
|
||||
|
||||
export
|
||||
runTCWith : NameSuf -> Definitions -> TC a -> (Either Error a, NameSuf)
|
||||
runTCWith = runEqualWith
|
||||
|
||||
export
|
||||
runTC : Definitions -> TC a -> Either Error a
|
||||
runTC = runEqual
|
||||
0 TC : List (Type -> Type)
|
||||
TC = [ErrorEff, DefsReader, NameGen, Log]
|
||||
|
||||
|
||||
parameters (loc : Loc)
|
||||
export
|
||||
popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) -> Eff fs (QOutput n)
|
||||
popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) ->
|
||||
Eff fs (QOutput n)
|
||||
popQs [<] qout = pure qout
|
||||
popQs (pis :< pi) (qout :< rh) = do expectCompatQ loc rh pi; popQs pis qout
|
||||
|
||||
|
@ -52,34 +42,24 @@ lubs ctx [] = zeroFor ctx
|
|||
lubs ctx (x :: xs) = lubs1 $ x ::: xs
|
||||
|
||||
|
||||
export
|
||||
typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe ->
|
||||
CtxExtension d n (arity k + n)
|
||||
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
|
||||
prettyTermTC : {opts : LayoutOpts} ->
|
||||
TyContext d n -> Term d n -> Eff Pretty (Doc opts)
|
||||
prettyTermTC ctx s = prettyTerm ctx.dnames ctx.tnames s
|
||||
|
||||
|
||||
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 ⊳ Σ"
|
||||
|||
|
||||
|
@ -91,28 +71,32 @@ mutual
|
|||
||| doing any further work.
|
||||
export covering %inline
|
||||
check : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
||||
TC (CheckResult ctx.dctx n)
|
||||
check ctx sg subj ty = ifConsistent ctx.dctx $ checkC ctx sg subj ty
|
||||
Eff TC (CheckResult ctx.dctx n)
|
||||
check 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"
|
||||
|||
|
||||
||| `check0 ctx subj ty` checks a term (as `check`) in a zero context.
|
||||
export covering %inline
|
||||
check0 : TyContext d n -> Term d n -> Term d n -> TC ()
|
||||
check0 ctx tm ty = ignore $ check ctx szero tm ty
|
||||
check0 : TyContext d n -> Term d n -> Term d n -> Eff TC ()
|
||||
check0 ctx tm ty = ignore $ check ctx SZero tm ty
|
||||
-- the output will always be 𝟎 because the subject quantity is 0
|
||||
|
||||
||| `check`, assuming the dimension context is consistent
|
||||
export covering %inline
|
||||
checkC : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
||||
TC (CheckResult' n)
|
||||
Eff TC (CheckResult' n)
|
||||
checkC ctx sg subj ty =
|
||||
wrapErr (WhileChecking ctx sg.fst subj ty) $
|
||||
wrapErr (WhileChecking ctx sg subj ty) $
|
||||
checkCNoWrap ctx sg subj ty
|
||||
|
||||
export covering %inline
|
||||
checkCNoWrap : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
||||
TC (CheckResult' n)
|
||||
Eff TC (CheckResult' n)
|
||||
checkCNoWrap ctx sg subj ty =
|
||||
let Element subj nc = pushSubsts subj in
|
||||
check' ctx sg subj ty
|
||||
|
@ -122,16 +106,21 @@ mutual
|
|||
||| `checkType ctx subj ty` checks a type (in a zero context). sometimes the
|
||||
||| 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 -> TC ()
|
||||
checkType ctx subj l = ignore $ ifConsistent ctx.dctx $ checkTypeC ctx subj l
|
||||
checkType : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
|
||||
checkType ctx subj l = do
|
||||
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 -> TC ()
|
||||
checkTypeC : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
|
||||
checkTypeC ctx subj l =
|
||||
wrapErr (WhileCheckingTy ctx subj l) $ checkTypeNoWrap ctx subj l
|
||||
|
||||
export covering %inline
|
||||
checkTypeNoWrap : TyContext d n -> Term d n -> Maybe Universe -> TC ()
|
||||
checkTypeNoWrap : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
|
||||
checkTypeNoWrap ctx subj l =
|
||||
let Element subj nc = pushSubsts subj in
|
||||
checkType' ctx subj l
|
||||
|
@ -145,15 +134,19 @@ mutual
|
|||
||| doing any further work.
|
||||
export covering %inline
|
||||
infer : (ctx : TyContext d n) -> SQty -> Elim d n ->
|
||||
TC (InferResult ctx.dctx d n)
|
||||
infer ctx sg subj = ifConsistent ctx.dctx $ inferC ctx sg subj
|
||||
Eff TC (InferResult ctx.dctx d n)
|
||||
infer ctx sg subj = do
|
||||
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
|
||||
inferC : (ctx : TyContext d n) -> SQty -> Elim d n ->
|
||||
TC (InferResult' d n)
|
||||
Eff TC (InferResult' d n)
|
||||
inferC ctx sg subj =
|
||||
wrapErr (WhileInferring ctx sg.fst subj) $
|
||||
wrapErr (WhileInferring ctx sg subj) $
|
||||
let Element subj nc = pushSubsts subj in
|
||||
infer' ctx sg subj
|
||||
|
||||
|
@ -161,27 +154,29 @@ mutual
|
|||
private covering
|
||||
toCheckType : TyContext d n -> SQty ->
|
||||
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
|
||||
TC (CheckResult' n)
|
||||
Eff TC (CheckResult' n)
|
||||
toCheckType ctx sg t ty = do
|
||||
u <- expectTYPE !(askAt DEFS) ctx ty.loc ty
|
||||
expectEqualQ t.loc Zero sg.fst
|
||||
u <- expectTYPE !(askAt DEFS) ctx sg ty.loc ty
|
||||
expectEqualQ t.loc Zero sg.qty
|
||||
checkTypeNoWrap ctx t (Just u)
|
||||
pure $ zeroFor ctx
|
||||
|
||||
private covering
|
||||
check' : TyContext d n -> SQty ->
|
||||
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
|
||||
TC (CheckResult' n)
|
||||
Eff TC (CheckResult' n)
|
||||
|
||||
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
|
||||
(qty, arg, res) <- expectPi !(askAt DEFS) ctx ty.loc ty
|
||||
(qty, arg, res) <- expectPi !(askAt DEFS) ctx SZero ty.loc ty
|
||||
-- if Ψ | Γ, x : A ⊢ σ · t ⇐ B ⊳ Σ, ρ·x
|
||||
-- with ρ ≤ σπ
|
||||
let qty' = sg.fst * qty
|
||||
let qty' = sg.qty * qty
|
||||
qout <- checkC (extendTy qty' body.name arg ctx) sg body.term res.term
|
||||
-- then Ψ | Γ ⊢ σ · (λx ⇒ t) ⇐ (π·x : A) → B ⊳ Σ
|
||||
popQ loc qty' qout
|
||||
|
@ -189,7 +184,7 @@ mutual
|
|||
check' ctx sg t@(Sig {}) ty = toCheckType ctx sg t ty
|
||||
|
||||
check' ctx sg (Pair fst snd loc) ty = do
|
||||
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx ty.loc ty
|
||||
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx SZero ty.loc ty
|
||||
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ₁
|
||||
qfst <- checkC ctx sg fst tfst
|
||||
let tsnd = sub1 tsnd (Ann fst tfst fst.loc)
|
||||
|
@ -201,7 +196,7 @@ mutual
|
|||
check' ctx sg t@(Enum {}) ty = toCheckType ctx sg t ty
|
||||
|
||||
check' ctx sg (Tag t loc) ty = do
|
||||
tags <- expectEnum !(askAt DEFS) ctx ty.loc ty
|
||||
tags <- expectEnum !(askAt DEFS) ctx SZero ty.loc ty
|
||||
-- if t ∈ ts
|
||||
unless (t `elem` tags) $ throw $ TagNotIn loc t tags
|
||||
-- then Ψ | Γ ⊢ σ · t ⇐ {ts} ⊳ 𝟎
|
||||
|
@ -210,38 +205,54 @@ mutual
|
|||
check' ctx sg t@(Eq {}) ty = toCheckType ctx sg t ty
|
||||
|
||||
check' ctx sg (DLam body loc) ty = do
|
||||
(ty, l, r) <- expectEq !(askAt DEFS) ctx ty.loc ty
|
||||
(ty, l, r) <- expectEq !(askAt DEFS) ctx SZero ty.loc ty
|
||||
let ctx' = extendDim body.name ctx
|
||||
ty = ty.term
|
||||
body = body.term
|
||||
-- if Ψ, i | Γ ⊢ σ · t ⇐ A ⊳ Σ
|
||||
qout <- checkC ctx' sg body ty
|
||||
-- if Ψ, i, i = 0 | Γ ⊢ t = l : A
|
||||
lift $ equal loc (eqDim (B VZ loc) (K Zero loc) ctx') ty body (dweakT 1 l)
|
||||
let ctx0 = eqDim (B VZ loc) (K Zero loc) ctx'
|
||||
lift $ equal loc ctx0 sg ty body $ dweakT 1 l
|
||||
-- if Ψ, i, i = 1 | Γ ⊢ t = r : A
|
||||
lift $ equal loc (eqDim (B VZ loc) (K One loc) ctx') ty body (dweakT 1 r)
|
||||
let ctx1 = eqDim (B VZ loc) (K One loc) ctx'
|
||||
lift $ equal loc ctx1 sg ty body $ dweakT 1 r
|
||||
-- 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 (Zero {}) ty = do
|
||||
expectNat !(askAt DEFS) ctx ty.loc ty
|
||||
check' ctx sg (Nat {}) ty = do
|
||||
expectNAT !(askAt DEFS) ctx SZero ty.loc ty
|
||||
pure $ zeroFor ctx
|
||||
|
||||
check' ctx sg (Succ n {}) ty = do
|
||||
expectNat !(askAt DEFS) ctx 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 ty.loc ty
|
||||
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
|
||||
valout <- checkC ctx sg val ty
|
||||
(q, ty) <- expectBOX !(askAt DEFS) ctx SZero ty.loc ty
|
||||
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ
|
||||
valout <- checkC ctx (subjMult sg q) 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
|
||||
|
@ -253,7 +264,7 @@ mutual
|
|||
private covering
|
||||
checkType' : TyContext d n ->
|
||||
(subj : Term d n) -> (0 nc : NotClo subj) =>
|
||||
Maybe Universe -> TC ()
|
||||
Maybe Universe -> Eff TC ()
|
||||
|
||||
checkType' ctx (TYPE k loc) u = do
|
||||
-- if 𝓀 < ℓ then Ψ | Γ ⊢₀ Type 𝓀 ⇐ Type ℓ
|
||||
|
@ -261,6 +272,9 @@ 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
|
||||
|
@ -301,26 +315,35 @@ mutual
|
|||
checkType' ctx t@(DLam {}) u =
|
||||
throw $ NotType t.loc ctx t
|
||||
|
||||
checkType' ctx (Nat {}) u = pure ()
|
||||
checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t
|
||||
checkType' ctx (NAT {}) u = pure ()
|
||||
checkType' ctx t@(Nat {}) 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
|
||||
infres <- inferC ctx SZero e
|
||||
-- if Ψ | Γ ⊢ Type ℓ <: Type 𝓀
|
||||
case u of
|
||||
Just u => lift $ subtype e.loc ctx infres.type (TYPE u noLoc)
|
||||
Nothing => ignore $ expectTYPE !(askAt DEFS) ctx e.loc infres.type
|
||||
Just u => lift $ subtype e.loc ctx infres.type (TYPE u e.loc)
|
||||
Nothing => ignore $ expectTYPE !(askAt DEFS) ctx SZero e.loc infres.type
|
||||
-- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀
|
||||
|
||||
|
||||
private covering
|
||||
checkTypeScope : TyContext d n -> Term d n ->
|
||||
ScopeTerm d n -> Maybe Universe -> TC ()
|
||||
ScopeTerm d n -> Maybe Universe -> Eff TC ()
|
||||
checkTypeScope ctx s (S _ (N body)) u = checkType ctx body u
|
||||
checkTypeScope ctx s (S [< x] (Y body)) u =
|
||||
checkType (extendTy Zero x s ctx) body u
|
||||
|
@ -329,25 +352,27 @@ mutual
|
|||
private covering
|
||||
infer' : TyContext d n -> SQty ->
|
||||
(subj : Elim d n) -> (0 nc : NotClo subj) =>
|
||||
TC (InferResult' d n)
|
||||
Eff TC (InferResult' d n)
|
||||
|
||||
infer' ctx sg (F x u loc) = do
|
||||
-- if π·x : A {≔ s} in global context
|
||||
g <- lookupFree x loc !(askAt DEFS)
|
||||
-- if σ ≤ π
|
||||
expectCompatQ loc sg.fst g.qty.fst
|
||||
expectCompatQ loc sg.qty g.qty.qty
|
||||
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
|
||||
let Val d = ctx.dimLen; Val n = ctx.termLen
|
||||
pure $ InfRes {type = displace u g.type, qout = zeroFor ctx}
|
||||
pure $ InfRes {
|
||||
type = g.typeWithAt ctx.dimLen ctx.termLen u,
|
||||
qout = zeroFor ctx
|
||||
}
|
||||
|
||||
infer' ctx sg (B i _) =
|
||||
-- if x : A ∈ Γ
|
||||
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ (𝟎, σ·x, 𝟎)
|
||||
pure $ lookupBound sg.fst i ctx.tctx
|
||||
pure $ lookupBound sg.qty i ctx.tctx
|
||||
where
|
||||
lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n
|
||||
lookupBound pi VZ (ctx :< type) =
|
||||
InfRes {type = weakT 1 type, qout = zeroFor ctx :< pi}
|
||||
lookupBound pi VZ (ctx :< var) =
|
||||
InfRes {type = weakT 1 var.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}
|
||||
|
@ -355,7 +380,7 @@ mutual
|
|||
infer' ctx sg (App fun arg loc) = do
|
||||
-- if Ψ | Γ ⊢ σ · f ⇒ (π·x : A) → B ⊳ Σ₁
|
||||
funres <- inferC ctx sg fun
|
||||
(qty, argty, res) <- expectPi !(askAt DEFS) ctx fun.loc funres.type
|
||||
(qty, argty, res) <- expectPi !(askAt DEFS) ctx SZero fun.loc funres.type
|
||||
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ₂
|
||||
argout <- checkC ctx (subjMult sg qty) arg argty
|
||||
-- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + πΣ₂
|
||||
|
@ -372,12 +397,12 @@ mutual
|
|||
pairres <- inferC ctx sg pair
|
||||
-- if Ψ | Γ, p : (x : A) × B ⊢₀ ret ⇐ Type
|
||||
checkTypeC (extendTy Zero ret.name pairres.type ctx) ret.term Nothing
|
||||
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx pair.loc pairres.type
|
||||
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
|
||||
-- if Ψ | Γ, x : A, y : B ⊢ σ · body ⇐
|
||||
-- ret[(x, y) ∷ (x : A) × B/p] ⊳ Σ₂, ρ₁·x, ρ₂·y
|
||||
-- with ρ₁, ρ₂ ≤ πσ
|
||||
let [< x, y] = body.names
|
||||
pisg = pi * sg.fst
|
||||
pisg = pi * sg.qty
|
||||
bodyctx = extendTyN [< (pisg, x, tfst), (pisg, y, tsnd.term)] ctx
|
||||
bodyty = substCasePairRet body.names pairres.type ret
|
||||
bodyout <- checkC bodyctx sg body.term bodyty >>=
|
||||
|
@ -388,10 +413,30 @@ mutual
|
|||
qout = pi * pairres.qout + bodyout
|
||||
}
|
||||
|
||||
infer' ctx sg (Fst pair loc) = do
|
||||
-- if Ψ | Γ ⊢ σ · e ⇒ (x : A) × B ⊳ Σ
|
||||
pairres <- inferC ctx sg pair
|
||||
(tfst, _) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
|
||||
-- then Ψ | Γ ⊢ σ · fst e ⇒ A ⊳ ωΣ
|
||||
pure $ InfRes {
|
||||
type = tfst,
|
||||
qout = Any * pairres.qout
|
||||
}
|
||||
|
||||
infer' ctx sg (Snd pair loc) = do
|
||||
-- if Ψ | Γ ⊢ σ · e ⇒ (x : A) × B ⊳ Σ
|
||||
pairres <- inferC ctx sg pair
|
||||
(_, tsnd) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
|
||||
-- then Ψ | Γ ⊢ σ · snd e ⇒ B[fst e/x] ⊳ ωΣ
|
||||
pure $ InfRes {
|
||||
type = sub1 tsnd (Fst pair loc),
|
||||
qout = Any * pairres.qout
|
||||
}
|
||||
|
||||
infer' ctx sg (CaseEnum pi t ret arms loc) {d, n} = do
|
||||
-- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁
|
||||
tres <- inferC ctx sg t
|
||||
ttags <- expectEnum !(askAt DEFS) ctx t.loc tres.type
|
||||
ttags <- expectEnum !(askAt DEFS) ctx SZero t.loc tres.type
|
||||
-- if 1 ≤ π, OR there is only zero or one option
|
||||
unless (length (SortedSet.toList ttags) <= 1) $ expectCompatQ loc One pi
|
||||
-- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type
|
||||
|
@ -415,39 +460,43 @@ mutual
|
|||
-- if Ψ | Γ ⊢ σ · n ⇒ ℕ ⊳ Σn
|
||||
nres <- inferC ctx sg n
|
||||
let nat = nres.type
|
||||
expectNat !(askAt DEFS) ctx 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
|
||||
-- with ρ₂ ≤ π'σ, (ρ₁ + ρ₂) ≤ πσ
|
||||
-- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ.p, ς.ih
|
||||
-- with ς ≤ π'σ, (ρ + ς) ≤ πσ
|
||||
let [< p, ih] = suc.names
|
||||
pisg = pi * sg.fst
|
||||
sucCtx = extendTyN [< (pisg, p, Nat p.loc), (pi', ih, ret.term)] ctx
|
||||
pisg = pi * sg.qty
|
||||
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.fst)
|
||||
expectCompatQ loc qih (pi' * sg.qty)
|
||||
-- [fixme] better error here
|
||||
expectCompatQ loc (qp + qih) pisg
|
||||
-- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σz + ωΣs
|
||||
-- if ς = 0, then Σb = lubs(Σz, Σs), otherwise Σb = Σ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 + zerout + Any * sucout
|
||||
qout = pi * nres.qout + bodyout
|
||||
}
|
||||
|
||||
infer' ctx sg (CaseBox pi box ret body loc) = do
|
||||
-- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁
|
||||
boxres <- inferC ctx sg box
|
||||
(q, ty) <- expectBOX !(askAt DEFS) ctx box.loc boxres.type
|
||||
(rh, 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 qpisg = q * pi * sg.fst
|
||||
bodyCtx = extendTy qpisg body.name ty ctx
|
||||
let rhpisg = rh * pi * sg.qty
|
||||
bodyCtx = extendTy rhpisg body.name ty ctx
|
||||
bodyType = substCaseBoxRet body.name ty ret
|
||||
bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc qpisg
|
||||
bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc rhpisg
|
||||
-- then Ψ | Γ ⊢ caseπ ⋯ ⇒ R[b/x] ⊳ Σ₁ + Σ₂
|
||||
pure $ InfRes {
|
||||
type = sub1 ret box,
|
||||
|
@ -457,42 +506,54 @@ mutual
|
|||
infer' ctx sg (DApp fun dim loc) = do
|
||||
-- if Ψ | Γ ⊢ σ · f ⇒ Eq [𝑖 ⇒ A] l r ⊳ Σ
|
||||
InfRes {type, qout} <- inferC ctx sg fun
|
||||
ty <- fst <$> expectEq !(askAt DEFS) ctx fun.loc type
|
||||
ty <- fst <$> expectEq !(askAt DEFS) ctx SZero fun.loc type
|
||||
-- then Ψ | Γ ⊢ σ · f p ⇒ A‹p/𝑖› ⊳ Σ
|
||||
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 = val0.term
|
||||
val0 = getTerm val0
|
||||
qout0 <- check ctx0 sg val0 ty'
|
||||
lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) ty' val0 val'
|
||||
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 = val1.term
|
||||
val1 = getTerm val1
|
||||
qout1 <- check ctx1 sg val1 ty'
|
||||
lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) ty' val1 val'
|
||||
-- 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
|
||||
-- if σ = 0
|
||||
expectEqualQ loc Zero sg.fst
|
||||
expectEqualQ loc Zero sg.qty
|
||||
-- if Ψ, Γ ⊢₀ e ⇒ Type u
|
||||
u <- expectTYPE !(askAt DEFS) ctx ty.loc . type =<< inferC ctx szero ty
|
||||
u <- inferC ctx SZero ty >>=
|
||||
expectTYPE !(askAt DEFS) ctx SZero ty.loc . type
|
||||
-- if Ψ, Γ ⊢₀ C ⇐ Type (non-dependent return type)
|
||||
checkTypeC ctx ret Nothing
|
||||
-- if Ψ, Γ' ⊢₀ A ⇐ C for each rhs A
|
||||
for_ allKinds $ \k =>
|
||||
for_ (lookupPrecise k arms) $ \(S names t) =>
|
||||
check0 (extendTyN (typecaseTel k names u) ctx)
|
||||
t.term (weakT (arity k) ret)
|
||||
(getTerm t) (weakT (arity k) ret)
|
||||
-- then Ψ, Γ ⊢₀ type-case ⋯ ⇒ C
|
||||
pure $ InfRes {type = ret, qout = zeroFor ctx}
|
||||
|
||||
|
|
|
@ -6,7 +6,8 @@ import public Quox.Typing.Error as Typing
|
|||
|
||||
import public Quox.Syntax
|
||||
import public Quox.Definition
|
||||
import public Quox.Reduce
|
||||
import public Quox.Whnf
|
||||
import public Quox.Pretty
|
||||
|
||||
import Language.Reflection
|
||||
import Control.Eff
|
||||
|
@ -47,15 +48,14 @@ 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 arg = Ann (Succ (BVT 1 p.loc) p.loc) (Nat noLoc) $ p.loc `extendL` ih.loc
|
||||
in
|
||||
let loc = p.loc `extendL` ih.loc
|
||||
arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT p.loc) loc in
|
||||
retty.term // (arg ::: shift 2)
|
||||
|
||||
public export
|
||||
|
@ -65,23 +65,31 @@ substCaseBoxRet x dty retty =
|
|||
retty.term // (arg ::: shift 1)
|
||||
|
||||
|
||||
parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
|
||||
private
|
||||
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) (loc : Loc)
|
||||
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)
|
||||
tm d n -> Eff fs (NonRedex tm d n defs (toWhnfContext ctx) sg)
|
||||
whnf tm = do
|
||||
let Val n = ctx.termLen; Val d = ctx.dimLen
|
||||
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm
|
||||
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
|
||||
rethrow res
|
||||
|
||||
private covering %macro
|
||||
expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
|
||||
TTImp -> TTImp -> Elab (Term d n -> Eff fs a)
|
||||
expect k l r = do
|
||||
f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
|
||||
pure $ \t => maybe (throw $ k loc ctx.names t) pure . f . fst =<< whnf t
|
||||
expect : ExpectErrorConstructor -> TTImp -> TTImp ->
|
||||
Elab (Term d n -> Eff fs a)
|
||||
expect err pat rhs = Prelude.do
|
||||
match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
|
||||
pure $ \term => do
|
||||
res <- whnf term
|
||||
maybe (throw $ err loc ctx.names term) pure $ match $ fst res
|
||||
|
||||
export covering %inline
|
||||
expectTYPE : Term d n -> Eff fs Universe
|
||||
|
@ -104,32 +112,40 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
|
|||
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
|
||||
|
||||
export covering %inline
|
||||
expectNat : Term d n -> Eff fs ()
|
||||
expectNat = expect ExpectedNat `(Nat {}) `(())
|
||||
expectNAT : Term d n -> Eff fs ()
|
||||
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) (loc : Loc)
|
||||
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)
|
||||
tm 0 n -> Eff fs (NonRedex tm 0 n defs (toWhnfContext ctx) sg)
|
||||
whnf tm = do
|
||||
let Val n = ctx.termLen
|
||||
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm
|
||||
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
|
||||
rethrow res
|
||||
|
||||
private covering %macro
|
||||
expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
|
||||
TTImp -> TTImp -> Elab (Term 0 n -> Eff fs a)
|
||||
expect k l r = do
|
||||
f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
|
||||
pure $ \t =>
|
||||
let err = throw $ k loc ctx.names (t // shift0 ctx.dimLen) in
|
||||
maybe err pure . f . fst =<< whnf t
|
||||
expect : ExpectErrorConstructor -> TTImp -> TTImp ->
|
||||
Elab (Term 0 n -> Eff fs a)
|
||||
expect err pat rhs = do
|
||||
match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
|
||||
pure $ \term => do
|
||||
res <- whnf term
|
||||
let t0 = delay $ term // shift0 ctx.dimLen
|
||||
maybe (throw $ err loc ctx.names t0) pure $ match $ fst res
|
||||
|
||||
export covering %inline
|
||||
expectTYPE : Term 0 n -> Eff fs Universe
|
||||
|
@ -152,9 +168,17 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
|
|||
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
|
||||
|
||||
export covering %inline
|
||||
expectNat : Term 0 n -> Eff fs ()
|
||||
expectNat = expect ExpectedNat `(Nat {}) `(())
|
||||
expectNAT : Term 0 n -> Eff fs ()
|
||||
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 {}) `(())
|
||||
|
|
|
@ -4,17 +4,51 @@ import Quox.Syntax
|
|||
import Quox.Context
|
||||
import Quox.Pretty
|
||||
import public Data.Singleton
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
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 (Term d)
|
||||
TContext d = Context (LocalVar d)
|
||||
|
||||
public export
|
||||
QOutput : Nat -> Type
|
||||
|
@ -31,11 +65,12 @@ record TyContext d n where
|
|||
{auto dimLen : Singleton d}
|
||||
{auto termLen : Singleton n}
|
||||
dctx : DimEq d
|
||||
dnames : BContext d
|
||||
dnames : BContext d -- only used for printing
|
||||
tctx : TContext d n
|
||||
tnames : BContext n
|
||||
tnames : BContext n -- only used for printing
|
||||
qtys : QContext n -- only used for printing
|
||||
%name TyContext ctx
|
||||
%runElab deriveIndexed "TyContext" [Show]
|
||||
|
||||
|
||||
public export
|
||||
|
@ -46,29 +81,29 @@ record EqContext n where
|
|||
dassign : DimAssign dimLen -- only used for printing
|
||||
dnames : BContext dimLen -- only used for printing
|
||||
tctx : TContext 0 n
|
||||
tnames : BContext n
|
||||
tnames : BContext n -- only used for printing
|
||||
qtys : QContext n -- only used for printing
|
||||
%name EqContext ctx
|
||||
%runElab deriveIndexed "EqContext" [Show]
|
||||
|
||||
|
||||
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
|
||||
%name WhnfContext ctx
|
||||
%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
|
||||
|
||||
private
|
||||
public export
|
||||
extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
|
||||
extendLen [<] x = x
|
||||
extendLen (tel :< _) x = [|S $ extendLen tel x|]
|
||||
|
@ -78,32 +113,66 @@ public export
|
|||
CtxExtension : Nat -> Nat -> Nat -> Type
|
||||
CtxExtension d = Telescope ((Qty, BindName,) . Term d)
|
||||
|
||||
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 {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
|
||||
empty = 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
|
||||
extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
|
||||
extendTyN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
|
||||
let (qs, xs, ss) = unzip3 xss in
|
||||
extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2
|
||||
extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
|
||||
let (qs, xs, ls) = unzip3 xss in
|
||||
MkTyContext {
|
||||
dctx, dnames,
|
||||
termLen = extendLen xss termLen,
|
||||
tctx = tctx . ss,
|
||||
tctx = tctx . ls,
|
||||
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)]
|
||||
|
||||
export %inline
|
||||
extendTy0 : BindName -> Term d n -> TyContext d n -> TyContext d (S n)
|
||||
extendTy0 = extendTy Zero
|
||||
|
||||
export %inline
|
||||
extendDim : BindName -> TyContext d n -> TyContext (S d) n
|
||||
extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
|
||||
|
@ -111,7 +180,7 @@ namespace TyContext
|
|||
dctx = dctx :<? Nothing,
|
||||
dnames = dnames :< x,
|
||||
dimLen = [|S dimLen|],
|
||||
tctx = pushD tctx,
|
||||
tctx = map weakD tctx,
|
||||
tnames, qtys
|
||||
}
|
||||
|
||||
|
@ -150,7 +219,7 @@ makeEqContext' ctx th = MkEqContext {
|
|||
termLen = ctx.termLen,
|
||||
dassign = makeDAssign th,
|
||||
dnames = ctx.dnames,
|
||||
tctx = map (// th) ctx.tctx,
|
||||
tctx = map (subD th) ctx.tctx,
|
||||
tnames = ctx.tnames,
|
||||
qtys = ctx.qtys
|
||||
}
|
||||
|
@ -158,7 +227,7 @@ makeEqContext' ctx th = MkEqContext {
|
|||
export
|
||||
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
|
||||
makeEqContext ctx@(MkTyContext {dnames, _}) th =
|
||||
let (d' ** Refl) = lengthPrf0 dnames in makeEqContext' ctx th
|
||||
let Val d = lengthPrf0 dnames in makeEqContext' ctx th
|
||||
|
||||
namespace EqContext
|
||||
public export %inline
|
||||
|
@ -172,21 +241,42 @@ namespace EqContext
|
|||
null ctx = null ctx.dnames && null ctx.tnames
|
||||
|
||||
export %inline
|
||||
extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
|
||||
extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
|
||||
let (qs, xs, ss) = unzip3 xss in
|
||||
extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2
|
||||
extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
|
||||
let (qs, xs, ls) = unzip3 xss in
|
||||
MkEqContext {
|
||||
termLen = extendLen xss termLen,
|
||||
tctx = tctx . ss,
|
||||
tctx = tctx . ls,
|
||||
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)]
|
||||
|
||||
export %inline
|
||||
extendTy0 : BindName -> Term 0 n -> EqContext n -> EqContext (S n)
|
||||
extendTy0 = extendTy Zero
|
||||
|
||||
export %inline
|
||||
extendDim : BindName -> DimConst -> EqContext n -> EqContext n
|
||||
extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) =
|
||||
|
@ -197,8 +287,8 @@ namespace EqContext
|
|||
toTyContext : (e : EqContext n) -> TyContext e.dimLen n
|
||||
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
|
||||
MkTyContext {
|
||||
dctx = fromGround dassign,
|
||||
tctx = map (// shift0 dimLen) tctx,
|
||||
dctx = fromGround dnames dassign,
|
||||
tctx = map (subD $ shift0 dimLen) tctx,
|
||||
dnames, tnames, qtys
|
||||
}
|
||||
|
||||
|
@ -207,18 +297,44 @@ 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}) =
|
||||
extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) =
|
||||
MkWhnfContext {
|
||||
dimLen = [|Val s + dimLen|],
|
||||
dnames = dnames ++ toSnocVect' ns,
|
||||
tctx = dweakT s <$> tctx,
|
||||
tctx = map (subD $ shift s) tctx,
|
||||
tnames
|
||||
}
|
||||
|
||||
|
@ -230,14 +346,25 @@ namespace WhnfContext
|
|||
private
|
||||
prettyTContextElt : {opts : _} ->
|
||||
BContext d -> BContext n ->
|
||||
Qty -> BindName -> Term d n -> Eff Pretty (Doc opts)
|
||||
prettyTContextElt dnames tnames q x s =
|
||||
pure $ hsep [hcat [!(prettyQty q), !dotD, !(prettyTBind x)], !colonD,
|
||||
!(withPrec Outer $ prettyTerm dnames tnames s)]
|
||||
Doc opts -> BindName -> LocalVar d n ->
|
||||
Eff Pretty (Doc opts)
|
||||
prettyTContextElt dnames tnames q x s = do
|
||||
dot <- dotD
|
||||
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 -> QContext n -> BContext n ->
|
||||
BContext d -> Context' (Doc opts) n -> BContext n ->
|
||||
TContext d n -> Eff Pretty (SnocList (Doc opts))
|
||||
prettyTContext' _ [<] [<] [<] = pure [<]
|
||||
prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
|
||||
|
@ -248,8 +375,11 @@ export
|
|||
prettyTContext : {opts : _} ->
|
||||
BContext d -> QContext n -> BContext n ->
|
||||
TContext d n -> Eff Pretty (Doc opts)
|
||||
prettyTContext dnames qtys tnames tys =
|
||||
separateTight !commaD <$> prettyTContext' dnames qtys tnames tys
|
||||
prettyTContext dnames qtys tnames tys = do
|
||||
comma <- commaD
|
||||
qtys <- traverse prettyQty qtys
|
||||
sepSingle . exceptLast (<+> comma) . toList <$>
|
||||
prettyTContext' dnames qtys tnames tys
|
||||
|
||||
export
|
||||
prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
|
||||
|
@ -257,9 +387,16 @@ prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
|
|||
case dctx of
|
||||
C [<] => prettyTContext dnames qtys tnames tctx
|
||||
_ => pure $
|
||||
sep [!(prettyDimEq dnames dctx) <++> !pipeD,
|
||||
sepSingle [!(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
|
||||
|
|
|
@ -2,12 +2,19 @@ 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
|
||||
|
||||
import Data.List
|
||||
import Control.Eff
|
||||
import Derive.Prelude
|
||||
|
||||
%language ElabReflection
|
||||
%hide TT.Name
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
|
@ -15,6 +22,7 @@ record NameContexts d n where
|
|||
constructor MkNameContexts
|
||||
dnames : BContext d
|
||||
tnames : BContext n
|
||||
%runElab deriveIndexed "NameContexts" [Show]
|
||||
|
||||
namespace NameContexts
|
||||
export
|
||||
|
@ -60,8 +68,10 @@ 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)
|
||||
|
@ -78,11 +88,14 @@ 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
|
||||
| WhileChecking
|
||||
(TyContext d n) Qty
|
||||
(TyContext d n) SQty
|
||||
(Term d n) -- term
|
||||
(Term d n) -- type
|
||||
Error
|
||||
|
@ -92,19 +105,20 @@ data Error
|
|||
(Maybe Universe)
|
||||
Error
|
||||
| WhileInferring
|
||||
(TyContext d n) Qty
|
||||
(TyContext d n) SQty
|
||||
(Elim d n)
|
||||
Error
|
||||
| WhileComparingT
|
||||
(EqContext n) EqMode
|
||||
(EqContext n) EqMode SQty
|
||||
(Term 0 n) -- type
|
||||
(Term 0 n) (Term 0 n) -- lhs/rhs
|
||||
Error
|
||||
| WhileComparingE
|
||||
(EqContext n) EqMode
|
||||
(EqContext n) EqMode SQty
|
||||
(Elim 0 n) (Elim 0 n)
|
||||
Error
|
||||
%name Error err
|
||||
%runElab derive "Error" [Show]
|
||||
|
||||
public export
|
||||
ErrorEff : Type -> Type
|
||||
|
@ -118,8 +132,10 @@ 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
|
||||
|
@ -132,12 +148,14 @@ 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
|
||||
(WhileInferring _ _ _ err).loc = err.loc
|
||||
(WhileComparingT _ _ _ _ _ err).loc = err.loc
|
||||
(WhileComparingE _ _ _ _ err).loc = err.loc
|
||||
(WhileComparingT _ _ _ _ _ _ err).loc = err.loc
|
||||
(WhileComparingE _ _ _ _ _ err).loc = err.loc
|
||||
|
||||
|
||||
||| separates out all the error context layers
|
||||
|
@ -150,10 +168,10 @@ explodeContext (WhileCheckingTy ctx s k err) =
|
|||
mapFst (WhileCheckingTy ctx s k ::) $ explodeContext err
|
||||
explodeContext (WhileInferring ctx x e err) =
|
||||
mapFst (WhileInferring ctx x e ::) $ explodeContext err
|
||||
explodeContext (WhileComparingT ctx x s t r err) =
|
||||
mapFst (WhileComparingT ctx x s t r ::) $ explodeContext err
|
||||
explodeContext (WhileComparingE ctx x e f err) =
|
||||
mapFst (WhileComparingE ctx x e f ::) $ explodeContext err
|
||||
explodeContext (WhileComparingT ctx x sg s t r err) =
|
||||
mapFst (WhileComparingT ctx x sg s t r ::) $ explodeContext err
|
||||
explodeContext (WhileComparingE ctx x sg e f err) =
|
||||
mapFst (WhileComparingE ctx x sg e f ::) $ explodeContext err
|
||||
explodeContext err = ([], err)
|
||||
|
||||
||| leaves the outermost context layer, and the innermost (up to) n, and removes
|
||||
|
@ -240,10 +258,26 @@ where
|
|||
hangDSingle "with quantities" $
|
||||
separateTight !commaD $ toSnocList' !(traverse prettyQty qs)]
|
||||
|
||||
export
|
||||
prettyErrorNoLoc : {opts : _} -> (showContext : Bool) -> Error ->
|
||||
Eff Pretty (Doc opts)
|
||||
prettyErrorNoLoc showContext = \case
|
||||
parameters {opts : LayoutOpts} (showContext : Bool)
|
||||
export
|
||||
inContext' : Bool -> a -> (a -> Eff Pretty (Doc opts)) ->
|
||||
Doc opts -> Eff Pretty (Doc opts)
|
||||
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)
|
||||
|
@ -261,19 +295,29 @@ prettyErrorNoLoc showContext = \case
|
|||
!(prettyTerm ctx.dnames ctx.tnames s)
|
||||
|
||||
ExpectedEq _ ctx s =>
|
||||
hangDSingle "expected an enumeration type, but got"
|
||||
hangDSingle "expected an equality 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)]
|
||||
|
@ -332,68 +376,68 @@ prettyErrorNoLoc showContext = \case
|
|||
[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)]
|
||||
|
||||
WhileChecking ctx pi s a err =>
|
||||
WhileChecking ctx sg s a err =>
|
||||
[|vappendBlank
|
||||
(inTContext ctx . sep =<< sequence
|
||||
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
|
||||
hangDSingle "has type" !(prettyTerm ctx.dnames ctx.tnames a),
|
||||
hangDSingle "with quantity" !(prettyQty pi)])
|
||||
(prettyErrorNoLoc showContext err)|]
|
||||
hangDSingle "with quantity" !(prettyQty sg.qty)])
|
||||
(prettyErrorNoLoc 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 showContext err)|]
|
||||
(prettyErrorNoLoc err)|]
|
||||
|
||||
WhileInferring ctx pi e err =>
|
||||
WhileInferring ctx sg e err =>
|
||||
[|vappendBlank
|
||||
(inTContext ctx . sep =<< sequence
|
||||
[hangDSingle "while inferring the type of"
|
||||
!(prettyElim ctx.dnames ctx.tnames e),
|
||||
hangDSingle "with quantity" !(prettyQty pi)])
|
||||
(prettyErrorNoLoc showContext err)|]
|
||||
hangDSingle "with quantity" !(prettyQty sg.qty)])
|
||||
(prettyErrorNoLoc err)|]
|
||||
|
||||
WhileComparingT ctx mode a s t err =>
|
||||
WhileComparingT ctx mode sg a s t err =>
|
||||
[|vappendBlank
|
||||
(inEContext ctx . sep =<< sequence
|
||||
[hangDSingle "while checking that" !(prettyTerm [<] ctx.tnames s),
|
||||
hangDSingle (text "is \{prettyMode mode}")
|
||||
!(prettyTerm [<] ctx.tnames t),
|
||||
hangDSingle "at type" !(prettyTerm [<] ctx.tnames a)])
|
||||
(prettyErrorNoLoc showContext err)|]
|
||||
hangDSingle "at type" !(prettyTerm [<] ctx.tnames a),
|
||||
hangDSingle "with quantity" !(prettyQty sg.qty)])
|
||||
(prettyErrorNoLoc err)|]
|
||||
|
||||
WhileComparingE ctx mode e f err =>
|
||||
WhileComparingE ctx mode sg e f err =>
|
||||
[|vappendBlank
|
||||
(inEContext ctx . sep =<< sequence
|
||||
[hangDSingle "while checking that" !(prettyElim [<] ctx.tnames e),
|
||||
hangDSingle (text "is \{prettyMode mode}")
|
||||
!(prettyElim [<] ctx.tnames f)])
|
||||
(prettyErrorNoLoc showContext err)|]
|
||||
!(prettyElim [<] ctx.tnames f),
|
||||
hangDSingle "with quantity" !(prettyQty sg.qty)])
|
||||
(prettyErrorNoLoc err)|]
|
||||
|
||||
where
|
||||
where
|
||||
vappendBlank : Doc opts -> Doc opts -> Doc opts
|
||||
vappendBlank a b = flush a `vappend` b
|
||||
|
||||
inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
|
||||
inTContext ctx doc =
|
||||
if showContext && not (null ctx) then
|
||||
pure $ vappend doc (sep ["in context", !(prettyTyContext ctx)])
|
||||
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]
|
||||
export
|
||||
prettyError : Error -> Eff Pretty (Doc opts)
|
||||
prettyError err = hangDSingle
|
||||
!(prettyLoc err.loc)
|
||||
!(indentD =<< prettyErrorNoLoc err)
|
||||
|
|
568
lib/Quox/Untyped/Erase.idr
Normal file
568
lib/Quox/Untyped/Erase.idr
Normal file
|
@ -0,0 +1,568 @@
|
|||
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
|
378
lib/Quox/Untyped/Scheme.idr
Normal file
378
lib/Quox/Untyped/Scheme.idr
Normal file
|
@ -0,0 +1,378 @@
|
|||
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]
|
Some files were not shown because too many files have changed in this diff Show more
Loading…
Reference in a new issue