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
|
||||||
quox-tests
|
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 "misc.quox"
|
||||||
load "bool.quox"
|
load "bool.quox"
|
||||||
load "either.quox"
|
load "either.quox"
|
||||||
|
load "maybe.quox"
|
||||||
load "nat.quox"
|
load "nat.quox"
|
||||||
load "pair.quox"
|
load "pair.quox"
|
||||||
load "list.quox"
|
load "list.quox"
|
||||||
|
load "eta.quox"
|
||||||
|
load "fail.quox"
|
||||||
|
load "qty.quox"
|
||||||
|
|
|
@ -4,24 +4,35 @@ namespace bool {
|
||||||
|
|
||||||
def0 Bool : ★ = {true, false};
|
def0 Bool : ★ = {true, false};
|
||||||
|
|
||||||
def boolω : 1.Bool → [ω.Bool] =
|
def if-dep : 0.(P : Bool → ★) → (b : Bool) → ω.(P 'true) → ω.(P 'false) → P b =
|
||||||
λ b ⇒ case1 b return [ω.Bool] of { 'true ⇒ ['true]; 'false ⇒ ['false] };
|
λ P b t f ⇒ case b return b' ⇒ P b' of { 'true ⇒ t; 'false ⇒ f };
|
||||||
|
|
||||||
def if : 0.(A : ★) → 1.Bool → ω.A → ω.A → A =
|
def if : 0.(A : ★) → (b : Bool) → ω.A → ω.A → A =
|
||||||
λ A b t f ⇒ case1 b return A of { 'true ⇒ t; 'false ⇒ f };
|
λ A ⇒ if-dep (λ _ ⇒ A);
|
||||||
|
|
||||||
def0 If : 1.Bool → 0.★ → 0.★ → ★ =
|
def0 if-same : (A : ★) → (b : Bool) → (x : A) → if A b x x ≡ x : A =
|
||||||
λ b T F ⇒ case1 b return ★ of { 'true ⇒ T; 'false ⇒ F };
|
λ 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) =
|
def true-not-false : Not ('true ≡ 'false : Bool) =
|
||||||
λ eq ⇒ coe (i ⇒ T (eq @i)) 'true;
|
λ eq ⇒ coe (𝑖 ⇒ T (eq @𝑖)) 'true;
|
||||||
|
|
||||||
|
|
||||||
-- [todo] infix
|
-- [todo] infix
|
||||||
def and : 1.Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
|
def and : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
|
||||||
def or : 1.Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
|
def or : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -5,35 +5,35 @@ namespace either {
|
||||||
|
|
||||||
def0 Tag : ★ = {left, right};
|
def0 Tag : ★ = {left, right};
|
||||||
|
|
||||||
def0 Payload : 0.★ → 0.★ → 1.Tag → ★ =
|
def0 Payload : ★ → ★ → Tag → ★ =
|
||||||
λ A B tag ⇒ case1 tag return ★ of { 'left ⇒ A; 'right ⇒ B };
|
λ 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;
|
λ 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);
|
λ 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);
|
λ A B x ⇒ ('right, x);
|
||||||
|
|
||||||
def elim' :
|
def elim' :
|
||||||
0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
|
0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
|
||||||
ω.(1.(x : A) → P (Left A B x)) →
|
ω.((x : A) → P (Left A B x)) →
|
||||||
ω.(1.(x : B) → P (Right A B x)) →
|
ω.((x : B) → P (Right A B x)) →
|
||||||
1.(t : Tag) → 1.(a : Payload A B t) → P (t, a) =
|
(t : Tag) → (a : Payload A B t) → P (t, a) =
|
||||||
λ A B P f g t ⇒
|
λ A B P f g t ⇒
|
||||||
case1 t
|
case t
|
||||||
return t' ⇒ 1.(a : Payload A B t') → P (t', a)
|
return t' ⇒ (a : Payload A B t') → P (t', a)
|
||||||
of { 'left ⇒ f; 'right ⇒ g };
|
of { 'left ⇒ f; 'right ⇒ g };
|
||||||
|
|
||||||
def elim :
|
def elim :
|
||||||
0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
|
0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
|
||||||
ω.(1.(x : A) → P (Left A B x)) →
|
ω.((x : A) → P (Left A B x)) →
|
||||||
ω.(1.(x : B) → P (Right A B x)) →
|
ω.((x : B) → P (Right A B x)) →
|
||||||
1.(x : Either A B) → P x =
|
(x : Either A B) → P x =
|
||||||
λ A B P f g e ⇒
|
λ 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 {
|
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 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];
|
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);
|
λ A ⇒ ω.(x : A) → ω.(y : A) → Dec (x ≡ y : A);
|
||||||
|
|
||||||
def elim :
|
def elim :
|
||||||
0.(A : ★) → 0.(P : 0.(Dec A) → ★) →
|
0.(A : ★) → 0.(P : 0.(Dec A) → ★) →
|
||||||
ω.(0.(y : A) → P (Yes A y)) →
|
ω.(0.(y : A) → P (Yes A y)) →
|
||||||
ω.(0.(n : Not A) → P (No A n)) →
|
ω.(0.(n : Not A) → P (No A n)) →
|
||||||
1.(x : Dec A) → P x =
|
(x : Dec A) → P x =
|
||||||
λ A P f g ⇒
|
λ A P f g ⇒
|
||||||
either.elim [0.A] [0.Not A] P
|
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'})
|
(λ 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'});
|
(λ 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);
|
λ 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";
|
load "nat.quox";
|
||||||
|
|
||||||
namespace list {
|
namespace vec {
|
||||||
|
|
||||||
def0 Vec : 0.ℕ → 0.★ → ★ =
|
def0 Vec : ℕ → ★ → ★ =
|
||||||
λ n A ⇒
|
λ n A ⇒
|
||||||
caseω n return ★ of {
|
caseω n return ★ of {
|
||||||
zero ⇒ {nil};
|
zero ⇒ {nil};
|
||||||
succ _, 0.Tail ⇒ A × Tail
|
succ _, 0.Tail ⇒ A × Tail
|
||||||
};
|
};
|
||||||
|
|
||||||
def0 List : 0.★ → ★ =
|
def elim : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
|
||||||
λ A ⇒ (len : ℕ) × Vec len A;
|
P 0 'nil →
|
||||||
|
ω.((x : A) → 0.(n : ℕ) → 0.(xs : Vec n A) →
|
||||||
def nil : 0.(A : ★) → List A =
|
P n xs → P (succ n) (x, xs)) →
|
||||||
λ A ⇒ (0, 'nil);
|
(n : ℕ) → (xs : Vec n A) → P n xs =
|
||||||
|
λ A P pn pc n ⇒
|
||||||
def cons : 0.(A : ★) → 1.A → 1.(List A) → List A =
|
case n return n' ⇒ (xs' : Vec n' A) → P n' xs' of {
|
||||||
λ A x xs ⇒ case1 xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
|
zero ⇒ λ n ⇒
|
||||||
|
case n return n' ⇒ P 0 n' of { 'nil ⇒ pn };
|
||||||
def foldr' : 0.(A B : ★) →
|
succ n, ih ⇒ λ c ⇒
|
||||||
1.B → ω.(1.A → 1.B → B) → 1.(n : ℕ) → 1.(Vec n A) → B =
|
case c return c' ⇒ P (succ n) c' of {
|
||||||
λ A B z c n ⇒
|
(first, rest) ⇒ pc first n rest (ih rest)
|
||||||
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 foldr : 0.(A B : ★) → 1.B → ω.(1.A → 1.B → B) → 1.(List A) → B =
|
#[compile-scheme "(lambda% (n xs) xs)"]
|
||||||
λ A B z c xs ⇒
|
def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A =
|
||||||
case1 xs return B of { (len, elems) ⇒ foldr' A B z c len elems };
|
λ A n ⇒
|
||||||
|
case n return n' ⇒ Vec n' A → Vec¹ n' A of {
|
||||||
def sum : 1.(List ℕ) → ℕ = foldr ℕ ℕ 0 nat.plus;
|
zero ⇒ λ xs ⇒
|
||||||
|
case xs return Vec¹ 0 A of { 'nil ⇒ 'nil };
|
||||||
def numbers : List ℕ = (5, (0, 1, 2, 3, 4, 'nil));
|
succ n', f' ⇒ λ xs ⇒
|
||||||
|
case xs return Vec¹ (succ n') A of {
|
||||||
def number-sum : sum numbers ≡ 10 : ℕ = δ _ ⇒ 10;
|
(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 False : ★ = {}
|
||||||
def0 Not : 0.★ → ★ = λ A ⇒ ω.A → False;
|
def0 Not : ★ → ★ = λ A ⇒ ω.A → False
|
||||||
|
|
||||||
def void : 0.(A : ★) → 0.False → A =
|
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) → ★¹ =
|
def0 cong :
|
||||||
λ A P ⇒ 1.(x : A) → P x;
|
(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 :
|
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.(p : All A P) → 0.(q : All A P) →
|
||||||
0.A → ★ =
|
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 :
|
def funext :
|
||||||
0.(A : ★) → 0.(P : Pred A) → 0.(p q : All A P) →
|
0.(A : ★) → 0.(P : 0.A → ★) → 0.(p q : All A P) →
|
||||||
1.(All A (eq-f A P p q)) → 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 @𝑖;
|
λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖
|
||||||
|
|
||||||
def sym : 0.(A : ★) → 0.(x y : A) → 1.(x ≡ y : A) → y ≡ x : A =
|
def refl : 0.(A : ★) → (x : A) → x ≡ x : A = λ A x ⇒ δ _ ⇒ x
|
||||||
λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 };
|
|
||||||
|
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) →
|
def trans : 0.(A : ★) → 0.(x y z : A) →
|
||||||
ω.(x ≡ y : A) → ω.(y ≡ z : A) → x ≡ z : A =
|
ω.(x ≡ y : A) → ω.(y ≡ z : A) → x ≡ z : A =
|
||||||
λ A x y z eq1 eq2 ⇒ δ 𝑖 ⇒
|
λ 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 {
|
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 ⇒
|
λ n ⇒
|
||||||
case1 n return [ω.ℕ] of {
|
case n return n' ⇒ [ω. Sing ℕ n'] of {
|
||||||
zero ⇒ [zero];
|
zero ⇒ [(zero, [δ _ ⇒ zero])];
|
||||||
succ _, 1.d ⇒ case1 d return [ω.ℕ] of { [d] ⇒ [succ d] }
|
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 ⇒
|
λ m n ⇒
|
||||||
case1 m return ℕ of {
|
case m return ℕ of {
|
||||||
zero ⇒ n;
|
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 ⇒
|
λ m n ⇒
|
||||||
case1 m return ℕ of {
|
case m return ℕ of {
|
||||||
zero ⇒ zero;
|
zero ⇒ zero;
|
||||||
succ _, 1.t ⇒ plus n t
|
succ _, t ⇒ plus n t
|
||||||
};
|
};
|
||||||
|
|
||||||
def times : 1.ℕ → 1.ℕ → ℕ =
|
def times : ℕ → ℕ → ℕ =
|
||||||
λ m n ⇒ case1 dup n return ℕ of { [n] ⇒ timesω m n };
|
λ 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 : ℕ =
|
def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ =
|
||||||
λ 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 @𝑖);
|
λ 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) =
|
def isSucc? : ω.(n : ℕ) → Dec (IsSucc n) =
|
||||||
λ n ⇒
|
λ n ⇒
|
||||||
|
@ -54,14 +85,15 @@ def succ-not-zero : 0.(m : ℕ) → Not (succ m ≡ zero : ℕ) =
|
||||||
λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true;
|
λ 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 ⇒
|
λ m ⇒
|
||||||
caseω m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
|
case m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
|
||||||
zero ⇒ zero-not-succ 0;
|
zero ⇒ zero-not-succ 0;
|
||||||
succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq)
|
succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"]
|
||||||
def eq? : DecEq ℕ =
|
def eq? : DecEq ℕ =
|
||||||
λ m ⇒
|
λ m ⇒
|
||||||
caseω m
|
caseω m
|
||||||
|
@ -86,28 +118,48 @@ def eq? : DecEq ℕ =
|
||||||
def eqb : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ dec.bool (m ≡ n : ℕ) (eq? m n);
|
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 ⇒
|
λ m ⇒
|
||||||
caseω m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
|
case m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
|
||||||
zero ⇒ δ _ ⇒ zero;
|
zero ⇒ δ _ ⇒ 0;
|
||||||
succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
|
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 ⇒
|
λ 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;
|
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 ⇒
|
λ 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;
|
zero ⇒ plus-zero n;
|
||||||
succ m', ω.ih ⇒
|
succ m', ih ⇒
|
||||||
trans ℕ (succ (plus m' n)) (succ (plus n m')) (plus n (succ m'))
|
trans ℕ (succ (plus m' n)) (succ (plus n m')) (plus n (succ m'))
|
||||||
(δ 𝑖 ⇒ succ (ih @𝑖))
|
(δ 𝑖 ⇒ succ (ih @𝑖))
|
||||||
(plus-succ n m')
|
(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 {
|
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 };
|
λ 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 };
|
λ A B p ⇒ caseω p return p' ⇒ B (fst A B p') of { (_, y) ⇒ y };
|
||||||
|
-}
|
||||||
|
|
||||||
def uncurry :
|
def uncurry :
|
||||||
0.(A : ★) → 0.(B : 0.A → ★) → 0.(C : 0.(x : A) → 0.(B x) → ★) →
|
0.(A : ★) → 0.(B : A → ★) → 0.(C : (x : A) → (B x) → ★) →
|
||||||
1.(f : 1.(x : A) → 1.(y : B x) → C x y) →
|
(f : (x : A) → (y : B x) → C x y) →
|
||||||
1.(p : Σ A B) → C (fst A B p) (snd A B p) =
|
(p : Σ A B) → C (fst p) (snd p) =
|
||||||
λ A B C f 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' :
|
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);
|
λ A B C ⇒ uncurry A (λ _ ⇒ B) (λ _ _ ⇒ C);
|
||||||
|
|
||||||
def curry :
|
def curry :
|
||||||
0.(A : ★) → 0.(B : 0.A → ★) → 0.(C : 0.(Σ A B) → ★) →
|
0.(A : ★) → 0.(B : A → ★) → 0.(C : (Σ A B) → ★) →
|
||||||
1.(f : 1.(p : Σ A B) → C p) → 1.(x : A) → 1.(y : B x) → C (x, y) =
|
(f : (p : Σ A B) → C p) → (x : A) → (y : B x) → C (x, y) =
|
||||||
λ A B C f x y ⇒ f (x, y);
|
λ A B C f x y ⇒ f (x, y);
|
||||||
|
|
||||||
def curry' :
|
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);
|
λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C);
|
||||||
|
|
||||||
def0 fst-snd :
|
def0 fst-snd :
|
||||||
0.(A : ★) → 0.(B : 0.A → ★) →
|
(A : ★) → (B : A → ★) →
|
||||||
1.(p : Σ A B) → p ≡ (fst A B p, snd A B p) : Σ A B =
|
(p : Σ A B) → p ≡ (fst p, snd p) : Σ A B =
|
||||||
λ A B p ⇒
|
λ A B p ⇒
|
||||||
case1 p
|
case p
|
||||||
return p' ⇒ p' ≡ (fst A B p', snd A B p') : Σ A B
|
return p' ⇒ p' ≡ (fst p', snd p') : Σ A B
|
||||||
of { (x, y) ⇒ δ 𝑖 ⇒ (x, y) };
|
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 :
|
def map :
|
||||||
0.(A A' : ★) →
|
0.(A A' : ★) →
|
||||||
0.(B : 0.A → ★) → 0.(B' : 0.A' → ★) →
|
0.(B : A → ★) → 0.(B' : A' → ★) →
|
||||||
1.(f : 1.A → A') → 1.(g : 0.(x : A) → 1.(B x) → B' (f x)) →
|
(f : A → A') → (g : 0.(x : A) → (B x) → B' (f x)) →
|
||||||
1.(Σ A B) → Σ A' B' =
|
Σ A B → Σ A' B' =
|
||||||
λ A A' B B' f g p ⇒
|
λ 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' : ★) →
|
def map' : 0.(A A' B B' : ★) → (A → A') → (B → B') → (A × B) → A' × B' =
|
||||||
1.(1.A → A') → 1.(1.B → B') → 1.(A × B) → A' × B' =
|
|
||||||
λ A A' B B' f g ⇒ map A A' (λ _ ⇒ B) (λ _ ⇒ B') f (λ _ ⇒ g);
|
λ 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.Σ;
|
def0 Σ = pair.Σ;
|
||||||
def fst = pair.fst;
|
-- def fst = pair.fst;
|
||||||
def snd = pair.snd;
|
-- 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
|
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.Parser
|
||||||
import Quox.Definition
|
import Quox.Untyped.Erase
|
||||||
|
import Quox.Untyped.Scheme
|
||||||
import Quox.Pretty
|
import Quox.Pretty
|
||||||
|
import Quox.Log
|
||||||
|
import Options
|
||||||
|
import Output
|
||||||
|
import Error
|
||||||
|
import CompileMonad
|
||||||
|
|
||||||
import System
|
import System
|
||||||
|
import System.File
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.SortedSet
|
|
||||||
import Control.Eff
|
import Control.Eff
|
||||||
|
|
||||||
private
|
%default total
|
||||||
Opts : LayoutOpts
|
|
||||||
Opts = Opts 80
|
%hide Doc.(>>=)
|
||||||
|
%hide Core.(>>=)
|
||||||
|
|
||||||
|
%hide FromParser.Error
|
||||||
|
%hide Erase.Error
|
||||||
|
%hide Lexer.Error
|
||||||
|
%hide Parser.Error
|
||||||
|
|
||||||
|
|
||||||
private
|
private
|
||||||
putDoc : Doc Opts -> IO ()
|
Step : Type -> Type -> Type
|
||||||
putDoc = putStr . render Opts
|
Step a b = OpenFile -> a -> Eff Compile b
|
||||||
|
|
||||||
private
|
private
|
||||||
die : Doc Opts -> IO a
|
step : ConsoleChannel -> Phase -> OutFile -> Step a b -> a -> Eff CompileStop b
|
||||||
die err = do putDoc err; exitFailure
|
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 : IO ()
|
||||||
main = do
|
main = do
|
||||||
seen <- newIORef SortedSet.empty
|
(_, opts, files) <- options
|
||||||
defs <- newIORef SortedMap.empty
|
case !(runCompile opts !newState $ traverse_ processFile files) of
|
||||||
suf <- newIORef $ the Nat 0
|
Right () => pure ()
|
||||||
for_ (drop 1 !getArgs) $ \file => do
|
Left e => dieError opts e
|
||||||
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
|
|
||||||
|
|
||||||
-----------------------------------
|
-----------------------------------
|
||||||
{-
|
{-
|
||||||
|
@ -55,6 +127,13 @@ text _ =
|
||||||
#" /_/"#,
|
#" /_/"#,
|
||||||
""]
|
""]
|
||||||
|
|
||||||
|
-- ["",
|
||||||
|
-- #" __ _ _ _ _____ __"#,
|
||||||
|
-- #"/ _` | || / _ \ \ /"#,
|
||||||
|
-- #"\__, |\_,_\___/_\_\"#,
|
||||||
|
-- #" |_|"#,
|
||||||
|
-- ""]
|
||||||
|
|
||||||
private
|
private
|
||||||
qtuwu : PrettyOpts -> List String
|
qtuwu : PrettyOpts -> List String
|
||||||
qtuwu opts =
|
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
|
package quox
|
||||||
version = 0
|
version = 0
|
||||||
|
|
||||||
depends = base, contrib, elab-util, sop, quox-lib
|
depends = base, contrib, elab-util, pretty-show, quox-lib
|
||||||
|
|
||||||
executable = quox
|
executable = quox
|
||||||
main = Main
|
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
|
import public Data.Bool
|
||||||
|
|
||||||
|
|
||||||
infixr 5 `andM`
|
export infixr 5 `andM`
|
||||||
infixr 4 `orM`
|
export infixr 4 `orM`
|
||||||
|
|
||||||
public export
|
public export
|
||||||
andM, orM : Monad m => m Bool -> m Bool -> m Bool
|
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
|
export
|
||||||
%foreign "scheme:string-normalize-nfc"
|
%foreign "scheme:string-normalize-nfc"
|
||||||
normalizeNfc : String -> String
|
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.DPair
|
||||||
import Data.Nat
|
import Data.Nat
|
||||||
|
import Data.Singleton
|
||||||
import Data.SnocList
|
import Data.SnocList
|
||||||
import Data.SnocVect
|
import Data.SnocVect
|
||||||
import Data.Vect
|
import Data.Vect
|
||||||
|
@ -57,6 +58,7 @@ public export
|
||||||
tail : Context tm (S n) -> Context tm n
|
tail : Context tm (S n) -> Context tm n
|
||||||
tail = fst . unsnoc
|
tail = fst . unsnoc
|
||||||
|
|
||||||
|
|
||||||
parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
|
parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
|
||||||
export
|
export
|
||||||
toSnocListWith : Telescope tm _ _ -> SnocList a
|
toSnocListWith : Telescope tm _ _ -> SnocList a
|
||||||
|
@ -107,10 +109,17 @@ fromSnocVect [<] = [<]
|
||||||
fromSnocVect (sx :< x) = fromSnocVect sx :< x
|
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
|
public export
|
||||||
tabulate : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
|
tabulate : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
|
||||||
tabulate f 0 = [<]
|
tabulate f n = tabulateLT n (\i => f i)
|
||||||
tabulate f (S k) = tabulate f k :< f k
|
-- [todo] fixup argument order lol
|
||||||
|
|
||||||
public export
|
public export
|
||||||
replicate : (n : Nat) -> a -> Context' a n
|
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
|
Context tm len -> Var len -> tm len
|
||||||
getWith shft = getShiftWith shft SZ
|
getWith shft = getShiftWith shft SZ
|
||||||
|
|
||||||
infixl 8 !!
|
export infixl 8 !!
|
||||||
public export %inline
|
public export %inline
|
||||||
(!!) : CanShift tm => Context tm len -> Var len -> tm len
|
(!!) : CanShift tm => Context tm len -> Var len -> tm len
|
||||||
(!!) = getWith (//)
|
(!!) = getWith (//)
|
||||||
|
|
||||||
infixl 8 !!!
|
export infixl 8 !!!
|
||||||
public export %inline
|
public export %inline
|
||||||
(!!!) : Context' tm len -> Var len -> tm
|
(!!!) : Context' tm len -> Var len -> tm
|
||||||
(!!!) = getWith const
|
(!!!) = getWith const
|
||||||
|
@ -180,6 +189,12 @@ export %hint
|
||||||
succGT = LTESucc reflexive
|
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}
|
parameters {auto _ : Applicative f}
|
||||||
export
|
export
|
||||||
traverse : (forall n. tm1 n -> f (tm2 n)) ->
|
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' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
|
||||||
traverse' f = traverse f
|
traverse' f = traverse f
|
||||||
|
|
||||||
infixl 3 `app`
|
export infixl 3 `app`
|
||||||
||| like `(<*>)` but with effects
|
||| like `(<*>)` but with effects
|
||||||
export
|
export
|
||||||
app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
|
app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
|
||||||
|
@ -258,16 +273,17 @@ unzip3 (tel :< (x, y, z)) =
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
lengthPrf : Telescope _ from to -> (len ** len + from = to)
|
lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
|
||||||
lengthPrf [<] = (0 ** Refl)
|
lengthPrf [<] = Element 0 Refl
|
||||||
lengthPrf (tel :< _) =
|
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
|
export
|
||||||
lengthPrf0 : Context _ to -> (len ** len = to)
|
lengthPrf0 : Context _ to -> Singleton to
|
||||||
lengthPrf0 ctx =
|
lengthPrf0 ctx =
|
||||||
let len = lengthPrf ctx in
|
let Element len prf = lengthPrf ctx in
|
||||||
(len.fst ** rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
|
rewrite sym prf `trans` plusZeroRightNeutral len in
|
||||||
|
[|len|]
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
length : Telescope {} -> Nat
|
length : Telescope {} -> Nat
|
||||||
|
@ -286,6 +302,10 @@ foldl : {0 acc : Nat -> Type} ->
|
||||||
foldl f z [<] = z
|
foldl f z [<] = z
|
||||||
foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
|
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
|
export %inline
|
||||||
foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
|
foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
|
||||||
foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
|
foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
|
||||||
|
@ -345,4 +365,4 @@ parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
|
||||||
namespace BContext
|
namespace BContext
|
||||||
export
|
export
|
||||||
toNames : BContext n -> SnocList BaseName
|
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.No
|
||||||
import public Quox.Syntax
|
import public Quox.Syntax
|
||||||
|
import Quox.Displace
|
||||||
import public Data.SortedMap
|
import public Data.SortedMap
|
||||||
import public Quox.Loc
|
import public Quox.Loc
|
||||||
|
import Quox.Pretty
|
||||||
import Control.Eff
|
import Control.Eff
|
||||||
|
import Data.Singleton
|
||||||
import Decidable.Decidable
|
import Decidable.Decidable
|
||||||
|
|
||||||
|
|
||||||
|
@ -26,15 +29,21 @@ record Definition where
|
||||||
qty : GQty
|
qty : GQty
|
||||||
type0 : Term 0 0
|
type0 : Term 0 0
|
||||||
body0 : DefBody
|
body0 : DefBody
|
||||||
|
scheme : Maybe String
|
||||||
|
isMain : Bool
|
||||||
loc_ : Loc
|
loc_ : Loc
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
mkPostulate : GQty -> (type0 : Term 0 0) -> Loc -> Definition
|
mkPostulate : GQty -> (type0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
|
||||||
mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_}
|
Definition
|
||||||
|
mkPostulate qty type0 scheme isMain loc_ =
|
||||||
|
MkDef {qty, type0, body0 = Postulate, scheme, isMain, loc_}
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition
|
mkDef : GQty -> (type0, term0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
|
||||||
mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, 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 Located Definition where def.loc = def.loc_
|
||||||
export Relocatable Definition where setLoc loc = {loc_ := loc}
|
export Relocatable Definition where setLoc loc = {loc_ := loc}
|
||||||
|
@ -45,27 +54,51 @@ parameters {d, n : Nat}
|
||||||
(.type) : Definition -> Term d n
|
(.type) : Definition -> Term d n
|
||||||
g.type = g.type0 // shift0 d // shift0 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
|
public export %inline
|
||||||
(.term) : Definition -> Maybe (Term d n)
|
(.term) : Definition -> Maybe (Term d n)
|
||||||
g.term = g.body0.term0 <&> \t => t // shift0 d // shift0 n
|
g.term = g.body0.term0 <&> \t => t // shift0 d // shift0 n
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
toElim : Definition -> Maybe $ Elim d n
|
(.termAt) : Definition -> Universe -> Maybe (Term d n)
|
||||||
toElim def = pure $ Ann !def.term def.type def.loc
|
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
|
public export %inline
|
||||||
isZero : Definition -> Bool
|
isZero : Definition -> Bool
|
||||||
isZero g = g.qty.fst == Zero
|
isZero g = g.qty == GZero
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
data DefEnvTag = DEFS
|
NDefinition : Type
|
||||||
|
NDefinition = (Name, Definition)
|
||||||
|
|
||||||
public export
|
public export
|
||||||
Definitions : Type
|
Definitions : Type
|
||||||
Definitions = SortedMap Name Definition
|
Definitions = SortedMap Name Definition
|
||||||
|
|
||||||
|
public export
|
||||||
|
data DefEnvTag = DEFS
|
||||||
|
|
||||||
public export
|
public export
|
||||||
DefsReader : Type -> Type
|
DefsReader : Type -> Type
|
||||||
DefsReader = ReaderL DEFS Definitions
|
DefsReader = ReaderL DEFS Definitions
|
||||||
|
@ -74,7 +107,21 @@ public export
|
||||||
DefsState : Type -> Type
|
DefsState : Type -> Type
|
||||||
DefsState = StateL DEFS Definitions
|
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
|
public export %inline
|
||||||
lookupElim : {d, n : Nat} -> Name -> Definitions -> Maybe (Elim d n)
|
lookupElim0 : Name -> Universe -> Definitions -> Maybe (Elim 0 0)
|
||||||
lookupElim x defs = toElim !(lookup x defs)
|
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
|
import Quox.Syntax
|
||||||
|
|
||||||
|
%default total
|
||||||
|
|
||||||
|
|
||||||
parameters (k : Universe)
|
parameters (k : Universe)
|
||||||
namespace Term
|
namespace Term
|
||||||
|
@ -14,6 +16,7 @@ parameters (k : Universe)
|
||||||
|
|
||||||
namespace Term
|
namespace Term
|
||||||
doDisplace (TYPE l loc) = TYPE (k + l) loc
|
doDisplace (TYPE l loc) = TYPE (k + l) loc
|
||||||
|
doDisplace (IOState loc) = IOState loc
|
||||||
doDisplace (Pi qty arg res loc) =
|
doDisplace (Pi qty arg res loc) =
|
||||||
Pi qty (doDisplace arg) (doDisplaceS res) loc
|
Pi qty (doDisplace arg) (doDisplaceS res) loc
|
||||||
doDisplace (Lam body loc) = Lam (doDisplaceS body) loc
|
doDisplace (Lam body loc) = Lam (doDisplaceS body) loc
|
||||||
|
@ -24,14 +27,18 @@ parameters (k : Universe)
|
||||||
doDisplace (Eq ty l r loc) =
|
doDisplace (Eq ty l r loc) =
|
||||||
Eq (doDisplaceDS ty) (doDisplace l) (doDisplace r) loc
|
Eq (doDisplaceDS ty) (doDisplace l) (doDisplace r) loc
|
||||||
doDisplace (DLam body loc) = DLam (doDisplaceDS body) loc
|
doDisplace (DLam body loc) = DLam (doDisplaceDS body) loc
|
||||||
doDisplace (Nat loc) = Nat loc
|
doDisplace (NAT loc) = NAT loc
|
||||||
doDisplace (Zero loc) = Zero loc
|
doDisplace (Nat n loc) = Nat n loc
|
||||||
doDisplace (Succ p loc) = Succ (doDisplace p) 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 qty ty loc) = BOX qty (doDisplace ty) loc
|
||||||
doDisplace (Box val loc) = Box (doDisplace val) 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 (E e) = E (doDisplace e)
|
||||||
doDisplace (CloT (Sub t th)) =
|
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)) =
|
doDisplace (DCloT (Sub t th)) =
|
||||||
DCloT (Sub (doDisplace 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 (App fun arg loc) = App (doDisplace fun) (doDisplace arg) loc
|
||||||
doDisplace (CasePair qty pair ret body loc) =
|
doDisplace (CasePair qty pair ret body loc) =
|
||||||
CasePair qty (doDisplace pair) (doDisplaceS ret) (doDisplaceS 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) =
|
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) =
|
doDisplace (CaseNat qty qtyIH nat ret zero succ loc) =
|
||||||
CaseNat qty qtyIH (doDisplace nat) (doDisplaceS ret)
|
CaseNat qty qtyIH (doDisplace nat) (doDisplaceS ret)
|
||||||
(doDisplace zero) (doDisplaceS succ) loc
|
(doDisplace zero) (doDisplaceS succ) loc
|
||||||
|
@ -65,9 +75,9 @@ parameters (k : Universe)
|
||||||
(doDisplaceDS zero) (doDisplaceDS one) loc
|
(doDisplaceDS zero) (doDisplaceDS one) loc
|
||||||
doDisplace (TypeCase ty ret arms def loc) =
|
doDisplace (TypeCase ty ret arms def loc) =
|
||||||
TypeCase (doDisplace ty) (doDisplace ret)
|
TypeCase (doDisplace ty) (doDisplace ret)
|
||||||
(map doDisplaceS arms) (doDisplace def) loc
|
(assert_total $ map doDisplaceS arms) (doDisplace def) loc
|
||||||
doDisplace (CloE (Sub e th)) =
|
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)) =
|
doDisplace (DCloE (Sub e th)) =
|
||||||
DCloE (Sub (doDisplace e) th)
|
DCloE (Sub (doDisplace e) th)
|
||||||
|
|
||||||
|
|
|
@ -2,6 +2,7 @@ module Quox.EffExtra
|
||||||
|
|
||||||
import public Control.Eff
|
import public Control.Eff
|
||||||
|
|
||||||
|
import Control.Monad.ST.Extra
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
|
|
||||||
|
|
||||||
|
@ -26,48 +27,40 @@ local_ : Has (State s) fs => s -> Eff fs a -> Eff fs a
|
||||||
local_ = localAt_ ()
|
local_ = localAt_ ()
|
||||||
|
|
||||||
|
|
||||||
export
|
export %inline
|
||||||
hasDrop : (0 neq : Not (a = b)) ->
|
getsAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> a) -> Eff fs a
|
||||||
(ha : Has a fs) => (hb : Has b fs) =>
|
getsAt lbl f = f <$> getAt lbl
|
||||||
Has a (drop fs hb)
|
|
||||||
hasDrop neq {ha = Z} {hb = Z} = void $ neq Refl
|
export %inline
|
||||||
hasDrop neq {ha = S ha} {hb = Z} = ha
|
gets : Has (State s) fs => (s -> a) -> Eff fs a
|
||||||
hasDrop neq {ha = Z} {hb = S hb} = Z
|
gets = getsAt ()
|
||||||
hasDrop neq {ha = S ha} {hb = S hb} = S $ hasDrop neq {ha, hb}
|
|
||||||
|
|
||||||
|
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
|
export
|
||||||
runStateIORefAt : (0 lbl : tag) -> (Has IO fs, Has (StateL lbl s) fs) =>
|
handleStateIORef : HasIO m => IORef st -> StateL lbl st a -> m a
|
||||||
IORef s -> Eff fs a -> Eff (fs - StateL lbl s) a
|
handleStateIORef r Get = readIORef r
|
||||||
runStateIORefAt lbl ref act = do
|
handleStateIORef r (Put s) = writeIORef r s
|
||||||
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 ()
|
|
||||||
|
|
||||||
|
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
|
public export
|
||||||
data Length : List a -> Type where
|
data Length : List a -> Type where
|
||||||
Z : Length []
|
Z : Length []
|
||||||
S : Length xs -> Length (x :: xs)
|
S : Length xs -> Length (x :: xs)
|
||||||
|
%builtin Natural Length
|
||||||
|
|
||||||
export
|
export
|
||||||
subsetWith : Length xs => (forall z. Has z xs -> Has z ys) ->
|
subsetWith : Length xs => (forall z. Has z xs -> Has z ys) ->
|
||||||
|
@ -80,23 +73,77 @@ subsetSelf : Length xs => Subset xs xs
|
||||||
subsetSelf = subsetWith id
|
subsetSelf = subsetWith id
|
||||||
|
|
||||||
export
|
export
|
||||||
subsetTail : Length xs => Subset xs (x :: xs)
|
subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
|
||||||
subsetTail = subsetWith S
|
subsetTail _ = subsetWith S
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- [fixme] allow the error to be anywhere in the effect list
|
|
||||||
export
|
export
|
||||||
wrapErrAt : Length fs => (0 lbl : tag) -> (e -> e) ->
|
rethrowAtWith : (0 lbl : tag) -> Has (ExceptL lbl e') fs =>
|
||||||
Eff (ExceptL lbl e :: fs) a -> Eff (ExceptL lbl e :: fs) a
|
(e -> e') -> Either e a -> Eff fs a
|
||||||
wrapErrAt lbl f act =
|
rethrowAtWith lbl f = rethrowAt lbl . mapFst f
|
||||||
rethrowAt lbl . mapFst f =<< lift @{subsetTail} (runExceptAt lbl act)
|
|
||||||
|
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
|
export %inline
|
||||||
wrapErr : Length fs => (e -> e) ->
|
ioLeft : e -> IOErr e a
|
||||||
Eff (Except e :: fs) a -> Eff (Except e :: fs) a
|
ioLeft = IOE . pure . Left
|
||||||
wrapErr = wrapErrAt ()
|
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
|
||||||
runIO : (MonadRec io, HasIO io) => Eff [IO] a -> io a
|
|
||||||
runIO act = runEff act [liftIO]
|
|
||||||
|
|
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
|
||| file locations
|
||||||
module Quox.Loc
|
module Quox.Loc
|
||||||
|
|
||||||
|
import Quox.PrettyValExtra
|
||||||
import public Text.Bounded
|
import public Text.Bounded
|
||||||
import Data.SortedMap
|
import Data.SortedMap
|
||||||
import Derive.Prelude
|
import Derive.Prelude
|
||||||
|
@ -12,12 +13,12 @@ public export
|
||||||
FileName : Type
|
FileName : Type
|
||||||
FileName = String
|
FileName = String
|
||||||
|
|
||||||
%runElab derive "Bounds" [Ord]
|
%runElab derive "Bounds" [Ord, PrettyVal]
|
||||||
|
|
||||||
public export
|
public export
|
||||||
data Loc_ = NoLoc | YesLoc FileName Bounds
|
data Loc_ = NoLoc | YesLoc FileName Bounds
|
||||||
%name Loc_ loc
|
%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
|
||| a wrapper for locations which are always considered equal
|
||||||
|
@ -39,6 +40,18 @@ public export %inline
|
||||||
makeLoc : FileName -> Bounds -> Loc
|
makeLoc : FileName -> Bounds -> Loc
|
||||||
makeLoc = L .: YesLoc
|
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
|
export
|
||||||
onlyStart_ : Loc_ -> Loc_
|
onlyStart_ : Loc_ -> Loc_
|
||||||
|
@ -95,7 +108,7 @@ extendL : Loc -> Loc -> Loc
|
||||||
extendL l1 l2 = l1 `extend'` l2.bounds
|
extendL l1 l2 = l1 `extend'` l2.bounds
|
||||||
|
|
||||||
|
|
||||||
infixr 1 `or_`, `or`
|
export infixr 1 `or_`, `or`
|
||||||
export %inline
|
export %inline
|
||||||
or_ : Loc_ -> Loc_ -> Loc_
|
or_ : Loc_ -> Loc_ -> Loc_
|
||||||
or_ l1@(YesLoc {}) _ = l1
|
or_ l1@(YesLoc {}) _ = l1
|
||||||
|
@ -105,6 +118,11 @@ export %inline
|
||||||
or : Loc -> Loc -> Loc
|
or : Loc -> Loc -> Loc
|
||||||
or (L l1) (L l2) = L $ l1 `or_` l2
|
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
|
public export
|
||||||
interface Located a where (.loc) : a -> Loc
|
interface Located a where (.loc) : a -> Loc
|
||||||
|
@ -113,9 +131,22 @@ public export
|
||||||
0 Located1 : (a -> Type) -> Type
|
0 Located1 : (a -> Type) -> Type
|
||||||
Located1 f = forall x. Located (f x)
|
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
|
public export
|
||||||
interface Located a => Relocatable a where setLoc : Loc -> a -> a
|
interface Located a => Relocatable a where setLoc : Loc -> a -> a
|
||||||
|
|
||||||
public export
|
public export
|
||||||
0 Relocatable1 : (a -> Type) -> Type
|
0 Relocatable1 : (a -> Type) -> Type
|
||||||
Relocatable1 f = forall x. Relocatable (f x)
|
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.Loc
|
||||||
import Quox.CharExtra
|
import Quox.CharExtra
|
||||||
|
import Quox.PrettyValExtra
|
||||||
import public Data.SnocList
|
import public Data.SnocList
|
||||||
import Data.List
|
import Data.List
|
||||||
import Control.Eff
|
import Control.Eff
|
||||||
|
@ -23,7 +24,7 @@ data BaseName
|
||||||
= UN String -- user-given name
|
= UN String -- user-given name
|
||||||
| MN String NameSuf -- machine-generated name
|
| MN String NameSuf -- machine-generated name
|
||||||
| Unused -- "_"
|
| Unused -- "_"
|
||||||
%runElab derive "BaseName" [Eq, Ord]
|
%runElab derive "BaseName" [Eq, Ord, PrettyVal]
|
||||||
|
|
||||||
export
|
export
|
||||||
baseStr : BaseName -> String
|
baseStr : BaseName -> String
|
||||||
|
@ -42,14 +43,14 @@ Mods = SnocList String
|
||||||
|
|
||||||
public export
|
public export
|
||||||
record Name where
|
record Name where
|
||||||
constructor MakeName
|
constructor MkName
|
||||||
mods : Mods
|
mods : Mods
|
||||||
base : BaseName
|
base : BaseName
|
||||||
%runElab derive "Name" [Eq, Ord]
|
%runElab derive "Name" [Eq, Ord]
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
unq : BaseName -> Name
|
unq : BaseName -> Name
|
||||||
unq = MakeName [<]
|
unq = MkName [<]
|
||||||
|
|
||||||
||| add some namespaces to the beginning of a name
|
||| add some namespaces to the beginning of a name
|
||||||
public export %inline
|
public export %inline
|
||||||
|
@ -63,31 +64,31 @@ PBaseName = String
|
||||||
|
|
||||||
public export
|
public export
|
||||||
record PName where
|
record PName where
|
||||||
constructor MakePName
|
constructor MkPName
|
||||||
mods : Mods
|
mods : Mods
|
||||||
base : PBaseName
|
base : PBaseName
|
||||||
%runElab derive "PName" [Eq, Ord]
|
%runElab derive "PName" [Eq, Ord, PrettyVal]
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
fromPName : PName -> Name
|
fromPName : PName -> Name
|
||||||
fromPName p = MakeName p.mods $ UN p.base
|
fromPName p = MkName p.mods $ UN p.base
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
toPName : Name -> PName
|
toPName : Name -> PName
|
||||||
toPName p = MakePName p.mods $ baseStr p.base
|
toPName p = MkPName p.mods $ baseStr p.base
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
fromPBaseName : PBaseName -> Name
|
fromPBaseName : PBaseName -> Name
|
||||||
fromPBaseName = MakeName [<] . UN
|
fromPBaseName = MkName [<] . UN
|
||||||
|
|
||||||
export
|
export
|
||||||
Show PName where
|
Show PName where
|
||||||
show (MakePName mods base) =
|
show (MkPName mods base) =
|
||||||
show $ concat $ intersperse "." $ toList $ mods :< base
|
show $ concat $ intersperse "." $ toList $ mods :< base
|
||||||
|
|
||||||
export Show Name where show = show . toPName
|
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
|
export FromString Name where fromString = fromPBaseName
|
||||||
|
|
||||||
|
@ -95,9 +96,9 @@ export FromString Name where fromString = fromPBaseName
|
||||||
public export
|
public export
|
||||||
record BindName where
|
record BindName where
|
||||||
constructor BN
|
constructor BN
|
||||||
name : BaseName
|
val : BaseName
|
||||||
loc_ : Loc
|
loc_ : Loc
|
||||||
%runElab derive "BindName" [Eq, Ord, Show]
|
%runElab derive "BindName" [Eq, Ord, Show, PrettyVal]
|
||||||
|
|
||||||
export Located BindName where n.loc = n.loc_
|
export Located BindName where n.loc = n.loc_
|
||||||
export Relocatable BindName where setLoc loc (BN x _) = BN x loc
|
export Relocatable BindName where setLoc loc (BN x _) = BN x loc
|
||||||
|
@ -115,7 +116,7 @@ export
|
||||||
fromListP : List1 String -> PName
|
fromListP : List1 String -> PName
|
||||||
fromListP (x ::: xs) = go [<] x xs where
|
fromListP (x ::: xs) = go [<] x xs where
|
||||||
go : SnocList String -> String -> List String -> PName
|
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
|
go mods x (y :: ys) = go (mods :< x) y ys
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
|
@ -169,14 +170,6 @@ public export
|
||||||
NameGen : Type -> Type
|
NameGen : Type -> Type
|
||||||
NameGen = StateL GEN NameSuf
|
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
|
||| generate a fresh name with the given base
|
||||||
export
|
export
|
||||||
|
@ -186,15 +179,13 @@ mn base = do
|
||||||
modifyAt GEN S
|
modifyAt GEN S
|
||||||
pure $ MN base i
|
pure $ MN base i
|
||||||
|
|
||||||
||| generate a fresh binding name with the given base and
|
||| generate a fresh binding name with the given base and location `loc`
|
||||||
||| (optionally) location `loc`
|
|
||||||
export
|
export
|
||||||
mnb : Has NameGen fs =>
|
mnb : Has NameGen fs => PBaseName -> Loc -> Eff fs BindName
|
||||||
PBaseName -> {default noLoc loc : Loc} -> Eff fs BindName
|
mnb base loc = pure $ BN !(mn base) loc
|
||||||
mnb base = pure $ BN !(mn base) loc
|
|
||||||
|
|
||||||
export
|
export
|
||||||
fresh : Has NameGen fs => BindName -> Eff fs BindName
|
fresh : Has NameGen fs => BindName -> Eff fs BindName
|
||||||
fresh (BN (UN str) loc) = mnb str {loc}
|
fresh (BN (UN str) loc) = mnb str loc
|
||||||
fresh (BN (MN str k) loc) = mnb str {loc}
|
fresh (BN (MN str k) loc) = mnb str loc
|
||||||
fresh (BN Unused loc) = mnb "x" {loc}
|
fresh (BN Unused loc) = mnb "x" loc
|
||||||
|
|
|
@ -4,6 +4,7 @@ import public Data.Nat
|
||||||
import Data.Nat.Division
|
import Data.Nat.Division
|
||||||
import Data.SnocList
|
import Data.SnocList
|
||||||
import Data.Vect
|
import Data.Vect
|
||||||
|
import Data.String
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
|
|
||||||
|
@ -52,6 +53,42 @@ parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char)
|
||||||
showAtBase : Nat -> String
|
showAtBase : Nat -> String
|
||||||
showAtBase = pack . showAtBase' []
|
showAtBase = pack . showAtBase' []
|
||||||
|
|
||||||
export
|
namespace Nat
|
||||||
showHex : Nat -> String
|
export
|
||||||
showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
|
showHex : Nat -> String
|
||||||
|
showHex = showAtBase $ fromList $ unpack "0123456789abcdef"
|
||||||
|
|
||||||
|
namespace Int
|
||||||
|
export
|
||||||
|
showHex : Int -> String
|
||||||
|
showHex x =
|
||||||
|
if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x)
|
||||||
|
|
||||||
|
|
||||||
|
namespace Int
|
||||||
|
export
|
||||||
|
fromHexit : Char -> Maybe Int
|
||||||
|
fromHexit c =
|
||||||
|
if c >= '0' && c <= '9' then Just $ ord c - ord '0'
|
||||||
|
else if c >= 'a' && c <= 'f' then Just $ ord c - ord 'a' + 10
|
||||||
|
else if c >= 'A' && c <= 'F' then Just $ ord c - ord 'A' + 10
|
||||||
|
else Nothing
|
||||||
|
|
||||||
|
private
|
||||||
|
fromHex' : Int -> String -> Maybe Int
|
||||||
|
fromHex' acc str = case strM str of
|
||||||
|
StrNil => Just acc
|
||||||
|
StrCons c cs => fromHex' (16 * acc + !(fromHexit c)) (assert_smaller str cs)
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
fromHex : String -> Maybe Int
|
||||||
|
fromHex str = do guard $ str /= ""; fromHex' 0 str
|
||||||
|
|
||||||
|
namespace Nat
|
||||||
|
export
|
||||||
|
fromHexit : Char -> Maybe Nat
|
||||||
|
fromHexit = map cast . Int.fromHexit
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
fromHex : String -> Maybe Nat
|
||||||
|
fromHex = map cast . Int.fromHex
|
||||||
|
|
|
@ -43,7 +43,7 @@ parameters {0 a, b : Bool}
|
||||||
noOr2 = snd . noOr
|
noOr2 = snd . noOr
|
||||||
|
|
||||||
|
|
||||||
infixr 1 `orNo`
|
export infixr 1 `orNo`
|
||||||
export %inline
|
export %inline
|
||||||
orNo : No a -> No b -> No (a || b)
|
orNo : No a -> No b -> No (a || b)
|
||||||
orNo Ah Ah = Ah
|
orNo Ah Ah = Ah
|
||||||
|
@ -52,3 +52,8 @@ export %inline
|
||||||
nchoose : (b : Bool) -> Either (So b) (No b)
|
nchoose : (b : Bool) -> Either (So b) (No b)
|
||||||
nchoose True = Left Oh
|
nchoose True = Left Oh
|
||||||
nchoose False = Right Ah
|
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
|
||| take freshly-parsed input, scope check, type check, add to env
|
||||||
module Quox.Parser.FromParser
|
module Quox.Parser.FromParser
|
||||||
|
|
||||||
|
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
|
||||||
|
|
||||||
|
import Quox.Pretty
|
||||||
import Quox.Parser.Syntax
|
import Quox.Parser.Syntax
|
||||||
import Quox.Parser.Parser
|
import Quox.Parser.Parser
|
||||||
|
import public Quox.Parser.LoadFile
|
||||||
import Quox.Typechecker
|
import Quox.Typechecker
|
||||||
|
import Quox.CheckBuiltin
|
||||||
|
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.SnocVect
|
import Data.SnocVect
|
||||||
import Quox.EffExtra
|
import Quox.EffExtra
|
||||||
|
import Control.Monad.ST.Extra
|
||||||
|
|
||||||
import System.File
|
import System.File
|
||||||
import System.Path
|
import System.Path
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
|
|
||||||
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
|
|
||||||
|
|
||||||
%default total
|
|
||||||
|
|
||||||
%hide Typing.Error
|
%hide Typing.Error
|
||||||
%hide Lexer.Error
|
%hide Lexer.Error
|
||||||
%hide Parser.Error
|
%hide Parser.Error
|
||||||
|
|
||||||
|
%default total
|
||||||
public export
|
|
||||||
NDefinition : Type
|
|
||||||
NDefinition = (Name, Definition)
|
|
||||||
|
|
||||||
public export
|
|
||||||
IncludePath : Type
|
|
||||||
IncludePath = List String
|
|
||||||
|
|
||||||
public export
|
|
||||||
SeenFiles : Type
|
|
||||||
SeenFiles = SortedSet String
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
|
@ -41,27 +33,50 @@ data StateTag = NS | SEEN
|
||||||
|
|
||||||
public export
|
public export
|
||||||
FromParserPure : List (Type -> Type)
|
FromParserPure : List (Type -> Type)
|
||||||
FromParserPure =
|
FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
|
||||||
[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]
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
FromParserIO : List (Type -> Type)
|
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)
|
parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
|
||||||
(xs : Context' PatVar n)
|
(xs : Context' PatVar n)
|
||||||
private
|
private
|
||||||
fromBaseName : PBaseName -> m a
|
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
|
Context.find (\y => y.name == Just x) xs
|
||||||
|
|
||||||
private
|
private
|
||||||
|
@ -113,11 +128,10 @@ fromV : Context' PatVar d -> Context' PatVar n ->
|
||||||
PName -> Maybe Universe -> Loc -> Eff FromParserPure (Term d n)
|
PName -> Maybe Universe -> Loc -> Eff FromParserPure (Term d n)
|
||||||
fromV ds ns x u loc = fromName bound free ns x where
|
fromV ds ns x u loc = fromName bound free ns x where
|
||||||
bound : Var n -> Eff FromParserPure (Term d n)
|
bound : Var n -> Eff FromParserPure (Term d n)
|
||||||
bound i = do whenJust u $ \u => throw $ DisplacedBoundVar loc x
|
bound i = unless (isNothing u) (throw $ DisplacedBoundVar loc x) $> BT i loc
|
||||||
pure $ E $ B i loc
|
|
||||||
free : PName -> Eff FromParserPure (Term d n)
|
free : PName -> Eff FromParserPure (Term d n)
|
||||||
free x = do x <- avoidDim ds loc x
|
free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
|
||||||
resolveName !(getAt NS) loc x u
|
|
||||||
|
|
||||||
mutual
|
mutual
|
||||||
export
|
export
|
||||||
|
@ -127,6 +141,9 @@ mutual
|
||||||
TYPE k loc =>
|
TYPE k loc =>
|
||||||
pure $ TYPE k loc
|
pure $ TYPE k loc
|
||||||
|
|
||||||
|
IOState loc =>
|
||||||
|
pure $ IOState loc
|
||||||
|
|
||||||
Pi pi x s t loc =>
|
Pi pi x s t loc =>
|
||||||
Pi (fromPQty pi)
|
Pi (fromPQty pi)
|
||||||
<$> fromPTermWith ds ns s
|
<$> fromPTermWith ds ns s
|
||||||
|
@ -157,17 +174,26 @@ mutual
|
||||||
<*> fromPTermTScope ds ns [< x, y] body
|
<*> fromPTermTScope ds ns [< x, y] body
|
||||||
<*> pure loc
|
<*> 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 =>
|
Case pi tag (r, ret) (CaseEnum arms _) loc =>
|
||||||
map E $ CaseEnum (fromPQty pi)
|
map E $ CaseEnum (fromPQty pi)
|
||||||
<$> fromPTermElim ds ns tag
|
<$> fromPTermElim ds ns tag
|
||||||
<*> fromPTermTScope ds ns [< r] ret
|
<*> fromPTermTScope ds ns [< r] ret
|
||||||
<*> assert_total fromPTermEnumArms ds ns arms
|
<*> assert_total fromPTermEnumArms loc ds ns arms
|
||||||
<*> pure loc
|
<*> pure loc
|
||||||
|
|
||||||
Nat loc => pure $ Nat loc
|
NAT loc => pure $ NAT loc
|
||||||
Zero loc => pure $ Zero loc
|
Nat n loc => pure $ Nat n loc
|
||||||
Succ n loc => [|Succ (fromPTermWith ds ns n) (pure 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 =>
|
Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
|
||||||
map E $ CaseNat (fromPQty pi) (fromPQty pi')
|
map E $ CaseNat (fromPQty pi) (fromPQty pi')
|
||||||
<$> fromPTermElim ds ns nat
|
<$> fromPTermElim ds ns nat
|
||||||
|
@ -176,12 +202,11 @@ mutual
|
||||||
<*> fromPTermTScope ds ns [< s, ih] suc
|
<*> fromPTermTScope ds ns [< s, ih] suc
|
||||||
<*> pure loc
|
<*> pure loc
|
||||||
|
|
||||||
Enum strs loc =>
|
Enum strs loc => do
|
||||||
let set = SortedSet.fromList strs in
|
let set = SortedSet.fromList strs
|
||||||
if length strs == length (SortedSet.toList set) then
|
unless (length strs == length (SortedSet.toList set)) $
|
||||||
|
throw $ DuplicatesInEnumType loc strs
|
||||||
pure $ Enum set loc
|
pure $ Enum set loc
|
||||||
else
|
|
||||||
throw $ DuplicatesInEnum loc strs
|
|
||||||
|
|
||||||
Tag str loc => pure $ Tag str loc
|
Tag str loc => pure $ Tag str loc
|
||||||
|
|
||||||
|
@ -238,13 +263,22 @@ mutual
|
||||||
<*> fromPTermDScope ds ns [< j1] val1
|
<*> fromPTermDScope ds ns [< j1] val1
|
||||||
<*> pure loc
|
<*> pure loc
|
||||||
|
|
||||||
|
Let (qty, x, rhs) body loc =>
|
||||||
|
Let (fromPQty qty)
|
||||||
|
<$> fromPTermElim ds ns rhs
|
||||||
|
<*> fromPTermTScope ds ns [< x] body
|
||||||
|
<*> pure loc
|
||||||
|
|
||||||
private
|
private
|
||||||
fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
|
fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n ->
|
||||||
List (PTagVal, PTerm) ->
|
List (PTagVal, PTerm) ->
|
||||||
Eff FromParserPure (CaseEnumArms d n)
|
Eff FromParserPure (CaseEnumArms d n)
|
||||||
fromPTermEnumArms ds ns =
|
fromPTermEnumArms loc ds ns arms = do
|
||||||
map SortedMap.fromList .
|
res <- SortedMap.fromList <$>
|
||||||
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
|
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms
|
||||||
|
unless (length (keys res) == length arms) $
|
||||||
|
throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms)
|
||||||
|
pure res
|
||||||
|
|
||||||
private
|
private
|
||||||
fromPTermElim : Context' PatVar d -> Context' PatVar n ->
|
fromPTermElim : Context' PatVar d -> Context' PatVar n ->
|
||||||
|
@ -263,7 +297,7 @@ mutual
|
||||||
if all isUnused xs then
|
if all isUnused xs then
|
||||||
SN <$> fromPTermWith ds ns t
|
SN <$> fromPTermWith ds ns t
|
||||||
else
|
else
|
||||||
ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
|
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
|
||||||
|
|
||||||
private
|
private
|
||||||
fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
|
fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
|
||||||
|
@ -271,9 +305,9 @@ mutual
|
||||||
Eff FromParserPure (DScopeTermN s d n)
|
Eff FromParserPure (DScopeTermN s d n)
|
||||||
fromPTermDScope ds ns xs t =
|
fromPTermDScope ds ns xs t =
|
||||||
if all isUnused xs then
|
if all isUnused xs then
|
||||||
SN <$> fromPTermWith ds ns t
|
SN {f = \d => Term d n} <$> fromPTermWith ds ns t
|
||||||
else
|
else
|
||||||
DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
|
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
|
@ -282,72 +316,110 @@ fromPTerm = fromPTermWith [<] [<]
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
globalPQty : Loc -> (q : Qty) -> Eff [Except Error] (So $ isGlobal q)
|
globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty
|
||||||
globalPQty loc pi = case choose $ isGlobal pi of
|
globalPQty (PQ pi loc) = case toGlobal pi of
|
||||||
Left y => pure y
|
Just g => pure g
|
||||||
Right _ => throw $ QtyNotGlobal loc pi
|
Nothing => throw $ QtyNotGlobal loc pi
|
||||||
|
|
||||||
|
|
||||||
export
|
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
|
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
|
||||||
|
|
||||||
|
|
||||||
private
|
private
|
||||||
liftTC : TC a -> Eff FromParserPure a
|
liftTC : Eff TC a -> Eff FromParserPure a
|
||||||
liftTC act = do
|
liftTC tc = runEff tc $ with Union.(::)
|
||||||
res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act
|
[handleExcept $ \e => throw $ WrapTypeError e,
|
||||||
rethrow $ mapFst WrapTypeError res
|
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
|
export covering
|
||||||
fromPDef : PDefinition -> Eff FromParserPure NDefinition
|
fromPDef : PDefinition -> Eff FromParserPure NDefinition
|
||||||
fromPDef (MkPDef qty pname ptype pterm defLoc) = do
|
fromPDef def = do
|
||||||
name <- lift $ fromPBaseNameNS pname
|
name <- fromPBaseNameNS def.name
|
||||||
qtyGlobal <- lift $ globalPQty qty.loc qty.val
|
defs <- getAt DEFS
|
||||||
let gqty = Element qty.val qtyGlobal
|
when (isJust $ lookup name defs) $ do
|
||||||
sqty = globalToSubj gqty
|
throw $ AlreadyExists def.loc name
|
||||||
type <- lift $ traverse fromPTerm ptype
|
gqty <- globalPQty def.qty
|
||||||
term <- lift $ fromPTerm pterm
|
let sqty = globalToSubj gqty
|
||||||
case type of
|
case def.body of
|
||||||
|
PConcrete ptype pterm => do
|
||||||
|
type <- traverse fromPTerm ptype
|
||||||
|
term <- fromPTerm pterm
|
||||||
|
type <- case type of
|
||||||
Just type => do
|
Just type => do
|
||||||
liftTC $ checkTypeC empty type Nothing
|
ignore $ liftTC $ do
|
||||||
liftTC $ ignore $ checkC empty sqty term type
|
checkTypeC empty type Nothing
|
||||||
let def = mkDef gqty type term defLoc
|
checkC empty sqty term type
|
||||||
modifyAt DEFS $ insert name def
|
pure type
|
||||||
pure (name, def)
|
|
||||||
Nothing => do
|
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
|
res <- liftTC $ inferC empty sqty elim
|
||||||
let def = mkDef gqty res.type term defLoc
|
pure res.type
|
||||||
modifyAt DEFS $ insert name def
|
when def.main $ liftWhnf $ expectMainType defs type
|
||||||
pure (name, def)
|
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
|
export covering
|
||||||
fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
|
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) =
|
fromPDecl (PNs ns) =
|
||||||
|
maybeFail ns.fail ns.loc $
|
||||||
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
||||||
|
fromPDecl (PPrag prag) =
|
||||||
|
case prag of
|
||||||
export covering
|
PLogPush p _ => Log.push p $> []
|
||||||
loadFile : Loc -> String -> Eff LoadFile (Maybe String)
|
PLogPop _ => Log.pop $> []
|
||||||
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
|
|
||||||
|
|
||||||
mutual
|
mutual
|
||||||
export covering
|
export covering
|
||||||
loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
|
loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
|
||||||
loadProcessFile loc file =
|
loadProcessFile loc file =
|
||||||
case !(lift $ loadFile loc file) of
|
case !(loadFile loc file) of
|
||||||
Just inp => do
|
Just tl => concat <$> traverse fromPTopLevel tl
|
||||||
tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
|
|
||||||
concat <$> traverse fromPTopLevel tl
|
|
||||||
Nothing => pure []
|
Nothing => pure []
|
||||||
|
|
||||||
||| populates the `defs` field of the state
|
||| populates the `defs` field of the state
|
||||||
|
@ -355,28 +427,3 @@ mutual
|
||||||
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
|
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
|
||||||
fromPTopLevel (PD decl) = lift $ fromPDecl decl
|
fromPTopLevel (PD decl) = lift $ fromPDecl decl
|
||||||
fromPTopLevel (PLoad file loc) = loadProcessFile loc file
|
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
|
module Quox.Parser.FromParser.Error
|
||||||
|
|
||||||
import Quox.Parser.Parser
|
import Quox.Parser.Parser
|
||||||
|
import Quox.Parser.LoadFile
|
||||||
import Quox.Typing
|
import Quox.Typing
|
||||||
import System.File
|
import System.File
|
||||||
|
|
||||||
import Quox.Pretty
|
import Quox.Pretty
|
||||||
|
|
||||||
|
%default total
|
||||||
|
|
||||||
%hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)
|
%hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)
|
||||||
|
|
||||||
|
|
||||||
|
@ -21,26 +24,34 @@ ParseError = Parser.Error
|
||||||
public export
|
public export
|
||||||
data Error =
|
data Error =
|
||||||
AnnotationNeeded Loc (NameContexts d n) (Term d n)
|
AnnotationNeeded Loc (NameContexts d n) (Term d n)
|
||||||
| DuplicatesInEnum Loc (List TagVal)
|
| DuplicatesInEnumType Loc (List TagVal)
|
||||||
|
| DuplicatesInEnumCase Loc (List TagVal)
|
||||||
| TermNotInScope Loc Name
|
| TermNotInScope Loc Name
|
||||||
| DimNotInScope Loc PBaseName
|
| DimNotInScope Loc PBaseName
|
||||||
| QtyNotGlobal Loc Qty
|
| QtyNotGlobal Loc Qty
|
||||||
| DimNameInTerm Loc PBaseName
|
| DimNameInTerm Loc PBaseName
|
||||||
| DisplacedBoundVar Loc PName
|
| DisplacedBoundVar Loc PName
|
||||||
| WrapTypeError TypeError
|
| 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
|
| WrapParseError String ParseError
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyLexError : {opts : _} -> String -> LexError -> Eff Pretty (Doc opts)
|
prettyLexError : {opts : _} -> String -> LexError -> Eff Pretty (Doc opts)
|
||||||
prettyLexError file (Err reason line col char) = do
|
prettyLexError file (Err reason line col char) = do
|
||||||
let loc = makeLoc file (MkBounds line col line col)
|
|
||||||
reason <- case reason of
|
reason <- case reason of
|
||||||
EndInput => pure "unexpected end of input"
|
Other msg => pure $ text msg
|
||||||
NoRuleApply => pure $ text "unrecognised character: \{show char}"
|
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 $
|
ComposeNotClosing (sl, sc) (el, ec) => pure $
|
||||||
hsep ["unterminated token at", !(prettyBounds (MkBounds sl sc el ec))]
|
hsep ["unterminated token at", !(prettyBounds (MkBounds sl sc el ec))]
|
||||||
|
let loc = makeLoc file (MkBounds line col line col)
|
||||||
pure $ vappend !(prettyLoc loc) reason
|
pure $ vappend !(prettyLoc loc) reason
|
||||||
|
|
||||||
export
|
export
|
||||||
|
@ -61,19 +72,23 @@ prettyParseError file (ParseError errs) =
|
||||||
traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
|
traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
|
||||||
|
|
||||||
|
|
||||||
parameters (showContext : Bool)
|
parameters {opts : LayoutOpts} (showContext : Bool)
|
||||||
export
|
export
|
||||||
prettyError : {opts : _} -> Error -> Eff Pretty (Doc opts)
|
prettyError : Error -> Eff Pretty (Doc opts)
|
||||||
prettyError (AnnotationNeeded loc ctx tm) =
|
prettyError (AnnotationNeeded loc ctx tm) =
|
||||||
[|vappend (prettyLoc loc)
|
[|vappend (prettyLoc loc)
|
||||||
(hangD "type annotation needed on"
|
(hangD "type annotation needed on"
|
||||||
!(prettyTerm ctx.dnames ctx.tnames tm))|]
|
!(prettyTerm ctx.dnames ctx.tnames tm))|]
|
||||||
-- [todo] print the original PTerm instead
|
-- [todo] print the original PTerm instead
|
||||||
|
|
||||||
prettyError (DuplicatesInEnum loc tags) =
|
prettyError (DuplicatesInEnumType loc tags) =
|
||||||
[|vappend (prettyLoc loc)
|
[|vappend (prettyLoc loc)
|
||||||
(hangD "duplicate tags in enum type" !(prettyEnum tags))|]
|
(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) =
|
prettyError (DimNotInScope loc i) =
|
||||||
[|vappend (prettyLoc loc)
|
[|vappend (prettyLoc loc)
|
||||||
(pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]
|
(pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]
|
||||||
|
@ -100,10 +115,32 @@ parameters (showContext : Bool)
|
||||||
prettyError (WrapTypeError err) =
|
prettyError (WrapTypeError err) =
|
||||||
Typing.prettyError showContext $ trimContext 2 err
|
Typing.prettyError showContext $ trimContext 2 err
|
||||||
|
|
||||||
prettyError (LoadError loc str err) = pure $
|
prettyError (AlreadyExists loc name) = pure $
|
||||||
vsep [!(prettyLoc loc),
|
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]
|
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) =
|
prettyError (WrapParseError file err) =
|
||||||
prettyParseError file err
|
prettyParseError file err
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
module Quox.Parser.Lexer
|
module Quox.Parser.Lexer
|
||||||
|
|
||||||
import Quox.CharExtra
|
import Quox.CharExtra
|
||||||
|
import Quox.NatExtra
|
||||||
import Quox.Name
|
import Quox.Name
|
||||||
import Data.String.Extra
|
import Data.String.Extra
|
||||||
import Data.SortedMap
|
import Data.SortedMap
|
||||||
|
@ -19,7 +20,7 @@ import Derive.Prelude
|
||||||
||| @ Reserved reserved token
|
||| @ Reserved reserved token
|
||||||
||| @ Name name, possibly qualified
|
||| @ Name name, possibly qualified
|
||||||
||| @ Nat nat literal
|
||| @ Nat nat literal
|
||||||
||| @ String string literal
|
||| @ Str string literal
|
||||||
||| @ Tag tag literal
|
||| @ Tag tag literal
|
||||||
||| @ TYPE "Type" or "★" with ascii nat directly after
|
||| @ TYPE "Type" or "★" with ascii nat directly after
|
||||||
||| @ Sup superscript or ^ number (displacement, or universe for ★)
|
||| @ Sup superscript or ^ number (displacement, or universe for ★)
|
||||||
|
@ -34,16 +35,27 @@ data Token =
|
||||||
| Sup Nat
|
| Sup Nat
|
||||||
%runElab derive "Token" [Eq, Ord, Show]
|
%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
|
public export
|
||||||
0 TokenW : Type
|
data ExtToken = Skip | Invalid String String | T Token
|
||||||
TokenW = Maybe 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
|
public export
|
||||||
record Error where
|
record Error where
|
||||||
constructor Err
|
constructor Err
|
||||||
reason : StopReason
|
reason : ErrorReason
|
||||||
line, col : Int
|
line, col : Int
|
||||||
||| `Nothing` if the error is at the end of the input
|
||| `Nothing` if the error is at the end of the input
|
||||||
char : Maybe Char
|
char : Maybe Char
|
||||||
|
@ -52,49 +64,94 @@ record Error where
|
||||||
|
|
||||||
|
|
||||||
private
|
private
|
||||||
skip : Lexer -> Tokenizer TokenW
|
skip : Lexer -> Tokenizer ExtToken
|
||||||
skip t = match t $ const Nothing
|
skip t = match t $ const Skip
|
||||||
|
|
||||||
private
|
private
|
||||||
match : Lexer -> (String -> Token) -> Tokenizer TokenW
|
tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
|
||||||
match t f = Tokenizer.match t (Just . f)
|
tmatch t f = match t (T . f)
|
||||||
%hide Tokenizer.match
|
|
||||||
|
|
||||||
|
|
||||||
private
|
|
||||||
name : Tokenizer TokenW
|
|
||||||
name = match name $ Name . fromListP . split (== '.') . normalizeNfc
|
|
||||||
|
|
||||||
||| [todo] escapes other than `\"` and (accidentally) `\\`
|
|
||||||
export
|
export
|
||||||
fromStringLit : String -> String
|
fromStringLit : (String -> Token) -> String -> ExtToken
|
||||||
fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where
|
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 : List Char -> List Char
|
||||||
go [] = []
|
go [] = []
|
||||||
go ['\\'] = ['\\'] -- i guess???
|
go ('_' :: cs) = go cs
|
||||||
go ('\\' :: c :: cs) = c :: go cs
|
|
||||||
go (c :: cs) = c :: go cs
|
go (c :: cs) = c :: go cs
|
||||||
|
|
||||||
private
|
decLit =
|
||||||
string : Tokenizer TokenW
|
withUnderscores (range '0' '9') <+> reject idContEnd
|
||||||
string = match stringLit (Str . fromStringLit)
|
|
||||||
|
hexLit =
|
||||||
|
approx "0x" <+>
|
||||||
|
withUnderscores (range '0' '9' <|> range 'a' 'f' <|> range 'A' 'F') <+>
|
||||||
|
reject idContEnd
|
||||||
|
|
||||||
|
fromDecLit : String -> Token
|
||||||
|
fromDecLit = Nat . cast . withoutUnderscores
|
||||||
|
|
||||||
|
fromHexLit : String -> ExtToken
|
||||||
|
fromHexLit str =
|
||||||
|
maybe (Invalid "invalid hex sequence" str) (T . Nat) $
|
||||||
|
fromHex $ withoutUnderscores $ drop 2 str
|
||||||
|
|
||||||
|
|
||||||
private
|
private
|
||||||
nat : Tokenizer TokenW
|
tag : Tokenizer ExtToken
|
||||||
nat = match (some (range '0' '9')) (Nat . cast)
|
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
|
private %inline
|
||||||
fromSup : Char -> Char
|
fromSup : Char -> Char
|
||||||
|
@ -102,27 +159,23 @@ fromSup c = case c of
|
||||||
'⁰' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '⁴' => '4'
|
'⁰' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '⁴' => '4'
|
||||||
'⁵' => '5'; '⁶' => '6'; '⁷' => '7'; '⁸' => '8'; '⁹' => '9'; _ => c
|
'⁵' => '5'; '⁶' => '6'; '⁷' => '7'; '⁸' => '8'; '⁹' => '9'; _ => c
|
||||||
|
|
||||||
private %inline
|
|
||||||
subToNat : String -> Nat
|
|
||||||
subToNat = cast . pack . map fromSub . unpack
|
|
||||||
|
|
||||||
private %inline
|
private %inline
|
||||||
supToNat : String -> Nat
|
supToNat : String -> Nat
|
||||||
supToNat = cast . pack . map fromSup . unpack
|
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
|
private
|
||||||
universe : Tokenizer TokenW
|
universe : Tokenizer ExtToken
|
||||||
universe = universeWith "★" <|> universeWith "Type" where
|
universe = universeWith "★" <|> universeWith "Type" where
|
||||||
universeWith : String -> Tokenizer TokenW
|
universeWith : String -> Tokenizer ExtToken
|
||||||
universeWith pfx =
|
universeWith pfx =
|
||||||
let len = length pfx in
|
let len = length pfx in
|
||||||
match (exact pfx <+> digits) (TYPE . cast . drop len)
|
tmatch (exact pfx <+> digits) (TYPE . cast . drop len)
|
||||||
|
|
||||||
private
|
private
|
||||||
sup : Tokenizer TokenW
|
sup : Tokenizer ExtToken
|
||||||
sup = match (some $ pred isSupDigit) (Sup . supToNat)
|
sup = tmatch (some $ pred isSupDigit) (Sup . supToNat)
|
||||||
<|> match (is '^' <+> digits) (Sup . cast . drop 1)
|
<|> tmatch (is '^' <+> digits) (Sup . cast . drop 1)
|
||||||
|
|
||||||
|
|
||||||
private %inline
|
private %inline
|
||||||
|
@ -134,9 +187,11 @@ namespace Reserved
|
||||||
||| description of a reserved symbol
|
||| description of a reserved symbol
|
||||||
||| @ Word a reserved word (must not be followed by letters, digits, etc)
|
||| @ Word a reserved word (must not be followed by letters, digits, etc)
|
||||||
||| @ Sym a reserved symbol (must not be followed by symbolic chars)
|
||| @ 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
|
public export
|
||||||
data Reserved1 = Word String | Sym String | Punc Char
|
data Reserved1 = Word String | Sym String | Punc String
|
||||||
%runElab derive "Reserved1" [Eq, Ord, Show]
|
%runElab derive "Reserved1" [Eq, Ord, Show]
|
||||||
|
|
||||||
||| description of a token that might have unicode & ascii-only aliases
|
||| description of a token that might have unicode & ascii-only aliases
|
||||||
|
@ -145,17 +200,14 @@ namespace Reserved
|
||||||
%runElab derive "Reserved" [Eq, Ord, Show]
|
%runElab derive "Reserved" [Eq, Ord, Show]
|
||||||
|
|
||||||
public export
|
public export
|
||||||
Sym1, Word1 : String -> Reserved
|
Sym1, Word1, Punc1 : String -> Reserved
|
||||||
Sym1 = Only . Sym
|
Sym1 = Only . Sym
|
||||||
Word1 = Only . Word
|
Word1 = Only . Word
|
||||||
|
|
||||||
public export
|
|
||||||
Punc1 : Char -> Reserved
|
|
||||||
Punc1 = Only . Punc
|
Punc1 = Only . Punc
|
||||||
|
|
||||||
public export
|
public export
|
||||||
resString1 : Reserved1 -> String
|
resString1 : Reserved1 -> String
|
||||||
resString1 (Punc x) = singleton x
|
resString1 (Punc x) = x
|
||||||
resString1 (Word w) = w
|
resString1 (Word w) = w
|
||||||
resString1 (Sym s) = s
|
resString1 (Sym s) = s
|
||||||
|
|
||||||
|
@ -166,17 +218,23 @@ resString : Reserved -> String
|
||||||
resString (Only r) = resString1 r
|
resString (Only r) = resString1 r
|
||||||
resString (r `Or` _) = 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
|
private
|
||||||
resTokenizer1 : Reserved1 -> String -> Tokenizer TokenW
|
resTokenizer1 : Reserved1 -> String -> Tokenizer ExtToken
|
||||||
resTokenizer1 r str =
|
resTokenizer1 r str =
|
||||||
let res : String -> Token := const $ Reserved str in
|
let res : String -> Token := const $ Reserved str in
|
||||||
case r of Word w => match (exact w <+> reject idContEnd) res
|
case r of Word w => tmatch (exact w <+> reject idContEnd) res
|
||||||
Sym s => match (exact s <+> reject symCont) res
|
Sym s => tmatch (exact s <+> reject symCont) res
|
||||||
Punc x => match (is x) res
|
Punc x => tmatch (exact x) res
|
||||||
|
|
||||||
||| match a reserved token
|
||| match a reserved token
|
||||||
export
|
export
|
||||||
resTokenizer : Reserved -> Tokenizer TokenW
|
resTokenizer : Reserved -> Tokenizer ExtToken
|
||||||
resTokenizer (Only r) = resTokenizer1 r (resString1 r)
|
resTokenizer (Only r) = resTokenizer1 r (resString1 r)
|
||||||
resTokenizer (r `Or` s) =
|
resTokenizer (r `Or` s) =
|
||||||
resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
|
resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
|
||||||
|
@ -188,8 +246,8 @@ resTokenizer (r `Or` s) =
|
||||||
public export
|
public export
|
||||||
reserved : List Reserved
|
reserved : List Reserved
|
||||||
reserved =
|
reserved =
|
||||||
[Punc1 '(', Punc1 ')', Punc1 '[', Punc1 ']', Punc1 '{', Punc1 '}',
|
[Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}",
|
||||||
Punc1 ',', Punc1 ';',
|
Punc1 ",", Punc1 ";", Punc1 "#[", Punc1 "#![",
|
||||||
Sym1 "@",
|
Sym1 "@",
|
||||||
Sym1 ":",
|
Sym1 ":",
|
||||||
Sym "⇒" `Or` Sym "=>",
|
Sym "⇒" `Or` Sym "=>",
|
||||||
|
@ -197,12 +255,16 @@ reserved =
|
||||||
Sym "×" `Or` Sym "**",
|
Sym "×" `Or` Sym "**",
|
||||||
Sym "≡" `Or` Sym "==",
|
Sym "≡" `Or` Sym "==",
|
||||||
Sym "∷" `Or` Sym "::",
|
Sym "∷" `Or` Sym "::",
|
||||||
Punc1 '.',
|
Punc1 ".",
|
||||||
Word1 "case",
|
Word1 "case",
|
||||||
Word1 "case0", Word1 "case1",
|
Word1 "case0", Word1 "case1",
|
||||||
Word "caseω" `Or` Word "case#",
|
Word "caseω" `Or` Word "case#",
|
||||||
Word1 "return",
|
Word1 "return",
|
||||||
Word1 "of",
|
Word1 "of",
|
||||||
|
Word1 "let", Word1 "in",
|
||||||
|
Word1 "let0", Word1 "let1",
|
||||||
|
Word "letω" `Or` Word "let#",
|
||||||
|
Word1 "fst", Word1 "snd",
|
||||||
Word1 "_",
|
Word1 "_",
|
||||||
Word1 "Eq",
|
Word1 "Eq",
|
||||||
Word "λ" `Or` Word "fun",
|
Word "λ" `Or` Word "fun",
|
||||||
|
@ -210,35 +272,71 @@ reserved =
|
||||||
Word "ω" `Or` Sym "#",
|
Word "ω" `Or` Sym "#",
|
||||||
Sym "★" `Or` Word "Type",
|
Sym "★" `Or` Word "Type",
|
||||||
Word "ℕ" `Or` Word "Nat",
|
Word "ℕ" `Or` Word "Nat",
|
||||||
|
Word1 "IOState",
|
||||||
|
Word1 "String",
|
||||||
Word1 "zero", Word1 "succ",
|
Word1 "zero", Word1 "succ",
|
||||||
Word1 "coe", Word1 "comp",
|
Word1 "coe", Word1 "comp",
|
||||||
Word1 "def",
|
Word1 "def",
|
||||||
Word1 "def0",
|
Word1 "def0",
|
||||||
Word "defω" `Or` Word "def#",
|
Word "defω" `Or` Word "def#",
|
||||||
|
Word1 "postulate",
|
||||||
|
Word1 "postulate0",
|
||||||
|
Word "postulateω" `Or` Word "postulate#",
|
||||||
Sym1 "=",
|
Sym1 "=",
|
||||||
Word1 "load",
|
Word1 "load",
|
||||||
Word1 "namespace"]
|
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
|
||| `IsReserved str` is true if `Reserved str` might actually show up in
|
||||||
||| the token stream
|
||| the token stream
|
||||||
public export
|
public export
|
||||||
IsReserved : String -> Type
|
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
|
export
|
||||||
tokens : Tokenizer TokenW
|
tokens : Tokenizer ExtToken
|
||||||
tokens = choice $
|
tokens = choice $
|
||||||
map skip [pred isWhitespace,
|
map skip [pred isWhitespace,
|
||||||
lineComment (exact "--" <+> reject symCont),
|
lineComment (exact "--" <+> reject symCont),
|
||||||
blockComment (exact "{-") (exact "-}")] <+>
|
blockComment (exact "{-") (exact "-}")] <+>
|
||||||
[universe] <+> -- ★ᵢ takes precedence over bare ★
|
[universe] <+> -- Type<i> takes precedence over bare Type
|
||||||
map resTokenizer reserved <+>
|
map resTokenizer reserved <+>
|
||||||
[sup, nat, string, tag, name]
|
[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
|
export
|
||||||
lex : String -> Either Error (List (WithBounds Token))
|
lex : String -> Either Error (List (WithBounds Token))
|
||||||
lex str =
|
lex str =
|
||||||
let (res, reason, line, col, str) = lex tokens str in
|
let (res, reason, line, col, str) = lex tokens str in
|
||||||
case reason of
|
case toErrorReason reason of
|
||||||
EndInput => Right $ mapMaybe sequence res
|
Nothing => concatMap check res @{MonoidApplicative}
|
||||||
_ => Left $ Err {reason, line, col, char = index 0 str}
|
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
|
||| unqualified name
|
||||||
export
|
export
|
||||||
baseName : Grammar True PBaseName
|
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)
|
||| dimension constant (0 or 1)
|
||||||
export
|
export
|
||||||
|
@ -149,6 +149,12 @@ export
|
||||||
qty : FileName -> Grammar True PQty
|
qty : FileName -> Grammar True PQty
|
||||||
qty fname = withLoc fname [|PQ qtyVal|]
|
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 _)
|
||| pattern var (unqualified name or _)
|
||||||
export
|
export
|
||||||
|
@ -198,18 +204,21 @@ export
|
||||||
enumType : Grammar True (List TagVal)
|
enumType : Grammar True (List TagVal)
|
||||||
enumType = delimSep "{" "}" "," bareTag
|
enumType = delimSep "{" "}" "," bareTag
|
||||||
|
|
||||||
||| e.g. `case` or `case 1.`
|
||| e.g. `case1` or `case 1.`
|
||||||
export
|
export
|
||||||
caseIntro : FileName -> Grammar True PQty
|
caseIntro : FileName -> Grammar True PQty
|
||||||
caseIntro fname =
|
caseIntro fname =
|
||||||
withLoc fname (PQ Zero <$ res "case0")
|
withLoc fname (PQ Zero <$ res "case0")
|
||||||
<|> withLoc fname (PQ One <$ res "case1")
|
<|> withLoc fname (PQ One <$ res "case1")
|
||||||
<|> withLoc fname (PQ Any <$ res "caseω")
|
<|> withLoc fname (PQ Any <$ res "caseω")
|
||||||
<|> delim "case" "." (qty fname)
|
<|> do resC "case"
|
||||||
|
qty fname <* needRes "." <|> defLoc fname (PQ One)
|
||||||
|
|
||||||
export
|
export
|
||||||
qtyPatVar : FileName -> Grammar True (PQty, PatVar)
|
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
|
export
|
||||||
|
@ -277,19 +286,81 @@ export
|
||||||
universe1 : Grammar True Universe
|
universe1 : Grammar True Universe
|
||||||
universe1 = universeTok <|> res "★" *> option 0 super
|
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
|
export
|
||||||
termArg : FileName -> Grammar True PTerm
|
termArg : FileName -> Grammar True PTerm
|
||||||
termArg fname = withLoc fname $
|
termArg fname = withLoc fname $
|
||||||
[|TYPE universe1|]
|
[|TYPE universe1|]
|
||||||
|
<|> IOState <$ res "IOState"
|
||||||
<|> [|Enum enumType|]
|
<|> [|Enum enumType|]
|
||||||
<|> [|Tag tag|]
|
<|> [|Tag tag|]
|
||||||
<|> const <$> boxTerm fname
|
<|> const <$> boxTerm fname
|
||||||
<|> Nat <$ res "ℕ"
|
<|> NAT <$ res "ℕ"
|
||||||
<|> Zero <$ res "zero"
|
<|> Nat 0 <$ res "zero"
|
||||||
<|> [|fromNat nat|]
|
<|> [|Nat nat|]
|
||||||
|
<|> STRING <$ res "String"
|
||||||
|
<|> [|Str strLit|]
|
||||||
<|> [|V qname displacement|]
|
<|> [|V qname displacement|]
|
||||||
|
<|> const <$> caseTerm fname
|
||||||
<|> const <$> tupleTerm fname
|
<|> const <$> tupleTerm fname
|
||||||
|
|
||||||
export
|
export
|
||||||
|
@ -369,10 +440,10 @@ eqTerm : FileName -> Grammar True PTerm
|
||||||
eqTerm fname = withLoc fname $
|
eqTerm fname = withLoc fname $
|
||||||
resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (termArg fname)|]
|
resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (termArg fname)|]
|
||||||
|
|
||||||
export
|
private
|
||||||
succTerm : FileName -> Grammar True PTerm
|
appArg : Loc -> PTerm -> Either PDim PTerm -> PTerm
|
||||||
succTerm fname = withLoc fname $
|
appArg loc f (Left p) = DApp f p loc
|
||||||
resC "succ" *> mustWork [|Succ (termArg fname)|]
|
appArg loc f (Right s) = App f s loc
|
||||||
|
|
||||||
||| a dimension argument with an `@` prefix, or
|
||| a dimension argument with an `@` prefix, or
|
||||||
||| a term argument with no prefix
|
||| a term argument with no prefix
|
||||||
|
@ -380,15 +451,32 @@ export
|
||||||
anyArg : FileName -> Grammar True (Either PDim PTerm)
|
anyArg : FileName -> Grammar True (Either PDim PTerm)
|
||||||
anyArg fname = dimArg fname <||> termArg fname
|
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
|
export
|
||||||
normalAppTerm : FileName -> Grammar True PTerm
|
normalAppTerm : FileName -> Grammar True PTerm
|
||||||
normalAppTerm fname = withLoc fname $ do
|
normalAppTerm fname = withLoc fname $ do
|
||||||
head <- termArg fname
|
head <- termArg fname
|
||||||
args <- many $ anyArg fname
|
args <- many $ anyArg fname
|
||||||
pure $ \loc => foldl (ap loc) head args
|
pure $ \loc => foldl (appArg loc) head args
|
||||||
where ap : Loc -> PTerm -> Either PDim PTerm -> PTerm
|
|
||||||
ap loc f (Left p) = DApp f p loc
|
|
||||||
ap loc f (Right s) = App f s loc
|
|
||||||
|
|
||||||
||| application term `f x @y z`, or other terms that look like application
|
||| application term `f x @y z`, or other terms that look like application
|
||||||
||| like `succ` or `coe`.
|
||| like `succ` or `coe`.
|
||||||
|
@ -400,6 +488,8 @@ appTerm fname =
|
||||||
<|> splitUniverseTerm fname
|
<|> splitUniverseTerm fname
|
||||||
<|> eqTerm fname
|
<|> eqTerm fname
|
||||||
<|> succTerm fname
|
<|> succTerm fname
|
||||||
|
<|> fstTerm fname
|
||||||
|
<|> sndTerm fname
|
||||||
<|> normalAppTerm fname
|
<|> normalAppTerm fname
|
||||||
|
|
||||||
export
|
export
|
||||||
|
@ -438,18 +528,6 @@ properBinders fname = assert_total $ do
|
||||||
t <- term fname; needRes ")"
|
t <- term fname; needRes ")"
|
||||||
pure (xs, t)
|
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
|
export
|
||||||
sigmaTerm : FileName -> Grammar True PTerm
|
sigmaTerm : FileName -> Grammar True PTerm
|
||||||
sigmaTerm fname =
|
sigmaTerm fname =
|
||||||
|
@ -470,105 +548,320 @@ where
|
||||||
rest <- optional $ resC "×" *> sepBy1 (res "×") (annTerm fname)
|
rest <- optional $ resC "×" *> sepBy1 (res "×") (annTerm fname)
|
||||||
pure $ foldr1 cross $ fst ::: maybe [] toList rest
|
pure $ foldr1 cross $ fst ::: maybe [] toList rest
|
||||||
|
|
||||||
public export
|
export
|
||||||
PCaseArm : Type
|
piTerm : FileName -> Grammar True PTerm
|
||||||
PCaseArm = (PCasePat, 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
|
export
|
||||||
caseArm : FileName -> Grammar True PCaseArm
|
letIntro : FileName -> Grammar True (Maybe PQty)
|
||||||
caseArm fname =
|
letIntro fname =
|
||||||
[|(,) (casePat fname) (needRes "⇒" *> assert_total term 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
|
export
|
||||||
checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody
|
letTerm : FileName -> Grammar True PTerm
|
||||||
checkCaseArms loc [] = pure $ CaseEnum [] loc
|
letTerm fname = withLoc fname $ do
|
||||||
checkCaseArms loc ((PPair x y _, rhs) :: rest) =
|
qty <- letIntro fname
|
||||||
if null rest then pure $ CasePair (x, y) rhs loc
|
binds <- sepEndBy1 (res ";") $ assert_total letBinder fname qty
|
||||||
else fatalError "unexpected pattern after pair"
|
mustWork $ resC "in"
|
||||||
checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do
|
body <- assert_total term fname
|
||||||
let rest = for rest $ \case
|
pure $ \loc => foldr (\b, s => Let b s loc) body binds
|
||||||
(PTag tag _, rhs) => Just (tag, rhs)
|
|
||||||
_ => Nothing
|
|
||||||
maybe (fatalError "expected all patterns to be tags")
|
|
||||||
(\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest
|
|
||||||
checkCaseArms loc ((PZero _, rhs1) :: rest) = do
|
|
||||||
let [(PSucc p q ih _, rhs2)] = rest
|
|
||||||
| _ => fatalError "expected succ pattern after zero"
|
|
||||||
pure $ CaseNat rhs1 (p, q, ih, rhs2) loc
|
|
||||||
checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do
|
|
||||||
let [(PZero _, rhs2)] = rest
|
|
||||||
| _ => fatalError "expected zero pattern after succ"
|
|
||||||
pure $ CaseNat rhs2 (p, q, ih, rhs1) loc
|
|
||||||
checkCaseArms loc ((PBox x _, rhs) :: rest) =
|
|
||||||
if null rest then pure $ CaseBox x rhs loc
|
|
||||||
else fatalError "unexpected pattern after box"
|
|
||||||
|
|
||||||
export
|
|
||||||
caseBody : FileName -> Grammar True PCaseBody
|
|
||||||
caseBody fname = do
|
|
||||||
body <- bounds $ delimSep "{" "}" ";" $ caseArm fname
|
|
||||||
let loc = makeLoc fname body.bounds
|
|
||||||
checkCaseArms loc body.val
|
|
||||||
|
|
||||||
export
|
|
||||||
caseReturn : FileName -> Grammar True (PatVar, PTerm)
|
|
||||||
caseReturn fname = do
|
|
||||||
x <- patVar fname <* resC "⇒" <|> unused fname
|
|
||||||
ret <- assert_total term fname
|
|
||||||
pure (x, ret)
|
|
||||||
|
|
||||||
export
|
|
||||||
caseTerm : FileName -> Grammar True PTerm
|
|
||||||
caseTerm fname = withLoc fname $ do
|
|
||||||
qty <- caseIntro fname; commit
|
|
||||||
head <- mustWork $ assert_total term fname; needRes "return"
|
|
||||||
ret <- mustWork $ caseReturn fname; needRes "of"
|
|
||||||
body <- mustWork $ caseBody fname
|
|
||||||
pure $ Case qty head ret body
|
|
||||||
|
|
||||||
-- export
|
|
||||||
-- term : FileName -> Grammar True PTerm
|
-- term : FileName -> Grammar True PTerm
|
||||||
term fname = lamTerm fname
|
term fname = lamTerm fname
|
||||||
<|> caseTerm fname
|
|
||||||
<|> piTerm fname
|
<|> piTerm fname
|
||||||
<|> sigmaTerm fname
|
<|> sigmaTerm fname
|
||||||
|
<|> letTerm fname
|
||||||
|
|
||||||
|
|
||||||
export
|
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
|
export
|
||||||
defIntro : FileName -> Grammar True PQty
|
findDups : List PAttr -> List String
|
||||||
defIntro fname =
|
findDups attrs =
|
||||||
withLoc fname (PQ Zero <$ resC "def0")
|
SortedSet.toList $ snd $ foldl check (empty, empty) attrs
|
||||||
<|> withLoc fname (PQ Any <$ resC "defω")
|
where
|
||||||
<|> do pos <- bounds $ resC "def"
|
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
|
let any = PQ Any $ makeLoc fname pos.bounds
|
||||||
option any $ qty fname <* needRes "."
|
option any $ qty fname <* needRes "."
|
||||||
|
|
||||||
export
|
export
|
||||||
definition : FileName -> Grammar True PDefinition
|
defIntro : FileName -> Grammar True PQty
|
||||||
definition fname = withLoc fname $ do
|
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
|
qty <- defIntro fname
|
||||||
name <- baseName
|
name <- baseName
|
||||||
type <- optional $ resC ":" *> mustWork (term fname)
|
type <- optional $ resC ":" *> mustWork (term fname)
|
||||||
term <- needRes "=" *> mustWork (term fname)
|
term <- needRes "=" *> mustWork (term fname)
|
||||||
optRes ";"
|
optRes ";"
|
||||||
pure $ MkPDef qty name type term
|
either fatalError pure $ mkPDef attrs qty name $ PConcrete type term
|
||||||
|
|
||||||
export
|
export
|
||||||
namespace_ : FileName -> Grammar True PNamespace
|
definition : FileName -> List PAttr -> Grammar True PDefinition
|
||||||
namespace_ fname = withLoc fname $ do
|
definition fname attrs =
|
||||||
ns <- resC "namespace" *> qname; needRes "{"
|
try (postulate fname attrs) <|> concrete fname attrs
|
||||||
decls <- nsInner; optRes ";"
|
|
||||||
pure $ MkPNamespace (ns.mods :< ns.base) decls
|
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
|
where
|
||||||
nsInner : Grammar True (List PDecl)
|
nsInner : Grammar True (List PDecl)
|
||||||
nsInner = [] <$ resC "}"
|
nsInner = [] <$ resC "}"
|
||||||
<|> [|(assert_total decl fname <* commit) :: assert_total nsInner|]
|
<|> [|(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
|
export
|
||||||
load : FileName -> Grammar True PTopLevel
|
load : FileName -> Grammar True PTopLevel
|
||||||
|
@ -580,7 +873,7 @@ topLevel : FileName -> Grammar True PTopLevel
|
||||||
topLevel fname = load fname <|> [|PD $ decl fname|]
|
topLevel fname = load fname <|> [|PD $ decl fname|]
|
||||||
|
|
||||||
export
|
export
|
||||||
input : FileName -> Grammar False (List PTopLevel)
|
input : FileName -> Grammar False PFile
|
||||||
input fname = [] <$ eof
|
input fname = [] <$ eof
|
||||||
<|> [|(topLevel fname <* commit) :: assert_total input fname|]
|
<|> [|(topLevel fname <* commit) :: assert_total input fname|]
|
||||||
|
|
||||||
|
@ -589,5 +882,5 @@ lexParseTerm : FileName -> String -> Either Error PTerm
|
||||||
lexParseTerm = lexParseWith . term
|
lexParseTerm = lexParseWith . term
|
||||||
|
|
||||||
export
|
export
|
||||||
lexParseInput : FileName -> String -> Either Error (List PTopLevel)
|
lexParseInput : FileName -> String -> Either Error PFile
|
||||||
lexParseInput = lexParseWith . input
|
lexParseInput = lexParseWith . input
|
||||||
|
|
|
@ -3,6 +3,8 @@ module Quox.Parser.Syntax
|
||||||
import public Quox.Loc
|
import public Quox.Loc
|
||||||
import public Quox.Syntax
|
import public Quox.Syntax
|
||||||
import public Quox.Definition
|
import public Quox.Definition
|
||||||
|
import Quox.PrettyValExtra
|
||||||
|
import public Quox.Log
|
||||||
|
|
||||||
import Derive.Prelude
|
import Derive.Prelude
|
||||||
%hide TT.Name
|
%hide TT.Name
|
||||||
|
@ -14,9 +16,9 @@ import Derive.Prelude
|
||||||
public export
|
public export
|
||||||
data PatVar = Unused Loc | PV PBaseName Loc
|
data PatVar = Unused Loc | PV PBaseName Loc
|
||||||
%name PatVar v
|
%name PatVar v
|
||||||
%runElab derive "PatVar" [Eq, Ord, Show]
|
%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
|
||||||
|
|
||||||
export
|
export %inline
|
||||||
Located PatVar where
|
Located PatVar where
|
||||||
(Unused loc).loc = loc
|
(Unused loc).loc = loc
|
||||||
(PV _ loc).loc = loc
|
(PV _ loc).loc = loc
|
||||||
|
@ -38,17 +40,17 @@ record PQty where
|
||||||
val : Qty
|
val : Qty
|
||||||
loc_ : Loc
|
loc_ : Loc
|
||||||
%name PQty qty
|
%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
|
namespace PDim
|
||||||
public export
|
public export
|
||||||
data PDim = K DimConst Loc | V PBaseName Loc
|
data PDim = K DimConst Loc | V PBaseName Loc
|
||||||
%name PDim p, q
|
%name PDim p, q
|
||||||
%runElab derive "PDim" [Eq, Ord, Show]
|
%runElab derive "PDim" [Eq, Ord, Show, PrettyVal]
|
||||||
|
|
||||||
export
|
export %inline
|
||||||
Located PDim where
|
Located PDim where
|
||||||
(K _ loc).loc = loc
|
(K _ loc).loc = loc
|
||||||
(V _ loc).loc = loc
|
(V _ loc).loc = loc
|
||||||
|
@ -56,7 +58,7 @@ Located PDim where
|
||||||
public export
|
public export
|
||||||
data PTagVal = PT TagVal Loc
|
data PTagVal = PT TagVal Loc
|
||||||
%name PTagVal tag
|
%name PTagVal tag
|
||||||
%runElab derive "PTagVal" [Eq, Ord, Show]
|
%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
|
||||||
|
|
||||||
|
|
||||||
namespace PTerm
|
namespace PTerm
|
||||||
|
@ -66,6 +68,8 @@ namespace PTerm
|
||||||
data PTerm =
|
data PTerm =
|
||||||
TYPE Universe Loc
|
TYPE Universe Loc
|
||||||
|
|
||||||
|
| IOState Loc
|
||||||
|
|
||||||
| Pi PQty PatVar PTerm PTerm Loc
|
| Pi PQty PatVar PTerm PTerm Loc
|
||||||
| Lam PatVar PTerm Loc
|
| Lam PatVar PTerm Loc
|
||||||
| App PTerm PTerm Loc
|
| App PTerm PTerm Loc
|
||||||
|
@ -73,6 +77,7 @@ namespace PTerm
|
||||||
| Sig PatVar PTerm PTerm Loc
|
| Sig PatVar PTerm PTerm Loc
|
||||||
| Pair PTerm PTerm Loc
|
| Pair PTerm PTerm Loc
|
||||||
| Case PQty PTerm (PatVar, PTerm) PCaseBody Loc
|
| Case PQty PTerm (PatVar, PTerm) PCaseBody Loc
|
||||||
|
| Fst PTerm Loc | Snd PTerm Loc
|
||||||
|
|
||||||
| Enum (List TagVal) Loc
|
| Enum (List TagVal) Loc
|
||||||
| Tag TagVal Loc
|
| Tag TagVal Loc
|
||||||
|
@ -81,8 +86,11 @@ namespace PTerm
|
||||||
| DLam PatVar PTerm Loc
|
| DLam PatVar PTerm Loc
|
||||||
| DApp PTerm PDim Loc
|
| DApp PTerm PDim Loc
|
||||||
|
|
||||||
| Nat Loc
|
| NAT Loc
|
||||||
| Zero Loc | Succ PTerm Loc
|
| Nat Nat Loc | Succ PTerm Loc
|
||||||
|
|
||||||
|
| STRING Loc -- "String" is a reserved word in idris
|
||||||
|
| Str String Loc
|
||||||
|
|
||||||
| BOX PQty PTerm Loc
|
| BOX PQty PTerm Loc
|
||||||
| Box PTerm Loc
|
| Box PTerm Loc
|
||||||
|
@ -93,6 +101,8 @@ namespace PTerm
|
||||||
| Coe (PatVar, PTerm) PDim PDim PTerm Loc
|
| Coe (PatVar, PTerm) PDim PDim PTerm Loc
|
||||||
| Comp (PatVar, PTerm) PDim PDim PTerm PDim
|
| Comp (PatVar, PTerm) PDim PDim PTerm PDim
|
||||||
(PatVar, PTerm) (PatVar, PTerm) Loc
|
(PatVar, PTerm) (PatVar, PTerm) Loc
|
||||||
|
|
||||||
|
| Let (PQty, PatVar, PTerm) PTerm Loc
|
||||||
%name PTerm s, t
|
%name PTerm s, t
|
||||||
|
|
||||||
public export
|
public export
|
||||||
|
@ -103,33 +113,43 @@ namespace PTerm
|
||||||
| CaseBox PatVar PTerm Loc
|
| CaseBox PatVar PTerm Loc
|
||||||
%name PCaseBody body
|
%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
|
Located PTerm where
|
||||||
(TYPE _ loc).loc = loc
|
(TYPE _ loc).loc = loc
|
||||||
|
(IOState loc).loc = loc
|
||||||
(Pi _ _ _ _ loc).loc = loc
|
(Pi _ _ _ _ loc).loc = loc
|
||||||
(Lam _ _ loc).loc = loc
|
(Lam _ _ loc).loc = loc
|
||||||
(App _ _ loc).loc = loc
|
(App _ _ loc).loc = loc
|
||||||
(Sig _ _ _ loc).loc = loc
|
(Sig _ _ _ loc).loc = loc
|
||||||
(Pair _ _ loc).loc = loc
|
(Pair _ _ loc).loc = loc
|
||||||
|
(Fst _ loc).loc = loc
|
||||||
|
(Snd _ loc).loc = loc
|
||||||
(Case _ _ _ _ loc).loc = loc
|
(Case _ _ _ _ loc).loc = loc
|
||||||
(Enum _ loc).loc = loc
|
(Enum _ loc).loc = loc
|
||||||
(Tag _ loc).loc = loc
|
(Tag _ loc).loc = loc
|
||||||
(Eq _ _ _ loc).loc = loc
|
(Eq _ _ _ loc).loc = loc
|
||||||
(DLam _ _ loc).loc = loc
|
(DLam _ _ loc).loc = loc
|
||||||
(DApp _ _ loc).loc = loc
|
(DApp _ _ loc).loc = loc
|
||||||
(Nat loc).loc = loc
|
(NAT loc).loc = loc
|
||||||
(Zero loc).loc = loc
|
(Nat _ loc).loc = loc
|
||||||
(Succ _ loc).loc = loc
|
(Succ _ loc).loc = loc
|
||||||
|
(STRING loc).loc = loc
|
||||||
|
(Str _ loc).loc = loc
|
||||||
(BOX _ _ loc).loc = loc
|
(BOX _ _ loc).loc = loc
|
||||||
(Box _ loc).loc = loc
|
(Box _ loc).loc = loc
|
||||||
(V _ _ loc).loc = loc
|
(V _ _ loc).loc = loc
|
||||||
(Ann _ _ loc).loc = loc
|
(Ann _ _ loc).loc = loc
|
||||||
(Coe _ _ _ _ loc).loc = loc
|
(Coe _ _ _ _ loc).loc = loc
|
||||||
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
||||||
|
(Let _ _ loc).loc = loc
|
||||||
|
|
||||||
export
|
export %inline
|
||||||
Located PCaseBody where
|
Located PCaseBody where
|
||||||
(CasePair _ _ loc).loc = loc
|
(CasePair _ _ loc).loc = loc
|
||||||
(CaseEnum _ loc).loc = loc
|
(CaseEnum _ loc).loc = loc
|
||||||
|
@ -137,18 +157,45 @@ Located PCaseBody where
|
||||||
(CaseBox _ _ loc).loc = loc
|
(CaseBox _ _ loc).loc = loc
|
||||||
|
|
||||||
|
|
||||||
|
public export
|
||||||
|
data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm
|
||||||
|
%name PBody body
|
||||||
|
%runElab derive "PBody" [Eq, Ord, Show, PrettyVal]
|
||||||
|
|
||||||
|
|
||||||
|
public export
|
||||||
|
data PFail =
|
||||||
|
PSucceed
|
||||||
|
| PFailAny
|
||||||
|
| PFailMatch String
|
||||||
|
%runElab derive "PFail" [Eq, Ord, Show, PrettyVal]
|
||||||
|
|
||||||
public export
|
public export
|
||||||
record PDefinition where
|
record PDefinition where
|
||||||
constructor MkPDef
|
constructor MkPDef
|
||||||
qty : PQty
|
qty : PQty
|
||||||
name : PBaseName
|
name : PBaseName
|
||||||
type : Maybe PTerm
|
body : PBody
|
||||||
term : PTerm
|
fail : PFail
|
||||||
|
main : Bool
|
||||||
|
scheme : Maybe String
|
||||||
loc_ : Loc
|
loc_ : Loc
|
||||||
%name PDefinition def
|
%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
|
mutual
|
||||||
public export
|
public export
|
||||||
|
@ -156,6 +203,7 @@ mutual
|
||||||
constructor MkPNamespace
|
constructor MkPNamespace
|
||||||
name : Mods
|
name : Mods
|
||||||
decls : List PDecl
|
decls : List PDecl
|
||||||
|
fail : PFail
|
||||||
loc_ : Loc
|
loc_ : Loc
|
||||||
%name PNamespace ns
|
%name PNamespace ns
|
||||||
|
|
||||||
|
@ -163,28 +211,41 @@ mutual
|
||||||
data PDecl =
|
data PDecl =
|
||||||
PDef PDefinition
|
PDef PDefinition
|
||||||
| PNs PNamespace
|
| PNs PNamespace
|
||||||
|
| PPrag PPragma
|
||||||
%name PDecl decl
|
%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
|
Located PDecl where
|
||||||
(PDef def).loc = def.loc
|
(PDef d).loc = d.loc
|
||||||
(PNs ns).loc = ns.loc
|
(PNs ns).loc = ns.loc
|
||||||
|
(PPrag prag).loc = prag.loc
|
||||||
|
|
||||||
public export
|
public export
|
||||||
data PTopLevel = PD PDecl | PLoad String Loc
|
data PTopLevel = PD PDecl | PLoad String Loc
|
||||||
%name PTopLevel t
|
%name PTopLevel t
|
||||||
%runElab derive "PTopLevel" [Eq, Ord, Show]
|
%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal]
|
||||||
|
|
||||||
export
|
export %inline
|
||||||
Located PTopLevel where
|
Located PTopLevel where
|
||||||
(PD decl).loc = decl.loc
|
(PD decl).loc = decl.loc
|
||||||
(PLoad _ loc).loc = loc
|
(PLoad _ loc).loc = loc
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
fromNat : Nat -> Loc -> PTerm
|
record PAttr where
|
||||||
fromNat 0 loc = Zero loc
|
constructor PA
|
||||||
fromNat (S k) loc = Succ (fromNat k loc) loc
|
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.Loc
|
||||||
import Quox.Name
|
import Quox.Name
|
||||||
|
|
||||||
|
import Control.Monad.ST.Extra
|
||||||
import public Text.PrettyPrint.Bernardy
|
import public Text.PrettyPrint.Bernardy
|
||||||
import public Text.PrettyPrint.Bernardy.Core.Decorate
|
import public Text.PrettyPrint.Bernardy.Core.Decorate
|
||||||
import public Quox.EffExtra
|
import public Quox.EffExtra
|
||||||
|
@ -40,7 +41,7 @@ data HL
|
||||||
| Dim | DVar | DVarErr
|
| Dim | DVar | DVarErr
|
||||||
| Qty | Universe
|
| Qty | Universe
|
||||||
| Syntax
|
| Syntax
|
||||||
| Tag
|
| Constant
|
||||||
%runElab derive "HL" [Eq, Ord, Show]
|
%runElab derive "HL" [Eq, Ord, Show]
|
||||||
|
|
||||||
|
|
||||||
|
@ -65,11 +66,12 @@ export %inline
|
||||||
runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
|
runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
|
||||||
Eff Pretty a -> a
|
Eff Pretty a -> a
|
||||||
runPrettyWith prec flavor highlight indent act =
|
runPrettyWith prec flavor highlight indent act =
|
||||||
extract $
|
runST $ do
|
||||||
evalStateAt PREC prec $
|
runEff act $ with Union.(::)
|
||||||
runReaderAt FLAVOR flavor $
|
[handleStateSTRef !(newSTRef prec),
|
||||||
runReaderAt HIGHLIGHT highlight $
|
handleReaderConst flavor,
|
||||||
runReaderAt INDENT indent act
|
handleReaderConst highlight,
|
||||||
|
handleReaderConst indent]
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
|
@ -84,43 +86,65 @@ toSGR DVarErr = [SetForeground BrightGreen, SetStyle SingleUnderline]
|
||||||
toSGR Qty = [SetForeground BrightMagenta]
|
toSGR Qty = [SetForeground BrightMagenta]
|
||||||
toSGR Universe = [SetForeground BrightRed]
|
toSGR Universe = [SetForeground BrightRed]
|
||||||
toSGR Syntax = [SetForeground BrightCyan]
|
toSGR Syntax = [SetForeground BrightCyan]
|
||||||
toSGR Tag = [SetForeground BrightRed]
|
toSGR Constant = [SetForeground BrightRed]
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
highlightSGR : HL -> Highlight
|
highlightSGR : HL -> Highlight
|
||||||
highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
|
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
|
export %inline
|
||||||
runPretty : Eff Pretty a -> a
|
runPretty : Eff Pretty a -> a
|
||||||
runPretty = runPrettyWith Outer Unicode noHighlight 2
|
runPretty = runPrettyHL noHighlight
|
||||||
|
|
||||||
export %inline
|
|
||||||
runPrettyColor : Eff Pretty a -> a
|
|
||||||
runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
|
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
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
|
hl h doc = asksAt HIGHLIGHT $ \f => decorate (f h) doc
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
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
|
indentD doc = pure $ indent !(askAt INDENT) doc
|
||||||
|
|
||||||
export %inline
|
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
|
hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
hangDSingle : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
|
hangSingle : {opts : LayoutOpts} -> Nat -> Doc opts -> Doc opts -> Doc opts
|
||||||
hangDSingle d1 d2 =
|
hangSingle n d1 d2 = ifMultiline (d1 <++> d2) (vappend d1 (indent n d2))
|
||||||
pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2))
|
|
||||||
|
export %inline
|
||||||
|
hangDSingle : {opts : LayoutOpts} -> Doc opts -> Doc opts ->
|
||||||
|
Eff Pretty (Doc opts)
|
||||||
|
hangDSingle d1 d2 = pure $ hangSingle !(askAt INDENT) d1 d2
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
tightDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
|
tightDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
|
||||||
Eff Pretty (Doc opts)
|
Eff Pretty (Doc opts)
|
||||||
tightDelims l r inner = do
|
tightDelims l r inner = do
|
||||||
l <- hl Delim $ text l
|
l <- hl Delim $ text l
|
||||||
|
@ -128,7 +152,7 @@ tightDelims l r inner = do
|
||||||
pure $ hcat [l, inner, r]
|
pure $ hcat [l, inner, r]
|
||||||
|
|
||||||
export
|
export
|
||||||
looseDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
|
looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
|
||||||
Eff Pretty (Doc opts)
|
Eff Pretty (Doc opts)
|
||||||
looseDelims l r inner = do
|
looseDelims l r inner = do
|
||||||
l <- hl Delim $ text l
|
l <- hl Delim $ text l
|
||||||
|
@ -138,39 +162,39 @@ looseDelims l r inner = do
|
||||||
pure $ ifMultiline short long
|
pure $ ifMultiline short long
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
parens : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||||
parens = tightDelims "(" ")"
|
parens = tightDelims "(" ")"
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
bracks : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||||
bracks = tightDelims "[" "]"
|
bracks = tightDelims "[" "]"
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
braces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||||
braces = looseDelims "{" "}"
|
braces = looseDelims "{" "}"
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
tightBraces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||||
tightBraces = tightDelims "{" "}"
|
tightBraces = tightDelims "{" "}"
|
||||||
|
|
||||||
export %inline
|
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 True = parens
|
||||||
parensIf False = pure
|
parensIf False = pure
|
||||||
|
|
||||||
|
|
||||||
||| uses hsep only if the whole list fits on one line
|
||| uses hsep only if the whole list fits on one line
|
||||||
export
|
export
|
||||||
sepSingle : {opts : _} -> List (Doc opts) -> Doc opts
|
sepSingle : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
|
||||||
sepSingle xs = ifMultiline (hsep xs) (vsep xs)
|
sepSingle xs = ifMultiline (hsep xs) (vsep xs)
|
||||||
|
|
||||||
export
|
export
|
||||||
fillSep : {opts : _} -> List (Doc opts) -> Doc opts
|
fillSep : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
|
||||||
fillSep [] = empty
|
fillSep [] = empty
|
||||||
fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
|
fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
|
||||||
|
|
||||||
export
|
export
|
||||||
exceptLast : {opts : _} -> (Doc opts -> Doc opts) ->
|
exceptLast : {opts : LayoutOpts} -> (Doc opts -> Doc opts) ->
|
||||||
List (Doc opts) -> List (Doc opts)
|
List (Doc opts) -> List (Doc opts)
|
||||||
exceptLast f [] = []
|
exceptLast f [] = []
|
||||||
exceptLast f [x] = [x]
|
exceptLast f [x] = [x]
|
||||||
|
@ -185,11 +209,24 @@ parameters {opts : LayoutOpts} {auto _ : Foldable t}
|
||||||
separateTight : Doc opts -> t (Doc opts) -> Doc opts
|
separateTight : Doc opts -> t (Doc opts) -> Doc opts
|
||||||
separateTight d = sep . exceptLast (<+> d) . toList
|
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
|
export
|
||||||
fillSeparateTight : Doc opts -> t (Doc opts) -> Doc opts
|
fillSeparateTight : Doc opts -> t (Doc opts) -> Doc opts
|
||||||
fillSeparateTight d = fillSep . exceptLast (<+> d) . toList
|
fillSeparateTight d = fillSep . exceptLast (<+> d) . toList
|
||||||
|
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
pshow : {opts : LayoutOpts} -> Show a => a -> Doc opts
|
||||||
|
pshow = text . show
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a
|
ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a
|
||||||
ifUnicode uni asc =
|
ifUnicode uni asc =
|
||||||
|
@ -198,7 +235,7 @@ ifUnicode uni asc =
|
||||||
Ascii => asc
|
Ascii => asc
|
||||||
|
|
||||||
export %inline
|
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
|
parensIfM d doc = parensIf (!(getAt PREC) > d) doc
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
|
@ -211,64 +248,73 @@ prettyName : Name -> Doc opts
|
||||||
prettyName = text . toDots
|
prettyName = text . toDots
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyFree : {opts : _} -> Name -> Eff Pretty (Doc opts)
|
prettyFree : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts)
|
||||||
prettyFree = hl Free . prettyName
|
prettyFree = hl Free . prettyName
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyBind' : BindName -> Doc opts
|
prettyBind' : BindName -> Doc opts
|
||||||
prettyBind' = text . baseStr . name
|
prettyBind' = text . baseStr . val
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyTBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
|
prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
|
||||||
prettyTBind = hl TVar . prettyBind'
|
prettyTBind = hl TVar . prettyBind'
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyDBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
|
prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
|
||||||
prettyDBind = hl DVar . prettyBind'
|
prettyDBind = hl DVar . prettyBind'
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
|
typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
|
||||||
eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
|
stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD,
|
||||||
ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD :
|
zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD :
|
||||||
{opts : _} -> Eff Pretty (Doc opts)
|
{opts : LayoutOpts} -> Eff Pretty (Doc opts)
|
||||||
typeD = hl Syntax . text =<< ifUnicode "★" "Type"
|
typeD = hl Syntax . text =<< ifUnicode "★" "Type"
|
||||||
arrowD = hl Delim . text =<< ifUnicode "→" "->"
|
ioStateD = hl Syntax $ text "IOState"
|
||||||
darrowD = hl Delim . text =<< ifUnicode "⇒" "=>"
|
arrowD = hl Syntax . text =<< ifUnicode "→" "->"
|
||||||
timesD = hl Delim . text =<< ifUnicode "×" "**"
|
darrowD = hl Syntax . text =<< ifUnicode "⇒" "=>"
|
||||||
|
timesD = hl Syntax . text =<< ifUnicode "×" "**"
|
||||||
lamD = hl Syntax . text =<< ifUnicode "λ" "fun"
|
lamD = hl Syntax . text =<< ifUnicode "λ" "fun"
|
||||||
eqndD = hl Delim . text =<< ifUnicode "≡" "=="
|
eqndD = hl Syntax . text =<< ifUnicode "≡" "=="
|
||||||
dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun"
|
dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun"
|
||||||
annD = hl Delim . text =<< ifUnicode "∷" "::"
|
annD = hl Syntax . text =<< ifUnicode "∷" "::"
|
||||||
natD = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
|
natD = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
|
||||||
|
stringD = hl Syntax $ text "String"
|
||||||
eqD = hl Syntax $ text "Eq"
|
eqD = hl Syntax $ text "Eq"
|
||||||
colonD = hl Delim $ text ":"
|
colonD = hl Syntax $ text ":"
|
||||||
commaD = hl Delim $ text ","
|
commaD = hl Syntax $ text ","
|
||||||
semiD = hl Delim $ text ";"
|
semiD = hl Delim $ text ";"
|
||||||
|
atD = hl Delim $ text "@"
|
||||||
caseD = hl Syntax $ text "case"
|
caseD = hl Syntax $ text "case"
|
||||||
typecaseD = hl Syntax $ text "type-case"
|
typecaseD = hl Syntax $ text "type-case"
|
||||||
ofD = hl Syntax $ text "of"
|
ofD = hl Syntax $ text "of"
|
||||||
returnD = hl Syntax $ text "return"
|
returnD = hl Syntax $ text "return"
|
||||||
dotD = hl Delim $ text "."
|
dotD = hl Delim $ text "."
|
||||||
zeroD = hl Syntax $ text "zero"
|
zeroD = hl Constant $ text "zero"
|
||||||
succD = hl Syntax $ text "succ"
|
succD = hl Constant $ text "succ"
|
||||||
coeD = hl Syntax $ text "coe"
|
coeD = hl Syntax $ text "coe"
|
||||||
compD = hl Syntax $ text "comp"
|
compD = hl Syntax $ text "comp"
|
||||||
undD = hl Syntax $ text "_"
|
undD = hl Syntax $ text "_"
|
||||||
cstD = 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
|
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 =
|
prettyApp ind f args =
|
||||||
hsep (f :: args)
|
ifMultiline
|
||||||
<|> hsep [f, vsep args]
|
(hsep (f :: args))
|
||||||
<|> vsep (f :: map (indent ind) args)
|
(f <++> vsep args <|> vsep (f :: map (indent ind) args))
|
||||||
|
|
||||||
export
|
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
|
prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
|
||||||
|
|
||||||
|
|
||||||
|
@ -288,7 +334,7 @@ quoteTag tag =
|
||||||
"\"" ++ escapeString tag ++ "\""
|
"\"" ++ escapeString tag ++ "\""
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyBounds : {opts : _} -> Bounds -> Eff Pretty (Doc opts)
|
prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
|
||||||
prettyBounds (MkBounds l1 c1 l2 c2) =
|
prettyBounds (MkBounds l1 c1 l2 c2) =
|
||||||
hcat <$> sequence
|
hcat <$> sequence
|
||||||
[hl TVar $ text $ show l1, colonD,
|
[hl TVar $ text $ show l1, colonD,
|
||||||
|
@ -297,8 +343,22 @@ prettyBounds (MkBounds l1 c1 l2 c2) =
|
||||||
hl DVar $ text $ show c2, colonD]
|
hl DVar $ text $ show c2, colonD]
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyLoc : {opts : _} -> Loc -> Eff Pretty (Doc opts)
|
prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
|
||||||
prettyLoc (L NoLoc) =
|
prettyLoc (L NoLoc) =
|
||||||
hcat <$> sequence [hl TVarErr "no location", colonD]
|
hcat <$> sequence [hl TVarErr "no location", colonD]
|
||||||
prettyLoc (L (YesLoc file b)) =
|
prettyLoc (L (YesLoc file b)) =
|
||||||
hcat <$> sequence [hl Free $ text file, colonD, prettyBounds 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.Shift
|
||||||
import public Quox.Syntax.Subst
|
import public Quox.Syntax.Subst
|
||||||
import public Quox.Syntax.Term
|
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.Loc
|
||||||
import Quox.Name
|
import Quox.Name
|
||||||
import Quox.Syntax.Var
|
import Quox.Var
|
||||||
import Quox.Syntax.Subst
|
import Quox.Syntax.Subst
|
||||||
import Quox.Pretty
|
import Quox.Pretty
|
||||||
import Quox.Context
|
import Quox.Context
|
||||||
|
import Quox.PrettyValExtra
|
||||||
|
|
||||||
import Decidable.Equality
|
import Decidable.Equality
|
||||||
import Control.Function
|
import Control.Function
|
||||||
|
@ -18,7 +19,7 @@ import Derive.Prelude
|
||||||
public export
|
public export
|
||||||
data DimConst = Zero | One
|
data DimConst = Zero | One
|
||||||
%name DimConst e
|
%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`.
|
||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
|
||||||
public export
|
public export
|
||||||
|
|
|
@ -1,11 +1,12 @@
|
||||||
module Quox.Syntax.DimEq
|
module Quox.Syntax.DimEq
|
||||||
|
|
||||||
import public Quox.Syntax.Var
|
import public Quox.Var
|
||||||
import public Quox.Syntax.Dim
|
import public Quox.Syntax.Dim
|
||||||
import public Quox.Syntax.Subst
|
import public Quox.Syntax.Subst
|
||||||
import public Quox.Context
|
import public Quox.Context
|
||||||
import Quox.Pretty
|
import Quox.Pretty
|
||||||
import Quox.Name
|
import Quox.Name
|
||||||
|
import Quox.FreeVars
|
||||||
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Nat
|
import Data.Nat
|
||||||
|
@ -58,10 +59,15 @@ Traversable (IfConsistent eqs) where
|
||||||
traverse f Nothing = pure Nothing
|
traverse f Nothing = pure Nothing
|
||||||
traverse f (Just x) = Just <$> f x
|
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
|
public export
|
||||||
ifConsistent : Applicative f => (eqs : DimEq d) -> f a -> f (IfConsistent eqs a)
|
ifConsistent : Applicative f => (eqs : DimEq d) -> f a -> f (IfConsistent eqs a)
|
||||||
ifConsistent ZeroIsOne act = pure Nothing
|
ifConsistent eqs act = ifConsistentElse eqs act (pure ())
|
||||||
ifConsistent (C _) act = Just <$> act
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
toMaybe : IfConsistent eqs a -> Maybe a
|
toMaybe : IfConsistent eqs a -> Maybe a
|
||||||
|
@ -70,13 +76,13 @@ toMaybe (Just x) = Just x
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
fromGround' : Context' DimConst d -> DimEq' d
|
fromGround' : BContext d -> Context' DimConst d -> DimEq' d
|
||||||
fromGround' [<] = [<]
|
fromGround' [<] [<] = [<]
|
||||||
fromGround' (ctx :< e) = fromGround' ctx :< Just (K e noLoc)
|
fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
|
||||||
|
|
||||||
export
|
export
|
||||||
fromGround : Context' DimConst d -> DimEq d
|
fromGround : BContext d -> Context' DimConst d -> DimEq d
|
||||||
fromGround = C . fromGround'
|
fromGround = C .: fromGround'
|
||||||
|
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
|
@ -117,7 +123,7 @@ equal ZeroIsOne p q = True
|
||||||
equal (C eqs) p q = get eqs p == get eqs q
|
equal (C eqs) p q = get eqs p == get eqs q
|
||||||
|
|
||||||
|
|
||||||
infixl 7 :<?
|
export infixl 7 :<?
|
||||||
export %inline
|
export %inline
|
||||||
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
|
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
|
||||||
ZeroIsOne :<? d = ZeroIsOne
|
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)
|
C (eqs :< _) => Just (eqs, K e loc ::: id)
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
split : Loc -> DimEq' (S d) -> List (Split d)
|
split1' : DimConst -> Loc -> DimEq' (S d) -> List (Split d)
|
||||||
split loc eqs = toList (split1 Zero loc eqs) <+> toList (split1 One loc eqs)
|
split1' e loc eqs = toList $ split1 e loc eqs
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
split : Loc -> DimEq' (S d) -> Bool -> List (Split d)
|
||||||
|
split loc eqs False = split1' Zero loc eqs
|
||||||
|
split loc eqs True = split1' Zero loc eqs <+> split1' One loc eqs
|
||||||
|
|
||||||
export
|
export
|
||||||
splits' : Loc -> DimEq' d -> List (DSubst d 0)
|
splits' : Loc -> DimEq' d -> FreeVars d -> List (DSubst d 0)
|
||||||
splits' _ [<] = [id]
|
splits' _ [<] _ = [id]
|
||||||
splits' loc eqs@(_ :< _) =
|
splits' loc eqs@(_ :< _) us = do
|
||||||
[th . ph | (eqs', th) <- split loc eqs, ph <- splits' loc eqs']
|
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
|
||| the Loc is put into each of the DimConsts
|
||||||
export %inline
|
export %inline
|
||||||
splits : Loc -> DimEq d -> List (DSubst d 0)
|
splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
|
||||||
splits _ ZeroIsOne = []
|
splits _ ZeroIsOne _ = []
|
||||||
splits loc (C eqs) = splits' loc eqs
|
splits loc (C eqs) fvs = splits' loc eqs fvs
|
||||||
|
|
||||||
|
|
||||||
private
|
private
|
||||||
|
@ -228,9 +242,20 @@ setSelf (B i _) (C eqs) with (compareP i i) | (compare i.nat i.nat)
|
||||||
_ | IsGT gt | GT = absurd gt
|
_ | 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
|
private
|
||||||
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
|
prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
|
||||||
prettyDVars = traverse prettyDBind . toSnocList'
|
prettyDVars' = traverse prettyDBind . toSnocList'
|
||||||
|
|
||||||
|
export
|
||||||
|
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
|
||||||
|
prettyDVars vars =
|
||||||
|
parensIfM (dimEqPrec vars Nothing) $
|
||||||
|
fillSeparateTight !commaD $ !(prettyDVars' vars)
|
||||||
|
|
||||||
private
|
private
|
||||||
prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
|
prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
|
||||||
|
@ -247,16 +272,16 @@ prettyCsts dnames (eqs :< Just q) =
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
|
prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
|
||||||
prettyDimEq' dnames eqs = do
|
prettyDimEq' vars eqs = do
|
||||||
vars <- prettyDVars dnames
|
vars' <- prettyDVars' vars
|
||||||
eqs <- prettyCsts dnames eqs
|
eqs' <- prettyCsts vars eqs
|
||||||
let prec = if length vars <= 1 && null eqs then Arg else Outer
|
parensIfM (dimEqPrec vars (Just eqs)) $
|
||||||
parensIfM prec $ fillSeparateTight !commaD $ toList vars ++ toList eqs
|
fillSeparateTight !commaD $ vars' ++ eqs'
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
|
prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
|
||||||
prettyDimEq dnames ZeroIsOne = do
|
prettyDimEq dnames ZeroIsOne = do
|
||||||
vars <- prettyDVars dnames
|
vars <- prettyDVars' dnames
|
||||||
cst <- prettyCst [<] (K Zero noLoc) (K One noLoc)
|
cst <- prettyCst [<] (K Zero noLoc) (K One noLoc)
|
||||||
pure $ separateTight !commaD $ vars :< cst
|
pure $ separateTight !commaD $ vars :< cst
|
||||||
prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
|
prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
|
||||||
|
|
|
@ -6,6 +6,7 @@ module Quox.Syntax.Qty
|
||||||
|
|
||||||
import Quox.Pretty
|
import Quox.Pretty
|
||||||
import Quox.Decidable
|
import Quox.Decidable
|
||||||
|
import Quox.PrettyValExtra
|
||||||
import Data.DPair
|
import Data.DPair
|
||||||
import Derive.Prelude
|
import Derive.Prelude
|
||||||
|
|
||||||
|
@ -20,7 +21,7 @@ import Derive.Prelude
|
||||||
||| - ω (or #): don't care. an ω variable *can* also be used 0/1 time
|
||| - ω (or #): don't care. an ω variable *can* also be used 0/1 time
|
||||||
public export
|
public export
|
||||||
data Qty = Zero | One | Any
|
data Qty = Zero | One | Any
|
||||||
%runElab derive "Qty" [Eq, Ord, Show]
|
%runElab derive "Qty" [Eq, Ord, Show, PrettyVal]
|
||||||
%name Qty.Qty pi, rh
|
%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
|
||| to maintain subject reduction, only 0 or 1 can occur
|
||||||
||| for the subject of a typing judgment. see @qtt, §2.3 for more detail
|
||| for the subject of a typing judgment. see @qtt, §2.3 for more detail
|
||||||
public export
|
public export
|
||||||
isSubj : Qty -> Bool
|
data SQty = SZero | SOne
|
||||||
isSubj Zero = True
|
%runElab derive "SQty" [Eq, Ord, Show, PrettyVal]
|
||||||
isSubj One = True
|
%name Qty.SQty sg
|
||||||
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
|
|
||||||
|
|
||||||
||| "σ ⨴ π"
|
||| "σ ⨴ π"
|
||||||
|||
|
|||
|
||||||
||| σ ⨭ π is 0 if either of σ or π are, otherwise it is σ.
|
||| σ ⨴ π is 0 if either of σ or π are, otherwise it is σ.
|
||||||
public export
|
public export
|
||||||
subjMult : SQty -> Qty -> SQty
|
subjMult : SQty -> Qty -> SQty
|
||||||
subjMult _ Zero = szero
|
subjMult _ Zero = SZero
|
||||||
subjMult sg _ = sg
|
subjMult sg _ = sg
|
||||||
|
|
||||||
|
|
||||||
|
@ -105,23 +96,59 @@ subjMult sg _ = sg
|
||||||
||| quantity of 1, so the only distinction is whether it is present
|
||| quantity of 1, so the only distinction is whether it is present
|
||||||
||| at runtime at all or not
|
||| at runtime at all or not
|
||||||
public export
|
public export
|
||||||
isGlobal : Qty -> Bool
|
data GQty = GZero | GAny
|
||||||
isGlobal Zero = True
|
%runElab derive "GQty" [Eq, Ord, Show, PrettyVal]
|
||||||
isGlobal One = False
|
%name GQty rh
|
||||||
isGlobal Any = True
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
GQty : Type
|
toGlobal : Qty -> Maybe GQty
|
||||||
GQty = Subset Qty $ So . isGlobal
|
toGlobal Zero = Just GZero
|
||||||
|
toGlobal Any = Just GAny
|
||||||
public export
|
toGlobal One = Nothing
|
||||||
gzero, gany : GQty
|
|
||||||
gzero = Element Zero Oh
|
|
||||||
gany = Element Any Oh
|
|
||||||
|
|
||||||
||| when checking a definition, a 0 definition is checked at 0,
|
||| when checking a definition, a 0 definition is checked at 0,
|
||||||
||| but an ω definition is checked at 1 since ω isn't a subject quantity
|
||| but an ω definition is checked at 1 since ω isn't a subject quantity
|
||||||
public export %inline
|
public export %inline
|
||||||
globalToSubj : GQty -> SQty
|
globalToSubj : GQty -> SQty
|
||||||
globalToSubj (Element Zero _) = szero
|
globalToSubj GZero = SZero
|
||||||
globalToSubj (Element Any _) = sone
|
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
|
module Quox.Syntax.Shift
|
||||||
|
|
||||||
import public Quox.Syntax.Var
|
import public Quox.Var
|
||||||
|
|
||||||
import Data.Nat
|
import Data.Nat
|
||||||
import Data.So
|
import Data.So
|
||||||
|
import Data.Singleton
|
||||||
|
import Syntax.PreorderReasoning
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
|
|
||||||
|
@ -146,6 +148,25 @@ weakViaNat s by =
|
||||||
%transform "Shift.weak" Shift.weak = weakViaNat
|
%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
|
public export
|
||||||
shift : Shift from to -> Var from -> Var to
|
shift : Shift from to -> Var from -> Var to
|
||||||
shift SZ i = i
|
shift SZ i = i
|
||||||
|
@ -178,11 +199,12 @@ by . SS bz = SS $ by . bz
|
||||||
private
|
private
|
||||||
0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
|
0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||||
to = by.nat + bz.nat + from
|
to = by.nat + bz.nat + from
|
||||||
compNatProof by bz =
|
compNatProof by bz = Calc $
|
||||||
trans (shiftDiff bz) $
|
|~ to
|
||||||
trans (cong (bz.nat +) (shiftDiff by)) $
|
~~ bz.nat + mid ...(shiftDiff {})
|
||||||
trans (plusAssociative bz.nat by.nat from) $
|
~~ bz.nat + (by.nat + from) ...(cong (bz.nat +) (shiftDiff {}))
|
||||||
cong (+ from) (plusCommutative bz.nat by.nat)
|
~~ bz.nat + by.nat + from ...(plusAssociative {})
|
||||||
|
~~ by.nat + bz.nat + from ...(cong (+ from) (plusCommutative {}))
|
||||||
|
|
||||||
private %inline
|
private %inline
|
||||||
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
|
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||||
|
@ -205,7 +227,7 @@ compViaNatCorrect by (SS bz) =
|
||||||
%transform "Shift.(.)" Shift.(.) = compViaNat
|
%transform "Shift.(.)" Shift.(.) = compViaNat
|
||||||
|
|
||||||
|
|
||||||
infixl 8 //
|
export infixl 8 //
|
||||||
public export
|
public export
|
||||||
interface CanShift f where
|
interface CanShift f where
|
||||||
(//) : f from -> Shift from to -> f to
|
(//) : f from -> Shift from to -> f to
|
||||||
|
|
|
@ -1,12 +1,13 @@
|
||||||
module Quox.Syntax.Subst
|
module Quox.Syntax.Subst
|
||||||
|
|
||||||
import public Quox.Syntax.Shift
|
import public Quox.Syntax.Shift
|
||||||
import Quox.Syntax.Var
|
import Quox.Var
|
||||||
import Quox.Name
|
import Quox.Name
|
||||||
|
|
||||||
import Data.Nat
|
import Data.Nat
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.SnocVect
|
import Data.SnocVect
|
||||||
|
import Data.Singleton
|
||||||
import Derive.Prelude
|
import Derive.Prelude
|
||||||
|
|
||||||
%default total
|
%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
|
(:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
|
||||||
%name Subst th, ph, ps
|
%name Subst th, ph, ps
|
||||||
|
|
||||||
infixr 7 !:::
|
export infixr 7 !:::
|
||||||
||| in case the automatic laziness insertion gets confused
|
||| in case the automatic laziness insertion gets confused
|
||||||
public export
|
public export
|
||||||
(!:::) : env to -> Subst env from to -> Subst env (S from) to
|
(!:::) : 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
|
export Show (f to) => Show (Subst f from to) where show = show . repr
|
||||||
|
|
||||||
|
|
||||||
infixl 8 //
|
export infixl 8 //
|
||||||
public export
|
public export
|
||||||
interface FromVar term => CanSubstSelf term where
|
interface FromVar term => CanSubstSelf term where
|
||||||
(//) : term from -> Lazy (Subst term from to) -> term to
|
(//) : 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
|
public export %inline
|
||||||
push : CanSubstSelf f => Subst f from to -> Subst f (S from) (S to)
|
push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
|
||||||
push th = fromVar VZ ::: (th . shift 1)
|
push loc th = fromVarLoc VZ loc ::: (th . shift 1)
|
||||||
|
|
||||||
-- [fixme] a better way to do this?
|
-- [fixme] a better way to do this?
|
||||||
public export
|
public export
|
||||||
pushN : CanSubstSelf f => (s : Nat) ->
|
pushN : CanSubstSelf f => (s : Nat) -> Loc ->
|
||||||
Subst f from to -> Subst f (s + from) (s + to)
|
Subst f from to -> Subst f (s + from) (s + to)
|
||||||
pushN 0 th = th
|
pushN 0 _ th = th
|
||||||
pushN (S s) th =
|
pushN (S s) loc th =
|
||||||
rewrite plusSuccRightSucc s from in
|
rewrite plusSuccRightSucc s from in
|
||||||
rewrite plusSuccRightSucc s to in
|
rewrite plusSuccRightSucc s to in
|
||||||
pushN s $ fromVar VZ ::: (th . shift 1)
|
pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
|
||||||
|
|
||||||
public export
|
public export
|
||||||
drop1 : Subst f (S from) to -> Subst f from to
|
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]
|
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
|
||| 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
|
||| (the same number of terms and the same shift at the end). if so, they
|
||||||
||| also have the same domain
|
||| 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 by) (Shift bz) = cmpLen by bz
|
||||||
cmpShape (Shift _) (_ ::: _) = Left LT
|
cmpShape (Shift _) (_ ::: _) = Left LT
|
||||||
cmpShape (_ ::: _) (Shift _) = Left GT
|
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
|
public export
|
||||||
|
|
|
@ -3,4 +3,3 @@ module Quox.Syntax.Term
|
||||||
import public Quox.Syntax.Term.Base
|
import public Quox.Syntax.Term.Base
|
||||||
import public Quox.Syntax.Term.Subst
|
import public Quox.Syntax.Term.Subst
|
||||||
import public Quox.Syntax.Term.Pretty
|
import public Quox.Syntax.Term.Pretty
|
||||||
import public Quox.Syntax.Term.Tighten
|
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
module Quox.Syntax.Term.Base
|
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.Shift
|
||||||
import public Quox.Syntax.Subst
|
import public Quox.Syntax.Subst
|
||||||
import public Quox.Syntax.Qty
|
import public Quox.Syntax.Qty
|
||||||
|
@ -46,39 +47,6 @@ TagVal : Type
|
||||||
TagVal = String
|
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
|
mutual
|
||||||
public export
|
public export
|
||||||
TSubst : TSubstLike
|
TSubst : TSubstLike
|
||||||
|
@ -91,6 +59,10 @@ mutual
|
||||||
||| type of types
|
||| type of types
|
||||||
TYPE : (l : Universe) -> (loc : Loc) -> Term d n
|
TYPE : (l : Universe) -> (loc : Loc) -> Term d n
|
||||||
|
|
||||||
|
||| IO state token. this is a builtin because otherwise #[main] being a
|
||||||
|
||| builtin makes no sense
|
||||||
|
IOState : (loc : Loc) -> Term d n
|
||||||
|
|
||||||
||| function type
|
||| function type
|
||||||
Pi : (qty : Qty) -> (arg : Term d n) ->
|
Pi : (qty : Qty) -> (arg : Term d n) ->
|
||||||
(res : ScopeTerm d n) -> (loc : Loc) -> 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
|
DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||||
|
|
||||||
||| natural numbers (temporary until 𝐖 gets added)
|
||| natural numbers (temporary until 𝐖 gets added)
|
||||||
Nat : (loc : Loc) -> Term d n
|
NAT : (loc : Loc) -> Term d n
|
||||||
-- [todo] can these be elims?
|
Nat : (val : Nat) -> (loc : Loc) -> Term d n
|
||||||
Zero : (loc : Loc) -> Term d n
|
|
||||||
Succ : (p : Term d n) -> (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" (package a value up with a certain quantity)
|
||||||
BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
|
BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
|
||||||
Box : (val : 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
|
||| elimination
|
||||||
E : (e : Elim d n) -> Term d n
|
E : (e : Elim d n) -> Term d n
|
||||||
|
|
||||||
|
@ -155,6 +133,12 @@ mutual
|
||||||
(loc : Loc) ->
|
(loc : Loc) ->
|
||||||
Elim d n
|
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
|
||| enum matching
|
||||||
CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
|
CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
|
||||||
(ret : ScopeTerm d n) ->
|
(ret : ScopeTerm d n) ->
|
||||||
|
@ -250,23 +234,123 @@ mutual
|
||||||
ShowElim : Show (Elim d n)
|
ShowElim : Show (Elim d n)
|
||||||
ShowElim = assert_total {a = Show (Elim d n)} deriveShow
|
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
|
export
|
||||||
public export %inline
|
Located (Elim d n) where
|
||||||
SY : BContext s -> f (s + n) -> Scoped s f n
|
(F _ _ loc).loc = loc
|
||||||
SY ns = S ns . Y
|
(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
|
export
|
||||||
name : Scoped 1 f n -> BindName
|
Located (Term d n) where
|
||||||
name (S [< x] _) = x
|
(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
|
||| more convenient Pi
|
||||||
public export %inline
|
public export %inline
|
||||||
|
@ -314,6 +398,12 @@ public export %inline
|
||||||
DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
|
DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
|
||||||
DLamN {body, loc} = DLam {body = SN body, loc}
|
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
|
||| non dependent equality type
|
||||||
public export %inline
|
public export %inline
|
||||||
Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
|
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 : Name -> Universe -> Loc -> Term d n
|
||||||
FT x u loc = E $ F x u loc
|
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
|
||| abbreviation for a bound variable like `BV 4` instead of
|
||||||
||| `B (VS (VS (VS (VS VZ))))`
|
||| `B (VS (VS (VS (VS VZ))))`
|
||||||
public export %inline
|
public export %inline
|
||||||
|
@ -335,10 +430,9 @@ public export %inline
|
||||||
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
|
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
|
||||||
BVT i loc = E $ BV i loc
|
BVT i loc = E $ BV i loc
|
||||||
|
|
||||||
public export
|
public export %inline
|
||||||
makeNat : Nat -> Loc -> Term d n
|
Zero : Loc -> Term d n
|
||||||
makeNat 0 loc = Zero loc
|
Zero = Nat 0
|
||||||
makeNat (S k) loc = Succ (makeNat k loc) loc
|
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
enum : List TagVal -> Loc -> Term d n
|
enum : List TagVal -> Loc -> Term d n
|
||||||
|
@ -353,111 +447,6 @@ public export %inline
|
||||||
typeCase1Y : Elim d n -> Term d n ->
|
typeCase1Y : Elim d n -> Term d n ->
|
||||||
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
|
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
|
||||||
(loc : Loc) ->
|
(loc : Loc) ->
|
||||||
{default (Nat loc) def : Term d n} ->
|
{default (NAT loc) def : Term d n} ->
|
||||||
Elim d n
|
Elim d n
|
||||||
typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc
|
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
|
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
|
private
|
||||||
superscript : String -> String
|
superscript : String -> String
|
||||||
superscript = pack . map sup . unpack where
|
superscript = pack . map sup . unpack where
|
||||||
|
@ -209,8 +201,7 @@ prettyTArg dnames tnames s =
|
||||||
|
|
||||||
private
|
private
|
||||||
prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
|
prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
|
||||||
prettyDArg dnames p =
|
prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
|
||||||
map (text "@" <+>) $ withPrec Arg $ prettyDim dnames p
|
|
||||||
|
|
||||||
private
|
private
|
||||||
splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
|
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
|
private
|
||||||
record CaseArm opts d n where
|
record CaseArm opts d n where
|
||||||
constructor MkCaseArm
|
constructor MkCaseArm
|
||||||
{0 dinner, ninner : Nat}
|
|
||||||
pat : Doc opts
|
pat : Doc opts
|
||||||
dbinds : BTelescope d dinner -- 🍴
|
dbinds : BTelescope d dinner -- 🍴
|
||||||
tbinds : BTelescope n ninner
|
tbinds : BTelescope n ninner
|
||||||
|
@ -251,12 +241,11 @@ parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
|
||||||
body <- withPrec Outer $ assert_total
|
body <- withPrec Outer $ assert_total
|
||||||
prettyTerm (dnames . dbinds) (tnames . tbinds) body
|
prettyTerm (dnames . dbinds) (tnames . tbinds) body
|
||||||
header <- (pat <++>) <$> darrowD
|
header <- (pat <++>) <$> darrowD
|
||||||
pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
|
pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
|
||||||
|
|
||||||
private
|
private
|
||||||
prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (Doc opts)
|
prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts))
|
||||||
prettyCaseBody xs =
|
prettyCaseBody xs = traverse prettyCaseArm xs
|
||||||
braces . separateTight !semiD =<< traverse prettyCaseArm xs
|
|
||||||
|
|
||||||
private
|
private
|
||||||
prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts)
|
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]])
|
[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
|
export
|
||||||
prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
|
prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
|
||||||
prettyEnum cases =
|
prettyEnum cases =
|
||||||
tightBraces =<<
|
tightBraces =<<
|
||||||
fillSeparateTight !commaD <$>
|
fillSeparateTight !commaD <$>
|
||||||
traverse (hl Tag . Doc.text . quoteTag) cases
|
traverse (hl Constant . Doc.text . quoteTag) cases
|
||||||
|
|
||||||
private
|
private
|
||||||
prettyCaseRet : {opts : _} ->
|
prettyCaseRet : {opts : _} ->
|
||||||
|
@ -303,7 +288,7 @@ prettyCaseRet dnames tnames body = withPrec Outer $ case body of
|
||||||
S [< x] (Y tm) => do
|
S [< x] (Y tm) => do
|
||||||
header <- [|prettyTBind x <++> darrowD|]
|
header <- [|prettyTBind x <++> darrowD|]
|
||||||
body <- assert_total prettyTerm dnames (tnames :< x) tm
|
body <- assert_total prettyTerm dnames (tnames :< x) tm
|
||||||
pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
|
hangDSingle header body
|
||||||
|
|
||||||
private
|
private
|
||||||
prettyCase_ : {opts : _} ->
|
prettyCase_ : {opts : _} ->
|
||||||
|
@ -311,10 +296,16 @@ prettyCase_ : {opts : _} ->
|
||||||
Doc opts -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) ->
|
Doc opts -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) ->
|
||||||
Eff Pretty (Doc opts)
|
Eff Pretty (Doc opts)
|
||||||
prettyCase_ dnames tnames intro head ret body = do
|
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
|
ret <- prettyCaseRet dnames tnames ret
|
||||||
body <- prettyCaseBody dnames tnames body
|
bodys <- prettyCaseBody dnames tnames body
|
||||||
parensIfM Outer $ sep [intro <++> head, !returnD <++> ret, !ofD <++> 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
|
private
|
||||||
prettyCase : {opts : _} ->
|
prettyCase : {opts : _} ->
|
||||||
|
@ -325,6 +316,62 @@ prettyCase dnames tnames qty head ret body =
|
||||||
prettyCase_ dnames tnames ![|caseD <+> prettyQty 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
|
private
|
||||||
isDefaultDir : Dim d -> Dim d -> Bool
|
isDefaultDir : Dim d -> Dim d -> Bool
|
||||||
isDefaultDir (K Zero _) (K One _) = True
|
isDefaultDir (K Zero _) (K One _) = True
|
||||||
|
@ -342,6 +389,7 @@ prettyTyCasePat : {opts : _} ->
|
||||||
(k : TyConKind) -> BContext (arity k) ->
|
(k : TyConKind) -> BContext (arity k) ->
|
||||||
Eff Pretty (Doc opts)
|
Eff Pretty (Doc opts)
|
||||||
prettyTyCasePat KTYPE [<] = typeD
|
prettyTyCasePat KTYPE [<] = typeD
|
||||||
|
prettyTyCasePat KIOState [<] = ioStateD
|
||||||
prettyTyCasePat KPi [< a, b] =
|
prettyTyCasePat KPi [< a, b] =
|
||||||
parens . hsep =<< sequence [prettyTBind a, arrowD, prettyTBind b]
|
parens . hsep =<< sequence [prettyTBind a, arrowD, prettyTBind b]
|
||||||
prettyTyCasePat KSig [< a, b] =
|
prettyTyCasePat KSig [< a, b] =
|
||||||
|
@ -350,6 +398,7 @@ prettyTyCasePat KEnum [<] = hl Syntax $ text "{}"
|
||||||
prettyTyCasePat KEq [< a0, a1, a, l, r] =
|
prettyTyCasePat KEq [< a0, a1, a, l, r] =
|
||||||
hsep <$> sequence (eqD :: map prettyTBind [a0, a1, a, l, r])
|
hsep <$> sequence (eqD :: map prettyTBind [a0, a1, a, l, r])
|
||||||
prettyTyCasePat KNat [<] = natD
|
prettyTyCasePat KNat [<] = natD
|
||||||
|
prettyTyCasePat KString [<] = stringD
|
||||||
prettyTyCasePat KBOX [< a] = bracks =<< prettyTBind a
|
prettyTyCasePat KBOX [< a] = bracks =<< prettyTBind a
|
||||||
|
|
||||||
|
|
||||||
|
@ -383,13 +432,13 @@ prettyDisp u = map Just $ hl Universe =<<
|
||||||
ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
|
ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
|
||||||
|
|
||||||
|
|
||||||
prettyTerm dnames tnames (TYPE l _) =
|
prettyTerm dnames tnames (TYPE l _) = do
|
||||||
case !(askAt FLAVOR) of
|
type <- hl Syntax . text =<< ifUnicode "★" "Type"
|
||||||
Unicode => do
|
level <- prettyDisp l
|
||||||
star <- hl Syntax "★"
|
pure $ maybe type (type <+>) level
|
||||||
level <- hl Universe $ text $ superscript $ show l
|
|
||||||
pure $ hcat [star, level]
|
prettyTerm dnames tnames (IOState _) =
|
||||||
Ascii => [|hl Syntax "Type" <++> hl Universe (text $ show l)|]
|
ioStateD
|
||||||
|
|
||||||
prettyTerm dnames tnames (Pi qty arg res _) =
|
prettyTerm dnames tnames (Pi qty arg res _) =
|
||||||
parensIfM Outer =<< do
|
parensIfM Outer =<< do
|
||||||
|
@ -426,13 +475,15 @@ prettyTerm dnames tnames (Enum cases _) =
|
||||||
prettyTerm dnames tnames (Tag tag _) =
|
prettyTerm dnames tnames (Tag tag _) =
|
||||||
prettyTag 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
|
l <- withPrec InEq $ prettyTerm dnames tnames l
|
||||||
r <- withPrec InEq $ prettyTerm dnames tnames r
|
r <- withPrec InEq $ prettyTerm dnames tnames r
|
||||||
ty <- withPrec InEq $ prettyTerm dnames tnames ty
|
ty <- withPrec InEq $ prettyTerm dnames tnames ty
|
||||||
pure $ sep [l <++> !eqndD, r <++> !colonD, 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
|
ty <- prettyTypeLine dnames tnames ty
|
||||||
l <- withPrec Arg $ prettyTerm dnames tnames l
|
l <- withPrec Arg $ prettyTerm dnames tnames l
|
||||||
r <- withPrec Arg $ prettyTerm dnames tnames r
|
r <- withPrec Arg $ prettyTerm dnames tnames r
|
||||||
|
@ -441,20 +492,14 @@ prettyTerm dnames tnames (Eq ty l r _) = do
|
||||||
prettyTerm dnames tnames s@(DLam {}) =
|
prettyTerm dnames tnames s@(DLam {}) =
|
||||||
prettyLambda dnames tnames s
|
prettyLambda dnames tnames s
|
||||||
|
|
||||||
prettyTerm dnames tnames (Nat _) = natD
|
prettyTerm dnames tnames (NAT _) = natD
|
||||||
prettyTerm dnames tnames (Zero _) = hl Syntax "0"
|
prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n
|
||||||
prettyTerm dnames tnames (Succ p _) = do
|
prettyTerm dnames tnames (Succ p _) =
|
||||||
succD <- succD
|
parensIfM App =<<
|
||||||
let succ : Doc opts -> Eff Pretty (Doc opts)
|
prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)]
|
||||||
succ t = prettyAppD succD [t]
|
|
||||||
toNat : Term d n -> Eff Pretty (Either (Doc opts) Nat)
|
prettyTerm dnames tnames (STRING _) = stringD
|
||||||
toNat s with (pushSubsts' s)
|
prettyTerm dnames tnames (Str s _) = prettyStrLit s
|
||||||
_ | Zero _ = pure $ Right 0
|
|
||||||
_ | Succ d _ = bitraverse succ (pure . S) =<<
|
|
||||||
toNat (assert_smaller s d)
|
|
||||||
_ | s' = map Left . withPrec Arg $
|
|
||||||
prettyTerm dnames tnames $ assert_smaller s s'
|
|
||||||
either succ (hl Syntax . text . show . S) =<< toNat p
|
|
||||||
|
|
||||||
prettyTerm dnames tnames (BOX qty ty _) =
|
prettyTerm dnames tnames (BOX qty ty _) =
|
||||||
bracks . hcat =<<
|
bracks . hcat =<<
|
||||||
|
@ -464,7 +509,18 @@ prettyTerm dnames tnames (BOX qty ty _) =
|
||||||
prettyTerm dnames tnames (Box val _) =
|
prettyTerm dnames tnames (Box val _) =
|
||||||
bracks =<< withPrec Outer (prettyTerm dnames tnames 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 t0@(CloT (Sub t ph)) =
|
||||||
prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' id ph t
|
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
|
prettyCase dnames tnames qty pair ret
|
||||||
[MkCaseArm pat [<] [< x, y] body.term]
|
[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
|
prettyElim dnames tnames (CaseEnum qty tag ret arms _) = do
|
||||||
arms <- for (SortedMap.toList arms) $ \(tag, body) =>
|
arms <- for (SortedMap.toList arms) $ \(tag, body) =>
|
||||||
pure $ MkCaseArm !(prettyTag 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
|
[< p, ih] = succ.names
|
||||||
spat0 <- [|succD <++> prettyTBind p|]
|
spat0 <- [|succD <++> prettyTBind p|]
|
||||||
ihpat0 <- map hcat $ sequence [prettyQty qtyIH, dotD, prettyTBind ih]
|
ihpat0 <- map hcat $ sequence [prettyQty qtyIH, dotD, prettyTBind ih]
|
||||||
spat <- if ih.name == Unused
|
spat <- if ih.val == Unused
|
||||||
then pure spat0
|
then pure spat0
|
||||||
else pure $ hsep [spat0 <+> !commaD, ihpat0]
|
else pure $ hsep [spat0 <+> !commaD, ihpat0]
|
||||||
let sarm = MkCaseArm spat [<] [< p, ih] succ.term
|
let sarm = MkCaseArm spat [<] [< p, ih] succ.term
|
||||||
|
@ -517,17 +583,15 @@ prettyElim dnames tnames e@(DApp {}) =
|
||||||
prettyDTApps dnames tnames f xs
|
prettyDTApps dnames tnames f xs
|
||||||
|
|
||||||
prettyElim dnames tnames (Ann tm ty _) =
|
prettyElim dnames tnames (Ann tm ty _) =
|
||||||
parensIfM Outer =<<
|
case the (Term d n) (pushSubsts' tm) of
|
||||||
hangDSingle !(withPrec AnnL [|prettyTerm dnames tnames tm <++> annD|])
|
E e => assert_total prettyElim dnames tnames e
|
||||||
!(withPrec Outer (prettyTerm dnames tnames ty))
|
_ => 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 _) =
|
prettyElim dnames tnames (Coe ty p q val _) =
|
||||||
parensIfM App =<<
|
parensIfM App =<< do
|
||||||
if isDefaultDir p q then do
|
|
||||||
ty <- prettyTypeLine dnames tnames ty
|
|
||||||
val <- prettyTArg dnames tnames val
|
|
||||||
prettyAppD !coeD [ty, val]
|
|
||||||
else do
|
|
||||||
ty <- prettyTypeLine dnames tnames ty
|
ty <- prettyTypeLine dnames tnames ty
|
||||||
p <- prettyDArg dnames p
|
p <- prettyDArg dnames p
|
||||||
q <- prettyDArg dnames q
|
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 _) =
|
prettyElim dnames tnames e@(Comp ty p q val r zero one _) =
|
||||||
parensIfM App =<< do
|
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]
|
pq <- sep <$> sequence [prettyDArg dnames p, prettyDArg dnames q]
|
||||||
val <- prettyTArg dnames tnames val
|
val <- prettyTArg dnames tnames val
|
||||||
r <- prettyDArg dnames r
|
r <- prettyDArg dnames r
|
||||||
arm0 <- [|prettyCompArm dnames tnames Zero zero <+> semiD|]
|
arm0 <- [|prettyCompArm dnames tnames Zero zero <+> semiD|]
|
||||||
arm1 <- prettyCompArm dnames tnames One one
|
arm1 <- prettyCompArm dnames tnames One one
|
||||||
ind <- askAt INDENT
|
ind <- askAt INDENT
|
||||||
if isDefaultDir p q
|
layoutComp [ty, pq] val r [arm0, arm1]
|
||||||
then layoutComp [ty] val r [arm0, arm1]
|
|
||||||
else layoutComp [ty, pq] val r [arm0, arm1]
|
|
||||||
|
|
||||||
prettyElim dnames tnames (TypeCase ty ret arms def _) = do
|
prettyElim dnames tnames (TypeCase ty ret arms def _) = do
|
||||||
arms <- for (toList arms) $ \(k ** body) => do
|
arms <- for (toList arms) $ \(k ** body) => do
|
||||||
|
|
|
@ -2,7 +2,6 @@ module Quox.Syntax.Term.Subst
|
||||||
|
|
||||||
import Quox.No
|
import Quox.No
|
||||||
import Quox.Syntax.Term.Base
|
import Quox.Syntax.Term.Base
|
||||||
import Quox.Syntax.Term.Tighten
|
|
||||||
import Data.SnocVect
|
import Data.SnocVect
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
|
@ -57,12 +56,12 @@ namespace DSubst.DScopeTermN
|
||||||
(//) : {s : Nat} ->
|
(//) : {s : Nat} ->
|
||||||
DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
|
DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
|
||||||
DScopeTermN s d2 n
|
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
|
S ns (N body) // th = S ns $ N $ body // th
|
||||||
|
|
||||||
|
|
||||||
export %inline FromVar (Elim d) where fromVarLoc = B
|
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:
|
||| does the minimal reasonable work:
|
||||||
|
@ -105,7 +104,7 @@ namespace ScopeTermN
|
||||||
(//) : {s : Nat} ->
|
(//) : {s : Nat} ->
|
||||||
ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
|
ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
|
||||||
ScopeTermN s d 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
|
S ns (N body) // th = S ns $ N $ body // th
|
||||||
|
|
||||||
namespace DScopeTermN
|
namespace DScopeTermN
|
||||||
|
@ -118,6 +117,9 @@ namespace DScopeTermN
|
||||||
export %inline CanShift (Term d) where s // by = s // Shift by
|
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 (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
|
export %inline
|
||||||
{s : Nat} -> CanShift (ScopeTermN s d) where
|
{s : Nat} -> CanShift (ScopeTermN s d) where
|
||||||
b // by = b // Shift by
|
b // by = b // Shift by
|
||||||
|
@ -132,6 +134,15 @@ public export %inline
|
||||||
dweakT : (by : Nat) -> Term d n -> Term (by + d) n
|
dweakT : (by : Nat) -> Term d n -> Term (by + d) n
|
||||||
dweakT by t = t // shift by
|
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
|
public export %inline
|
||||||
dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
|
dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
|
||||||
dweakE by t = t // shift by
|
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 : Nat) -> Term d n -> Term d (by + n)
|
||||||
weakT by t = t // shift by
|
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
|
public export %inline
|
||||||
weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
|
weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
|
||||||
weakE by t = t // shift by
|
weakE by t = t // shift by
|
||||||
|
|
||||||
|
|
||||||
parameters {s : Nat}
|
parameters {auto _ : CanShift f} {s : Nat}
|
||||||
namespace ScopeTermBody
|
|
||||||
export %inline
|
export %inline
|
||||||
(.term) : ScopedBody s (Term d) n -> Term d (s + n)
|
getTerm : ScopedBody s f n -> f (s + n)
|
||||||
(Y b).term = b
|
getTerm (Y b) = b
|
||||||
(N b).term = weakT s b
|
getTerm (N b) = b // fromNat s
|
||||||
|
|
||||||
namespace ScopeTermN
|
|
||||||
export %inline
|
export %inline
|
||||||
(.term) : ScopeTermN s d n -> Term d (s + n)
|
(.term) : Scoped s f n -> f (s + n)
|
||||||
t.term = t.body.term
|
t.term = getTerm t.body
|
||||||
|
|
||||||
namespace DScopeTermBody
|
namespace ScopeTermBody
|
||||||
export %inline
|
export %inline
|
||||||
(.term) : ScopedBody s (\d => Term d n) d -> Term (s + d) n
|
getTerm0 : ScopedBody 0 f n -> f n
|
||||||
(Y b).term = b
|
getTerm0 (Y b) = b
|
||||||
(N b).term = dweakT s b
|
getTerm0 (N b) = b
|
||||||
|
|
||||||
namespace DScopeTermN
|
namespace ScopeTermN
|
||||||
export %inline
|
export %inline
|
||||||
(.term) : DScopeTermN s d n -> Term (s + d) n
|
(.term0) : Scoped 0 f n -> f n
|
||||||
t.term = t.body.term
|
t.term0 = getTerm0 t.body
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
|
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
|
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
|
body.zero = dsub1 body $ K Zero loc
|
||||||
|
|
||||||
public export %inline
|
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
|
body.one = dsub1 body $ K One loc
|
||||||
|
|
||||||
|
|
||||||
|
@ -202,6 +219,7 @@ public export
|
||||||
0 CloTest : TermLike -> Type
|
0 CloTest : TermLike -> Type
|
||||||
CloTest tm = forall d, n. tm d n -> Bool
|
CloTest tm = forall d, n. tm d n -> Bool
|
||||||
|
|
||||||
|
public export
|
||||||
interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
|
interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
|
||||||
pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
|
pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
|
||||||
tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
|
tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
|
||||||
|
@ -249,46 +267,8 @@ mutual
|
||||||
isCloE (DCloE {}) = True
|
isCloE (DCloE {}) = True
|
||||||
isCloE _ = False
|
isCloE _ = False
|
||||||
|
|
||||||
mutual
|
export
|
||||||
export
|
PushSubsts Elim Subst.isCloE where
|
||||||
PushSubsts Term Subst.isCloT where
|
|
||||||
pushSubstsWith th ph (TYPE l loc) =
|
|
||||||
nclo $ TYPE l loc
|
|
||||||
pushSubstsWith th ph (Pi qty a body loc) =
|
|
||||||
nclo $ Pi qty (a // th // ph) (body // th // ph) loc
|
|
||||||
pushSubstsWith th ph (Lam body loc) =
|
|
||||||
nclo $ Lam (body // th // ph) loc
|
|
||||||
pushSubstsWith th ph (Sig a b loc) =
|
|
||||||
nclo $ Sig (a // th // ph) (b // th // ph) loc
|
|
||||||
pushSubstsWith th ph (Pair s t loc) =
|
|
||||||
nclo $ Pair (s // th // ph) (t // th // ph) loc
|
|
||||||
pushSubstsWith th ph (Enum tags loc) =
|
|
||||||
nclo $ Enum tags loc
|
|
||||||
pushSubstsWith th ph (Tag tag loc) =
|
|
||||||
nclo $ Tag tag loc
|
|
||||||
pushSubstsWith th ph (Eq ty l r loc) =
|
|
||||||
nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
|
|
||||||
pushSubstsWith th ph (DLam body loc) =
|
|
||||||
nclo $ DLam (body // th // ph) loc
|
|
||||||
pushSubstsWith _ _ (Nat loc) =
|
|
||||||
nclo $ Nat loc
|
|
||||||
pushSubstsWith _ _ (Zero loc) =
|
|
||||||
nclo $ Zero loc
|
|
||||||
pushSubstsWith th ph (Succ n loc) =
|
|
||||||
nclo $ Succ (n // th // ph) loc
|
|
||||||
pushSubstsWith th ph (BOX pi ty loc) =
|
|
||||||
nclo $ BOX pi (ty // th // ph) loc
|
|
||||||
pushSubstsWith th ph (Box val loc) =
|
|
||||||
nclo $ Box (val // th // ph) loc
|
|
||||||
pushSubstsWith th ph (E e) =
|
|
||||||
let Element e nc = pushSubstsWith th ph e in nclo $ E e
|
|
||||||
pushSubstsWith th ph (CloT (Sub s ps)) =
|
|
||||||
pushSubstsWith th (comp th ps ph) s
|
|
||||||
pushSubstsWith th ph (DCloT (Sub s ps)) =
|
|
||||||
pushSubstsWith (ps . th) ph s
|
|
||||||
|
|
||||||
export
|
|
||||||
PushSubsts Elim Subst.isCloE where
|
|
||||||
pushSubstsWith th ph (F x u loc) =
|
pushSubstsWith th ph (F x u loc) =
|
||||||
nclo $ F x u loc
|
nclo $ F x u loc
|
||||||
pushSubstsWith th ph (B i loc) =
|
pushSubstsWith th ph (B i loc) =
|
||||||
|
@ -300,6 +280,10 @@ mutual
|
||||||
nclo $ App (f // th // ph) (s // th // ph) loc
|
nclo $ App (f // th // ph) (s // th // ph) loc
|
||||||
pushSubstsWith th ph (CasePair pi p r b loc) =
|
pushSubstsWith th ph (CasePair pi p r b loc) =
|
||||||
nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) 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) =
|
pushSubstsWith th ph (CaseEnum pi t r arms loc) =
|
||||||
nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
|
nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
|
||||||
(map (\b => b // th // ph) arms) loc
|
(map (\b => b // th // ph) arms) loc
|
||||||
|
@ -326,16 +310,61 @@ mutual
|
||||||
pushSubstsWith th ph (DCloE (Sub e ps)) =
|
pushSubstsWith th ph (DCloE (Sub e ps)) =
|
||||||
pushSubstsWith (ps . th) ph e
|
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
|
(r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
|
||||||
CompHY {ty, p, q, val, r, zero, one, loc} =
|
CompH' {ty, p, q, val, r, zero, one, loc} =
|
||||||
let ty' = SY ty.names $ ty.term // (B VZ ty.loc ::: shift 2) in
|
let ty' = SY ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
|
||||||
Comp {
|
Comp {
|
||||||
ty = dsub1 ty q, p, q,
|
ty = dsub1 ty q, p, q,
|
||||||
val = E $ Coe ty p q val val.loc, r,
|
val = E $ Coe ty p q val val.loc, r,
|
||||||
-- [fixme] better locations for these vars?
|
|
||||||
zero = SY zero.names $ E $
|
zero = SY zero.names $ E $
|
||||||
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
|
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
|
||||||
one = SY one.names $ E $
|
one = SY one.names $ E $
|
||||||
|
@ -343,33 +372,13 @@ CompHY {ty, p, q, val, r, zero, one, loc} =
|
||||||
loc
|
loc
|
||||||
}
|
}
|
||||||
|
|
||||||
public export %inline
|
||| heterogeneous comp, in terms of Comp and Coe
|
||||||
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₁
|
|
||||||
||| }
|
|
||||||
public export %inline
|
public export %inline
|
||||||
CompH : (i : BindName) -> (ty : Term (S d) n) ->
|
CompH : (i : BindName) -> (ty : Term (S d) n) ->
|
||||||
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
|
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
|
||||||
(j0 : BindName) -> (zero : Term (S d) n) ->
|
(j0 : BindName) -> (zero : Term (S d) n) ->
|
||||||
(j1 : BindName) -> (one : Term (S d) n) ->
|
(j1 : BindName) -> (one : Term (S d) n) ->
|
||||||
(loc : Loc) ->
|
(loc : Loc) -> Elim d n
|
||||||
Elim d n
|
|
||||||
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
|
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
|
||||||
CompH' {ty = SY [< i] ty, p, q, val, r,
|
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
|
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
|
%name TyConKind k
|
||||||
%runElab derive "TyConKind" [Eq.Eq, Ord.Ord, Show.Show, Generic, Meta, DecEq]
|
%runElab derive "TyConKind" [Eq.Eq, Ord.Ord, Show.Show, Generic, Meta, DecEq]
|
||||||
|
|
||||||
|
@ -26,9 +27,11 @@ allKinds = %runElab do
|
||||||
public export %inline
|
public export %inline
|
||||||
arity : TyConKind -> Nat
|
arity : TyConKind -> Nat
|
||||||
arity KTYPE = 0
|
arity KTYPE = 0
|
||||||
|
arity KIOState = 0
|
||||||
arity KPi = 2
|
arity KPi = 2
|
||||||
arity KSig = 2
|
arity KSig = 2
|
||||||
arity KEnum = 0
|
arity KEnum = 0
|
||||||
arity KEq = 5
|
arity KEq = 5
|
||||||
arity KNat = 0
|
arity KNat = 0
|
||||||
|
arity KString = 0
|
||||||
arity KBOX = 1
|
arity KBOX = 1
|
||||||
|
|
|
@ -3,6 +3,7 @@ module Quox.Typechecker
|
||||||
import public Quox.Typing
|
import public Quox.Typing
|
||||||
import public Quox.Equal
|
import public Quox.Equal
|
||||||
import Quox.Displace
|
import Quox.Displace
|
||||||
|
import Quox.Pretty
|
||||||
|
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.SnocVect
|
import Data.SnocVect
|
||||||
|
@ -13,25 +14,14 @@ import Quox.EffExtra
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
0 TCEff : List (Type -> Type)
|
0 TC : List (Type -> Type)
|
||||||
TCEff = [ErrorEff, DefsReader, NameGen]
|
TC = [ErrorEff, DefsReader, NameGen, Log]
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
|
|
||||||
parameters (loc : Loc)
|
parameters (loc : Loc)
|
||||||
export
|
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 [<] qout = pure qout
|
||||||
popQs (pis :< pi) (qout :< rh) = do expectCompatQ loc rh pi; popQs pis 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
|
lubs ctx (x :: xs) = lubs1 $ x ::: xs
|
||||||
|
|
||||||
|
|
||||||
export
|
private
|
||||||
typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe ->
|
prettyTermTC : {opts : LayoutOpts} ->
|
||||||
CtxExtension d n (arity k + n)
|
TyContext d n -> Term d n -> Eff Pretty (Doc opts)
|
||||||
typecaseTel k xs u = case k of
|
prettyTermTC ctx s = prettyTerm ctx.dnames ctx.tnames s
|
||||||
KTYPE => [<]
|
|
||||||
-- A : ★ᵤ, B : 0.A → ★ᵤ
|
|
||||||
KPi =>
|
|
||||||
let [< a, b] = xs in
|
|
||||||
[< (Zero, a, TYPE u a.loc),
|
|
||||||
(Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
|
|
||||||
KSig =>
|
|
||||||
let [< a, b] = xs in
|
|
||||||
[< (Zero, a, TYPE u a.loc),
|
|
||||||
(Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
|
|
||||||
KEnum => [<]
|
|
||||||
-- A₀ : ★ᵤ, A₁ : ★ᵤ, A : (A₀ ≡ A₁ : ★ᵤ), L : A₀, R : A₀
|
|
||||||
KEq =>
|
|
||||||
let [< a0, a1, a, l, r] = xs in
|
|
||||||
[< (Zero, a0, TYPE u a0.loc),
|
|
||||||
(Zero, a1, TYPE u a1.loc),
|
|
||||||
(Zero, a, Eq0 (TYPE u a.loc) (BVT 1 a.loc) (BVT 0 a.loc) a.loc),
|
|
||||||
(Zero, l, BVT 2 l.loc),
|
|
||||||
(Zero, r, BVT 2 r.loc)]
|
|
||||||
KNat => [<]
|
|
||||||
-- A : ★ᵤ
|
|
||||||
KBOX => let [< a] = xs in [< (Zero, a, TYPE u a.loc)]
|
|
||||||
|
|
||||||
|
|
||||||
|
private
|
||||||
|
checkLogs : String -> TyContext d n -> SQty ->
|
||||||
|
Term d n -> Maybe (Term d n) -> Eff TC ()
|
||||||
|
checkLogs fun ctx sg subj ty = do
|
||||||
|
let tyDoc = delay $ maybe (text "none") (runPretty . prettyTermTC ctx) ty
|
||||||
|
sayMany "check" subj.loc
|
||||||
|
[10 :> text fun,
|
||||||
|
95 :> hsep ["ctx =", runPretty $ prettyTyContext ctx],
|
||||||
|
95 :> hsep ["sg =", runPretty $ prettyQty sg.qty],
|
||||||
|
10 :> hsep ["subj =", runPretty $ prettyTermTC ctx subj],
|
||||||
|
10 :> hsep ["ty =", tyDoc]]
|
||||||
|
|
||||||
mutual
|
mutual
|
||||||
||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ"
|
||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ"
|
||||||
|||
|
|||
|
||||||
|
@ -91,28 +71,32 @@ mutual
|
||||||
||| doing any further work.
|
||| doing any further work.
|
||||||
export covering %inline
|
export covering %inline
|
||||||
check : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
check : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
||||||
TC (CheckResult ctx.dctx n)
|
Eff TC (CheckResult ctx.dctx n)
|
||||||
check ctx sg subj ty = ifConsistent ctx.dctx $ checkC ctx sg subj ty
|
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"
|
||| "Ψ | Γ ⊢₀ s ⇐ A"
|
||||||
|||
|
|||
|
||||||
||| `check0 ctx subj ty` checks a term (as `check`) in a zero context.
|
||| `check0 ctx subj ty` checks a term (as `check`) in a zero context.
|
||||||
export covering %inline
|
export covering %inline
|
||||||
check0 : TyContext d n -> Term d n -> Term d n -> TC ()
|
check0 : TyContext d n -> Term d n -> Term d n -> Eff TC ()
|
||||||
check0 ctx tm ty = ignore $ check ctx szero tm ty
|
check0 ctx tm ty = ignore $ check ctx SZero tm ty
|
||||||
-- the output will always be 𝟎 because the subject quantity is 0
|
-- the output will always be 𝟎 because the subject quantity is 0
|
||||||
|
|
||||||
||| `check`, assuming the dimension context is consistent
|
||| `check`, assuming the dimension context is consistent
|
||||||
export covering %inline
|
export covering %inline
|
||||||
checkC : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
checkC : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
||||||
TC (CheckResult' n)
|
Eff TC (CheckResult' n)
|
||||||
checkC ctx sg subj ty =
|
checkC ctx sg subj ty =
|
||||||
wrapErr (WhileChecking ctx sg.fst subj ty) $
|
wrapErr (WhileChecking ctx sg subj ty) $
|
||||||
checkCNoWrap ctx sg subj ty
|
checkCNoWrap ctx sg subj ty
|
||||||
|
|
||||||
export covering %inline
|
export covering %inline
|
||||||
checkCNoWrap : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
checkCNoWrap : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
|
||||||
TC (CheckResult' n)
|
Eff TC (CheckResult' n)
|
||||||
checkCNoWrap ctx sg subj ty =
|
checkCNoWrap ctx sg subj ty =
|
||||||
let Element subj nc = pushSubsts subj in
|
let Element subj nc = pushSubsts subj in
|
||||||
check' ctx sg subj ty
|
check' ctx sg subj ty
|
||||||
|
@ -122,16 +106,21 @@ mutual
|
||||||
||| `checkType ctx subj ty` checks a type (in a zero context). sometimes the
|
||| `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.
|
||| universe doesn't matter, only that a term is _a_ type, so it is optional.
|
||||||
export covering %inline
|
export covering %inline
|
||||||
checkType : TyContext d n -> Term d n -> Maybe Universe -> TC ()
|
checkType : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
|
||||||
checkType ctx subj l = ignore $ ifConsistent ctx.dctx $ checkTypeC ctx subj l
|
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
|
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 =
|
checkTypeC ctx subj l =
|
||||||
wrapErr (WhileCheckingTy ctx subj l) $ checkTypeNoWrap ctx subj l
|
wrapErr (WhileCheckingTy ctx subj l) $ checkTypeNoWrap ctx subj l
|
||||||
|
|
||||||
export covering %inline
|
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 =
|
checkTypeNoWrap ctx subj l =
|
||||||
let Element subj nc = pushSubsts subj in
|
let Element subj nc = pushSubsts subj in
|
||||||
checkType' ctx subj l
|
checkType' ctx subj l
|
||||||
|
@ -145,15 +134,19 @@ mutual
|
||||||
||| doing any further work.
|
||| doing any further work.
|
||||||
export covering %inline
|
export covering %inline
|
||||||
infer : (ctx : TyContext d n) -> SQty -> Elim d n ->
|
infer : (ctx : TyContext d n) -> SQty -> Elim d n ->
|
||||||
TC (InferResult ctx.dctx d n)
|
Eff TC (InferResult ctx.dctx d n)
|
||||||
infer ctx sg subj = ifConsistent ctx.dctx $ inferC ctx sg subj
|
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
|
||| `infer`, assuming the dimension context is consistent
|
||||||
export covering %inline
|
export covering %inline
|
||||||
inferC : (ctx : TyContext d n) -> SQty -> Elim d n ->
|
inferC : (ctx : TyContext d n) -> SQty -> Elim d n ->
|
||||||
TC (InferResult' d n)
|
Eff TC (InferResult' d n)
|
||||||
inferC ctx sg subj =
|
inferC ctx sg subj =
|
||||||
wrapErr (WhileInferring ctx sg.fst subj) $
|
wrapErr (WhileInferring ctx sg subj) $
|
||||||
let Element subj nc = pushSubsts subj in
|
let Element subj nc = pushSubsts subj in
|
||||||
infer' ctx sg subj
|
infer' ctx sg subj
|
||||||
|
|
||||||
|
@ -161,27 +154,29 @@ mutual
|
||||||
private covering
|
private covering
|
||||||
toCheckType : TyContext d n -> SQty ->
|
toCheckType : TyContext d n -> SQty ->
|
||||||
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
|
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
|
||||||
TC (CheckResult' n)
|
Eff TC (CheckResult' n)
|
||||||
toCheckType ctx sg t ty = do
|
toCheckType ctx sg t ty = do
|
||||||
u <- expectTYPE !(askAt DEFS) ctx ty.loc ty
|
u <- expectTYPE !(askAt DEFS) ctx sg ty.loc ty
|
||||||
expectEqualQ t.loc Zero sg.fst
|
expectEqualQ t.loc Zero sg.qty
|
||||||
checkTypeNoWrap ctx t (Just u)
|
checkTypeNoWrap ctx t (Just u)
|
||||||
pure $ zeroFor ctx
|
pure $ zeroFor ctx
|
||||||
|
|
||||||
private covering
|
private covering
|
||||||
check' : TyContext d n -> SQty ->
|
check' : TyContext d n -> SQty ->
|
||||||
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
|
(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@(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 t@(Pi {}) ty = toCheckType ctx sg t ty
|
||||||
|
|
||||||
check' ctx sg (Lam body loc) ty = do
|
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
|
-- if Ψ | Γ, x : A ⊢ σ · t ⇐ B ⊳ Σ, ρ·x
|
||||||
-- with ρ ≤ σπ
|
-- with ρ ≤ σπ
|
||||||
let qty' = sg.fst * qty
|
let qty' = sg.qty * qty
|
||||||
qout <- checkC (extendTy qty' body.name arg ctx) sg body.term res.term
|
qout <- checkC (extendTy qty' body.name arg ctx) sg body.term res.term
|
||||||
-- then Ψ | Γ ⊢ σ · (λx ⇒ t) ⇐ (π·x : A) → B ⊳ Σ
|
-- then Ψ | Γ ⊢ σ · (λx ⇒ t) ⇐ (π·x : A) → B ⊳ Σ
|
||||||
popQ loc qty' qout
|
popQ loc qty' qout
|
||||||
|
@ -189,7 +184,7 @@ mutual
|
||||||
check' ctx sg t@(Sig {}) ty = toCheckType ctx sg t ty
|
check' ctx sg t@(Sig {}) ty = toCheckType ctx sg t ty
|
||||||
|
|
||||||
check' ctx sg (Pair fst snd loc) ty = do
|
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 ⊳ Σ₁
|
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ₁
|
||||||
qfst <- checkC ctx sg fst tfst
|
qfst <- checkC ctx sg fst tfst
|
||||||
let tsnd = sub1 tsnd (Ann fst tfst fst.loc)
|
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 t@(Enum {}) ty = toCheckType ctx sg t ty
|
||||||
|
|
||||||
check' ctx sg (Tag t loc) ty = do
|
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
|
-- if t ∈ ts
|
||||||
unless (t `elem` tags) $ throw $ TagNotIn loc t tags
|
unless (t `elem` tags) $ throw $ TagNotIn loc t tags
|
||||||
-- then Ψ | Γ ⊢ σ · t ⇐ {ts} ⊳ 𝟎
|
-- then Ψ | Γ ⊢ σ · t ⇐ {ts} ⊳ 𝟎
|
||||||
|
@ -210,38 +205,54 @@ mutual
|
||||||
check' ctx sg t@(Eq {}) ty = toCheckType ctx sg t ty
|
check' ctx sg t@(Eq {}) ty = toCheckType ctx sg t ty
|
||||||
|
|
||||||
check' ctx sg (DLam body loc) ty = do
|
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
|
let ctx' = extendDim body.name ctx
|
||||||
ty = ty.term
|
ty = ty.term
|
||||||
body = body.term
|
body = body.term
|
||||||
-- if Ψ, i | Γ ⊢ σ · t ⇐ A ⊳ Σ
|
-- if Ψ, i | Γ ⊢ σ · t ⇐ A ⊳ Σ
|
||||||
qout <- checkC ctx' sg body ty
|
qout <- checkC ctx' sg body ty
|
||||||
-- if Ψ, i, i = 0 | Γ ⊢ t = l : A
|
-- 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
|
-- 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 ⊳ Σ
|
-- then Ψ | Γ ⊢ σ · (δ i ⇒ t) ⇐ Eq [i ⇒ A] l r ⊳ Σ
|
||||||
pure qout
|
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
|
check' ctx sg (Nat {}) ty = do
|
||||||
expectNat !(askAt DEFS) ctx ty.loc ty
|
expectNAT !(askAt DEFS) ctx SZero ty.loc ty
|
||||||
pure $ zeroFor ctx
|
pure $ zeroFor ctx
|
||||||
|
|
||||||
check' ctx sg (Succ n {}) ty = do
|
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
|
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 t@(BOX {}) ty = toCheckType ctx sg t ty
|
||||||
|
|
||||||
check' ctx sg (Box val loc) ty = do
|
check' ctx sg (Box val loc) ty = do
|
||||||
(q, ty) <- expectBOX !(askAt DEFS) ctx ty.loc ty
|
(q, ty) <- expectBOX !(askAt DEFS) ctx SZero ty.loc ty
|
||||||
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
|
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ
|
||||||
valout <- checkC ctx sg val ty
|
valout <- checkC ctx (subjMult sg q) val ty
|
||||||
-- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ
|
-- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ
|
||||||
pure $ q * valout
|
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
|
check' ctx sg (E e) ty = do
|
||||||
-- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ
|
-- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ
|
||||||
infres <- inferC ctx sg e
|
infres <- inferC ctx sg e
|
||||||
|
@ -253,7 +264,7 @@ mutual
|
||||||
private covering
|
private covering
|
||||||
checkType' : TyContext d n ->
|
checkType' : TyContext d n ->
|
||||||
(subj : Term d n) -> (0 nc : NotClo subj) =>
|
(subj : Term d n) -> (0 nc : NotClo subj) =>
|
||||||
Maybe Universe -> TC ()
|
Maybe Universe -> Eff TC ()
|
||||||
|
|
||||||
checkType' ctx (TYPE k loc) u = do
|
checkType' ctx (TYPE k loc) u = do
|
||||||
-- if 𝓀 < ℓ then Ψ | Γ ⊢₀ Type 𝓀 ⇐ Type ℓ
|
-- if 𝓀 < ℓ then Ψ | Γ ⊢₀ Type 𝓀 ⇐ Type ℓ
|
||||||
|
@ -261,6 +272,9 @@ mutual
|
||||||
Just l => unless (k < l) $ throw $ BadUniverse loc k l
|
Just l => unless (k < l) $ throw $ BadUniverse loc k l
|
||||||
Nothing => pure ()
|
Nothing => pure ()
|
||||||
|
|
||||||
|
checkType' ctx (IOState loc) u = pure ()
|
||||||
|
-- Ψ | Γ ⊢₀ IOState ⇒ Type ℓ
|
||||||
|
|
||||||
checkType' ctx (Pi qty arg res _) u = do
|
checkType' ctx (Pi qty arg res _) u = do
|
||||||
-- if Ψ | Γ ⊢₀ A ⇐ Type ℓ
|
-- if Ψ | Γ ⊢₀ A ⇐ Type ℓ
|
||||||
checkTypeC ctx arg u
|
checkTypeC ctx arg u
|
||||||
|
@ -301,26 +315,35 @@ mutual
|
||||||
checkType' ctx t@(DLam {}) u =
|
checkType' ctx t@(DLam {}) u =
|
||||||
throw $ NotType t.loc ctx t
|
throw $ NotType t.loc ctx t
|
||||||
|
|
||||||
checkType' ctx (Nat {}) u = pure ()
|
checkType' ctx (NAT {}) u = pure ()
|
||||||
checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t
|
checkType' ctx t@(Nat {}) u = throw $ NotType t.loc ctx t
|
||||||
checkType' ctx t@(Succ {}) 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 (BOX q ty _) u = checkType ctx ty u
|
||||||
checkType' ctx t@(Box {}) u = throw $ NotType t.loc ctx t
|
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
|
checkType' ctx (E e) u = do
|
||||||
-- if Ψ | Γ ⊢₀ E ⇒ Type ℓ
|
-- if Ψ | Γ ⊢₀ E ⇒ Type ℓ
|
||||||
infres <- inferC ctx szero e
|
infres <- inferC ctx SZero e
|
||||||
-- if Ψ | Γ ⊢ Type ℓ <: Type 𝓀
|
-- if Ψ | Γ ⊢ Type ℓ <: Type 𝓀
|
||||||
case u of
|
case u of
|
||||||
Just u => lift $ subtype e.loc ctx infres.type (TYPE u noLoc)
|
Just u => lift $ subtype e.loc ctx infres.type (TYPE u e.loc)
|
||||||
Nothing => ignore $ expectTYPE !(askAt DEFS) ctx e.loc infres.type
|
Nothing => ignore $ expectTYPE !(askAt DEFS) ctx SZero e.loc infres.type
|
||||||
-- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀
|
-- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀
|
||||||
|
|
||||||
|
|
||||||
private covering
|
private covering
|
||||||
checkTypeScope : TyContext d n -> Term d n ->
|
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 _ (N body)) u = checkType ctx body u
|
||||||
checkTypeScope ctx s (S [< x] (Y body)) u =
|
checkTypeScope ctx s (S [< x] (Y body)) u =
|
||||||
checkType (extendTy Zero x s ctx) body u
|
checkType (extendTy Zero x s ctx) body u
|
||||||
|
@ -329,25 +352,27 @@ mutual
|
||||||
private covering
|
private covering
|
||||||
infer' : TyContext d n -> SQty ->
|
infer' : TyContext d n -> SQty ->
|
||||||
(subj : Elim d n) -> (0 nc : NotClo subj) =>
|
(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
|
infer' ctx sg (F x u loc) = do
|
||||||
-- if π·x : A {≔ s} in global context
|
-- if π·x : A {≔ s} in global context
|
||||||
g <- lookupFree x loc !(askAt DEFS)
|
g <- lookupFree x loc !(askAt DEFS)
|
||||||
-- if σ ≤ π
|
-- if σ ≤ π
|
||||||
expectCompatQ loc sg.fst g.qty.fst
|
expectCompatQ loc sg.qty g.qty.qty
|
||||||
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
|
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
|
||||||
let Val d = ctx.dimLen; Val n = ctx.termLen
|
pure $ InfRes {
|
||||||
pure $ InfRes {type = displace u g.type, qout = zeroFor ctx}
|
type = g.typeWithAt ctx.dimLen ctx.termLen u,
|
||||||
|
qout = zeroFor ctx
|
||||||
|
}
|
||||||
|
|
||||||
infer' ctx sg (B i _) =
|
infer' ctx sg (B i _) =
|
||||||
-- if x : A ∈ Γ
|
-- if x : A ∈ Γ
|
||||||
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ (𝟎, σ·x, 𝟎)
|
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ (𝟎, σ·x, 𝟎)
|
||||||
pure $ lookupBound sg.fst i ctx.tctx
|
pure $ lookupBound sg.qty i ctx.tctx
|
||||||
where
|
where
|
||||||
lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n
|
lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n
|
||||||
lookupBound pi VZ (ctx :< type) =
|
lookupBound pi VZ (ctx :< var) =
|
||||||
InfRes {type = weakT 1 type, qout = zeroFor ctx :< pi}
|
InfRes {type = weakT 1 var.type, qout = zeroFor ctx :< pi}
|
||||||
lookupBound pi (VS i) (ctx :< _) =
|
lookupBound pi (VS i) (ctx :< _) =
|
||||||
let InfRes {type, qout} = lookupBound pi i ctx in
|
let InfRes {type, qout} = lookupBound pi i ctx in
|
||||||
InfRes {type = weakT 1 type, qout = qout :< Zero}
|
InfRes {type = weakT 1 type, qout = qout :< Zero}
|
||||||
|
@ -355,7 +380,7 @@ mutual
|
||||||
infer' ctx sg (App fun arg loc) = do
|
infer' ctx sg (App fun arg loc) = do
|
||||||
-- if Ψ | Γ ⊢ σ · f ⇒ (π·x : A) → B ⊳ Σ₁
|
-- if Ψ | Γ ⊢ σ · f ⇒ (π·x : A) → B ⊳ Σ₁
|
||||||
funres <- inferC ctx sg fun
|
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 ⊳ Σ₂
|
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ₂
|
||||||
argout <- checkC ctx (subjMult sg qty) arg argty
|
argout <- checkC ctx (subjMult sg qty) arg argty
|
||||||
-- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + πΣ₂
|
-- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + πΣ₂
|
||||||
|
@ -372,12 +397,12 @@ mutual
|
||||||
pairres <- inferC ctx sg pair
|
pairres <- inferC ctx sg pair
|
||||||
-- if Ψ | Γ, p : (x : A) × B ⊢₀ ret ⇐ Type
|
-- if Ψ | Γ, p : (x : A) × B ⊢₀ ret ⇐ Type
|
||||||
checkTypeC (extendTy Zero ret.name pairres.type ctx) ret.term Nothing
|
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 ⇐
|
-- if Ψ | Γ, x : A, y : B ⊢ σ · body ⇐
|
||||||
-- ret[(x, y) ∷ (x : A) × B/p] ⊳ Σ₂, ρ₁·x, ρ₂·y
|
-- ret[(x, y) ∷ (x : A) × B/p] ⊳ Σ₂, ρ₁·x, ρ₂·y
|
||||||
-- with ρ₁, ρ₂ ≤ πσ
|
-- with ρ₁, ρ₂ ≤ πσ
|
||||||
let [< x, y] = body.names
|
let [< x, y] = body.names
|
||||||
pisg = pi * sg.fst
|
pisg = pi * sg.qty
|
||||||
bodyctx = extendTyN [< (pisg, x, tfst), (pisg, y, tsnd.term)] ctx
|
bodyctx = extendTyN [< (pisg, x, tfst), (pisg, y, tsnd.term)] ctx
|
||||||
bodyty = substCasePairRet body.names pairres.type ret
|
bodyty = substCasePairRet body.names pairres.type ret
|
||||||
bodyout <- checkC bodyctx sg body.term bodyty >>=
|
bodyout <- checkC bodyctx sg body.term bodyty >>=
|
||||||
|
@ -388,10 +413,30 @@ mutual
|
||||||
qout = pi * pairres.qout + bodyout
|
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
|
infer' ctx sg (CaseEnum pi t ret arms loc) {d, n} = do
|
||||||
-- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁
|
-- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁
|
||||||
tres <- inferC ctx sg t
|
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
|
-- if 1 ≤ π, OR there is only zero or one option
|
||||||
unless (length (SortedSet.toList ttags) <= 1) $ expectCompatQ loc One pi
|
unless (length (SortedSet.toList ttags) <= 1) $ expectCompatQ loc One pi
|
||||||
-- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type
|
-- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type
|
||||||
|
@ -415,39 +460,43 @@ mutual
|
||||||
-- if Ψ | Γ ⊢ σ · n ⇒ ℕ ⊳ Σn
|
-- if Ψ | Γ ⊢ σ · n ⇒ ℕ ⊳ Σn
|
||||||
nres <- inferC ctx sg n
|
nres <- inferC ctx sg n
|
||||||
let nat = nres.type
|
let nat = nres.type
|
||||||
expectNat !(askAt DEFS) ctx n.loc nat
|
expectNAT !(askAt DEFS) ctx SZero n.loc nat
|
||||||
-- if Ψ | Γ, n : ℕ ⊢₀ A ⇐ Type
|
-- if Ψ | Γ, n : ℕ ⊢₀ A ⇐ Type
|
||||||
checkTypeC (extendTy Zero ret.name nat ctx) ret.term Nothing
|
checkTypeC (extendTy Zero ret.name nat ctx) ret.term Nothing
|
||||||
-- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ ℕ/n] ⊳ Σz
|
-- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ ℕ/n] ⊳ Σz
|
||||||
zerout <- checkC ctx sg zer $ sub1 ret $ Ann (Zero zer.loc) nat zer.loc
|
zerout <- checkC ctx sg zer $ sub1 ret $ Ann (Zero zer.loc) nat zer.loc
|
||||||
-- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ₁.p, ρ₂.ih
|
-- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ.p, ς.ih
|
||||||
-- with ρ₂ ≤ π'σ, (ρ₁ + ρ₂) ≤ πσ
|
-- with ς ≤ π'σ, (ρ + ς) ≤ πσ
|
||||||
let [< p, ih] = suc.names
|
let [< p, ih] = suc.names
|
||||||
pisg = pi * sg.fst
|
pisg = pi * sg.qty
|
||||||
sucCtx = extendTyN [< (pisg, p, Nat p.loc), (pi', ih, ret.term)] ctx
|
sucCtx = extendTyN [< (pisg, p, NAT p.loc), (pi', ih, ret.term)] ctx
|
||||||
sucType = substCaseSuccRet suc.names ret
|
sucType = substCaseSuccRet suc.names ret
|
||||||
sucout :< qp :< qih <- checkC sucCtx sg suc.term sucType
|
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
|
-- [fixme] better error here
|
||||||
expectCompatQ loc (qp + qih) pisg
|
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 {
|
pure $ InfRes {
|
||||||
type = sub1 ret n,
|
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
|
infer' ctx sg (CaseBox pi box ret body loc) = do
|
||||||
-- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁
|
-- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁
|
||||||
boxres <- inferC ctx sg box
|
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
|
-- if Ψ | Γ, x : [ρ.A] ⊢₀ R ⇐ Type
|
||||||
checkTypeC (extendTy Zero ret.name boxres.type ctx) ret.term Nothing
|
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 ς ≤ ρπσ
|
-- with ς ≤ ρπσ
|
||||||
let qpisg = q * pi * sg.fst
|
let rhpisg = rh * pi * sg.qty
|
||||||
bodyCtx = extendTy qpisg body.name ty ctx
|
bodyCtx = extendTy rhpisg body.name ty ctx
|
||||||
bodyType = substCaseBoxRet body.name ty ret
|
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] ⊳ Σ₁ + Σ₂
|
-- then Ψ | Γ ⊢ caseπ ⋯ ⇒ R[b/x] ⊳ Σ₁ + Σ₂
|
||||||
pure $ InfRes {
|
pure $ InfRes {
|
||||||
type = sub1 ret box,
|
type = sub1 ret box,
|
||||||
|
@ -457,42 +506,54 @@ mutual
|
||||||
infer' ctx sg (DApp fun dim loc) = do
|
infer' ctx sg (DApp fun dim loc) = do
|
||||||
-- if Ψ | Γ ⊢ σ · f ⇒ Eq [𝑖 ⇒ A] l r ⊳ Σ
|
-- if Ψ | Γ ⊢ σ · f ⇒ Eq [𝑖 ⇒ A] l r ⊳ Σ
|
||||||
InfRes {type, qout} <- inferC ctx sg fun
|
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/𝑖› ⊳ Σ
|
-- then Ψ | Γ ⊢ σ · f p ⇒ A‹p/𝑖› ⊳ Σ
|
||||||
pure $ InfRes {type = dsub1 ty dim, qout}
|
pure $ InfRes {type = dsub1 ty dim, qout}
|
||||||
|
|
||||||
infer' ctx sg (Coe ty p q val loc) = do
|
infer' ctx sg (Coe ty p q val loc) = do
|
||||||
|
-- if Ψ, 𝑖 | Γ ⊢₀ A ⇐ Type _
|
||||||
checkType (extendDim ty.name ctx) ty.term Nothing
|
checkType (extendDim ty.name ctx) ty.term Nothing
|
||||||
|
-- if Ψ | Γ ⊢ σ · s ⇐ A‹p/𝑖› ⊳ Σ
|
||||||
qout <- checkC ctx sg val $ dsub1 ty p
|
qout <- checkC ctx sg val $ dsub1 ty p
|
||||||
|
-- then Ψ | Γ ⊢ σ · coe (𝑖 ⇒ A) @p @q s ⇒ A‹q/𝑖› ⊳ Σ
|
||||||
pure $ InfRes {type = dsub1 ty q, qout}
|
pure $ InfRes {type = dsub1 ty q, qout}
|
||||||
|
|
||||||
infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1) loc) = do
|
infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1) loc) = do
|
||||||
|
-- if Ψ | Γ ⊢₀ A ⇐ Type _
|
||||||
checkType ctx ty Nothing
|
checkType ctx ty Nothing
|
||||||
|
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
|
||||||
qout <- checkC ctx sg val ty
|
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
|
let ty' = dweakT 1 ty; val' = dweakT 1 val; p' = weakD 1 p
|
||||||
ctx0 = extendDim j0 $ eqDim r (K Zero j0.loc) ctx
|
ctx0 = extendDim j0 $ eqDim r (K Zero j0.loc) ctx
|
||||||
val0 = val0.term
|
val0 = getTerm val0
|
||||||
qout0 <- check ctx0 sg val0 ty'
|
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
|
let ctx1 = extendDim j1 $ eqDim r (K One j1.loc) ctx
|
||||||
val1 = val1.term
|
val1 = getTerm val1
|
||||||
qout1 <- check ctx1 sg val1 ty'
|
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]
|
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}
|
pure $ InfRes {type = ty, qout = lubs ctx qouts}
|
||||||
|
|
||||||
infer' ctx sg (TypeCase ty ret arms def loc) = do
|
infer' ctx sg (TypeCase ty ret arms def loc) = do
|
||||||
-- if σ = 0
|
-- if σ = 0
|
||||||
expectEqualQ loc Zero sg.fst
|
expectEqualQ loc Zero sg.qty
|
||||||
-- if Ψ, Γ ⊢₀ e ⇒ Type u
|
-- 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)
|
-- if Ψ, Γ ⊢₀ C ⇐ Type (non-dependent return type)
|
||||||
checkTypeC ctx ret Nothing
|
checkTypeC ctx ret Nothing
|
||||||
-- if Ψ, Γ' ⊢₀ A ⇐ C for each rhs A
|
-- if Ψ, Γ' ⊢₀ A ⇐ C for each rhs A
|
||||||
for_ allKinds $ \k =>
|
for_ allKinds $ \k =>
|
||||||
for_ (lookupPrecise k arms) $ \(S names t) =>
|
for_ (lookupPrecise k arms) $ \(S names t) =>
|
||||||
check0 (extendTyN (typecaseTel k names u) ctx)
|
check0 (extendTyN (typecaseTel k names u) ctx)
|
||||||
t.term (weakT (arity k) ret)
|
(getTerm t) (weakT (arity k) ret)
|
||||||
-- then Ψ, Γ ⊢₀ type-case ⋯ ⇒ C
|
-- then Ψ, Γ ⊢₀ type-case ⋯ ⇒ C
|
||||||
pure $ InfRes {type = ret, qout = zeroFor ctx}
|
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.Syntax
|
||||||
import public Quox.Definition
|
import public Quox.Definition
|
||||||
import public Quox.Reduce
|
import public Quox.Whnf
|
||||||
|
import public Quox.Pretty
|
||||||
|
|
||||||
import Language.Reflection
|
import Language.Reflection
|
||||||
import Control.Eff
|
import Control.Eff
|
||||||
|
@ -47,15 +48,14 @@ public export
|
||||||
substCasePairRet : BContext 2 -> Term d n -> ScopeTerm d n -> Term d (2 + n)
|
substCasePairRet : BContext 2 -> Term d n -> ScopeTerm d n -> Term d (2 + n)
|
||||||
substCasePairRet [< x, y] dty retty =
|
substCasePairRet [< x, y] dty retty =
|
||||||
let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc
|
let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc
|
||||||
arg = Ann tm (dty // fromNat 2) tm.loc
|
arg = Ann tm (dty // fromNat 2) tm.loc in
|
||||||
in
|
|
||||||
retty.term // (arg ::: shift 2)
|
retty.term // (arg ::: shift 2)
|
||||||
|
|
||||||
public export
|
public export
|
||||||
substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n)
|
substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n)
|
||||||
substCaseSuccRet [< p, ih] retty =
|
substCaseSuccRet [< p, ih] retty =
|
||||||
let arg = Ann (Succ (BVT 1 p.loc) p.loc) (Nat noLoc) $ p.loc `extendL` ih.loc
|
let loc = p.loc `extendL` ih.loc
|
||||||
in
|
arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT p.loc) loc in
|
||||||
retty.term // (arg ::: shift 2)
|
retty.term // (arg ::: shift 2)
|
||||||
|
|
||||||
public export
|
public export
|
||||||
|
@ -65,23 +65,31 @@ substCaseBoxRet x dty retty =
|
||||||
retty.term // (arg ::: shift 1)
|
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
|
namespace TyContext
|
||||||
parameters (ctx : TyContext d n) (loc : Loc)
|
parameters (ctx : TyContext d n) (sg : SQty) (loc : Loc)
|
||||||
export covering
|
export covering
|
||||||
whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
|
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
|
whnf tm = do
|
||||||
let Val n = ctx.termLen; Val d = ctx.dimLen
|
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
|
rethrow res
|
||||||
|
|
||||||
private covering %macro
|
private covering %macro
|
||||||
expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
|
expect : ExpectErrorConstructor -> TTImp -> TTImp ->
|
||||||
TTImp -> TTImp -> Elab (Term d n -> Eff fs a)
|
Elab (Term d n -> Eff fs a)
|
||||||
expect k l r = do
|
expect err pat rhs = Prelude.do
|
||||||
f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
|
match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
|
||||||
pure $ \t => maybe (throw $ k loc ctx.names t) pure . f . fst =<< whnf t
|
pure $ \term => do
|
||||||
|
res <- whnf term
|
||||||
|
maybe (throw $ err loc ctx.names term) pure $ match $ fst res
|
||||||
|
|
||||||
export covering %inline
|
export covering %inline
|
||||||
expectTYPE : Term d n -> Eff fs Universe
|
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))
|
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
|
||||||
|
|
||||||
export covering %inline
|
export covering %inline
|
||||||
expectNat : Term d n -> Eff fs ()
|
expectNAT : Term d n -> Eff fs ()
|
||||||
expectNat = expect ExpectedNat `(Nat {}) `(())
|
expectNAT = expect ExpectedNAT `(NAT {}) `(())
|
||||||
|
|
||||||
|
export covering %inline
|
||||||
|
expectSTRING : Term d n -> Eff fs ()
|
||||||
|
expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
|
||||||
|
|
||||||
export covering %inline
|
export covering %inline
|
||||||
expectBOX : Term d n -> Eff fs (Qty, Term d n)
|
expectBOX : Term d n -> Eff fs (Qty, Term d n)
|
||||||
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
|
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
|
||||||
|
|
||||||
|
export covering %inline
|
||||||
|
expectIOState : Term d n -> Eff fs ()
|
||||||
|
expectIOState = expect ExpectedIOState `(IOState {}) `(())
|
||||||
|
|
||||||
|
|
||||||
namespace EqContext
|
namespace EqContext
|
||||||
parameters (ctx : EqContext n) (loc : Loc)
|
parameters (ctx : EqContext n) (sg : SQty) (loc : Loc)
|
||||||
export covering
|
export covering
|
||||||
whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
|
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
|
whnf tm = do
|
||||||
let Val n = ctx.termLen
|
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
|
||||||
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm
|
|
||||||
rethrow res
|
rethrow res
|
||||||
|
|
||||||
private covering %macro
|
private covering %macro
|
||||||
expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
|
expect : ExpectErrorConstructor -> TTImp -> TTImp ->
|
||||||
TTImp -> TTImp -> Elab (Term 0 n -> Eff fs a)
|
Elab (Term 0 n -> Eff fs a)
|
||||||
expect k l r = do
|
expect err pat rhs = do
|
||||||
f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
|
match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
|
||||||
pure $ \t =>
|
pure $ \term => do
|
||||||
let err = throw $ k loc ctx.names (t // shift0 ctx.dimLen) in
|
res <- whnf term
|
||||||
maybe err pure . f . fst =<< whnf t
|
let t0 = delay $ term // shift0 ctx.dimLen
|
||||||
|
maybe (throw $ err loc ctx.names t0) pure $ match $ fst res
|
||||||
|
|
||||||
export covering %inline
|
export covering %inline
|
||||||
expectTYPE : Term 0 n -> Eff fs Universe
|
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))
|
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
|
||||||
|
|
||||||
export covering %inline
|
export covering %inline
|
||||||
expectNat : Term 0 n -> Eff fs ()
|
expectNAT : Term 0 n -> Eff fs ()
|
||||||
expectNat = expect ExpectedNat `(Nat {}) `(())
|
expectNAT = expect ExpectedNAT `(NAT {}) `(())
|
||||||
|
|
||||||
|
export covering %inline
|
||||||
|
expectSTRING : Term 0 n -> Eff fs ()
|
||||||
|
expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
|
||||||
|
|
||||||
export covering %inline
|
export covering %inline
|
||||||
expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n)
|
expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n)
|
||||||
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
|
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.Context
|
||||||
import Quox.Pretty
|
import Quox.Pretty
|
||||||
import public Data.Singleton
|
import public Data.Singleton
|
||||||
|
import Derive.Prelude
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
|
%language ElabReflection
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
QContext : Nat -> Type
|
QContext : Nat -> Type
|
||||||
QContext = Context' Qty
|
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
|
public export
|
||||||
TContext : TermLike
|
TContext : TermLike
|
||||||
TContext d = Context (Term d)
|
TContext d = Context (LocalVar d)
|
||||||
|
|
||||||
public export
|
public export
|
||||||
QOutput : Nat -> Type
|
QOutput : Nat -> Type
|
||||||
|
@ -31,11 +65,12 @@ record TyContext d n where
|
||||||
{auto dimLen : Singleton d}
|
{auto dimLen : Singleton d}
|
||||||
{auto termLen : Singleton n}
|
{auto termLen : Singleton n}
|
||||||
dctx : DimEq d
|
dctx : DimEq d
|
||||||
dnames : BContext d
|
dnames : BContext d -- only used for printing
|
||||||
tctx : TContext d n
|
tctx : TContext d n
|
||||||
tnames : BContext n
|
tnames : BContext n -- only used for printing
|
||||||
qtys : QContext n -- only used for printing
|
qtys : QContext n -- only used for printing
|
||||||
%name TyContext ctx
|
%name TyContext ctx
|
||||||
|
%runElab deriveIndexed "TyContext" [Show]
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
|
@ -46,29 +81,29 @@ record EqContext n where
|
||||||
dassign : DimAssign dimLen -- only used for printing
|
dassign : DimAssign dimLen -- only used for printing
|
||||||
dnames : BContext dimLen -- only used for printing
|
dnames : BContext dimLen -- only used for printing
|
||||||
tctx : TContext 0 n
|
tctx : TContext 0 n
|
||||||
tnames : BContext n
|
tnames : BContext n -- only used for printing
|
||||||
qtys : QContext n -- only used for printing
|
qtys : QContext n -- only used for printing
|
||||||
%name EqContext ctx
|
%name EqContext ctx
|
||||||
|
%runElab deriveIndexed "EqContext" [Show]
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
record WhnfContext d n where
|
record WhnfContext d n where
|
||||||
constructor MkWhnfContext
|
constructor MkWhnfContext
|
||||||
|
{auto dimLen : Singleton d}
|
||||||
|
{auto termLen : Singleton n}
|
||||||
dnames : BContext d
|
dnames : BContext d
|
||||||
tnames : BContext n
|
tnames : BContext n
|
||||||
tctx : TContext d n
|
tctx : TContext d n
|
||||||
%name WhnfContext ctx
|
%name WhnfContext ctx
|
||||||
|
%runElab deriveIndexed "WhnfContext" [Show]
|
||||||
|
|
||||||
namespace TContext
|
namespace TContext
|
||||||
export %inline
|
|
||||||
pushD : TContext d n -> TContext (S d) n
|
|
||||||
pushD tel = map (// shift 1) tel
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
zeroFor : Context tm n -> QOutput n
|
zeroFor : Context tm n -> QOutput n
|
||||||
zeroFor ctx = Zero <$ ctx
|
zeroFor ctx = Zero <$ ctx
|
||||||
|
|
||||||
private
|
public export
|
||||||
extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
|
extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
|
||||||
extendLen [<] x = x
|
extendLen [<] x = x
|
||||||
extendLen (tel :< _) x = [|S $ extendLen tel x|]
|
extendLen (tel :< _) x = [|S $ extendLen tel x|]
|
||||||
|
@ -78,32 +113,66 @@ public export
|
||||||
CtxExtension : Nat -> Nat -> Nat -> Type
|
CtxExtension : Nat -> Nat -> Nat -> Type
|
||||||
CtxExtension d = Telescope ((Qty, BindName,) . Term d)
|
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
|
namespace TyContext
|
||||||
public export %inline
|
public export %inline
|
||||||
empty : TyContext 0 0
|
empty : TyContext 0 0
|
||||||
empty =
|
empty = MkTyContext {
|
||||||
MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
|
dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]
|
||||||
|
}
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
null : TyContext d n -> Bool
|
null : TyContext d n -> Bool
|
||||||
null ctx = null ctx.dnames && null ctx.tnames
|
null ctx = null ctx.dnames && null ctx.tnames
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
|
extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2
|
||||||
extendTyN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
|
extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
|
||||||
let (qs, xs, ss) = unzip3 xss in
|
let (qs, xs, ls) = unzip3 xss in
|
||||||
MkTyContext {
|
MkTyContext {
|
||||||
dctx, dnames,
|
dctx, dnames,
|
||||||
termLen = extendLen xss termLen,
|
termLen = extendLen xss termLen,
|
||||||
tctx = tctx . ss,
|
tctx = tctx . ls,
|
||||||
tnames = tnames . xs,
|
tnames = tnames . xs,
|
||||||
qtys = qtys . qs
|
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
|
export %inline
|
||||||
extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
|
extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
|
||||||
extendTy q x s = extendTyN [< (q, x, s)]
|
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
|
export %inline
|
||||||
extendDim : BindName -> TyContext d n -> TyContext (S d) n
|
extendDim : BindName -> TyContext d n -> TyContext (S d) n
|
||||||
extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
|
extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
|
||||||
|
@ -111,7 +180,7 @@ namespace TyContext
|
||||||
dctx = dctx :<? Nothing,
|
dctx = dctx :<? Nothing,
|
||||||
dnames = dnames :< x,
|
dnames = dnames :< x,
|
||||||
dimLen = [|S dimLen|],
|
dimLen = [|S dimLen|],
|
||||||
tctx = pushD tctx,
|
tctx = map weakD tctx,
|
||||||
tnames, qtys
|
tnames, qtys
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -150,7 +219,7 @@ makeEqContext' ctx th = MkEqContext {
|
||||||
termLen = ctx.termLen,
|
termLen = ctx.termLen,
|
||||||
dassign = makeDAssign th,
|
dassign = makeDAssign th,
|
||||||
dnames = ctx.dnames,
|
dnames = ctx.dnames,
|
||||||
tctx = map (// th) ctx.tctx,
|
tctx = map (subD th) ctx.tctx,
|
||||||
tnames = ctx.tnames,
|
tnames = ctx.tnames,
|
||||||
qtys = ctx.qtys
|
qtys = ctx.qtys
|
||||||
}
|
}
|
||||||
|
@ -158,7 +227,7 @@ makeEqContext' ctx th = MkEqContext {
|
||||||
export
|
export
|
||||||
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
|
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
|
||||||
makeEqContext ctx@(MkTyContext {dnames, _}) th =
|
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
|
namespace EqContext
|
||||||
public export %inline
|
public export %inline
|
||||||
|
@ -172,21 +241,42 @@ namespace EqContext
|
||||||
null ctx = null ctx.dnames && null ctx.tnames
|
null ctx = null ctx.dnames && null ctx.tnames
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
|
extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2
|
||||||
extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
|
extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
|
||||||
let (qs, xs, ss) = unzip3 xss in
|
let (qs, xs, ls) = unzip3 xss in
|
||||||
MkEqContext {
|
MkEqContext {
|
||||||
termLen = extendLen xss termLen,
|
termLen = extendLen xss termLen,
|
||||||
tctx = tctx . ss,
|
tctx = tctx . ls,
|
||||||
tnames = tnames . xs,
|
tnames = tnames . xs,
|
||||||
qtys = qtys . qs,
|
qtys = qtys . qs,
|
||||||
dassign, dnames
|
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
|
export %inline
|
||||||
extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
|
extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
|
||||||
extendTy q x s = extendTyN [< (q, x, s)]
|
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
|
export %inline
|
||||||
extendDim : BindName -> DimConst -> EqContext n -> EqContext n
|
extendDim : BindName -> DimConst -> EqContext n -> EqContext n
|
||||||
extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) =
|
extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) =
|
||||||
|
@ -197,8 +287,8 @@ namespace EqContext
|
||||||
toTyContext : (e : EqContext n) -> TyContext e.dimLen n
|
toTyContext : (e : EqContext n) -> TyContext e.dimLen n
|
||||||
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
|
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
|
||||||
MkTyContext {
|
MkTyContext {
|
||||||
dctx = fromGround dassign,
|
dctx = fromGround dnames dassign,
|
||||||
tctx = map (// shift0 dimLen) tctx,
|
tctx = map (subD $ shift0 dimLen) tctx,
|
||||||
dnames, tnames, qtys
|
dnames, tnames, qtys
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -207,18 +297,44 @@ namespace EqContext
|
||||||
toWhnfContext (MkEqContext {tnames, tctx, _}) =
|
toWhnfContext (MkEqContext {tnames, tctx, _}) =
|
||||||
MkWhnfContext {dnames = [<], 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
|
namespace WhnfContext
|
||||||
public export %inline
|
public export %inline
|
||||||
empty : WhnfContext 0 0
|
empty : WhnfContext 0 0
|
||||||
empty = MkWhnfContext [<] [<] [<]
|
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
|
export
|
||||||
extendDimN : {s : Nat} -> BContext s -> WhnfContext d n ->
|
extendDimN : {s : Nat} -> BContext s -> WhnfContext d n ->
|
||||||
WhnfContext (s + d) n
|
WhnfContext (s + d) n
|
||||||
extendDimN ns (MkWhnfContext {dnames, tnames, tctx}) =
|
extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) =
|
||||||
MkWhnfContext {
|
MkWhnfContext {
|
||||||
|
dimLen = [|Val s + dimLen|],
|
||||||
dnames = dnames ++ toSnocVect' ns,
|
dnames = dnames ++ toSnocVect' ns,
|
||||||
tctx = dweakT s <$> tctx,
|
tctx = map (subD $ shift s) tctx,
|
||||||
tnames
|
tnames
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -230,14 +346,25 @@ namespace WhnfContext
|
||||||
private
|
private
|
||||||
prettyTContextElt : {opts : _} ->
|
prettyTContextElt : {opts : _} ->
|
||||||
BContext d -> BContext n ->
|
BContext d -> BContext n ->
|
||||||
Qty -> BindName -> Term d n -> Eff Pretty (Doc opts)
|
Doc opts -> BindName -> LocalVar d n ->
|
||||||
prettyTContextElt dnames tnames q x s =
|
Eff Pretty (Doc opts)
|
||||||
pure $ hsep [hcat [!(prettyQty q), !dotD, !(prettyTBind x)], !colonD,
|
prettyTContextElt dnames tnames q x s = do
|
||||||
!(withPrec Outer $ prettyTerm dnames tnames s)]
|
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
|
private
|
||||||
prettyTContext' : {opts : _} ->
|
prettyTContext' : {opts : _} ->
|
||||||
BContext d -> QContext n -> BContext n ->
|
BContext d -> Context' (Doc opts) n -> BContext n ->
|
||||||
TContext d n -> Eff Pretty (SnocList (Doc opts))
|
TContext d n -> Eff Pretty (SnocList (Doc opts))
|
||||||
prettyTContext' _ [<] [<] [<] = pure [<]
|
prettyTContext' _ [<] [<] [<] = pure [<]
|
||||||
prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
|
prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
|
||||||
|
@ -248,8 +375,11 @@ export
|
||||||
prettyTContext : {opts : _} ->
|
prettyTContext : {opts : _} ->
|
||||||
BContext d -> QContext n -> BContext n ->
|
BContext d -> QContext n -> BContext n ->
|
||||||
TContext d n -> Eff Pretty (Doc opts)
|
TContext d n -> Eff Pretty (Doc opts)
|
||||||
prettyTContext dnames qtys tnames tys =
|
prettyTContext dnames qtys tnames tys = do
|
||||||
separateTight !commaD <$> prettyTContext' dnames qtys tnames tys
|
comma <- commaD
|
||||||
|
qtys <- traverse prettyQty qtys
|
||||||
|
sepSingle . exceptLast (<+> comma) . toList <$>
|
||||||
|
prettyTContext' dnames qtys tnames tys
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
|
prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
|
||||||
|
@ -257,9 +387,16 @@ prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
|
||||||
case dctx of
|
case dctx of
|
||||||
C [<] => prettyTContext dnames qtys tnames tctx
|
C [<] => prettyTContext dnames qtys tnames tctx
|
||||||
_ => pure $
|
_ => pure $
|
||||||
sep [!(prettyDimEq dnames dctx) <++> !pipeD,
|
sepSingle [!(prettyDimEq dnames dctx) <++> !pipeD,
|
||||||
!(prettyTContext dnames qtys tnames tctx)]
|
!(prettyTContext dnames qtys tnames tctx)]
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts)
|
prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts)
|
||||||
prettyEqContext ctx = prettyTyContext $ toTyContext ctx
|
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.Loc
|
||||||
import Quox.Syntax
|
import Quox.Syntax
|
||||||
|
import Quox.Syntax.Builtin
|
||||||
import Quox.Typing.Context
|
import Quox.Typing.Context
|
||||||
import Quox.Typing.EqMode
|
import Quox.Typing.EqMode
|
||||||
import Quox.Pretty
|
import Quox.Pretty
|
||||||
|
|
||||||
import Data.List
|
import Data.List
|
||||||
import Control.Eff
|
import Control.Eff
|
||||||
|
import Derive.Prelude
|
||||||
|
|
||||||
|
%language ElabReflection
|
||||||
|
%hide TT.Name
|
||||||
|
|
||||||
|
%default total
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
|
@ -15,6 +22,7 @@ record NameContexts d n where
|
||||||
constructor MkNameContexts
|
constructor MkNameContexts
|
||||||
dnames : BContext d
|
dnames : BContext d
|
||||||
tnames : BContext n
|
tnames : BContext n
|
||||||
|
%runElab deriveIndexed "NameContexts" [Show]
|
||||||
|
|
||||||
namespace NameContexts
|
namespace NameContexts
|
||||||
export
|
export
|
||||||
|
@ -60,8 +68,10 @@ data Error
|
||||||
| ExpectedSig Loc (NameContexts d n) (Term d n)
|
| ExpectedSig Loc (NameContexts d n) (Term d n)
|
||||||
| ExpectedEnum Loc (NameContexts d n) (Term d n)
|
| ExpectedEnum Loc (NameContexts d n) (Term d n)
|
||||||
| ExpectedEq 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)
|
| ExpectedBOX Loc (NameContexts d n) (Term d n)
|
||||||
|
| ExpectedIOState Loc (NameContexts d n) (Term d n)
|
||||||
| BadUniverse Loc Universe Universe
|
| BadUniverse Loc Universe Universe
|
||||||
| TagNotIn Loc TagVal (SortedSet TagVal)
|
| TagNotIn Loc TagVal (SortedSet TagVal)
|
||||||
| BadCaseEnum Loc (SortedSet TagVal) (SortedSet TagVal)
|
| BadCaseEnum Loc (SortedSet TagVal) (SortedSet TagVal)
|
||||||
|
@ -78,11 +88,14 @@ data Error
|
||||||
| NotType Loc (TyContext d n) (Term d n)
|
| NotType Loc (TyContext d n) (Term d n)
|
||||||
| WrongType Loc (EqContext n) (Term 0 n) (Term 0 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)
|
| MissingEnumArm Loc TagVal (List TagVal)
|
||||||
|
|
||||||
-- extra context
|
-- extra context
|
||||||
| WhileChecking
|
| WhileChecking
|
||||||
(TyContext d n) Qty
|
(TyContext d n) SQty
|
||||||
(Term d n) -- term
|
(Term d n) -- term
|
||||||
(Term d n) -- type
|
(Term d n) -- type
|
||||||
Error
|
Error
|
||||||
|
@ -92,19 +105,20 @@ data Error
|
||||||
(Maybe Universe)
|
(Maybe Universe)
|
||||||
Error
|
Error
|
||||||
| WhileInferring
|
| WhileInferring
|
||||||
(TyContext d n) Qty
|
(TyContext d n) SQty
|
||||||
(Elim d n)
|
(Elim d n)
|
||||||
Error
|
Error
|
||||||
| WhileComparingT
|
| WhileComparingT
|
||||||
(EqContext n) EqMode
|
(EqContext n) EqMode SQty
|
||||||
(Term 0 n) -- type
|
(Term 0 n) -- type
|
||||||
(Term 0 n) (Term 0 n) -- lhs/rhs
|
(Term 0 n) (Term 0 n) -- lhs/rhs
|
||||||
Error
|
Error
|
||||||
| WhileComparingE
|
| WhileComparingE
|
||||||
(EqContext n) EqMode
|
(EqContext n) EqMode SQty
|
||||||
(Elim 0 n) (Elim 0 n)
|
(Elim 0 n) (Elim 0 n)
|
||||||
Error
|
Error
|
||||||
%name Error err
|
%name Error err
|
||||||
|
%runElab derive "Error" [Show]
|
||||||
|
|
||||||
public export
|
public export
|
||||||
ErrorEff : Type -> Type
|
ErrorEff : Type -> Type
|
||||||
|
@ -118,8 +132,10 @@ Located Error where
|
||||||
(ExpectedSig loc _ _).loc = loc
|
(ExpectedSig loc _ _).loc = loc
|
||||||
(ExpectedEnum loc _ _).loc = loc
|
(ExpectedEnum loc _ _).loc = loc
|
||||||
(ExpectedEq loc _ _).loc = loc
|
(ExpectedEq loc _ _).loc = loc
|
||||||
(ExpectedNat loc _ _).loc = loc
|
(ExpectedNAT loc _ _).loc = loc
|
||||||
|
(ExpectedSTRING loc _ _).loc = loc
|
||||||
(ExpectedBOX loc _ _).loc = loc
|
(ExpectedBOX loc _ _).loc = loc
|
||||||
|
(ExpectedIOState loc _ _).loc = loc
|
||||||
(BadUniverse loc _ _).loc = loc
|
(BadUniverse loc _ _).loc = loc
|
||||||
(TagNotIn loc _ _).loc = loc
|
(TagNotIn loc _ _).loc = loc
|
||||||
(BadCaseEnum loc _ _).loc = loc
|
(BadCaseEnum loc _ _).loc = loc
|
||||||
|
@ -132,12 +148,14 @@ Located Error where
|
||||||
(NotInScope loc _).loc = loc
|
(NotInScope loc _).loc = loc
|
||||||
(NotType loc _ _).loc = loc
|
(NotType loc _ _).loc = loc
|
||||||
(WrongType loc _ _ _).loc = loc
|
(WrongType loc _ _ _).loc = loc
|
||||||
|
(WrongBuiltinType _ err).loc = err.loc
|
||||||
|
(ExpectedSingleEnum loc _ _).loc = loc
|
||||||
(MissingEnumArm loc _ _).loc = loc
|
(MissingEnumArm loc _ _).loc = loc
|
||||||
(WhileChecking _ _ _ _ err).loc = err.loc
|
(WhileChecking _ _ _ _ err).loc = err.loc
|
||||||
(WhileCheckingTy _ _ _ err).loc = err.loc
|
(WhileCheckingTy _ _ _ err).loc = err.loc
|
||||||
(WhileInferring _ _ _ err).loc = err.loc
|
(WhileInferring _ _ _ err).loc = err.loc
|
||||||
(WhileComparingT _ _ _ _ _ err).loc = err.loc
|
(WhileComparingT _ _ _ _ _ _ err).loc = err.loc
|
||||||
(WhileComparingE _ _ _ _ err).loc = err.loc
|
(WhileComparingE _ _ _ _ _ err).loc = err.loc
|
||||||
|
|
||||||
|
|
||||||
||| separates out all the error context layers
|
||| separates out all the error context layers
|
||||||
|
@ -150,10 +168,10 @@ explodeContext (WhileCheckingTy ctx s k err) =
|
||||||
mapFst (WhileCheckingTy ctx s k ::) $ explodeContext err
|
mapFst (WhileCheckingTy ctx s k ::) $ explodeContext err
|
||||||
explodeContext (WhileInferring ctx x e err) =
|
explodeContext (WhileInferring ctx x e err) =
|
||||||
mapFst (WhileInferring ctx x e ::) $ explodeContext err
|
mapFst (WhileInferring ctx x e ::) $ explodeContext err
|
||||||
explodeContext (WhileComparingT ctx x s t r err) =
|
explodeContext (WhileComparingT ctx x sg s t r err) =
|
||||||
mapFst (WhileComparingT ctx x s t r ::) $ explodeContext err
|
mapFst (WhileComparingT ctx x sg s t r ::) $ explodeContext err
|
||||||
explodeContext (WhileComparingE ctx x e f err) =
|
explodeContext (WhileComparingE ctx x sg e f err) =
|
||||||
mapFst (WhileComparingE ctx x e f ::) $ explodeContext err
|
mapFst (WhileComparingE ctx x sg e f ::) $ explodeContext err
|
||||||
explodeContext err = ([], err)
|
explodeContext err = ([], err)
|
||||||
|
|
||||||
||| leaves the outermost context layer, and the innermost (up to) n, and removes
|
||| leaves the outermost context layer, and the innermost (up to) n, and removes
|
||||||
|
@ -240,10 +258,26 @@ where
|
||||||
hangDSingle "with quantities" $
|
hangDSingle "with quantities" $
|
||||||
separateTight !commaD $ toSnocList' !(traverse prettyQty qs)]
|
separateTight !commaD $ toSnocList' !(traverse prettyQty qs)]
|
||||||
|
|
||||||
export
|
parameters {opts : LayoutOpts} (showContext : Bool)
|
||||||
prettyErrorNoLoc : {opts : _} -> (showContext : Bool) -> Error ->
|
export
|
||||||
Eff Pretty (Doc opts)
|
inContext' : Bool -> a -> (a -> Eff Pretty (Doc opts)) ->
|
||||||
prettyErrorNoLoc showContext = \case
|
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 =>
|
ExpectedTYPE _ ctx s =>
|
||||||
hangDSingle "expected a type universe, but got"
|
hangDSingle "expected a type universe, but got"
|
||||||
!(prettyTerm ctx.dnames ctx.tnames s)
|
!(prettyTerm ctx.dnames ctx.tnames s)
|
||||||
|
@ -261,19 +295,29 @@ prettyErrorNoLoc showContext = \case
|
||||||
!(prettyTerm ctx.dnames ctx.tnames s)
|
!(prettyTerm ctx.dnames ctx.tnames s)
|
||||||
|
|
||||||
ExpectedEq _ ctx s =>
|
ExpectedEq _ ctx s =>
|
||||||
hangDSingle "expected an enumeration type, but got"
|
hangDSingle "expected an equality type, but got"
|
||||||
!(prettyTerm ctx.dnames ctx.tnames s)
|
!(prettyTerm ctx.dnames ctx.tnames s)
|
||||||
|
|
||||||
ExpectedNat _ ctx s =>
|
ExpectedNAT _ ctx s =>
|
||||||
hangDSingle
|
hangDSingle
|
||||||
("expected the type" <++>
|
("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)
|
!(prettyTerm ctx.dnames ctx.tnames s)
|
||||||
|
|
||||||
ExpectedBOX _ ctx s =>
|
ExpectedBOX _ ctx s =>
|
||||||
hangDSingle "expected a box type, but got"
|
hangDSingle "expected a box type, but got"
|
||||||
!(prettyTerm ctx.dnames ctx.tnames s)
|
!(prettyTerm ctx.dnames ctx.tnames s)
|
||||||
|
|
||||||
|
ExpectedIOState _ ctx s =>
|
||||||
|
hangDSingle "expected IOState, but got"
|
||||||
|
!(prettyTerm ctx.dnames ctx.tnames s)
|
||||||
|
|
||||||
BadUniverse _ k l => pure $
|
BadUniverse _ k l => pure $
|
||||||
sep ["the universe level" <++> !(prettyUniverse k),
|
sep ["the universe level" <++> !(prettyUniverse k),
|
||||||
"is not strictly less than" <++> !(prettyUniverse l)]
|
"is not strictly less than" <++> !(prettyUniverse l)]
|
||||||
|
@ -332,68 +376,68 @@ prettyErrorNoLoc showContext = \case
|
||||||
[hangDSingle "the term" !(prettyTerm [<] ctx.tnames s),
|
[hangDSingle "the term" !(prettyTerm [<] ctx.tnames s),
|
||||||
hangDSingle "cannot have type" !(prettyTerm [<] ctx.tnames ty)]
|
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 $
|
MissingEnumArm _ tag tags => pure $
|
||||||
sep [hsep ["the tag", !(prettyTag tag), "is not contained in"],
|
sep [hsep ["the tag", !(prettyTag tag), "is not contained in"],
|
||||||
!(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)]
|
!(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)]
|
||||||
|
|
||||||
WhileChecking ctx pi s a err =>
|
WhileChecking ctx sg s a err =>
|
||||||
[|vappendBlank
|
[|vappendBlank
|
||||||
(inTContext ctx . sep =<< sequence
|
(inTContext ctx . sep =<< sequence
|
||||||
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
|
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
|
||||||
hangDSingle "has type" !(prettyTerm ctx.dnames ctx.tnames a),
|
hangDSingle "has type" !(prettyTerm ctx.dnames ctx.tnames a),
|
||||||
hangDSingle "with quantity" !(prettyQty pi)])
|
hangDSingle "with quantity" !(prettyQty sg.qty)])
|
||||||
(prettyErrorNoLoc showContext err)|]
|
(prettyErrorNoLoc err)|]
|
||||||
|
|
||||||
WhileCheckingTy ctx a k err =>
|
WhileCheckingTy ctx a k err =>
|
||||||
[|vappendBlank
|
[|vappendBlank
|
||||||
(inTContext ctx . sep =<< sequence
|
(inTContext ctx . sep =<< sequence
|
||||||
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a),
|
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a),
|
||||||
pure $ text $ isTypeInUniverse k])
|
pure $ text $ isTypeInUniverse k])
|
||||||
(prettyErrorNoLoc showContext err)|]
|
(prettyErrorNoLoc err)|]
|
||||||
|
|
||||||
WhileInferring ctx pi e err =>
|
WhileInferring ctx sg e err =>
|
||||||
[|vappendBlank
|
[|vappendBlank
|
||||||
(inTContext ctx . sep =<< sequence
|
(inTContext ctx . sep =<< sequence
|
||||||
[hangDSingle "while inferring the type of"
|
[hangDSingle "while inferring the type of"
|
||||||
!(prettyElim ctx.dnames ctx.tnames e),
|
!(prettyElim ctx.dnames ctx.tnames e),
|
||||||
hangDSingle "with quantity" !(prettyQty pi)])
|
hangDSingle "with quantity" !(prettyQty sg.qty)])
|
||||||
(prettyErrorNoLoc showContext err)|]
|
(prettyErrorNoLoc err)|]
|
||||||
|
|
||||||
WhileComparingT ctx mode a s t err =>
|
WhileComparingT ctx mode sg a s t err =>
|
||||||
[|vappendBlank
|
[|vappendBlank
|
||||||
(inEContext ctx . sep =<< sequence
|
(inEContext ctx . sep =<< sequence
|
||||||
[hangDSingle "while checking that" !(prettyTerm [<] ctx.tnames s),
|
[hangDSingle "while checking that" !(prettyTerm [<] ctx.tnames s),
|
||||||
hangDSingle (text "is \{prettyMode mode}")
|
hangDSingle (text "is \{prettyMode mode}")
|
||||||
!(prettyTerm [<] ctx.tnames t),
|
!(prettyTerm [<] ctx.tnames t),
|
||||||
hangDSingle "at type" !(prettyTerm [<] ctx.tnames a)])
|
hangDSingle "at type" !(prettyTerm [<] ctx.tnames a),
|
||||||
(prettyErrorNoLoc showContext err)|]
|
hangDSingle "with quantity" !(prettyQty sg.qty)])
|
||||||
|
(prettyErrorNoLoc err)|]
|
||||||
|
|
||||||
WhileComparingE ctx mode e f err =>
|
WhileComparingE ctx mode sg e f err =>
|
||||||
[|vappendBlank
|
[|vappendBlank
|
||||||
(inEContext ctx . sep =<< sequence
|
(inEContext ctx . sep =<< sequence
|
||||||
[hangDSingle "while checking that" !(prettyElim [<] ctx.tnames e),
|
[hangDSingle "while checking that" !(prettyElim [<] ctx.tnames e),
|
||||||
hangDSingle (text "is \{prettyMode mode}")
|
hangDSingle (text "is \{prettyMode mode}")
|
||||||
!(prettyElim [<] ctx.tnames f)])
|
!(prettyElim [<] ctx.tnames f),
|
||||||
(prettyErrorNoLoc showContext err)|]
|
hangDSingle "with quantity" !(prettyQty sg.qty)])
|
||||||
|
(prettyErrorNoLoc err)|]
|
||||||
|
|
||||||
where
|
where
|
||||||
vappendBlank : Doc opts -> Doc opts -> Doc opts
|
vappendBlank : Doc opts -> Doc opts -> Doc opts
|
||||||
vappendBlank a b = flush a `vappend` b
|
vappendBlank a b = flush a `vappend` b
|
||||||
|
|
||||||
inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
|
export
|
||||||
inTContext ctx doc =
|
prettyError : Error -> Eff Pretty (Doc opts)
|
||||||
if showContext && not (null ctx) then
|
prettyError err = hangDSingle
|
||||||
pure $ vappend doc (sep ["in context", !(prettyTyContext ctx)])
|
!(prettyLoc err.loc)
|
||||||
else pure doc
|
!(indentD =<< prettyErrorNoLoc err)
|
||||||
|
|
||||||
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]
|
|
||||||
|
|
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