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 |
160 changed files with 12311 additions and 6725 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
|
|
@ -5,3 +5,6 @@ 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;
|
||||||
|
|
|
@ -5,10 +5,10 @@ namespace maybe {
|
||||||
|
|
||||||
def0 Tag : ★ = {nothing, just}
|
def0 Tag : ★ = {nothing, just}
|
||||||
|
|
||||||
def0 Payload : ω.Tag → ω.★ → ★ =
|
def0 Payload : Tag → ★ → ★ =
|
||||||
λ tag A ⇒ caseω tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
|
λ tag A ⇒ case tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
|
||||||
|
|
||||||
def0 Maybe : ω.★ → ★ =
|
def0 Maybe : ★ → ★ =
|
||||||
λ A ⇒ (t : Tag) × Payload t A
|
λ A ⇒ (t : Tag) × Payload t A
|
||||||
|
|
||||||
def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
|
def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
|
||||||
|
@ -17,13 +17,13 @@ def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
|
||||||
def Nothing : 0.(A : ★) → Maybe A =
|
def Nothing : 0.(A : ★) → Maybe A =
|
||||||
λ _ ⇒ ('nothing, 'true)
|
λ _ ⇒ ('nothing, 'true)
|
||||||
|
|
||||||
def Just : 0.(A : ★) → 1.A → Maybe A =
|
def Just : 0.(A : ★) → A → Maybe A =
|
||||||
λ _ x ⇒ ('just, x)
|
λ _ x ⇒ ('just, x)
|
||||||
|
|
||||||
def0 IsJustTag : ω.Tag → ★ =
|
def0 IsJustTag : Tag → ★ =
|
||||||
λ t ⇒ caseω t return ★ of { 'just ⇒ True; 'nothing ⇒ False }
|
λ t ⇒ case t return ★ of { 'just ⇒ True; 'nothing ⇒ False }
|
||||||
|
|
||||||
def0 IsJust : 0.(A : ★) → ω.(Maybe A) → ★ =
|
def0 IsJust : (A : ★) → Maybe A → ★ =
|
||||||
λ A x ⇒ IsJustTag (tag A x)
|
λ A x ⇒ IsJustTag (tag A x)
|
||||||
|
|
||||||
def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
|
def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
|
||||||
|
@ -34,28 +34,27 @@ def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
|
||||||
}
|
}
|
||||||
|
|
||||||
def0 nothing-unique :
|
def0 nothing-unique :
|
||||||
0.(A : ★) → ω.(x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
|
(A : ★) → (x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
|
||||||
λ A x ⇒
|
λ A x ⇒
|
||||||
caseω x return x' ⇒ ('nothing, x') ≡ Nothing A : Maybe A of {
|
case x return x' ⇒ ('nothing, x') ≡ Nothing A : Maybe A of {
|
||||||
'true ⇒ δ _ ⇒ ('nothing, 'true)
|
'true ⇒ δ _ ⇒ ('nothing, 'true)
|
||||||
}
|
}
|
||||||
|
|
||||||
def elim :
|
def elim :
|
||||||
0.(A : ★) →
|
0.(A : ★) →
|
||||||
0.(P : 0.(Maybe A) → ★) →
|
0.(P : Maybe A → ★) →
|
||||||
ω.(P (Nothing A)) →
|
ω.(P (Nothing A)) →
|
||||||
ω.(ω.(x : A) → P (Just A x)) →
|
ω.((x : A) → P (Just A x)) →
|
||||||
1.(x : Maybe A) → P x =
|
(x : Maybe A) → P x =
|
||||||
λ A P n j x ⇒
|
λ A P n j x ⇒
|
||||||
caseω x return x' ⇒ P x' of {
|
case x return x' ⇒ P x' of { (tag, payload) ⇒
|
||||||
(tag, payload) ⇒
|
(case tag
|
||||||
(caseω tag
|
|
||||||
return t ⇒
|
return t ⇒
|
||||||
0.(eq : tag ≡ t : Tag) → P (t, coe (i ⇒ Payload (eq @i) A) payload)
|
0.(eq : tag ≡ t : Tag) → P (t, coe (i ⇒ Payload (eq @i) A) payload)
|
||||||
of {
|
of {
|
||||||
'nothing ⇒
|
'nothing ⇒
|
||||||
λ eq ⇒
|
λ eq ⇒
|
||||||
caseω coe (i ⇒ Payload (eq @i) A) payload
|
case coe (i ⇒ Payload (eq @i) A) payload
|
||||||
return p ⇒ P ('nothing, p)
|
return p ⇒ P ('nothing, p)
|
||||||
of { 'true ⇒ n };
|
of { 'true ⇒ n };
|
||||||
'just ⇒ λ eq ⇒ j (coe (i ⇒ Payload (eq @i) A) payload)
|
'just ⇒ λ eq ⇒ j (coe (i ⇒ Payload (eq @i) A) payload)
|
||||||
|
|
|
@ -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,16 +6,13 @@ import Quox.Name
|
||||||
|
|
||||||
import Data.DPair
|
import Data.DPair
|
||||||
import Data.Nat
|
import Data.Nat
|
||||||
import Data.Fin
|
|
||||||
import Data.Singleton
|
import Data.Singleton
|
||||||
import Data.SnocList
|
import Data.SnocList
|
||||||
import Data.SnocVect
|
import Data.SnocVect
|
||||||
import Data.Vect
|
import Data.Vect
|
||||||
import Control.Monad.Identity
|
import Control.Monad.Identity
|
||||||
import Derive.Prelude
|
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
%language ElabReflection
|
|
||||||
|
|
||||||
|
|
||||||
||| a sequence of bindings under an existing context. each successive element
|
||| a sequence of bindings under an existing context. each successive element
|
||||||
|
@ -61,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
|
||||||
|
@ -87,13 +85,6 @@ export %inline
|
||||||
toSnocList' : Telescope' a _ _ -> SnocList a
|
toSnocList' : Telescope' a _ _ -> SnocList a
|
||||||
toSnocList' = toSnocListWith id
|
toSnocList' = toSnocListWith id
|
||||||
|
|
||||||
export %inline
|
|
||||||
toSnocListRelevant : {n1 : Nat} -> Telescope tm n1 n2 -> SnocList (n ** tm n)
|
|
||||||
toSnocListRelevant tel = toSnocList' $ snd $ go tel where
|
|
||||||
go : Telescope tm n1 n2' -> (Singleton n2', Telescope' (n ** tm n) n1 n2')
|
|
||||||
go [<] = (Val n1, [<])
|
|
||||||
go (tel :< x) = let (Val n, tel) = go tel in (Val (S n), tel :< (n ** x))
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
toList : Telescope tm _ _ -> List (Exists tm)
|
toList : Telescope tm _ _ -> List (Exists tm)
|
||||||
toList = toListWith (Evidence _)
|
toList = toListWith (Evidence _)
|
||||||
|
@ -118,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
|
||||||
|
@ -147,34 +145,34 @@ tel ++ (sx :< x) = (tel ++ sx) :< x
|
||||||
|
|
||||||
public export
|
public export
|
||||||
getShiftWith : (forall from, to. tm from -> Shift from to -> tm to) ->
|
getShiftWith : (forall from, to. tm from -> Shift from to -> tm to) ->
|
||||||
Shift len out -> Context tm len -> Fin len -> tm out
|
Shift len out -> Context tm len -> Var len -> tm out
|
||||||
getShiftWith shft by (ctx :< t) FZ = t `shft` ssDown by
|
getShiftWith shft by (ctx :< t) VZ = t `shft` ssDown by
|
||||||
getShiftWith shft by (ctx :< t) (FS i) = getShiftWith shft (ssDown by) ctx i
|
getShiftWith shft by (ctx :< t) (VS i) = getShiftWith shft (ssDown by) ctx i
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
getShift : CanShift tm => Shift len out -> Context tm len -> Fin len -> tm out
|
getShift : CanShift tm => Shift len out -> Context tm len -> Var len -> tm out
|
||||||
getShift = getShiftWith (//)
|
getShift = getShiftWith (//)
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
|
getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
|
||||||
Context tm len -> Fin 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 -> Fin 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 -> Fin len -> tm
|
(!!!) : Context' tm len -> Var len -> tm
|
||||||
(!!!) = getWith const
|
(!!!) = getWith const
|
||||||
|
|
||||||
public export
|
public export
|
||||||
find : Alternative f =>
|
find : Alternative f =>
|
||||||
(forall n. tm n -> Bool) -> Context tm len -> f (Fin len)
|
(forall n. tm n -> Bool) -> Context tm len -> f (Var len)
|
||||||
find p [<] = empty
|
find p [<] = empty
|
||||||
find p (ctx :< x) = (guard (p x) $> FZ) <|> (FS <$> find p ctx)
|
find p (ctx :< x) = (guard (p x) $> VZ) <|> (VS <$> find p ctx)
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
|
@ -191,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)) ->
|
||||||
|
@ -202,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 ->
|
||||||
|
@ -269,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
|
||||||
|
@ -297,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
|
||||||
|
@ -331,14 +340,6 @@ export %inline
|
||||||
where Show (Exists tm) where showPrec d t = showPrec d t.snd
|
where Show (Exists tm) where showPrec d t = showPrec d t.snd
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
implementation [ShowTelRelevant]
|
|
||||||
{n1 : Nat} -> ({n : Nat} -> Show (f n)) => Show (Telescope f n1 n2)
|
|
||||||
where
|
|
||||||
showPrec d = showPrec d . toSnocListRelevant
|
|
||||||
where Show (n : Nat ** f n) where showPrec d (_ ** t) = showPrec d t
|
|
||||||
|
|
||||||
|
|
||||||
parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
|
parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
|
||||||
(nameHL : HL)
|
(nameHL : HL)
|
||||||
(pterm : forall n. BContext n -> tm n -> Eff Pretty (Doc opts))
|
(pterm : forall n. BContext n -> tm n -> Eff Pretty (Doc opts))
|
||||||
|
@ -364,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]
|
|
||||||
|
|
1028
lib/Quox/Equal.idr
1028
lib/Quox/Equal.idr
File diff suppressed because it is too large
Load diff
|
@ -1,44 +0,0 @@
|
||||||
module Quox.FinExtra
|
|
||||||
|
|
||||||
import public Data.Fin
|
|
||||||
import Quox.Decidable
|
|
||||||
|
|
||||||
public export
|
|
||||||
data LT : Rel (Fin n) where
|
|
||||||
LTZ : FZ `LT` FS i
|
|
||||||
LTS : i `LT` j -> FS i `LT` FS j
|
|
||||||
%builtin Natural FinExtra.LT
|
|
||||||
%name FinExtra.LT lt
|
|
||||||
|
|
||||||
public export %inline
|
|
||||||
GT : Rel (Fin n)
|
|
||||||
GT = flip LT
|
|
||||||
|
|
||||||
export
|
|
||||||
Transitive (Fin n) LT where
|
|
||||||
transitive LTZ (LTS _) = LTZ
|
|
||||||
transitive (LTS p) (LTS q) = LTS $ transitive p q
|
|
||||||
|
|
||||||
export Uninhabited (i `FinExtra.LT` i) where uninhabited (LTS p) = uninhabited p
|
|
||||||
export Uninhabited (FS i `LT` FZ) where uninhabited _ impossible
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
data Compare : Rel (Fin n) where
|
|
||||||
IsLT : (lt : i `LT` j) -> Compare i j
|
|
||||||
IsEQ : Compare i i
|
|
||||||
IsGT : (gt : i `GT` j) -> Compare i j
|
|
||||||
%name Compare cmp
|
|
||||||
|
|
||||||
export
|
|
||||||
compareS : Compare i j -> Compare (FS i) (FS j)
|
|
||||||
compareS (IsLT lt) = IsLT (LTS lt)
|
|
||||||
compareS IsEQ = IsEQ
|
|
||||||
compareS (IsGT gt) = IsGT (LTS gt)
|
|
||||||
|
|
||||||
export
|
|
||||||
compareP : (i, j : Fin n) -> Compare i j
|
|
||||||
compareP FZ FZ = IsEQ
|
|
||||||
compareP FZ (FS j) = IsLT LTZ
|
|
||||||
compareP (FS i) FZ = IsGT LTZ
|
|
||||||
compareP (FS i) (FS j) = compareS $ compareP i j
|
|
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
|
||||||
|
|
|
@ -1,19 +1,13 @@
|
||||||
module Quox.NatExtra
|
module Quox.NatExtra
|
||||||
|
|
||||||
import public Data.Nat
|
import public Data.Nat
|
||||||
import public Data.Nat.Views
|
|
||||||
import Data.Nat.Division
|
import Data.Nat.Division
|
||||||
import Data.SnocList
|
import Data.SnocList
|
||||||
import Data.Vect
|
import Data.Vect
|
||||||
import Syntax.PreorderReasoning
|
import Data.String
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
|
|
||||||
infixl 8 `shiftL`, `shiftR`
|
|
||||||
infixl 7 .&.
|
|
||||||
infixl 6 `xor`
|
|
||||||
infixl 5 .|.
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
data LTE' : Nat -> Nat -> Type where
|
data LTE' : Nat -> Nat -> Type where
|
||||||
|
@ -59,151 +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' []
|
||||||
|
|
||||||
|
namespace Nat
|
||||||
export
|
export
|
||||||
showHex : Nat -> String
|
showHex : Nat -> String
|
||||||
showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
|
showHex = showAtBase $ fromList $ unpack "0123456789abcdef"
|
||||||
|
|
||||||
|
|
||||||
|
namespace Int
|
||||||
export
|
export
|
||||||
0 notEvenOdd : (a, b : Nat) -> Not (a + a = S (b + b))
|
showHex : Int -> String
|
||||||
notEvenOdd 0 b prf = absurd prf
|
showHex x =
|
||||||
notEvenOdd (S a) b prf =
|
if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x)
|
||||||
notEvenOdd b a $ Calc $
|
|
||||||
|~ b + b
|
|
||||||
~~ a + S a ..<(inj S prf)
|
|
||||||
~~ S (a + a) ..<(plusSuccRightSucc {})
|
|
||||||
|
|
||||||
|
|
||||||
|
namespace Int
|
||||||
export
|
export
|
||||||
0 doubleInj : (m, n : Nat) -> m + m = n + n -> m = n
|
fromHexit : Char -> Maybe Int
|
||||||
doubleInj 0 0 _ = Refl
|
fromHexit c =
|
||||||
doubleInj (S m) (S n) prf =
|
if c >= '0' && c <= '9' then Just $ ord c - ord '0'
|
||||||
cong S $ doubleInj m n $
|
else if c >= 'a' && c <= 'f' then Just $ ord c - ord 'a' + 10
|
||||||
inj S $ Calc $
|
else if c >= 'A' && c <= 'F' then Just $ ord c - ord 'A' + 10
|
||||||
|~ S (m + m)
|
else Nothing
|
||||||
~~ m + S m ...(plusSuccRightSucc {})
|
|
||||||
~~ n + S n ...(inj S prf)
|
|
||||||
~~ S (n + n) ..<(plusSuccRightSucc {})
|
|
||||||
|
|
||||||
|
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
|
export
|
||||||
0 halfDouble : (n : Nat) -> half (n + n) = HalfEven n
|
fromHexit : Char -> Maybe Nat
|
||||||
halfDouble n with (half (n + n)) | (n + n) proof nn
|
fromHexit = map cast . Int.fromHexit
|
||||||
_ | HalfOdd k | S (k + k) = void $ notEvenOdd n k nn
|
|
||||||
_ | HalfEven k | k + k = rewrite doubleInj n k nn in Refl
|
|
||||||
|
|
||||||
export
|
export %inline
|
||||||
floorHalf : Nat -> Nat
|
fromHex : String -> Maybe Nat
|
||||||
floorHalf k = case half k of
|
fromHex = map cast . Int.fromHex
|
||||||
HalfOdd n => n
|
|
||||||
HalfEven n => n
|
|
||||||
|
|
||||||
|
|
||||||
||| like in intercal ☺
|
|
||||||
|||
|
|
||||||
||| take all the bits of `subj` that are set in `mask`, and squish them down
|
|
||||||
||| towards the lsb
|
|
||||||
public export
|
|
||||||
select : (mask, subj : Nat) -> Nat
|
|
||||||
select mask subj = go 1 (halfRec mask) subj 0 where
|
|
||||||
go : forall mask. Nat -> HalfRec mask -> Nat -> Nat -> Nat
|
|
||||||
go bit HalfRecZ subj res = res
|
|
||||||
go bit (HalfRecEven _ rec) subj res = go bit rec (floorHalf subj) res
|
|
||||||
go bit (HalfRecOdd _ rec) subj res = case half subj of
|
|
||||||
HalfOdd subj => go (bit + bit) rec subj (res + bit)
|
|
||||||
HalfEven subj => go (bit + bit) rec subj res
|
|
||||||
|
|
||||||
||| take the i least significant bits of subj (where i = popCount mask),
|
|
||||||
||| and place them where mask's set bits are
|
|
||||||
|||
|
|
||||||
||| left inverse of select if mask .|. subj = mask
|
|
||||||
public export
|
|
||||||
spread : (mask, subj : Nat) -> Nat
|
|
||||||
spread mask subj = go 1 (halfRec mask) subj 0 where
|
|
||||||
go : forall mask. Nat -> HalfRec mask -> Nat -> Nat -> Nat
|
|
||||||
go bit HalfRecZ subj res = res
|
|
||||||
go bit (HalfRecEven _ rec) subj res = go (bit + bit) rec subj res
|
|
||||||
go bit (HalfRecOdd _ rec) subj res = case half subj of
|
|
||||||
HalfOdd subj => go (bit + bit) rec subj (res + bit)
|
|
||||||
HalfEven subj => go (bit + bit) rec subj res
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
data BitwiseRec : Nat -> Nat -> Type where
|
|
||||||
BwDone : BitwiseRec 0 0
|
|
||||||
Bw00 : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
|
|
||||||
BitwiseRec (m + m) (n + n)
|
|
||||||
Bw01 : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
|
|
||||||
BitwiseRec (m + m) (S (n + n))
|
|
||||||
Bw10 : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
|
|
||||||
BitwiseRec (S (m + m)) (n + n)
|
|
||||||
Bw11 : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
|
|
||||||
BitwiseRec (S (m + m)) (S (n + n))
|
|
||||||
|
|
||||||
export
|
|
||||||
bitwiseRec : (m, n : Nat) -> BitwiseRec m n
|
|
||||||
bitwiseRec m n = go (halfRec m) (halfRec n) where
|
|
||||||
go : forall m, n. HalfRec m -> HalfRec n -> BitwiseRec m n
|
|
||||||
go HalfRecZ HalfRecZ = BwDone
|
|
||||||
go HalfRecZ (HalfRecEven n nr) = Bw00 0 n $ go HalfRecZ nr
|
|
||||||
go HalfRecZ (HalfRecOdd n nr) = Bw01 0 n $ go HalfRecZ nr
|
|
||||||
go (HalfRecEven m mr) HalfRecZ = Bw00 m 0 $ go mr HalfRecZ
|
|
||||||
go (HalfRecEven m mr) (HalfRecEven n nr) = Bw00 m n $ go mr nr
|
|
||||||
go (HalfRecEven m mr) (HalfRecOdd n nr) = Bw01 m n $ go mr nr
|
|
||||||
go (HalfRecOdd m mr) HalfRecZ = Bw10 m 0 $ go mr HalfRecZ
|
|
||||||
go (HalfRecOdd m mr) (HalfRecEven n nr) = Bw10 m n $ go mr nr
|
|
||||||
go (HalfRecOdd m mr) (HalfRecOdd n nr) = Bw11 m n $ go mr nr
|
|
||||||
|
|
||||||
public export
|
|
||||||
bitwise : (Bool -> Bool -> Bool) -> Nat -> Nat -> Nat
|
|
||||||
bitwise f m n = go 1 (bitwiseRec m n) 0 where
|
|
||||||
one : Bool -> Bool -> Nat -> Nat -> Nat
|
|
||||||
one p q bit res = if f p q then bit + res else res
|
|
||||||
go : forall m, n. Nat -> BitwiseRec m n -> Nat -> Nat
|
|
||||||
go bit BwDone res = res
|
|
||||||
go bit (Bw00 m n rec) res = go (bit + bit) rec $ one False False bit res
|
|
||||||
go bit (Bw01 m n rec) res = go (bit + bit) rec $ one False True bit res
|
|
||||||
go bit (Bw10 m n rec) res = go (bit + bit) rec $ one True False bit res
|
|
||||||
go bit (Bw11 m n rec) res = go (bit + bit) rec $ one True True bit res
|
|
||||||
|
|
||||||
public export
|
|
||||||
(.&.) : Nat -> Nat -> Nat
|
|
||||||
(.&.) = bitwise $ \p, q => p && q
|
|
||||||
|
|
||||||
private %foreign "scheme:blodwen-and"
|
|
||||||
primAnd : Nat -> Nat -> Nat
|
|
||||||
%transform "NatExtra.(.&.)" NatExtra.(.&.) m n = primAnd m n
|
|
||||||
|
|
||||||
public export
|
|
||||||
(.|.) : Nat -> Nat -> Nat
|
|
||||||
(.|.) = bitwise $ \p, q => p || q
|
|
||||||
|
|
||||||
private %foreign "scheme:blodwen-or"
|
|
||||||
primOr : Nat -> Nat -> Nat
|
|
||||||
%transform "NatExtra.(.|.)" NatExtra.(.|.) m n = primOr m n
|
|
||||||
|
|
||||||
public export
|
|
||||||
xor : Nat -> Nat -> Nat
|
|
||||||
xor = bitwise (/=)
|
|
||||||
|
|
||||||
private %foreign "scheme:blodwen-xor"
|
|
||||||
primXor : Nat -> Nat -> Nat
|
|
||||||
%transform "NatExtra.xor" NatExtra.xor m n = primXor m n
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
shiftL : Nat -> Nat -> Nat
|
|
||||||
shiftL n 0 = n
|
|
||||||
shiftL n (S i) = shiftL (n + n) i
|
|
||||||
|
|
||||||
private %foreign "scheme:blodwen-shl"
|
|
||||||
primShiftL : Nat -> Nat -> Nat
|
|
||||||
%transform "NatExtra.shiftL" NatExtra.shiftL n i = primShiftL n i
|
|
||||||
|
|
||||||
public export
|
|
||||||
shiftR : Nat -> Nat -> Nat
|
|
||||||
shiftR n 0 = n
|
|
||||||
shiftR n (S i) = shiftL (floorHalf n) i
|
|
||||||
|
|
||||||
private %foreign "scheme:blodwen-shr"
|
|
||||||
primShiftR : Nat -> Nat -> Nat
|
|
||||||
%transform "NatExtra.shiftR" NatExtra.shiftR n i = primShiftR n i
|
|
||||||
|
|
|
@ -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
|
|
@ -1,18 +1,16 @@
|
||||||
module Quox.Syntax.Dim
|
module Quox.Syntax.Dim
|
||||||
|
|
||||||
import Quox.Thin
|
import Quox.Loc
|
||||||
import Quox.Syntax.Var
|
import Quox.Name
|
||||||
|
import Quox.Var
|
||||||
import Quox.Syntax.Subst
|
import Quox.Syntax.Subst
|
||||||
import Quox.Pretty
|
import Quox.Pretty
|
||||||
import Quox.Name
|
|
||||||
import Quox.Loc
|
|
||||||
import Quox.Context
|
import Quox.Context
|
||||||
|
import Quox.PrettyValExtra
|
||||||
|
|
||||||
import Decidable.Equality
|
import Decidable.Equality
|
||||||
import Control.Function
|
import Control.Function
|
||||||
import Derive.Prelude
|
import Derive.Prelude
|
||||||
import Data.DPair
|
|
||||||
import Data.SnocVect
|
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
%language ElabReflection
|
%language ElabReflection
|
||||||
|
@ -21,7 +19,7 @@ import Data.SnocVect
|
||||||
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
|
||||||
|
@ -42,48 +40,38 @@ DecEq DimConst where
|
||||||
|
|
||||||
public export
|
public export
|
||||||
data Dim : Nat -> Type where
|
data Dim : Nat -> Type where
|
||||||
K : DimConst -> Loc -> Dim 0
|
K : DimConst -> Loc -> Dim d
|
||||||
B : Loc -> Dim 1
|
B : Var d -> Loc -> Dim d
|
||||||
%name Dim.Dim p, q
|
%name Dim.Dim p, q
|
||||||
%runElab deriveIndexed "Dim" [Eq, Ord, Show]
|
%runElab deriveIndexed "Dim" [Eq, Ord, Show]
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
DimT : Nat -> Type
|
|
||||||
DimT = Thinned Dim
|
|
||||||
|
|
||||||
public export %inline
|
|
||||||
KT : DimConst -> Loc -> DimT d
|
|
||||||
KT e loc = Th zero $ K e loc
|
|
||||||
|
|
||||||
|
|
||||||
||| `endsOr l r x p` returns `ends l r ε` if `p` is a constant ε, and
|
||| `endsOr l r x p` returns `ends l r ε` if `p` is a constant ε, and
|
||||||
||| `x` otherwise.
|
||| `x` otherwise.
|
||||||
public export
|
public export
|
||||||
endsOr : Lazy a -> Lazy a -> Lazy a -> Dim n -> a
|
endsOr : Lazy a -> Lazy a -> Lazy a -> Dim n -> a
|
||||||
endsOr l r x (K e _) = ends l r e
|
endsOr l r x (K e _) = ends l r e
|
||||||
endsOr l r x (B _) = x
|
endsOr l r x (B _ _) = x
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
Located (Dim d) where
|
Located (Dim d) where
|
||||||
(K _ loc).loc = loc
|
(K _ loc).loc = loc
|
||||||
(B loc).loc = loc
|
(B _ loc).loc = loc
|
||||||
|
|
||||||
export
|
export
|
||||||
Relocatable (Dim d) where
|
Relocatable (Dim d) where
|
||||||
setLoc loc (K e _) = K e loc
|
setLoc loc (K e _) = K e loc
|
||||||
setLoc loc (B _) = B loc
|
setLoc loc (B i _) = B i loc
|
||||||
|
|
||||||
parameters {opts : LayoutOpts}
|
|
||||||
export
|
export
|
||||||
prettyDimConst : DimConst -> Eff Pretty (Doc opts)
|
prettyDimConst : {opts : _} -> DimConst -> Eff Pretty (Doc opts)
|
||||||
prettyDimConst = hl Dim . text . ends "0" "1"
|
prettyDimConst = hl Dim . text . ends "0" "1"
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyDim : {d : Nat} -> BContext d -> DimT d -> Eff Pretty (Doc opts)
|
prettyDim : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
|
||||||
prettyDim names (Th _ (K e _)) = prettyDimConst e
|
prettyDim names (K e _) = prettyDimConst e
|
||||||
prettyDim names (Th i (B _)) = prettyDBind $ names !!! i.fin
|
prettyDim names (B i _) = prettyDBind $ names !!! i
|
||||||
|
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
|
@ -96,54 +84,57 @@ DSubst : Nat -> Nat -> Type
|
||||||
DSubst = Subst Dim
|
DSubst = Subst Dim
|
||||||
|
|
||||||
|
|
||||||
-- public export FromVar Dim where fromVarLoc = B
|
public export FromVar Dim where fromVarLoc = B
|
||||||
|
|
||||||
|
|
||||||
-- export
|
export
|
||||||
-- CanShift Dim where
|
CanShift Dim where
|
||||||
-- K e loc // _ = K e loc
|
K e loc // _ = K e loc
|
||||||
-- B i loc // by = B (i // by) loc
|
B i loc // by = B (i // by) loc
|
||||||
|
|
||||||
export %inline FromVar Dim where var = B
|
export
|
||||||
|
|
||||||
export %inline
|
|
||||||
CanSubstSelf Dim where
|
CanSubstSelf Dim where
|
||||||
Th _ (K e loc) // _ = KT e loc
|
K e loc // _ = K e loc
|
||||||
Th i (B loc) // th = get th i.fin
|
B i loc // th = getLoc th i loc
|
||||||
|
|
||||||
|
|
||||||
export Uninhabited (B loc1 = K e loc2) where uninhabited _ impossible
|
export Uninhabited (B i loc1 = K e loc2) where uninhabited _ impossible
|
||||||
export Uninhabited (K e loc1 = B loc2) where uninhabited _ impossible
|
export Uninhabited (K e loc1 = B i loc2) where uninhabited _ impossible
|
||||||
|
|
||||||
-- public export
|
public export
|
||||||
-- data Eqv : Dim d1 -> Dim d2 -> Type where
|
data Eqv : Dim d1 -> Dim d2 -> Type where
|
||||||
-- EK : K e _ `Eqv` K e _
|
EK : K e _ `Eqv` K e _
|
||||||
-- EB : i `Eqv` j -> B i _ `Eqv` B j _
|
EB : i `Eqv` j -> B i _ `Eqv` B j _
|
||||||
|
|
||||||
-- export Uninhabited (K e l1 `Eqv` B i l2) where uninhabited _ impossible
|
export Uninhabited (K e l1 `Eqv` B i l2) where uninhabited _ impossible
|
||||||
-- export Uninhabited (B i l1 `Eqv` K e l2) where uninhabited _ impossible
|
export Uninhabited (B i l1 `Eqv` K e l2) where uninhabited _ impossible
|
||||||
|
|
||||||
-- export
|
export
|
||||||
-- injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j
|
injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j
|
||||||
-- injectiveB (EB e) = e
|
injectiveB (EB e) = e
|
||||||
|
|
||||||
-- export
|
export
|
||||||
-- injectiveK : K e loc1 `Eqv` K f loc2 -> e = f
|
injectiveK : K e loc1 `Eqv` K f loc2 -> e = f
|
||||||
-- injectiveK EK = Refl
|
injectiveK EK = Refl
|
||||||
|
|
||||||
-- public export
|
public export
|
||||||
-- decEqv : Dec2 Dim.Eqv
|
decEqv : Dec2 Dim.Eqv
|
||||||
-- decEqv (K e _) (K f _) = case decEq e f of
|
decEqv (K e _) (K f _) = case decEq e f of
|
||||||
-- Yes Refl => Yes EK
|
Yes Refl => Yes EK
|
||||||
-- No n => No $ n . injectiveK
|
No n => No $ n . injectiveK
|
||||||
-- decEqv (B i _) (B j _) = case decEqv i j of
|
decEqv (B i _) (B j _) = case decEqv i j of
|
||||||
-- Yes y => Yes $ EB y
|
Yes y => Yes $ EB y
|
||||||
-- No n => No $ \(EB y) => n y
|
No n => No $ \(EB y) => n y
|
||||||
-- decEqv (B _ _) (K _ _) = No absurd
|
decEqv (B _ _) (K _ _) = No absurd
|
||||||
-- decEqv (K _ _) (B _ _) = No absurd
|
decEqv (K _ _) (B _ _) = No absurd
|
||||||
|
|
||||||
||| 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
|
||||||
BV : (i : Fin d) -> (loc : Loc) -> DimT d
|
BV : (i : Nat) -> (0 _ : LT i d) => (loc : Loc) -> Dim d
|
||||||
BV i loc = Th (one' i) $ B loc
|
BV i loc = B (V i) loc
|
||||||
|
|
||||||
|
|
||||||
|
export
|
||||||
|
weakD : (by : Nat) -> Dim d -> Dim (by + d)
|
||||||
|
weakD by p = p // shift by
|
||||||
|
|
|
@ -1,19 +1,17 @@
|
||||||
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.Thin
|
import Quox.FreeVars
|
||||||
import Quox.FinExtra
|
|
||||||
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Nat
|
import Data.Nat
|
||||||
import Data.DPair
|
import Data.DPair
|
||||||
import Data.Fun.Graph
|
import Data.Fun.Graph
|
||||||
import Data.SnocVect
|
|
||||||
import Decidable.Decidable
|
import Decidable.Decidable
|
||||||
import Decidable.Equality
|
import Decidable.Equality
|
||||||
import Derive.Prelude
|
import Derive.Prelude
|
||||||
|
@ -24,7 +22,7 @@ import Derive.Prelude
|
||||||
|
|
||||||
public export
|
public export
|
||||||
DimEq' : Nat -> Type
|
DimEq' : Nat -> Type
|
||||||
DimEq' = Context (Maybe . DimT)
|
DimEq' = Context (Maybe . Dim)
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
|
@ -32,12 +30,7 @@ data DimEq : Nat -> Type where
|
||||||
ZeroIsOne : DimEq d
|
ZeroIsOne : DimEq d
|
||||||
C : (eqs : DimEq' d) -> DimEq d
|
C : (eqs : DimEq' d) -> DimEq d
|
||||||
%name DimEq eqs
|
%name DimEq eqs
|
||||||
%runElab deriveIndexed "DimEq" [Eq]
|
%runElab deriveIndexed "DimEq" [Eq, Ord, Show]
|
||||||
|
|
||||||
export
|
|
||||||
Show (DimEq d) where
|
|
||||||
showPrec d ZeroIsOne = "ZeroIsOne"
|
|
||||||
showPrec d (C eq') = showCon d "C" $ showArg eq' @{ShowTelRelevant}
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
|
@ -66,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
|
||||||
|
@ -78,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 (KT 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
|
||||||
|
@ -102,40 +100,39 @@ new = C new'
|
||||||
|
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
get' : DimEq' d -> Fin d -> Maybe (DimT d)
|
get' : DimEq' d -> Var d -> Maybe (Dim d)
|
||||||
get' = getWith $ \p, by => map (// by) p
|
get' = getWith $ \p, by => map (// by) p
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
getShift' : Shift len out -> DimEq' len -> Fin len -> Maybe (DimT out)
|
getVar : DimEq' d -> Var d -> Loc -> Dim d
|
||||||
|
getVar eqs i loc = fromMaybe (B i loc) $ get' eqs i
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
getShift' : Shift len out -> DimEq' len -> Var len -> Maybe (Dim out)
|
||||||
getShift' = getShiftWith $ \p, by => map (// by) p
|
getShift' = getShiftWith $ \p, by => map (// by) p
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
get : {d : Nat} -> DimEq' d -> DimT d -> DimT d
|
get : DimEq' d -> Dim d -> Dim d
|
||||||
get eqs p@(Th _ (K {})) = p
|
get _ (K e loc) = K e loc
|
||||||
get eqs p@(Th i (B _)) = fromMaybe p $ get' eqs i.fin
|
get eqs (B i loc) = getVar eqs i loc
|
||||||
|
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
equal : {d : Nat} -> DimEq d -> (p, q : DimT d) -> Bool
|
equal : DimEq d -> (p, q : Dim d) -> Bool
|
||||||
equal ZeroIsOne p q = True
|
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
|
||||||
(:<?) : {d : Nat} -> DimEq d -> Maybe (DimT d) -> DimEq (S d)
|
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
|
||||||
ZeroIsOne :<? d = ZeroIsOne
|
ZeroIsOne :<? d = ZeroIsOne
|
||||||
C eqs :<? d = C $ eqs :< map (get eqs) d
|
C eqs :<? d = C $ eqs :< map (get eqs) d
|
||||||
|
|
||||||
|
|
||||||
private %inline
|
private %inline
|
||||||
isVar : {d : Nat} -> Fin d -> DimT d -> Bool
|
ifVar : Var d -> Dim d -> Maybe (Dim d) -> Maybe (Dim d)
|
||||||
isVar i (Th j (B _)) = i == j.fin
|
ifVar i p = map $ \q => if q == B i noLoc then p else q
|
||||||
isVar i (Th _ (K {})) = False
|
|
||||||
|
|
||||||
private %inline
|
|
||||||
ifVar : {d : Nat} -> Fin d -> DimT d -> Maybe (DimT d) -> Maybe (DimT d)
|
|
||||||
ifVar i p = map $ \q => if isVar i q then p else q
|
|
||||||
|
|
||||||
-- (using decEq instead of (==) because of the proofs below)
|
-- (using decEq instead of (==) because of the proofs below)
|
||||||
private %inline
|
private %inline
|
||||||
|
@ -144,45 +141,43 @@ checkConst e f eqs = if isYes $ e `decEq` f then C eqs else ZeroIsOne
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
setConst : {d : Nat} -> Fin d -> DimConst -> Loc -> DimEq' d -> DimEq d
|
setConst : Var d -> DimConst -> Loc -> DimEq' d -> DimEq d
|
||||||
setConst FZ e loc (eqs :< Nothing) =
|
setConst VZ e loc (eqs :< Nothing) =
|
||||||
C $ eqs :< Just (KT e loc)
|
C $ eqs :< Just (K e loc)
|
||||||
setConst FZ e _ (eqs :< Just (Th _ (K f loc))) =
|
setConst VZ e _ (eqs :< Just (K f loc)) =
|
||||||
checkConst e f $ eqs :< Just (KT f loc)
|
checkConst e f $ eqs :< Just (K f loc)
|
||||||
setConst FZ e loc (eqs :< Just (Th j (B _))) =
|
setConst VZ e loc (eqs :< Just (B i _)) =
|
||||||
setConst j.fin e loc eqs :<? Just (KT e loc)
|
setConst i e loc eqs :<? Just (K e loc)
|
||||||
setConst (FS i) e loc (eqs :< p) =
|
setConst (VS i) e loc (eqs :< p) =
|
||||||
setConst i e loc eqs :<? ifVar i (KT e loc) p
|
setConst i e loc eqs :<? ifVar i (K e loc) p
|
||||||
|
|
||||||
mutual
|
mutual
|
||||||
private
|
private
|
||||||
setVar' : {d : Nat} ->
|
setVar' : (i, j : Var d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
|
||||||
(i, j : Fin d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
|
setVar' VZ (VS i) LTZ loc (eqs :< Nothing) =
|
||||||
setVar' FZ (FS i) LTZ loc (eqs :< Nothing) =
|
C eqs :<? Just (B i loc)
|
||||||
C eqs :<? Just (BV i loc)
|
setVar' VZ (VS i) LTZ loc (eqs :< Just (K e eloc)) =
|
||||||
setVar' FZ (FS i) LTZ loc (eqs :< Just (Th _ (K e eloc))) =
|
setConst i e loc eqs :<? Just (K e eloc)
|
||||||
setConst i e loc eqs :<? Just (KT e eloc)
|
setVar' VZ (VS i) LTZ loc (eqs :< Just (B j jloc)) =
|
||||||
setVar' FZ (FS i) LTZ loc (eqs :< Just (Th j (B jloc))) =
|
setVar i j loc jloc eqs :<? Just (if j > i then B j jloc else B i loc)
|
||||||
let j = j.fin in
|
setVar' (VS i) (VS j) (LTS lt) loc (eqs :< p) =
|
||||||
setVar i j loc jloc eqs :<? Just (if j > i then BV j jloc else BV i loc)
|
setVar' i j lt loc eqs :<? ifVar i (B j loc) p
|
||||||
setVar' (FS i) (FS j) (LTS lt) loc (eqs :< p) =
|
|
||||||
setVar' i j lt loc eqs :<? ifVar i (BV j loc) p
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
setVar : {d : Nat} -> (i, j : Fin d) -> Loc -> Loc -> DimEq' d -> DimEq d
|
setVar : (i, j : Var d) -> Loc -> Loc -> DimEq' d -> DimEq d
|
||||||
setVar i j li lj eqs with (compareP i j)
|
setVar i j li lj eqs with (compareP i j) | (compare i.nat j.nat)
|
||||||
setVar i j li lj eqs | IsLT lt = setVar' i j lt lj eqs
|
setVar i j li lj eqs | IsLT lt | LT = setVar' i j lt lj eqs
|
||||||
setVar i i li lj eqs | IsEQ = C eqs
|
setVar i i li lj eqs | IsEQ | EQ = C eqs
|
||||||
setVar i j li lj eqs | IsGT gt = setVar' j i gt li eqs
|
setVar i j li lj eqs | IsGT gt | GT = setVar' j i gt li eqs
|
||||||
|
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
set : {d : Nat} -> (p, q : DimT d) -> DimEq d -> DimEq d
|
set : (p, q : Dim d) -> DimEq d -> DimEq d
|
||||||
set _ _ ZeroIsOne = ZeroIsOne
|
set _ _ ZeroIsOne = ZeroIsOne
|
||||||
set (Th _ (K e _)) (Th _ (K f _)) (C eqs) = checkConst e f eqs
|
set (K e eloc) (K f floc) (C eqs) = checkConst e f eqs
|
||||||
set (Th _ (K e el)) (Th j (B _)) (C eqs) = setConst j.fin e el eqs
|
set (K e eloc) (B i iloc) (C eqs) = setConst i e eloc eqs
|
||||||
set (Th i (B _)) (Th _ (K e el)) (C eqs) = setConst i.fin e el eqs
|
set (B i iloc) (K e eloc) (C eqs) = setConst i e eloc eqs
|
||||||
set (Th i (B il)) (Th j (B jl)) (C eqs) = setVar i.fin j.fin il jl eqs
|
set (B i iloc) (B j jloc) (C eqs) = setVar i j iloc jloc eqs
|
||||||
|
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
|
@ -190,99 +185,116 @@ Split : Nat -> Type
|
||||||
Split d = (DimEq' d, DSubst (S d) d)
|
Split d = (DimEq' d, DSubst (S d) d)
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
split1 : {d : Nat} -> DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
|
split1 : DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
|
||||||
split1 e loc eqs = case setConst 0 e loc eqs of
|
split1 e loc eqs = case setConst VZ e loc eqs of
|
||||||
ZeroIsOne => Nothing
|
ZeroIsOne => Nothing
|
||||||
C (eqs :< _) => Just (eqs, id (B loc) :< KT e loc)
|
C (eqs :< _) => Just (eqs, K e loc ::: id)
|
||||||
|
|
||||||
export %inline
|
export %inline
|
||||||
split : {d : Nat} -> 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' : {d : Nat} -> Loc -> DimEq' d -> List (DSubst d 0)
|
splits' : Loc -> DimEq' d -> FreeVars d -> List (DSubst d 0)
|
||||||
splits' _ [<] = [[<]]
|
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 : {d : Nat} -> 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
|
|
||||||
-- 0 newGetShift : (d : Nat) -> (i : Fin d) -> (by : Shift d d') ->
|
|
||||||
-- getShift' by (new' {d}) i = Nothing
|
|
||||||
-- newGetShift (S d) FZ by = Refl
|
|
||||||
-- newGetShift (S d) (FS i) by = newGetShift d i (ssDown by)
|
|
||||||
|
|
||||||
-- export
|
|
||||||
-- 0 newGet' : (d : Nat) -> (i : Fin d) -> get' (new' {d}) i = Nothing
|
|
||||||
-- newGet' d i = newGetShift d i SZ
|
|
||||||
|
|
||||||
-- export
|
|
||||||
-- 0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p
|
|
||||||
-- newGet d (K e _) = Refl
|
|
||||||
-- newGet d (B i _) = rewrite newGet' d i in Refl
|
|
||||||
|
|
||||||
|
|
||||||
-- export
|
|
||||||
-- 0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs
|
|
||||||
-- setSelf p ZeroIsOne = Refl
|
|
||||||
-- setSelf (K Zero _) (C eqs) = Refl
|
|
||||||
-- setSelf (K One _) (C eqs) = Refl
|
|
||||||
-- setSelf (B i _) (C eqs) with (compareP i i) | (compare i.nat i.nat)
|
|
||||||
-- _ | IsLT lt | LT = absurd lt
|
|
||||||
-- _ | IsEQ | EQ = Refl
|
|
||||||
-- _ | IsGT gt | GT = absurd gt
|
|
||||||
|
|
||||||
|
|
||||||
parameters {opts : LayoutOpts}
|
|
||||||
private
|
|
||||||
prettyDVars : {d : Nat} -> BContext d -> Eff Pretty (SnocList (Doc opts))
|
|
||||||
prettyDVars = traverse prettyDBind . toSnocList'
|
|
||||||
|
|
||||||
private
|
private
|
||||||
prettyCst : {d : Nat} -> BContext d -> DimT d -> DimT d -> Eff Pretty (Doc opts)
|
0 newGetShift : (d : Nat) -> (i : Var d) -> (by : Shift d d') ->
|
||||||
|
getShift' by (new' {d}) i = Nothing
|
||||||
|
newGetShift (S d) VZ by = Refl
|
||||||
|
newGetShift (S d) (VS i) by = newGetShift d i (ssDown by)
|
||||||
|
|
||||||
|
export
|
||||||
|
0 newGet' : (d : Nat) -> (i : Var d) -> get' (new' {d}) i = Nothing
|
||||||
|
newGet' d i = newGetShift d i SZ
|
||||||
|
|
||||||
|
export
|
||||||
|
0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p
|
||||||
|
newGet d (K e _) = Refl
|
||||||
|
newGet d (B i _) = rewrite newGet' d i in Refl
|
||||||
|
|
||||||
|
|
||||||
|
export
|
||||||
|
0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs
|
||||||
|
setSelf p ZeroIsOne = Refl
|
||||||
|
setSelf (K Zero _) (C eqs) = Refl
|
||||||
|
setSelf (K One _) (C eqs) = Refl
|
||||||
|
setSelf (B i _) (C eqs) with (compareP i i) | (compare i.nat i.nat)
|
||||||
|
_ | IsLT lt | LT = absurd lt
|
||||||
|
_ | IsEQ | EQ = Refl
|
||||||
|
_ | IsGT gt | GT = absurd gt
|
||||||
|
|
||||||
|
|
||||||
|
private %inline
|
||||||
|
dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec
|
||||||
|
dimEqPrec vars eqs =
|
||||||
|
if length vars <= 1 && maybe True null eqs then Arg else Outer
|
||||||
|
|
||||||
|
private
|
||||||
|
prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
|
||||||
|
prettyDVars' = traverse prettyDBind . toSnocList'
|
||||||
|
|
||||||
|
export
|
||||||
|
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
|
||||||
|
prettyDVars vars =
|
||||||
|
parensIfM (dimEqPrec vars Nothing) $
|
||||||
|
fillSeparateTight !commaD $ !(prettyDVars' vars)
|
||||||
|
|
||||||
|
private
|
||||||
|
prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
|
||||||
prettyCst dnames p q =
|
prettyCst dnames p q =
|
||||||
hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
|
hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
|
||||||
|
|
||||||
private
|
private
|
||||||
prettyCsts : {d : Nat} -> BContext d -> DimEq' d ->
|
prettyCsts : {opts : _} -> BContext d -> DimEq' d ->
|
||||||
Eff Pretty (SnocList (Doc opts))
|
Eff Pretty (SnocList (Doc opts))
|
||||||
prettyCsts [<] [<] = pure [<]
|
prettyCsts [<] [<] = pure [<]
|
||||||
prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs
|
prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs
|
||||||
prettyCsts dnames (eqs :< Just q) =
|
prettyCsts dnames (eqs :< Just q) =
|
||||||
[|prettyCsts (tail dnames) eqs :<
|
[|prettyCsts (tail dnames) eqs :< prettyCst dnames (BV 0 noLoc) (weakD 1 q)|]
|
||||||
prettyCst dnames (BV 0 noLoc) (weak 1 q)|]
|
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyDimEq' : {d : Nat} -> 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 : {d : Nat} -> 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 [<] (KT Zero noLoc) (KT 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
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
wf' : {d : Nat} -> DimEq' d -> Bool
|
wf' : DimEq' d -> Bool
|
||||||
wf' [<] = True
|
wf' [<] = True
|
||||||
wf' (eqs :< Nothing) = wf' eqs
|
wf' (eqs :< Nothing) = wf' eqs
|
||||||
wf' (eqs :< Just (Th _ (K {}))) = wf' eqs
|
wf' (eqs :< Just (K e _)) = wf' eqs
|
||||||
wf' (eqs :< Just (Th i (B _))) = isNothing (get' eqs i.fin) && wf' eqs
|
wf' (eqs :< Just (B i _)) = isNothing (get' eqs i) && wf' eqs
|
||||||
|
|
||||||
public export
|
public export
|
||||||
wf : {d : Nat} -> DimEq d -> Bool
|
wf : DimEq d -> Bool
|
||||||
wf ZeroIsOne = True
|
wf ZeroIsOne = True
|
||||||
wf (C eqs) = wf' eqs
|
wf (C eqs) = wf' 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,11 +1,11 @@
|
||||||
module Quox.Syntax.Shift
|
module Quox.Syntax.Shift
|
||||||
|
|
||||||
import public Quox.Syntax.Var
|
import public Quox.Var
|
||||||
import public Quox.Thin
|
|
||||||
|
|
||||||
import Data.Nat
|
import Data.Nat
|
||||||
import Data.So
|
import Data.So
|
||||||
import Data.DPair
|
import Data.Singleton
|
||||||
|
import Syntax.PreorderReasoning
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
|
|
||||||
|
@ -148,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
|
||||||
|
@ -180,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) ->
|
||||||
|
@ -207,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
|
||||||
|
@ -222,15 +242,3 @@ namespace CanShift
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
[Const] CanShift (\_ => a) where x // _ = x
|
[Const] CanShift (\_ => a) where x // _ = x
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
shiftOPE : {mask : Nat} -> (0 ope : OPE m n mask) ->
|
|
||||||
Shift n n' -> Subset Nat (OPE m n')
|
|
||||||
shiftOPE ope SZ = Element _ ope
|
|
||||||
shiftOPE ope (SS by) =
|
|
||||||
let Element _ ope = shiftOPE ope by in Element _ $ drop ope
|
|
||||||
|
|
||||||
export
|
|
||||||
CanShift (Thinned f) where
|
|
||||||
Th ope tm // by = Th (shiftOPE ope by).snd tm
|
|
||||||
|
|
|
@ -1,11 +1,13 @@
|
||||||
module Quox.Syntax.Subst
|
module Quox.Syntax.Subst
|
||||||
|
|
||||||
import Quox.Thin
|
import public Quox.Syntax.Shift
|
||||||
import Quox.Loc
|
import Quox.Var
|
||||||
|
import Quox.Name
|
||||||
|
|
||||||
import Data.DPair
|
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
|
||||||
|
@ -13,159 +15,155 @@ import Derive.Prelude
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
Subst : (Nat -> Type) -> Nat -> Nat -> Type
|
data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
|
||||||
Subst env from to = SnocVect from (Lazy (Thinned env to))
|
Shift : Shift from to -> Subst env from to
|
||||||
|
(:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
|
||||||
|
%name Subst th, ph, ps
|
||||||
|
|
||||||
|
export infixr 7 !:::
|
||||||
|
||| in case the automatic laziness insertion gets confused
|
||||||
public export
|
public export
|
||||||
Subst2 : (Nat -> Nat -> Type) -> Nat -> Nat -> Nat -> Type
|
(!:::) : env to -> Subst env from to -> Subst env (S from) to
|
||||||
Subst2 env d from to = SnocVect from (Lazy (Thinned2 env d to))
|
t !::: ts = t ::: ts
|
||||||
|
|
||||||
|
|
||||||
public export
|
private
|
||||||
get : Subst env f t -> Fin f -> Thinned env t
|
Repr : (Nat -> Type) -> Nat -> Type
|
||||||
get (sx :< x) FZ = x
|
Repr f to = (List (f to), Nat)
|
||||||
get (sx :< x) (FS i) = get sx i
|
|
||||||
|
private
|
||||||
|
repr : Subst f from to -> Repr f to
|
||||||
|
repr (Shift by) = ([], by.nat)
|
||||||
|
repr (t ::: th) = let (ts, i) = repr th in (t::ts, i)
|
||||||
|
|
||||||
|
|
||||||
public export
|
export Eq (f to) => Eq (Subst f from to) where (==) = (==) `on` repr
|
||||||
interface FromVar (0 term : Nat -> Type) where
|
export Ord (f to) => Ord (Subst f from to) where compare = compare `on` repr
|
||||||
var : Loc -> term 1
|
export Show (f to) => Show (Subst f from to) where show = show . repr
|
||||||
|
|
||||||
public export
|
|
||||||
0 FromVar2 : (Nat -> Nat -> Type) -> Type
|
|
||||||
FromVar2 t = FromVar (t 0)
|
|
||||||
|
|
||||||
public export
|
export infixl 8 //
|
||||||
varT : FromVar term => Fin n -> Loc -> Thinned term n
|
|
||||||
varT i loc = Th (one' i) (var loc)
|
|
||||||
|
|
||||||
public export
|
|
||||||
varT2 : FromVar2 term => Fin n -> Loc -> Thinned2 term d n
|
|
||||||
varT2 i loc = Th2 zero (one' i) (var loc)
|
|
||||||
|
|
||||||
infixl 8 //
|
|
||||||
namespace CanSubstSelf
|
|
||||||
public export
|
public export
|
||||||
interface FromVar term => CanSubstSelf term where
|
interface FromVar term => CanSubstSelf term where
|
||||||
(//) : {f : Nat} -> Thinned term f -> Subst term f t -> Thinned term t
|
(//) : term from -> Lazy (Subst term from to) -> term to
|
||||||
|
|
||||||
namespace CanSubstSelf2
|
|
||||||
public export
|
|
||||||
interface FromVar2 term => CanSubstSelf2 term where
|
|
||||||
(//) : {f : Nat} -> Thinned2 term d f ->
|
|
||||||
Subst2 term d f t -> Thinned2 term d t
|
|
||||||
|
|
||||||
public export
|
|
||||||
(.) : {mid : Nat} -> CanSubstSelf f =>
|
|
||||||
Subst f from mid -> Subst f mid to -> Subst f from to
|
|
||||||
th . ph = map (\(Delay x) => x // ph) th
|
|
||||||
|
|
||||||
infixr 9 .%
|
|
||||||
|
|
||||||
public export
|
|
||||||
(.%) : {mid : Nat} -> CanSubstSelf2 f =>
|
|
||||||
Subst2 f d from mid -> Subst2 f d mid to -> Subst2 f d from to
|
|
||||||
th .% ph = map (\(Delay x) => x // ph) th
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
tabulate : (n : Nat) -> SnocVect n (Fin n)
|
getLoc : FromVar term => Subst term from to -> Var from -> Loc -> term to
|
||||||
tabulate n = go n id where
|
getLoc (Shift by) i loc = fromVarLoc (shift by i) loc
|
||||||
go : (n : Nat) -> (Fin n -> Fin n') -> SnocVect n (Fin n')
|
getLoc (t ::: th) VZ _ = t
|
||||||
go 0 f = [<]
|
getLoc (t ::: th) (VS i) loc = getLoc th i loc
|
||||||
go (S n) f = go n (f . FS) :< f FZ
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
id : FromVar term => {n : Nat} -> (under : Nat) -> Loc ->
|
CanSubstSelf Var where
|
||||||
Subst term n (n + under)
|
i // Shift by = shift by i
|
||||||
id under loc =
|
VZ // (t ::: th) = t
|
||||||
map (\i => delay $ varT (weakenN under i) loc) (tabulate n)
|
VS i // (t ::: th) = i // th
|
||||||
|
|
||||||
public export
|
|
||||||
id2 : FromVar2 term => {n : Nat} -> Loc -> Subst2 term d n n
|
|
||||||
id2 loc = map (\i => delay $ varT2 i loc) $ tabulate n
|
|
||||||
|
|
||||||
export
|
|
||||||
select : {n, mask : Nat} -> (0 ope : OPE m n mask) ->
|
|
||||||
SnocVect n a -> SnocVect m a
|
|
||||||
select ope sx with %syntactic (view ope)
|
|
||||||
select _ [<] | StopV = [<]
|
|
||||||
select _ (sx :< x) | DropV _ ope = select ope sx
|
|
||||||
select _ (sx :< x) | KeepV _ ope = select ope sx :< x
|
|
||||||
|
|
||||||
export
|
|
||||||
opeToFins : {n, mask : Nat} ->
|
|
||||||
(0 ope : OPE m n mask) -> SnocVect m (Fin n)
|
|
||||||
opeToFins ope = select ope $ tabulate n
|
|
||||||
|
|
||||||
export
|
|
||||||
shift : FromVar term => {from : Nat} ->
|
|
||||||
(n : Nat) -> Loc -> Subst term from (n + from)
|
|
||||||
shift n loc = map (\i => delay $ varT (shift n i) loc) $ tabulate from
|
|
||||||
|
|
||||||
public export
|
|
||||||
pushN : CanSubstSelf term => {to : Nat} -> (by : Nat) ->
|
|
||||||
Subst term from to -> Loc -> Subst term (by + from) (by + to)
|
|
||||||
pushN by th loc =
|
|
||||||
rewrite plusCommutative by from in
|
|
||||||
(th . shift by loc) ++ id to loc
|
|
||||||
|
|
||||||
public export %inline
|
|
||||||
push : CanSubstSelf f => {to : Nat} ->
|
|
||||||
Subst f from to -> Loc -> Subst f (S from) (S to)
|
|
||||||
push = pushN 1
|
|
||||||
|
|
||||||
|
|
||||||
public export %inline
|
public export %inline
|
||||||
one : Thinned f n -> Subst f 1 n
|
shift : (by : Nat) -> Subst env from (by + from)
|
||||||
one x = [< x]
|
shift by = Shift $ fromNat by
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
shift0 : (by : Nat) -> Subst env 0 by
|
||||||
|
shift0 by = rewrite sym $ plusZeroRightNeutral by in Shift $ fromNat by
|
||||||
|
|
||||||
|
|
||||||
|
public export
|
||||||
|
(.) : CanSubstSelf f => Subst f from mid -> Subst f mid to -> Subst f from to
|
||||||
|
Shift by . Shift bz = Shift $ by . bz
|
||||||
|
Shift SZ . ph = ph
|
||||||
|
Shift (SS by) . (t ::: th) = Shift by . th
|
||||||
|
(t ::: th) . ph = (t // ph) ::: (th . ph)
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
id : Subst f n n
|
||||||
|
id = shift 0
|
||||||
|
|
||||||
|
public export
|
||||||
|
traverse : Applicative m =>
|
||||||
|
(f to -> m (g to)) -> Subst f from to -> m (Subst g from to)
|
||||||
|
traverse f (Shift by) = pure $ Shift by
|
||||||
|
traverse f (t ::: th) = [|f t !::: traverse f th|]
|
||||||
|
|
||||||
|
-- not in terms of traverse because this map can maintain laziness better
|
||||||
|
public export
|
||||||
|
map : (f to -> g to) -> Subst f from to -> Subst g from to
|
||||||
|
map f (Shift by) = Shift by
|
||||||
|
map f (t ::: th) = f t ::: map f th
|
||||||
|
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
|
||||||
|
push loc th = fromVarLoc VZ loc ::: (th . shift 1)
|
||||||
|
|
||||||
|
-- [fixme] a better way to do this?
|
||||||
|
public export
|
||||||
|
pushN : CanSubstSelf f => (s : Nat) -> Loc ->
|
||||||
|
Subst f from to -> Subst f (s + from) (s + to)
|
||||||
|
pushN 0 _ th = th
|
||||||
|
pushN (S s) loc th =
|
||||||
|
rewrite plusSuccRightSucc s from in
|
||||||
|
rewrite plusSuccRightSucc s to in
|
||||||
|
pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
|
||||||
|
|
||||||
|
public export
|
||||||
|
drop1 : Subst f (S from) to -> Subst f from to
|
||||||
|
drop1 (Shift by) = Shift $ ssDown by
|
||||||
|
drop1 (t ::: th) = th
|
||||||
|
|
||||||
|
|
||||||
|
public export
|
||||||
|
fromSnocVect : SnocVect s (f n) -> Subst f (s + n) n
|
||||||
|
fromSnocVect [<] = id
|
||||||
|
fromSnocVect (xs :< x) = x ::: fromSnocVect xs
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
one : f n -> Subst f (S n) n
|
||||||
|
one x = fromSnocVect [< x]
|
||||||
|
|
||||||
|
|
||||||
||| whether two substitutions with the same codomain have the same domain
|
|
||||||
export
|
export
|
||||||
cmpShape : SnocVect m a -> SnocVect n a -> Either Ordering (m = n)
|
getFrom : {to : Nat} -> Subst _ from to -> Singleton from
|
||||||
cmpShape [<] [<] = Right Refl
|
getFrom (Shift by) = getFrom by
|
||||||
cmpShape [<] (sx :< _) = Left LT
|
getFrom (t ::: th) = [|S $ getFrom th|]
|
||||||
cmpShape (sx :< _) [<] = Left GT
|
|
||||||
cmpShape (sx :< _) (sy :< _) = cong S <$> cmpShape sx sy
|
|
||||||
|
||| whether two substitutions with the same codomain have the same shape
|
||||||
|
||| (the same number of terms and the same shift at the end). if so, they
|
||||||
|
||| also have the same domain
|
||||||
|
export
|
||||||
|
cmpShape : Subst env from1 to -> Subst env from2 to ->
|
||||||
|
Either Ordering (from1 = from2)
|
||||||
|
cmpShape (Shift by) (Shift bz) = cmpLen by bz
|
||||||
|
cmpShape (Shift _) (_ ::: _) = Left LT
|
||||||
|
cmpShape (_ ::: _) (Shift _) = Left GT
|
||||||
|
cmpShape (_ ::: th) (_ ::: ph) = map (\x => cong S x) $ cmpShape th ph
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
record WithSubst tm env n where
|
record WithSubst tm env n where
|
||||||
constructor Sub
|
constructor Sub
|
||||||
term : tm from
|
term : tm from
|
||||||
subst : Subst env from n
|
subst : Lazy (Subst env from n)
|
||||||
|
|
||||||
{-
|
|
||||||
export
|
export
|
||||||
(forall n. Eq (env n), forall n. Eq (tm n)) =>
|
(Eq (env n), forall n. Eq (tm n)) => Eq (WithSubst tm env n) where
|
||||||
Eq (WithSubst tm env n) where
|
|
||||||
Sub t1 s1 == Sub t2 s2 =
|
Sub t1 s1 == Sub t2 s2 =
|
||||||
case cmpShape s1 s2 of
|
case cmpShape s1 s2 of
|
||||||
Left _ => False
|
Left _ => False
|
||||||
Right Refl =>
|
Right Refl => t1 == t2 && s1 == s2
|
||||||
t1 == t2 && concat @{All} (zipWith ((==) `on` force) s1 s2)
|
|
||||||
|
|
||||||
export
|
export
|
||||||
(forall n. Ord (env n), forall n. Ord (tm n)) =>
|
(Ord (env n), forall n. Ord (tm n)) => Ord (WithSubst tm env n) where
|
||||||
Ord (WithSubst tm env n) where
|
|
||||||
Sub t1 s1 `compare` Sub t2 s2 =
|
Sub t1 s1 `compare` Sub t2 s2 =
|
||||||
case cmpShape s1 s2 of
|
case cmpShape s1 s2 of
|
||||||
Left o => o
|
Left o => o
|
||||||
Right Refl =>
|
Right Refl => compare (t1, s1) (t2, s2)
|
||||||
compare t1 t2 <+> concat (zipWith (compare `on` force) s1 s2)
|
|
||||||
|
|
||||||
export %hint
|
export %hint
|
||||||
ShowWithSubst : {n : Nat} ->
|
ShowWithSubst : (Show (env n), forall n. Show (tm n)) =>
|
||||||
(forall n. Show (env n), forall n. Show (tm n)) =>
|
|
||||||
Show (WithSubst tm env n)
|
Show (WithSubst tm env n)
|
||||||
ShowWithSubst = deriveShow where
|
ShowWithSubst = deriveShow
|
||||||
Show (Lazy (Thinned env n)) where showPrec d = showPrec d . force
|
|
||||||
-}
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
record WithSubst2 tm env d n where
|
|
||||||
constructor Sub2
|
|
||||||
term : tm d from
|
|
||||||
subst : Subst2 env d from n
|
|
||||||
|
|
|
@ -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,7 +1,7 @@
|
||||||
module Quox.Syntax.Term.Base
|
module Quox.Syntax.Term.Base
|
||||||
|
|
||||||
import public Quox.Thin
|
import public Quox.Var
|
||||||
import public Quox.Syntax.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
|
||||||
|
@ -19,6 +19,9 @@ import Data.Maybe
|
||||||
import Data.Nat
|
import Data.Nat
|
||||||
import public Data.So
|
import public Data.So
|
||||||
import Data.String
|
import Data.String
|
||||||
|
import public Data.SortedMap
|
||||||
|
import public Data.SortedMap.Dependent
|
||||||
|
import public Data.SortedSet
|
||||||
import Derive.Prelude
|
import Derive.Prelude
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
|
@ -44,344 +47,406 @@ TagVal : Type
|
||||||
TagVal = String
|
TagVal = String
|
||||||
|
|
||||||
|
|
||||||
||| type-checkable terms, which consists of types and constructor forms.
|
mutual
|
||||||
|||
|
|
||||||
||| first argument `d` is dimension scope size; second `n` is term scope size
|
|
||||||
public export
|
public export
|
||||||
data Term : (d, n : Nat) -> Type
|
TSubst : TSubstLike
|
||||||
%name Term s, t, r
|
TSubst d = Subst $ \n => Elim d n
|
||||||
|
|
||||||
||| inferrable terms, which consists of elimination forms like application and
|
||| first argument `d` is dimension scope size;
|
||||||
||| `case` (as well as other terms with an annotation)
|
||| second `n` is term scope size
|
||||||
|||
|
|
||||||
||| first argument `d` is dimension scope size; second `n` is term scope size
|
|
||||||
public export
|
public export
|
||||||
data Elim : (d, n : Nat) -> Type
|
data Term : (d, n : Nat) -> Type where
|
||||||
%name Elim e, f
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
ScopeTermN : Nat -> TermLike
|
|
||||||
ScopeTermN s d n = ScopedN s (\n => Term d n) n
|
|
||||||
|
|
||||||
public export
|
|
||||||
DScopeTermN : Nat -> TermLike
|
|
||||||
DScopeTermN s d n = ScopedN s (\d => Term d n) d
|
|
||||||
|
|
||||||
public export
|
|
||||||
ScopeTerm : TermLike
|
|
||||||
ScopeTerm = ScopeTermN 1
|
|
||||||
|
|
||||||
public export
|
|
||||||
DScopeTerm : TermLike
|
|
||||||
DScopeTerm = DScopeTermN 1
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
TermT : TermLike
|
|
||||||
TermT = Thinned2 (\d, n => Term d n)
|
|
||||||
|
|
||||||
public export
|
|
||||||
ElimT : TermLike
|
|
||||||
ElimT = Thinned2 (\d, n => Elim d n)
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
DimArg : TermLike
|
|
||||||
DimArg d n = Dim d
|
|
||||||
|
|
||||||
|
|
||||||
data Term where
|
|
||||||
||| type of types
|
||| type of types
|
||||||
TYPE : (l : Universe) -> (loc : Loc) -> Term 0 0
|
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 -> Subterms [Term, ScopeTerm] d n -> Loc -> Term d n
|
Pi : (qty : Qty) -> (arg : Term d n) ->
|
||||||
||| function value
|
(res : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||||
Lam : ScopeTerm d n -> Loc -> Term d n
|
||| function term
|
||||||
|
Lam : (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||||
|
|
||||||
||| pair type
|
||| pair type
|
||||||
Sig : Subterms [Term, ScopeTerm] d n -> Loc -> Term d n
|
Sig : (fst : Term d n) -> (snd : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||||
||| pair value
|
||| pair value
|
||||||
Pair : Subterms [Term, Term] d n -> Loc -> Term d n
|
Pair : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
|
||||||
||| enum type
|
||| enumeration type
|
||||||
Enum : List TagVal -> Loc -> Term 0 0
|
Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term d n
|
||||||
||| enum value
|
||| enumeration value
|
||||||
Tag : TagVal -> Loc -> Term 0 0
|
Tag : (tag : TagVal) -> (loc : Loc) -> Term d n
|
||||||
|
|
||||||
||| equality type
|
||| equality type
|
||||||
Eq : Subterms [DScopeTerm, Term, Term] d n -> Loc -> Term d n
|
Eq : (ty : DScopeTerm d n) -> (l, r : Term d n) -> (loc : Loc) -> Term d n
|
||||||
||| equality value
|
||| equality term
|
||||||
DLam : DScopeTerm d n -> 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 -> Term 0 0
|
NAT : (loc : Loc) -> Term d n
|
||||||
Zero : Loc -> Term 0 0
|
Nat : (val : Nat) -> (loc : Loc) -> Term d n
|
||||||
Succ : Term d n -> Loc -> Term 0 0
|
Succ : (p : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
|
||||||
||| package a value with a quantity
|
||| strings
|
||||||
||| e.g. a value of [ω. A], when unpacked, can be used ω times,
|
STRING : (loc : Loc) -> Term d n
|
||||||
||| even if the box itself is linear
|
Str : (str : String) -> (loc : Loc) -> Term d n
|
||||||
BOX : Qty -> Term d n -> Loc -> Term d n
|
|
||||||
Box : Term d n -> Loc -> Term d n
|
|
||||||
|
|
||||||
E : Elim d n -> Term d n
|
||| "box" (package a value up with a certain quantity)
|
||||||
|
BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
Box : (val : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
|
||||||
|
Let : (qty : Qty) -> (rhs : Elim d n) ->
|
||||||
|
(body : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||||
|
|
||||||
|
||| elimination
|
||||||
|
E : (e : Elim d n) -> Term d n
|
||||||
|
|
||||||
||| term closure/suspended substitution
|
||| term closure/suspended substitution
|
||||||
CloT : WithSubst2 Term Elim d n -> Term d n
|
CloT : WithSubst (Term d) (Elim d) n -> Term d n
|
||||||
||| dimension closure/suspended substitution
|
||| dimension closure/suspended substitution
|
||||||
DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
|
DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
|
||||||
|
%name Term s, t, r
|
||||||
|
|
||||||
|
||| first argument `d` is dimension scope size, second `n` is term scope size
|
||||||
public export
|
public export
|
||||||
data Elim where
|
data Elim : (d, n : Nat) -> Type where
|
||||||
||| free variable, possibly with a displacement (see @crude, or @mugen for a
|
||| free variable, possibly with a displacement (see @crude, or @mugen for a
|
||||||
||| more abstract and formalised take)
|
||| more abstract and formalised take)
|
||||||
|||
|
|||
|
||||||
||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
|
||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
|
||||||
F : Name -> Universe -> Loc -> Elim 0 0
|
F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim d n
|
||||||
||| bound variable
|
||| bound variable
|
||||||
B : Loc -> Elim 0 1
|
B : (i : Var n) -> (loc : Loc) -> Elim d n
|
||||||
|
|
||||||
||| term application
|
||| term application
|
||||||
App : Subterms [Elim, Term] d n -> Loc -> Elim d n
|
App : (fun : Elim d n) -> (arg : Term d n) -> (loc : Loc) -> Elim d n
|
||||||
|
|
||||||
||| pair match
|
||| pair destruction
|
||||||
||| - the subterms are, in order: [head, return type, body]
|
|||
|
||||||
||| - the quantity is that of the head, and since pairs only have one
|
||| `CasePair 𝜋 𝑒 ([𝑟], 𝐴) ([𝑥, 𝑦], 𝑡)` is
|
||||||
||| constructor, can be 0
|
||| `𝐜𝐚𝐬𝐞 𝜋 · 𝑒 𝐫𝐞𝐭𝐮𝐫𝐧 𝑟 ⇒ 𝐴 𝐨𝐟 { (𝑥, 𝑦) ⇒ 𝑡 }`
|
||||||
CasePair : Qty -> Subterms [Elim, ScopeTerm, ScopeTermN 2] d n ->
|
CasePair : (qty : Qty) -> (pair : Elim d n) ->
|
||||||
Loc -> Elim d n
|
(ret : ScopeTerm d n) ->
|
||||||
|
(body : ScopeTermN 2 d n) ->
|
||||||
|
(loc : Loc) ->
|
||||||
|
Elim d n
|
||||||
|
|
||||||
||| enum match
|
||| first element of a pair. only works in non-linear contexts.
|
||||||
CaseEnum : Qty -> (arms : List TagVal) ->
|
Fst : (pair : Elim d n) -> (loc : Loc) -> Elim d n
|
||||||
Subterms (Elim :: ScopeTerm :: (Term <$ arms)) d n ->
|
|
||||||
Loc -> Elim d n
|
|
||||||
|
|
||||||
||| nat match
|
||| second element of a pair. only works in non-linear contexts.
|
||||||
CaseNat : Qty -> Qty ->
|
Snd : (pair : Elim d n) -> (loc : Loc) -> Elim d n
|
||||||
Subterms [Elim, ScopeTerm, Term, ScopeTermN 2] d n ->
|
|
||||||
Loc -> Elim d n
|
|
||||||
|
|
||||||
||| box match
|
||| enum matching
|
||||||
CaseBox : Qty -> Subterms [Elim, ScopeTerm, ScopeTerm] d n -> Loc -> Elim d n
|
CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
|
||||||
|
(ret : ScopeTerm d n) ->
|
||||||
|
(arms : CaseEnumArms d n) ->
|
||||||
|
(loc : Loc) ->
|
||||||
|
Elim d n
|
||||||
|
|
||||||
|
||| nat matching
|
||||||
|
CaseNat : (qty, qtyIH : Qty) -> (nat : Elim d n) ->
|
||||||
|
(ret : ScopeTerm d n) ->
|
||||||
|
(zero : Term d n) ->
|
||||||
|
(succ : ScopeTermN 2 d n) ->
|
||||||
|
(loc : Loc) ->
|
||||||
|
Elim d n
|
||||||
|
|
||||||
|
||| unboxing
|
||||||
|
CaseBox : (qty : Qty) -> (box : Elim d n) ->
|
||||||
|
(ret : ScopeTerm d n) ->
|
||||||
|
(body : ScopeTerm d n) ->
|
||||||
|
(loc : Loc) ->
|
||||||
|
Elim d n
|
||||||
|
|
||||||
||| dim application
|
||| dim application
|
||||||
DApp : Subterms [Elim, DimArg] d n -> Loc -> Elim d n
|
DApp : (fun : Elim d n) -> (arg : Dim d) -> (loc : Loc) -> Elim d n
|
||||||
|
|
||||||
||| type-annotated term
|
||| type-annotated term
|
||||||
Ann : Subterms [Term, Term] d n -> Loc -> Elim d n
|
Ann : (tm, ty : Term d n) -> (loc : Loc) -> Elim d n
|
||||||
|
|
||||||
||| coerce a value along a type equality, or show its coherence
|
||| coerce a value along a type equality, or show its coherence
|
||||||
||| [@xtt; §2.1.1]
|
||| [@xtt; §2.1.1]
|
||||||
Coe : Subterms [DScopeTerm, DimArg, DimArg, Term] d n ->
|
Coe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
|
||||||
Loc -> Elim d n
|
(val : Term d n) -> (loc : Loc) -> Elim d n
|
||||||
|
|
||||||
||| "generalised composition" [@xtt; §2.1.2]
|
||| "generalised composition" [@xtt; §2.1.2]
|
||||||
Comp : Subterms [Term, DimArg, DimArg, Term,
|
Comp : (ty : Term d n) -> (p, q : Dim d) ->
|
||||||
DimArg, DScopeTerm, DScopeTerm] d n ->
|
(val : Term d n) -> (r : Dim d) ->
|
||||||
Loc -> Elim d n
|
(zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
|
||||||
|
|
||||||
||| match on types. needed for b.s. of coercions [@xtt; §2.2]
|
||| match on types. needed for b.s. of coercions [@xtt; §2.2]
|
||||||
TypeCase : Subterms [Elim, Term, -- head, type
|
TypeCase : (ty : Elim d n) -> (ret : Term d n) ->
|
||||||
Term, -- ★
|
(arms : TypeCaseArms d n) -> (def : Term d n) ->
|
||||||
ScopeTermN 2, -- pi
|
(loc : Loc) ->
|
||||||
ScopeTermN 2, -- sig
|
Elim d n
|
||||||
Term, -- enum
|
|
||||||
ScopeTermN 5, -- eq
|
|
||||||
Term, -- nat
|
|
||||||
ScopeTerm -- box
|
|
||||||
] d n -> Loc -> Elim d n
|
|
||||||
|
|
||||||
||| term closure/suspended substitution
|
||| term closure/suspended substitution
|
||||||
CloE : WithSubst2 Elim Elim d n -> Elim d n
|
CloE : WithSubst (Elim d) (Elim d) n -> Elim d n
|
||||||
||| dimension closure/suspended substitution
|
||| dimension closure/suspended substitution
|
||||||
DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
|
DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
|
||||||
|
%name Elim e, f
|
||||||
|
|
||||||
-- this kills the idris ☹
|
|
||||||
-- export %hint
|
|
||||||
-- EqTerm : Eq (Term d n)
|
|
||||||
|
|
||||||
-- export %hint
|
|
||||||
-- EqElim : Eq (Elim d n)
|
|
||||||
|
|
||||||
-- EqTerm = deriveEq
|
|
||||||
-- EqElim = deriveEq
|
|
||||||
|
|
||||||
|
|
||||||
-- mutual
|
|
||||||
-- export %hint
|
|
||||||
-- ShowTerm : Show (Term d n)
|
|
||||||
-- ShowTerm = assert_total {a = Show (Term d n)} deriveShow
|
|
||||||
|
|
||||||
-- export %hint
|
|
||||||
-- ShowElim : Show (Elim d n)
|
|
||||||
-- ShowElim = assert_total {a = Show (Elim d n)} deriveShow
|
|
||||||
|
|
||||||
-- ||| scope which ignores all its binders
|
|
||||||
-- public export %inline
|
|
||||||
-- SN : {s : Nat} -> f n -> Scoped s f n
|
|
||||||
-- SN = S (replicate s $ BN Unused noLoc) . N
|
|
||||||
|
|
||||||
-- ||| scope which uses its binders
|
|
||||||
-- public export %inline
|
|
||||||
-- SY : BContext s -> f (s + n) -> Scoped s f n
|
|
||||||
-- SY ns = S ns . Y
|
|
||||||
|
|
||||||
-- 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
|
|
||||||
|
|
||||||
-- ||| more convenient Pi
|
|
||||||
-- public export %inline
|
|
||||||
-- PiY : (qty : Qty) -> (x : BindName) ->
|
|
||||||
-- (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
|
|
||||||
-- PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc}
|
|
||||||
|
|
||||||
-- ||| more convenient Lam
|
|
||||||
-- public export %inline
|
|
||||||
-- LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
|
|
||||||
-- LamY {x, body, loc} = Lam {body = SY [< x] body, loc}
|
|
||||||
|
|
||||||
-- public export %inline
|
|
||||||
-- LamN : (body : Term d n) -> (loc : Loc) -> Term d n
|
|
||||||
-- LamN {body, loc} = Lam {body = SN body, loc}
|
|
||||||
|
|
||||||
-- ||| non dependent function type
|
|
||||||
-- public export %inline
|
|
||||||
-- Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n
|
|
||||||
-- Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}
|
|
||||||
|
|
||||||
-- ||| more convenient Sig
|
|
||||||
-- public export %inline
|
|
||||||
-- SigY : (x : BindName) -> (fst : Term d n) ->
|
|
||||||
-- (snd : Term d (S n)) -> (loc : Loc) -> Term d n
|
|
||||||
-- SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}
|
|
||||||
|
|
||||||
-- ||| non dependent pair type
|
|
||||||
-- public export %inline
|
|
||||||
-- And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
|
|
||||||
-- And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}
|
|
||||||
|
|
||||||
-- ||| more convenient Eq
|
|
||||||
-- public export %inline
|
|
||||||
-- EqY : (i : BindName) -> (ty : Term (S d) n) ->
|
|
||||||
-- (l, r : Term d n) -> (loc : Loc) -> Term d n
|
|
||||||
-- EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}
|
|
||||||
|
|
||||||
-- ||| more convenient DLam
|
|
||||||
-- public export %inline
|
|
||||||
-- DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
|
|
||||||
-- DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}
|
|
||||||
|
|
||||||
-- public export %inline
|
|
||||||
-- DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
|
|
||||||
-- DLamN {body, loc} = DLam {body = SN body, loc}
|
|
||||||
|
|
||||||
-- ||| non dependent equality type
|
|
||||||
-- public export %inline
|
|
||||||
-- Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
|
|
||||||
-- Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
|
|
||||||
|
|
||||||
|
|
||||||
||| same as `F` but as a term
|
|
||||||
public export %inline
|
|
||||||
FT : Name -> Universe -> Loc -> Term 0 0
|
|
||||||
FT x u loc = E $ F x u loc
|
|
||||||
|
|
||||||
||| abbreviation for a bound variable like `BV 4` instead of
|
|
||||||
||| `B (VS (VS (VS (VS VZ))))`
|
|
||||||
public export %inline
|
|
||||||
BV : (i : Fin n) -> (loc : Loc) -> ElimT d n
|
|
||||||
BV i loc = Th2 zero (one' i) $ B loc
|
|
||||||
|
|
||||||
||| same as `BV` but as a term
|
|
||||||
public export %inline
|
|
||||||
BVT : (i : Fin n) -> (loc : Loc) -> TermT d n
|
|
||||||
BVT i loc = Th2 zero (one' i) $ E $ B loc
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
makeNat : Nat -> Loc -> Term 0 0
|
CaseEnumArms : TermLike
|
||||||
makeNat 0 loc = Zero loc
|
CaseEnumArms d n = SortedMap TagVal (Term d n)
|
||||||
makeNat (S k) loc = Succ (makeNat k loc) loc
|
|
||||||
|
public export
|
||||||
|
TypeCaseArms : TermLike
|
||||||
|
TypeCaseArms d n = SortedDMap TyConKind (\k => TypeCaseArmBody k d n)
|
||||||
|
|
||||||
|
public export
|
||||||
|
TypeCaseArm : TermLike
|
||||||
|
TypeCaseArm d n = (k ** TypeCaseArmBody k d n)
|
||||||
|
|
||||||
|
public export
|
||||||
|
TypeCaseArmBody : TyConKind -> TermLike
|
||||||
|
TypeCaseArmBody k = ScopeTermN (arity k)
|
||||||
|
|
||||||
|
|
||||||
|
public export
|
||||||
|
ScopeTermN, DScopeTermN : Nat -> TermLike
|
||||||
|
ScopeTermN s d n = Scoped s (Term d) n
|
||||||
|
DScopeTermN s d n = Scoped s (\d => Term d n) d
|
||||||
|
|
||||||
|
public export
|
||||||
|
ScopeTerm, DScopeTerm : TermLike
|
||||||
|
ScopeTerm = ScopeTermN 1
|
||||||
|
DScopeTerm = DScopeTermN 1
|
||||||
|
|
||||||
|
mutual
|
||||||
|
export %hint
|
||||||
|
EqTerm : Eq (Term d n)
|
||||||
|
EqTerm = assert_total {a = Eq (Term d n)} deriveEq
|
||||||
|
|
||||||
|
export %hint
|
||||||
|
EqElim : Eq (Elim d n)
|
||||||
|
EqElim = assert_total {a = Eq (Elim d n)} deriveEq
|
||||||
|
|
||||||
|
mutual
|
||||||
|
export %hint
|
||||||
|
ShowTerm : Show (Term d n)
|
||||||
|
ShowTerm = assert_total {a = Show (Term d n)} deriveShow
|
||||||
|
|
||||||
|
export %hint
|
||||||
|
ShowElim : Show (Elim d n)
|
||||||
|
ShowElim = assert_total {a = Show (Elim d n)} deriveShow
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
Located (Elim d n) where
|
Located (Elim d n) where
|
||||||
(F _ _ loc).loc = loc
|
(F _ _ loc).loc = loc
|
||||||
(B loc).loc = loc
|
(B _ loc).loc = loc
|
||||||
(App _ loc).loc = loc
|
(App _ _ loc).loc = loc
|
||||||
(CasePair _ _ loc).loc = loc
|
(CasePair _ _ _ _ loc).loc = loc
|
||||||
(CaseEnum _ _ _ loc).loc = loc
|
(Fst _ loc).loc = loc
|
||||||
(CaseNat _ _ _ loc).loc = loc
|
(Snd _ loc).loc = loc
|
||||||
(CaseBox _ _ loc).loc = loc
|
(CaseEnum _ _ _ _ loc).loc = loc
|
||||||
(DApp _ loc).loc = loc
|
(CaseNat _ _ _ _ _ _ loc).loc = loc
|
||||||
(Ann _ loc).loc = loc
|
(CaseBox _ _ _ _ loc).loc = loc
|
||||||
(Coe _ loc).loc = loc
|
(DApp _ _ loc).loc = loc
|
||||||
(Comp _ loc).loc = loc
|
(Ann _ _ loc).loc = loc
|
||||||
(TypeCase _ loc).loc = loc
|
(Coe _ _ _ _ loc).loc = loc
|
||||||
(CloE (Sub2 e _)).loc = e.loc
|
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
||||||
|
(TypeCase _ _ _ _ loc).loc = loc
|
||||||
|
(CloE (Sub e _)).loc = e.loc
|
||||||
(DCloE (Sub e _)).loc = e.loc
|
(DCloE (Sub e _)).loc = e.loc
|
||||||
|
|
||||||
export
|
export
|
||||||
Located (Term d n) where
|
Located (Term d n) where
|
||||||
(TYPE _ loc).loc = loc
|
(TYPE _ loc).loc = loc
|
||||||
(Pi _ _ loc).loc = loc
|
(IOState loc).loc = loc
|
||||||
|
(Pi _ _ _ loc).loc = loc
|
||||||
(Lam _ loc).loc = loc
|
(Lam _ loc).loc = loc
|
||||||
(Sig _ loc).loc = loc
|
(Sig _ _ loc).loc = loc
|
||||||
(Pair _ loc).loc = loc
|
(Pair _ _ 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
|
||||||
(Nat loc).loc = loc
|
(NAT loc).loc = loc
|
||||||
(Zero loc).loc = loc
|
(Nat _ loc).loc = loc
|
||||||
|
(STRING loc).loc = loc
|
||||||
|
(Str _ loc).loc = loc
|
||||||
(Succ _ loc).loc = loc
|
(Succ _ loc).loc = loc
|
||||||
(BOX _ _ loc).loc = loc
|
(BOX _ _ loc).loc = loc
|
||||||
(Box _ loc).loc = loc
|
(Box _ loc).loc = loc
|
||||||
|
(Let _ _ _ loc).loc = loc
|
||||||
(E e).loc = e.loc
|
(E e).loc = e.loc
|
||||||
(CloT (Sub2 t _)).loc = t.loc
|
(CloT (Sub t _)).loc = t.loc
|
||||||
(DCloT (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
|
export
|
||||||
Relocatable (Elim d n) where
|
Relocatable (Elim d n) where
|
||||||
setLoc loc (F x u _) = F x u loc
|
setLoc loc (F x u _) = F x u loc
|
||||||
setLoc loc (B _) = B loc
|
setLoc loc (B i _) = B i loc
|
||||||
setLoc loc (App ts _) = App ts loc
|
setLoc loc (App fun arg _) = App fun arg loc
|
||||||
setLoc loc (CasePair qty ts _) = CasePair qty ts loc
|
setLoc loc (CasePair qty pair ret body _) =
|
||||||
setLoc loc (CaseEnum qty arms ts _) = CaseEnum qty arms ts loc
|
CasePair qty pair ret body loc
|
||||||
setLoc loc (CaseNat qty qtyIH ts _) = CaseNat qty qtyIH ts loc
|
setLoc loc (Fst pair _) = Fst pair loc
|
||||||
setLoc loc (CaseBox qty ts _) = CaseBox qty ts loc
|
setLoc loc (Snd pair _) = Fst pair loc
|
||||||
setLoc loc (DApp ts _) = DApp ts loc
|
setLoc loc (CaseEnum qty tag ret arms _) =
|
||||||
setLoc loc (Ann ts _) = Ann ts loc
|
CaseEnum qty tag ret arms loc
|
||||||
setLoc loc (Coe ts _) = Coe ts loc
|
setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
|
||||||
setLoc loc (Comp ts _) = Comp ts loc
|
CaseNat qty qtyIH nat ret zero succ loc
|
||||||
setLoc loc (TypeCase ts _) = TypeCase ts loc
|
setLoc loc (CaseBox qty box ret body _) =
|
||||||
setLoc loc (CloE (Sub2 term subst)) = CloE $ Sub2 (setLoc loc term) subst
|
CaseBox qty box ret body loc
|
||||||
setLoc loc (DCloE (Sub term subst)) = DCloE $ Sub (setLoc loc term) subst
|
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
|
export
|
||||||
Relocatable (Term d n) where
|
Relocatable (Term d n) where
|
||||||
setLoc loc (TYPE l _) = TYPE l loc
|
setLoc loc (TYPE l _) = TYPE l loc
|
||||||
setLoc loc (Pi qty ts _) = Pi qty ts 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 (Lam body _) = Lam body loc
|
||||||
setLoc loc (Sig ts _) = Sig ts loc
|
setLoc loc (Sig fst snd _) = Sig fst snd loc
|
||||||
setLoc loc (Pair ts _) = Pair ts loc
|
setLoc loc (Pair fst snd _) = Pair fst snd loc
|
||||||
setLoc loc (Enum cases _) = Enum cases loc
|
setLoc loc (Enum cases _) = Enum cases loc
|
||||||
setLoc loc (Tag tag _) = Tag tag loc
|
setLoc loc (Tag tag _) = Tag tag loc
|
||||||
setLoc loc (Eq ts _) = Eq ts loc
|
setLoc loc (Eq ty l r _) = Eq ty l r loc
|
||||||
setLoc loc (DLam body _) = DLam body loc
|
setLoc loc (DLam body _) = DLam body loc
|
||||||
setLoc loc (Nat _) = Nat loc
|
setLoc loc (NAT _) = NAT loc
|
||||||
setLoc loc (Zero _) = Zero loc
|
setLoc loc (Nat n _) = Nat n loc
|
||||||
setLoc loc (Succ p _) = Succ p 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 qty ty _) = BOX qty ty loc
|
||||||
setLoc loc (Box val _) = Box val 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 (E e) = E $ setLoc loc e
|
||||||
setLoc loc (CloT (Sub2 term subst)) = CloT $ Sub2 (setLoc loc term) subst
|
setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
|
||||||
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
|
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
|
||||||
|
|
||||||
|
export
|
||||||
|
Relocatable1 f => Relocatable (ScopedBody s f n) where
|
||||||
|
setLoc loc (Y body) = Y $ setLoc loc body
|
||||||
|
setLoc loc (N body) = N $ setLoc loc body
|
||||||
|
|
||||||
|
export
|
||||||
|
Relocatable1 f => Relocatable (Scoped s f n) where
|
||||||
|
setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
|
||||||
|
|
||||||
|
|
||||||
|
||| more convenient Pi
|
||||||
|
public export %inline
|
||||||
|
PiY : (qty : Qty) -> (x : BindName) ->
|
||||||
|
(arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||||
|
PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc}
|
||||||
|
|
||||||
|
||| more convenient Lam
|
||||||
|
public export %inline
|
||||||
|
LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||||
|
LamY {x, body, loc} = Lam {body = SY [< x] body, loc}
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
LamN : (body : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
LamN {body, loc} = Lam {body = SN body, loc}
|
||||||
|
|
||||||
|
||| non dependent function type
|
||||||
|
public export %inline
|
||||||
|
Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}
|
||||||
|
|
||||||
|
||| more convenient Sig
|
||||||
|
public export %inline
|
||||||
|
SigY : (x : BindName) -> (fst : Term d n) ->
|
||||||
|
(snd : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||||
|
SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}
|
||||||
|
|
||||||
|
||| non dependent pair type
|
||||||
|
public export %inline
|
||||||
|
And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}
|
||||||
|
|
||||||
|
||| more convenient Eq
|
||||||
|
public export %inline
|
||||||
|
EqY : (i : BindName) -> (ty : Term (S d) n) ->
|
||||||
|
(l, r : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}
|
||||||
|
|
||||||
|
||| more convenient DLam
|
||||||
|
public export %inline
|
||||||
|
DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
|
||||||
|
DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
DLamN {body, loc} = DLam {body = SN body, loc}
|
||||||
|
|
||||||
|
||| more convenient Coe
|
||||||
|
public export %inline
|
||||||
|
CoeY : (i : BindName) -> (ty : Term (S d) n) ->
|
||||||
|
(p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
|
||||||
|
CoeY {i, ty, p, q, val, loc} = Coe {ty = SY [< i] ty, p, q, val, loc}
|
||||||
|
|
||||||
|
||| non dependent equality type
|
||||||
|
public export %inline
|
||||||
|
Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
|
||||||
|
Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
|
||||||
|
|
||||||
|
||| same as `F` but as a term
|
||||||
|
public export %inline
|
||||||
|
FT : Name -> Universe -> Loc -> Term d n
|
||||||
|
FT x u loc = E $ F x u loc
|
||||||
|
|
||||||
|
||| same as `B` but as a term
|
||||||
|
public export %inline
|
||||||
|
BT : Var n -> (loc : Loc) -> Term d n
|
||||||
|
BT i loc = E $ B i loc
|
||||||
|
|
||||||
|
||| abbreviation for a bound variable like `BV 4` instead of
|
||||||
|
||| `B (VS (VS (VS (VS VZ))))`
|
||||||
|
public export %inline
|
||||||
|
BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n
|
||||||
|
BV i loc = B (V i) loc
|
||||||
|
|
||||||
|
||| same as `BV` but as a term
|
||||||
|
public export %inline
|
||||||
|
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
|
||||||
|
BVT i loc = E $ BV i loc
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
Zero : Loc -> Term d n
|
||||||
|
Zero = Nat 0
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
enum : List TagVal -> Loc -> Term d n
|
||||||
|
enum ts loc = Enum (SortedSet.fromList ts) loc
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
typeCase : Elim d n -> Term d n ->
|
||||||
|
List (TypeCaseArm d n) -> Term d n -> Loc -> Elim d n
|
||||||
|
typeCase ty ret arms def loc = TypeCase ty ret (fromList arms) def loc
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
typeCase1Y : Elim d n -> Term d n ->
|
||||||
|
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
|
||||||
|
(loc : Loc) ->
|
||||||
|
{default (NAT loc) def : Term d n} ->
|
||||||
|
Elim d n
|
||||||
|
typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc
|
||||||
|
|
|
@ -18,11 +18,11 @@ prettyUniverse = hl Universe . text . show
|
||||||
|
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyTerm : {opts : _} -> BContext d -> BContext n -> TermT d n ->
|
prettyTerm : {opts : _} -> BContext d -> BContext n -> Term d n ->
|
||||||
Eff Pretty (Doc opts)
|
Eff Pretty (Doc opts)
|
||||||
|
|
||||||
export
|
export
|
||||||
prettyElim : {opts : _} -> BContext d -> BContext n -> ElimT d n ->
|
prettyElim : {opts : _} -> BContext d -> BContext n -> Elim d n ->
|
||||||
Eff Pretty (Doc opts)
|
Eff Pretty (Doc opts)
|
||||||
|
|
||||||
private
|
private
|
||||||
|
@ -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,462 +2,383 @@ module Quox.Syntax.Term.Subst
|
||||||
|
|
||||||
import Quox.No
|
import Quox.No
|
||||||
import Quox.Syntax.Term.Base
|
import Quox.Syntax.Term.Base
|
||||||
import Quox.Syntax.Subst
|
|
||||||
|
|
||||||
import Data.SnocVect
|
import Data.SnocVect
|
||||||
import Data.Singleton
|
|
||||||
|
|
||||||
%default total
|
%default total
|
||||||
|
|
||||||
|
namespace CanDSubst
|
||||||
|
public export
|
||||||
|
interface CanDSubst (0 tm : TermLike) where
|
||||||
|
(//) : tm d1 n -> Lazy (DSubst d1 d2) -> tm d2 n
|
||||||
|
|
||||||
infixl 8 ///
|
||| does the minimal reasonable work:
|
||||||
|
||| - deletes the closure around an atomic constant like `TYPE`
|
||||||
parameters {0 f : Nat -> Nat -> Type}
|
||| - deletes an identity substitution
|
||||||
private
|
||| - composes (lazily) with an existing top-level dim-closure
|
||||||
th0 : f 0 0 -> Thinned2 f d n
|
||| - otherwise, wraps in a new closure
|
||||||
th0 = Th2 zero zero
|
export
|
||||||
|
CanDSubst Term where
|
||||||
|
s // Shift SZ = s
|
||||||
|
TYPE l loc // _ = TYPE l loc
|
||||||
|
DCloT (Sub s ph) // th = DCloT $ Sub s $ ph . th
|
||||||
|
s // th = DCloT $ Sub s th
|
||||||
|
|
||||||
private
|
private
|
||||||
th1 : {d, n : Nat} -> f d n -> Thinned2 f d n
|
subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
|
||||||
th1 = Th2 id' id'
|
subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
|
||||||
|
subDArgs e th = DCloE $ Sub e th
|
||||||
|
|
||||||
private dsubTerm : {d1, d2, n : Nat} -> Term d1 n -> DSubst d1 d2 -> TermT d2 n
|
||| does the minimal reasonable work:
|
||||||
private dsubElim : {d1, d2, n : Nat} -> Elim d1 n -> DSubst d1 d2 -> ElimT d2 n
|
||| - deletes the closure around a term variable
|
||||||
|
||| - deletes an identity substitution
|
||||||
dsubTerm (TYPE l loc) th = th0 $ TYPE l loc
|
||| - composes (lazily) with an existing top-level dim-closure
|
||||||
dsubTerm (Enum strs loc) th = th0 $ Enum strs loc
|
||| - immediately looks up bound variables in a
|
||||||
dsubTerm (Tag str loc) th = th0 $ Tag str loc
|
||| top-level sequence of dimension applications
|
||||||
dsubTerm (Nat loc) th = th0 $ Nat loc
|
||| - otherwise, wraps in a new closure
|
||||||
dsubTerm (Zero loc) th = th0 $ Zero loc
|
|
||||||
dsubTerm (E e) th =
|
|
||||||
let Th2 dope tope e' = dsubElim e th in
|
|
||||||
Th2 dope tope $ E e'
|
|
||||||
dsubTerm (DCloT (Sub t ph)) th = th1 $ DCloT $ Sub t $ ph . th
|
|
||||||
dsubTerm t th = th1 $ DCloT $ Sub t th
|
|
||||||
|
|
||||||
dsubElim (F x l loc) th = th0 $ F x l loc
|
|
||||||
dsubElim (B loc) th = Th2 zero id' $ B loc
|
|
||||||
dsubElim (DCloE (Sub e ph)) th = th1 $ DCloE $ Sub e $ ph . th
|
|
||||||
dsubElim e th = th1 $ DCloE $ Sub e th
|
|
||||||
|
|
||||||
mutual
|
|
||||||
namespace Term
|
|
||||||
export
|
export
|
||||||
(///) : {d1, d2, n : Nat} -> TermT d1 n -> DSubst d1 d2 -> TermT d2 n
|
CanDSubst Elim where
|
||||||
Th2 dope tope term /// th =
|
e // Shift SZ = e
|
||||||
let Val tscope = appOpe n tope; Val dscope = appOpe d1 dope
|
F x u loc // _ = F x u loc
|
||||||
Th2 dope' tope' term' = dsubTerm term (select dope th)
|
B i loc // _ = B i loc
|
||||||
in
|
e@(DApp {}) // th = subDArgs e th
|
||||||
Th2 dope' (tope . tope') term'
|
DCloE (Sub e ph) // th = DCloE $ Sub e $ ph . th
|
||||||
|
e // th = DCloE $ Sub e th
|
||||||
|
|
||||||
namespace Elim
|
namespace DSubst.ScopeTermN
|
||||||
|
export %inline
|
||||||
|
(//) : ScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
|
||||||
|
ScopeTermN s d2 n
|
||||||
|
S ns (Y body) // th = S ns $ Y $ body // th
|
||||||
|
S ns (N body) // th = S ns $ N $ body // th
|
||||||
|
|
||||||
|
namespace DSubst.DScopeTermN
|
||||||
|
export %inline
|
||||||
|
(//) : {s : Nat} ->
|
||||||
|
DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
|
||||||
|
DScopeTermN s d2 n
|
||||||
|
S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
|
||||||
|
S ns (N body) // th = S ns $ N $ body // th
|
||||||
|
|
||||||
|
|
||||||
|
export %inline FromVar (Elim d) where fromVarLoc = B
|
||||||
|
export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
|
||||||
|
|
||||||
|
|
||||||
|
||| does the minimal reasonable work:
|
||||||
|
||| - deletes the closure around a *free* name
|
||||||
|
||| - deletes an identity substitution
|
||||||
|
||| - composes (lazily) with an existing top-level closure
|
||||||
|
||| - immediately looks up a bound variable
|
||||||
|
||| - otherwise, wraps in a new closure
|
||||||
export
|
export
|
||||||
(///) : {d1, d2, n : Nat} -> ElimT d1 n -> DSubst d1 d2 -> ElimT d2 n
|
CanSubstSelf (Elim d) where
|
||||||
Th2 dope tope elim /// th =
|
F x u loc // _ = F x u loc
|
||||||
let Val tscope = appOpe n tope; Val dscope = appOpe d1 dope
|
B i loc // th = getLoc th i loc
|
||||||
Th2 dope' tope' elim' = dsubElim elim (select dope th)
|
CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th
|
||||||
in
|
e // th = case force th of
|
||||||
Th2 dope' (tope . tope') elim'
|
Shift SZ => e
|
||||||
|
th => CloE $ Sub e th
|
||||||
|
|
||||||
|
namespace CanTSubst
|
||||||
|
public export
|
||||||
|
interface CanTSubst (0 tm : TermLike) where
|
||||||
|
(//) : tm d n1 -> Lazy (TSubst d n1 n2) -> tm d n2
|
||||||
|
|
||||||
|
||| does the minimal reasonable work:
|
||||||
|
||| - deletes the closure around an atomic constant like `TYPE`
|
||||||
|
||| - deletes an identity substitution
|
||||||
|
||| - composes (lazily) with an existing top-level closure
|
||||||
|
||| - goes inside `E` in case it is a simple variable or something
|
||||||
|
||| - otherwise, wraps in a new closure
|
||||||
|
export
|
||||||
|
CanTSubst Term where
|
||||||
|
TYPE l loc // _ = TYPE l loc
|
||||||
|
E e // th = E $ e // th
|
||||||
|
CloT (Sub s ph) // th = CloT $ Sub s $ ph . th
|
||||||
|
s // th = case force th of
|
||||||
|
Shift SZ => s
|
||||||
|
th => CloT $ Sub s th
|
||||||
|
|
||||||
|
namespace ScopeTermN
|
||||||
|
export %inline
|
||||||
|
(//) : {s : Nat} ->
|
||||||
|
ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
|
||||||
|
ScopeTermN s d n2
|
||||||
|
S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
|
||||||
|
S ns (N body) // th = S ns $ N $ body // th
|
||||||
|
|
||||||
|
namespace DScopeTermN
|
||||||
|
export %inline
|
||||||
|
(//) : {s : Nat} ->
|
||||||
|
DScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> DScopeTermN s d n2
|
||||||
|
S ns (Y body) // th = S ns $ Y $ body // map (// shift s) th
|
||||||
|
S ns (N body) // th = S ns $ N $ body // th
|
||||||
|
|
||||||
|
export %inline CanShift (Term d) where s // by = s // Shift by
|
||||||
|
export %inline CanShift (Elim d) where e // by = e // Shift by
|
||||||
|
|
||||||
|
export %inline CanShift (flip Term n) where s // by = s // Shift by
|
||||||
|
export %inline CanShift (flip Elim n) where e // by = e // Shift by
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
{s : Nat} -> CanShift (ScopeTermN s d) where
|
||||||
|
b // by = b // Shift by
|
||||||
|
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
comp : DSubst d1 d2 -> TSubst d1 n1 mid -> TSubst d2 mid n2 -> TSubst d2 n1 n2
|
||||||
|
comp th ps ph = map (// th) ps . ph
|
||||||
|
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
dweakT : (by : Nat) -> Term d n -> Term (by + d) n
|
||||||
|
dweakT by t = t // shift by
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
dweakS : (by : Nat) -> ScopeTermN s d n -> ScopeTermN s (by + d) n
|
||||||
|
dweakS by t = t // shift by
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
dweakDS : {s : Nat} -> (by : Nat) ->
|
||||||
|
DScopeTermN s d n -> DScopeTermN s (by + d) n
|
||||||
|
dweakDS by t = t // shift by
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
|
||||||
|
dweakE by t = t // shift by
|
||||||
|
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
weakT : (by : Nat) -> Term d n -> Term d (by + n)
|
||||||
|
weakT by t = t // shift by
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
weakS : {s : Nat} -> (by : Nat) -> ScopeTermN s d n -> ScopeTermN s d (by + n)
|
||||||
|
weakS by t = t // shift by
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
weakDS : {s : Nat} -> (by : Nat) ->
|
||||||
|
DScopeTermN s d n -> DScopeTermN s d (by + n)
|
||||||
|
weakDS by t = t // shift by
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
|
||||||
|
weakE by t = t // shift by
|
||||||
|
|
||||||
|
|
||||||
|
parameters {auto _ : CanShift f} {s : Nat}
|
||||||
|
export %inline
|
||||||
|
getTerm : ScopedBody s f n -> f (s + n)
|
||||||
|
getTerm (Y b) = b
|
||||||
|
getTerm (N b) = b // fromNat s
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
(.term) : Scoped s f n -> f (s + n)
|
||||||
|
t.term = getTerm t.body
|
||||||
|
|
||||||
|
namespace ScopeTermBody
|
||||||
|
export %inline
|
||||||
|
getTerm0 : ScopedBody 0 f n -> f n
|
||||||
|
getTerm0 (Y b) = b
|
||||||
|
getTerm0 (N b) = b
|
||||||
|
|
||||||
|
namespace ScopeTermN
|
||||||
|
export %inline
|
||||||
|
(.term0) : Scoped 0 f n -> f n
|
||||||
|
t.term0 = getTerm0 t.body
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
|
||||||
|
subN (S _ (Y body)) es = body // fromSnocVect es
|
||||||
|
subN (S _ (N body)) _ = body
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
sub1 : ScopeTerm d n -> Elim d n -> Term d n
|
||||||
|
sub1 t e = subN t [< e]
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
dsubN : DScopeTermN s d n -> SnocVect s (Dim d) -> Term d n
|
||||||
|
dsubN (S _ (Y body)) ps = body // fromSnocVect ps
|
||||||
|
dsubN (S _ (N body)) _ = body
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
dsub1 : DScopeTerm d n -> Dim d -> Term d n
|
||||||
|
dsub1 t p = dsubN t [< p]
|
||||||
|
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
|
||||||
|
body.zero = dsub1 body $ K Zero loc
|
||||||
|
|
||||||
|
public export %inline
|
||||||
|
(.one) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
|
||||||
|
body.one = dsub1 body $ K One loc
|
||||||
|
|
||||||
|
|
||||||
public export
|
public export
|
||||||
TSubst : Nat -> Nat -> Nat -> Type
|
0 CloTest : TermLike -> Type
|
||||||
TSubst = Subst2 Elim
|
CloTest tm = forall d, n. tm d n -> Bool
|
||||||
|
|
||||||
|
public export
|
||||||
|
interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
|
||||||
|
pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
|
||||||
|
tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
|
||||||
|
|
||||||
public export %inline FromVar (Elim 0) where var = B
|
public export
|
||||||
|
0 NotClo : {isClo : CloTest tm} -> PushSubsts tm isClo => Pred (tm d n)
|
||||||
|
NotClo = No . isClo
|
||||||
|
|
||||||
export CanSubstSelf2 Elim
|
public export
|
||||||
|
0 NonClo : (tm : TermLike) -> {isClo : CloTest tm} ->
|
||||||
|
PushSubsts tm isClo => TermLike
|
||||||
|
NonClo tm d n = Subset (tm d n) NotClo
|
||||||
|
|
||||||
private subTerm : {d, n1, n2 : Nat} -> Term d n1 -> TSubst d n1 n2 -> TermT d n2
|
public export %inline
|
||||||
private subElim : {d, n1, n2 : Nat} -> Elim d n1 -> TSubst d n1 n2 -> ElimT d n2
|
nclo : {isClo : CloTest tm} -> (0 _ : PushSubsts tm isClo) =>
|
||||||
|
(t : tm d n) -> (0 nc : NotClo t) => NonClo tm d n
|
||||||
|
nclo t = Element t nc
|
||||||
|
|
||||||
subTerm (TYPE l loc) th = th0 $ TYPE l loc
|
parameters {0 isClo : CloTest tm} {auto _ : PushSubsts tm isClo}
|
||||||
subTerm (Nat loc) th = th0 $ Nat loc
|
||| if the input term has any top-level closures, push them under one layer of
|
||||||
subTerm (Zero loc) th = th0 $ Zero loc
|
||| syntax
|
||||||
subTerm (E e) th = let Th2 dope tope e' = subElim e th in Th2 dope tope $ E e'
|
export %inline
|
||||||
subTerm (CloT (Sub2 s ph)) th = th1 $ CloT $ Sub2 s $ ph .% th
|
pushSubsts : tm d n -> NonClo tm d n
|
||||||
subTerm s th = th1 $ CloT $ Sub2 s th
|
pushSubsts s = pushSubstsWith id id s
|
||||||
|
|
||||||
subElim (F x k loc) th = th0 $ F x k loc
|
export %inline
|
||||||
subElim (B loc) [< e] = e
|
pushSubstsWith' : DSubst d1 d2 -> TSubst d2 n1 n2 -> tm d1 n1 -> tm d2 n2
|
||||||
subElim (CloE (Sub2 e ph)) th = th1 $ CloE $ Sub2 e $ ph .% th
|
pushSubstsWith' th ph x = fst $ pushSubstsWith th ph x
|
||||||
subElim e th = th1 $ CloE $ Sub2 e th
|
|
||||||
|
|
||||||
|
export %inline
|
||||||
|
pushSubsts' : tm d n -> tm d n
|
||||||
|
pushSubsts' s = fst $ pushSubsts s
|
||||||
|
|
||||||
|
mutual
|
||||||
|
public export
|
||||||
|
isCloT : CloTest Term
|
||||||
|
isCloT (CloT {}) = True
|
||||||
|
isCloT (DCloT {}) = True
|
||||||
|
isCloT (E e) = isCloE e
|
||||||
|
isCloT _ = False
|
||||||
|
|
||||||
|
public export
|
||||||
|
isCloE : CloTest Elim
|
||||||
|
isCloE (CloE {}) = True
|
||||||
|
isCloE (DCloE {}) = True
|
||||||
|
isCloE _ = False
|
||||||
|
|
||||||
export
|
export
|
||||||
CanSubstSelf2 Elim where
|
PushSubsts Elim Subst.isCloE where
|
||||||
Th2 dope tope elim // th =
|
pushSubstsWith th ph (F x u loc) =
|
||||||
let
|
nclo $ F x u loc
|
||||||
th' = select tope th
|
pushSubstsWith th ph (B i loc) =
|
||||||
in
|
let res = getLoc ph i loc in
|
||||||
?sube2
|
case nchoose $ isCloE res of
|
||||||
|
Left yes => assert_total pushSubsts res
|
||||||
|
Right no => Element res no
|
||||||
|
pushSubstsWith th ph (App f s loc) =
|
||||||
|
nclo $ App (f // th // ph) (s // th // ph) loc
|
||||||
|
pushSubstsWith th ph (CasePair pi p r b loc) =
|
||||||
|
nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
|
||||||
|
pushSubstsWith th ph (Fst pair loc) =
|
||||||
|
nclo $ Fst (pair // th // ph) loc
|
||||||
|
pushSubstsWith th ph (Snd pair loc) =
|
||||||
|
nclo $ Snd (pair // th // ph) loc
|
||||||
|
pushSubstsWith th ph (CaseEnum pi t r arms loc) =
|
||||||
|
nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
|
||||||
|
(map (\b => b // th // ph) arms) loc
|
||||||
|
pushSubstsWith th ph (CaseNat pi pi' n r z s loc) =
|
||||||
|
nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph)
|
||||||
|
(z // th // ph) (s // th // ph) loc
|
||||||
|
pushSubstsWith th ph (CaseBox pi x r b loc) =
|
||||||
|
nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc
|
||||||
|
pushSubstsWith th ph (DApp f d loc) =
|
||||||
|
nclo $ DApp (f // th // ph) (d // th) loc
|
||||||
|
pushSubstsWith th ph (Ann s a loc) =
|
||||||
|
nclo $ Ann (s // th // ph) (a // th // ph) loc
|
||||||
|
pushSubstsWith th ph (Coe ty p q val loc) =
|
||||||
|
nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc
|
||||||
|
pushSubstsWith th ph (Comp ty p q val r zero one loc) =
|
||||||
|
nclo $ Comp (ty // th // ph) (p // th) (q // th)
|
||||||
|
(val // th // ph) (r // th)
|
||||||
|
(zero // th // ph) (one // th // ph) loc
|
||||||
|
pushSubstsWith th ph (TypeCase ty ret arms def loc) =
|
||||||
|
nclo $ TypeCase (ty // th // ph) (ret // th // ph)
|
||||||
|
(map (\t => t // th // ph) arms) (def // th // ph) loc
|
||||||
|
pushSubstsWith th ph (CloE (Sub e ps)) =
|
||||||
|
pushSubstsWith th (comp th ps ph) e
|
||||||
|
pushSubstsWith th ph (DCloE (Sub e ps)) =
|
||||||
|
pushSubstsWith (ps . th) ph e
|
||||||
|
|
||||||
-- namespace CanDSubst
|
export
|
||||||
-- public export
|
PushSubsts Term Subst.isCloT where
|
||||||
-- interface CanDSubst (0 tm : TermLike) where
|
pushSubstsWith th ph (TYPE l loc) =
|
||||||
-- (//) : {d1 : Nat} -> Thinned2 tm d1 n -> Lazy (DSubst d1 d2) ->
|
nclo $ TYPE l loc
|
||||||
-- Thinned2 tm d2 n
|
pushSubstsWith th ph (IOState loc) =
|
||||||
|
nclo $ IOState loc
|
||||||
-- ||| does the minimal reasonable work:
|
pushSubstsWith th ph (Pi qty a body loc) =
|
||||||
-- ||| - deletes the closure around an atomic constant like `TYPE`
|
nclo $ Pi qty (a // th // ph) (body // th // ph) loc
|
||||||
-- ||| - deletes an identity substitution
|
pushSubstsWith th ph (Lam body loc) =
|
||||||
-- ||| - composes (lazily) with an existing top-level dim-closure
|
nclo $ Lam (body // th // ph) loc
|
||||||
-- ||| - otherwise, wraps in a new closure
|
pushSubstsWith th ph (Sig a b loc) =
|
||||||
-- export
|
nclo $ Sig (a // th // ph) (b // th // ph) loc
|
||||||
-- CanDSubst Term where
|
pushSubstsWith th ph (Pair s t loc) =
|
||||||
-- Th2 _ _ (TYPE l loc) // _ = Th2 zero zero $ TYPE l loc
|
nclo $ Pair (s // th // ph) (t // th // ph) loc
|
||||||
-- Th2 i j (DCloT (Sub s ph)) // th =
|
pushSubstsWith th ph (Enum tags loc) =
|
||||||
-- Th2 ?i' j $ DCloT $ Sub s $ ph . ?th'
|
nclo $ Enum tags loc
|
||||||
-- Th2 i j s // th = ?sdf -- DCloT $ Sub s th
|
pushSubstsWith th ph (Tag tag loc) =
|
||||||
|
nclo $ Tag tag loc
|
||||||
-- -- private
|
pushSubstsWith th ph (Eq ty l r loc) =
|
||||||
-- -- subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
|
nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
|
||||||
-- -- subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
|
pushSubstsWith th ph (DLam body loc) =
|
||||||
-- -- subDArgs e th = DCloE $ Sub e th
|
nclo $ DLam (body // th // ph) loc
|
||||||
|
pushSubstsWith _ _ (NAT loc) =
|
||||||
-- -- ||| does the minimal reasonable work:
|
nclo $ NAT loc
|
||||||
-- -- ||| - deletes the closure around a term variable
|
pushSubstsWith _ _ (Nat n loc) =
|
||||||
-- -- ||| - deletes an identity substitution
|
nclo $ Nat n loc
|
||||||
-- -- ||| - composes (lazily) with an existing top-level dim-closure
|
pushSubstsWith th ph (Succ n loc) =
|
||||||
-- -- ||| - immediately looks up bound variables in a
|
nclo $ Succ (n // th // ph) loc
|
||||||
-- -- ||| top-level sequence of dimension applications
|
pushSubstsWith _ _ (STRING loc) =
|
||||||
-- -- ||| - otherwise, wraps in a new closure
|
nclo $ STRING loc
|
||||||
-- -- export
|
pushSubstsWith _ _ (Str s loc) =
|
||||||
-- -- CanDSubst Elim where
|
nclo $ Str s loc
|
||||||
-- -- e // Shift SZ = e
|
pushSubstsWith th ph (BOX pi ty loc) =
|
||||||
-- -- F x u loc // _ = F x u loc
|
nclo $ BOX pi (ty // th // ph) loc
|
||||||
-- -- B i loc // _ = B i loc
|
pushSubstsWith th ph (Box val loc) =
|
||||||
-- -- e@(DApp {}) // th = subDArgs e th
|
nclo $ Box (val // th // ph) loc
|
||||||
-- -- DCloE (Sub e ph) // th = DCloE $ Sub e $ ph . th
|
pushSubstsWith th ph (E e) =
|
||||||
-- -- e // th = DCloE $ Sub e th
|
let Element e nc = pushSubstsWith th ph e in nclo $ E e
|
||||||
|
pushSubstsWith th ph (Let qty rhs body loc) =
|
||||||
-- -- namespace DSubst.ScopeTermN
|
nclo $ Let qty (rhs // th // ph) (body // th // ph) loc
|
||||||
-- -- export %inline
|
pushSubstsWith th ph (CloT (Sub s ps)) =
|
||||||
-- -- (//) : ScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
|
pushSubstsWith th (comp th ps ph) s
|
||||||
-- -- ScopeTermN s d2 n
|
pushSubstsWith th ph (DCloT (Sub s ps)) =
|
||||||
-- -- S ns (Y body) // th = S ns $ Y $ body // th
|
pushSubstsWith (ps . th) ph s
|
||||||
-- -- S ns (N body) // th = S ns $ N $ body // th
|
|
||||||
|
|
||||||
-- -- namespace DSubst.DScopeTermN
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- (//) : {s : Nat} ->
|
|
||||||
-- -- DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
|
|
||||||
-- -- DScopeTermN s d2 n
|
|
||||||
-- -- S ns (Y body) // th = S ns $ Y $ body // pushN s th
|
|
||||||
-- -- S ns (N body) // th = S ns $ N $ body // th
|
|
||||||
|
|
||||||
|
|
||||||
-- -- export %inline FromVar (Elim d) where fromVarLoc = B
|
||| heterogeneous comp, in terms of Comp and Coe
|
||||||
-- -- export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
|
public export %inline
|
||||||
|
CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||||
|
(r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
|
||||||
|
CompH' {ty, p, q, val, r, zero, one, loc} =
|
||||||
|
let ty' = SY ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
|
||||||
|
Comp {
|
||||||
|
ty = dsub1 ty q, p, q,
|
||||||
|
val = E $ Coe ty p q val val.loc, r,
|
||||||
|
zero = SY zero.names $ E $
|
||||||
|
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
|
||||||
|
one = SY one.names $ E $
|
||||||
|
Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
|
||||||
|
loc
|
||||||
|
}
|
||||||
|
|
||||||
|
||| heterogeneous comp, in terms of Comp and Coe
|
||||||
-- -- ||| does the minimal reasonable work:
|
public export %inline
|
||||||
-- -- ||| - deletes the closure around a *free* name
|
CompH : (i : BindName) -> (ty : Term (S d) n) ->
|
||||||
-- -- ||| - deletes an identity substitution
|
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
|
||||||
-- -- ||| - composes (lazily) with an existing top-level closure
|
(j0 : BindName) -> (zero : Term (S d) n) ->
|
||||||
-- -- ||| - immediately looks up a bound variable
|
(j1 : BindName) -> (one : Term (S d) n) ->
|
||||||
-- -- ||| - otherwise, wraps in a new closure
|
(loc : Loc) -> Elim d n
|
||||||
-- -- export
|
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
|
||||||
-- -- CanSubstSelf (Elim d) where
|
CompH' {ty = SY [< i] ty, p, q, val, r,
|
||||||
-- -- F x u loc // _ = F x u loc
|
zero = SY [< j0] zero, one = SY [< j1] one, loc}
|
||||||
-- -- B i loc // th = getLoc th i loc
|
|
||||||
-- -- CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th
|
|
||||||
-- -- e // th = case force th of
|
|
||||||
-- -- Shift SZ => e
|
|
||||||
-- -- th => CloE $ Sub e th
|
|
||||||
|
|
||||||
-- -- namespace CanTSubst
|
|
||||||
-- -- public export
|
|
||||||
-- -- interface CanTSubst (0 tm : TermLike) where
|
|
||||||
-- -- (//) : tm d n1 -> Lazy (TSubst d n1 n2) -> tm d n2
|
|
||||||
|
|
||||||
-- -- ||| does the minimal reasonable work:
|
|
||||||
-- -- ||| - deletes the closure around an atomic constant like `TYPE`
|
|
||||||
-- -- ||| - deletes an identity substitution
|
|
||||||
-- -- ||| - composes (lazily) with an existing top-level closure
|
|
||||||
-- -- ||| - goes inside `E` in case it is a simple variable or something
|
|
||||||
-- -- ||| - otherwise, wraps in a new closure
|
|
||||||
-- -- export
|
|
||||||
-- -- CanTSubst Term where
|
|
||||||
-- -- TYPE l loc // _ = TYPE l loc
|
|
||||||
-- -- E e // th = E $ e // th
|
|
||||||
-- -- CloT (Sub s ph) // th = CloT $ Sub s $ ph . th
|
|
||||||
-- -- s // th = case force th of
|
|
||||||
-- -- Shift SZ => s
|
|
||||||
-- -- th => CloT $ Sub s th
|
|
||||||
|
|
||||||
-- -- namespace ScopeTermN
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- (//) : {s : Nat} ->
|
|
||||||
-- -- ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
|
|
||||||
-- -- ScopeTermN s d n2
|
|
||||||
-- -- S ns (Y body) // th = S ns $ Y $ body // pushN s th
|
|
||||||
-- -- S ns (N body) // th = S ns $ N $ body // th
|
|
||||||
|
|
||||||
-- -- namespace DScopeTermN
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- (//) : {s : Nat} ->
|
|
||||||
-- -- DScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> DScopeTermN s d n2
|
|
||||||
-- -- S ns (Y body) // th = S ns $ Y $ body // map (// shift s) th
|
|
||||||
-- -- S ns (N body) // th = S ns $ N $ body // th
|
|
||||||
|
|
||||||
-- -- export %inline CanShift (Term d) where s // by = s // Shift by
|
|
||||||
-- -- export %inline CanShift (Elim d) where e // by = e // Shift by
|
|
||||||
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- {s : Nat} -> CanShift (ScopeTermN s d) where
|
|
||||||
-- -- b // by = b // Shift by
|
|
||||||
|
|
||||||
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- comp : DSubst d1 d2 -> TSubst d1 n1 mid -> TSubst d2 mid n2 -> TSubst d2 n1 n2
|
|
||||||
-- -- comp th ps ph = map (// th) ps . ph
|
|
||||||
|
|
||||||
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- dweakT : (by : Nat) -> Term d n -> Term (by + d) n
|
|
||||||
-- -- dweakT by t = t // shift by
|
|
||||||
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
|
|
||||||
-- -- dweakE by t = t // shift by
|
|
||||||
|
|
||||||
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- weakT : (by : Nat) -> Term d n -> Term d (by + n)
|
|
||||||
-- -- weakT by t = t // shift by
|
|
||||||
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
|
|
||||||
-- -- weakE by t = t // shift by
|
|
||||||
|
|
||||||
|
|
||||||
-- -- parameters {s : Nat}
|
|
||||||
-- -- namespace ScopeTermBody
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- (.term) : ScopedBody s (Term d) n -> Term d (s + n)
|
|
||||||
-- -- (Y b).term = b
|
|
||||||
-- -- (N b).term = weakT s b
|
|
||||||
|
|
||||||
-- -- namespace ScopeTermN
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- (.term) : ScopeTermN s d n -> Term d (s + n)
|
|
||||||
-- -- t.term = t.body.term
|
|
||||||
|
|
||||||
-- -- namespace DScopeTermBody
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- (.term) : ScopedBody s (\d => Term d n) d -> Term (s + d) n
|
|
||||||
-- -- (Y b).term = b
|
|
||||||
-- -- (N b).term = dweakT s b
|
|
||||||
|
|
||||||
-- -- namespace DScopeTermN
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- (.term) : DScopeTermN s d n -> Term (s + d) n
|
|
||||||
-- -- t.term = t.body.term
|
|
||||||
|
|
||||||
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
|
|
||||||
-- -- subN (S _ (Y body)) es = body // fromSnocVect es
|
|
||||||
-- -- subN (S _ (N body)) _ = body
|
|
||||||
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- sub1 : ScopeTerm d n -> Elim d n -> Term d n
|
|
||||||
-- -- sub1 t e = subN t [< e]
|
|
||||||
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- dsubN : DScopeTermN s d n -> SnocVect s (Dim d) -> Term d n
|
|
||||||
-- -- dsubN (S _ (Y body)) ps = body // fromSnocVect ps
|
|
||||||
-- -- dsubN (S _ (N body)) _ = body
|
|
||||||
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- dsub1 : DScopeTerm d n -> Dim d -> Term d n
|
|
||||||
-- -- dsub1 t p = dsubN t [< p]
|
|
||||||
|
|
||||||
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- (.zero) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
|
|
||||||
-- -- body.zero = dsub1 body $ K Zero loc
|
|
||||||
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- (.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
|
|
||||||
-- -- body.one = dsub1 body $ K One loc
|
|
||||||
|
|
||||||
|
|
||||||
-- -- public export
|
|
||||||
-- -- 0 CloTest : TermLike -> Type
|
|
||||||
-- -- CloTest tm = forall d, n. tm d n -> Bool
|
|
||||||
|
|
||||||
-- -- interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
|
|
||||||
-- -- pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
|
|
||||||
-- -- tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
|
|
||||||
|
|
||||||
-- -- public export
|
|
||||||
-- -- 0 NotClo : {isClo : CloTest tm} -> PushSubsts tm isClo => Pred (tm d n)
|
|
||||||
-- -- NotClo = No . isClo
|
|
||||||
|
|
||||||
-- -- public export
|
|
||||||
-- -- 0 NonClo : (tm : TermLike) -> {isClo : CloTest tm} ->
|
|
||||||
-- -- PushSubsts tm isClo => TermLike
|
|
||||||
-- -- NonClo tm d n = Subset (tm d n) NotClo
|
|
||||||
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- nclo : {isClo : CloTest tm} -> (0 _ : PushSubsts tm isClo) =>
|
|
||||||
-- -- (t : tm d n) -> (0 nc : NotClo t) => NonClo tm d n
|
|
||||||
-- -- nclo t = Element t nc
|
|
||||||
|
|
||||||
-- -- parameters {0 isClo : CloTest tm} {auto _ : PushSubsts tm isClo}
|
|
||||||
-- -- ||| if the input term has any top-level closures, push them under one layer of
|
|
||||||
-- -- ||| syntax
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- pushSubsts : tm d n -> NonClo tm d n
|
|
||||||
-- -- pushSubsts s = pushSubstsWith id id s
|
|
||||||
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- pushSubstsWith' : DSubst d1 d2 -> TSubst d2 n1 n2 -> tm d1 n1 -> tm d2 n2
|
|
||||||
-- -- pushSubstsWith' th ph x = fst $ pushSubstsWith th ph x
|
|
||||||
|
|
||||||
-- -- export %inline
|
|
||||||
-- -- pushSubsts' : tm d n -> tm d n
|
|
||||||
-- -- pushSubsts' s = fst $ pushSubsts s
|
|
||||||
|
|
||||||
-- -- mutual
|
|
||||||
-- -- public export
|
|
||||||
-- -- isCloT : CloTest Term
|
|
||||||
-- -- isCloT (CloT {}) = True
|
|
||||||
-- -- isCloT (DCloT {}) = True
|
|
||||||
-- -- isCloT (E e) = isCloE e
|
|
||||||
-- -- isCloT _ = False
|
|
||||||
|
|
||||||
-- -- public export
|
|
||||||
-- -- isCloE : CloTest Elim
|
|
||||||
-- -- isCloE (CloE {}) = True
|
|
||||||
-- -- isCloE (DCloE {}) = True
|
|
||||||
-- -- isCloE _ = False
|
|
||||||
|
|
||||||
-- -- mutual
|
|
||||||
-- -- export
|
|
||||||
-- -- PushSubsts Term Subst.isCloT where
|
|
||||||
-- -- pushSubstsWith th ph (TYPE l loc) =
|
|
||||||
-- -- nclo $ TYPE l loc
|
|
||||||
-- -- pushSubstsWith th ph (Pi qty a body loc) =
|
|
||||||
-- -- nclo $ Pi qty (a // th // ph) (body // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (Lam body loc) =
|
|
||||||
-- -- nclo $ Lam (body // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (Sig a b loc) =
|
|
||||||
-- -- nclo $ Sig (a // th // ph) (b // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (Pair s t loc) =
|
|
||||||
-- -- nclo $ Pair (s // th // ph) (t // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (Enum tags loc) =
|
|
||||||
-- -- nclo $ Enum tags loc
|
|
||||||
-- -- pushSubstsWith th ph (Tag tag loc) =
|
|
||||||
-- -- nclo $ Tag tag loc
|
|
||||||
-- -- pushSubstsWith th ph (Eq ty l r loc) =
|
|
||||||
-- -- nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (DLam body loc) =
|
|
||||||
-- -- nclo $ DLam (body // th // ph) loc
|
|
||||||
-- -- pushSubstsWith _ _ (Nat loc) =
|
|
||||||
-- -- nclo $ Nat loc
|
|
||||||
-- -- pushSubstsWith _ _ (Zero loc) =
|
|
||||||
-- -- nclo $ Zero loc
|
|
||||||
-- -- pushSubstsWith th ph (Succ n loc) =
|
|
||||||
-- -- nclo $ Succ (n // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (BOX pi ty loc) =
|
|
||||||
-- -- nclo $ BOX pi (ty // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (Box val loc) =
|
|
||||||
-- -- nclo $ Box (val // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (E e) =
|
|
||||||
-- -- let Element e nc = pushSubstsWith th ph e in nclo $ E e
|
|
||||||
-- -- pushSubstsWith th ph (CloT (Sub s ps)) =
|
|
||||||
-- -- pushSubstsWith th (comp th ps ph) s
|
|
||||||
-- -- pushSubstsWith th ph (DCloT (Sub s ps)) =
|
|
||||||
-- -- pushSubstsWith (ps . th) ph s
|
|
||||||
|
|
||||||
-- -- export
|
|
||||||
-- -- PushSubsts Elim Subst.isCloE where
|
|
||||||
-- -- pushSubstsWith th ph (F x u loc) =
|
|
||||||
-- -- nclo $ F x u loc
|
|
||||||
-- -- pushSubstsWith th ph (B i loc) =
|
|
||||||
-- -- let res = getLoc ph i loc in
|
|
||||||
-- -- case nchoose $ isCloE res of
|
|
||||||
-- -- Left yes => assert_total pushSubsts res
|
|
||||||
-- -- Right no => Element res no
|
|
||||||
-- -- pushSubstsWith th ph (App f s loc) =
|
|
||||||
-- -- nclo $ App (f // th // ph) (s // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (CasePair pi p r b loc) =
|
|
||||||
-- -- nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (CaseEnum pi t r arms loc) =
|
|
||||||
-- -- nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
|
|
||||||
-- -- (map (\b => b // th // ph) arms) loc
|
|
||||||
-- -- pushSubstsWith th ph (CaseNat pi pi' n r z s loc) =
|
|
||||||
-- -- nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph)
|
|
||||||
-- -- (z // th // ph) (s // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (CaseBox pi x r b loc) =
|
|
||||||
-- -- nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (DApp f d loc) =
|
|
||||||
-- -- nclo $ DApp (f // th // ph) (d // th) loc
|
|
||||||
-- -- pushSubstsWith th ph (Ann s a loc) =
|
|
||||||
-- -- nclo $ Ann (s // th // ph) (a // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (Coe ty p q val loc) =
|
|
||||||
-- -- nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (Comp ty p q val r zero one loc) =
|
|
||||||
-- -- nclo $ Comp (ty // th // ph) (p // th) (q // th)
|
|
||||||
-- -- (val // th // ph) (r // th)
|
|
||||||
-- -- (zero // th // ph) (one // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (TypeCase ty ret arms def loc) =
|
|
||||||
-- -- nclo $ TypeCase (ty // th // ph) (ret // th // ph)
|
|
||||||
-- -- (map (\t => t // th // ph) arms) (def // th // ph) loc
|
|
||||||
-- -- pushSubstsWith th ph (CloE (Sub e ps)) =
|
|
||||||
-- -- pushSubstsWith th (comp th ps ph) e
|
|
||||||
-- -- pushSubstsWith th ph (DCloE (Sub e ps)) =
|
|
||||||
-- -- pushSubstsWith (ps . th) ph e
|
|
||||||
|
|
||||||
|
|
||||||
-- -- private %inline
|
|
||||||
-- -- CompHY : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
|
||||||
-- -- (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
|
|
||||||
-- -- CompHY {ty, p, q, val, r, zero, one, loc} =
|
|
||||||
-- -- let ty' = SY ty.names $ ty.term // (B VZ ty.loc ::: shift 2) in
|
|
||||||
-- -- Comp {
|
|
||||||
-- -- ty = dsub1 ty q, p, q,
|
|
||||||
-- -- val = E $ Coe ty p q val val.loc, r,
|
|
||||||
-- -- -- [fixme] better locations for these vars?
|
|
||||||
-- -- zero = SY zero.names $ E $
|
|
||||||
-- -- Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
|
|
||||||
-- -- one = SY one.names $ E $
|
|
||||||
-- -- Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
|
|
||||||
-- -- loc
|
|
||||||
-- -- }
|
|
||||||
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- CompH' : (ty : DScopeTerm d n) ->
|
|
||||||
-- -- (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
|
|
||||||
-- -- (zero : DScopeTerm d n) ->
|
|
||||||
-- -- (one : DScopeTerm d n) ->
|
|
||||||
-- -- (loc : Loc) ->
|
|
||||||
-- -- Elim d n
|
|
||||||
-- -- CompH' {ty, p, q, val, r, zero, one, loc} =
|
|
||||||
-- -- case dsqueeze ty of
|
|
||||||
-- -- S _ (N ty) => Comp {ty, p, q, val, r, zero, one, loc}
|
|
||||||
-- -- S _ (Y _) => CompHY {ty, p, q, val, r, zero, one, loc}
|
|
||||||
|
|
||||||
-- -- ||| heterogeneous composition, using Comp and Coe (and subst)
|
|
||||||
-- -- |||
|
|
||||||
-- -- ||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ }
|
|
||||||
-- -- ||| ≔
|
|
||||||
-- -- ||| comp [A‹q/i›] @p @q (coe [i ⇒ A] @p @q s) @r {
|
|
||||||
-- -- ||| 0 j ⇒ coe [i ⇒ A] @j @q t₀;
|
|
||||||
-- -- ||| 1 j ⇒ coe [i ⇒ A] @j @q t₁
|
|
||||||
-- -- ||| }
|
|
||||||
-- -- public export %inline
|
|
||||||
-- -- CompH : (i : BindName) -> (ty : Term (S d) n) ->
|
|
||||||
-- -- (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
|
|
||||||
-- -- (j0 : BindName) -> (zero : Term (S d) n) ->
|
|
||||||
-- -- (j1 : BindName) -> (one : Term (S d) n) ->
|
|
||||||
-- -- (loc : Loc) ->
|
|
||||||
-- -- Elim d n
|
|
||||||
-- -- CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
|
|
||||||
-- -- CompH' {ty = SY [< i] ty, p, q, val, r,
|
|
||||||
-- -- zero = SY [< j0] zero, one = SY [< j0] 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
|
||||||
|
|
|
@ -1,13 +0,0 @@
|
||||||
module Quox.Thin
|
|
||||||
|
|
||||||
import public Quox.Thin.Base
|
|
||||||
import public Quox.Thin.View
|
|
||||||
import public Quox.Thin.Eqv
|
|
||||||
import public Quox.Thin.Cons
|
|
||||||
import public Quox.Thin.List
|
|
||||||
import public Quox.Thin.Append
|
|
||||||
import public Quox.Thin.Comp
|
|
||||||
import public Quox.Thin.Cover
|
|
||||||
import public Quox.Thin.Coprod
|
|
||||||
import public Quox.Thin.Split
|
|
||||||
import public Quox.Thin.Term
|
|
|
@ -1,27 +0,0 @@
|
||||||
module Quox.Thin.Append
|
|
||||||
|
|
||||||
import public Quox.Thin.Base
|
|
||||||
import public Quox.Thin.View
|
|
||||||
import Data.DPair
|
|
||||||
|
|
||||||
%default total
|
|
||||||
|
|
||||||
public export
|
|
||||||
app' : OPE m1 n1 mask1 -> OPE m2 n2 mask2 -> Exists (OPE (m1 + m2) (n1 + n2))
|
|
||||||
app' Stop ope2 = Evidence _ ope2
|
|
||||||
app' (Drop ope1 Refl) ope2 = Evidence _ $ Drop (app' ope1 ope2).snd Refl
|
|
||||||
app' (Keep ope1 Refl) ope2 = Evidence _ $ Keep (app' ope1 ope2).snd Refl
|
|
||||||
|
|
||||||
public export
|
|
||||||
(++) : {n1, n2, mask1, mask2 : Nat} ->
|
|
||||||
(0 ope1 : OPE m1 n1 mask1) -> (0 ope2 : OPE m2 n2 mask2) ->
|
|
||||||
Subset Nat (OPE (m1 + m2) (n1 + n2))
|
|
||||||
ope1 ++ ope2 with %syntactic (view ope1)
|
|
||||||
Stop ++ ope2 | StopV = Element _ ope2
|
|
||||||
Drop ope1 Refl ++ ope2 | DropV mask ope1 =
|
|
||||||
Element _ $ Drop (ope1 ++ ope2).snd Refl
|
|
||||||
Keep ope1 Refl ++ ope2 | KeepV mask ope1 =
|
|
||||||
Element _ $ Keep (ope1 ++ ope2).snd Refl
|
|
||||||
|
|
||||||
-- [todo] this mask is just (mask1 << n2) | mask2
|
|
||||||
-- prove it and add %transform
|
|
|
@ -1,81 +0,0 @@
|
||||||
module Quox.Thin.Base
|
|
||||||
|
|
||||||
import Data.Fin
|
|
||||||
import Data.DPair
|
|
||||||
|
|
||||||
%default total
|
|
||||||
|
|
||||||
||| "order preserving embeddings", for recording a correspondence between a
|
|
||||||
||| smaller scope and part of a larger one. the third argument is a bitmask
|
|
||||||
||| representing this OPE, unique for a given `n`.
|
|
||||||
public export
|
|
||||||
data OPE : (m, n, mask : Nat) -> Type where
|
|
||||||
[search m n]
|
|
||||||
Stop : OPE 0 0 0
|
|
||||||
Drop : OPE m n mask -> mask' = mask + mask -> OPE m (S n) mask'
|
|
||||||
Keep : OPE m n mask -> mask' = (S (mask + mask)) -> OPE (S m) (S n) mask'
|
|
||||||
%name OPE ope
|
|
||||||
|
|
||||||
export
|
|
||||||
Show (OPE m n mask) where
|
|
||||||
showPrec d Stop = "Stop"
|
|
||||||
showPrec d (Drop ope Refl) = showCon d "Drop" $ showArg ope ++ " Refl"
|
|
||||||
showPrec d (Keep ope Refl) = showCon d "Keep" $ showArg ope ++ " Refl"
|
|
||||||
|
|
||||||
public export %inline
|
|
||||||
drop : OPE m n mask -> OPE m (S n) (mask + mask)
|
|
||||||
drop ope = Drop ope Refl
|
|
||||||
|
|
||||||
public export %inline
|
|
||||||
keep : OPE m n mask -> OPE (S m) (S n) (S (mask + mask))
|
|
||||||
keep ope = Keep ope Refl
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
data IsStop : OPE m n mask -> Type where ItIsStop : IsStop Stop
|
|
||||||
|
|
||||||
public export
|
|
||||||
data IsDrop : OPE m n mask -> Type where ItIsDrop : IsDrop (Drop ope eq)
|
|
||||||
|
|
||||||
public export
|
|
||||||
data IsKeep : OPE m n mask -> Type where ItIsKeep : IsKeep (Keep ope eq)
|
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
0 zeroIsStop : (ope : OPE m 0 mask) -> IsStop ope
|
|
||||||
zeroIsStop Stop = ItIsStop
|
|
||||||
|
|
||||||
|
|
||||||
||| everything selected
|
|
||||||
public export
|
|
||||||
id : {m : Nat} -> Subset Nat (OPE m m)
|
|
||||||
id {m = 0} = Element _ Stop
|
|
||||||
id {m = S m} = Element _ $ Keep id.snd Refl
|
|
||||||
|
|
||||||
public export %inline
|
|
||||||
0 id' : {m : Nat} -> OPE m m (fst (Base.id {m}))
|
|
||||||
id' = id.snd
|
|
||||||
|
|
||||||
||| nothing selected
|
|
||||||
public export
|
|
||||||
zero : {m : Nat} -> OPE 0 m 0
|
|
||||||
zero {m = 0} = Stop
|
|
||||||
zero {m = S m} = Drop zero Refl
|
|
||||||
|
|
||||||
||| a single slot selected
|
|
||||||
public export
|
|
||||||
one : Fin n -> Subset Nat (OPE 1 n)
|
|
||||||
one FZ = Element _ $ keep zero
|
|
||||||
one (FS i) = Element _ $ drop (one i).snd
|
|
||||||
|
|
||||||
public export %inline
|
|
||||||
0 one' : (i : Fin n) -> OPE 1 n (one i).fst
|
|
||||||
one' i = (one i).snd
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
record SomeOPE n where
|
|
||||||
constructor MkOPE
|
|
||||||
{0 scope : Nat}
|
|
||||||
{mask : Nat}
|
|
||||||
0 ope : OPE scope n mask
|
|
|
@ -1,55 +0,0 @@
|
||||||
module Quox.Thin.Comp
|
|
||||||
|
|
||||||
import public Quox.Thin.Base
|
|
||||||
import public Quox.Thin.View
|
|
||||||
import Quox.NatExtra
|
|
||||||
import Data.Singleton
|
|
||||||
|
|
||||||
%default total
|
|
||||||
|
|
||||||
||| inductive definition of OPE composition
|
|
||||||
public export
|
|
||||||
data Comp : (l : OPE n p mask1) -> (r : OPE m n mask2) ->
|
|
||||||
(res : OPE m p mask3) -> Type where
|
|
||||||
[search l r]
|
|
||||||
StopZ : Comp Stop Stop Stop
|
|
||||||
DropZ : Comp a b c -> Comp (Drop a Refl) b (Drop c Refl)
|
|
||||||
KeepZ : Comp a b c -> Comp (Keep a Refl) (Keep b Refl) (Keep c Refl)
|
|
||||||
KDZ : Comp a b c -> Comp (Keep a Refl) (Drop b Refl) (Drop c Refl)
|
|
||||||
|
|
||||||
public export
|
|
||||||
record CompResult (ope1 : OPE n p mask1) (ope2 : OPE m n mask2) where
|
|
||||||
constructor MkComp
|
|
||||||
{mask : Nat}
|
|
||||||
{0 ope : OPE m p mask}
|
|
||||||
0 comp : Comp ope1 ope2 ope
|
|
||||||
%name CompResult comp
|
|
||||||
|
|
||||||
||| compose two OPEs, if the middle scope size is already known at runtime
|
|
||||||
export
|
|
||||||
comp' : {n, p, mask1, mask2 : Nat} ->
|
|
||||||
(0 ope1 : OPE n p mask1) -> (0 ope2 : OPE m n mask2) ->
|
|
||||||
CompResult ope1 ope2
|
|
||||||
comp' ope1 ope2 with %syntactic (view ope1) | (view ope2)
|
|
||||||
comp' Stop Stop | StopV | StopV =
|
|
||||||
MkComp StopZ
|
|
||||||
comp' (Drop ope1 Refl) ope2 | DropV _ ope1 | _ =
|
|
||||||
MkComp $ DropZ (comp' ope1 ope2).comp
|
|
||||||
comp' (Keep ope1 Refl) (Drop ope2 Refl) | KeepV _ ope1 | DropV _ ope2 =
|
|
||||||
MkComp $ KDZ (comp' ope1 ope2).comp
|
|
||||||
comp' (Keep ope1 Refl) (Keep ope2 Refl) | KeepV _ ope1 | KeepV _ ope2 =
|
|
||||||
MkComp $ KeepZ (comp' ope1 ope2).comp
|
|
||||||
|
|
||||||
||| compose two OPEs, after recomputing the middle scope size using `appOpe`
|
|
||||||
export
|
|
||||||
comp : {p, mask1, mask2 : Nat} ->
|
|
||||||
(0 ope1 : OPE n p mask1) -> (0 ope2 : OPE m n mask2) ->
|
|
||||||
CompResult ope1 ope2
|
|
||||||
comp ope1 ope2 = let Val n = appOpe p ope1 in comp' ope1 ope2
|
|
||||||
|
|
||||||
-- [todo] is there a quick way to compute the mask of comp?
|
|
||||||
|
|
||||||
export
|
|
||||||
0 (.) : (ope1 : OPE n p mask1) -> (ope2 : OPE m n mask2) ->
|
|
||||||
OPE m p (comp ope1 ope2).mask
|
|
||||||
ope1 . ope2 = (comp ope1 ope2).ope
|
|
|
@ -1,74 +0,0 @@
|
||||||
module Quox.Thin.Cons
|
|
||||||
|
|
||||||
import public Quox.Thin.Base
|
|
||||||
import Quox.Thin.Eqv
|
|
||||||
import Quox.Thin.View
|
|
||||||
import Data.DPair
|
|
||||||
import Control.Relation
|
|
||||||
|
|
||||||
%default total
|
|
||||||
|
|
||||||
|
|
||||||
public export
|
|
||||||
data IsHead : (ope : OPE m (S n) mask) -> Bool -> Type where
|
|
||||||
[search ope]
|
|
||||||
DropH : IsHead (Drop ope eq) False
|
|
||||||
KeepH : IsHead (Keep ope eq) True
|
|
||||||
|
|
||||||
public export
|
|
||||||
data IsTail : (full : OPE m (S n) mask) -> OPE m' n mask' -> Type where
|
|
||||||
[search full]
|
|
||||||
DropT : IsTail (Drop ope eq) ope
|
|
||||||
KeepT : IsTail (Keep ope eq) ope
|
|
||||||
|
|
||||||
public export
|
|
||||||
record Uncons (ope : OPE m (S n) mask) where
|
|
||||||
constructor MkUncons
|
|
||||||
0 head : Bool
|
|
||||||
{tailMask : Nat}
|
|
||||||
0 tail : OPE scope n tailMask
|
|
||||||
{auto isHead : IsHead ope head}
|
|
||||||
{auto 0 isTail : IsTail ope tail}
|
|
||||||
|
|
||||||
public export
|
|
||||||
uncons : {n, mask : Nat} -> (0 ope : OPE m (S n) mask) -> Uncons ope
|
|
||||||
uncons ope with %syntactic (view ope)
|
|
||||||
uncons (Drop ope Refl) | DropV _ ope = MkUncons False ope
|
|
||||||
uncons (Keep ope Refl) | KeepV _ ope = MkUncons True ope
|
|
||||||
|
|
||||||
public export
|
|
||||||
head : {n, mask : Nat} -> (0 ope : OPE m (S n) mask) -> Exists $ IsHead ope
|
|
||||||
head ope = Evidence _ (uncons ope).isHead
|
|
||||||
|
|
||||||
public export
|
|
||||||
record Tail (ope : OPE m (S n) mask) where
|
|
||||||
constructor MkTail
|
|
||||||
{tailMask : Nat}
|
|
||||||
0 tail : OPE scope n tailMask
|
|
||||||
{auto 0 isTail : IsTail ope tail}
|
|
||||||
|
|
||||||
public export
|
|
||||||
tail : {n, mask : Nat} -> (0 ope : OPE m (S n) mask) -> Tail ope
|
|
||||||
tail ope = let u = uncons ope in MkTail u.tail @{u.isTail}
|
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
cons : {mask : Nat} -> (head : Bool) -> (0 tail : OPE m n mask) ->
|
|
||||||
Subset Nat (OPE (if head then S m else m) (S n))
|
|
||||||
cons False tail = Element _ $ drop tail
|
|
||||||
cons True tail = Element _ $ keep tail
|
|
||||||
|
|
||||||
export
|
|
||||||
0 consEquiv' : (self : OPE m' (S n) mask') ->
|
|
||||||
(head : Bool) -> (tail : OPE m n mask) ->
|
|
||||||
IsHead self head -> IsTail self tail ->
|
|
||||||
(cons head tail).snd `Eqv` self
|
|
||||||
consEquiv' (Drop tail _) False tail DropH DropT = EqvDrop reflexive
|
|
||||||
consEquiv' (Keep tail _) True tail KeepH KeepT = EqvKeep reflexive
|
|
||||||
|
|
||||||
export
|
|
||||||
0 consEquiv : (full : OPE m' (S n) mask') ->
|
|
||||||
(cons (uncons full).head (uncons full).tail).snd `Eqv` full
|
|
||||||
consEquiv full with %syntactic (uncons full)
|
|
||||||
_ | MkUncons head tail {isHead, isTail} =
|
|
||||||
consEquiv' full head tail isHead isTail
|
|
Some files were not shown because too many files have changed in this diff Show more
Loading…
Reference in a new issue