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-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 "pair.quox"
|
||||
load "list.quox"
|
||||
load "eta.quox"
|
||||
load "fail.quox"
|
||||
load "qty.quox"
|
||||
|
|
|
@ -4,24 +4,35 @@ namespace bool {
|
|||
|
||||
def0 Bool : ★ = {true, false};
|
||||
|
||||
def boolω : 1.Bool → [ω.Bool] =
|
||||
λ b ⇒ case1 b return [ω.Bool] of { 'true ⇒ ['true]; 'false ⇒ ['false] };
|
||||
def if-dep : 0.(P : Bool → ★) → (b : Bool) → ω.(P 'true) → ω.(P 'false) → P b =
|
||||
λ P b t f ⇒ case b return b' ⇒ P b' of { 'true ⇒ t; 'false ⇒ f };
|
||||
|
||||
def if : 0.(A : ★) → 1.Bool → ω.A → ω.A → A =
|
||||
λ A b t f ⇒ case1 b return A of { 'true ⇒ t; 'false ⇒ f };
|
||||
def if : 0.(A : ★) → (b : Bool) → ω.A → ω.A → A =
|
||||
λ A ⇒ if-dep (λ _ ⇒ A);
|
||||
|
||||
def0 If : 1.Bool → 0.★ → 0.★ → ★ =
|
||||
λ b T F ⇒ case1 b return ★ of { 'true ⇒ T; 'false ⇒ F };
|
||||
def0 if-same : (A : ★) → (b : Bool) → (x : A) → if A b x x ≡ x : A =
|
||||
λ A b x ⇒ if-dep (λ b' ⇒ if A b' x x ≡ x : A) b (δ _ ⇒ x) (δ _ ⇒ x);
|
||||
|
||||
def0 T : ω.Bool → ★ = λ b ⇒ If b True False;
|
||||
def if2 : 0.(A B : ★) → (b : Bool) → ω.A → ω.B → if¹ ★ b A B =
|
||||
λ A B ⇒ if-dep (λ b ⇒ if-dep¹ (λ _ ⇒ ★) b A B);
|
||||
|
||||
def0 T : Bool → ★ = λ b ⇒ if¹ ★ b True False;
|
||||
|
||||
def dup! : (b : Bool) → [ω. Sing Bool b] =
|
||||
λ b ⇒ if-dep (λ b ⇒ [ω. Sing Bool b]) b
|
||||
[('true, [δ _ ⇒ 'true])]
|
||||
[('false, [δ _ ⇒ 'false])];
|
||||
|
||||
def dup : Bool → [ω. Bool] =
|
||||
λ b ⇒ appω (Sing Bool b) Bool (sing.val Bool b) (dup! b);
|
||||
|
||||
def true-not-false : Not ('true ≡ 'false : Bool) =
|
||||
λ eq ⇒ coe (i ⇒ T (eq @i)) 'true;
|
||||
λ eq ⇒ coe (𝑖 ⇒ T (eq @𝑖)) 'true;
|
||||
|
||||
|
||||
-- [todo] infix
|
||||
def and : 1.Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
|
||||
def or : 1.Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
|
||||
def and : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
|
||||
def or : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
|
||||
|
||||
}
|
||||
|
||||
|
|
|
@ -5,35 +5,35 @@ namespace either {
|
|||
|
||||
def0 Tag : ★ = {left, right};
|
||||
|
||||
def0 Payload : 0.★ → 0.★ → 1.Tag → ★ =
|
||||
λ A B tag ⇒ case1 tag return ★ of { 'left ⇒ A; 'right ⇒ B };
|
||||
def0 Payload : ★ → ★ → Tag → ★ =
|
||||
λ A B tag ⇒ case tag return ★ of { 'left ⇒ A; 'right ⇒ B };
|
||||
|
||||
def0 Either : 0.★ → 0.★ → ★ =
|
||||
def0 Either : ★ → ★ → ★ =
|
||||
λ A B ⇒ (tag : Tag) × Payload A B tag;
|
||||
|
||||
def Left : 0.(A B : ★) → 1.A → Either A B =
|
||||
def Left : 0.(A B : ★) → A → Either A B =
|
||||
λ A B x ⇒ ('left, x);
|
||||
|
||||
def Right : 0.(A B : ★) → 1.B → Either A B =
|
||||
def Right : 0.(A B : ★) → B → Either A B =
|
||||
λ A B x ⇒ ('right, x);
|
||||
|
||||
def elim' :
|
||||
0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
|
||||
ω.(1.(x : A) → P (Left A B x)) →
|
||||
ω.(1.(x : B) → P (Right A B x)) →
|
||||
1.(t : Tag) → 1.(a : Payload A B t) → P (t, a) =
|
||||
ω.((x : A) → P (Left A B x)) →
|
||||
ω.((x : B) → P (Right A B x)) →
|
||||
(t : Tag) → (a : Payload A B t) → P (t, a) =
|
||||
λ A B P f g t ⇒
|
||||
case1 t
|
||||
return t' ⇒ 1.(a : Payload A B t') → P (t', a)
|
||||
case t
|
||||
return t' ⇒ (a : Payload A B t') → P (t', a)
|
||||
of { 'left ⇒ f; 'right ⇒ g };
|
||||
|
||||
def elim :
|
||||
0.(A B : ★) → 0.(P : 0.(Either A B) → ★) →
|
||||
ω.(1.(x : A) → P (Left A B x)) →
|
||||
ω.(1.(x : B) → P (Right A B x)) →
|
||||
1.(x : Either A B) → P x =
|
||||
ω.((x : A) → P (Left A B x)) →
|
||||
ω.((x : B) → P (Right A B x)) →
|
||||
(x : Either A B) → P x =
|
||||
λ A B P f g e ⇒
|
||||
case1 e return e' ⇒ P e' of { (t, a) ⇒ elim' A B P f g t a };
|
||||
case e return e' ⇒ P e' of { (t, a) ⇒ elim' A B P f g t a };
|
||||
|
||||
|
||||
}
|
||||
|
@ -45,25 +45,25 @@ def Right = either.Right;
|
|||
|
||||
namespace dec {
|
||||
|
||||
def0 Dec : 0.★ → ★ = λ A ⇒ Either [0.A] [0.Not A];
|
||||
def0 Dec : ★ → ★ = λ A ⇒ Either [0.A] [0.Not A];
|
||||
|
||||
def Yes : 0.(A : ★) → 0.A → Dec A = λ A y ⇒ Left [0.A] [0.Not A] [y];
|
||||
def No : 0.(A : ★) → 0.(Not A) → Dec A = λ A n ⇒ Right [0.A] [0.Not A] [n];
|
||||
|
||||
def0 DecEq : 0.★ → ★ =
|
||||
def0 DecEq : ★ → ★ =
|
||||
λ A ⇒ ω.(x : A) → ω.(y : A) → Dec (x ≡ y : A);
|
||||
|
||||
def elim :
|
||||
0.(A : ★) → 0.(P : 0.(Dec A) → ★) →
|
||||
ω.(0.(y : A) → P (Yes A y)) →
|
||||
ω.(0.(n : Not A) → P (No A n)) →
|
||||
1.(x : Dec A) → P x =
|
||||
(x : Dec A) → P x =
|
||||
λ A P f g ⇒
|
||||
either.elim [0.A] [0.Not A] P
|
||||
(λ y ⇒ case0 y return y' ⇒ P (Left [0.A] [0.Not A] y') of {[y'] ⇒ f y'})
|
||||
(λ n ⇒ case0 n return n' ⇒ P (Right [0.A] [0.Not A] n') of {[n'] ⇒ g n'});
|
||||
|
||||
def bool : 0.(A : ★) → 1.(Dec A) → Bool =
|
||||
def bool : 0.(A : ★) → Dec A → Bool =
|
||||
λ A ⇒ elim A (λ _ ⇒ Bool) (λ _ ⇒ 'true) (λ _ ⇒ 'false);
|
||||
|
||||
}
|
||||
|
|
25
examples/eta.quox
Normal file
25
examples/eta.quox
Normal file
|
@ -0,0 +1,25 @@
|
|||
load "misc.quox"
|
||||
|
||||
namespace eta {
|
||||
|
||||
def0 Π : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) → B x
|
||||
def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x
|
||||
|
||||
def0 function : (A : ★) → (B : A → Type) → (P : Π A B → ★) → (f : Π A B) →
|
||||
P (λ x ⇒ f x) → P f =
|
||||
λ A B P f p ⇒ p
|
||||
|
||||
def0 box : (A : ★) → (P : [ω.A] → ★) → (e : [ω.A]) →
|
||||
P [case1 e return A of {[x] ⇒ x}] → P e =
|
||||
λ A P e p ⇒ p
|
||||
|
||||
def0 pair : (A : ★) → (B : A → ★) → (P : Σ A B → ★) → (e : Σ A B) →
|
||||
P (fst e, snd e) → P e =
|
||||
λ A B P e p ⇒ p
|
||||
|
||||
-- not exactly η, but kinda related
|
||||
def0 from-false : (A : ★) → (P : (0.False → A) → ★) → (f : 0.False → A) →
|
||||
P (void A) → P f =
|
||||
λ A P f p ⇒ p
|
||||
|
||||
}
|
16
examples/fail.quox
Normal file
16
examples/fail.quox
Normal file
|
@ -0,0 +1,16 @@
|
|||
#[fail "but cases for"]
|
||||
def missing-b : {a, b} → {a} =
|
||||
λ x ⇒ case x return {a} of { 'a ⇒ 'a }
|
||||
|
||||
#[fail "duplicate arms"]
|
||||
def repeat-enum-case : {a} → {a} =
|
||||
λ x ⇒ case x return {a} of { 'a ⇒ 'a; 'a ⇒ 'a }
|
||||
|
||||
#[fail "duplicate tags"]
|
||||
def repeat-enum-type : {a, a} = 'a
|
||||
|
||||
#[fail "double-def.X has already been defined"]
|
||||
namespace double-def {
|
||||
def0 X : ★ = {a}
|
||||
def0 X : ★ = {a}
|
||||
}
|
26
examples/hello.quox
Normal file
26
examples/hello.quox
Normal file
|
@ -0,0 +1,26 @@
|
|||
def0 Unit : ★ = {tt}
|
||||
|
||||
def drop-unit : 0.(A : ★) → Unit → A → A =
|
||||
λ A u x ⇒ case u return A of {'tt ⇒ x}
|
||||
|
||||
def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
|
||||
|
||||
def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B =
|
||||
λ A B m k s0 ⇒
|
||||
case m s0 return B × IOState of { (x, s1) ⇒ k x s1 }
|
||||
|
||||
def seq : IO Unit → IO Unit → IO Unit =
|
||||
λ a b ⇒ bind Unit Unit a (λ u ⇒ drop-unit (IO Unit) u b)
|
||||
|
||||
#[compile-scheme "(lambda (n) (builtin-io (printf \"~d~n\" n) 'tt))"]
|
||||
postulate print-ℕ : ℕ → IO Unit
|
||||
|
||||
#[compile-scheme "(lambda (s) (builtin-io (printf \"~s~n\" s) 'tt))"]
|
||||
postulate print : String → IO Unit
|
||||
|
||||
load "nat.quox"
|
||||
|
||||
#[main]
|
||||
def main : IO Unit =
|
||||
let1 sixty-nine = nat.plus 60 9 in
|
||||
seq (print-ℕ sixty-nine) (print "(nice)")
|
31
examples/io.quox
Normal file
31
examples/io.quox
Normal file
|
@ -0,0 +1,31 @@
|
|||
load "misc.quox"
|
||||
|
||||
namespace io {
|
||||
|
||||
def0 IORes : ★ → ★ = λ A ⇒ A × IOState
|
||||
|
||||
def0 IO : ★ → ★ = λ A ⇒ IOState → IORes A
|
||||
|
||||
def pure : 0.(A : ★) → A → IO A = λ A x s ⇒ (x, s)
|
||||
|
||||
def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B =
|
||||
λ A B m k s0 ⇒
|
||||
case m s0 return IORes B of { (x, s1) ⇒ k x s1 }
|
||||
|
||||
def seq : 0.(B : ★) → IO True → IO B → IO B =
|
||||
λ B x y ⇒ bind True B x (λ u ⇒ case u return IO B of { 'true ⇒ y })
|
||||
|
||||
def seq' : IO True → IO True → IO True = seq True
|
||||
|
||||
#[compile-scheme "(lambda (str) (builtin-io (display str) 'true))"]
|
||||
postulate print : String → IO True
|
||||
|
||||
def newline = print "\n"
|
||||
|
||||
def println : String → IO True =
|
||||
λ str ⇒ seq' (print str) newline
|
||||
|
||||
#[compile-scheme "(builtin-io (get-line (current-input-port)))"]
|
||||
postulate readln : IO String
|
||||
|
||||
}
|
|
@ -1,41 +1,91 @@
|
|||
load "nat.quox";
|
||||
|
||||
namespace list {
|
||||
namespace vec {
|
||||
|
||||
def0 Vec : 0.ℕ → 0.★ → ★ =
|
||||
def0 Vec : ℕ → ★ → ★ =
|
||||
λ n A ⇒
|
||||
caseω n return ★ of {
|
||||
zero ⇒ {nil};
|
||||
succ _, 0.Tail ⇒ A × Tail
|
||||
};
|
||||
|
||||
def0 List : 0.★ → ★ =
|
||||
λ A ⇒ (len : ℕ) × Vec len A;
|
||||
def elim : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
|
||||
P 0 'nil →
|
||||
ω.((x : A) → 0.(n : ℕ) → 0.(xs : Vec n A) →
|
||||
P n xs → P (succ n) (x, xs)) →
|
||||
(n : ℕ) → (xs : Vec n A) → P n xs =
|
||||
λ A P pn pc n ⇒
|
||||
case n return n' ⇒ (xs' : Vec n' A) → P n' xs' of {
|
||||
zero ⇒ λ n ⇒
|
||||
case n return n' ⇒ P 0 n' of { 'nil ⇒ pn };
|
||||
succ n, ih ⇒ λ c ⇒
|
||||
case c return c' ⇒ P (succ n) c' of {
|
||||
(first, rest) ⇒ pc first n rest (ih rest)
|
||||
}
|
||||
};
|
||||
|
||||
def nil : 0.(A : ★) → List A =
|
||||
λ A ⇒ (0, 'nil);
|
||||
|
||||
def cons : 0.(A : ★) → 1.A → 1.(List A) → List A =
|
||||
λ A x xs ⇒ case1 xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
|
||||
|
||||
def foldr' : 0.(A B : ★) →
|
||||
1.B → ω.(1.A → 1.B → B) → 1.(n : ℕ) → 1.(Vec n A) → B =
|
||||
λ A B z c n ⇒
|
||||
case1 n return n' ⇒ 1.(Vec n' A) → B of {
|
||||
zero ⇒
|
||||
λ nil ⇒ case1 nil return B of { 'nil ⇒ z };
|
||||
succ n, 1.ih ⇒
|
||||
λ cons ⇒ case1 cons return B of { (first, rest) ⇒ c first (ih rest) }
|
||||
};
|
||||
|
||||
def foldr : 0.(A B : ★) → 1.B → ω.(1.A → 1.B → B) → 1.(List A) → B =
|
||||
λ A B z c xs ⇒
|
||||
case1 xs return B of { (len, elems) ⇒ foldr' A B z c len elems };
|
||||
|
||||
def sum : 1.(List ℕ) → ℕ = foldr ℕ ℕ 0 nat.plus;
|
||||
|
||||
def numbers : List ℕ = (5, (0, 1, 2, 3, 4, 'nil));
|
||||
|
||||
def number-sum : sum numbers ≡ 10 : ℕ = δ _ ⇒ 10;
|
||||
#[compile-scheme "(lambda% (n xs) xs)"]
|
||||
def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A =
|
||||
λ A n ⇒
|
||||
case n return n' ⇒ Vec n' A → Vec¹ n' A of {
|
||||
zero ⇒ λ xs ⇒
|
||||
case xs return Vec¹ 0 A of { 'nil ⇒ 'nil };
|
||||
succ n', f' ⇒ λ xs ⇒
|
||||
case xs return Vec¹ (succ n') A of {
|
||||
(first, rest) ⇒ (first, f' rest)
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
def0 Vec = vec.Vec;
|
||||
|
||||
|
||||
namespace list {
|
||||
|
||||
def0 List : ★ → ★ =
|
||||
λ A ⇒ (len : ℕ) × Vec len A;
|
||||
|
||||
def Nil : 0.(A : ★) → List A =
|
||||
λ A ⇒ (0, 'nil);
|
||||
|
||||
def Cons : 0.(A : ★) → A → List A → List A =
|
||||
λ A x xs ⇒ case xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
|
||||
|
||||
def elim : 0.(A : ★) → 0.(P : List A → ★) →
|
||||
P (Nil A) →
|
||||
ω.((x : A) → 0.(xs : List A) → P xs → P (Cons A x xs)) →
|
||||
(xs : List A) → P xs =
|
||||
λ A P pn pc xs ⇒
|
||||
case xs return xs' ⇒ P xs' of { (len, elems) ⇒
|
||||
vec.elim A (λ n xs ⇒ P (n, xs))
|
||||
pn (λ x n xs ih ⇒ pc x (n, xs) ih)
|
||||
len elems
|
||||
};
|
||||
|
||||
-- [fixme] List A <: List¹ A should be automatic, imo
|
||||
#[compile-scheme "(lambda (xs) xs)"]
|
||||
def up : 0.(A : ★) → List A → List¹ A =
|
||||
λ A xs ⇒
|
||||
case xs return List¹ A of { (len, elems) ⇒
|
||||
case nat.dup! len return List¹ A of { [p] ⇒
|
||||
caseω p return List¹ A of { (lenω, eq0) ⇒
|
||||
case eq0 return List¹ A of { [eq] ⇒
|
||||
(lenω, vec.up A lenω (coe (𝑖 ⇒ Vec (eq @𝑖) A) @1 @0 elems))
|
||||
}
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
def foldr : 0.(A B : ★) → B → ω.(A → B → B) → List A → B =
|
||||
λ A B z f xs ⇒ elim A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs;
|
||||
|
||||
def map : 0.(A B : ★) → ω.(A → B) → List A → List B =
|
||||
λ A B f ⇒ foldr A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys);
|
||||
|
||||
def0 All : (A : ★) → (P : A → ★) → List A → ★ =
|
||||
λ A P xs ⇒ foldr¹ A ★ True (λ x ps ⇒ P x × ps) (up A xs);
|
||||
|
||||
}
|
||||
|
||||
def0 List = list.List;
|
||||
|
|
|
@ -5,10 +5,10 @@ namespace maybe {
|
|||
|
||||
def0 Tag : ★ = {nothing, just}
|
||||
|
||||
def0 Payload : ω.Tag → ω.★ → ★ =
|
||||
λ tag A ⇒ caseω tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
|
||||
def0 Payload : Tag → ★ → ★ =
|
||||
λ tag A ⇒ case tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
|
||||
|
||||
def0 Maybe : ω.★ → ★ =
|
||||
def0 Maybe : ★ → ★ =
|
||||
λ A ⇒ (t : Tag) × Payload t A
|
||||
|
||||
def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
|
||||
|
@ -17,13 +17,13 @@ def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
|
|||
def Nothing : 0.(A : ★) → Maybe A =
|
||||
λ _ ⇒ ('nothing, 'true)
|
||||
|
||||
def Just : 0.(A : ★) → 1.A → Maybe A =
|
||||
def Just : 0.(A : ★) → A → Maybe A =
|
||||
λ _ x ⇒ ('just, x)
|
||||
|
||||
def0 IsJustTag : ω.Tag → ★ =
|
||||
λ t ⇒ caseω t return ★ of { 'just ⇒ True; 'nothing ⇒ False }
|
||||
def0 IsJustTag : Tag → ★ =
|
||||
λ 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)
|
||||
|
||||
def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
|
||||
|
@ -34,32 +34,31 @@ def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
|
|||
}
|
||||
|
||||
def0 nothing-unique :
|
||||
0.(A : ★) → ω.(x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
|
||||
(A : ★) → (x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
|
||||
λ 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)
|
||||
}
|
||||
|
||||
def elim :
|
||||
0.(A : ★) →
|
||||
0.(P : 0.(Maybe A) → ★) →
|
||||
0.(P : Maybe A → ★) →
|
||||
ω.(P (Nothing A)) →
|
||||
ω.(ω.(x : A) → P (Just A x)) →
|
||||
1.(x : Maybe A) → P x =
|
||||
ω.((x : A) → P (Just A x)) →
|
||||
(x : Maybe A) → P x =
|
||||
λ A P n j x ⇒
|
||||
caseω x return x' ⇒ P x' of {
|
||||
(tag, payload) ⇒
|
||||
(caseω tag
|
||||
return t ⇒
|
||||
0.(eq : tag ≡ t : Tag) → P (t, coe (i ⇒ Payload (eq @i) A) payload)
|
||||
of {
|
||||
'nothing ⇒
|
||||
λ eq ⇒
|
||||
caseω coe (i ⇒ Payload (eq @i) A) payload
|
||||
return p ⇒ P ('nothing, p)
|
||||
of { 'true ⇒ n };
|
||||
'just ⇒ λ eq ⇒ j (coe (i ⇒ Payload (eq @i) A) payload)
|
||||
}) (δ _ ⇒ tag)
|
||||
case x return x' ⇒ P x' of { (tag, payload) ⇒
|
||||
(case tag
|
||||
return t ⇒
|
||||
0.(eq : tag ≡ t : Tag) → P (t, coe (i ⇒ Payload (eq @i) A) payload)
|
||||
of {
|
||||
'nothing ⇒
|
||||
λ eq ⇒
|
||||
case coe (i ⇒ Payload (eq @i) A) payload
|
||||
return p ⇒ P ('nothing, p)
|
||||
of { 'true ⇒ n };
|
||||
'just ⇒ λ eq ⇒ j (coe (i ⇒ Payload (eq @i) A) payload)
|
||||
}) (δ _ ⇒ tag)
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
@ -1,36 +1,83 @@
|
|||
def0 True : ★ = {true};
|
||||
def0 True : ★ = {true}
|
||||
|
||||
def0 False : ★ = {};
|
||||
def0 Not : 0.★ → ★ = λ A ⇒ ω.A → False;
|
||||
def0 False : ★ = {}
|
||||
def0 Not : ★ → ★ = λ A ⇒ ω.A → False
|
||||
|
||||
def void : 0.(A : ★) → 0.False → A =
|
||||
λ A v ⇒ case0 v return A of { };
|
||||
λ A v ⇒ case0 v return A of { }
|
||||
|
||||
def0 Pred : 0.★ → ★¹ = λ A ⇒ 0.A → ★;
|
||||
def0 All : (A : ★) → (0.A → ★) → ★ =
|
||||
λ A P ⇒ (x : A) → P x
|
||||
|
||||
def0 All : 0.(A : ★) → 0.(Pred A) → ★¹ =
|
||||
λ A P ⇒ 1.(x : A) → P x;
|
||||
def0 cong :
|
||||
(A : ★) → (P : 0.A → ★) → (p : All A P) →
|
||||
(x y : A) → (xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) =
|
||||
λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖)
|
||||
|
||||
def0 cong' :
|
||||
(A B : ★) → (f : A → B) →
|
||||
(x y : A) → (xy : x ≡ y : A) → f x ≡ f y : B =
|
||||
λ A B ⇒ cong A (λ _ ⇒ B)
|
||||
|
||||
def0 coherence :
|
||||
(A B : ★) → (AB : A ≡ B : ★) → (x : A) →
|
||||
Eq (𝑖 ⇒ AB @𝑖) x (coe (𝑖 ⇒ AB @𝑖) x) =
|
||||
λ A B AB x ⇒
|
||||
δ 𝑗 ⇒ coe (𝑖 ⇒ AB @𝑖) @0 @𝑗 x
|
||||
|
||||
def cong :
|
||||
0.(A : ★) → 0.(P : Pred A) → 1.(p : All A P) →
|
||||
0.(x y : A) → 1.(xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) =
|
||||
λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖);
|
||||
|
||||
def0 eq-f :
|
||||
0.(A : ★) → 0.(P : Pred A) →
|
||||
0.(A : ★) → 0.(P : 0.A → ★) →
|
||||
0.(p : All A P) → 0.(q : All A P) →
|
||||
0.A → ★ =
|
||||
λ A P p q x ⇒ p x ≡ q x : P x;
|
||||
λ A P p q x ⇒ p x ≡ q x : P x
|
||||
|
||||
def funext :
|
||||
0.(A : ★) → 0.(P : Pred A) → 0.(p q : All A P) →
|
||||
1.(All A (eq-f A P p q)) → p ≡ q : All A P =
|
||||
λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖;
|
||||
0.(A : ★) → 0.(P : 0.A → ★) → 0.(p q : All A P) →
|
||||
(All A (eq-f A P p q)) → p ≡ q : All A P =
|
||||
λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖
|
||||
|
||||
def sym : 0.(A : ★) → 0.(x y : A) → 1.(x ≡ y : A) → y ≡ x : A =
|
||||
λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 };
|
||||
def refl : 0.(A : ★) → (x : A) → x ≡ x : A = λ A x ⇒ δ _ ⇒ x
|
||||
|
||||
def sym : 0.(A : ★) → 0.(x y : A) → (x ≡ y : A) → y ≡ x : A =
|
||||
λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 }
|
||||
|
||||
def trans : 0.(A : ★) → 0.(x y z : A) →
|
||||
ω.(x ≡ y : A) → ω.(y ≡ z : A) → x ≡ z : A =
|
||||
λ A x y z eq1 eq2 ⇒ δ 𝑖 ⇒
|
||||
comp A (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 };
|
||||
comp A (eq1 @𝑖) @𝑖 { 0 _ ⇒ eq1 @0; 1 𝑗 ⇒ eq2 @𝑗 }
|
||||
|
||||
def appω : 0.(A B : ★) → ω.(f : A → B) → [ω.A] → [ω.B] =
|
||||
λ A B f x ⇒
|
||||
case x return [ω.B] of { [x'] ⇒ [f x'] }
|
||||
|
||||
def0 HEq : (A B : ★) → A → B → ★¹ =
|
||||
λ A B x y ⇒ (AB : A ≡ B : ★) × Eq (𝑖 ⇒ AB @𝑖) x y
|
||||
|
||||
|
||||
def0 Sing : (A : ★) → A → ★ =
|
||||
λ A x ⇒ (val : A) × [0. val ≡ x : A]
|
||||
|
||||
def sing : 0.(A : ★) → (x : A) → Sing A x =
|
||||
λ A x ⇒ (x, [δ _ ⇒ x])
|
||||
|
||||
namespace sing {
|
||||
|
||||
def val : 0.(A : ★) → 0.(x : A) → Sing A x → A =
|
||||
λ A _ sg ⇒
|
||||
case sg return A of { (x, eq) ⇒ case eq return A of { [_] ⇒ x } }
|
||||
|
||||
def0 proof : (A : ★) → (x : A) → (sg : Sing A x) → val A x sg ≡ x : A =
|
||||
λ A x sg ⇒
|
||||
case sg return sg' ⇒ val A x sg' ≡ x : A of { (x', eq) ⇒
|
||||
case eq return eq' ⇒ val A x (x', eq') ≡ x : A of { [eq'] ⇒ eq' }
|
||||
}
|
||||
|
||||
def app : 0.(A B : ★) → 0.(x : A) →
|
||||
(f : A → B) → Sing A x → Sing B (f x) =
|
||||
λ A B x f sg ⇒
|
||||
case sg return Sing B (f x) of { (x_, eq) ⇒
|
||||
case eq return Sing B (f x) of { [eq] ⇒ (f x_, [δ 𝑖 ⇒ f (eq @𝑖)]) }
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
@ -4,41 +4,72 @@ load "either.quox";
|
|||
|
||||
namespace nat {
|
||||
|
||||
def dup : 1.ℕ → [ω.ℕ] =
|
||||
def elim-0-1 :
|
||||
0.(P : ℕ → ★) →
|
||||
ω.(P 0) → ω.(P 1) →
|
||||
ω.(0.(n : ℕ) → P n → P (succ n)) →
|
||||
(n : ℕ) → P n =
|
||||
λ P p0 p1 ps n ⇒
|
||||
case n return n' ⇒ P n' of {
|
||||
zero ⇒ p0;
|
||||
succ n' ⇒
|
||||
case n' return n'' ⇒ P (succ n'') of {
|
||||
zero ⇒ p1;
|
||||
succ n'', IH ⇒ ps (succ n'') IH
|
||||
}
|
||||
}
|
||||
|
||||
#[compile-scheme "(lambda (n) (cons n 'erased))"]
|
||||
def dup! : (n : ℕ) → [ω. Sing ℕ n] =
|
||||
λ n ⇒
|
||||
case1 n return [ω.ℕ] of {
|
||||
zero ⇒ [zero];
|
||||
succ _, 1.d ⇒ case1 d return [ω.ℕ] of { [d] ⇒ [succ d] }
|
||||
case n return n' ⇒ [ω. Sing ℕ n'] of {
|
||||
zero ⇒ [(zero, [δ _ ⇒ zero])];
|
||||
succ n, d ⇒
|
||||
appω (Sing ℕ n) (Sing ℕ (succ n))
|
||||
(sing.app ℕ ℕ n (λ n ⇒ succ n)) d
|
||||
};
|
||||
|
||||
def plus : 1.ℕ → 1.ℕ → ℕ =
|
||||
def dup : ℕ → [ω.ℕ] =
|
||||
λ n ⇒ appω (Sing ℕ n) ℕ (sing.val ℕ n) (dup! n);
|
||||
|
||||
#[compile-scheme "(lambda% (m n) (+ m n))"]
|
||||
def plus : ℕ → ℕ → ℕ =
|
||||
λ m n ⇒
|
||||
case1 m return ℕ of {
|
||||
zero ⇒ n;
|
||||
succ _, 1.p ⇒ succ p
|
||||
case m return ℕ of {
|
||||
zero ⇒ n;
|
||||
succ _, p ⇒ succ p
|
||||
};
|
||||
|
||||
def timesω : 1.ℕ → ω.ℕ → ℕ =
|
||||
#[compile-scheme "(lambda% (m n) (* m n))"]
|
||||
def timesω : ℕ → ω.ℕ → ℕ =
|
||||
λ m n ⇒
|
||||
case1 m return ℕ of {
|
||||
zero ⇒ zero;
|
||||
succ _, 1.t ⇒ plus n t
|
||||
case m return ℕ of {
|
||||
zero ⇒ zero;
|
||||
succ _, t ⇒ plus n t
|
||||
};
|
||||
|
||||
def times : 1.ℕ → 1.ℕ → ℕ =
|
||||
λ m n ⇒ case1 dup n return ℕ of { [n] ⇒ timesω m n };
|
||||
def times : ℕ → ℕ → ℕ =
|
||||
λ m n ⇒ case dup n return ℕ of { [n] ⇒ timesω m n };
|
||||
|
||||
def pred : 1.ℕ → ℕ = λ n ⇒ case1 n return ℕ of { zero ⇒ zero; succ n ⇒ n };
|
||||
def pred : ℕ → ℕ = λ n ⇒ case n return ℕ of { zero ⇒ zero; succ n ⇒ n };
|
||||
|
||||
def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ =
|
||||
λ n ⇒ δ 𝑖 ⇒ n;
|
||||
|
||||
def0 succ-inj : 0.(m n : ℕ) → 0.(succ m ≡ succ n : ℕ) → m ≡ n : ℕ =
|
||||
def0 succ-inj : (m n : ℕ) → succ m ≡ succ n : ℕ → m ≡ n : ℕ =
|
||||
λ m n eq ⇒ δ 𝑖 ⇒ pred (eq @𝑖);
|
||||
|
||||
#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"]
|
||||
def minus : ℕ → ℕ → ℕ =
|
||||
λ m n ⇒
|
||||
(case n return ℕ → ℕ of {
|
||||
zero ⇒ λ m ⇒ m;
|
||||
succ _, f ⇒ λ m ⇒ f (pred m)
|
||||
}) m;
|
||||
|
||||
def0 IsSucc : 0.ℕ → ★ =
|
||||
λ n ⇒ caseω n return ★ of { zero ⇒ False; succ _ ⇒ True };
|
||||
|
||||
def0 IsSucc : ℕ → ★ =
|
||||
λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True };
|
||||
|
||||
def isSucc? : ω.(n : ℕ) → Dec (IsSucc n) =
|
||||
λ n ⇒
|
||||
|
@ -54,14 +85,15 @@ def succ-not-zero : 0.(m : ℕ) → Not (succ m ≡ zero : ℕ) =
|
|||
λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true;
|
||||
|
||||
|
||||
def0 not-succ-self : 0.(m : ℕ) → Not (m ≡ succ m : ℕ) =
|
||||
def0 not-succ-self : (m : ℕ) → Not (m ≡ succ m : ℕ) =
|
||||
λ m ⇒
|
||||
caseω m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
|
||||
case m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
|
||||
zero ⇒ zero-not-succ 0;
|
||||
succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq)
|
||||
}
|
||||
|
||||
|
||||
#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"]
|
||||
def eq? : DecEq ℕ =
|
||||
λ m ⇒
|
||||
caseω m
|
||||
|
@ -86,28 +118,48 @@ def eq? : DecEq ℕ =
|
|||
def eqb : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ dec.bool (m ≡ n : ℕ) (eq? m n);
|
||||
|
||||
|
||||
def0 plus-zero : 0.(m : ℕ) → m ≡ plus m 0 : ℕ =
|
||||
def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ =
|
||||
λ m ⇒
|
||||
caseω m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
|
||||
zero ⇒ δ _ ⇒ zero;
|
||||
succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
|
||||
case m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
|
||||
zero ⇒ δ _ ⇒ 0;
|
||||
succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
|
||||
};
|
||||
|
||||
def0 plus-succ : 0.(m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ =
|
||||
def0 plus-succ : (m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ =
|
||||
λ m n ⇒
|
||||
caseω m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : ℕ of {
|
||||
zero ⇒ δ _ ⇒ succ n;
|
||||
succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
|
||||
case m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : ℕ of {
|
||||
zero ⇒ δ _ ⇒ succ n;
|
||||
succ _, ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
|
||||
};
|
||||
|
||||
def0 plus-comm : 0.(m n : ℕ) → plus m n ≡ plus n m : ℕ =
|
||||
def0 plus-comm : (m n : ℕ) → plus m n ≡ plus n m : ℕ =
|
||||
λ m n ⇒
|
||||
caseω m return m' ⇒ plus m' n ≡ plus n m' : ℕ of {
|
||||
case m return m' ⇒ plus m' n ≡ plus n m' : ℕ of {
|
||||
zero ⇒ plus-zero n;
|
||||
succ m', ω.ih ⇒
|
||||
succ m', ih ⇒
|
||||
trans ℕ (succ (plus m' n)) (succ (plus n m')) (plus n (succ m'))
|
||||
(δ 𝑖 ⇒ succ (ih @𝑖))
|
||||
(plus-succ n m')
|
||||
};
|
||||
|
||||
def0 times-zero : (m : ℕ) → 0 ≡ timesω m 0 : ℕ =
|
||||
λ m ⇒
|
||||
case m return m' ⇒ 0 ≡ timesω m' 0 : ℕ of {
|
||||
zero ⇒ δ _ ⇒ zero;
|
||||
succ m', ih ⇒ ih
|
||||
};
|
||||
|
||||
{-
|
||||
-- unfinished
|
||||
def0 times-succ : (m n : ℕ) → plus m (timesω m n) ≡ timesω m (succ n) : ℕ =
|
||||
λ m n ⇒
|
||||
case m
|
||||
return m' ⇒ plus m' (timesω m' n) ≡ timesω m' (succ n) : ℕ
|
||||
of {
|
||||
zero ⇒ δ _ ⇒ 0;
|
||||
succ m', ih ⇒
|
||||
δ 𝑖 ⇒ plus (succ n) (ih @𝑖)
|
||||
};
|
||||
-}
|
||||
|
||||
}
|
||||
|
|
|
@ -1,55 +1,74 @@
|
|||
namespace pair {
|
||||
|
||||
def0 Σ : 0.(A : ★) → 0.(0.A → ★) → ★ = λ A B ⇒ (x : A) × B x;
|
||||
def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x;
|
||||
|
||||
def fst : 0.(A : ★) → 0.(B : 0.A → ★) → ω.(Σ A B) → A =
|
||||
{-
|
||||
-- now builtins
|
||||
def fst : 0.(A : ★) → 0.(B : A → ★) → ω.(Σ A B) → A =
|
||||
λ A B p ⇒ caseω p return A of { (x, _) ⇒ x };
|
||||
|
||||
def snd : 0.(A : ★) → 0.(B : 0.A → ★) → ω.(p : Σ A B) → B (fst A B p) =
|
||||
def snd : 0.(A : ★) → 0.(B : A → ★) → ω.(p : Σ A B) → B (fst A B p) =
|
||||
λ A B p ⇒ caseω p return p' ⇒ B (fst A B p') of { (_, y) ⇒ y };
|
||||
-}
|
||||
|
||||
def uncurry :
|
||||
0.(A : ★) → 0.(B : 0.A → ★) → 0.(C : 0.(x : A) → 0.(B x) → ★) →
|
||||
1.(f : 1.(x : A) → 1.(y : B x) → C x y) →
|
||||
1.(p : Σ A B) → C (fst A B p) (snd A B p) =
|
||||
0.(A : ★) → 0.(B : A → ★) → 0.(C : (x : A) → (B x) → ★) →
|
||||
(f : (x : A) → (y : B x) → C x y) →
|
||||
(p : Σ A B) → C (fst p) (snd p) =
|
||||
λ A B C f p ⇒
|
||||
case1 p return p' ⇒ C (fst A B p') (snd A B p') of { (x, y) ⇒ f x y };
|
||||
case p return p' ⇒ C (fst p') (snd p') of { (x, y) ⇒ f x y };
|
||||
|
||||
def uncurry' :
|
||||
0.(A B C : ★) → 1.(1.A → 1.B → C) → 1.(A × B) → C =
|
||||
0.(A B C : ★) → (A → B → C) → (A × B) → C =
|
||||
λ A B C ⇒ uncurry A (λ _ ⇒ B) (λ _ _ ⇒ C);
|
||||
|
||||
def curry :
|
||||
0.(A : ★) → 0.(B : 0.A → ★) → 0.(C : 0.(Σ A B) → ★) →
|
||||
1.(f : 1.(p : Σ A B) → C p) → 1.(x : A) → 1.(y : B x) → C (x, y) =
|
||||
0.(A : ★) → 0.(B : A → ★) → 0.(C : (Σ A B) → ★) →
|
||||
(f : (p : Σ A B) → C p) → (x : A) → (y : B x) → C (x, y) =
|
||||
λ A B C f x y ⇒ f (x, y);
|
||||
|
||||
def curry' :
|
||||
0.(A B C : ★) → 1.(1.(A × B) → C) → 1.A → 1.B → C =
|
||||
0.(A B C : ★) → (A × B → C) → A → B → C =
|
||||
λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C);
|
||||
|
||||
def0 fst-snd :
|
||||
0.(A : ★) → 0.(B : 0.A → ★) →
|
||||
1.(p : Σ A B) → p ≡ (fst A B p, snd A B p) : Σ A B =
|
||||
(A : ★) → (B : A → ★) →
|
||||
(p : Σ A B) → p ≡ (fst p, snd p) : Σ A B =
|
||||
λ A B p ⇒
|
||||
case1 p
|
||||
return p' ⇒ p' ≡ (fst A B p', snd A B p') : Σ A B
|
||||
case p
|
||||
return p' ⇒ p' ≡ (fst p', snd p') : Σ A B
|
||||
of { (x, y) ⇒ δ 𝑖 ⇒ (x, y) };
|
||||
|
||||
def0 fst-eq :
|
||||
(A : ★) → (B : A → ★) →
|
||||
(p q : Σ A B) → p ≡ q : Σ A B → fst p ≡ fst q : A =
|
||||
λ A B p q eq ⇒ δ 𝑖 ⇒ fst (eq @𝑖);
|
||||
|
||||
def0 snd-eq :
|
||||
(A : ★) → (B : A → ★) →
|
||||
(p q : Σ A B) → (eq : p ≡ q : Σ A B) →
|
||||
Eq (𝑖 ⇒ B (fst-eq A B p q eq @𝑖)) (snd p) (snd q) =
|
||||
λ A B p q eq ⇒ δ 𝑖 ⇒ snd (eq @𝑖);
|
||||
|
||||
def map :
|
||||
0.(A A' : ★) →
|
||||
0.(B : 0.A → ★) → 0.(B' : 0.A' → ★) →
|
||||
1.(f : 1.A → A') → 1.(g : 0.(x : A) → 1.(B x) → B' (f x)) →
|
||||
1.(Σ A B) → Σ A' B' =
|
||||
0.(B : A → ★) → 0.(B' : A' → ★) →
|
||||
(f : A → A') → (g : 0.(x : A) → (B x) → B' (f x)) →
|
||||
Σ A B → Σ A' B' =
|
||||
λ A A' B B' f g p ⇒
|
||||
case1 p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
|
||||
case p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
|
||||
|
||||
def map' : 0.(A A' B B' : ★) →
|
||||
1.(1.A → A') → 1.(1.B → B') → 1.(A × B) → A' × B' =
|
||||
def map' : 0.(A A' B B' : ★) → (A → A') → (B → B') → (A × B) → A' × B' =
|
||||
λ A A' B B' f g ⇒ map A A' (λ _ ⇒ B) (λ _ ⇒ B') f (λ _ ⇒ g);
|
||||
|
||||
def map-fst : 0.(A A' B : ★) → (A → A') → A × B → A' × B =
|
||||
λ A A' B f ⇒ map' A A' B B f (λ x ⇒ x);
|
||||
|
||||
def map-snd : 0.(A B B' : ★) → (B → B') → A × B → A × B' =
|
||||
λ A B B' f ⇒ map' A A B B' (λ x ⇒ x) f;
|
||||
|
||||
}
|
||||
|
||||
def0 Σ = pair.Σ;
|
||||
def fst = pair.fst;
|
||||
def snd = pair.snd;
|
||||
-- def fst = pair.fst;
|
||||
-- def snd = pair.snd;
|
||||
|
|
77
examples/qty.quox
Normal file
77
examples/qty.quox
Normal file
|
@ -0,0 +1,77 @@
|
|||
def0 Qty : ★ = {"zero", one, any}
|
||||
|
||||
def dup : Qty → [ω.Qty] =
|
||||
λ π ⇒ case π return [ω.Qty] of {
|
||||
'zero ⇒ ['zero];
|
||||
'one ⇒ ['one];
|
||||
'any ⇒ ['any];
|
||||
}
|
||||
|
||||
def drop : 0.(A : ★) → Qty → A → A =
|
||||
λ A π x ⇒ case π return A of {
|
||||
'zero ⇒ x;
|
||||
'one ⇒ x;
|
||||
'any ⇒ x;
|
||||
}
|
||||
|
||||
def if-zero : 0.(A : ★) → Qty → ω.A → ω.A → A =
|
||||
λ A π z nz ⇒
|
||||
case π return A of { 'zero ⇒ z; 'one ⇒ nz; 'any ⇒ nz }
|
||||
|
||||
def plus : Qty → Qty → Qty =
|
||||
λ π ρ ⇒
|
||||
case π return Qty of {
|
||||
'zero ⇒ ρ;
|
||||
'one ⇒ if-zero Qty ρ 'one 'any;
|
||||
'any ⇒ drop Qty ρ 'any;
|
||||
}
|
||||
|
||||
def times : Qty → Qty → Qty =
|
||||
λ π ρ ⇒
|
||||
case π return Qty of {
|
||||
'zero ⇒ drop Qty ρ 'zero;
|
||||
'one ⇒ ρ;
|
||||
'any ⇒ if-zero Qty ρ 'zero 'any;
|
||||
}
|
||||
|
||||
def0 FUN : Qty → (A : ★) → (A → ★) → ★ =
|
||||
λ π A B ⇒
|
||||
case π return ★ of {
|
||||
'zero ⇒ 0.(x : A) → B x;
|
||||
'one ⇒ 1.(x : A) → B x;
|
||||
'any ⇒ ω.(x : A) → B x;
|
||||
}
|
||||
|
||||
def0 Fun : Qty → ★ → ★ → ★ =
|
||||
λ π A B ⇒ FUN π A (λ _ ⇒ B)
|
||||
|
||||
def0 Box : Qty → ★ → ★ =
|
||||
λ π A ⇒
|
||||
case π return ★ of {
|
||||
'zero ⇒ [0.A];
|
||||
'one ⇒ [1.A];
|
||||
'any ⇒ [ω.A];
|
||||
}
|
||||
|
||||
def0 unbox : (π : Qty) → (A : ★) → Box π A → A =
|
||||
λ π A ⇒
|
||||
case π return π' ⇒ Box π' A → A of {
|
||||
'zero ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
|
||||
'one ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
|
||||
'any ⇒ λ x ⇒ case x return A of { [x] ⇒ x };
|
||||
}
|
||||
|
||||
def0 unbox0 = unbox 'zero
|
||||
def0 unbox1 = unbox 'one
|
||||
def0 unboxω = unbox 'any
|
||||
|
||||
def apply : (π : Qty) → 0.(A : ★) → 0.(B : A → ★) →
|
||||
FUN π A B → (x : Box π A) → B (unbox π A x) =
|
||||
λ π A B ⇒
|
||||
case π
|
||||
return π' ⇒ FUN π' A B → (x : Box π' A) → B (unbox π' A x)
|
||||
of {
|
||||
'zero ⇒ λ f x ⇒ case x return x' ⇒ B (unbox0 A x') of { [x] ⇒ f x };
|
||||
'one ⇒ λ f x ⇒ case x return x' ⇒ B (unbox1 A x') of { [x] ⇒ f x };
|
||||
'any ⇒ λ f x ⇒ case x return x' ⇒ B (unboxω A x') of { [x] ⇒ f x };
|
||||
}
|
164
exe/CompileMonad.idr
Normal file
164
exe/CompileMonad.idr
Normal file
|
@ -0,0 +1,164 @@
|
|||
module CompileMonad
|
||||
|
||||
import Quox.Syntax as Q
|
||||
import Quox.Definition as Q
|
||||
import Quox.Untyped.Syntax as U
|
||||
import Quox.Parser
|
||||
import Quox.Untyped.Erase
|
||||
import Quox.Untyped.Scheme
|
||||
import Quox.Pretty
|
||||
import Quox.Log
|
||||
import Options
|
||||
import Output
|
||||
import Error
|
||||
|
||||
import System.File
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Control.Eff
|
||||
|
||||
%default total
|
||||
|
||||
%hide Doc.(>>=)
|
||||
%hide Core.(>>=)
|
||||
|
||||
%hide FromParser.Error
|
||||
%hide Erase.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
|
||||
public export
|
||||
record State where
|
||||
constructor MkState
|
||||
seen : IORef SeenSet
|
||||
defs : IORef Q.Definitions
|
||||
ns : IORef Mods
|
||||
suf : IORef NameSuf
|
||||
%name CompileMonad.State state
|
||||
|
||||
export %inline
|
||||
newState : HasIO io => io State
|
||||
newState = pure $ MkState {
|
||||
seen = !(newIORef empty),
|
||||
defs = !(newIORef empty),
|
||||
ns = !(newIORef [<]),
|
||||
suf = !(newIORef 0)
|
||||
}
|
||||
|
||||
|
||||
public export
|
||||
data CompileTag = OPTS | STATE
|
||||
|
||||
public export
|
||||
Compile : List (Type -> Type)
|
||||
Compile =
|
||||
[Except Error,
|
||||
ReaderL STATE State, ReaderL OPTS Options, Log,
|
||||
LoadFile, IO]
|
||||
|
||||
|
||||
export %inline
|
||||
handleLog : IORef LevelStack -> OpenFile -> LogL x a -> IOErr Error a
|
||||
handleLog ref f l = case f of
|
||||
OConsole ch => handleLogIO (const $ pure ()) ref (consoleHandle ch) l
|
||||
OFile _ h => handleLogIO (const $ pure ()) ref h l
|
||||
ONone => do
|
||||
lvls <- readIORef ref
|
||||
lenRef <- newIORef (length lvls)
|
||||
res <- handleLogDiscardIO lenRef l
|
||||
writeIORef ref $ fixupDiscardedLog !(readIORef lenRef) lvls
|
||||
pure res
|
||||
|
||||
private %inline
|
||||
withLogFile : Options ->
|
||||
(IORef LevelStack -> OpenFile -> IO (Either Error a)) ->
|
||||
IO (Either Error a)
|
||||
withLogFile opts act = do
|
||||
lvlStack <- newIORef $ singleton opts.logLevels
|
||||
withOutFile CErr opts.logFile fromError $ act lvlStack
|
||||
where
|
||||
fromError : String -> FileError -> IO (Either Error a)
|
||||
fromError file err = pure $ Left $ WriteError file err
|
||||
|
||||
export covering %inline
|
||||
runCompile : Options -> State -> Eff Compile a -> IO (Either Error a)
|
||||
runCompile opts state act = do
|
||||
withLogFile opts $ \lvls, logFile =>
|
||||
fromIOErr $ runEff act $ with Union.(::)
|
||||
[handleExcept (\e => ioLeft e),
|
||||
handleReaderConst state,
|
||||
handleReaderConst opts,
|
||||
handleLog lvls logFile,
|
||||
handleLoadFileIOE loadError ParseError state.seen opts.include,
|
||||
liftIO]
|
||||
|
||||
private %inline
|
||||
rethrowFileC : String -> Either FileError a -> Eff Compile a
|
||||
rethrowFileC f = rethrow . mapFst (WriteError f)
|
||||
|
||||
|
||||
export %inline
|
||||
outputStr : OpenFile -> Lazy String -> Eff Compile ()
|
||||
outputStr ONone _ = pure ()
|
||||
outputStr (OConsole COut) str = putStr str
|
||||
outputStr (OConsole CErr) str = fPutStr stderr str >>= rethrowFileC "<stderr>"
|
||||
outputStr (OFile f h) str = fPutStr h str >>= rethrowFileC f
|
||||
|
||||
export %inline
|
||||
outputDocs : OpenFile ->
|
||||
({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) ->
|
||||
Eff Compile ()
|
||||
outputDocs file docs = do
|
||||
opts <- askAt OPTS
|
||||
for_ (runPretty opts (toOutFile file) docs) $ \x =>
|
||||
outputStr file $ render (Opts opts.width) x
|
||||
|
||||
export %inline
|
||||
outputDoc : OpenFile ->
|
||||
({opts : LayoutOpts} -> Eff Pretty (Doc opts)) -> Eff Compile ()
|
||||
outputDoc file doc = outputDocs file $ singleton <$> doc
|
||||
|
||||
|
||||
public export
|
||||
data StopTag = STOP
|
||||
|
||||
public export
|
||||
CompileStop : List (Type -> Type)
|
||||
CompileStop = FailL STOP :: Compile
|
||||
|
||||
export %inline
|
||||
withEarlyStop : Eff CompileStop () -> Eff Compile ()
|
||||
withEarlyStop = ignore . runFailAt STOP
|
||||
|
||||
export %inline
|
||||
stopHere : Has (FailL STOP) fs => Eff fs ()
|
||||
stopHere = failAt STOP
|
||||
|
||||
|
||||
export %inline
|
||||
liftFromParser : Eff FromParserIO a -> Eff Compile a
|
||||
liftFromParser act =
|
||||
runEff act $ with Union.(::)
|
||||
[handleExcept $ \err => throw $ FromParserError err,
|
||||
handleStateIORef !(asksAt STATE defs),
|
||||
handleStateIORef !(asksAt STATE ns),
|
||||
handleStateIORef !(asksAt STATE suf),
|
||||
\g => send g,
|
||||
\g => send g]
|
||||
|
||||
export %inline
|
||||
liftErase : Q.Definitions -> Eff Erase a -> Eff Compile a
|
||||
liftErase defs act =
|
||||
runEff act
|
||||
[handleExcept $ \err => throw $ EraseError err,
|
||||
handleStateIORef !(asksAt STATE suf),
|
||||
\g => send g]
|
||||
|
||||
export %inline
|
||||
liftScheme : Eff Scheme a -> Eff Compile (a, List Id)
|
||||
liftScheme act = do
|
||||
runEff [|MkPair act (getAt MAIN)|]
|
||||
[handleStateIORef !(newIORef empty),
|
||||
handleStateIORef !(newIORef [])]
|
49
exe/Error.idr
Normal file
49
exe/Error.idr
Normal file
|
@ -0,0 +1,49 @@
|
|||
module Error
|
||||
|
||||
import Quox.Pretty
|
||||
import Quox.Parser
|
||||
import Quox.Untyped.Erase
|
||||
import Quox.Untyped.Scheme
|
||||
import Options
|
||||
import Output
|
||||
|
||||
import System.File
|
||||
|
||||
|
||||
public export
|
||||
data Error =
|
||||
ParseError String Parser.Error
|
||||
| FromParserError FromParser.Error
|
||||
| EraseError Erase.Error
|
||||
| WriteError FilePath FileError
|
||||
| NoMain
|
||||
| MultipleMains (List Scheme.Id)
|
||||
|
||||
%hide FromParser.Error
|
||||
%hide Erase.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
export
|
||||
loadError : Loc -> FilePath -> FileError -> Error
|
||||
loadError loc file err = FromParserError $ LoadError loc file err
|
||||
|
||||
export
|
||||
prettyError : {opts : LayoutOpts} -> Error -> Eff Pretty (Doc opts)
|
||||
prettyError (ParseError file e) = prettyParseError file e
|
||||
prettyError (FromParserError e) = FromParser.prettyError True e
|
||||
prettyError (EraseError e) = Erase.prettyError True e
|
||||
prettyError NoMain = pure "no #[main] function given"
|
||||
prettyError (MultipleMains xs) =
|
||||
pure $ sep ["multiple #[main] functions given:",
|
||||
separateLoose "," !(traverse prettyId xs)]
|
||||
prettyError (WriteError file e) = pure $
|
||||
hangSingle 2 (text "couldn't write file \{file}:") (pshow e)
|
||||
|
||||
export
|
||||
dieError : Options -> Error -> IO a
|
||||
dieError opts e =
|
||||
die (Opts opts.width) $
|
||||
runPretty ({outFile := Console} opts) Console $
|
||||
prettyError e
|
131
exe/Main.idr
131
exe/Main.idr
|
@ -1,46 +1,118 @@
|
|||
module Main
|
||||
|
||||
import Quox.Syntax
|
||||
import Quox.Syntax as Q
|
||||
import Quox.Definition as Q
|
||||
import Quox.Untyped.Syntax as U
|
||||
import Quox.Parser
|
||||
import Quox.Definition
|
||||
import Quox.Untyped.Erase
|
||||
import Quox.Untyped.Scheme
|
||||
import Quox.Pretty
|
||||
import Quox.Log
|
||||
import Options
|
||||
import Output
|
||||
import Error
|
||||
import CompileMonad
|
||||
|
||||
import System
|
||||
import System.File
|
||||
import Data.IORef
|
||||
import Data.SortedSet
|
||||
import Control.Eff
|
||||
|
||||
private
|
||||
Opts : LayoutOpts
|
||||
Opts = Opts 80
|
||||
%default total
|
||||
|
||||
%hide Doc.(>>=)
|
||||
%hide Core.(>>=)
|
||||
|
||||
%hide FromParser.Error
|
||||
%hide Erase.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
private
|
||||
putDoc : Doc Opts -> IO ()
|
||||
putDoc = putStr . render Opts
|
||||
Step : Type -> Type -> Type
|
||||
Step a b = OpenFile -> a -> Eff Compile b
|
||||
|
||||
private
|
||||
die : Doc Opts -> IO a
|
||||
die err = do putDoc err; exitFailure
|
||||
step : ConsoleChannel -> Phase -> OutFile -> Step a b -> a -> Eff CompileStop b
|
||||
step console phase file act x = do
|
||||
opts <- askAt OPTS
|
||||
res <- withOutFile console file fromError $ \h => lift $ act h x
|
||||
when (opts.until == Just phase) stopHere
|
||||
pure res
|
||||
where
|
||||
fromError : String -> FileError -> Eff CompileStop c
|
||||
fromError file err = throw $ WriteError file err
|
||||
|
||||
private
|
||||
prettySig : {opts : _} -> Name -> Definition -> Eff Pretty (Doc opts)
|
||||
prettySig name def = do
|
||||
qty <- prettyQty def.qty.fst
|
||||
name <- prettyFree name
|
||||
type <- prettyTerm [<] [<] def.type
|
||||
hangDSingle (hsep [hcat [qty, !dotD, name], !colonD]) type
|
||||
|
||||
export
|
||||
private covering
|
||||
parse : Step String PFile
|
||||
parse h file = do
|
||||
Just ast <- loadFile noLoc file
|
||||
| Nothing => pure []
|
||||
outputStr h $ show ast
|
||||
pure ast
|
||||
|
||||
private covering
|
||||
check : Step PFile (List Q.NDefinition)
|
||||
check h decls =
|
||||
map concat $ for decls $ \decl => do
|
||||
defs <- liftFromParser $ fromPTopLevel decl
|
||||
outputDocs h $ traverse (\(x, d) => prettyDef x d) defs
|
||||
pure defs
|
||||
|
||||
private covering
|
||||
erase : Step (List Q.NDefinition) (List U.NDefinition)
|
||||
erase h defList =
|
||||
for defList $ \(x, def) => do
|
||||
def <- liftErase defs $ eraseDef defs x def
|
||||
outputDoc h $ U.prettyDef x def
|
||||
pure (x, def)
|
||||
where defs = SortedMap.fromList defList
|
||||
|
||||
private covering
|
||||
scheme : Step (List U.NDefinition) (List Sexp, List Id)
|
||||
scheme h defs = do
|
||||
sexps' <- for defs $ \(x, d) => do
|
||||
(msexp, mains) <- liftScheme $ defToScheme x d
|
||||
outputDoc h $ case msexp of
|
||||
Just s => prettySexp s
|
||||
Nothing => pure $ hsep [";;", prettyName x, "erased"]
|
||||
pure (msexp, mains)
|
||||
pure $ bimap catMaybes concat $ unzip sexps'
|
||||
|
||||
private covering
|
||||
output : Step (List Sexp, List Id) ()
|
||||
output h (sexps, mains) = do
|
||||
main <- case mains of
|
||||
[m] => pure m
|
||||
[] => throw NoMain
|
||||
_ => throw $ MultipleMains mains
|
||||
lift $ outputDocs h $ do
|
||||
res <- traverse prettySexp sexps
|
||||
runner <- makeRunMain main
|
||||
pure $ text Scheme.prelude :: res ++ [runner]
|
||||
|
||||
private covering
|
||||
processFile : String -> Eff Compile ()
|
||||
processFile file = withEarlyStop $ pipeline !(askAt OPTS) file where
|
||||
pipeline : Options -> String -> Eff CompileStop ()
|
||||
pipeline opts =
|
||||
step CErr Parse opts.dump.parse Main.parse >=>
|
||||
step CErr Check opts.dump.check Main.check >=>
|
||||
step CErr Erase opts.dump.erase Main.erase >=>
|
||||
step CErr Scheme opts.dump.scheme Main.scheme >=>
|
||||
step COut End opts.outFile Main.output
|
||||
|
||||
|
||||
export covering
|
||||
main : IO ()
|
||||
main = do
|
||||
seen <- newIORef SortedSet.empty
|
||||
defs <- newIORef SortedMap.empty
|
||||
suf <- newIORef $ the Nat 0
|
||||
for_ (drop 1 !getArgs) $ \file => do
|
||||
putStrLn "checking \{file}"
|
||||
Right res <- fromParserIO ["."] seen suf defs $ loadProcessFile noLoc file
|
||||
| Left err => die $ runPrettyColor $ prettyError True err
|
||||
for_ res $ \(name, def) => putDoc $ runPrettyColor $ prettySig name def
|
||||
(_, opts, files) <- options
|
||||
case !(runCompile opts !newState $ traverse_ processFile files) of
|
||||
Right () => pure ()
|
||||
Left e => dieError opts e
|
||||
|
||||
|
||||
-----------------------------------
|
||||
{-
|
||||
|
@ -55,6 +127,13 @@ text _ =
|
|||
#" /_/"#,
|
||||
""]
|
||||
|
||||
-- ["",
|
||||
-- #" __ _ _ _ _____ __"#,
|
||||
-- #"/ _` | || / _ \ \ /"#,
|
||||
-- #"\__, |\_,_\___/_\_\"#,
|
||||
-- #" |_|"#,
|
||||
-- ""]
|
||||
|
||||
private
|
||||
qtuwu : PrettyOpts -> List String
|
||||
qtuwu opts =
|
||||
|
|
258
exe/Options.idr
Normal file
258
exe/Options.idr
Normal file
|
@ -0,0 +1,258 @@
|
|||
module Options
|
||||
|
||||
import Quox.Pretty
|
||||
import Quox.Log
|
||||
import Data.DPair
|
||||
import Data.SortedMap
|
||||
import System
|
||||
import System.Console.GetOpt
|
||||
import System.File
|
||||
import System.Term
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
public export
|
||||
data OutFile = File String | Console | NoOut
|
||||
%name OutFile f
|
||||
%runElab derive "OutFile" [Eq, Show]
|
||||
|
||||
public export
|
||||
data Phase = Parse | Check | Erase | Scheme | End
|
||||
%name Phase p
|
||||
%runElab derive "Phase" [Eq, Show]
|
||||
|
||||
||| a list of all intermediate `Phase`s (excluding `End`)
|
||||
public export %inline
|
||||
allPhases : List Phase
|
||||
allPhases = %runElab do
|
||||
cs <- getCons $ fst !(lookupName "Phase")
|
||||
traverse (check . var) $ fromMaybe [] $ init' cs
|
||||
|
||||
||| `Guess` is `Term` for a terminal and `NoHL` for a file
|
||||
public export
|
||||
data HLType = Guess | NoHL | Term | Html
|
||||
%runElab derive "HLType" [Eq, Show]
|
||||
|
||||
public export
|
||||
record Dump where
|
||||
constructor MkDump
|
||||
parse, check, erase, scheme : OutFile
|
||||
%name Dump dump
|
||||
%runElab derive "Dump" [Show]
|
||||
|
||||
public export
|
||||
record Options where
|
||||
constructor MkOpts
|
||||
include : List String
|
||||
dump : Dump
|
||||
outFile : OutFile
|
||||
until : Maybe Phase
|
||||
hlType : HLType
|
||||
flavor : Pretty.Flavor
|
||||
width : Nat
|
||||
logLevels : LogLevels
|
||||
logFile : OutFile
|
||||
%name Options opts
|
||||
%runElab derive "Options" [Show]
|
||||
|
||||
export
|
||||
defaultWidth : IO Nat
|
||||
defaultWidth = do
|
||||
w <- cast {to = Nat} <$> getTermCols
|
||||
pure $ if w == 0 then 80 else w
|
||||
|
||||
export
|
||||
defaultOpts : IO Options
|
||||
defaultOpts = pure $ MkOpts {
|
||||
include = ["."],
|
||||
dump = MkDump NoOut NoOut NoOut NoOut,
|
||||
outFile = Console,
|
||||
until = Nothing,
|
||||
hlType = Guess,
|
||||
flavor = Unicode,
|
||||
width = !defaultWidth,
|
||||
logLevels = defaultLogLevels,
|
||||
logFile = Console
|
||||
}
|
||||
|
||||
private
|
||||
data HelpType = Common | All
|
||||
|
||||
private
|
||||
data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options)
|
||||
%name OptAction act
|
||||
|
||||
private
|
||||
toOutFile : String -> OutFile
|
||||
toOutFile "" = NoOut
|
||||
toOutFile "-" = Console
|
||||
toOutFile f = File f
|
||||
|
||||
private
|
||||
toPhase : String -> OptAction
|
||||
toPhase str =
|
||||
let lstr = toLower str in
|
||||
case find (\p => toLower (show p) == lstr) allPhases of
|
||||
Just p => Ok $ setPhase p
|
||||
Nothing => Err "unknown phase name \{show str}\nphases: \{phaseNames}"
|
||||
where
|
||||
phaseNames = joinBy ", " $ map (toLower . show) allPhases
|
||||
|
||||
defConsole : OutFile -> OutFile
|
||||
defConsole NoOut = Console
|
||||
defConsole f = f
|
||||
|
||||
setPhase : Phase -> Options -> Options
|
||||
setPhase Parse = {until := Just Parse, dump.parse $= defConsole}
|
||||
setPhase Check = {until := Just Check, dump.check $= defConsole}
|
||||
setPhase Erase = {until := Just Erase, dump.erase $= defConsole}
|
||||
setPhase Scheme = {until := Just Scheme, dump.scheme $= defConsole}
|
||||
setPhase End = id
|
||||
|
||||
private
|
||||
toWidth : String -> OptAction
|
||||
toWidth s = case parsePositive s of
|
||||
Just n => Ok {width := n}
|
||||
Nothing => Err "invalid width: \{show s}"
|
||||
|
||||
private
|
||||
toHLType : String -> OptAction
|
||||
toHLType str = case toLower str of
|
||||
"none" => Ok {hlType := NoHL}
|
||||
"term" => Ok {hlType := Term}
|
||||
"html" => Ok {hlType := Html}
|
||||
_ => Err "unknown highlighting type \{show str}\ntypes: term, html, none"
|
||||
|
||||
||| like ghc, `-i ""` clears the search path;
|
||||
||| `-i a:b:c` adds `a`, `b`, `c` to the end
|
||||
private
|
||||
dirListFlag : String -> List String -> List String
|
||||
dirListFlag "" val = []
|
||||
dirListFlag dirs val = val ++ toList (split (== ':') dirs)
|
||||
|
||||
private
|
||||
splitLogFlag : String -> Either String (List (Maybe LogCategory, LogLevel))
|
||||
splitLogFlag = traverse flag1 . toList . split (== ':') where
|
||||
parseLogCategory : String -> Either String LogCategory
|
||||
parseLogCategory cat = do
|
||||
let Just cat = toLogCategory cat
|
||||
| _ => let catList = joinBy ", " logCategories in
|
||||
Left "unknown log category. categories are:\n\{catList}"
|
||||
pure cat
|
||||
|
||||
parseLogLevel : String -> Either String LogLevel
|
||||
parseLogLevel lvl = do
|
||||
let Just lvl = parsePositive lvl
|
||||
| _ => Left "log level \{lvl} not a number"
|
||||
let Just lvl = toLogLevel lvl
|
||||
| _ => Left "log level \{show lvl} out of range 0–\{show maxLogLevel}"
|
||||
pure lvl
|
||||
|
||||
flag1 : String -> Either String (Maybe LogCategory, LogLevel)
|
||||
flag1 str = do
|
||||
let (first, second) = break (== '=') str
|
||||
case strM second of
|
||||
StrCons '=' lvl => do
|
||||
cat <- parseLogCategory first
|
||||
lvl <- parseLogLevel lvl
|
||||
pure (Just cat, lvl)
|
||||
StrNil => (Nothing,) <$> parseLogLevel first
|
||||
_ => Left "invalid log flag \{str}"
|
||||
|
||||
private
|
||||
setLogFlag : LogLevels -> (Maybe LogCategory, LogLevel) -> LogLevels
|
||||
setLogFlag lvls (Nothing, lvl) = {defLevel := lvl} lvls
|
||||
setLogFlag lvls (Just name, lvl) = {levels $= ((name, lvl) ::)} lvls
|
||||
|
||||
private
|
||||
logFlag : String -> OptAction
|
||||
logFlag str = case splitLogFlag str of
|
||||
Left err => Err err
|
||||
Right flags => Ok $ \o => {logLevels := foldl setLogFlag o.logLevels flags} o
|
||||
|
||||
private
|
||||
commonOptDescrs' : List (OptDescr OptAction)
|
||||
commonOptDescrs' = [
|
||||
MkOpt ['i'] ["include"]
|
||||
(ReqArg (\is => Ok {include $= dirListFlag is}) "<dir>:<dir>...")
|
||||
"add directories to look for source files",
|
||||
MkOpt ['o'] ["output"] (ReqArg (\s => Ok {outFile := toOutFile s}) "<file>")
|
||||
"output file (\"-\" for stdout, \"\" for no output)",
|
||||
MkOpt ['P'] ["phase"] (ReqArg toPhase "<phase>")
|
||||
"stop after the given phase",
|
||||
MkOpt ['l'] ["log"] (ReqArg logFlag "[<cat>=]<n>:...")
|
||||
"set log level",
|
||||
MkOpt ['L'] ["log-file"] (ReqArg (\s => Ok {logFile := toOutFile s}) "<file>")
|
||||
"set log output file"
|
||||
]
|
||||
|
||||
private
|
||||
extraOptDescrs : List (OptDescr OptAction)
|
||||
extraOptDescrs = [
|
||||
MkOpt [] ["unicode"] (NoArg $ Ok {flavor := Unicode})
|
||||
"use unicode syntax when printing (default)",
|
||||
MkOpt [] ["ascii"] (NoArg $ Ok {flavor := Ascii})
|
||||
"use ascii syntax when printing",
|
||||
MkOpt [] ["width"] (ReqArg toWidth "<width>")
|
||||
"max output width (defaults to terminal width)",
|
||||
MkOpt [] ["color", "colour"] (ReqArg toHLType "<type>")
|
||||
"select highlighting type",
|
||||
|
||||
MkOpt [] ["dump-parse"]
|
||||
(ReqArg (\s => Ok {dump.parse := toOutFile s}) "<file>")
|
||||
"dump AST",
|
||||
MkOpt [] ["dump-check"]
|
||||
(ReqArg (\s => Ok {dump.check := toOutFile s}) "<file>")
|
||||
"dump typechecker output",
|
||||
MkOpt [] ["dump-erase"]
|
||||
(ReqArg (\s => Ok {dump.erase := toOutFile s}) "<file>")
|
||||
"dump erasure output",
|
||||
MkOpt [] ["dump-scheme"]
|
||||
(ReqArg (\s => Ok {dump.scheme := toOutFile s}) "<file>")
|
||||
"dump scheme output (without prelude)"
|
||||
]
|
||||
|
||||
private
|
||||
helpOptDescrs : List (OptDescr OptAction)
|
||||
helpOptDescrs = [
|
||||
MkOpt ['h'] ["help"] (NoArg $ ShowHelp Common) "show common options",
|
||||
MkOpt [] ["help-all"] (NoArg $ ShowHelp All) "show all options"
|
||||
]
|
||||
|
||||
commonOptDescrs = commonOptDescrs' ++ helpOptDescrs
|
||||
allOptDescrs = commonOptDescrs' ++ extraOptDescrs ++ helpOptDescrs
|
||||
|
||||
export
|
||||
usageHeader : String
|
||||
usageHeader = trim """
|
||||
quox [options] [file.quox ...]
|
||||
rawr
|
||||
"""
|
||||
|
||||
export
|
||||
usage : List (OptDescr _) -> IO a
|
||||
usage ds = do
|
||||
ignore $ fPutStr stderr $ usageInfo usageHeader ds
|
||||
exitSuccess
|
||||
|
||||
private
|
||||
applyAction : Options -> OptAction -> IO Options
|
||||
applyAction opts (ShowHelp Common) = usage commonOptDescrs
|
||||
applyAction opts (ShowHelp All) = usage allOptDescrs
|
||||
applyAction opts (Err err) = die err
|
||||
applyAction opts (Ok f) = pure $ f opts
|
||||
|
||||
export
|
||||
options : IO (String, Options, List String)
|
||||
options = do
|
||||
app :: args <- getArgs
|
||||
| [] => die "couldn't get command line arguments"
|
||||
let res = getOpt Permute allOptDescrs args
|
||||
unless (null res.errors) $
|
||||
die $ trim $ concat res.errors
|
||||
unless (null res.unrecognized) $
|
||||
die "unrecognised options: \{joinBy ", " res.unrecognized}"
|
||||
opts <- foldlM applyAction !defaultOpts res.options
|
||||
pure (app, opts, res.nonOptions)
|
59
exe/Output.idr
Normal file
59
exe/Output.idr
Normal file
|
@ -0,0 +1,59 @@
|
|||
module Output
|
||||
|
||||
import Quox.Pretty
|
||||
import Options
|
||||
|
||||
import System.File
|
||||
import System
|
||||
|
||||
public export
|
||||
data ConsoleChannel = COut | CErr
|
||||
|
||||
export
|
||||
consoleHandle : ConsoleChannel -> File
|
||||
consoleHandle COut = stdout
|
||||
consoleHandle CErr = stderr
|
||||
|
||||
public export
|
||||
data OpenFile = OConsole ConsoleChannel | OFile String File | ONone
|
||||
|
||||
export
|
||||
toOutFile : OpenFile -> OutFile
|
||||
toOutFile (OConsole _) = Console
|
||||
toOutFile (OFile f _) = File f
|
||||
toOutFile ONone = NoOut
|
||||
|
||||
export
|
||||
withFile : HasIO m => String -> (String -> FileError -> m a) ->
|
||||
(OpenFile -> m a) -> m a
|
||||
withFile f catch act = Prelude.do
|
||||
res <- withFile f WriteTruncate pure (Prelude.map Right . act . OFile f)
|
||||
either (catch f) pure res
|
||||
|
||||
export
|
||||
withOutFile : HasIO m => ConsoleChannel -> OutFile ->
|
||||
(String -> FileError -> m a) -> (OpenFile -> m a) -> m a
|
||||
withOutFile _ (File f) catch act = withFile f catch act
|
||||
withOutFile ch Console catch act = act $ OConsole ch
|
||||
withOutFile _ NoOut catch act = act ONone
|
||||
|
||||
|
||||
|
||||
private
|
||||
hlFor : HLType -> OutFile -> HL -> Highlight
|
||||
hlFor Guess Console = highlightSGR
|
||||
hlFor Guess _ = noHighlight
|
||||
hlFor NoHL _ = noHighlight
|
||||
hlFor Term _ = highlightSGR
|
||||
hlFor Html _ = highlightHtml
|
||||
|
||||
export
|
||||
runPretty : Options -> OutFile -> Eff Pretty a -> a
|
||||
runPretty opts file act =
|
||||
runPrettyWith Outer opts.flavor (hlFor opts.hlType file) 2 act
|
||||
|
||||
export
|
||||
die : HasIO io => (opts : LayoutOpts) -> Doc opts -> io a
|
||||
die opts err = do
|
||||
ignore $ fPutStr stderr $ render opts err
|
||||
exitFailure
|
|
@ -1,7 +1,7 @@
|
|||
package quox
|
||||
version = 0
|
||||
|
||||
depends = base, contrib, elab-util, sop, quox-lib
|
||||
depends = base, contrib, elab-util, pretty-show, quox-lib
|
||||
|
||||
executable = quox
|
||||
main = Main
|
||||
|
|
15
golden-tests/Tests.idr
Normal file
15
golden-tests/Tests.idr
Normal file
|
@ -0,0 +1,15 @@
|
|||
module Tests
|
||||
|
||||
import Test.Golden
|
||||
import Language.Reflection
|
||||
import System
|
||||
import System.Path
|
||||
|
||||
%language ElabReflection
|
||||
|
||||
projDir = %runElab idrisDir ProjectDir
|
||||
testDir = projDir </> "tests"
|
||||
|
||||
tests = testsInDir { poolName = "quox golden tests", dirName = testDir }
|
||||
|
||||
main = runner [!tests]
|
4
golden-tests/quox-golden-tests.ipkg
Normal file
4
golden-tests/quox-golden-tests.ipkg
Normal file
|
@ -0,0 +1,4 @@
|
|||
package quox-golden-tests
|
||||
depends = quox, contrib, test
|
||||
executable = quox-golden-tests
|
||||
main = Tests
|
10
golden-tests/run-tests.sh
Executable file
10
golden-tests/run-tests.sh
Executable file
|
@ -0,0 +1,10 @@
|
|||
#!/bin/bash
|
||||
|
||||
set -e
|
||||
|
||||
quox="$PWD/../exe/build/exec/quox"
|
||||
run_tests="$PWD/build/exec/quox-golden-tests"
|
||||
test -f "$quox" || pack build quox
|
||||
test -f "$run_tests" || pack build quox-golden-tests
|
||||
|
||||
"$run_tests" "$quox" "$@"
|
0
golden-tests/tests/empty/empty.quox
Normal file
0
golden-tests/tests/empty/empty.quox
Normal file
0
golden-tests/tests/empty/expected
Normal file
0
golden-tests/tests/empty/expected
Normal file
2
golden-tests/tests/empty/run
Normal file
2
golden-tests/tests/empty/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
scheme "$1" empty.quox
|
33
golden-tests/tests/eta-singleton/eta-sing.quox
Normal file
33
golden-tests/tests/eta-singleton/eta-sing.quox
Normal file
|
@ -0,0 +1,33 @@
|
|||
-- inspired by https://github.com/agda/agda/issues/2556
|
||||
|
||||
postulate0 A : ★
|
||||
|
||||
def0 ZZ : ★ = 0 ≡ 0 : ℕ
|
||||
|
||||
def reflZ : ZZ = δ _ ⇒ 0
|
||||
|
||||
|
||||
namespace erased {
|
||||
def0 ZZA : ★ = 0.ZZ → A
|
||||
|
||||
def propeq : (x : ZZA) → x ≡ (λ _ ⇒ x reflZ) : ZZA =
|
||||
λ x ⇒ δ _ ⇒ x
|
||||
|
||||
def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
|
||||
λ P x p ⇒ p
|
||||
}
|
||||
|
||||
namespace unrestricted {
|
||||
def0 ZZA : ★ = ω.ZZ → A
|
||||
|
||||
def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
|
||||
λ P x p ⇒ p
|
||||
}
|
||||
|
||||
namespace linear {
|
||||
def0 ZZA : ★ = 1.ZZ → A
|
||||
|
||||
#[fail "λ _ ⇒ x reflZ is not equal to x"]
|
||||
def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x =
|
||||
λ P x p ⇒ p
|
||||
}
|
9
golden-tests/tests/eta-singleton/expected
Normal file
9
golden-tests/tests/eta-singleton/expected
Normal file
|
@ -0,0 +1,9 @@
|
|||
0.A : ★
|
||||
0.ZZ : ★
|
||||
ω.reflZ : ZZ
|
||||
0.erased.ZZA : ★
|
||||
ω.erased.propeq : 1.(x : erased.ZZA) → x ≡ (λ _ ⇒ x reflZ) : erased.ZZA
|
||||
ω.erased.defeq : 0.(P : 1.erased.ZZA → ★) → 0.(x : erased.ZZA) → 1.(P (λ _ ⇒ (x reflZ))) → P x
|
||||
0.unrestricted.ZZA : ★
|
||||
ω.unrestricted.defeq : 0.(P : 1.unrestricted.ZZA → ★) → 0.(x : unrestricted.ZZA) → 1.(P (λ _ ⇒ (x reflZ))) → P x
|
||||
0.linear.ZZA : ★
|
2
golden-tests/tests/eta-singleton/run
Normal file
2
golden-tests/tests/eta-singleton/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" eta-sing.quox
|
3
golden-tests/tests/file-not-found/expected
Normal file
3
golden-tests/tests/file-not-found/expected
Normal file
|
@ -0,0 +1,3 @@
|
|||
no location:
|
||||
couldn't load file nonexistent.quox
|
||||
File Not Found
|
2
golden-tests/tests/file-not-found/run
Normal file
2
golden-tests/tests/file-not-found/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" nonexistent.quox
|
12
golden-tests/tests/hello/expected
Normal file
12
golden-tests/tests/hello/expected
Normal file
|
@ -0,0 +1,12 @@
|
|||
0.IO : 1.★ → ★
|
||||
ω.print : 1.String → IO {ok}
|
||||
ω.main : IO {ok}
|
||||
IO = □
|
||||
print = scheme:(lambda (str) (builtin-io (display str) (newline)))
|
||||
#[main] main = print "hello 🐉"
|
||||
;; IO erased
|
||||
(define print
|
||||
(lambda (str) (builtin-io (display str) (newline))))
|
||||
(define main
|
||||
(print "hello \x1f409;"))
|
||||
hello 🐉
|
7
golden-tests/tests/hello/hello.quox
Normal file
7
golden-tests/tests/hello/hello.quox
Normal file
|
@ -0,0 +1,7 @@
|
|||
def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
|
||||
|
||||
#[compile-scheme "(lambda (str) (builtin-io (display str) (newline)))"]
|
||||
postulate print : String → IO {ok}
|
||||
|
||||
#[main]
|
||||
def main = print "hello 🐉"
|
2
golden-tests/tests/hello/run
Normal file
2
golden-tests/tests/hello/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
compile_run "$1" hello.quox hello.ss
|
3
golden-tests/tests/ill-typed-main/expected
Normal file
3
golden-tests/tests/ill-typed-main/expected
Normal file
|
@ -0,0 +1,3 @@
|
|||
ill-typed-main.quox:1:11-1:12:
|
||||
when checking a function declared as #[main] has type 1.IOState → {𝑎} × IOState
|
||||
expected a function type, but got ℕ
|
2
golden-tests/tests/ill-typed-main/ill-typed-main.quox
Normal file
2
golden-tests/tests/ill-typed-main/ill-typed-main.quox
Normal file
|
@ -0,0 +1,2 @@
|
|||
#[main]
|
||||
def main : ℕ = 5
|
2
golden-tests/tests/ill-typed-main/run
Normal file
2
golden-tests/tests/ill-typed-main/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" ill-typed-main.quox
|
2
golden-tests/tests/isprop-subsing/expected
Normal file
2
golden-tests/tests/isprop-subsing/expected
Normal file
|
@ -0,0 +1,2 @@
|
|||
0.IsProp : 1.★ → ★
|
||||
0.feq : 1.(A : ★) → 1.(f : IsProp A) → 1.(g : IsProp A) → f ≡ g : IsProp A
|
4
golden-tests/tests/isprop-subsing/isprop-subsing.quox
Normal file
4
golden-tests/tests/isprop-subsing/isprop-subsing.quox
Normal file
|
@ -0,0 +1,4 @@
|
|||
def0 IsProp : ★ → ★ = λ A ⇒ (x y : A) → x ≡ y : A
|
||||
|
||||
def0 feq : (A : ★) → (f g : IsProp A) → f ≡ g : IsProp A =
|
||||
λ A f g ⇒ δ _ ⇒ f
|
2
golden-tests/tests/isprop-subsing/run
Normal file
2
golden-tests/tests/isprop-subsing/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" isprop-subsing.quox
|
4
golden-tests/tests/it-5/expected
Normal file
4
golden-tests/tests/it-5/expected
Normal file
|
@ -0,0 +1,4 @@
|
|||
ω.five : ℕ
|
||||
five = 5
|
||||
(define five
|
||||
5)
|
1
golden-tests/tests/it-5/five.quox
Normal file
1
golden-tests/tests/it-5/five.quox
Normal file
|
@ -0,0 +1 @@
|
|||
def five : ℕ = 5
|
2
golden-tests/tests/it-5/run
Normal file
2
golden-tests/tests/it-5/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
scheme "$1" five.quox
|
18
golden-tests/tests/lib.sh
Normal file
18
golden-tests/tests/lib.sh
Normal file
|
@ -0,0 +1,18 @@
|
|||
FLAGS="--dump-check - --dump-erase - --dump-scheme - --color=none --width=100000"
|
||||
|
||||
check() {
|
||||
$1 $FLAGS "$2" -P check 2>&1
|
||||
}
|
||||
|
||||
erase() {
|
||||
$1 $FLAGS "$2" -P erase 2>&1
|
||||
}
|
||||
|
||||
scheme() {
|
||||
$1 $FLAGS "$2" -P scheme 2>&1
|
||||
}
|
||||
|
||||
compile_run() {
|
||||
$1 $FLAGS "$2" -o "$3" 2>&1
|
||||
chezscheme --program "$3"
|
||||
}
|
16
golden-tests/tests/load/expected
Normal file
16
golden-tests/tests/load/expected
Normal file
|
@ -0,0 +1,16 @@
|
|||
0.lib.IO : 1.★ → ★
|
||||
ω.lib.print : 1.String → lib.IO {ok}
|
||||
ω.lib.main : lib.IO {ok}
|
||||
ω.main : lib.IO {ok}
|
||||
lib.IO = □
|
||||
lib.print = scheme:(lambda (str) (builtin-io (display str) (newline)))
|
||||
lib.main = lib.print "hello 🐉"
|
||||
#[main] main = lib.main
|
||||
;; lib.IO erased
|
||||
(define lib.print
|
||||
(lambda (str) (builtin-io (display str) (newline))))
|
||||
(define lib.main
|
||||
(lib.print "hello \x1f409;"))
|
||||
(define main
|
||||
lib.main)
|
||||
hello 🐉
|
8
golden-tests/tests/load/lib.quox
Normal file
8
golden-tests/tests/load/lib.quox
Normal file
|
@ -0,0 +1,8 @@
|
|||
namespace lib {
|
||||
def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState
|
||||
|
||||
#[compile-scheme "(lambda (str) (builtin-io (display str) (newline)))"]
|
||||
postulate print : String → IO {ok}
|
||||
|
||||
def main = print "hello 🐉"
|
||||
}
|
4
golden-tests/tests/load/main.quox
Normal file
4
golden-tests/tests/load/main.quox
Normal file
|
@ -0,0 +1,4 @@
|
|||
load "lib.quox"
|
||||
|
||||
#[main]
|
||||
def main = lib.main
|
2
golden-tests/tests/load/run
Normal file
2
golden-tests/tests/load/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
compile_run "$1" main.quox load.ss
|
1
golden-tests/tests/regularity/expected
Normal file
1
golden-tests/tests/regularity/expected
Normal file
|
@ -0,0 +1 @@
|
|||
0.reggie : 1.(A : ★) → 1.(AA : A ≡ A : ★) → 1.(s : A) → 1.(P : 1.A → ★) → 1.(P (coe (𝑖 ⇒ AA @𝑖) @0 @1 s)) → P s
|
12
golden-tests/tests/regularity/regularity.quox
Normal file
12
golden-tests/tests/regularity/regularity.quox
Normal file
|
@ -0,0 +1,12 @@
|
|||
-- this definition depends on coercion regularity in xtt. which is this
|
||||
-- (adapted to quox):
|
||||
--
|
||||
-- Ψ | Γ ⊢ 0 · A‹0/𝑖› = A‹1/𝑖› ⇐ ★
|
||||
-- ---------------------------------------------------------
|
||||
-- Ψ | Γ ⊢ π · coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A‹1/𝑖›) ⇒ A‹1/𝑖›
|
||||
--
|
||||
-- otherwise, the types P (coe ⋯ s) and P s are incompatible
|
||||
|
||||
def0 reggie : (A : ★) → (AA : A ≡ A : ★) → (s : A) →
|
||||
(P : A → ★) → P (coe (𝑖 ⇒ AA @𝑖) s) → P s =
|
||||
λ A AA s P p ⇒ p
|
2
golden-tests/tests/regularity/run
Normal file
2
golden-tests/tests/regularity/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" regularity.quox
|
9
golden-tests/tests/useless-coe/coe.quox
Normal file
9
golden-tests/tests/useless-coe/coe.quox
Normal file
|
@ -0,0 +1,9 @@
|
|||
-- non-dependent coe should reduce to its body
|
||||
|
||||
def five : ℕ = 5
|
||||
def five? : ℕ = coe ℕ 5
|
||||
|
||||
def eq : five ≡ five? : ℕ = δ _ ⇒ 5
|
||||
|
||||
def subst1 : 0.(P : ℕ → ★) → P five → P five? = λ P p ⇒ p
|
||||
def subst2 : 0.(P : ℕ → ★) → P five? → P five = λ P p ⇒ p
|
5
golden-tests/tests/useless-coe/expected
Normal file
5
golden-tests/tests/useless-coe/expected
Normal file
|
@ -0,0 +1,5 @@
|
|||
ω.five : ℕ
|
||||
ω.five? : ℕ
|
||||
ω.eq : five ≡ five? : ℕ
|
||||
ω.subst1 : 0.(P : 1.ℕ → ★) → 1.(P five) → P five?
|
||||
ω.subst2 : 0.(P : 1.ℕ → ★) → 1.(P five?) → P five
|
2
golden-tests/tests/useless-coe/run
Normal file
2
golden-tests/tests/useless-coe/run
Normal file
|
@ -0,0 +1,2 @@
|
|||
. ../lib.sh
|
||||
check "$1" coe.quox
|
82
lib/Control/Monad/ST/Extra.idr
Normal file
82
lib/Control/Monad/ST/Extra.idr
Normal file
|
@ -0,0 +1,82 @@
|
|||
module Control.Monad.ST.Extra
|
||||
|
||||
import public Control.Monad.ST
|
||||
import Data.IORef
|
||||
import Control.MonadRec
|
||||
|
||||
%default total
|
||||
|
||||
export %inline
|
||||
MonadRec (ST s) where
|
||||
tailRecM seed (Access rec) st f = MkST $ do
|
||||
let MkST io = f seed st
|
||||
case !io of
|
||||
Done res => pure res
|
||||
Cont seed2 prf vst =>
|
||||
let MkST io = tailRecM seed2 (rec seed2 prf) vst f in io
|
||||
|
||||
|
||||
public export
|
||||
interface HasST (0 m : Type -> Type -> Type) where
|
||||
liftST : ST s a -> m s a
|
||||
|
||||
export %inline HasST ST where liftST = id
|
||||
|
||||
|
||||
public export
|
||||
record STErr e s a where
|
||||
constructor STE
|
||||
fromSTErr : ST s (Either e a)
|
||||
|
||||
export
|
||||
Functor (STErr e s) where
|
||||
map f (STE e) = STE $ map f <$> e
|
||||
|
||||
export
|
||||
Applicative (STErr e s) where
|
||||
pure x = STE $ pure $ pure x
|
||||
STE f <*> STE x = STE [|f <*> x|]
|
||||
|
||||
export
|
||||
Monad (STErr e s) where
|
||||
STE m >>= k = STE $ do
|
||||
case !m of
|
||||
Left err => pure $ Left err
|
||||
Right x => fromSTErr $ k x
|
||||
|
||||
export
|
||||
MonadRec (STErr e s) where
|
||||
tailRecM s (Access r) x k = STE $ do
|
||||
let STE m = k s x
|
||||
case !m of
|
||||
Left err => pure $ Left err
|
||||
Right (Cont s' p y) => fromSTErr $ tailRecM s' (r s' p) y k
|
||||
Right (Done y) => pure $ Right y
|
||||
|
||||
export
|
||||
runSTErr : (forall s. STErr e s a) -> Either e a
|
||||
runSTErr ste = runST $ fromSTErr ste
|
||||
|
||||
export %inline HasST (STErr e) where liftST = STE . map Right
|
||||
|
||||
export
|
||||
stLeft : e -> STErr e s a
|
||||
stLeft e = STE $ pure $ Left e
|
||||
|
||||
|
||||
parameters {auto _ : HasST m}
|
||||
export %inline
|
||||
newSTRef' : a -> m s (STRef s a)
|
||||
newSTRef' x = liftST $ newSTRef x
|
||||
|
||||
export %inline
|
||||
readSTRef' : STRef s a -> m s a
|
||||
readSTRef' r = liftST $ readSTRef r
|
||||
|
||||
export %inline
|
||||
writeSTRef' : STRef s a -> a -> m s ()
|
||||
writeSTRef' r x = liftST $ writeSTRef r x
|
||||
|
||||
export %inline
|
||||
modifySTRef' : STRef s a -> (a -> a) -> m s ()
|
||||
modifySTRef' r f = liftST $ modifySTRef r f
|
|
@ -3,8 +3,8 @@ module Quox.BoolExtra
|
|||
import public Data.Bool
|
||||
|
||||
|
||||
infixr 5 `andM`
|
||||
infixr 4 `orM`
|
||||
export infixr 5 `andM`
|
||||
export infixr 4 `orM`
|
||||
|
||||
public export
|
||||
andM, orM : Monad m => m Bool -> m Bool -> m Bool
|
||||
|
|
|
@ -166,3 +166,10 @@ isWhitespace ch = ch == '\t' || ch == '\r' || ch == '\n' || isSeparator ch
|
|||
export
|
||||
%foreign "scheme:string-normalize-nfc"
|
||||
normalizeNfc : String -> String
|
||||
|
||||
|
||||
export
|
||||
isCodepoint : Int -> Bool
|
||||
isCodepoint n =
|
||||
n <= 0x10FFFF &&
|
||||
not (n >= 0xD800 && n <= 0xDBFF || n >= 0xDC00 && n <= 0xDFFF)
|
||||
|
|
33
lib/Quox/CheckBuiltin.idr
Normal file
33
lib/Quox/CheckBuiltin.idr
Normal file
|
@ -0,0 +1,33 @@
|
|||
||| check that special functions (e.g. `main`) have the expected type
|
||||
module Quox.CheckBuiltin
|
||||
|
||||
import Quox.Syntax
|
||||
import Quox.Typing
|
||||
import Quox.Whnf
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
export covering
|
||||
expectSingleEnum : Definitions -> TyContext d n -> SQty -> Loc ->
|
||||
Term d n -> Eff Whnf ()
|
||||
expectSingleEnum defs ctx sg loc s = do
|
||||
let err = delay $ ExpectedSingleEnum loc ctx.names s
|
||||
cases <- wrapErr (const err) $ expectEnum defs ctx sg loc s
|
||||
unless (length (SortedSet.toList cases) == 1) $ throw err
|
||||
|
||||
||| `main` should have a type `1.IOState → {𝑎} × IOState`,
|
||||
||| for some (single) tag `𝑎`
|
||||
export covering
|
||||
expectMainType : Definitions -> Term 0 0 -> Eff Whnf ()
|
||||
expectMainType defs ty =
|
||||
wrapErr (WrongBuiltinType Main) $ do
|
||||
let ctx = TyContext.empty
|
||||
(qty, arg, res) <- expectPi defs ctx SZero ty.loc ty
|
||||
expectEqualQ ty.loc qty One
|
||||
expectIOState defs ctx SZero arg.loc arg
|
||||
let ctx = extendTy qty res.name arg ctx
|
||||
(ret, st) <- expectSig defs ctx SZero res.loc res.term
|
||||
expectSingleEnum defs ctx SZero ret.loc ret
|
||||
let ctx = extendTy qty st.name ret ctx
|
||||
expectIOState defs ctx SZero st.loc st.term
|
|
@ -6,16 +6,13 @@ import Quox.Name
|
|||
|
||||
import Data.DPair
|
||||
import Data.Nat
|
||||
import Data.Fin
|
||||
import Data.Singleton
|
||||
import Data.SnocList
|
||||
import Data.SnocVect
|
||||
import Data.Vect
|
||||
import Control.Monad.Identity
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
||| 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 = fst . unsnoc
|
||||
|
||||
|
||||
parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
|
||||
export
|
||||
toSnocListWith : Telescope tm _ _ -> SnocList a
|
||||
|
@ -87,13 +85,6 @@ export %inline
|
|||
toSnocList' : Telescope' a _ _ -> SnocList a
|
||||
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
|
||||
toList : Telescope tm _ _ -> List (Exists tm)
|
||||
toList = toListWith (Evidence _)
|
||||
|
@ -118,10 +109,17 @@ fromSnocVect [<] = [<]
|
|||
fromSnocVect (sx :< x) = fromSnocVect sx :< x
|
||||
|
||||
|
||||
public export
|
||||
tabulateLT : (n : Nat) -> ((i : Nat) -> (0 p : i `LT` n) => tm i) ->
|
||||
Context tm n
|
||||
tabulateLT 0 f = [<]
|
||||
tabulateLT (S k) f =
|
||||
tabulateLT k (\i => f i @{lteSuccRight %search}) :< f k @{reflexive}
|
||||
|
||||
public export
|
||||
tabulate : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
|
||||
tabulate f 0 = [<]
|
||||
tabulate f (S k) = tabulate f k :< f k
|
||||
tabulate f n = tabulateLT n (\i => f i)
|
||||
-- [todo] fixup argument order lol
|
||||
|
||||
public export
|
||||
replicate : (n : Nat) -> a -> Context' a n
|
||||
|
@ -147,34 +145,34 @@ tel ++ (sx :< x) = (tel ++ sx) :< x
|
|||
|
||||
public export
|
||||
getShiftWith : (forall from, to. tm from -> Shift from to -> tm to) ->
|
||||
Shift len out -> Context tm len -> Fin len -> tm out
|
||||
getShiftWith shft by (ctx :< t) FZ = t `shft` ssDown by
|
||||
getShiftWith shft by (ctx :< t) (FS i) = getShiftWith shft (ssDown by) ctx i
|
||||
Shift len out -> Context tm len -> Var len -> tm out
|
||||
getShiftWith shft by (ctx :< t) VZ = t `shft` ssDown by
|
||||
getShiftWith shft by (ctx :< t) (VS i) = getShiftWith shft (ssDown by) ctx i
|
||||
|
||||
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 (//)
|
||||
|
||||
public export %inline
|
||||
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
|
||||
|
||||
infixl 8 !!
|
||||
export infixl 8 !!
|
||||
public export %inline
|
||||
(!!) : CanShift tm => Context tm len -> Fin len -> tm len
|
||||
(!!) : CanShift tm => Context tm len -> Var len -> tm len
|
||||
(!!) = getWith (//)
|
||||
|
||||
infixl 8 !!!
|
||||
export infixl 8 !!!
|
||||
public export %inline
|
||||
(!!!) : Context' tm len -> Fin len -> tm
|
||||
(!!!) : Context' tm len -> Var len -> tm
|
||||
(!!!) = getWith const
|
||||
|
||||
public export
|
||||
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 (ctx :< x) = (guard (p x) $> FZ) <|> (FS <$> find p ctx)
|
||||
find p (ctx :< x) = (guard (p x) $> VZ) <|> (VS <$> find p ctx)
|
||||
|
||||
|
||||
export
|
||||
|
@ -191,6 +189,12 @@ export %hint
|
|||
succGT = LTESucc reflexive
|
||||
|
||||
|
||||
public export
|
||||
drop : (m : Nat) -> Context term (m + n) -> Context term n
|
||||
drop 0 ctx = ctx
|
||||
drop (S m) (ctx :< _) = drop m ctx
|
||||
|
||||
|
||||
parameters {auto _ : Applicative f}
|
||||
export
|
||||
traverse : (forall n. tm1 n -> f (tm2 n)) ->
|
||||
|
@ -202,7 +206,7 @@ parameters {auto _ : Applicative f}
|
|||
traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
|
||||
traverse' f = traverse f
|
||||
|
||||
infixl 3 `app`
|
||||
export infixl 3 `app`
|
||||
||| like `(<*>)` but with effects
|
||||
export
|
||||
app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
|
||||
|
@ -269,16 +273,17 @@ unzip3 (tel :< (x, y, z)) =
|
|||
|
||||
|
||||
public export
|
||||
lengthPrf : Telescope _ from to -> (len ** len + from = to)
|
||||
lengthPrf [<] = (0 ** Refl)
|
||||
lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
|
||||
lengthPrf [<] = Element 0 Refl
|
||||
lengthPrf (tel :< _) =
|
||||
let len = lengthPrf tel in (S len.fst ** cong S len.snd)
|
||||
let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
|
||||
|
||||
export
|
||||
lengthPrf0 : Context _ to -> (len ** len = to)
|
||||
lengthPrf0 : Context _ to -> Singleton to
|
||||
lengthPrf0 ctx =
|
||||
let len = lengthPrf ctx in
|
||||
(len.fst ** rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
|
||||
let Element len prf = lengthPrf ctx in
|
||||
rewrite sym prf `trans` plusZeroRightNeutral len in
|
||||
[|len|]
|
||||
|
||||
public export %inline
|
||||
length : Telescope {} -> Nat
|
||||
|
@ -297,6 +302,10 @@ foldl : {0 acc : Nat -> Type} ->
|
|||
foldl f z [<] = z
|
||||
foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
|
||||
|
||||
export %inline
|
||||
foldl_ : (acc -> tm -> acc) -> acc -> Telescope' tm from to -> acc
|
||||
foldl_ f z tel = foldl f z tel
|
||||
|
||||
export %inline
|
||||
foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
|
||||
foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
|
||||
|
@ -331,14 +340,6 @@ export %inline
|
|||
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}
|
||||
(nameHL : HL)
|
||||
(pterm : forall n. BContext n -> tm n -> Eff Pretty (Doc opts))
|
||||
|
@ -364,4 +365,4 @@ parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
|
|||
namespace BContext
|
||||
export
|
||||
toNames : BContext n -> SnocList BaseName
|
||||
toNames = foldl (\xs, x => xs :< x.name) [<]
|
||||
toNames = foldl (\xs, x => xs :< x.val) [<]
|
||||
|
|
|
@ -2,9 +2,12 @@ module Quox.Definition
|
|||
|
||||
import public Quox.No
|
||||
import public Quox.Syntax
|
||||
import Quox.Displace
|
||||
import public Data.SortedMap
|
||||
import public Quox.Loc
|
||||
import Quox.Pretty
|
||||
import Control.Eff
|
||||
import Data.Singleton
|
||||
import Decidable.Decidable
|
||||
|
||||
|
||||
|
@ -23,18 +26,24 @@ namespace DefBody
|
|||
public export
|
||||
record Definition where
|
||||
constructor MkDef
|
||||
qty : GQty
|
||||
type0 : Term 0 0
|
||||
body0 : DefBody
|
||||
loc_ : Loc
|
||||
qty : GQty
|
||||
type0 : Term 0 0
|
||||
body0 : DefBody
|
||||
scheme : Maybe String
|
||||
isMain : Bool
|
||||
loc_ : Loc
|
||||
|
||||
public export %inline
|
||||
mkPostulate : GQty -> (type0 : Term 0 0) -> Loc -> Definition
|
||||
mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_}
|
||||
mkPostulate : GQty -> (type0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
|
||||
Definition
|
||||
mkPostulate qty type0 scheme isMain loc_ =
|
||||
MkDef {qty, type0, body0 = Postulate, scheme, isMain, loc_}
|
||||
|
||||
public export %inline
|
||||
mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition
|
||||
mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, loc_}
|
||||
mkDef : GQty -> (type0, term0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
|
||||
Definition
|
||||
mkDef qty type0 term0 scheme isMain loc_ =
|
||||
MkDef {qty, type0, body0 = Concrete term0, scheme, isMain, loc_}
|
||||
|
||||
export Located Definition where def.loc = def.loc_
|
||||
export Relocatable Definition where setLoc loc = {loc_ := loc}
|
||||
|
@ -45,27 +54,51 @@ parameters {d, n : Nat}
|
|||
(.type) : Definition -> Term d n
|
||||
g.type = g.type0 // shift0 d // shift0 n
|
||||
|
||||
public export %inline
|
||||
(.typeAt) : Definition -> Universe -> Term d n
|
||||
g.typeAt u = displace u g.type
|
||||
|
||||
public export %inline
|
||||
(.term) : Definition -> Maybe (Term d n)
|
||||
g.term = g.body0.term0 <&> \t => t // shift0 d // shift0 n
|
||||
|
||||
public export %inline
|
||||
toElim : Definition -> Maybe $ Elim d n
|
||||
toElim def = pure $ Ann !def.term def.type def.loc
|
||||
(.termAt) : Definition -> Universe -> Maybe (Term d n)
|
||||
g.termAt u = displace u <$> g.term
|
||||
|
||||
public export %inline
|
||||
toElim : Definition -> Universe -> Maybe $ Elim d n
|
||||
toElim def u = pure $ Ann !(def.termAt u) (def.typeAt u) def.loc
|
||||
|
||||
public export
|
||||
(.typeWith) : Definition -> Singleton d -> Singleton n -> Term d n
|
||||
g.typeWith (Val d) (Val n) = g.type
|
||||
|
||||
public export
|
||||
(.typeWithAt) : Definition -> Singleton d -> Singleton n -> Universe -> Term d n
|
||||
g.typeWithAt d n u = displace u $ g.typeWith d n
|
||||
|
||||
public export
|
||||
(.termWith) : Definition -> Singleton d -> Singleton n -> Maybe (Term d n)
|
||||
g.termWith (Val d) (Val n) = g.term
|
||||
|
||||
|
||||
public export %inline
|
||||
isZero : Definition -> Bool
|
||||
isZero g = g.qty.fst == Zero
|
||||
isZero g = g.qty == GZero
|
||||
|
||||
|
||||
public export
|
||||
data DefEnvTag = DEFS
|
||||
NDefinition : Type
|
||||
NDefinition = (Name, Definition)
|
||||
|
||||
public export
|
||||
Definitions : Type
|
||||
Definitions = SortedMap Name Definition
|
||||
|
||||
public export
|
||||
data DefEnvTag = DEFS
|
||||
|
||||
public export
|
||||
DefsReader : Type -> Type
|
||||
DefsReader = ReaderL DEFS Definitions
|
||||
|
@ -74,7 +107,21 @@ public export
|
|||
DefsState : Type -> Type
|
||||
DefsState = StateL DEFS Definitions
|
||||
|
||||
public export %inline
|
||||
lookupElim : {d, n : Nat} -> Name -> Universe -> Definitions -> Maybe (Elim d n)
|
||||
lookupElim x u defs = toElim !(lookup x defs) u
|
||||
|
||||
public export %inline
|
||||
lookupElim : {d, n : Nat} -> Name -> Definitions -> Maybe (Elim d n)
|
||||
lookupElim x defs = toElim !(lookup x defs)
|
||||
lookupElim0 : Name -> Universe -> Definitions -> Maybe (Elim 0 0)
|
||||
lookupElim0 = lookupElim
|
||||
|
||||
|
||||
export
|
||||
prettyDef : {opts : LayoutOpts} -> Name -> Definition -> Eff Pretty (Doc opts)
|
||||
prettyDef name def = withPrec Outer $ do
|
||||
qty <- prettyQty def.qty.qty
|
||||
dot <- dotD
|
||||
name <- prettyFree name
|
||||
colon <- colonD
|
||||
type <- prettyTerm [<] [<] def.type
|
||||
hangDSingle (hsep [hcat [qty, dot, name], colon]) type
|
||||
|
|
|
@ -2,6 +2,8 @@ module Quox.Displace
|
|||
|
||||
import Quox.Syntax
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
parameters (k : Universe)
|
||||
namespace Term
|
||||
|
@ -14,6 +16,7 @@ parameters (k : Universe)
|
|||
|
||||
namespace Term
|
||||
doDisplace (TYPE l loc) = TYPE (k + l) loc
|
||||
doDisplace (IOState loc) = IOState loc
|
||||
doDisplace (Pi qty arg res loc) =
|
||||
Pi qty (doDisplace arg) (doDisplaceS res) loc
|
||||
doDisplace (Lam body loc) = Lam (doDisplaceS body) loc
|
||||
|
@ -24,14 +27,18 @@ parameters (k : Universe)
|
|||
doDisplace (Eq ty l r loc) =
|
||||
Eq (doDisplaceDS ty) (doDisplace l) (doDisplace r) loc
|
||||
doDisplace (DLam body loc) = DLam (doDisplaceDS body) loc
|
||||
doDisplace (Nat loc) = Nat loc
|
||||
doDisplace (Zero loc) = Zero loc
|
||||
doDisplace (NAT loc) = NAT loc
|
||||
doDisplace (Nat n loc) = Nat n loc
|
||||
doDisplace (Succ p loc) = Succ (doDisplace p) loc
|
||||
doDisplace (STRING loc) = STRING loc
|
||||
doDisplace (Str s loc) = Str s loc
|
||||
doDisplace (BOX qty ty loc) = BOX qty (doDisplace ty) loc
|
||||
doDisplace (Box val loc) = Box (doDisplace val) loc
|
||||
doDisplace (Let qty rhs body loc) =
|
||||
Let qty (doDisplace rhs) (doDisplaceS body) loc
|
||||
doDisplace (E e) = E (doDisplace e)
|
||||
doDisplace (CloT (Sub t th)) =
|
||||
CloT (Sub (doDisplace t) (map doDisplace th))
|
||||
CloT (Sub (doDisplace t) (assert_total $ map doDisplace th))
|
||||
doDisplace (DCloT (Sub t th)) =
|
||||
DCloT (Sub (doDisplace t) th)
|
||||
|
||||
|
@ -47,8 +54,11 @@ parameters (k : Universe)
|
|||
doDisplace (App fun arg loc) = App (doDisplace fun) (doDisplace arg) loc
|
||||
doDisplace (CasePair qty pair ret body loc) =
|
||||
CasePair qty (doDisplace pair) (doDisplaceS ret) (doDisplaceS body) loc
|
||||
doDisplace (Fst pair loc) = Fst (doDisplace pair) loc
|
||||
doDisplace (Snd pair loc) = Snd (doDisplace pair) loc
|
||||
doDisplace (CaseEnum qty tag ret arms loc) =
|
||||
CaseEnum qty (doDisplace tag) (doDisplaceS ret) (map doDisplace arms) loc
|
||||
CaseEnum qty (doDisplace tag) (doDisplaceS ret)
|
||||
(assert_total $ map doDisplace arms) loc
|
||||
doDisplace (CaseNat qty qtyIH nat ret zero succ loc) =
|
||||
CaseNat qty qtyIH (doDisplace nat) (doDisplaceS ret)
|
||||
(doDisplace zero) (doDisplaceS succ) loc
|
||||
|
@ -65,9 +75,9 @@ parameters (k : Universe)
|
|||
(doDisplaceDS zero) (doDisplaceDS one) loc
|
||||
doDisplace (TypeCase ty ret arms def loc) =
|
||||
TypeCase (doDisplace ty) (doDisplace ret)
|
||||
(map doDisplaceS arms) (doDisplace def) loc
|
||||
(assert_total $ map doDisplaceS arms) (doDisplace def) loc
|
||||
doDisplace (CloE (Sub e th)) =
|
||||
CloE (Sub (doDisplace e) (map doDisplace th))
|
||||
CloE (Sub (doDisplace e) (assert_total $ map doDisplace th))
|
||||
doDisplace (DCloE (Sub e th)) =
|
||||
DCloE (Sub (doDisplace e) th)
|
||||
|
||||
|
|
|
@ -2,6 +2,7 @@ module Quox.EffExtra
|
|||
|
||||
import public Control.Eff
|
||||
|
||||
import Control.Monad.ST.Extra
|
||||
import Data.IORef
|
||||
|
||||
|
||||
|
@ -26,48 +27,40 @@ local_ : Has (State s) fs => s -> Eff fs a -> Eff fs a
|
|||
local_ = localAt_ ()
|
||||
|
||||
|
||||
export
|
||||
hasDrop : (0 neq : Not (a = b)) ->
|
||||
(ha : Has a fs) => (hb : Has b fs) =>
|
||||
Has a (drop fs hb)
|
||||
hasDrop neq {ha = Z} {hb = Z} = void $ neq Refl
|
||||
hasDrop neq {ha = S ha} {hb = Z} = ha
|
||||
hasDrop neq {ha = Z} {hb = S hb} = Z
|
||||
hasDrop neq {ha = S ha} {hb = S hb} = S $ hasDrop neq {ha, hb}
|
||||
export %inline
|
||||
getsAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> a) -> Eff fs a
|
||||
getsAt lbl f = f <$> getAt lbl
|
||||
|
||||
export %inline
|
||||
gets : Has (State s) fs => (s -> a) -> Eff fs a
|
||||
gets = getsAt ()
|
||||
|
||||
|
||||
export %inline
|
||||
stateAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> (a, s)) -> Eff fs a
|
||||
stateAt lbl f = do (res, x) <- getsAt lbl f; putAt lbl x $> res
|
||||
|
||||
export %inline
|
||||
state : Has (State s) fs => (s -> (a, s)) -> Eff fs a
|
||||
state = stateAt ()
|
||||
|
||||
private
|
||||
0 ioNotState : Not (IO = StateL _ _)
|
||||
ioNotState Refl impossible
|
||||
|
||||
export
|
||||
runStateIORefAt : (0 lbl : tag) -> (Has IO fs, Has (StateL lbl s) fs) =>
|
||||
IORef s -> Eff fs a -> Eff (fs - StateL lbl s) a
|
||||
runStateIORefAt lbl ref act = do
|
||||
let hh : Has IO (fs - StateL lbl s) := hasDrop ioNotState
|
||||
(val, st) <- runStateAt lbl !(readIORef ref) act
|
||||
writeIORef ref st $> val
|
||||
|
||||
export %inline
|
||||
runStateIORef : (Has IO fs, Has (State s) fs) =>
|
||||
IORef s -> Eff fs a -> Eff (fs - State s) a
|
||||
runStateIORef = runStateIORefAt ()
|
||||
|
||||
|
||||
export %inline
|
||||
evalStateAt : (0 lbl : tag) -> Has (StateL lbl s) fs =>
|
||||
s -> Eff fs a -> Eff (fs - StateL lbl s) a
|
||||
evalStateAt lbl s act = map fst $ runStateAt lbl s act
|
||||
|
||||
export %inline
|
||||
evalState : Has (State s) fs => s -> Eff fs a -> Eff (fs - State s) a
|
||||
evalState = evalStateAt ()
|
||||
handleStateIORef : HasIO m => IORef st -> StateL lbl st a -> m a
|
||||
handleStateIORef r Get = readIORef r
|
||||
handleStateIORef r (Put s) = writeIORef r s
|
||||
|
||||
export
|
||||
handleStateSTRef : HasST m => STRef s st -> StateL lbl st a -> m s a
|
||||
handleStateSTRef r Get = liftST $ readSTRef r
|
||||
handleStateSTRef r (Put s) = liftST $ writeSTRef r s
|
||||
|
||||
|
||||
public export
|
||||
data Length : List a -> Type where
|
||||
Z : Length []
|
||||
S : Length xs -> Length (x :: xs)
|
||||
%builtin Natural Length
|
||||
|
||||
export
|
||||
subsetWith : Length xs => (forall z. Has z xs -> Has z ys) ->
|
||||
|
@ -80,23 +73,77 @@ subsetSelf : Length xs => Subset xs xs
|
|||
subsetSelf = subsetWith id
|
||||
|
||||
export
|
||||
subsetTail : Length xs => Subset xs (x :: xs)
|
||||
subsetTail = subsetWith S
|
||||
subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
|
||||
subsetTail _ = subsetWith S
|
||||
|
||||
|
||||
|
||||
-- [fixme] allow the error to be anywhere in the effect list
|
||||
export
|
||||
wrapErrAt : Length fs => (0 lbl : tag) -> (e -> e) ->
|
||||
Eff (ExceptL lbl e :: fs) a -> Eff (ExceptL lbl e :: fs) a
|
||||
wrapErrAt lbl f act =
|
||||
rethrowAt lbl . mapFst f =<< lift @{subsetTail} (runExceptAt lbl act)
|
||||
rethrowAtWith : (0 lbl : tag) -> Has (ExceptL lbl e') fs =>
|
||||
(e -> e') -> Either e a -> Eff fs a
|
||||
rethrowAtWith lbl f = rethrowAt lbl . mapFst f
|
||||
|
||||
export
|
||||
rethrowWith : Has (Except e') fs => (e -> e') -> Either e a -> Eff fs a
|
||||
rethrowWith = rethrowAtWith ()
|
||||
|
||||
export
|
||||
wrapErr : Length fs => (e -> e') ->
|
||||
Eff (ExceptL lbl e :: fs) a ->
|
||||
Eff (ExceptL lbl e' :: fs) a
|
||||
wrapErr f act =
|
||||
catchAt lbl (throwAt lbl . f) @{S Z} $
|
||||
lift @{subsetTail _} act
|
||||
|
||||
|
||||
export
|
||||
handleExcept : Functor m => (forall c. e -> m c) -> ExceptL lbl e a -> m a
|
||||
handleExcept thr (Err e) = thr e
|
||||
|
||||
|
||||
export
|
||||
handleReaderConst : Applicative m => r -> ReaderL lbl r a -> m a
|
||||
handleReaderConst x Ask = pure x
|
||||
|
||||
export
|
||||
handleWriterSTRef : HasST m => STRef s (SnocList w) -> WriterL lbl w a -> m s a
|
||||
handleWriterSTRef ref (Tell w) = liftST $ modifySTRef ref (:< w)
|
||||
|
||||
|
||||
public export
|
||||
record IOErr e a where
|
||||
constructor IOE
|
||||
fromIOErr : IO (Either e a)
|
||||
|
||||
export
|
||||
Functor (IOErr e) where
|
||||
map f (IOE e) = IOE $ map f <$> e
|
||||
|
||||
export
|
||||
Applicative (IOErr e) where
|
||||
pure x = IOE $ pure $ pure x
|
||||
IOE f <*> IOE x = IOE [|f <*> x|]
|
||||
|
||||
export
|
||||
Monad (IOErr e) where
|
||||
IOE m >>= k = IOE $ do
|
||||
case !m of
|
||||
Left err => pure $ Left err
|
||||
Right x => fromIOErr $ k x
|
||||
|
||||
export
|
||||
MonadRec (IOErr e) where
|
||||
tailRecM s (Access r) x k = IOE $ do
|
||||
let IOE m = k s x
|
||||
case !m of
|
||||
Left err => pure $ Left err
|
||||
Right (Cont s' p y) => fromIOErr $ tailRecM s' (r s' p) y k
|
||||
Right (Done y) => pure $ Right y
|
||||
|
||||
export
|
||||
HasIO (IOErr e) where
|
||||
liftIO = IOE . map Right
|
||||
|
||||
export %inline
|
||||
wrapErr : Length fs => (e -> e) ->
|
||||
Eff (Except e :: fs) a -> Eff (Except e :: fs) a
|
||||
wrapErr = wrapErrAt ()
|
||||
|
||||
|
||||
export %inline
|
||||
runIO : (MonadRec io, HasIO io) => Eff [IO] a -> io a
|
||||
runIO act = runEff act [liftIO]
|
||||
ioLeft : e -> IOErr e a
|
||||
ioLeft = IOE . pure . Left
|
||||
|
|
1362
lib/Quox/Equal.idr
1362
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
|
||||
module Quox.Loc
|
||||
|
||||
import Quox.PrettyValExtra
|
||||
import public Text.Bounded
|
||||
import Data.SortedMap
|
||||
import Derive.Prelude
|
||||
|
@ -12,12 +13,12 @@ public export
|
|||
FileName : Type
|
||||
FileName = String
|
||||
|
||||
%runElab derive "Bounds" [Ord]
|
||||
%runElab derive "Bounds" [Ord, PrettyVal]
|
||||
|
||||
public export
|
||||
data Loc_ = NoLoc | YesLoc FileName Bounds
|
||||
%name Loc_ loc
|
||||
%runElab derive "Loc_" [Eq, Ord, Show]
|
||||
%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
|
||||
||| a wrapper for locations which are always considered equal
|
||||
|
@ -39,6 +40,18 @@ public export %inline
|
|||
makeLoc : FileName -> Bounds -> Loc
|
||||
makeLoc = L .: YesLoc
|
||||
|
||||
public export %inline
|
||||
loc : FileName -> (sl, sc, el, ec : Int) -> Loc
|
||||
loc file sl sc el ec = makeLoc file $ MkBounds sl sc el ec
|
||||
|
||||
export
|
||||
PrettyVal Loc where
|
||||
prettyVal (L NoLoc) = Con "noLoc" []
|
||||
prettyVal (L (YesLoc file (MkBounds sl sc el ec))) =
|
||||
Con "loc" [prettyVal file,
|
||||
prettyVal sl, prettyVal sc,
|
||||
prettyVal el, prettyVal ec]
|
||||
|
||||
|
||||
export
|
||||
onlyStart_ : Loc_ -> Loc_
|
||||
|
@ -95,7 +108,7 @@ extendL : Loc -> Loc -> Loc
|
|||
extendL l1 l2 = l1 `extend'` l2.bounds
|
||||
|
||||
|
||||
infixr 1 `or_`, `or`
|
||||
export infixr 1 `or_`, `or`
|
||||
export %inline
|
||||
or_ : Loc_ -> Loc_ -> Loc_
|
||||
or_ l1@(YesLoc {}) _ = l1
|
||||
|
@ -105,6 +118,11 @@ export %inline
|
|||
or : Loc -> Loc -> Loc
|
||||
or (L l1) (L l2) = L $ l1 `or_` l2
|
||||
|
||||
export %inline
|
||||
extendOr : Loc -> Loc -> Loc
|
||||
extendOr l1 l2 = (l1 `extendL` l2) `or` l2
|
||||
|
||||
|
||||
|
||||
public export
|
||||
interface Located a where (.loc) : a -> Loc
|
||||
|
@ -113,9 +131,22 @@ public export
|
|||
0 Located1 : (a -> Type) -> Type
|
||||
Located1 f = forall x. Located (f x)
|
||||
|
||||
public export
|
||||
0 Located2 : (a -> b -> Type) -> Type
|
||||
Located2 f = forall x, y. Located (f x y)
|
||||
|
||||
public export
|
||||
interface Located a => Relocatable a where setLoc : Loc -> a -> a
|
||||
|
||||
public export
|
||||
0 Relocatable1 : (a -> Type) -> Type
|
||||
Relocatable1 f = forall x. Relocatable (f x)
|
||||
|
||||
public export
|
||||
0 Relocatable2 : (a -> b -> Type) -> Type
|
||||
Relocatable2 f = forall x, y. Relocatable (f x y)
|
||||
|
||||
|
||||
export
|
||||
locs : Located a => Foldable t => t a -> Loc
|
||||
locs = foldl (\loc, y => loc `extendOr` y.loc) noLoc
|
||||
|
|
317
lib/Quox/Log.idr
Normal file
317
lib/Quox/Log.idr
Normal file
|
@ -0,0 +1,317 @@
|
|||
module Quox.Log
|
||||
|
||||
import Quox.Loc
|
||||
import Quox.Pretty
|
||||
import Quox.PrettyValExtra
|
||||
|
||||
import Data.So
|
||||
import Data.DPair
|
||||
import Data.Maybe
|
||||
import Data.List1
|
||||
import Control.Eff
|
||||
import Control.Monad.ST.Extra
|
||||
import Data.IORef
|
||||
import System.File
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
public export %inline
|
||||
maxLogLevel : Nat
|
||||
maxLogLevel = 100
|
||||
|
||||
public export %inline
|
||||
logCategories : List String
|
||||
logCategories = ["whnf", "equal", "check"]
|
||||
|
||||
public export %inline
|
||||
isLogLevel : Nat -> Bool
|
||||
isLogLevel l = l <= maxLogLevel
|
||||
|
||||
public export
|
||||
IsLogLevel : Nat -> Type
|
||||
IsLogLevel l = So $ isLogLevel l
|
||||
|
||||
public export %inline
|
||||
isLogCategory : String -> Bool
|
||||
isLogCategory cat = cat `elem` logCategories
|
||||
|
||||
public export
|
||||
IsLogCategory : String -> Type
|
||||
IsLogCategory cat = So $ isLogCategory cat
|
||||
|
||||
-- Q: why are you using `So` instead of `LT` and `Elem`
|
||||
-- A: ① proof search gives up before finding a proof of e.g. ``99 `LT` 100``
|
||||
-- (i.e. `LTESucc⁹⁹ LTEZero`)
|
||||
-- ② the proofs aren't looked at in any way, i just wanted to make sure the
|
||||
-- list of categories was consistent everywhere
|
||||
|
||||
|
||||
||| a verbosity level from 0–100. higher is noisier. each log entry has a
|
||||
||| verbosity level above which it will be printed, chosen, uh, based on vibes.
|
||||
public export
|
||||
LogLevel : Type
|
||||
LogLevel = Subset Nat IsLogLevel
|
||||
|
||||
||| a logging category, like "check" (type checking), "whnf", or whatever.
|
||||
public export
|
||||
LogCategory : Type
|
||||
LogCategory = Subset String IsLogCategory
|
||||
|
||||
|
||||
public export %inline
|
||||
toLogLevel : Nat -> Maybe LogLevel
|
||||
toLogLevel l =
|
||||
case choose $ isLogLevel l of
|
||||
Left y => Just $ Element l y
|
||||
Right _ => Nothing
|
||||
|
||||
public export %inline
|
||||
toLogCategory : String -> Maybe LogCategory
|
||||
toLogCategory c =
|
||||
case choose $ isLogCategory c of
|
||||
Left y => Just $ Element c y
|
||||
Right _ => Nothing
|
||||
|
||||
|
||||
||| verbosity levels for each category, if they differ from the default
|
||||
public export
|
||||
LevelMap : Type
|
||||
LevelMap = List (LogCategory, LogLevel)
|
||||
|
||||
-- Q: why `List` instead of `SortedMap`
|
||||
-- A: oof ouch my constant factors (maybe this one was more obvious)
|
||||
|
||||
|
||||
public export
|
||||
record LogLevels where
|
||||
constructor MkLogLevels
|
||||
defLevel : LogLevel
|
||||
levels : LevelMap
|
||||
%name LogLevels lvls
|
||||
%runElab derive "LogLevels" [Eq, Show, PrettyVal]
|
||||
|
||||
public export
|
||||
LevelStack : Type
|
||||
LevelStack = List LogLevels
|
||||
|
||||
public export %inline
|
||||
defaultLevel : LogLevel
|
||||
defaultLevel = Element 0 Oh
|
||||
|
||||
export %inline
|
||||
defaultLogLevels : LogLevels
|
||||
defaultLogLevels = MkLogLevels defaultLevel []
|
||||
|
||||
export %inline
|
||||
initStack : LevelStack
|
||||
initStack = []
|
||||
|
||||
export %inline
|
||||
getLevel1 : LogCategory -> LogLevels -> LogLevel
|
||||
getLevel1 cat (MkLogLevels def lvls) = fromMaybe def $ lookup cat lvls
|
||||
|
||||
export %inline
|
||||
getLevel : LogCategory -> LevelStack -> LogLevel
|
||||
getLevel cat (lvls :: _) = getLevel1 cat lvls
|
||||
getLevel cat [] = defaultLevel
|
||||
|
||||
export %inline
|
||||
getCurLevels : LevelStack -> LogLevels
|
||||
getCurLevels (lvls :: _) = lvls
|
||||
getCurLevels [] = defaultLogLevels
|
||||
|
||||
|
||||
public export
|
||||
LogDoc : Type
|
||||
LogDoc = Doc (Opts {lineLength = 80})
|
||||
|
||||
|
||||
private %inline
|
||||
replace : Eq a => a -> b -> List (a, b) -> List (a, b)
|
||||
replace k v kvs = (k, v) :: filter (\y => fst y /= k) kvs
|
||||
|
||||
private %inline
|
||||
mergeLeft : Eq a => List (a, b) -> List (a, b) -> List (a, b)
|
||||
mergeLeft l r = foldl (\lst, (k, v) => replace k v lst) r l
|
||||
|
||||
|
||||
public export
|
||||
data PushArg =
|
||||
SetDefault LogLevel
|
||||
| SetCat LogCategory LogLevel
|
||||
| SetAll LogLevel
|
||||
%runElab derive "PushArg" [Eq, Ord, Show, PrettyVal]
|
||||
%name PushArg push
|
||||
|
||||
export %inline
|
||||
applyPush : LogLevels -> PushArg -> LogLevels
|
||||
applyPush lvls (SetDefault def) = {defLevel := def} lvls
|
||||
applyPush lvls (SetCat cat lvl) = {levels $= replace cat lvl} lvls
|
||||
applyPush lvls (SetAll lvl) = MkLogLevels lvl []
|
||||
|
||||
export %inline
|
||||
fromPush : PushArg -> LogLevels
|
||||
fromPush = applyPush defaultLogLevels
|
||||
|
||||
|
||||
public export
|
||||
record LogMsg where
|
||||
constructor (:>)
|
||||
level : Nat
|
||||
{auto 0 levelOk : IsLogLevel level}
|
||||
message : Lazy LogDoc
|
||||
export infix 0 :>
|
||||
%name Log.LogMsg msg
|
||||
|
||||
public export
|
||||
data LogL : (lbl : tag) -> Type -> Type where
|
||||
||| print some log messages
|
||||
SayMany : (cat : LogCategory) -> (loc : Loc) ->
|
||||
(msgs : List LogMsg) -> LogL lbl ()
|
||||
||| set some verbosity levels
|
||||
Push : (push : List PushArg) -> LogL lbl ()
|
||||
||| restore the previous verbosity levels.
|
||||
||| returns False if the stack was already empty
|
||||
Pop : LogL lbl Bool
|
||||
||| returns the current verbosity levels
|
||||
CurLevels : LogL lbl LogLevels
|
||||
|
||||
public export
|
||||
Log : Type -> Type
|
||||
Log = LogL ()
|
||||
|
||||
parameters (0 lbl : tag) {auto _ : Has (LogL lbl) fs}
|
||||
public export %inline
|
||||
sayManyAt : (cat : String) -> (0 catOk : IsLogCategory cat) =>
|
||||
Loc -> List LogMsg -> Eff fs ()
|
||||
sayManyAt cat loc msgs {catOk} =
|
||||
send $ SayMany {lbl} (Element cat catOk) loc msgs
|
||||
|
||||
public export %inline
|
||||
sayAt : (cat : String) -> (0 catOk : IsLogCategory cat) =>
|
||||
(lvl : Nat) -> (0 lvlOk : IsLogLevel lvl) =>
|
||||
Loc -> Lazy LogDoc -> Eff fs ()
|
||||
sayAt cat lvl loc msg = sayManyAt cat loc [lvl :> msg]
|
||||
|
||||
public export %inline
|
||||
pushAt : List PushArg -> Eff fs ()
|
||||
pushAt lvls = send $ Push {lbl} lvls
|
||||
|
||||
public export %inline
|
||||
push1At : PushArg -> Eff fs ()
|
||||
push1At lvl = pushAt [lvl]
|
||||
|
||||
public export %inline
|
||||
popAt : Eff fs Bool
|
||||
popAt = send $ Pop {lbl}
|
||||
|
||||
public export %inline
|
||||
curLevelsAt : Eff fs LogLevels
|
||||
curLevelsAt = send $ CurLevels {lbl}
|
||||
|
||||
parameters {auto _ : Has Log fs}
|
||||
public export %inline
|
||||
sayMany : (cat : String) -> (0 catOk : IsLogCategory cat) =>
|
||||
Loc -> List LogMsg -> Eff fs ()
|
||||
sayMany = sayManyAt ()
|
||||
|
||||
public export %inline
|
||||
say : (cat : String) -> (0 _ : IsLogCategory cat) =>
|
||||
(lvl : Nat) -> (0 _ : IsLogLevel lvl) =>
|
||||
Loc -> Lazy LogDoc -> Eff fs ()
|
||||
say = sayAt ()
|
||||
|
||||
public export %inline
|
||||
push : List PushArg -> Eff fs ()
|
||||
push = pushAt ()
|
||||
|
||||
public export %inline
|
||||
push1 : PushArg -> Eff fs ()
|
||||
push1 = push1At ()
|
||||
|
||||
public export %inline
|
||||
pop : Eff fs Bool
|
||||
pop = popAt ()
|
||||
|
||||
public export %inline
|
||||
curLevels : Eff fs LogLevels
|
||||
curLevels = curLevelsAt ()
|
||||
|
||||
|
||||
||| handles a `Log` effect with an existing `State` and `Writer`
|
||||
export %inline
|
||||
handleLogSW : (0 s : ts) -> (0 w : tw) ->
|
||||
Has (StateL s LevelStack) fs => Has (WriterL w LogDoc) fs =>
|
||||
LogL tag a -> Eff fs a
|
||||
handleLogSW s w = \case
|
||||
Push push => modifyAt s $ \lst =>
|
||||
foldl applyPush (fromMaybe defaultLogLevels (head' lst)) push :: lst
|
||||
Pop => stateAt s $ maybe (False, []) (True,) . tail'
|
||||
SayMany cat loc msgs => do
|
||||
catLvl <- getsAt s $ fst . getLevel cat
|
||||
let loc = runPretty $ prettyLoc loc
|
||||
for_ msgs $ \(lvl :> msg) => when (lvl <= catLvl) $ tellAt w $
|
||||
hcat [loc, text cat.fst, "@", pshow lvl, ":"] <++> msg
|
||||
CurLevels =>
|
||||
getsAt s getCurLevels
|
||||
|
||||
export %inline
|
||||
handleLogSW_ : LogL tag a -> Eff [State LevelStack, Writer LogDoc] a
|
||||
handleLogSW_ = handleLogSW () ()
|
||||
|
||||
export %inline
|
||||
handleLogIO : HasIO m => MonadRec m =>
|
||||
(FileError -> m ()) -> IORef LevelStack -> File ->
|
||||
LogL tag a -> m a
|
||||
handleLogIO th lvls h act =
|
||||
runEff (handleLogSW_ act) [handleStateIORef lvls, handleWriter {m} printMsg]
|
||||
where printMsg : LogDoc -> m ()
|
||||
printMsg msg = fPutStr h (render _ msg) >>= either th pure
|
||||
|
||||
export %inline
|
||||
handleLogST : HasST m => MonadRec (m s) =>
|
||||
STRef s (SnocList LogDoc) -> STRef s LevelStack ->
|
||||
LogL tag a -> m s a
|
||||
handleLogST docs lvls act =
|
||||
runEff (handleLogSW_ act) [handleStateSTRef lvls, handleWriterSTRef docs]
|
||||
|
||||
export %inline
|
||||
handleLogDiscard : (0 s : ts) -> Has (StateL s Nat) fs =>
|
||||
LogL tag a -> Eff fs a
|
||||
handleLogDiscard s = \case
|
||||
Push _ => modifyAt s S
|
||||
Pop => stateAt s $ \k => (k > 0, pred k)
|
||||
SayMany {} => pure ()
|
||||
CurLevels => pure defaultLogLevels
|
||||
|
||||
export %inline
|
||||
handleLogDiscard_ : LogL tag a -> Eff [State Nat] a
|
||||
handleLogDiscard_ = handleLogDiscard ()
|
||||
|
||||
export %inline
|
||||
handleLogDiscardST : HasST m => MonadRec (m s) => STRef s Nat ->
|
||||
LogL tag a -> m s a
|
||||
handleLogDiscardST ref act =
|
||||
runEff (handleLogDiscard_ act) [handleStateSTRef ref]
|
||||
|
||||
export %inline
|
||||
handleLogDiscardIO : HasIO m => MonadRec m => IORef Nat ->
|
||||
LogL tag a -> m a
|
||||
handleLogDiscardIO ref act =
|
||||
runEff (handleLogDiscard_ act) [handleStateIORef ref]
|
||||
|
||||
|
||||
||| approximate the push/pop effects in a discarded log by trimming a stack or
|
||||
||| repeating its most recent element
|
||||
export %inline
|
||||
fixupDiscardedLog : Nat -> LevelStack -> LevelStack
|
||||
fixupDiscardedLog want lvls =
|
||||
let len = length lvls in
|
||||
case compare len want of
|
||||
EQ => lvls
|
||||
GT => drop (len `minus` want) lvls
|
||||
LT => let new = fromMaybe defaultLogLevels $ head' lvls in
|
||||
replicate (want `minus` len) new ++ lvls
|
|
@ -2,6 +2,7 @@ module Quox.Name
|
|||
|
||||
import Quox.Loc
|
||||
import Quox.CharExtra
|
||||
import Quox.PrettyValExtra
|
||||
import public Data.SnocList
|
||||
import Data.List
|
||||
import Control.Eff
|
||||
|
@ -23,7 +24,7 @@ data BaseName
|
|||
= UN String -- user-given name
|
||||
| MN String NameSuf -- machine-generated name
|
||||
| Unused -- "_"
|
||||
%runElab derive "BaseName" [Eq, Ord]
|
||||
%runElab derive "BaseName" [Eq, Ord, PrettyVal]
|
||||
|
||||
export
|
||||
baseStr : BaseName -> String
|
||||
|
@ -42,14 +43,14 @@ Mods = SnocList String
|
|||
|
||||
public export
|
||||
record Name where
|
||||
constructor MakeName
|
||||
constructor MkName
|
||||
mods : Mods
|
||||
base : BaseName
|
||||
%runElab derive "Name" [Eq, Ord]
|
||||
|
||||
public export %inline
|
||||
unq : BaseName -> Name
|
||||
unq = MakeName [<]
|
||||
unq = MkName [<]
|
||||
|
||||
||| add some namespaces to the beginning of a name
|
||||
public export %inline
|
||||
|
@ -63,31 +64,31 @@ PBaseName = String
|
|||
|
||||
public export
|
||||
record PName where
|
||||
constructor MakePName
|
||||
constructor MkPName
|
||||
mods : Mods
|
||||
base : PBaseName
|
||||
%runElab derive "PName" [Eq, Ord]
|
||||
%runElab derive "PName" [Eq, Ord, PrettyVal]
|
||||
|
||||
export %inline
|
||||
fromPName : PName -> Name
|
||||
fromPName p = MakeName p.mods $ UN p.base
|
||||
fromPName p = MkName p.mods $ UN p.base
|
||||
|
||||
export %inline
|
||||
toPName : Name -> PName
|
||||
toPName p = MakePName p.mods $ baseStr p.base
|
||||
toPName p = MkPName p.mods $ baseStr p.base
|
||||
|
||||
export %inline
|
||||
fromPBaseName : PBaseName -> Name
|
||||
fromPBaseName = MakeName [<] . UN
|
||||
fromPBaseName = MkName [<] . UN
|
||||
|
||||
export
|
||||
Show PName where
|
||||
show (MakePName mods base) =
|
||||
show (MkPName mods base) =
|
||||
show $ concat $ intersperse "." $ toList $ mods :< base
|
||||
|
||||
export Show Name where show = show . toPName
|
||||
|
||||
export FromString PName where fromString = MakePName [<]
|
||||
export FromString PName where fromString = MkPName [<]
|
||||
|
||||
export FromString Name where fromString = fromPBaseName
|
||||
|
||||
|
@ -95,9 +96,9 @@ export FromString Name where fromString = fromPBaseName
|
|||
public export
|
||||
record BindName where
|
||||
constructor BN
|
||||
name : BaseName
|
||||
val : BaseName
|
||||
loc_ : Loc
|
||||
%runElab derive "BindName" [Eq, Ord, Show]
|
||||
%runElab derive "BindName" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export Located BindName where n.loc = n.loc_
|
||||
export Relocatable BindName where setLoc loc (BN x _) = BN x loc
|
||||
|
@ -115,7 +116,7 @@ export
|
|||
fromListP : List1 String -> PName
|
||||
fromListP (x ::: xs) = go [<] x xs where
|
||||
go : SnocList String -> String -> List String -> PName
|
||||
go mods x [] = MakePName mods x
|
||||
go mods x [] = MkPName mods x
|
||||
go mods x (y :: ys) = go (mods :< x) y ys
|
||||
|
||||
export %inline
|
||||
|
@ -169,14 +170,6 @@ public export
|
|||
NameGen : Type -> Type
|
||||
NameGen = StateL GEN NameSuf
|
||||
|
||||
export
|
||||
runNameGenWith : Has NameGen fs =>
|
||||
NameSuf -> Eff fs a -> Eff (fs - NameGen) (a, NameSuf)
|
||||
runNameGenWith = runStateAt GEN
|
||||
|
||||
export
|
||||
runNameGen : Has NameGen fs => Eff fs a -> Eff (fs - NameGen) a
|
||||
runNameGen = map fst . runNameGenWith 0
|
||||
|
||||
||| generate a fresh name with the given base
|
||||
export
|
||||
|
@ -186,15 +179,13 @@ mn base = do
|
|||
modifyAt GEN S
|
||||
pure $ MN base i
|
||||
|
||||
||| generate a fresh binding name with the given base and
|
||||
||| (optionally) location `loc`
|
||||
||| generate a fresh binding name with the given base and location `loc`
|
||||
export
|
||||
mnb : Has NameGen fs =>
|
||||
PBaseName -> {default noLoc loc : Loc} -> Eff fs BindName
|
||||
mnb base = pure $ BN !(mn base) loc
|
||||
mnb : Has NameGen fs => PBaseName -> Loc -> Eff fs BindName
|
||||
mnb base loc = pure $ BN !(mn base) loc
|
||||
|
||||
export
|
||||
fresh : Has NameGen fs => BindName -> Eff fs BindName
|
||||
fresh (BN (UN str) loc) = mnb str {loc}
|
||||
fresh (BN (MN str k) loc) = mnb str {loc}
|
||||
fresh (BN Unused loc) = mnb "x" {loc}
|
||||
fresh (BN (UN str) loc) = mnb str loc
|
||||
fresh (BN (MN str k) loc) = mnb str loc
|
||||
fresh (BN Unused loc) = mnb "x" loc
|
||||
|
|
|
@ -1,19 +1,13 @@
|
|||
module Quox.NatExtra
|
||||
|
||||
import public Data.Nat
|
||||
import public Data.Nat.Views
|
||||
import Data.Nat.Division
|
||||
import Data.SnocList
|
||||
import Data.Vect
|
||||
import Syntax.PreorderReasoning
|
||||
import Data.String
|
||||
|
||||
%default total
|
||||
|
||||
infixl 8 `shiftL`, `shiftR`
|
||||
infixl 7 .&.
|
||||
infixl 6 `xor`
|
||||
infixl 5 .|.
|
||||
|
||||
|
||||
public export
|
||||
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 = pack . showAtBase' []
|
||||
|
||||
export
|
||||
showHex : Nat -> String
|
||||
showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
|
||||
namespace Nat
|
||||
export
|
||||
showHex : Nat -> String
|
||||
showHex = showAtBase $ fromList $ unpack "0123456789abcdef"
|
||||
|
||||
namespace Int
|
||||
export
|
||||
showHex : Int -> String
|
||||
showHex x =
|
||||
if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x)
|
||||
|
||||
|
||||
export
|
||||
0 notEvenOdd : (a, b : Nat) -> Not (a + a = S (b + b))
|
||||
notEvenOdd 0 b prf = absurd prf
|
||||
notEvenOdd (S a) b prf =
|
||||
notEvenOdd b a $ Calc $
|
||||
|~ b + b
|
||||
~~ a + S a ..<(inj S prf)
|
||||
~~ S (a + a) ..<(plusSuccRightSucc {})
|
||||
namespace Int
|
||||
export
|
||||
fromHexit : Char -> Maybe Int
|
||||
fromHexit c =
|
||||
if c >= '0' && c <= '9' then Just $ ord c - ord '0'
|
||||
else if c >= 'a' && c <= 'f' then Just $ ord c - ord 'a' + 10
|
||||
else if c >= 'A' && c <= 'F' then Just $ ord c - ord 'A' + 10
|
||||
else Nothing
|
||||
|
||||
export
|
||||
0 doubleInj : (m, n : Nat) -> m + m = n + n -> m = n
|
||||
doubleInj 0 0 _ = Refl
|
||||
doubleInj (S m) (S n) prf =
|
||||
cong S $ doubleInj m n $
|
||||
inj S $ Calc $
|
||||
|~ S (m + m)
|
||||
~~ 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
|
||||
0 halfDouble : (n : Nat) -> half (n + n) = HalfEven n
|
||||
halfDouble n with (half (n + n)) | (n + n) proof nn
|
||||
_ | HalfOdd k | S (k + k) = void $ notEvenOdd n k nn
|
||||
_ | HalfEven k | k + k = rewrite doubleInj n k nn in Refl
|
||||
export %inline
|
||||
fromHex : String -> Maybe Int
|
||||
fromHex str = do guard $ str /= ""; fromHex' 0 str
|
||||
|
||||
export
|
||||
floorHalf : Nat -> Nat
|
||||
floorHalf k = case half k of
|
||||
HalfOdd n => n
|
||||
HalfEven n => n
|
||||
namespace Nat
|
||||
export
|
||||
fromHexit : Char -> Maybe Nat
|
||||
fromHexit = map cast . Int.fromHexit
|
||||
|
||||
|
||||
||| 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
|
||||
export %inline
|
||||
fromHex : String -> Maybe Nat
|
||||
fromHex = map cast . Int.fromHex
|
||||
|
|
|
@ -43,7 +43,7 @@ parameters {0 a, b : Bool}
|
|||
noOr2 = snd . noOr
|
||||
|
||||
|
||||
infixr 1 `orNo`
|
||||
export infixr 1 `orNo`
|
||||
export %inline
|
||||
orNo : No a -> No b -> No (a || b)
|
||||
orNo Ah Ah = Ah
|
||||
|
@ -52,3 +52,8 @@ export %inline
|
|||
nchoose : (b : Bool) -> Either (So b) (No b)
|
||||
nchoose True = Left Oh
|
||||
nchoose False = Right Ah
|
||||
|
||||
export
|
||||
0 notYesNo : {f : Dec p} -> Not p -> No (isYes f)
|
||||
notYesNo {f = Yes y} g = absurd $ g y
|
||||
notYesNo {f = No n} g = Ah
|
||||
|
|
|
@ -1,76 +0,0 @@
|
|||
||| "order preserving embeddings", for recording a correspondence between
|
||||
||| a smaller scope and part of a larger one.
|
||||
module Quox.OPE
|
||||
|
||||
import Quox.NatExtra
|
||||
import Data.Nat
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data OPE : Nat -> Nat -> Type where
|
||||
Id : OPE n n
|
||||
Drop : OPE m n -> OPE m (S n)
|
||||
Keep : OPE m n -> OPE (S m) (S n)
|
||||
%name OPE p, q
|
||||
|
||||
public export %inline Injective Drop where injective Refl = Refl
|
||||
public export %inline Injective Keep where injective Refl = Refl
|
||||
|
||||
public export
|
||||
opeZero : {n : Nat} -> OPE 0 n
|
||||
opeZero {n = 0} = Id
|
||||
opeZero {n = S n} = Drop opeZero
|
||||
|
||||
public export
|
||||
(.) : OPE m n -> OPE n p -> OPE m p
|
||||
p . Id = p
|
||||
Id . q = q
|
||||
p . Drop q = Drop $ p . q
|
||||
Drop p . Keep q = Drop $ p . q
|
||||
Keep p . Keep q = Keep $ p . q
|
||||
|
||||
public export
|
||||
toLTE : {m : Nat} -> OPE m n -> m `LTE` n
|
||||
toLTE Id = reflexive
|
||||
toLTE (Drop p) = lteSuccRight $ toLTE p
|
||||
toLTE (Keep p) = LTESucc $ toLTE p
|
||||
|
||||
|
||||
public export
|
||||
keepN : (n : Nat) -> OPE a b -> OPE (n + a) (n + b)
|
||||
keepN 0 p = p
|
||||
keepN (S n) p = Keep $ keepN n p
|
||||
|
||||
public export
|
||||
dropInner' : LTE' m n -> OPE m n
|
||||
dropInner' LTERefl = Id
|
||||
dropInner' (LTESuccR p) = Drop $ dropInner' $ force p
|
||||
|
||||
public export
|
||||
dropInner : {n : Nat} -> LTE m n -> OPE m n
|
||||
dropInner = dropInner' . fromLte
|
||||
|
||||
public export
|
||||
dropInnerN : (m : Nat) -> OPE n (m + n)
|
||||
dropInnerN 0 = Id
|
||||
dropInnerN (S m) = Drop $ dropInnerN m
|
||||
|
||||
|
||||
public export
|
||||
interface Tighten t where
|
||||
tighten : OPE m n -> t n -> Maybe (t m)
|
||||
|
||||
parameters {auto _ : Tighten t}
|
||||
export %inline
|
||||
tightenInner : {n : Nat} -> m `LTE` n -> t n -> Maybe (t m)
|
||||
tightenInner = tighten . dropInner
|
||||
|
||||
export %inline
|
||||
tightenN : (m : Nat) -> t (m + n) -> Maybe (t n)
|
||||
tightenN m = tighten $ dropInnerN m
|
||||
|
||||
export %inline
|
||||
tighten1 : t (S n) -> Maybe (t n)
|
||||
tighten1 = tightenN 1
|
|
@ -1,39 +1,31 @@
|
|||
||| take freshly-parsed input, scope check, type check, add to env
|
||||
module Quox.Parser.FromParser
|
||||
|
||||
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
|
||||
|
||||
import Quox.Pretty
|
||||
import Quox.Parser.Syntax
|
||||
import Quox.Parser.Parser
|
||||
import public Quox.Parser.LoadFile
|
||||
import Quox.Typechecker
|
||||
import Quox.CheckBuiltin
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.SnocVect
|
||||
import Quox.EffExtra
|
||||
import Control.Monad.ST.Extra
|
||||
|
||||
import System.File
|
||||
import System.Path
|
||||
import Data.IORef
|
||||
|
||||
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
|
||||
|
||||
%default total
|
||||
|
||||
%hide Typing.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
public export
|
||||
NDefinition : Type
|
||||
NDefinition = (Name, Definition)
|
||||
|
||||
public export
|
||||
IncludePath : Type
|
||||
IncludePath = List String
|
||||
|
||||
public export
|
||||
SeenFiles : Type
|
||||
SeenFiles = SortedSet String
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
|
@ -41,27 +33,50 @@ data StateTag = NS | SEEN
|
|||
|
||||
public export
|
||||
FromParserPure : List (Type -> Type)
|
||||
FromParserPure =
|
||||
[Except Error, DefsState, StateL NS Mods, NameGen]
|
||||
|
||||
public export
|
||||
LoadFile' : List (Type -> Type)
|
||||
LoadFile' = [IO, StateL SEEN SeenFiles, Reader IncludePath]
|
||||
|
||||
public export
|
||||
LoadFile : List (Type -> Type)
|
||||
LoadFile = LoadFile' ++ [Except Error]
|
||||
FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
|
||||
|
||||
public export
|
||||
FromParserIO : List (Type -> Type)
|
||||
FromParserIO = FromParserPure ++ LoadFile'
|
||||
FromParserIO = FromParserPure ++ [LoadFile]
|
||||
|
||||
|
||||
public export
|
||||
record PureParserResult a where
|
||||
constructor MkPureParserResult
|
||||
val : a
|
||||
suf : NameSuf
|
||||
defs : Definitions
|
||||
log : SnocList LogDoc
|
||||
logLevels : LevelStack
|
||||
|
||||
export
|
||||
fromParserPure : Mods -> NameSuf -> Definitions -> LevelStack ->
|
||||
Eff FromParserPure a -> Either Error (PureParserResult a)
|
||||
fromParserPure ns suf defs lvls act = runSTErr $ do
|
||||
suf <- newSTRef' suf
|
||||
defs <- newSTRef' defs
|
||||
log <- newSTRef' [<]
|
||||
lvls <- newSTRef' lvls
|
||||
res <- runEff act $ with Union.(::)
|
||||
[handleExcept $ \e => stLeft e,
|
||||
handleStateSTRef defs,
|
||||
handleStateSTRef !(newSTRef' ns),
|
||||
handleStateSTRef suf,
|
||||
handleLogST log lvls]
|
||||
pure $ MkPureParserResult {
|
||||
val = res,
|
||||
suf = !(readSTRef' suf),
|
||||
defs = !(readSTRef' defs),
|
||||
log = !(readSTRef' log),
|
||||
logLevels = !(readSTRef' lvls)
|
||||
}
|
||||
|
||||
|
||||
parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
|
||||
(xs : Context' PatVar n)
|
||||
private
|
||||
fromBaseName : PBaseName -> m a
|
||||
fromBaseName x = maybe (f $ MakePName [<] x) b $
|
||||
fromBaseName x = maybe (f $ MkPName [<] x) b $
|
||||
Context.find (\y => y.name == Just x) xs
|
||||
|
||||
private
|
||||
|
@ -113,11 +128,10 @@ fromV : Context' PatVar d -> Context' PatVar n ->
|
|||
PName -> Maybe Universe -> Loc -> Eff FromParserPure (Term d n)
|
||||
fromV ds ns x u loc = fromName bound free ns x where
|
||||
bound : Var n -> Eff FromParserPure (Term d n)
|
||||
bound i = do whenJust u $ \u => throw $ DisplacedBoundVar loc x
|
||||
pure $ E $ B i loc
|
||||
bound i = unless (isNothing u) (throw $ DisplacedBoundVar loc x) $> BT i loc
|
||||
|
||||
free : PName -> Eff FromParserPure (Term d n)
|
||||
free x = do x <- avoidDim ds loc x
|
||||
resolveName !(getAt NS) loc x u
|
||||
free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
|
||||
|
||||
mutual
|
||||
export
|
||||
|
@ -127,6 +141,9 @@ mutual
|
|||
TYPE k loc =>
|
||||
pure $ TYPE k loc
|
||||
|
||||
IOState loc =>
|
||||
pure $ IOState loc
|
||||
|
||||
Pi pi x s t loc =>
|
||||
Pi (fromPQty pi)
|
||||
<$> fromPTermWith ds ns s
|
||||
|
@ -157,17 +174,26 @@ mutual
|
|||
<*> fromPTermTScope ds ns [< x, y] body
|
||||
<*> pure loc
|
||||
|
||||
Fst pair loc =>
|
||||
map E $ Fst <$> fromPTermElim ds ns pair <*> pure loc
|
||||
|
||||
Snd pair loc =>
|
||||
map E $ Snd <$> fromPTermElim ds ns pair <*> pure loc
|
||||
|
||||
Case pi tag (r, ret) (CaseEnum arms _) loc =>
|
||||
map E $ CaseEnum (fromPQty pi)
|
||||
<$> fromPTermElim ds ns tag
|
||||
<*> fromPTermTScope ds ns [< r] ret
|
||||
<*> assert_total fromPTermEnumArms ds ns arms
|
||||
<*> assert_total fromPTermEnumArms loc ds ns arms
|
||||
<*> pure loc
|
||||
|
||||
Nat loc => pure $ Nat loc
|
||||
Zero loc => pure $ Zero loc
|
||||
NAT loc => pure $ NAT loc
|
||||
Nat n loc => pure $ Nat n loc
|
||||
Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|]
|
||||
|
||||
STRING loc => pure $ STRING loc
|
||||
Str str loc => pure $ Str str loc
|
||||
|
||||
Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
|
||||
map E $ CaseNat (fromPQty pi) (fromPQty pi')
|
||||
<$> fromPTermElim ds ns nat
|
||||
|
@ -176,12 +202,11 @@ mutual
|
|||
<*> fromPTermTScope ds ns [< s, ih] suc
|
||||
<*> pure loc
|
||||
|
||||
Enum strs loc =>
|
||||
let set = SortedSet.fromList strs in
|
||||
if length strs == length (SortedSet.toList set) then
|
||||
pure $ Enum set loc
|
||||
else
|
||||
throw $ DuplicatesInEnum loc strs
|
||||
Enum strs loc => do
|
||||
let set = SortedSet.fromList strs
|
||||
unless (length strs == length (SortedSet.toList set)) $
|
||||
throw $ DuplicatesInEnumType loc strs
|
||||
pure $ Enum set loc
|
||||
|
||||
Tag str loc => pure $ Tag str loc
|
||||
|
||||
|
@ -238,13 +263,22 @@ mutual
|
|||
<*> fromPTermDScope ds ns [< j1] val1
|
||||
<*> pure loc
|
||||
|
||||
Let (qty, x, rhs) body loc =>
|
||||
Let (fromPQty qty)
|
||||
<$> fromPTermElim ds ns rhs
|
||||
<*> fromPTermTScope ds ns [< x] body
|
||||
<*> pure loc
|
||||
|
||||
private
|
||||
fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
|
||||
fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n ->
|
||||
List (PTagVal, PTerm) ->
|
||||
Eff FromParserPure (CaseEnumArms d n)
|
||||
fromPTermEnumArms ds ns =
|
||||
map SortedMap.fromList .
|
||||
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
|
||||
fromPTermEnumArms loc ds ns arms = do
|
||||
res <- SortedMap.fromList <$>
|
||||
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms
|
||||
unless (length (keys res) == length arms) $
|
||||
throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms)
|
||||
pure res
|
||||
|
||||
private
|
||||
fromPTermElim : Context' PatVar d -> Context' PatVar n ->
|
||||
|
@ -263,7 +297,7 @@ mutual
|
|||
if all isUnused xs then
|
||||
SN <$> fromPTermWith ds ns t
|
||||
else
|
||||
ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
|
||||
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
|
||||
|
||||
private
|
||||
fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
|
||||
|
@ -271,9 +305,9 @@ mutual
|
|||
Eff FromParserPure (DScopeTermN s d n)
|
||||
fromPTermDScope ds ns xs t =
|
||||
if all isUnused xs then
|
||||
SN <$> fromPTermWith ds ns t
|
||||
SN {f = \d => Term d n} <$> fromPTermWith ds ns t
|
||||
else
|
||||
DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
|
||||
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
|
||||
|
||||
|
||||
export %inline
|
||||
|
@ -282,72 +316,110 @@ fromPTerm = fromPTermWith [<] [<]
|
|||
|
||||
|
||||
export
|
||||
globalPQty : Loc -> (q : Qty) -> Eff [Except Error] (So $ isGlobal q)
|
||||
globalPQty loc pi = case choose $ isGlobal pi of
|
||||
Left y => pure y
|
||||
Right _ => throw $ QtyNotGlobal loc pi
|
||||
|
||||
globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty
|
||||
globalPQty (PQ pi loc) = case toGlobal pi of
|
||||
Just g => pure g
|
||||
Nothing => throw $ QtyNotGlobal loc pi
|
||||
|
||||
export
|
||||
fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name
|
||||
fromPBaseNameNS : Has (StateL NS Mods) fs => PBaseName -> Eff fs Name
|
||||
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
|
||||
|
||||
|
||||
private
|
||||
liftTC : TC a -> Eff FromParserPure a
|
||||
liftTC act = do
|
||||
res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act
|
||||
rethrow $ mapFst WrapTypeError res
|
||||
liftTC : Eff TC a -> Eff FromParserPure a
|
||||
liftTC tc = runEff tc $ with Union.(::)
|
||||
[handleExcept $ \e => throw $ WrapTypeError e,
|
||||
handleReaderConst !(getAt DEFS),
|
||||
\g => send g,
|
||||
\g => send g]
|
||||
|
||||
private
|
||||
liftWhnf : Eff Whnf a -> Eff FromParserPure a
|
||||
liftWhnf tc = runEff tc $ with Union.(::)
|
||||
[handleExcept $ \e => throw $ WrapTypeError e,
|
||||
\g => send g,
|
||||
\g => send g]
|
||||
|
||||
private
|
||||
addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition
|
||||
addDef name def = do
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
|
||||
|
||||
export covering
|
||||
fromPDef : PDefinition -> Eff FromParserPure NDefinition
|
||||
fromPDef (MkPDef qty pname ptype pterm defLoc) = do
|
||||
name <- lift $ fromPBaseNameNS pname
|
||||
qtyGlobal <- lift $ globalPQty qty.loc qty.val
|
||||
let gqty = Element qty.val qtyGlobal
|
||||
sqty = globalToSubj gqty
|
||||
type <- lift $ traverse fromPTerm ptype
|
||||
term <- lift $ fromPTerm pterm
|
||||
case type of
|
||||
Just type => do
|
||||
liftTC $ checkTypeC empty type Nothing
|
||||
liftTC $ ignore $ checkC empty sqty term type
|
||||
let def = mkDef gqty type term defLoc
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
Nothing => do
|
||||
let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term
|
||||
res <- liftTC $ inferC empty sqty elim
|
||||
let def = mkDef gqty res.type term defLoc
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
fromPDef def = do
|
||||
name <- fromPBaseNameNS def.name
|
||||
defs <- getAt DEFS
|
||||
when (isJust $ lookup name defs) $ do
|
||||
throw $ AlreadyExists def.loc name
|
||||
gqty <- globalPQty def.qty
|
||||
let sqty = globalToSubj gqty
|
||||
case def.body of
|
||||
PConcrete ptype pterm => do
|
||||
type <- traverse fromPTerm ptype
|
||||
term <- fromPTerm pterm
|
||||
type <- case type of
|
||||
Just type => do
|
||||
ignore $ liftTC $ do
|
||||
checkTypeC empty type Nothing
|
||||
checkC empty sqty term type
|
||||
pure type
|
||||
Nothing => do
|
||||
let E elim = term
|
||||
| _ => throw $ AnnotationNeeded term.loc empty term
|
||||
res <- liftTC $ inferC empty sqty elim
|
||||
pure res.type
|
||||
when def.main $ liftWhnf $ expectMainType defs type
|
||||
addDef name $ mkDef gqty type term def.scheme def.main def.loc
|
||||
PPostulate ptype => do
|
||||
type <- fromPTerm ptype
|
||||
addDef name $ mkPostulate gqty type def.scheme def.main def.loc
|
||||
|
||||
|
||||
public export
|
||||
data HasFail = NoFail | AnyFail | FailWith String
|
||||
|
||||
export covering
|
||||
expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error
|
||||
expectFail loc act = do
|
||||
gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels
|
||||
case fromParserPure ns gen defs (singleton lvl) act of
|
||||
Left err => pure err
|
||||
Right _ => throw $ ExpectedFail loc
|
||||
|
||||
export covering
|
||||
maybeFail : Monoid a =>
|
||||
PFail -> Loc -> Eff FromParserPure a -> Eff FromParserPure a
|
||||
maybeFail PSucceed _ act = act
|
||||
maybeFail PFailAny loc act = expectFail loc act $> neutral
|
||||
maybeFail (PFailMatch str) loc act = do
|
||||
err <- expectFail loc act
|
||||
let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e
|
||||
if str `isInfixOf` renderInfinite msg
|
||||
then pure neutral
|
||||
else throw $ WrongFail str err loc
|
||||
|
||||
export covering
|
||||
fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
|
||||
fromPDecl (PDef def) = singleton <$> fromPDef def
|
||||
fromPDecl (PDef def) =
|
||||
maybeFail def.fail def.loc $ singleton <$> fromPDef def
|
||||
fromPDecl (PNs ns) =
|
||||
maybeFail ns.fail ns.loc $
|
||||
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
||||
|
||||
|
||||
export covering
|
||||
loadFile : Loc -> String -> Eff LoadFile (Maybe String)
|
||||
loadFile loc file =
|
||||
if contains file !(getAt SEEN) then
|
||||
pure Nothing
|
||||
else do
|
||||
Just ifile <- firstExists (map (</> file) !ask)
|
||||
| Nothing => throw $ LoadError loc file FileNotFound
|
||||
case !(readFile ifile) of
|
||||
Right res => modifyAt SEEN (insert file) $> Just res
|
||||
Left err => throw $ LoadError loc ifile err
|
||||
fromPDecl (PPrag prag) =
|
||||
case prag of
|
||||
PLogPush p _ => Log.push p $> []
|
||||
PLogPop _ => Log.pop $> []
|
||||
|
||||
mutual
|
||||
export covering
|
||||
loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
|
||||
loadProcessFile loc file =
|
||||
case !(lift $ loadFile loc file) of
|
||||
Just inp => do
|
||||
tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
|
||||
concat <$> traverse fromPTopLevel tl
|
||||
case !(loadFile loc file) of
|
||||
Just tl => concat <$> traverse fromPTopLevel tl
|
||||
Nothing => pure []
|
||||
|
||||
||| populates the `defs` field of the state
|
||||
|
@ -355,28 +427,3 @@ mutual
|
|||
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
|
||||
fromPTopLevel (PD decl) = lift $ fromPDecl decl
|
||||
fromPTopLevel (PLoad file loc) = loadProcessFile loc file
|
||||
|
||||
export
|
||||
fromParserPure : NameSuf -> Definitions ->
|
||||
Eff FromParserPure a ->
|
||||
(Either Error (a, Definitions), NameSuf)
|
||||
fromParserPure suf defs act =
|
||||
extract $
|
||||
runStateAt GEN suf $
|
||||
runExcept $
|
||||
evalStateAt NS [<] $
|
||||
runStateAt DEFS defs act
|
||||
|
||||
export
|
||||
fromParserIO : (MonadRec io, HasIO io) =>
|
||||
IncludePath ->
|
||||
IORef SeenFiles -> IORef NameSuf -> IORef Definitions ->
|
||||
Eff FromParserIO a -> io (Either Error a)
|
||||
fromParserIO inc seen suf defs act =
|
||||
runIO $
|
||||
runStateIORefAt GEN suf $
|
||||
runExcept $
|
||||
evalStateAt NS [<] $
|
||||
runStateIORefAt SEEN seen $
|
||||
runStateIORefAt DEFS defs $
|
||||
runReader inc act
|
||||
|
|
|
@ -1,11 +1,14 @@
|
|||
module Quox.Parser.FromParser.Error
|
||||
|
||||
import Quox.Parser.Parser
|
||||
import Quox.Parser.LoadFile
|
||||
import Quox.Typing
|
||||
import System.File
|
||||
|
||||
import Quox.Pretty
|
||||
|
||||
%default total
|
||||
|
||||
%hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>)
|
||||
|
||||
|
||||
|
@ -21,26 +24,34 @@ ParseError = Parser.Error
|
|||
public export
|
||||
data Error =
|
||||
AnnotationNeeded Loc (NameContexts d n) (Term d n)
|
||||
| DuplicatesInEnum Loc (List TagVal)
|
||||
| DuplicatesInEnumType Loc (List TagVal)
|
||||
| DuplicatesInEnumCase Loc (List TagVal)
|
||||
| TermNotInScope Loc Name
|
||||
| DimNotInScope Loc PBaseName
|
||||
| QtyNotGlobal Loc Qty
|
||||
| DimNameInTerm Loc PBaseName
|
||||
| DisplacedBoundVar Loc PName
|
||||
| WrapTypeError TypeError
|
||||
| LoadError Loc String FileError
|
||||
| AlreadyExists Loc Name
|
||||
| LoadError Loc FilePath FileError
|
||||
| ExpectedFail Loc
|
||||
| SchemeOnNamespace Loc Mods
|
||||
| MainOnNamespace Loc Mods
|
||||
| WrongFail String Error Loc
|
||||
| WrapParseError String ParseError
|
||||
|
||||
|
||||
export
|
||||
prettyLexError : {opts : _} -> String -> LexError -> Eff Pretty (Doc opts)
|
||||
prettyLexError file (Err reason line col char) = do
|
||||
let loc = makeLoc file (MkBounds line col line col)
|
||||
reason <- case reason of
|
||||
EndInput => pure "unexpected end of input"
|
||||
NoRuleApply => pure $ text "unrecognised character: \{show char}"
|
||||
Other msg => pure $ text msg
|
||||
NoRuleApply => case char of
|
||||
Just char => pure $ text "unrecognised character: \{show char}"
|
||||
Nothing => pure $ text "unexpected end of input"
|
||||
ComposeNotClosing (sl, sc) (el, ec) => pure $
|
||||
hsep ["unterminated token at", !(prettyBounds (MkBounds sl sc el ec))]
|
||||
let loc = makeLoc file (MkBounds line col line col)
|
||||
pure $ vappend !(prettyLoc loc) reason
|
||||
|
||||
export
|
||||
|
@ -61,19 +72,23 @@ prettyParseError file (ParseError errs) =
|
|||
traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
|
||||
|
||||
|
||||
parameters (showContext : Bool)
|
||||
parameters {opts : LayoutOpts} (showContext : Bool)
|
||||
export
|
||||
prettyError : {opts : _} -> Error -> Eff Pretty (Doc opts)
|
||||
prettyError : Error -> Eff Pretty (Doc opts)
|
||||
prettyError (AnnotationNeeded loc ctx tm) =
|
||||
[|vappend (prettyLoc loc)
|
||||
(hangD "type annotation needed on"
|
||||
!(prettyTerm ctx.dnames ctx.tnames tm))|]
|
||||
-- [todo] print the original PTerm instead
|
||||
|
||||
prettyError (DuplicatesInEnum loc tags) =
|
||||
prettyError (DuplicatesInEnumType loc tags) =
|
||||
[|vappend (prettyLoc loc)
|
||||
(hangD "duplicate tags in enum type" !(prettyEnum tags))|]
|
||||
|
||||
prettyError (DuplicatesInEnumCase loc tags) =
|
||||
[|vappend (prettyLoc loc)
|
||||
(hangD "duplicate arms in enum case" !(prettyEnum tags))|]
|
||||
|
||||
prettyError (DimNotInScope loc i) =
|
||||
[|vappend (prettyLoc loc)
|
||||
(pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|]
|
||||
|
@ -100,10 +115,32 @@ parameters (showContext : Bool)
|
|||
prettyError (WrapTypeError err) =
|
||||
Typing.prettyError showContext $ trimContext 2 err
|
||||
|
||||
prettyError (LoadError loc str err) = pure $
|
||||
prettyError (AlreadyExists loc name) = pure $
|
||||
vsep [!(prettyLoc loc),
|
||||
"couldn't load file" <++> text str,
|
||||
sep [!(prettyFree name), "has already been defined"]]
|
||||
|
||||
prettyError (LoadError loc file err) = pure $
|
||||
vsep [!(prettyLoc loc),
|
||||
"couldn't load file" <++> text file,
|
||||
text $ show err]
|
||||
|
||||
prettyError (ExpectedFail loc) = pure $
|
||||
vsep [!(prettyLoc loc), "expected error"]
|
||||
|
||||
prettyError (SchemeOnNamespace loc ns) = pure $
|
||||
vsep [!(prettyLoc loc),
|
||||
hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns),
|
||||
"cannot have #[compile-scheme] attached"]]
|
||||
|
||||
prettyError (MainOnNamespace loc ns) = pure $
|
||||
vsep [!(prettyLoc loc),
|
||||
hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns),
|
||||
"cannot have #[main] attached"]]
|
||||
|
||||
prettyError (WrongFail str err loc) = pure $
|
||||
vsep [!(prettyLoc loc),
|
||||
"wrong error, expected to match", !(hl Constant $ text "\"\{str}\""),
|
||||
"but got", !(prettyError err)]
|
||||
|
||||
prettyError (WrapParseError file err) =
|
||||
prettyParseError file err
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
module Quox.Parser.Lexer
|
||||
|
||||
import Quox.CharExtra
|
||||
import Quox.NatExtra
|
||||
import Quox.Name
|
||||
import Data.String.Extra
|
||||
import Data.SortedMap
|
||||
|
@ -19,7 +20,7 @@ import Derive.Prelude
|
|||
||| @ Reserved reserved token
|
||||
||| @ Name name, possibly qualified
|
||||
||| @ Nat nat literal
|
||||
||| @ String string literal
|
||||
||| @ Str string literal
|
||||
||| @ Tag tag literal
|
||||
||| @ TYPE "Type" or "★" with ascii nat directly after
|
||||
||| @ Sup superscript or ^ number (displacement, or universe for ★)
|
||||
|
@ -34,16 +35,27 @@ data Token =
|
|||
| Sup Nat
|
||||
%runElab derive "Token" [Eq, Ord, Show]
|
||||
|
||||
-- token or whitespace
|
||||
||| token or whitespace
|
||||
||| @ Skip whitespace, comments, etc
|
||||
||| @ Invalid a token which failed a post-lexer check
|
||||
||| (e.g. a qualified name containing a keyword)
|
||||
||| @ T a well formed token
|
||||
public export
|
||||
0 TokenW : Type
|
||||
TokenW = Maybe Token
|
||||
data ExtToken = Skip | Invalid String String | T Token
|
||||
%runElab derive "ExtToken" [Eq, Ord, Show]
|
||||
|
||||
|
||||
public export
|
||||
data ErrorReason =
|
||||
NoRuleApply
|
||||
| ComposeNotClosing (Int, Int) (Int, Int)
|
||||
| Other String
|
||||
%runElab derive "ErrorReason" [Eq, Ord, Show]
|
||||
|
||||
public export
|
||||
record Error where
|
||||
constructor Err
|
||||
reason : StopReason
|
||||
reason : ErrorReason
|
||||
line, col : Int
|
||||
||| `Nothing` if the error is at the end of the input
|
||||
char : Maybe Char
|
||||
|
@ -52,77 +64,118 @@ record Error where
|
|||
|
||||
|
||||
private
|
||||
skip : Lexer -> Tokenizer TokenW
|
||||
skip t = match t $ const Nothing
|
||||
skip : Lexer -> Tokenizer ExtToken
|
||||
skip t = match t $ const Skip
|
||||
|
||||
private
|
||||
match : Lexer -> (String -> Token) -> Tokenizer TokenW
|
||||
match t f = Tokenizer.match t (Just . f)
|
||||
%hide Tokenizer.match
|
||||
tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
|
||||
tmatch t f = match t (T . f)
|
||||
|
||||
|
||||
private
|
||||
name : Tokenizer TokenW
|
||||
name = match name $ Name . fromListP . split (== '.') . normalizeNfc
|
||||
|
||||
||| [todo] escapes other than `\"` and (accidentally) `\\`
|
||||
export
|
||||
fromStringLit : String -> String
|
||||
fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where
|
||||
go : List Char -> List Char
|
||||
go [] = []
|
||||
go ['\\'] = ['\\'] -- i guess???
|
||||
go ('\\' :: c :: cs) = c :: go cs
|
||||
go (c :: cs) = c :: go cs
|
||||
fromStringLit : (String -> Token) -> String -> ExtToken
|
||||
fromStringLit f str =
|
||||
case go $ unpack $ drop 1 $ dropLast 1 str of
|
||||
Left err => Invalid err str
|
||||
Right ok => T $ f $ pack ok
|
||||
where
|
||||
Interpolation Char where interpolate = singleton
|
||||
|
||||
go, hexEscape : List Char -> Either String (List Char)
|
||||
|
||||
go [] = Right []
|
||||
go ['\\'] = Left "string ends with \\"
|
||||
go ('\\' :: 'n' :: cs) = ('\n' ::) <$> go cs
|
||||
go ('\\' :: 't' :: cs) = ('\t' ::) <$> go cs
|
||||
go ('\\' :: 'x' :: cs) = hexEscape cs
|
||||
go ('\\' :: 'X' :: cs) = hexEscape cs
|
||||
go ('\\' :: '\\' :: cs) = ('\\' ::) <$> go cs
|
||||
go ('\\' :: '"' :: cs) = ('"' ::) <$> go cs
|
||||
-- [todo] others
|
||||
go ('\\' :: c :: _) = Left "unknown escape '\{c}'"
|
||||
go (c :: cs) = (c ::) <$> go cs
|
||||
|
||||
hexEscape cs =
|
||||
case break (== ';') cs of
|
||||
(hs, ';' :: rest) => do
|
||||
let hs = pack hs
|
||||
let Just c = Int.fromHex hs
|
||||
| Nothing => Left #"invalid hex string "\#{hs}" in escape"#
|
||||
if isCodepoint c
|
||||
then (chr c ::) <$> go (assert_smaller cs rest)
|
||||
else Left "codepoint \{hs} out of range"
|
||||
_ => Left "unterminated hex escape"
|
||||
|
||||
private
|
||||
string : Tokenizer TokenW
|
||||
string = match stringLit (Str . fromStringLit)
|
||||
string : Tokenizer ExtToken
|
||||
string = match stringLit $ fromStringLit Str
|
||||
|
||||
|
||||
%hide binLit
|
||||
%hide octLit
|
||||
%hide hexLit
|
||||
|
||||
private
|
||||
nat : Tokenizer TokenW
|
||||
nat = match (some (range '0' '9')) (Nat . cast)
|
||||
nat : Tokenizer ExtToken
|
||||
nat = match hexLit fromHexLit
|
||||
<|> tmatch decLit fromDecLit
|
||||
where
|
||||
withUnderscores : Lexer -> Lexer
|
||||
withUnderscores l = l <+> many (opt (is '_') <+> l)
|
||||
|
||||
withoutUnderscores : String -> String
|
||||
withoutUnderscores = pack . go . unpack where
|
||||
go : List Char -> List Char
|
||||
go [] = []
|
||||
go ('_' :: cs) = go cs
|
||||
go (c :: cs) = c :: go cs
|
||||
|
||||
decLit =
|
||||
withUnderscores (range '0' '9') <+> reject idContEnd
|
||||
|
||||
hexLit =
|
||||
approx "0x" <+>
|
||||
withUnderscores (range '0' '9' <|> range 'a' 'f' <|> range 'A' 'F') <+>
|
||||
reject idContEnd
|
||||
|
||||
fromDecLit : String -> Token
|
||||
fromDecLit = Nat . cast . withoutUnderscores
|
||||
|
||||
fromHexLit : String -> ExtToken
|
||||
fromHexLit str =
|
||||
maybe (Invalid "invalid hex sequence" str) (T . Nat) $
|
||||
fromHex $ withoutUnderscores $ drop 2 str
|
||||
|
||||
|
||||
private
|
||||
tag : Tokenizer TokenW
|
||||
tag = match (is '\'' <+> name) (Tag . drop 1)
|
||||
<|> match (is '\'' <+> stringLit) (Tag . fromStringLit . drop 1)
|
||||
tag : Tokenizer ExtToken
|
||||
tag = tmatch (is '\'' <+> name) (Tag . drop 1)
|
||||
<|> match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1)
|
||||
|
||||
|
||||
|
||||
private %inline
|
||||
fromSub : Char -> Char
|
||||
fromSub c = case c of
|
||||
'₀' => '0'; '₁' => '1'; '₂' => '2'; '₃' => '3'; '₄' => '4'
|
||||
'₅' => '5'; '₆' => '6'; '₇' => '7'; '₈' => '8'; '₉' => '9'; _ => c
|
||||
|
||||
private %inline
|
||||
fromSup : Char -> Char
|
||||
fromSup c = case c of
|
||||
'⁰' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '⁴' => '4'
|
||||
'⁵' => '5'; '⁶' => '6'; '⁷' => '7'; '⁸' => '8'; '⁹' => '9'; _ => c
|
||||
|
||||
private %inline
|
||||
subToNat : String -> Nat
|
||||
subToNat = cast . pack . map fromSub . unpack
|
||||
|
||||
private %inline
|
||||
supToNat : String -> Nat
|
||||
supToNat = cast . pack . map fromSup . unpack
|
||||
|
||||
-- ★0, Type0. base ★/Type is a Reserved
|
||||
-- ★0, Type0. base ★/Type is a Reserved and ★¹/Type¹ are sequences of two tokens
|
||||
private
|
||||
universe : Tokenizer TokenW
|
||||
universe : Tokenizer ExtToken
|
||||
universe = universeWith "★" <|> universeWith "Type" where
|
||||
universeWith : String -> Tokenizer TokenW
|
||||
universeWith : String -> Tokenizer ExtToken
|
||||
universeWith pfx =
|
||||
let len = length pfx in
|
||||
match (exact pfx <+> digits) (TYPE . cast . drop len)
|
||||
tmatch (exact pfx <+> digits) (TYPE . cast . drop len)
|
||||
|
||||
private
|
||||
sup : Tokenizer TokenW
|
||||
sup = match (some $ pred isSupDigit) (Sup . supToNat)
|
||||
<|> match (is '^' <+> digits) (Sup . cast . drop 1)
|
||||
sup : Tokenizer ExtToken
|
||||
sup = tmatch (some $ pred isSupDigit) (Sup . supToNat)
|
||||
<|> tmatch (is '^' <+> digits) (Sup . cast . drop 1)
|
||||
|
||||
|
||||
private %inline
|
||||
|
@ -134,9 +187,11 @@ namespace Reserved
|
|||
||| description of a reserved symbol
|
||||
||| @ Word a reserved word (must not be followed by letters, digits, etc)
|
||||
||| @ Sym a reserved symbol (must not be followed by symbolic chars)
|
||||
||| @ Punc a character that doesn't show up in names (brackets, etc)
|
||||
||| @ Punc a character that doesn't show up in names (brackets, etc);
|
||||
||| also a sequence ending in one of those, like `#[`, since the
|
||||
||| difference relates to lookahead
|
||||
public export
|
||||
data Reserved1 = Word String | Sym String | Punc Char
|
||||
data Reserved1 = Word String | Sym String | Punc String
|
||||
%runElab derive "Reserved1" [Eq, Ord, Show]
|
||||
|
||||
||| description of a token that might have unicode & ascii-only aliases
|
||||
|
@ -145,17 +200,14 @@ namespace Reserved
|
|||
%runElab derive "Reserved" [Eq, Ord, Show]
|
||||
|
||||
public export
|
||||
Sym1, Word1 : String -> Reserved
|
||||
Sym1 = Only . Sym
|
||||
Sym1, Word1, Punc1 : String -> Reserved
|
||||
Sym1 = Only . Sym
|
||||
Word1 = Only . Word
|
||||
|
||||
public export
|
||||
Punc1 : Char -> Reserved
|
||||
Punc1 = Only . Punc
|
||||
|
||||
public export
|
||||
resString1 : Reserved1 -> String
|
||||
resString1 (Punc x) = singleton x
|
||||
resString1 (Punc x) = x
|
||||
resString1 (Word w) = w
|
||||
resString1 (Sym s) = s
|
||||
|
||||
|
@ -166,17 +218,23 @@ resString : Reserved -> String
|
|||
resString (Only r) = resString1 r
|
||||
resString (r `Or` _) = resString1 r
|
||||
|
||||
||| return both representative strings for a token description
|
||||
public export
|
||||
resString2 : Reserved -> List String
|
||||
resString2 (Only r) = [resString1 r]
|
||||
resString2 (r `Or` s) = [resString1 r, resString1 s]
|
||||
|
||||
private
|
||||
resTokenizer1 : Reserved1 -> String -> Tokenizer TokenW
|
||||
resTokenizer1 : Reserved1 -> String -> Tokenizer ExtToken
|
||||
resTokenizer1 r str =
|
||||
let res : String -> Token := const $ Reserved str in
|
||||
case r of Word w => match (exact w <+> reject idContEnd) res
|
||||
Sym s => match (exact s <+> reject symCont) res
|
||||
Punc x => match (is x) res
|
||||
case r of Word w => tmatch (exact w <+> reject idContEnd) res
|
||||
Sym s => tmatch (exact s <+> reject symCont) res
|
||||
Punc x => tmatch (exact x) res
|
||||
|
||||
||| match a reserved token
|
||||
export
|
||||
resTokenizer : Reserved -> Tokenizer TokenW
|
||||
resTokenizer : Reserved -> Tokenizer ExtToken
|
||||
resTokenizer (Only r) = resTokenizer1 r (resString1 r)
|
||||
resTokenizer (r `Or` s) =
|
||||
resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
|
||||
|
@ -188,8 +246,8 @@ resTokenizer (r `Or` s) =
|
|||
public export
|
||||
reserved : List Reserved
|
||||
reserved =
|
||||
[Punc1 '(', Punc1 ')', Punc1 '[', Punc1 ']', Punc1 '{', Punc1 '}',
|
||||
Punc1 ',', Punc1 ';',
|
||||
[Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}",
|
||||
Punc1 ",", Punc1 ";", Punc1 "#[", Punc1 "#![",
|
||||
Sym1 "@",
|
||||
Sym1 ":",
|
||||
Sym "⇒" `Or` Sym "=>",
|
||||
|
@ -197,12 +255,16 @@ reserved =
|
|||
Sym "×" `Or` Sym "**",
|
||||
Sym "≡" `Or` Sym "==",
|
||||
Sym "∷" `Or` Sym "::",
|
||||
Punc1 '.',
|
||||
Punc1 ".",
|
||||
Word1 "case",
|
||||
Word1 "case0", Word1 "case1",
|
||||
Word "caseω" `Or` Word "case#",
|
||||
Word1 "return",
|
||||
Word1 "of",
|
||||
Word1 "let", Word1 "in",
|
||||
Word1 "let0", Word1 "let1",
|
||||
Word "letω" `Or` Word "let#",
|
||||
Word1 "fst", Word1 "snd",
|
||||
Word1 "_",
|
||||
Word1 "Eq",
|
||||
Word "λ" `Or` Word "fun",
|
||||
|
@ -210,35 +272,71 @@ reserved =
|
|||
Word "ω" `Or` Sym "#",
|
||||
Sym "★" `Or` Word "Type",
|
||||
Word "ℕ" `Or` Word "Nat",
|
||||
Word1 "IOState",
|
||||
Word1 "String",
|
||||
Word1 "zero", Word1 "succ",
|
||||
Word1 "coe", Word1 "comp",
|
||||
Word1 "def",
|
||||
Word1 "def0",
|
||||
Word "defω" `Or` Word "def#",
|
||||
Word1 "postulate",
|
||||
Word1 "postulate0",
|
||||
Word "postulateω" `Or` Word "postulate#",
|
||||
Sym1 "=",
|
||||
Word1 "load",
|
||||
Word1 "namespace"]
|
||||
|
||||
public export
|
||||
reservedStrings : List String
|
||||
reservedStrings = map resString reserved
|
||||
|
||||
public export
|
||||
allReservedStrings : List String
|
||||
allReservedStrings = foldMap resString2 reserved
|
||||
|
||||
||| `IsReserved str` is true if `Reserved str` might actually show up in
|
||||
||| the token stream
|
||||
public export
|
||||
IsReserved : String -> Type
|
||||
IsReserved str = str `Elem` map resString reserved
|
||||
IsReserved str = So (str `elem` reservedStrings)
|
||||
|
||||
private
|
||||
name : Tokenizer ExtToken
|
||||
name =
|
||||
match name $ \str =>
|
||||
let parts = split (== '.') $ normalizeNfc str in
|
||||
case find (`elem` allReservedStrings) (toList parts) of
|
||||
Nothing => T $ Name $ fromListP parts
|
||||
Just w => Invalid "reserved word '\{w}' inside name \{str}" str
|
||||
|
||||
export
|
||||
tokens : Tokenizer TokenW
|
||||
tokens : Tokenizer ExtToken
|
||||
tokens = choice $
|
||||
map skip [pred isWhitespace,
|
||||
lineComment (exact "--" <+> reject symCont),
|
||||
blockComment (exact "{-") (exact "-}")] <+>
|
||||
[universe] <+> -- ★ᵢ takes precedence over bare ★
|
||||
[universe] <+> -- Type<i> takes precedence over bare Type
|
||||
map resTokenizer reserved <+>
|
||||
[sup, nat, string, tag, name]
|
||||
|
||||
export
|
||||
check : Alternative f =>
|
||||
WithBounds ExtToken -> Either Error (f (WithBounds Token))
|
||||
check (MkBounded val irr bounds@(MkBounds line col _ _)) = case val of
|
||||
Skip => Right empty
|
||||
T tok => Right $ pure $ MkBounded tok irr bounds
|
||||
Invalid msg tok => Left $ Err (Other msg) line col (index 0 tok)
|
||||
|
||||
export
|
||||
toErrorReason : StopReason -> Maybe ErrorReason
|
||||
toErrorReason EndInput = Nothing
|
||||
toErrorReason NoRuleApply = Just NoRuleApply
|
||||
toErrorReason (ComposeNotClosing s e) = Just $ ComposeNotClosing s e
|
||||
|
||||
export
|
||||
lex : String -> Either Error (List (WithBounds Token))
|
||||
lex str =
|
||||
let (res, reason, line, col, str) = lex tokens str in
|
||||
case reason of
|
||||
EndInput => Right $ mapMaybe sequence res
|
||||
_ => Left $ Err {reason, line, col, char = index 0 str}
|
||||
case toErrorReason reason of
|
||||
Nothing => concatMap check res @{MonoidApplicative}
|
||||
Just e => Left $ Err {reason = e, line, col, char = index 0 str}
|
||||
|
|
100
lib/Quox/Parser/LoadFile.idr
Normal file
100
lib/Quox/Parser/LoadFile.idr
Normal file
|
@ -0,0 +1,100 @@
|
|||
module Quox.Parser.LoadFile
|
||||
|
||||
import public Quox.Parser.Syntax
|
||||
import Quox.Parser.Parser
|
||||
import Quox.Loc
|
||||
import Quox.EffExtra
|
||||
import Data.IORef
|
||||
import Data.SortedSet
|
||||
import System.File
|
||||
import System.Path
|
||||
|
||||
|
||||
%default total
|
||||
|
||||
public export
|
||||
FilePath : Type
|
||||
FilePath = String
|
||||
|
||||
|
||||
public export
|
||||
data LoadFileL : (lbl : k) -> Type -> Type where
|
||||
[search lbl]
|
||||
Seen : FilePath -> LoadFileL lbl Bool
|
||||
SetSeen : FilePath -> LoadFileL lbl ()
|
||||
DoLoad : Loc -> FilePath -> LoadFileL lbl PFile
|
||||
|
||||
public export
|
||||
LoadFile : Type -> Type
|
||||
LoadFile = LoadFileL ()
|
||||
|
||||
|
||||
export
|
||||
seenAt : (0 lbl : k) -> Has (LoadFileL lbl) fs => FilePath -> Eff fs Bool
|
||||
seenAt lbl file = send $ Seen {lbl} file
|
||||
|
||||
export %inline
|
||||
seen : Has LoadFile fs => FilePath -> Eff fs Bool
|
||||
seen = seenAt ()
|
||||
|
||||
|
||||
export
|
||||
setSeenAt : (0 lbl : k) -> Has (LoadFileL lbl) fs => FilePath -> Eff fs ()
|
||||
setSeenAt lbl file = send $ SetSeen {lbl} file
|
||||
|
||||
export %inline
|
||||
setSeen : Has LoadFile fs => FilePath -> Eff fs ()
|
||||
setSeen = setSeenAt ()
|
||||
|
||||
|
||||
export
|
||||
doLoadAt : (0 lbl : k) -> Has (LoadFileL lbl) fs =>
|
||||
Loc -> FilePath -> Eff fs PFile
|
||||
doLoadAt lbl loc file = send $ DoLoad {lbl} loc file
|
||||
|
||||
export %inline
|
||||
doLoad : Has LoadFile fs => Loc -> FilePath -> Eff fs PFile
|
||||
doLoad = doLoadAt ()
|
||||
|
||||
|
||||
public export
|
||||
SeenSet : Type
|
||||
SeenSet = SortedSet FilePath
|
||||
|
||||
public export
|
||||
IncludePath : Type
|
||||
IncludePath = List String
|
||||
|
||||
export covering
|
||||
readFileFrom : HasIO io => IncludePath -> FilePath ->
|
||||
io (Either FileError String)
|
||||
readFileFrom inc f =
|
||||
case !(firstExists $ map (</> f) inc) of
|
||||
Just path => readFile path
|
||||
Nothing => pure $ Left $ FileNotFound
|
||||
|
||||
export covering
|
||||
handleLoadFileIOE : (Loc -> FilePath -> FileError -> e) ->
|
||||
(FilePath -> Parser.Error -> e) ->
|
||||
IORef SeenSet -> IncludePath ->
|
||||
LoadFileL lbl a -> IOErr e a
|
||||
handleLoadFileIOE injf injp seen inc = \case
|
||||
Seen f => contains f <$> readIORef seen
|
||||
SetSeen f => modifyIORef seen $ insert f
|
||||
DoLoad l f =>
|
||||
case !(readFileFrom inc f) of
|
||||
Left err => ioLeft $ injf l f err
|
||||
Right str => either (ioLeft . injp f) pure $ lexParseInput f str
|
||||
|
||||
|
||||
export
|
||||
loadFileAt : (0 lbl : k) -> Has (LoadFileL lbl) fs =>
|
||||
Loc -> FilePath -> Eff fs (Maybe PFile)
|
||||
loadFileAt lbl loc file =
|
||||
if !(seenAt lbl file)
|
||||
then pure Nothing
|
||||
else Just <$> doLoadAt lbl loc file <* setSeenAt lbl file
|
||||
|
||||
export
|
||||
loadFile : Has LoadFile fs => Loc -> FilePath -> Eff fs (Maybe PFile)
|
||||
loadFile = loadFileAt ()
|
|
@ -124,7 +124,7 @@ qname = terminalMatch "name" `(Name n) `(n)
|
|||
||| unqualified name
|
||||
export
|
||||
baseName : Grammar True PBaseName
|
||||
baseName = terminalMatch "unqualified name" `(Name (MakePName [<] b)) `(b)
|
||||
baseName = terminalMatch "unqualified name" `(Name (MkPName [<] b)) `(b)
|
||||
|
||||
||| dimension constant (0 or 1)
|
||||
export
|
||||
|
@ -149,6 +149,12 @@ export
|
|||
qty : FileName -> Grammar True PQty
|
||||
qty fname = withLoc fname [|PQ qtyVal|]
|
||||
|
||||
export
|
||||
exactName : String -> Grammar True ()
|
||||
exactName name = terminal "expected '\{name}'" $ \case
|
||||
Name (MkPName [<] x) => guard $ x == name
|
||||
_ => Nothing
|
||||
|
||||
|
||||
||| pattern var (unqualified name or _)
|
||||
export
|
||||
|
@ -198,18 +204,21 @@ export
|
|||
enumType : Grammar True (List TagVal)
|
||||
enumType = delimSep "{" "}" "," bareTag
|
||||
|
||||
||| e.g. `case` or `case 1.`
|
||||
||| e.g. `case1` or `case 1.`
|
||||
export
|
||||
caseIntro : FileName -> Grammar True PQty
|
||||
caseIntro fname =
|
||||
withLoc fname (PQ Zero <$ res "case0")
|
||||
<|> withLoc fname (PQ One <$ res "case1")
|
||||
<|> withLoc fname (PQ Any <$ res "caseω")
|
||||
<|> delim "case" "." (qty fname)
|
||||
<|> do resC "case"
|
||||
qty fname <* needRes "." <|> defLoc fname (PQ One)
|
||||
|
||||
export
|
||||
qtyPatVar : FileName -> Grammar True (PQty, PatVar)
|
||||
qtyPatVar fname = [|(,) (qty fname) (needRes "." *> patVar fname)|]
|
||||
qtyPatVar fname =
|
||||
[|(,) (qty fname) (needRes "." *> patVar fname)|]
|
||||
<|> [|(,) (defLoc fname $ PQ One) (patVar fname)|]
|
||||
|
||||
|
||||
export
|
||||
|
@ -277,19 +286,81 @@ export
|
|||
universe1 : Grammar True Universe
|
||||
universe1 = universeTok <|> res "★" *> option 0 super
|
||||
|
||||
||| argument/atomic term: single-token terms, or those with delimiters e.g.
|
||||
||| `[t]`
|
||||
|
||||
public export
|
||||
PCaseArm : Type
|
||||
PCaseArm = (PCasePat, PTerm)
|
||||
|
||||
export
|
||||
caseArm : FileName -> Grammar True PCaseArm
|
||||
caseArm fname =
|
||||
[|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
|
||||
|
||||
export
|
||||
checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody
|
||||
checkCaseArms loc [] = pure $ CaseEnum [] loc
|
||||
checkCaseArms loc ((PPair x y _, rhs) :: rest) =
|
||||
if null rest then pure $ CasePair (x, y) rhs loc
|
||||
else fatalError "unexpected pattern after pair"
|
||||
checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do
|
||||
let rest = for rest $ \case
|
||||
(PTag tag _, rhs) => Just (tag, rhs)
|
||||
_ => Nothing
|
||||
maybe (fatalError "expected all patterns to be tags")
|
||||
(\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest
|
||||
checkCaseArms loc ((PZero _, rhs1) :: rest) = do
|
||||
let [(PSucc p q ih _, rhs2)] = rest
|
||||
| _ => fatalError "expected succ pattern after zero"
|
||||
pure $ CaseNat rhs1 (p, q, ih, rhs2) loc
|
||||
checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do
|
||||
let [(PZero _, rhs2)] = rest
|
||||
| _ => fatalError "expected zero pattern after succ"
|
||||
pure $ CaseNat rhs2 (p, q, ih, rhs1) loc
|
||||
checkCaseArms loc ((PBox x _, rhs) :: rest) =
|
||||
if null rest then pure $ CaseBox x rhs loc
|
||||
else fatalError "unexpected pattern after box"
|
||||
|
||||
export
|
||||
caseBody : FileName -> Grammar True PCaseBody
|
||||
caseBody fname = do
|
||||
body <- bounds $ delimSep "{" "}" ";" $ caseArm fname
|
||||
let loc = makeLoc fname body.bounds
|
||||
checkCaseArms loc body.val
|
||||
|
||||
export
|
||||
caseReturn : FileName -> Grammar True (PatVar, PTerm)
|
||||
caseReturn fname = do
|
||||
x <- patVar fname <* resC "⇒" <|> unused fname
|
||||
ret <- assert_total term fname
|
||||
pure (x, ret)
|
||||
|
||||
export
|
||||
caseTerm : FileName -> Grammar True PTerm
|
||||
caseTerm fname = withLoc fname $ do
|
||||
qty <- caseIntro fname; commit
|
||||
head <- mustWork $ assert_total term fname; needRes "return"
|
||||
ret <- mustWork $ caseReturn fname; needRes "of"
|
||||
body <- mustWork $ caseBody fname
|
||||
pure $ Case qty head ret body
|
||||
|
||||
|
||||
||| argument/atomic term: single-token terms, or those with delimiters
|
||||
||| e.g. `[t]`. includes `case` because the end delimiter is the `}`.
|
||||
export
|
||||
termArg : FileName -> Grammar True PTerm
|
||||
termArg fname = withLoc fname $
|
||||
[|TYPE universe1|]
|
||||
<|> IOState <$ res "IOState"
|
||||
<|> [|Enum enumType|]
|
||||
<|> [|Tag tag|]
|
||||
<|> const <$> boxTerm fname
|
||||
<|> Nat <$ res "ℕ"
|
||||
<|> Zero <$ res "zero"
|
||||
<|> [|fromNat nat|]
|
||||
<|> NAT <$ res "ℕ"
|
||||
<|> Nat 0 <$ res "zero"
|
||||
<|> [|Nat nat|]
|
||||
<|> STRING <$ res "String"
|
||||
<|> [|Str strLit|]
|
||||
<|> [|V qname displacement|]
|
||||
<|> const <$> caseTerm fname
|
||||
<|> const <$> tupleTerm fname
|
||||
|
||||
export
|
||||
|
@ -369,10 +440,10 @@ eqTerm : FileName -> Grammar True PTerm
|
|||
eqTerm fname = withLoc fname $
|
||||
resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (termArg fname)|]
|
||||
|
||||
export
|
||||
succTerm : FileName -> Grammar True PTerm
|
||||
succTerm fname = withLoc fname $
|
||||
resC "succ" *> mustWork [|Succ (termArg fname)|]
|
||||
private
|
||||
appArg : Loc -> PTerm -> Either PDim PTerm -> PTerm
|
||||
appArg loc f (Left p) = DApp f p loc
|
||||
appArg loc f (Right s) = App f s loc
|
||||
|
||||
||| a dimension argument with an `@` prefix, or
|
||||
||| a term argument with no prefix
|
||||
|
@ -380,15 +451,32 @@ export
|
|||
anyArg : FileName -> Grammar True (Either PDim PTerm)
|
||||
anyArg fname = dimArg fname <||> termArg fname
|
||||
|
||||
export
|
||||
resAppTerm : FileName -> (word : String) -> (0 _ : IsReserved word) =>
|
||||
(PTerm -> Loc -> PTerm) -> Grammar True PTerm
|
||||
resAppTerm fname word f = withLoc fname $ do
|
||||
head <- withLoc fname $ resC word *> mustWork [|f (termArg fname)|]
|
||||
args <- many $ anyArg fname
|
||||
pure $ \loc => foldl (appArg loc) head args
|
||||
|
||||
export
|
||||
succTerm : FileName -> Grammar True PTerm
|
||||
succTerm fname = resAppTerm fname "succ" Succ
|
||||
|
||||
export
|
||||
fstTerm : FileName -> Grammar True PTerm
|
||||
fstTerm fname = resAppTerm fname "fst" Fst
|
||||
|
||||
export
|
||||
sndTerm : FileName -> Grammar True PTerm
|
||||
sndTerm fname = resAppTerm fname "snd" Snd
|
||||
|
||||
export
|
||||
normalAppTerm : FileName -> Grammar True PTerm
|
||||
normalAppTerm fname = withLoc fname $ do
|
||||
head <- termArg fname
|
||||
args <- many $ anyArg fname
|
||||
pure $ \loc => foldl (ap loc) head args
|
||||
where ap : Loc -> PTerm -> Either PDim PTerm -> PTerm
|
||||
ap loc f (Left p) = DApp f p loc
|
||||
ap loc f (Right s) = App f s loc
|
||||
pure $ \loc => foldl (appArg loc) head args
|
||||
|
||||
||| application term `f x @y z`, or other terms that look like application
|
||||
||| like `succ` or `coe`.
|
||||
|
@ -400,6 +488,8 @@ appTerm fname =
|
|||
<|> splitUniverseTerm fname
|
||||
<|> eqTerm fname
|
||||
<|> succTerm fname
|
||||
<|> fstTerm fname
|
||||
<|> sndTerm fname
|
||||
<|> normalAppTerm fname
|
||||
|
||||
export
|
||||
|
@ -438,18 +528,6 @@ properBinders fname = assert_total $ do
|
|||
t <- term fname; needRes ")"
|
||||
pure (xs, t)
|
||||
|
||||
export
|
||||
piTerm : FileName -> Grammar True PTerm
|
||||
piTerm fname = withLoc fname $ do
|
||||
q <- qty fname; resC "."
|
||||
dom <- piBinder; needRes "→"
|
||||
cod <- assert_total term fname; commit
|
||||
pure $ \loc => foldr (\x, t => Pi q x (snd dom) t loc) cod (fst dom)
|
||||
where
|
||||
piBinder : Grammar True (List1 PatVar, PTerm)
|
||||
piBinder = properBinders fname
|
||||
<|> [|(,) [|singleton $ unused fname|] (termArg fname)|]
|
||||
|
||||
export
|
||||
sigmaTerm : FileName -> Grammar True PTerm
|
||||
sigmaTerm fname =
|
||||
|
@ -470,105 +548,320 @@ where
|
|||
rest <- optional $ resC "×" *> sepBy1 (res "×") (annTerm fname)
|
||||
pure $ foldr1 cross $ fst ::: maybe [] toList rest
|
||||
|
||||
public export
|
||||
PCaseArm : Type
|
||||
PCaseArm = (PCasePat, PTerm)
|
||||
export
|
||||
piTerm : FileName -> Grammar True PTerm
|
||||
piTerm fname = withLoc fname $ do
|
||||
q <- [|GivenQ $ qty fname <* resC "."|] <|> defLoc fname DefaultQ
|
||||
dom <- [|Dep $ properBinders fname|] <|> [|Nondep $ ndDom q fname|]
|
||||
cod <- optional $ do resC "→"; assert_total term fname <* commit
|
||||
when (needCod q dom && isNothing cod) $ fail "missing function type result"
|
||||
pure $ maybe (const $ toTerm dom) (makePi q dom) cod
|
||||
where
|
||||
data PiQty = GivenQ PQty | DefaultQ Loc
|
||||
data PiDom = Dep (List1 PatVar, PTerm) | Nondep PTerm
|
||||
|
||||
ndDom : PiQty -> FileName -> Grammar True PTerm
|
||||
ndDom (GivenQ _) = termArg -- 「1.(List A)」, not 「1.List A」
|
||||
ndDom (DefaultQ _) = sigmaTerm
|
||||
|
||||
needCod : PiQty -> PiDom -> Bool
|
||||
needCod (DefaultQ _) (Nondep _) = False
|
||||
needCod _ _ = True
|
||||
|
||||
toTerm : PiDom -> PTerm
|
||||
toTerm (Dep (_, s)) = s
|
||||
toTerm (Nondep s) = s
|
||||
|
||||
toQty : PiQty -> PQty
|
||||
toQty (GivenQ qty) = qty
|
||||
toQty (DefaultQ loc) = PQ One loc
|
||||
|
||||
toDoms : PQty -> PiDom -> List1 (PQty, PatVar, PTerm)
|
||||
toDoms qty (Dep (xs, s)) = [(qty, x, s) | x <- xs]
|
||||
toDoms qty (Nondep s) = singleton (qty, Unused s.loc, s)
|
||||
|
||||
makePi : PiQty -> PiDom -> PTerm -> Loc -> PTerm
|
||||
makePi q doms cod loc =
|
||||
foldr (\(q, x, s), t => Pi q x s t loc) cod $ toDoms (toQty q) doms
|
||||
|
||||
|
||||
export
|
||||
caseArm : FileName -> Grammar True PCaseArm
|
||||
caseArm fname =
|
||||
[|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
|
||||
letIntro : FileName -> Grammar True (Maybe PQty)
|
||||
letIntro fname =
|
||||
withLoc fname (Just . PQ Zero <$ res "let0")
|
||||
<|> withLoc fname (Just . PQ One <$ res "let1")
|
||||
<|> withLoc fname (Just . PQ Any <$ res "letω")
|
||||
<|> Nothing <$ resC "let"
|
||||
|
||||
private
|
||||
letBinder : FileName -> Maybe PQty -> Grammar True (PQty, PatVar, PTerm)
|
||||
letBinder fname mq = do
|
||||
qty <- letQty fname mq
|
||||
x <- patVar fname
|
||||
type <- optional $ resC ":" *> term fname
|
||||
rhs <- resC "=" *> term fname
|
||||
pure (qty, x, makeLetRhs rhs type)
|
||||
where
|
||||
letQty : FileName -> Maybe PQty -> Grammar False PQty
|
||||
letQty fname Nothing = qty fname <* mustWork (resC ".") <|> defLoc fname (PQ One)
|
||||
letQty fname (Just q) = pure q
|
||||
|
||||
makeLetRhs : PTerm -> Maybe PTerm -> PTerm
|
||||
makeLetRhs tm ty = maybe tm (\t => Ann tm t (extendL tm.loc t.loc)) ty
|
||||
|
||||
export
|
||||
checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody
|
||||
checkCaseArms loc [] = pure $ CaseEnum [] loc
|
||||
checkCaseArms loc ((PPair x y _, rhs) :: rest) =
|
||||
if null rest then pure $ CasePair (x, y) rhs loc
|
||||
else fatalError "unexpected pattern after pair"
|
||||
checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do
|
||||
let rest = for rest $ \case
|
||||
(PTag tag _, rhs) => Just (tag, rhs)
|
||||
_ => Nothing
|
||||
maybe (fatalError "expected all patterns to be tags")
|
||||
(\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest
|
||||
checkCaseArms loc ((PZero _, rhs1) :: rest) = do
|
||||
let [(PSucc p q ih _, rhs2)] = rest
|
||||
| _ => fatalError "expected succ pattern after zero"
|
||||
pure $ CaseNat rhs1 (p, q, ih, rhs2) loc
|
||||
checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do
|
||||
let [(PZero _, rhs2)] = rest
|
||||
| _ => fatalError "expected zero pattern after succ"
|
||||
pure $ CaseNat rhs2 (p, q, ih, rhs1) loc
|
||||
checkCaseArms loc ((PBox x _, rhs) :: rest) =
|
||||
if null rest then pure $ CaseBox x rhs loc
|
||||
else fatalError "unexpected pattern after box"
|
||||
letTerm : FileName -> Grammar True PTerm
|
||||
letTerm fname = withLoc fname $ do
|
||||
qty <- letIntro fname
|
||||
binds <- sepEndBy1 (res ";") $ assert_total letBinder fname qty
|
||||
mustWork $ resC "in"
|
||||
body <- assert_total term fname
|
||||
pure $ \loc => foldr (\b, s => Let b s loc) body binds
|
||||
|
||||
export
|
||||
caseBody : FileName -> Grammar True PCaseBody
|
||||
caseBody fname = do
|
||||
body <- bounds $ delimSep "{" "}" ";" $ caseArm fname
|
||||
let loc = makeLoc fname body.bounds
|
||||
checkCaseArms loc body.val
|
||||
|
||||
export
|
||||
caseReturn : FileName -> Grammar True (PatVar, PTerm)
|
||||
caseReturn fname = do
|
||||
x <- patVar fname <* resC "⇒" <|> unused fname
|
||||
ret <- assert_total term fname
|
||||
pure (x, ret)
|
||||
|
||||
export
|
||||
caseTerm : FileName -> Grammar True PTerm
|
||||
caseTerm fname = withLoc fname $ do
|
||||
qty <- caseIntro fname; commit
|
||||
head <- mustWork $ assert_total term fname; needRes "return"
|
||||
ret <- mustWork $ caseReturn fname; needRes "of"
|
||||
body <- mustWork $ caseBody fname
|
||||
pure $ Case qty head ret body
|
||||
|
||||
-- export
|
||||
-- term : FileName -> Grammar True PTerm
|
||||
term fname = lamTerm fname
|
||||
<|> caseTerm fname
|
||||
<|> piTerm fname
|
||||
<|> sigmaTerm fname
|
||||
<|> letTerm fname
|
||||
|
||||
|
||||
export
|
||||
decl : FileName -> Grammar True PDecl
|
||||
attr' : FileName -> (o : String) -> (0 _ : IsReserved o) =>
|
||||
Grammar True PAttr
|
||||
attr' fname o = withLoc fname $ do
|
||||
resC o
|
||||
name <- baseName
|
||||
args <- many $ termArg fname
|
||||
mustWork $ resC "]"
|
||||
pure $ PA name args
|
||||
|
||||
export %inline
|
||||
attr : FileName -> Grammar True PAttr
|
||||
attr fname = attr' fname "#["
|
||||
|
||||
||| `def` alone means `defω`
|
||||
export
|
||||
defIntro : FileName -> Grammar True PQty
|
||||
defIntro fname =
|
||||
withLoc fname (PQ Zero <$ resC "def0")
|
||||
<|> withLoc fname (PQ Any <$ resC "defω")
|
||||
<|> do pos <- bounds $ resC "def"
|
||||
findDups : List PAttr -> List String
|
||||
findDups attrs =
|
||||
SortedSet.toList $ snd $ foldl check (empty, empty) attrs
|
||||
where
|
||||
Seen = SortedSet String; Dups = SortedSet String
|
||||
check : (Seen, Dups) -> PAttr -> (Seen, Dups)
|
||||
check (seen, dups) (PA a _ _) =
|
||||
(insert a seen, if contains a seen then insert a dups else dups)
|
||||
|
||||
export
|
||||
noDups : List PAttr -> Grammar False ()
|
||||
noDups attrs = do
|
||||
let dups = findDups attrs
|
||||
when (not $ null dups) $
|
||||
fatalError "duplicate attribute names: \{joinBy "," dups}"
|
||||
|
||||
export
|
||||
attrList : FileName -> Grammar False (List PAttr)
|
||||
attrList fname = do
|
||||
res <- many $ attr fname
|
||||
noDups res $> res
|
||||
|
||||
public export
|
||||
data AttrMatch a =
|
||||
Matched a
|
||||
| NoMatch String (List String)
|
||||
| Malformed String String
|
||||
|
||||
export
|
||||
Functor AttrMatch where
|
||||
map f (Matched x) = Matched $ f x
|
||||
map f (NoMatch s w) = NoMatch s w
|
||||
map f (Malformed a e) = Malformed a e
|
||||
|
||||
export
|
||||
(<|>) : AttrMatch a -> AttrMatch a -> AttrMatch a
|
||||
Matched x <|> _ = Matched x
|
||||
NoMatch {} <|> y = y
|
||||
Malformed a e <|> _ = Malformed a e
|
||||
|
||||
export
|
||||
isFail : PAttr -> List String -> AttrMatch PFail
|
||||
isFail (PA "fail" [] _) _ = Matched PFailAny
|
||||
isFail (PA "fail" [Str s _] _) _ = Matched $ PFailMatch s
|
||||
isFail (PA "fail" _ _) _ = Malformed "fail" "be absent or a string literal"
|
||||
isFail a w = NoMatch a.name w
|
||||
|
||||
export
|
||||
isMain : PAttr -> List String -> AttrMatch ()
|
||||
isMain (PA "main" [] _) _ = Matched ()
|
||||
isMain (PA "main" _ _) _ = Malformed "main" "have no arguments"
|
||||
isMain a w = NoMatch a.name w
|
||||
|
||||
export
|
||||
isScheme : PAttr -> List String -> AttrMatch String
|
||||
isScheme (PA "compile-scheme" [Str s _] _) _ = Matched s
|
||||
isScheme (PA "compile-scheme" _ _) _ =
|
||||
Malformed "compile-scheme" "be a string literal"
|
||||
isScheme a w = NoMatch a.name w
|
||||
|
||||
export
|
||||
matchAttr : String -> AttrMatch a -> Either String a
|
||||
matchAttr _ (Matched x) = Right x
|
||||
matchAttr d (NoMatch a w) = Left $ unlines
|
||||
["unrecognised \{d} attribute \{a}", "expected one of: \{show w}"]
|
||||
matchAttr _ (Malformed a s) = Left $ unlines
|
||||
["invalid \{a} attribute", "(should \{s})"]
|
||||
|
||||
export
|
||||
mkPDef : List PAttr -> PQty -> PBaseName -> PBody ->
|
||||
Either String (Loc -> PDefinition)
|
||||
mkPDef attrs qty name body = do
|
||||
let start = MkPDef qty name body PSucceed False Nothing noLoc
|
||||
res <- foldlM addAttr start attrs
|
||||
pure $ \l => {loc_ := l} (the PDefinition res)
|
||||
where
|
||||
data PDefAttr = DefFail PFail | DefMain | DefScheme String
|
||||
|
||||
isDefAttr : PAttr -> Either String PDefAttr
|
||||
isDefAttr attr =
|
||||
let defAttrs = ["fail", "main", "compile-scheme"] in
|
||||
matchAttr "definition" $
|
||||
DefFail <$> isFail attr defAttrs
|
||||
<|> DefMain <$ isMain attr defAttrs
|
||||
<|> DefScheme <$> isScheme attr defAttrs
|
||||
|
||||
addAttr : PDefinition -> PAttr -> Either String PDefinition
|
||||
addAttr def attr =
|
||||
case !(isDefAttr attr) of
|
||||
DefFail f => pure $ {fail := f} def
|
||||
DefMain => pure $ {main := True} def
|
||||
DefScheme str => pure $ {scheme := Just str} def
|
||||
|
||||
export
|
||||
mkPNamespace : List PAttr -> Mods -> List PDecl ->
|
||||
Either String (Loc -> PNamespace)
|
||||
mkPNamespace attrs name decls = do
|
||||
let start = MkPNamespace name decls PSucceed noLoc
|
||||
res <- foldlM addAttr start attrs
|
||||
pure $ \l => {loc_ := l} (the PNamespace res)
|
||||
where
|
||||
isNsAttr a = matchAttr "namespace" $ isFail a ["fail"]
|
||||
|
||||
addAttr : PNamespace -> PAttr -> Either String PNamespace
|
||||
addAttr ns attr = pure $ {fail := !(isNsAttr attr)} ns
|
||||
|
||||
||| `def` alone means `defω`; same for `postulate`
|
||||
export
|
||||
defIntro' : (bare, zero, omega : String) ->
|
||||
(0 _ : IsReserved bare) =>
|
||||
(0 _ : IsReserved zero) =>
|
||||
(0 _ : IsReserved omega) =>
|
||||
FileName -> Grammar True PQty
|
||||
defIntro' bare zero omega fname =
|
||||
withLoc fname (PQ Zero <$ resC zero)
|
||||
<|> withLoc fname (PQ Any <$ resC omega)
|
||||
<|> do pos <- bounds $ resC bare
|
||||
let any = PQ Any $ makeLoc fname pos.bounds
|
||||
option any $ qty fname <* needRes "."
|
||||
|
||||
export
|
||||
definition : FileName -> Grammar True PDefinition
|
||||
definition fname = withLoc fname $ do
|
||||
defIntro : FileName -> Grammar True PQty
|
||||
defIntro = defIntro' "def" "def0" "defω"
|
||||
|
||||
export
|
||||
postulateIntro : FileName -> Grammar True PQty
|
||||
postulateIntro = defIntro' "postulate" "postulate0" "postulateω"
|
||||
|
||||
export
|
||||
postulate : FileName -> List PAttr -> Grammar True PDefinition
|
||||
postulate fname attrs = withLoc fname $ do
|
||||
qty <- postulateIntro fname
|
||||
name <- baseName
|
||||
type <- resC ":" *> mustWork (term fname)
|
||||
optRes ";"
|
||||
either fatalError pure $ mkPDef attrs qty name $ PPostulate type
|
||||
|
||||
export
|
||||
concrete : FileName -> List PAttr -> Grammar True PDefinition
|
||||
concrete fname attrs = withLoc fname $ do
|
||||
qty <- defIntro fname
|
||||
name <- baseName
|
||||
type <- optional $ resC ":" *> mustWork (term fname)
|
||||
term <- needRes "=" *> mustWork (term fname)
|
||||
optRes ";"
|
||||
pure $ MkPDef qty name type term
|
||||
either fatalError pure $ mkPDef attrs qty name $ PConcrete type term
|
||||
|
||||
export
|
||||
namespace_ : FileName -> Grammar True PNamespace
|
||||
namespace_ fname = withLoc fname $ do
|
||||
ns <- resC "namespace" *> qname; needRes "{"
|
||||
decls <- nsInner; optRes ";"
|
||||
pure $ MkPNamespace (ns.mods :< ns.base) decls
|
||||
definition : FileName -> List PAttr -> Grammar True PDefinition
|
||||
definition fname attrs =
|
||||
try (postulate fname attrs) <|> concrete fname attrs
|
||||
|
||||
export
|
||||
nsname : Grammar True Mods
|
||||
nsname = do ns <- qname; pure $ ns.mods :< ns.base
|
||||
|
||||
export
|
||||
pragma : FileName -> Grammar True PPragma
|
||||
pragma fname = do
|
||||
a <- attr' fname "#!["
|
||||
either fatalError pure $ case a.name of
|
||||
"log" => logArgs a.args a.loc
|
||||
_ => Left $
|
||||
#"unrecognised pragma "\#{a.name}"\n"# ++
|
||||
#"known pragmas: ["log"]"#
|
||||
where
|
||||
levelOOB : Nat -> Either String a
|
||||
levelOOB n = Left $
|
||||
"log level \{show n} out of bounds\n" ++
|
||||
"expected number in range 0–\{show maxLogLevel} inclusive"
|
||||
|
||||
toLevel : Nat -> Either String LogLevel
|
||||
toLevel lvl = maybe (levelOOB lvl) Right $ toLogLevel lvl
|
||||
|
||||
unknownCat : String -> Either String a
|
||||
unknownCat cat = Left $
|
||||
"unknown log category \{show cat}\n" ++
|
||||
"known categories: \{show $ ["all", "default"] ++ logCategories}"
|
||||
|
||||
toCat : String -> Either String LogCategory
|
||||
toCat cat = maybe (unknownCat cat) Right $ toLogCategory cat
|
||||
|
||||
fromPair : PTerm -> Either String (String, Nat)
|
||||
fromPair (Pair (V (MkPName [<] x) Nothing _) (Nat n _) _) = Right (x, n)
|
||||
fromPair _ = Left "invalid argument to log pragma"
|
||||
|
||||
logCatArg : (String, Nat) -> Either String Log.PushArg
|
||||
logCatArg ("default", lvl) = [|SetDefault $ toLevel lvl|]
|
||||
logCatArg ("all", lvl) = [|SetAll $ toLevel lvl|]
|
||||
logCatArg (cat, lvl) = [|SetCat (toCat cat) (toLevel lvl)|]
|
||||
|
||||
logArgs : List PTerm -> Loc -> Either String PPragma
|
||||
logArgs [] _ = Left "missing arguments to log pragma"
|
||||
logArgs [V "pop" Nothing _] loc = Right $ PLogPop loc
|
||||
logArgs other loc = do
|
||||
args <- traverse (logCatArg <=< fromPair) other
|
||||
pure $ PLogPush args loc
|
||||
|
||||
|
||||
export
|
||||
decl : FileName -> Grammar True PDecl
|
||||
|
||||
export
|
||||
namespace_ : FileName -> List PAttr -> Grammar True PNamespace
|
||||
namespace_ fname attrs = withLoc fname $ do
|
||||
ns <- resC "namespace" *> nsname; needRes "{"
|
||||
decls <- nsInner
|
||||
either fatalError pure $ mkPNamespace attrs ns decls
|
||||
where
|
||||
nsInner : Grammar True (List PDecl)
|
||||
nsInner = [] <$ resC "}"
|
||||
<|> [|(assert_total decl fname <* commit) :: assert_total nsInner|]
|
||||
|
||||
decl fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|]
|
||||
export
|
||||
declBody : FileName -> List PAttr -> Grammar True PDecl
|
||||
declBody fname attrs =
|
||||
[|PDef $ definition fname attrs|] <|> [|PNs $ namespace_ fname attrs|]
|
||||
|
||||
-- decl : FileName -> Grammar True PDecl
|
||||
decl fname =
|
||||
(attrList fname >>= declBody fname)
|
||||
<|> PPrag <$> pragma fname
|
||||
|
||||
export
|
||||
load : FileName -> Grammar True PTopLevel
|
||||
|
@ -580,7 +873,7 @@ topLevel : FileName -> Grammar True PTopLevel
|
|||
topLevel fname = load fname <|> [|PD $ decl fname|]
|
||||
|
||||
export
|
||||
input : FileName -> Grammar False (List PTopLevel)
|
||||
input : FileName -> Grammar False PFile
|
||||
input fname = [] <$ eof
|
||||
<|> [|(topLevel fname <* commit) :: assert_total input fname|]
|
||||
|
||||
|
@ -589,5 +882,5 @@ lexParseTerm : FileName -> String -> Either Error PTerm
|
|||
lexParseTerm = lexParseWith . term
|
||||
|
||||
export
|
||||
lexParseInput : FileName -> String -> Either Error (List PTopLevel)
|
||||
lexParseInput : FileName -> String -> Either Error PFile
|
||||
lexParseInput = lexParseWith . input
|
||||
|
|
|
@ -3,6 +3,8 @@ module Quox.Parser.Syntax
|
|||
import public Quox.Loc
|
||||
import public Quox.Syntax
|
||||
import public Quox.Definition
|
||||
import Quox.PrettyValExtra
|
||||
import public Quox.Log
|
||||
|
||||
import Derive.Prelude
|
||||
%hide TT.Name
|
||||
|
@ -14,9 +16,9 @@ import Derive.Prelude
|
|||
public export
|
||||
data PatVar = Unused Loc | PV PBaseName Loc
|
||||
%name PatVar v
|
||||
%runElab derive "PatVar" [Eq, Ord, Show]
|
||||
%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PatVar where
|
||||
(Unused loc).loc = loc
|
||||
(PV _ loc).loc = loc
|
||||
|
@ -38,17 +40,17 @@ record PQty where
|
|||
val : Qty
|
||||
loc_ : Loc
|
||||
%name PQty qty
|
||||
%runElab derive "PQty" [Eq, Ord, Show]
|
||||
%runElab derive "PQty" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export Located PQty where q.loc = q.loc_
|
||||
export %inline Located PQty where q.loc = q.loc_
|
||||
|
||||
namespace PDim
|
||||
public export
|
||||
data PDim = K DimConst Loc | V PBaseName Loc
|
||||
%name PDim p, q
|
||||
%runElab derive "PDim" [Eq, Ord, Show]
|
||||
%runElab derive "PDim" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PDim where
|
||||
(K _ loc).loc = loc
|
||||
(V _ loc).loc = loc
|
||||
|
@ -56,7 +58,7 @@ Located PDim where
|
|||
public export
|
||||
data PTagVal = PT TagVal Loc
|
||||
%name PTagVal tag
|
||||
%runElab derive "PTagVal" [Eq, Ord, Show]
|
||||
%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
|
||||
namespace PTerm
|
||||
|
@ -66,6 +68,8 @@ namespace PTerm
|
|||
data PTerm =
|
||||
TYPE Universe Loc
|
||||
|
||||
| IOState Loc
|
||||
|
||||
| Pi PQty PatVar PTerm PTerm Loc
|
||||
| Lam PatVar PTerm Loc
|
||||
| App PTerm PTerm Loc
|
||||
|
@ -73,6 +77,7 @@ namespace PTerm
|
|||
| Sig PatVar PTerm PTerm Loc
|
||||
| Pair PTerm PTerm Loc
|
||||
| Case PQty PTerm (PatVar, PTerm) PCaseBody Loc
|
||||
| Fst PTerm Loc | Snd PTerm Loc
|
||||
|
||||
| Enum (List TagVal) Loc
|
||||
| Tag TagVal Loc
|
||||
|
@ -81,8 +86,11 @@ namespace PTerm
|
|||
| DLam PatVar PTerm Loc
|
||||
| DApp PTerm PDim Loc
|
||||
|
||||
| Nat Loc
|
||||
| Zero Loc | Succ PTerm Loc
|
||||
| NAT Loc
|
||||
| Nat Nat Loc | Succ PTerm Loc
|
||||
|
||||
| STRING Loc -- "String" is a reserved word in idris
|
||||
| Str String Loc
|
||||
|
||||
| BOX PQty PTerm Loc
|
||||
| Box PTerm Loc
|
||||
|
@ -93,6 +101,8 @@ namespace PTerm
|
|||
| Coe (PatVar, PTerm) PDim PDim PTerm Loc
|
||||
| Comp (PatVar, PTerm) PDim PDim PTerm PDim
|
||||
(PatVar, PTerm) (PatVar, PTerm) Loc
|
||||
|
||||
| Let (PQty, PatVar, PTerm) PTerm Loc
|
||||
%name PTerm s, t
|
||||
|
||||
public export
|
||||
|
@ -103,33 +113,43 @@ namespace PTerm
|
|||
| CaseBox PatVar PTerm Loc
|
||||
%name PCaseBody body
|
||||
|
||||
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
|
||||
public export %inline
|
||||
Zero : Loc -> PTerm
|
||||
Zero = Nat 0
|
||||
|
||||
export
|
||||
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export %inline
|
||||
Located PTerm where
|
||||
(TYPE _ loc).loc = loc
|
||||
(Pi _ _ _ _ loc).loc = loc
|
||||
(Lam _ _ loc).loc = loc
|
||||
(App _ _ loc).loc = loc
|
||||
(Sig _ _ _ loc).loc = loc
|
||||
(Pair _ _ loc).loc = loc
|
||||
(Case _ _ _ _ loc).loc = loc
|
||||
(Enum _ loc).loc = loc
|
||||
(Tag _ loc).loc = loc
|
||||
(Eq _ _ _ loc).loc = loc
|
||||
(DLam _ _ loc).loc = loc
|
||||
(DApp _ _ loc).loc = loc
|
||||
(Nat loc).loc = loc
|
||||
(Zero loc).loc = loc
|
||||
(Succ _ loc).loc = loc
|
||||
(BOX _ _ loc).loc = loc
|
||||
(Box _ loc).loc = loc
|
||||
(V _ _ loc).loc = loc
|
||||
(Ann _ _ loc).loc = loc
|
||||
(Coe _ _ _ _ loc).loc = loc
|
||||
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
||||
(TYPE _ loc).loc = loc
|
||||
(IOState loc).loc = loc
|
||||
(Pi _ _ _ _ loc).loc = loc
|
||||
(Lam _ _ loc).loc = loc
|
||||
(App _ _ loc).loc = loc
|
||||
(Sig _ _ _ loc).loc = loc
|
||||
(Pair _ _ loc).loc = loc
|
||||
(Fst _ loc).loc = loc
|
||||
(Snd _ loc).loc = loc
|
||||
(Case _ _ _ _ loc).loc = loc
|
||||
(Enum _ loc).loc = loc
|
||||
(Tag _ loc).loc = loc
|
||||
(Eq _ _ _ loc).loc = loc
|
||||
(DLam _ _ loc).loc = loc
|
||||
(DApp _ _ loc).loc = loc
|
||||
(NAT loc).loc = loc
|
||||
(Nat _ loc).loc = loc
|
||||
(Succ _ loc).loc = loc
|
||||
(STRING loc).loc = loc
|
||||
(Str _ loc).loc = loc
|
||||
(BOX _ _ loc).loc = loc
|
||||
(Box _ loc).loc = loc
|
||||
(V _ _ loc).loc = loc
|
||||
(Ann _ _ loc).loc = loc
|
||||
(Coe _ _ _ _ loc).loc = loc
|
||||
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
||||
(Let _ _ loc).loc = loc
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PCaseBody where
|
||||
(CasePair _ _ loc).loc = loc
|
||||
(CaseEnum _ loc).loc = loc
|
||||
|
@ -137,18 +157,45 @@ Located PCaseBody where
|
|||
(CaseBox _ _ loc).loc = loc
|
||||
|
||||
|
||||
public export
|
||||
data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm
|
||||
%name PBody body
|
||||
%runElab derive "PBody" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
|
||||
public export
|
||||
data PFail =
|
||||
PSucceed
|
||||
| PFailAny
|
||||
| PFailMatch String
|
||||
%runElab derive "PFail" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
public export
|
||||
record PDefinition where
|
||||
constructor MkPDef
|
||||
qty : PQty
|
||||
name : PBaseName
|
||||
type : Maybe PTerm
|
||||
term : PTerm
|
||||
loc_ : Loc
|
||||
qty : PQty
|
||||
name : PBaseName
|
||||
body : PBody
|
||||
fail : PFail
|
||||
main : Bool
|
||||
scheme : Maybe String
|
||||
loc_ : Loc
|
||||
%name PDefinition def
|
||||
%runElab derive "PDefinition" [Eq, Ord, Show]
|
||||
%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export Located PDefinition where def.loc = def.loc_
|
||||
export %inline Located PDefinition where def.loc = def.loc_
|
||||
|
||||
public export
|
||||
data PPragma =
|
||||
PLogPush (List Log.PushArg) Loc
|
||||
| PLogPop Loc
|
||||
%name PPragma prag
|
||||
%runElab derive "PPragma" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export %inline
|
||||
Located PPragma where
|
||||
(PLogPush _ loc).loc = loc
|
||||
(PLogPop loc).loc = loc
|
||||
|
||||
mutual
|
||||
public export
|
||||
|
@ -156,35 +203,49 @@ mutual
|
|||
constructor MkPNamespace
|
||||
name : Mods
|
||||
decls : List PDecl
|
||||
fail : PFail
|
||||
loc_ : Loc
|
||||
%name PNamespace ns
|
||||
|
||||
public export
|
||||
data PDecl =
|
||||
PDef PDefinition
|
||||
| PNs PNamespace
|
||||
PDef PDefinition
|
||||
| PNs PNamespace
|
||||
| PPrag PPragma
|
||||
%name PDecl decl
|
||||
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show]
|
||||
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export Located PNamespace where ns.loc = ns.loc_
|
||||
export %inline Located PNamespace where ns.loc = ns.loc_
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PDecl where
|
||||
(PDef def).loc = def.loc
|
||||
(PNs ns).loc = ns.loc
|
||||
(PDef d).loc = d.loc
|
||||
(PNs ns).loc = ns.loc
|
||||
(PPrag prag).loc = prag.loc
|
||||
|
||||
public export
|
||||
data PTopLevel = PD PDecl | PLoad String Loc
|
||||
%name PTopLevel t
|
||||
%runElab derive "PTopLevel" [Eq, Ord, Show]
|
||||
%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export
|
||||
export %inline
|
||||
Located PTopLevel where
|
||||
(PD decl).loc = decl.loc
|
||||
(PLoad _ loc).loc = loc
|
||||
|
||||
|
||||
public export
|
||||
fromNat : Nat -> Loc -> PTerm
|
||||
fromNat 0 loc = Zero loc
|
||||
fromNat (S k) loc = Succ (fromNat k loc) loc
|
||||
record PAttr where
|
||||
constructor PA
|
||||
name : PBaseName
|
||||
args : List PTerm
|
||||
loc_ : Loc
|
||||
%name PAttr attr
|
||||
%runElab derive "PAttr" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
export %inline Located PAttr where attr.loc = attr.loc_
|
||||
|
||||
|
||||
public export
|
||||
PFile : Type
|
||||
PFile = List PTopLevel
|
||||
|
|
|
@ -3,6 +3,7 @@ module Quox.Pretty
|
|||
import Quox.Loc
|
||||
import Quox.Name
|
||||
|
||||
import Control.Monad.ST.Extra
|
||||
import public Text.PrettyPrint.Bernardy
|
||||
import public Text.PrettyPrint.Bernardy.Core.Decorate
|
||||
import public Quox.EffExtra
|
||||
|
@ -40,7 +41,7 @@ data HL
|
|||
| Dim | DVar | DVarErr
|
||||
| Qty | Universe
|
||||
| Syntax
|
||||
| Tag
|
||||
| Constant
|
||||
%runElab derive "HL" [Eq, Ord, Show]
|
||||
|
||||
|
||||
|
@ -65,11 +66,12 @@ export %inline
|
|||
runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
|
||||
Eff Pretty a -> a
|
||||
runPrettyWith prec flavor highlight indent act =
|
||||
extract $
|
||||
evalStateAt PREC prec $
|
||||
runReaderAt FLAVOR flavor $
|
||||
runReaderAt HIGHLIGHT highlight $
|
||||
runReaderAt INDENT indent act
|
||||
runST $ do
|
||||
runEff act $ with Union.(::)
|
||||
[handleStateSTRef !(newSTRef prec),
|
||||
handleReaderConst flavor,
|
||||
handleReaderConst highlight,
|
||||
handleReaderConst indent]
|
||||
|
||||
|
||||
export %inline
|
||||
|
@ -84,43 +86,65 @@ toSGR DVarErr = [SetForeground BrightGreen, SetStyle SingleUnderline]
|
|||
toSGR Qty = [SetForeground BrightMagenta]
|
||||
toSGR Universe = [SetForeground BrightRed]
|
||||
toSGR Syntax = [SetForeground BrightCyan]
|
||||
toSGR Tag = [SetForeground BrightRed]
|
||||
toSGR Constant = [SetForeground BrightRed]
|
||||
|
||||
export %inline
|
||||
highlightSGR : HL -> Highlight
|
||||
highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
|
||||
|
||||
export %inline
|
||||
toClass : HL -> String
|
||||
toClass Delim = "dl"
|
||||
toClass Free = "fr"
|
||||
toClass TVar = "tv"
|
||||
toClass TVarErr = "tv err"
|
||||
toClass Dim = "dc"
|
||||
toClass DVar = "dv"
|
||||
toClass DVarErr = "dv err"
|
||||
toClass Qty = "qt"
|
||||
toClass Universe = "un"
|
||||
toClass Syntax = "sy"
|
||||
toClass Constant = "co"
|
||||
|
||||
export %inline
|
||||
highlightHtml : HL -> Highlight
|
||||
highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
|
||||
|
||||
|
||||
export %inline
|
||||
runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
|
||||
runPrettyHL f = runPrettyWith Outer Unicode f 2
|
||||
|
||||
export %inline
|
||||
runPretty : Eff Pretty a -> a
|
||||
runPretty = runPrettyWith Outer Unicode noHighlight 2
|
||||
|
||||
export %inline
|
||||
runPrettyColor : Eff Pretty a -> a
|
||||
runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
|
||||
runPretty = runPrettyHL noHighlight
|
||||
|
||||
|
||||
export %inline
|
||||
hl : {opts : _} -> HL -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hl : {opts : LayoutOpts} -> HL -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hl h doc = asksAt HIGHLIGHT $ \f => decorate (f h) doc
|
||||
|
||||
|
||||
export %inline
|
||||
indentD : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
indentD : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
indentD doc = pure $ indent !(askAt INDENT) doc
|
||||
|
||||
export %inline
|
||||
hangD : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hangD : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
|
||||
|
||||
export %inline
|
||||
hangDSingle : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
|
||||
hangDSingle d1 d2 =
|
||||
pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2))
|
||||
hangSingle : {opts : LayoutOpts} -> Nat -> Doc opts -> Doc opts -> Doc opts
|
||||
hangSingle n d1 d2 = ifMultiline (d1 <++> d2) (vappend d1 (indent n d2))
|
||||
|
||||
export %inline
|
||||
hangDSingle : {opts : LayoutOpts} -> Doc opts -> Doc opts ->
|
||||
Eff Pretty (Doc opts)
|
||||
hangDSingle d1 d2 = pure $ hangSingle !(askAt INDENT) d1 d2
|
||||
|
||||
|
||||
export
|
||||
tightDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
|
||||
tightDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
|
||||
Eff Pretty (Doc opts)
|
||||
tightDelims l r inner = do
|
||||
l <- hl Delim $ text l
|
||||
|
@ -128,7 +152,7 @@ tightDelims l r inner = do
|
|||
pure $ hcat [l, inner, r]
|
||||
|
||||
export
|
||||
looseDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
|
||||
looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
|
||||
Eff Pretty (Doc opts)
|
||||
looseDelims l r inner = do
|
||||
l <- hl Delim $ text l
|
||||
|
@ -138,39 +162,39 @@ looseDelims l r inner = do
|
|||
pure $ ifMultiline short long
|
||||
|
||||
export %inline
|
||||
parens : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parens = tightDelims "(" ")"
|
||||
|
||||
export %inline
|
||||
bracks : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
bracks = tightDelims "[" "]"
|
||||
|
||||
export %inline
|
||||
braces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
braces = looseDelims "{" "}"
|
||||
|
||||
export %inline
|
||||
tightBraces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
|
||||
tightBraces = tightDelims "{" "}"
|
||||
|
||||
export %inline
|
||||
parensIf : {opts : _} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parensIf : {opts : LayoutOpts} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parensIf True = parens
|
||||
parensIf False = pure
|
||||
|
||||
|
||||
||| uses hsep only if the whole list fits on one line
|
||||
export
|
||||
sepSingle : {opts : _} -> List (Doc opts) -> Doc opts
|
||||
sepSingle : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
|
||||
sepSingle xs = ifMultiline (hsep xs) (vsep xs)
|
||||
|
||||
export
|
||||
fillSep : {opts : _} -> List (Doc opts) -> Doc opts
|
||||
fillSep : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
|
||||
fillSep [] = empty
|
||||
fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
|
||||
|
||||
export
|
||||
exceptLast : {opts : _} -> (Doc opts -> Doc opts) ->
|
||||
exceptLast : {opts : LayoutOpts} -> (Doc opts -> Doc opts) ->
|
||||
List (Doc opts) -> List (Doc opts)
|
||||
exceptLast f [] = []
|
||||
exceptLast f [x] = [x]
|
||||
|
@ -185,11 +209,24 @@ parameters {opts : LayoutOpts} {auto _ : Foldable t}
|
|||
separateTight : Doc opts -> t (Doc opts) -> Doc opts
|
||||
separateTight d = sep . exceptLast (<+> d) . toList
|
||||
|
||||
export
|
||||
hseparateTight : Doc opts -> t (Doc opts) -> Doc opts
|
||||
hseparateTight d = hsep . exceptLast (<+> d) . toList
|
||||
|
||||
export
|
||||
vseparateTight : Doc opts -> t (Doc opts) -> Doc opts
|
||||
vseparateTight d = vsep . exceptLast (<+> d) . toList
|
||||
|
||||
export
|
||||
fillSeparateTight : Doc opts -> t (Doc opts) -> Doc opts
|
||||
fillSeparateTight d = fillSep . exceptLast (<+> d) . toList
|
||||
|
||||
|
||||
export %inline
|
||||
pshow : {opts : LayoutOpts} -> Show a => a -> Doc opts
|
||||
pshow = text . show
|
||||
|
||||
|
||||
export %inline
|
||||
ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a
|
||||
ifUnicode uni asc =
|
||||
|
@ -198,7 +235,7 @@ ifUnicode uni asc =
|
|||
Ascii => asc
|
||||
|
||||
export %inline
|
||||
parensIfM : {opts : _} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
|
||||
parensIfM d doc = parensIf (!(getAt PREC) > d) doc
|
||||
|
||||
export %inline
|
||||
|
@ -211,64 +248,73 @@ prettyName : Name -> Doc opts
|
|||
prettyName = text . toDots
|
||||
|
||||
export
|
||||
prettyFree : {opts : _} -> Name -> Eff Pretty (Doc opts)
|
||||
prettyFree : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts)
|
||||
prettyFree = hl Free . prettyName
|
||||
|
||||
export
|
||||
prettyBind' : BindName -> Doc opts
|
||||
prettyBind' = text . baseStr . name
|
||||
prettyBind' = text . baseStr . val
|
||||
|
||||
export
|
||||
prettyTBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
|
||||
prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
|
||||
prettyTBind = hl TVar . prettyBind'
|
||||
|
||||
export
|
||||
prettyDBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
|
||||
prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
|
||||
prettyDBind = hl DVar . prettyBind'
|
||||
|
||||
|
||||
|
||||
export %inline
|
||||
typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
|
||||
eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
|
||||
ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD :
|
||||
{opts : _} -> Eff Pretty (Doc opts)
|
||||
typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
|
||||
stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD,
|
||||
zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD :
|
||||
{opts : LayoutOpts} -> Eff Pretty (Doc opts)
|
||||
typeD = hl Syntax . text =<< ifUnicode "★" "Type"
|
||||
arrowD = hl Delim . text =<< ifUnicode "→" "->"
|
||||
darrowD = hl Delim . text =<< ifUnicode "⇒" "=>"
|
||||
timesD = hl Delim . text =<< ifUnicode "×" "**"
|
||||
ioStateD = hl Syntax $ text "IOState"
|
||||
arrowD = hl Syntax . text =<< ifUnicode "→" "->"
|
||||
darrowD = hl Syntax . text =<< ifUnicode "⇒" "=>"
|
||||
timesD = hl Syntax . text =<< ifUnicode "×" "**"
|
||||
lamD = hl Syntax . text =<< ifUnicode "λ" "fun"
|
||||
eqndD = hl Delim . text =<< ifUnicode "≡" "=="
|
||||
eqndD = hl Syntax . text =<< ifUnicode "≡" "=="
|
||||
dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun"
|
||||
annD = hl Delim . text =<< ifUnicode "∷" "::"
|
||||
annD = hl Syntax . text =<< ifUnicode "∷" "::"
|
||||
natD = hl Syntax . text =<< ifUnicode "ℕ" "Nat"
|
||||
eqD = hl Syntax $ text "Eq"
|
||||
colonD = hl Delim $ text ":"
|
||||
commaD = hl Delim $ text ","
|
||||
semiD = hl Delim $ text ";"
|
||||
caseD = hl Syntax $ text "case"
|
||||
typecaseD = hl Syntax $ text "type-case"
|
||||
ofD = hl Syntax $ text "of"
|
||||
returnD = hl Syntax $ text "return"
|
||||
dotD = hl Delim $ text "."
|
||||
zeroD = hl Syntax $ text "zero"
|
||||
succD = hl Syntax $ text "succ"
|
||||
coeD = hl Syntax $ text "coe"
|
||||
compD = hl Syntax $ text "comp"
|
||||
undD = hl Syntax $ text "_"
|
||||
cstD = hl Syntax $ text "="
|
||||
pipeD = hl Syntax $ text "|"
|
||||
stringD = hl Syntax $ text "String"
|
||||
eqD = hl Syntax $ text "Eq"
|
||||
colonD = hl Syntax $ text ":"
|
||||
commaD = hl Syntax $ text ","
|
||||
semiD = hl Delim $ text ";"
|
||||
atD = hl Delim $ text "@"
|
||||
caseD = hl Syntax $ text "case"
|
||||
typecaseD = hl Syntax $ text "type-case"
|
||||
ofD = hl Syntax $ text "of"
|
||||
returnD = hl Syntax $ text "return"
|
||||
dotD = hl Delim $ text "."
|
||||
zeroD = hl Constant $ text "zero"
|
||||
succD = hl Constant $ text "succ"
|
||||
coeD = hl Syntax $ text "coe"
|
||||
compD = hl Syntax $ text "comp"
|
||||
undD = hl Syntax $ text "_"
|
||||
cstD = hl Syntax $ text "="
|
||||
pipeD = hl Delim $ text "|"
|
||||
fstD = hl Syntax $ text "fst"
|
||||
sndD = hl Syntax $ text "snd"
|
||||
letD = hl Syntax $ text "let"
|
||||
inD = hl Syntax $ text "in"
|
||||
|
||||
|
||||
export
|
||||
prettyApp : {opts : _} -> Nat -> Doc opts -> List (Doc opts) -> Doc opts
|
||||
prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
|
||||
List (Doc opts) -> Doc opts
|
||||
prettyApp ind f args =
|
||||
hsep (f :: args)
|
||||
<|> hsep [f, vsep args]
|
||||
<|> vsep (f :: map (indent ind) args)
|
||||
ifMultiline
|
||||
(hsep (f :: args))
|
||||
(f <++> vsep args <|> vsep (f :: map (indent ind) args))
|
||||
|
||||
export
|
||||
prettyAppD : {opts : _} -> Doc opts -> List (Doc opts) -> Eff Pretty (Doc opts)
|
||||
prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
|
||||
Eff Pretty (Doc opts)
|
||||
prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
|
||||
|
||||
|
||||
|
@ -288,7 +334,7 @@ quoteTag tag =
|
|||
"\"" ++ escapeString tag ++ "\""
|
||||
|
||||
export
|
||||
prettyBounds : {opts : _} -> Bounds -> Eff Pretty (Doc opts)
|
||||
prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
|
||||
prettyBounds (MkBounds l1 c1 l2 c2) =
|
||||
hcat <$> sequence
|
||||
[hl TVar $ text $ show l1, colonD,
|
||||
|
@ -297,8 +343,22 @@ prettyBounds (MkBounds l1 c1 l2 c2) =
|
|||
hl DVar $ text $ show c2, colonD]
|
||||
|
||||
export
|
||||
prettyLoc : {opts : _} -> Loc -> Eff Pretty (Doc opts)
|
||||
prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
|
||||
prettyLoc (L NoLoc) =
|
||||
hcat <$> sequence [hl TVarErr "no location", colonD]
|
||||
prettyLoc (L (YesLoc file b)) =
|
||||
hcat <$> sequence [hl Free $ text file, colonD, prettyBounds b]
|
||||
|
||||
export
|
||||
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
|
||||
prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
|
||||
|
||||
export
|
||||
prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
|
||||
prettyStrLit s =
|
||||
let s = concatMap esc1 $ unpack s in
|
||||
hl Constant $ hcat ["\"", text s, "\""]
|
||||
where
|
||||
esc1 : Char -> String
|
||||
esc1 '"' = "\""; esc1 '\\' = "\\"
|
||||
esc1 c = singleton c
|
||||
|
|
20
lib/Quox/PrettyValExtra.idr
Normal file
20
lib/Quox/PrettyValExtra.idr
Normal file
|
@ -0,0 +1,20 @@
|
|||
module Quox.PrettyValExtra
|
||||
|
||||
import Data.DPair
|
||||
import Derive.Prelude
|
||||
import public Text.Show.Value
|
||||
import public Text.Show.PrettyVal
|
||||
import public Text.Show.PrettyVal.Derive
|
||||
|
||||
%language ElabReflection
|
||||
|
||||
%runElab derive "SnocList" [PrettyVal]
|
||||
|
||||
|
||||
export %inline
|
||||
PrettyVal a => PrettyVal (Subset a p) where
|
||||
prettyVal (Element x _) = Con "Element" [prettyVal x, Con "_" []]
|
||||
|
||||
export %inline
|
||||
(forall x. PrettyVal (p x)) => PrettyVal (Exists p) where
|
||||
prettyVal (Evidence _ p) = Con "Evidence" [Con "_" [], prettyVal p]
|
|
@ -1,751 +0,0 @@
|
|||
module Quox.Reduce
|
||||
|
||||
import Quox.No
|
||||
import Quox.Syntax
|
||||
import Quox.Definition
|
||||
import Quox.Displace
|
||||
import Quox.Typing.Context
|
||||
import Quox.Typing.Error
|
||||
import Data.SnocVect
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import Control.Eff
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
Whnf : List (Type -> Type)
|
||||
Whnf = [NameGen, Except Error]
|
||||
|
||||
export
|
||||
runWhnfWith : NameSuf -> Eff Whnf a -> (Either Error a, NameSuf)
|
||||
runWhnfWith suf act = extract $ runStateAt GEN suf $ runExcept act
|
||||
|
||||
export
|
||||
runWhnf : Eff Whnf a -> Either Error a
|
||||
runWhnf = fst . runWhnfWith 0
|
||||
|
||||
|
||||
public export
|
||||
0 RedexTest : TermLike -> Type
|
||||
RedexTest tm = {d, n : Nat} -> Definitions -> tm d n -> Bool
|
||||
|
||||
public export
|
||||
interface CanWhnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm
|
||||
where
|
||||
whnf : {d, n : Nat} -> (defs : Definitions) ->
|
||||
(ctx : WhnfContext d n) ->
|
||||
tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs))
|
||||
|
||||
public export %inline
|
||||
whnf0 : {d, n : Nat} -> {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
|
||||
(defs : Definitions) -> WhnfContext d n -> tm d n -> Eff Whnf (tm d n)
|
||||
whnf0 defs ctx t = fst <$> whnf defs ctx t
|
||||
|
||||
public export
|
||||
0 IsRedex, NotRedex : {isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
|
||||
Definitions -> Pred (tm d n)
|
||||
IsRedex defs = So . isRedex defs
|
||||
NotRedex defs = No . isRedex defs
|
||||
|
||||
public export
|
||||
0 NonRedex : (tm : TermLike) -> {isRedex : RedexTest tm} ->
|
||||
CanWhnf tm isRedex => (d, n : Nat) -> (defs : Definitions) -> Type
|
||||
NonRedex tm d n defs = Subset (tm d n) (NotRedex defs)
|
||||
|
||||
public export %inline
|
||||
nred : {0 isRedex : RedexTest tm} -> (0 _ : CanWhnf tm isRedex) =>
|
||||
(t : tm d n) -> (0 nr : NotRedex defs t) => NonRedex tm d n defs
|
||||
nred t = Element t nr
|
||||
|
||||
|
||||
public export %inline
|
||||
isLamHead : Elim {} -> Bool
|
||||
isLamHead (Ann (Lam {}) (Pi {}) _) = True
|
||||
isLamHead (Coe {}) = True
|
||||
isLamHead _ = False
|
||||
|
||||
public export %inline
|
||||
isDLamHead : Elim {} -> Bool
|
||||
isDLamHead (Ann (DLam {}) (Eq {}) _) = True
|
||||
isDLamHead (Coe {}) = True
|
||||
isDLamHead _ = False
|
||||
|
||||
public export %inline
|
||||
isPairHead : Elim {} -> Bool
|
||||
isPairHead (Ann (Pair {}) (Sig {}) _) = True
|
||||
isPairHead (Coe {}) = True
|
||||
isPairHead _ = False
|
||||
|
||||
public export %inline
|
||||
isTagHead : Elim {} -> Bool
|
||||
isTagHead (Ann (Tag {}) (Enum {}) _) = True
|
||||
isTagHead (Coe {}) = True
|
||||
isTagHead _ = False
|
||||
|
||||
public export %inline
|
||||
isNatHead : Elim {} -> Bool
|
||||
isNatHead (Ann (Zero {}) (Nat {}) _) = True
|
||||
isNatHead (Ann (Succ {}) (Nat {}) _) = True
|
||||
isNatHead (Coe {}) = True
|
||||
isNatHead _ = False
|
||||
|
||||
public export %inline
|
||||
isBoxHead : Elim {} -> Bool
|
||||
isBoxHead (Ann (Box {}) (BOX {}) _) = True
|
||||
isBoxHead (Coe {}) = True
|
||||
isBoxHead _ = False
|
||||
|
||||
public export %inline
|
||||
isE : Term {} -> Bool
|
||||
isE (E {}) = True
|
||||
isE _ = False
|
||||
|
||||
public export %inline
|
||||
isAnn : Elim {} -> Bool
|
||||
isAnn (Ann {}) = True
|
||||
isAnn _ = False
|
||||
|
||||
||| true if a term is syntactically a type.
|
||||
public export %inline
|
||||
isTyCon : Term {} -> Bool
|
||||
isTyCon (TYPE {}) = True
|
||||
isTyCon (Pi {}) = True
|
||||
isTyCon (Lam {}) = False
|
||||
isTyCon (Sig {}) = True
|
||||
isTyCon (Pair {}) = False
|
||||
isTyCon (Enum {}) = True
|
||||
isTyCon (Tag {}) = False
|
||||
isTyCon (Eq {}) = True
|
||||
isTyCon (DLam {}) = False
|
||||
isTyCon (Nat {}) = True
|
||||
isTyCon (Zero {}) = False
|
||||
isTyCon (Succ {}) = False
|
||||
isTyCon (BOX {}) = True
|
||||
isTyCon (Box {}) = False
|
||||
isTyCon (E {}) = False
|
||||
isTyCon (CloT {}) = False
|
||||
isTyCon (DCloT {}) = False
|
||||
|
||||
||| true if a term is syntactically a type, or a neutral.
|
||||
public export %inline
|
||||
isTyConE : Term {} -> Bool
|
||||
isTyConE s = isTyCon s || isE s
|
||||
|
||||
||| true if a term is syntactically a type.
|
||||
public export %inline
|
||||
isAnnTyCon : Elim {} -> Bool
|
||||
isAnnTyCon (Ann ty (TYPE {}) _) = isTyCon ty
|
||||
isAnnTyCon _ = False
|
||||
|
||||
public export %inline
|
||||
isK : Dim d -> Bool
|
||||
isK (K {}) = True
|
||||
isK _ = False
|
||||
|
||||
|
||||
mutual
|
||||
public export
|
||||
isRedexE : RedexTest Elim
|
||||
isRedexE defs (F {x, _}) {d, n} =
|
||||
isJust $ lookupElim x defs {d, n}
|
||||
isRedexE _ (B {}) = False
|
||||
isRedexE defs (App {fun, _}) =
|
||||
isRedexE defs fun || isLamHead fun
|
||||
isRedexE defs (CasePair {pair, _}) =
|
||||
isRedexE defs pair || isPairHead pair
|
||||
isRedexE defs (CaseEnum {tag, _}) =
|
||||
isRedexE defs tag || isTagHead tag
|
||||
isRedexE defs (CaseNat {nat, _}) =
|
||||
isRedexE defs nat || isNatHead nat
|
||||
isRedexE defs (CaseBox {box, _}) =
|
||||
isRedexE defs box || isBoxHead box
|
||||
isRedexE defs (DApp {fun, arg, _}) =
|
||||
isRedexE defs fun || isDLamHead fun || isK arg
|
||||
isRedexE defs (Ann {tm, ty, _}) =
|
||||
isE tm || isRedexT defs tm || isRedexT defs ty
|
||||
isRedexE defs (Coe {val, _}) =
|
||||
isRedexT defs val || not (isE val)
|
||||
isRedexE defs (Comp {ty, r, _}) =
|
||||
isRedexT defs ty || isK r
|
||||
isRedexE defs (TypeCase {ty, ret, _}) =
|
||||
isRedexE defs ty || isRedexT defs ret || isAnnTyCon ty
|
||||
isRedexE _ (CloE {}) = True
|
||||
isRedexE _ (DCloE {}) = True
|
||||
|
||||
public export
|
||||
isRedexT : RedexTest Term
|
||||
isRedexT _ (CloT {}) = True
|
||||
isRedexT _ (DCloT {}) = True
|
||||
isRedexT defs (E {e, _}) = isAnn e || isRedexE defs e
|
||||
isRedexT _ _ = False
|
||||
|
||||
|
||||
public export
|
||||
tycaseRhs : (k : TyConKind) -> TypeCaseArms d n ->
|
||||
Maybe (ScopeTermN (arity k) d n)
|
||||
tycaseRhs k arms = lookupPrecise k arms
|
||||
|
||||
public export
|
||||
tycaseRhsDef : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
|
||||
ScopeTermN (arity k) d n
|
||||
tycaseRhsDef def k arms = fromMaybe (SN def) $ tycaseRhs k arms
|
||||
|
||||
public export
|
||||
tycaseRhs0 : (k : TyConKind) -> TypeCaseArms d n ->
|
||||
(0 eq : arity k = 0) => Maybe (Term d n)
|
||||
tycaseRhs0 k arms {eq} with (tycaseRhs k arms) | (arity k)
|
||||
tycaseRhs0 k arms {eq = Refl} | res | 0 = map (.term) res
|
||||
|
||||
public export
|
||||
tycaseRhsDef0 : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
|
||||
(0 eq : arity k = 0) => Term d n
|
||||
tycaseRhsDef0 def k arms = fromMaybe def $ tycaseRhs0 k arms
|
||||
|
||||
|
||||
|
||||
private
|
||||
weakDS : (by : Nat) -> DScopeTerm d n -> DScopeTerm d (by + n)
|
||||
weakDS by (S names (Y body)) = S names $ Y $ weakT by body
|
||||
weakDS by (S names (N body)) = S names $ N $ weakT by body
|
||||
|
||||
private
|
||||
dweakS : (by : Nat) -> ScopeTerm d n -> ScopeTerm (by + d) n
|
||||
dweakS by (S names (Y body)) = S names $ Y $ dweakT by body
|
||||
dweakS by (S names (N body)) = S names $ N $ dweakT by body
|
||||
|
||||
private
|
||||
coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc ->
|
||||
ScopeTermN s d n -> ScopeTermN s d n
|
||||
coeScoped ty p q loc (S names (Y body)) =
|
||||
S names $ Y $ E $ Coe (weakDS s ty) p q body loc
|
||||
coeScoped ty p q loc (S names (N body)) =
|
||||
S names $ N $ E $ Coe ty p q body loc
|
||||
|
||||
|
||||
export covering
|
||||
CanWhnf Term Reduce.isRedexT
|
||||
|
||||
export covering
|
||||
CanWhnf Elim Reduce.isRedexE
|
||||
|
||||
parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
|
||||
||| performs the minimum work required to recompute the type of an elim.
|
||||
|||
|
||||
||| ⚠ **assumes the elim is already typechecked.** ⚠
|
||||
export covering
|
||||
computeElimType : (e : Elim d n) -> (0 ne : No (isRedexE defs e)) =>
|
||||
Eff Whnf (Term d n)
|
||||
computeElimType (F {x, u, loc}) = do
|
||||
let Just def = lookup x defs | Nothing => throw $ NotInScope loc x
|
||||
pure $ displace u def.type
|
||||
computeElimType (B {i, _}) = pure $ ctx.tctx !! i
|
||||
computeElimType (App {fun = f, arg = s, loc}) {ne} = do
|
||||
Pi {arg, res, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne}
|
||||
| t => throw $ ExpectedPi loc ctx.names t
|
||||
pure $ sub1 res $ Ann s arg loc
|
||||
computeElimType (CasePair {pair, ret, _}) = pure $ sub1 ret pair
|
||||
computeElimType (CaseEnum {tag, ret, _}) = pure $ sub1 ret tag
|
||||
computeElimType (CaseNat {nat, ret, _}) = pure $ sub1 ret nat
|
||||
computeElimType (CaseBox {box, ret, _}) = pure $ sub1 ret box
|
||||
computeElimType (DApp {fun = f, arg = p, loc}) {ne} = do
|
||||
Eq {ty, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne}
|
||||
| t => throw $ ExpectedEq loc ctx.names t
|
||||
pure $ dsub1 ty p
|
||||
computeElimType (Ann {ty, _}) = pure ty
|
||||
computeElimType (Coe {ty, q, _}) = pure $ dsub1 ty q
|
||||
computeElimType (Comp {ty, _}) = pure ty
|
||||
computeElimType (TypeCase {ret, _}) = pure ret
|
||||
|
||||
parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext (S d) n)
|
||||
||| for π.(x : A) → B, returns (A, B);
|
||||
||| for an elim returns a pair of type-cases that will reduce to that;
|
||||
||| for other intro forms error
|
||||
private covering
|
||||
tycasePi : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
|
||||
Eff Whnf (Term (S d) n, ScopeTerm (S d) n)
|
||||
tycasePi (Pi {arg, res, _}) = pure (arg, res)
|
||||
tycasePi (E e) {tnf} = do
|
||||
ty <- computeElimType defs ctx e @{noOr2 tnf}
|
||||
let loc = e.loc
|
||||
narg = mnb "Arg"; nret = mnb "Ret"
|
||||
arg = E $ typeCase1Y e ty KPi [< !narg, !nret] (BVT 1 loc) loc
|
||||
res' = typeCase1Y e (Arr Zero arg ty loc) KPi [< !narg, !nret]
|
||||
(BVT 0 loc) loc
|
||||
res = SY [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc
|
||||
pure (arg, res)
|
||||
tycasePi t = throw $ ExpectedPi t.loc ctx.names t
|
||||
|
||||
||| for (x : A) × B, returns (A, B);
|
||||
||| for an elim returns a pair of type-cases that will reduce to that;
|
||||
||| for other intro forms error
|
||||
private covering
|
||||
tycaseSig : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
|
||||
Eff Whnf (Term (S d) n, ScopeTerm (S d) n)
|
||||
tycaseSig (Sig {fst, snd, _}) = pure (fst, snd)
|
||||
tycaseSig (E e) {tnf} = do
|
||||
ty <- computeElimType defs ctx e @{noOr2 tnf}
|
||||
let loc = e.loc
|
||||
nfst = mnb "Fst"; nsnd = mnb "Snd"
|
||||
fst = E $ typeCase1Y e ty KSig [< !nfst, !nsnd] (BVT 1 loc) loc
|
||||
snd' = typeCase1Y e (Arr Zero fst ty loc) KSig [< !nfst, !nsnd]
|
||||
(BVT 0 loc) loc
|
||||
snd = SY [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc
|
||||
pure (fst, snd)
|
||||
tycaseSig t = throw $ ExpectedSig t.loc ctx.names t
|
||||
|
||||
||| for [π. A], returns A;
|
||||
||| for an elim returns a type-case that will reduce to that;
|
||||
||| for other intro forms error
|
||||
private covering
|
||||
tycaseBOX : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
|
||||
Eff Whnf (Term (S d) n)
|
||||
tycaseBOX (BOX {ty, _}) = pure ty
|
||||
tycaseBOX (E e) {tnf} = do
|
||||
ty <- computeElimType defs ctx e @{noOr2 tnf}
|
||||
pure $ E $ typeCase1Y e ty KBOX [< !(mnb "Ty")] (BVT 0 e.loc) e.loc
|
||||
tycaseBOX t = throw $ ExpectedBOX t.loc ctx.names t
|
||||
|
||||
||| for Eq [i ⇒ A] l r, returns (A‹0/i›, A‹1/i›, A, l, r);
|
||||
||| for an elim returns five type-cases that will reduce to that;
|
||||
||| for other intro forms error
|
||||
private covering
|
||||
tycaseEq : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
|
||||
Eff Whnf (Term (S d) n, Term (S d) n, DScopeTerm (S d) n,
|
||||
Term (S d) n, Term (S d) n)
|
||||
tycaseEq (Eq {ty, l, r, _}) = pure (ty.zero, ty.one, ty, l, r)
|
||||
tycaseEq (E e) {tnf} = do
|
||||
ty <- computeElimType defs ctx e @{noOr2 tnf}
|
||||
let loc = e.loc
|
||||
names = traverse' (\x => mnb x) [< "A0", "A1", "A", "L", "R"]
|
||||
a0 = E $ typeCase1Y e ty KEq !names (BVT 4 loc) loc
|
||||
a1 = E $ typeCase1Y e ty KEq !names (BVT 3 loc) loc
|
||||
a' = typeCase1Y e (Eq0 ty a0 a1 loc) KEq !names (BVT 2 loc) loc
|
||||
a = SY [< !(mnb "i")] $ E $ DApp (dweakE 1 a') (B VZ loc) loc
|
||||
l = E $ typeCase1Y e a0 KEq !names (BVT 1 loc) loc
|
||||
r = E $ typeCase1Y e a1 KEq !names (BVT 0 loc) loc
|
||||
pure (a0, a1, a, l, r)
|
||||
tycaseEq t = throw $ ExpectedEq t.loc ctx.names t
|
||||
|
||||
-- new block because the functions below might pass a different ctx
|
||||
-- into the ones above
|
||||
parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
|
||||
||| reduce a function application `App (Coe ty p q val) s loc`
|
||||
private covering
|
||||
piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
|
||||
(val, s : Term d n) -> Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
piCoe sty@(S [< i] ty) p q val s loc = do
|
||||
-- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝
|
||||
-- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›)
|
||||
-- where 𝒔‹j› ≔ coe [i ⇒ A] @q @j s
|
||||
--
|
||||
-- type-case is used to expose A,B if the type is neutral
|
||||
let ctx1 = extendDim i ctx
|
||||
Element ty tynf <- whnf defs ctx1 ty.term
|
||||
(arg, res) <- tycasePi defs ctx1 ty
|
||||
let s0 = CoeT i arg q p s s.loc
|
||||
body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc
|
||||
s1 = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
|
||||
(s // shift 1) s.loc
|
||||
whnf defs ctx $ CoeT i (sub1 res s1) p q body loc
|
||||
|
||||
||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc`
|
||||
private covering
|
||||
sigCoe : (qty : Qty) ->
|
||||
(ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
(ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
sigCoe qty sty@(S [< i] ty) p q val ret body loc = do
|
||||
-- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e }
|
||||
-- ⇝
|
||||
-- caseπ s ∷ ((x : A) × B)‹p/i› return z ⇒ C
|
||||
-- of { (a, b) ⇒
|
||||
-- e[(coe [i ⇒ A] @p @q a)/a,
|
||||
-- (coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i a)/x]] @p @q b)/b] }
|
||||
--
|
||||
-- type-case is used to expose A,B if the type is neutral
|
||||
let ctx1 = extendDim i ctx
|
||||
Element ty tynf <- whnf defs ctx1 ty.term
|
||||
(tfst, tsnd) <- tycaseSig defs ctx1 ty
|
||||
let [< x, y] = body.names
|
||||
a' = CoeT i (weakT 2 tfst) p q (BVT 1 noLoc) x.loc
|
||||
tsnd' = tsnd.term //
|
||||
(CoeT i (weakT 2 $ tfst // (B VZ noLoc ::: shift 2))
|
||||
(weakD 1 p) (B VZ noLoc) (BVT 1 noLoc) y.loc ::: shift 2)
|
||||
b' = CoeT i tsnd' p q (BVT 0 noLoc) y.loc
|
||||
whnf defs ctx $ CasePair qty (Ann val (ty // one p) val.loc) ret
|
||||
(ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc
|
||||
|
||||
||| reduce a dimension application `DApp (Coe ty p q val) r loc`
|
||||
private covering
|
||||
eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
(r : Dim d) -> Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
eqCoe sty@(S [< j] ty) p q val r loc = do
|
||||
-- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r
|
||||
-- ⇝
|
||||
-- comp [j ⇒ A‹r/i›] @p @q (eq ∷ (Eq [i ⇒ A] L R)‹p/j›)
|
||||
-- @r { 0 j ⇒ L; 1 j ⇒ R }
|
||||
let ctx1 = extendDim j ctx
|
||||
Element ty tynf <- whnf defs ctx1 ty.term
|
||||
(a0, a1, a, s, t) <- tycaseEq defs ctx1 ty
|
||||
let a' = dsub1 a (weakD 1 r)
|
||||
val' = E $ DApp (Ann val (ty // one p) val.loc) r loc
|
||||
whnf defs ctx $ CompH j a' p q val' r j s j t loc
|
||||
|
||||
||| reduce a pair elimination `CaseBox pi (Coe ty p q val) ret body`
|
||||
private covering
|
||||
boxCoe : (qty : Qty) ->
|
||||
(ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
(ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
boxCoe qty sty@(S [< i] ty) p q val ret body loc = do
|
||||
-- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e }
|
||||
-- ⇝
|
||||
-- caseπ s ∷ [ρ. A]‹p/i› return z ⇒ C
|
||||
-- of { [a] ⇒ e[(coe [i ⇒ A] p q a)/a] }
|
||||
let ctx1 = extendDim i ctx
|
||||
Element ty tynf <- whnf defs ctx1 ty.term
|
||||
ta <- tycaseBOX defs ctx1 ty
|
||||
let a' = CoeT i (weakT 1 ta) p q (BVT 0 noLoc) body.name.loc
|
||||
whnf defs ctx $ CaseBox qty (Ann val (ty // one p) val.loc) ret
|
||||
(ST body.names $ body.term // (a' ::: shift 1)) loc
|
||||
|
||||
|
||||
||| reduce a type-case applied to a type constructor
|
||||
private covering
|
||||
reduceTypeCase : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
|
||||
(ty : Term d n) -> (u : Universe) -> (ret : Term d n) ->
|
||||
(arms : TypeCaseArms d n) -> (def : Term d n) ->
|
||||
(0 _ : So (isTyCon ty)) => Loc ->
|
||||
Eff Whnf (Subset (Elim d n) (No . isRedexE defs))
|
||||
reduceTypeCase defs ctx ty u ret arms def loc = case ty of
|
||||
-- (type-case ★ᵢ ∷ _ return Q of { ★ ⇒ s; ⋯ }) ⇝ s ∷ Q
|
||||
TYPE {} =>
|
||||
whnf defs ctx $ Ann (tycaseRhsDef0 def KTYPE arms) ret loc
|
||||
|
||||
-- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝
|
||||
-- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
|
||||
Pi {arg, res, loc = piLoc, _} =>
|
||||
let arg' = Ann arg (TYPE u noLoc) arg.loc
|
||||
res' = Ann (Lam res res.loc)
|
||||
(Arr Zero arg (TYPE u noLoc) arg.loc) res.loc
|
||||
in
|
||||
whnf defs ctx $
|
||||
Ann (subN (tycaseRhsDef def KPi arms) [< arg', res']) ret loc
|
||||
|
||||
-- (type-case (x : A) × B ∷ ★ᵢ return Q of { (a × b) ⇒ s; ⋯ }) ⇝
|
||||
-- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
|
||||
Sig {fst, snd, loc = sigLoc, _} =>
|
||||
let fst' = Ann fst (TYPE u noLoc) fst.loc
|
||||
snd' = Ann (Lam snd snd.loc)
|
||||
(Arr Zero fst (TYPE u noLoc) fst.loc) snd.loc
|
||||
in
|
||||
whnf defs ctx $
|
||||
Ann (subN (tycaseRhsDef def KSig arms) [< fst', snd']) ret loc
|
||||
|
||||
-- (type-case {⋯} ∷ _ return Q of { {} ⇒ s; ⋯ }) ⇝ s ∷ Q
|
||||
Enum {} =>
|
||||
whnf defs ctx $ Ann (tycaseRhsDef0 def KEnum arms) ret loc
|
||||
|
||||
-- (type-case Eq [i ⇒ A] L R ∷ ★ᵢ return Q
|
||||
-- of { Eq a₀ a₁ a l r ⇒ s; ⋯ }) ⇝
|
||||
-- s[(A‹0/i› ∷ ★ᵢ)/a₀, (A‹1/i› ∷ ★ᵢ)/a₁,
|
||||
-- ((δ i ⇒ A) ∷ Eq [★ᵢ] A‹0/i› A‹1/i›)/a,
|
||||
-- (L ∷ A‹0/i›)/l, (R ∷ A‹1/i›)/r] ∷ Q
|
||||
Eq {ty = a, l, r, loc = eqLoc, _} =>
|
||||
let a0 = a.zero; a1 = a.one in
|
||||
whnf defs ctx $ Ann
|
||||
(subN (tycaseRhsDef def KEq arms)
|
||||
[< Ann a0 (TYPE u noLoc) a.loc, Ann a1 (TYPE u noLoc) a.loc,
|
||||
Ann (DLam a a.loc) (Eq0 (TYPE u noLoc) a0 a1 a.loc) a.loc,
|
||||
Ann l a0 l.loc, Ann r a1 r.loc])
|
||||
ret loc
|
||||
|
||||
-- (type-case ℕ ∷ _ return Q of { ℕ ⇒ s; ⋯ }) ⇝ s ∷ Q
|
||||
Nat {} =>
|
||||
whnf defs ctx $ Ann (tycaseRhsDef0 def KNat arms) ret loc
|
||||
|
||||
-- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q
|
||||
BOX {ty = a, loc = boxLoc, _} =>
|
||||
whnf defs ctx $ Ann
|
||||
(sub1 (tycaseRhsDef def KBOX arms) (Ann a (TYPE u noLoc) a.loc))
|
||||
ret loc
|
||||
|
||||
|
||||
||| pushes a coercion inside a whnf-ed term
|
||||
private covering
|
||||
pushCoe : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
|
||||
BindName ->
|
||||
(ty : Term (S d) n) -> (0 tynf : No (isRedexT defs ty)) =>
|
||||
Dim d -> Dim d ->
|
||||
(s : Term d n) -> (0 snf : No (isRedexT defs s)) => Loc ->
|
||||
Eff Whnf (NonRedex Elim d n defs)
|
||||
pushCoe defs ctx i ty p q s loc =
|
||||
if p == q then whnf defs ctx $ Ann s (ty // one q) loc else
|
||||
case s of
|
||||
-- (coe [_ ⇒ ★ᵢ] @_ @_ ty) ⇝ (ty ∷ ★ᵢ)
|
||||
TYPE {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Pi {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Sig {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Enum {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Eq {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
Nat {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
BOX {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
|
||||
|
||||
-- just η expand it. then whnf for App will handle it later
|
||||
-- this is how @xtt does it
|
||||
--
|
||||
-- (coe [i ⇒ A] @p @q (λ x ⇒ s)) ⇝
|
||||
-- (λ y ⇒ (coe [i ⇒ A] @p @q (λ x ⇒ s)) y) ∷ A‹q/i› ⇝ ⋯
|
||||
lam@(Lam {body, _}) => do
|
||||
let lam' = CoeT i ty p q lam loc
|
||||
term' = LamY !(fresh body.name)
|
||||
(E $ App (weakE 1 lam') (BVT 0 noLoc) loc) loc
|
||||
type' = ty // one q
|
||||
whnf defs ctx $ Ann term' type' loc
|
||||
|
||||
-- (coe [i ⇒ (x : A) × B] @p @q (s, t)) ⇝
|
||||
-- (coe [i ⇒ A] @p @q s,
|
||||
-- coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i s)/x]] @p @q t)
|
||||
-- ∷ (x : A‹q/i›) × B‹q/i›
|
||||
--
|
||||
-- can't use η here because... it doesn't exist
|
||||
Pair {fst, snd, loc = pairLoc} => do
|
||||
let Sig {fst = tfst, snd = tsnd, loc = sigLoc} = ty
|
||||
| _ => throw $ ExpectedSig ty.loc (extendDim i ctx.names) ty
|
||||
let fst' = E $ CoeT i tfst p q fst fst.loc
|
||||
tfst' = tfst // (B VZ noLoc ::: shift 2)
|
||||
tsnd' = sub1 tsnd $
|
||||
CoeT !(fresh i) tfst' (weakD 1 p) (B VZ noLoc)
|
||||
(dweakT 1 fst) fst.loc
|
||||
snd' = E $ CoeT i tsnd' p q snd snd.loc
|
||||
pure $
|
||||
Element (Ann (Pair fst' snd' pairLoc)
|
||||
(Sig (tfst // one q) (tsnd // one q) sigLoc) loc) Ah
|
||||
|
||||
-- η expand, like for Lam
|
||||
--
|
||||
-- (coe [i ⇒ A] @p @q (δ j ⇒ s)) ⇝
|
||||
-- (δ k ⇒ (coe [i ⇒ A] @p @q (δ j ⇒ s)) @k) ∷ A‹q/i› ⇝ ⋯
|
||||
dlam@(DLam {body, _}) => do
|
||||
let dlam' = CoeT i ty p q dlam loc
|
||||
term' = DLamY !(mnb "j")
|
||||
(E $ DApp (dweakE 1 dlam') (B VZ noLoc) loc) loc
|
||||
type' = ty // one q
|
||||
whnf defs ctx $ Ann term' type' loc
|
||||
|
||||
-- (coe [_ ⇒ {⋯}] @_ @_ t) ⇝ (t ∷ {⋯})
|
||||
Tag {tag, loc = tagLoc} => do
|
||||
let Enum {cases, loc = enumLoc} = ty
|
||||
| _ => throw $ ExpectedEnum ty.loc (extendDim i ctx.names) ty
|
||||
pure $ Element (Ann (Tag tag tagLoc) (Enum cases enumLoc) loc) Ah
|
||||
|
||||
-- (coe [_ ⇒ ℕ] @_ @_ n) ⇝ (n ∷ ℕ)
|
||||
Zero {loc = zeroLoc} => do
|
||||
pure $ Element (Ann (Zero zeroLoc) (Nat ty.loc) loc) Ah
|
||||
Succ {p = pred, loc = succLoc} => do
|
||||
pure $ Element (Ann (Succ pred succLoc) (Nat ty.loc) loc) Ah
|
||||
|
||||
-- (coe [i ⇒ [π.A]] @p @q [s]) ⇝
|
||||
-- [coe [i ⇒ A] @p @q s] ∷ [π. A‹q/i›]
|
||||
Box {val, loc = boxLoc} => do
|
||||
let BOX {qty, ty = a, loc = tyLoc} = ty
|
||||
| _ => throw $ ExpectedBOX ty.loc (extendDim i ctx.names) ty
|
||||
pure $ Element
|
||||
(Ann (Box (E $ CoeT i a p q val val.loc) boxLoc)
|
||||
(BOX qty (a // one q) tyLoc) loc)
|
||||
Ah
|
||||
|
||||
E e => pure $ Element (CoeT i ty p q (E e) e.loc) (snf `orNo` Ah)
|
||||
where
|
||||
unwrapTYPE : Term (S d) n -> Eff Whnf Universe
|
||||
unwrapTYPE (TYPE {l, _}) = pure l
|
||||
unwrapTYPE ty = throw $ ExpectedTYPE ty.loc (extendDim i ctx.names) ty
|
||||
|
||||
|
||||
export covering
|
||||
CanWhnf Elim Reduce.isRedexE where
|
||||
whnf defs ctx (F x u loc) with (lookupElim x defs) proof eq
|
||||
_ | Just y = whnf defs ctx $ setLoc loc $ displace u y
|
||||
_ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah
|
||||
|
||||
whnf _ _ (B i loc) = pure $ nred $ B i loc
|
||||
|
||||
-- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x]
|
||||
whnf defs ctx (App f s appLoc) = do
|
||||
Element f fnf <- whnf defs ctx f
|
||||
case nchoose $ isLamHead f of
|
||||
Left _ => case f of
|
||||
Ann (Lam {body, _}) (Pi {arg, res, _}) floc =>
|
||||
let s = Ann s arg s.loc in
|
||||
whnf defs ctx $ Ann (sub1 body s) (sub1 res s) appLoc
|
||||
Coe ty p q val _ => piCoe defs ctx ty p q val s appLoc
|
||||
Right nlh => pure $ Element (App f s appLoc) $ fnf `orNo` nlh
|
||||
|
||||
-- case (s, t) ∷ (x : A) × B return p ⇒ C of { (a, b) ⇒ u } ⇝
|
||||
-- u[s∷A/a, t∷B[s∷A/x]] ∷ C[(s, t)∷((x : A) × B)/p]
|
||||
whnf defs ctx (CasePair pi pair ret body caseLoc) = do
|
||||
Element pair pairnf <- whnf defs ctx pair
|
||||
case nchoose $ isPairHead pair of
|
||||
Left _ => case pair of
|
||||
Ann (Pair {fst, snd, _}) (Sig {fst = tfst, snd = tsnd, _}) pairLoc =>
|
||||
let fst = Ann fst tfst fst.loc
|
||||
snd = Ann snd (sub1 tsnd fst) snd.loc
|
||||
in
|
||||
whnf defs ctx $ Ann (subN body [< fst, snd]) (sub1 ret pair) caseLoc
|
||||
Coe ty p q val _ => do
|
||||
sigCoe defs ctx pi ty p q val ret body caseLoc
|
||||
Right np =>
|
||||
pure $ Element (CasePair pi pair ret body caseLoc) $ pairnf `orNo` np
|
||||
|
||||
-- case 'a ∷ {a,…} return p ⇒ C of { 'a ⇒ u } ⇝
|
||||
-- u ∷ C['a∷{a,…}/p]
|
||||
whnf defs ctx (CaseEnum pi tag ret arms caseLoc) = do
|
||||
Element tag tagnf <- whnf defs ctx tag
|
||||
case nchoose $ isTagHead tag of
|
||||
Left _ => case tag of
|
||||
Ann (Tag t _) (Enum ts _) _ =>
|
||||
let ty = sub1 ret tag in
|
||||
case lookup t arms of
|
||||
Just arm => whnf defs ctx $ Ann arm ty arm.loc
|
||||
Nothing => throw $ MissingEnumArm caseLoc t (keys arms)
|
||||
Coe ty p q val _ =>
|
||||
-- there is nowhere an equality can be hiding inside an enum type
|
||||
whnf defs ctx $
|
||||
CaseEnum pi (Ann val (dsub1 ty q) val.loc) ret arms caseLoc
|
||||
Right nt =>
|
||||
pure $ Element (CaseEnum pi tag ret arms caseLoc) $ tagnf `orNo` nt
|
||||
|
||||
-- case zero ∷ ℕ return p ⇒ C of { zero ⇒ u; … } ⇝
|
||||
-- u ∷ C[zero∷ℕ/p]
|
||||
--
|
||||
-- case succ n ∷ ℕ return p ⇒ C of { succ n', π.ih ⇒ u; … } ⇝
|
||||
-- u[n∷ℕ/n', (case n ∷ ℕ ⋯)/ih] ∷ C[succ n ∷ ℕ/p]
|
||||
whnf defs ctx (CaseNat pi piIH nat ret zer suc caseLoc) = do
|
||||
Element nat natnf <- whnf defs ctx nat
|
||||
case nchoose $ isNatHead nat of
|
||||
Left _ =>
|
||||
let ty = sub1 ret nat in
|
||||
case nat of
|
||||
Ann (Zero _) (Nat _) _ =>
|
||||
whnf defs ctx $ Ann zer ty zer.loc
|
||||
Ann (Succ n succLoc) (Nat natLoc) _ =>
|
||||
let nn = Ann n (Nat natLoc) succLoc
|
||||
tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc]
|
||||
in
|
||||
whnf defs ctx $ Ann tm ty caseLoc
|
||||
Coe ty p q val _ =>
|
||||
-- same deal as Enum
|
||||
whnf defs ctx $
|
||||
CaseNat pi piIH (Ann val (dsub1 ty q) val.loc) ret zer suc caseLoc
|
||||
Right nn => pure $
|
||||
Element (CaseNat pi piIH nat ret zer suc caseLoc) $ natnf `orNo` nn
|
||||
|
||||
-- case [t] ∷ [π.A] return p ⇒ C of { [x] ⇒ u } ⇝
|
||||
-- u[t∷A/x] ∷ C[[t] ∷ [π.A]/p]
|
||||
whnf defs ctx (CaseBox pi box ret body caseLoc) = do
|
||||
Element box boxnf <- whnf defs ctx box
|
||||
case nchoose $ isBoxHead box of
|
||||
Left _ => case box of
|
||||
Ann (Box val boxLoc) (BOX q bty tyLoc) _ =>
|
||||
let ty = sub1 ret box in
|
||||
whnf defs ctx $ Ann (sub1 body (Ann val bty val.loc)) ty caseLoc
|
||||
Coe ty p q val _ =>
|
||||
boxCoe defs ctx pi ty p q val ret body caseLoc
|
||||
Right nb =>
|
||||
pure $ Element (CaseBox pi box ret body caseLoc) $ boxnf `orNo` nb
|
||||
|
||||
-- e : Eq (𝑗 ⇒ A) t u ⊢ e @0 ⇝ t ∷ A‹0/𝑗›
|
||||
-- e : Eq (𝑗 ⇒ A) t u ⊢ e @1 ⇝ u ∷ A‹1/𝑗›
|
||||
--
|
||||
-- ((δ 𝑖 ⇒ s) ∷ Eq (𝑗 ⇒ A) t u) @𝑘 ⇝ s‹𝑘/𝑖› ∷ A‹𝑘/𝑗›
|
||||
whnf defs ctx (DApp f p appLoc) = do
|
||||
Element f fnf <- whnf defs ctx f
|
||||
case nchoose $ isDLamHead f of
|
||||
Left _ => case f of
|
||||
Ann (DLam {body, _}) (Eq {ty, l, r, _}) _ =>
|
||||
whnf defs ctx $
|
||||
Ann (endsOr (setLoc appLoc l) (setLoc appLoc r) (dsub1 body p) p)
|
||||
(dsub1 ty p) appLoc
|
||||
Coe ty p' q' val _ =>
|
||||
eqCoe defs ctx ty p' q' val p appLoc
|
||||
Right ndlh => case p of
|
||||
K e _ => do
|
||||
Eq {l, r, ty, _} <- whnf0 defs ctx =<< computeElimType defs ctx f
|
||||
| ty => throw $ ExpectedEq ty.loc ctx.names ty
|
||||
whnf defs ctx $
|
||||
ends (Ann (setLoc appLoc l) ty.zero appLoc)
|
||||
(Ann (setLoc appLoc r) ty.one appLoc) e
|
||||
B {} => pure $ Element (DApp f p appLoc) $ fnf `orNo` ndlh `orNo` Ah
|
||||
|
||||
-- e ∷ A ⇝ e
|
||||
whnf defs ctx (Ann s a annLoc) = do
|
||||
Element s snf <- whnf defs ctx s
|
||||
case nchoose $ isE s of
|
||||
Left _ => let E e = s in pure $ Element e $ noOr2 snf
|
||||
Right ne => do
|
||||
Element a anf <- whnf defs ctx a
|
||||
pure $ Element (Ann s a annLoc) $ ne `orNo` snf `orNo` anf
|
||||
|
||||
whnf defs ctx (Coe (S _ (N ty)) _ _ val coeLoc) =
|
||||
whnf defs ctx $ Ann val ty coeLoc
|
||||
whnf defs ctx (Coe (S [< i] ty) p q val coeLoc) = do
|
||||
Element ty tynf <- whnf defs (extendDim i ctx) ty.term
|
||||
Element val valnf <- whnf defs ctx val
|
||||
pushCoe defs ctx i ty p q val coeLoc
|
||||
|
||||
whnf defs ctx (Comp ty p q val r zero one compLoc) =
|
||||
-- comp [A] @p @p s { ⋯ } ⇝ s ∷ A
|
||||
if p == q then whnf defs ctx $ Ann val ty compLoc else
|
||||
case nchoose (isK r) of
|
||||
-- comp [A] @p @q s @0 { 0 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A
|
||||
-- comp [A] @p @q s @1 { 1 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A
|
||||
Left y => case r of
|
||||
K Zero _ => whnf defs ctx $ Ann (dsub1 zero q) ty compLoc
|
||||
K One _ => whnf defs ctx $ Ann (dsub1 one q) ty compLoc
|
||||
Right nk => do
|
||||
Element ty tynf <- whnf defs ctx ty
|
||||
pure $ Element (Comp ty p q val r zero one compLoc) $ tynf `orNo` nk
|
||||
|
||||
whnf defs ctx (TypeCase ty ret arms def tcLoc) = do
|
||||
Element ty tynf <- whnf defs ctx ty
|
||||
Element ret retnf <- whnf defs ctx ret
|
||||
case nchoose $ isAnnTyCon ty of
|
||||
Left y =>
|
||||
let Ann ty (TYPE u _) _ = ty in
|
||||
reduceTypeCase defs ctx ty u ret arms def tcLoc
|
||||
Right nt => pure $
|
||||
Element (TypeCase ty ret arms def tcLoc) (tynf `orNo` retnf `orNo` nt)
|
||||
|
||||
whnf defs ctx (CloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' id th el
|
||||
whnf defs ctx (DCloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' th id el
|
||||
|
||||
export covering
|
||||
CanWhnf Term Reduce.isRedexT where
|
||||
whnf _ _ t@(TYPE {}) = pure $ nred t
|
||||
whnf _ _ t@(Pi {}) = pure $ nred t
|
||||
whnf _ _ t@(Lam {}) = pure $ nred t
|
||||
whnf _ _ t@(Sig {}) = pure $ nred t
|
||||
whnf _ _ t@(Pair {}) = pure $ nred t
|
||||
whnf _ _ t@(Enum {}) = pure $ nred t
|
||||
whnf _ _ t@(Tag {}) = pure $ nred t
|
||||
whnf _ _ t@(Eq {}) = pure $ nred t
|
||||
whnf _ _ t@(DLam {}) = pure $ nred t
|
||||
whnf _ _ t@(Nat {}) = pure $ nred t
|
||||
whnf _ _ t@(Zero {}) = pure $ nred t
|
||||
whnf _ _ t@(Succ {}) = pure $ nred t
|
||||
whnf _ _ t@(BOX {}) = pure $ nred t
|
||||
whnf _ _ t@(Box {}) = pure $ nred t
|
||||
|
||||
-- s ∷ A ⇝ s (in term context)
|
||||
whnf defs ctx (E e) = do
|
||||
Element e enf <- whnf defs ctx e
|
||||
case nchoose $ isAnn e of
|
||||
Left _ => let Ann {tm, _} = e in pure $ Element tm $ noOr1 $ noOr2 enf
|
||||
Right na => pure $ Element (E e) $ na `orNo` enf
|
||||
|
||||
whnf defs ctx (CloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' id th tm
|
||||
whnf defs ctx (DCloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' th id tm
|
59
lib/Quox/Scoped.idr
Normal file
59
lib/Quox/Scoped.idr
Normal file
|
@ -0,0 +1,59 @@
|
|||
module Quox.Scoped
|
||||
|
||||
import public Quox.Var
|
||||
import public Quox.Context
|
||||
|
||||
import Derive.Prelude
|
||||
|
||||
%language ElabReflection
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data ScopedBody : Nat -> (Nat -> Type) -> Nat -> Type where
|
||||
Y : (body : f (s + n)) -> ScopedBody s f n
|
||||
N : (body : f n) -> ScopedBody s f n
|
||||
%name ScopedBody body
|
||||
|
||||
export %inline %hint
|
||||
EqScopedBody : (forall n. Eq (f n)) => Eq (ScopedBody s f n)
|
||||
EqScopedBody = deriveEq
|
||||
|
||||
export %inline %hint
|
||||
ShowScopedBody : (forall n. Show (f n)) => Show (ScopedBody s f n)
|
||||
ShowScopedBody = deriveShow
|
||||
|
||||
||| a scoped term with names
|
||||
public export
|
||||
record Scoped (s : Nat) (f : Nat -> Type) (n : Nat) where
|
||||
constructor S
|
||||
names : BContext s
|
||||
body : ScopedBody s f n
|
||||
%name Scoped body
|
||||
|
||||
export %inline
|
||||
(forall n. Eq (f n)) => Eq (Scoped s f n) where
|
||||
s == t = s.body == t.body
|
||||
|
||||
export %inline %hint
|
||||
ShowScoped : (forall n. Show (f n)) => Show (Scoped s f n)
|
||||
ShowScoped = deriveShow
|
||||
|
||||
|
||||
||| scope which ignores all its binders
|
||||
public export %inline
|
||||
SN : Located1 f => {s : Nat} -> f n -> Scoped s f n
|
||||
SN body = S (replicate s $ BN Unused body.loc) $ N body
|
||||
|
||||
||| scope which uses its binders
|
||||
public export %inline
|
||||
SY : BContext s -> f (s + n) -> Scoped s f n
|
||||
SY ns = S ns . Y
|
||||
|
||||
public export %inline
|
||||
name : Scoped 1 f n -> BindName
|
||||
name (S [< x] _) = x
|
||||
|
||||
public export %inline
|
||||
(.name) : Scoped 1 f n -> BindName
|
||||
s.name = name s
|
|
@ -6,4 +6,5 @@ import public Quox.Syntax.Qty
|
|||
import public Quox.Syntax.Shift
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Syntax.Term
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Syntax.Builtin
|
||||
import public Quox.Var
|
||||
|
|
27
lib/Quox/Syntax/Builtin.idr
Normal file
27
lib/Quox/Syntax/Builtin.idr
Normal file
|
@ -0,0 +1,27 @@
|
|||
module Quox.Syntax.Builtin
|
||||
|
||||
import Derive.Prelude
|
||||
import Quox.PrettyValExtra
|
||||
import Quox.Pretty
|
||||
import Quox.Syntax.Term
|
||||
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
public export
|
||||
data Builtin
|
||||
= Main
|
||||
%runElab derive "Builtin" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
public export
|
||||
builtinDesc : Builtin -> String
|
||||
builtinDesc Main = "a function declared as #[main]"
|
||||
|
||||
public export
|
||||
builtinTypeDoc : {opts : LayoutOpts} -> Builtin -> Eff Pretty (Doc opts)
|
||||
builtinTypeDoc Main =
|
||||
prettyTerm [<] [<] $
|
||||
Pi One (IOState noLoc)
|
||||
(SN $ Sig (Enum (fromList [!(ifUnicode "𝑎" "a")]) noLoc)
|
||||
(SN (IOState noLoc)) noLoc) noLoc
|
|
@ -1,18 +1,16 @@
|
|||
module Quox.Syntax.Dim
|
||||
|
||||
import Quox.Thin
|
||||
import Quox.Syntax.Var
|
||||
import Quox.Loc
|
||||
import Quox.Name
|
||||
import Quox.Var
|
||||
import Quox.Syntax.Subst
|
||||
import Quox.Pretty
|
||||
import Quox.Name
|
||||
import Quox.Loc
|
||||
import Quox.Context
|
||||
import Quox.PrettyValExtra
|
||||
|
||||
import Decidable.Equality
|
||||
import Control.Function
|
||||
import Derive.Prelude
|
||||
import Data.DPair
|
||||
import Data.SnocVect
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
@ -21,7 +19,7 @@ import Data.SnocVect
|
|||
public export
|
||||
data DimConst = Zero | One
|
||||
%name DimConst e
|
||||
%runElab derive "DimConst" [Eq, Ord, Show]
|
||||
%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
|
||||
public export
|
||||
|
@ -42,48 +40,38 @@ DecEq DimConst where
|
|||
|
||||
public export
|
||||
data Dim : Nat -> Type where
|
||||
K : DimConst -> Loc -> Dim 0
|
||||
B : Loc -> Dim 1
|
||||
K : DimConst -> Loc -> Dim d
|
||||
B : Var d -> Loc -> Dim d
|
||||
%name Dim.Dim p, q
|
||||
%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
|
||||
||| `x` otherwise.
|
||||
public export
|
||||
endsOr : Lazy a -> Lazy a -> Lazy a -> Dim n -> a
|
||||
endsOr l r x (K e _) = ends l r e
|
||||
endsOr l r x (B _) = x
|
||||
endsOr l r x (B _ _) = x
|
||||
|
||||
|
||||
export
|
||||
Located (Dim d) where
|
||||
(K _ loc).loc = loc
|
||||
(B loc).loc = loc
|
||||
(B _ loc).loc = loc
|
||||
|
||||
export
|
||||
Relocatable (Dim d) where
|
||||
setLoc loc (K e _) = K e loc
|
||||
setLoc loc (B _) = B loc
|
||||
setLoc loc (B i _) = B i loc
|
||||
|
||||
parameters {opts : LayoutOpts}
|
||||
export
|
||||
prettyDimConst : DimConst -> Eff Pretty (Doc opts)
|
||||
prettyDimConst = hl Dim . text . ends "0" "1"
|
||||
export
|
||||
prettyDimConst : {opts : _} -> DimConst -> Eff Pretty (Doc opts)
|
||||
prettyDimConst = hl Dim . text . ends "0" "1"
|
||||
|
||||
export
|
||||
prettyDim : {d : Nat} -> BContext d -> DimT d -> Eff Pretty (Doc opts)
|
||||
prettyDim names (Th _ (K e _)) = prettyDimConst e
|
||||
prettyDim names (Th i (B _)) = prettyDBind $ names !!! i.fin
|
||||
export
|
||||
prettyDim : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
|
||||
prettyDim names (K e _) = prettyDimConst e
|
||||
prettyDim names (B i _) = prettyDBind $ names !!! i
|
||||
|
||||
|
||||
public export %inline
|
||||
|
@ -96,54 +84,57 @@ DSubst : Nat -> Nat -> Type
|
|||
DSubst = Subst Dim
|
||||
|
||||
|
||||
-- public export FromVar Dim where fromVarLoc = B
|
||||
public export FromVar Dim where fromVarLoc = B
|
||||
|
||||
|
||||
-- export
|
||||
-- CanShift Dim where
|
||||
-- K e loc // _ = K e loc
|
||||
-- B i loc // by = B (i // by) loc
|
||||
export
|
||||
CanShift Dim where
|
||||
K e loc // _ = K e loc
|
||||
B i loc // by = B (i // by) loc
|
||||
|
||||
export %inline FromVar Dim where var = B
|
||||
|
||||
export %inline
|
||||
export
|
||||
CanSubstSelf Dim where
|
||||
Th _ (K e loc) // _ = KT e loc
|
||||
Th i (B loc) // th = get th i.fin
|
||||
K e loc // _ = K e loc
|
||||
B i loc // th = getLoc th i loc
|
||||
|
||||
|
||||
export Uninhabited (B loc1 = K e loc2) where uninhabited _ impossible
|
||||
export Uninhabited (K e loc1 = B loc2) where uninhabited _ impossible
|
||||
export Uninhabited (B i loc1 = K e loc2) where uninhabited _ impossible
|
||||
export Uninhabited (K e loc1 = B i loc2) where uninhabited _ impossible
|
||||
|
||||
-- public export
|
||||
-- data Eqv : Dim d1 -> Dim d2 -> Type where
|
||||
-- EK : K e _ `Eqv` K e _
|
||||
-- EB : i `Eqv` j -> B i _ `Eqv` B j _
|
||||
public export
|
||||
data Eqv : Dim d1 -> Dim d2 -> Type where
|
||||
EK : K e _ `Eqv` K e _
|
||||
EB : i `Eqv` j -> B i _ `Eqv` B j _
|
||||
|
||||
-- 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 (K e l1 `Eqv` B i l2) where uninhabited _ impossible
|
||||
export Uninhabited (B i l1 `Eqv` K e l2) where uninhabited _ impossible
|
||||
|
||||
-- export
|
||||
-- injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j
|
||||
-- injectiveB (EB e) = e
|
||||
export
|
||||
injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j
|
||||
injectiveB (EB e) = e
|
||||
|
||||
-- export
|
||||
-- injectiveK : K e loc1 `Eqv` K f loc2 -> e = f
|
||||
-- injectiveK EK = Refl
|
||||
export
|
||||
injectiveK : K e loc1 `Eqv` K f loc2 -> e = f
|
||||
injectiveK EK = Refl
|
||||
|
||||
-- public export
|
||||
-- decEqv : Dec2 Dim.Eqv
|
||||
-- decEqv (K e _) (K f _) = case decEq e f of
|
||||
-- Yes Refl => Yes EK
|
||||
-- No n => No $ n . injectiveK
|
||||
-- decEqv (B i _) (B j _) = case decEqv i j of
|
||||
-- Yes y => Yes $ EB y
|
||||
-- No n => No $ \(EB y) => n y
|
||||
-- decEqv (B _ _) (K _ _) = No absurd
|
||||
-- decEqv (K _ _) (B _ _) = No absurd
|
||||
public export
|
||||
decEqv : Dec2 Dim.Eqv
|
||||
decEqv (K e _) (K f _) = case decEq e f of
|
||||
Yes Refl => Yes EK
|
||||
No n => No $ n . injectiveK
|
||||
decEqv (B i _) (B j _) = case decEqv i j of
|
||||
Yes y => Yes $ EB y
|
||||
No n => No $ \(EB y) => n y
|
||||
decEqv (B _ _) (K _ _) = No absurd
|
||||
decEqv (K _ _) (B _ _) = No absurd
|
||||
|
||||
||| abbreviation for a bound variable like `BV 4` instead of
|
||||
||| `B (VS (VS (VS (VS VZ))))`
|
||||
public export %inline
|
||||
BV : (i : Fin d) -> (loc : Loc) -> DimT d
|
||||
BV i loc = Th (one' i) $ B loc
|
||||
BV : (i : Nat) -> (0 _ : LT i d) => (loc : Loc) -> Dim d
|
||||
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
|
||||
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Var
|
||||
import public Quox.Syntax.Dim
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Context
|
||||
import Quox.Pretty
|
||||
import Quox.Name
|
||||
import Quox.Thin
|
||||
import Quox.FinExtra
|
||||
import Quox.FreeVars
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Nat
|
||||
import Data.DPair
|
||||
import Data.Fun.Graph
|
||||
import Data.SnocVect
|
||||
import Decidable.Decidable
|
||||
import Decidable.Equality
|
||||
import Derive.Prelude
|
||||
|
@ -24,7 +22,7 @@ import Derive.Prelude
|
|||
|
||||
public export
|
||||
DimEq' : Nat -> Type
|
||||
DimEq' = Context (Maybe . DimT)
|
||||
DimEq' = Context (Maybe . Dim)
|
||||
|
||||
|
||||
public export
|
||||
|
@ -32,12 +30,7 @@ data DimEq : Nat -> Type where
|
|||
ZeroIsOne : DimEq d
|
||||
C : (eqs : DimEq' d) -> DimEq d
|
||||
%name DimEq eqs
|
||||
%runElab deriveIndexed "DimEq" [Eq]
|
||||
|
||||
export
|
||||
Show (DimEq d) where
|
||||
showPrec d ZeroIsOne = "ZeroIsOne"
|
||||
showPrec d (C eq') = showCon d "C" $ showArg eq' @{ShowTelRelevant}
|
||||
%runElab deriveIndexed "DimEq" [Eq, Ord, Show]
|
||||
|
||||
|
||||
public export
|
||||
|
@ -66,10 +59,15 @@ Traversable (IfConsistent eqs) where
|
|||
traverse f Nothing = pure Nothing
|
||||
traverse f (Just x) = Just <$> f x
|
||||
|
||||
public export
|
||||
ifConsistentElse : Applicative f => (eqs : DimEq d) ->
|
||||
f a -> f () -> f (IfConsistent eqs a)
|
||||
ifConsistentElse ZeroIsOne yes no = Nothing <$ no
|
||||
ifConsistentElse (C _) yes no = Just <$> yes
|
||||
|
||||
public export
|
||||
ifConsistent : Applicative f => (eqs : DimEq d) -> f a -> f (IfConsistent eqs a)
|
||||
ifConsistent ZeroIsOne act = pure Nothing
|
||||
ifConsistent (C _) act = Just <$> act
|
||||
ifConsistent eqs act = ifConsistentElse eqs act (pure ())
|
||||
|
||||
public export
|
||||
toMaybe : IfConsistent eqs a -> Maybe a
|
||||
|
@ -78,13 +76,13 @@ toMaybe (Just x) = Just x
|
|||
|
||||
|
||||
export
|
||||
fromGround' : Context' DimConst d -> DimEq' d
|
||||
fromGround' [<] = [<]
|
||||
fromGround' (ctx :< e) = fromGround' ctx :< Just (KT e noLoc)
|
||||
fromGround' : BContext d -> Context' DimConst d -> DimEq' d
|
||||
fromGround' [<] [<] = [<]
|
||||
fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
|
||||
|
||||
export
|
||||
fromGround : Context' DimConst d -> DimEq d
|
||||
fromGround = C . fromGround'
|
||||
fromGround : BContext d -> Context' DimConst d -> DimEq d
|
||||
fromGround = C .: fromGround'
|
||||
|
||||
|
||||
public export %inline
|
||||
|
@ -102,40 +100,39 @@ new = C new'
|
|||
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
public export %inline
|
||||
get : {d : Nat} -> DimEq' d -> DimT d -> DimT d
|
||||
get eqs p@(Th _ (K {})) = p
|
||||
get eqs p@(Th i (B _)) = fromMaybe p $ get' eqs i.fin
|
||||
get : DimEq' d -> Dim d -> Dim d
|
||||
get _ (K e loc) = K e loc
|
||||
get eqs (B i loc) = getVar eqs i loc
|
||||
|
||||
|
||||
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 (C eqs) p q = get eqs p == get eqs q
|
||||
|
||||
|
||||
infixl 7 :<?
|
||||
export infixl 7 :<?
|
||||
export %inline
|
||||
(:<?) : {d : Nat} -> DimEq d -> Maybe (DimT d) -> DimEq (S d)
|
||||
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
|
||||
ZeroIsOne :<? d = ZeroIsOne
|
||||
C eqs :<? d = C $ eqs :< map (get eqs) d
|
||||
|
||||
|
||||
private %inline
|
||||
isVar : {d : Nat} -> Fin d -> DimT d -> Bool
|
||||
isVar i (Th j (B _)) = i == j.fin
|
||||
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
|
||||
ifVar : Var d -> Dim d -> Maybe (Dim d) -> Maybe (Dim d)
|
||||
ifVar i p = map $ \q => if q == B i noLoc then p else q
|
||||
|
||||
-- (using decEq instead of (==) because of the proofs below)
|
||||
private %inline
|
||||
|
@ -144,45 +141,43 @@ checkConst e f eqs = if isYes $ e `decEq` f then C eqs else ZeroIsOne
|
|||
|
||||
|
||||
export
|
||||
setConst : {d : Nat} -> Fin d -> DimConst -> Loc -> DimEq' d -> DimEq d
|
||||
setConst FZ e loc (eqs :< Nothing) =
|
||||
C $ eqs :< Just (KT e loc)
|
||||
setConst FZ e _ (eqs :< Just (Th _ (K f loc))) =
|
||||
checkConst e f $ eqs :< Just (KT f loc)
|
||||
setConst FZ e loc (eqs :< Just (Th j (B _))) =
|
||||
setConst j.fin e loc eqs :<? Just (KT e loc)
|
||||
setConst (FS i) e loc (eqs :< p) =
|
||||
setConst i e loc eqs :<? ifVar i (KT e loc) p
|
||||
setConst : Var d -> DimConst -> Loc -> DimEq' d -> DimEq d
|
||||
setConst VZ e loc (eqs :< Nothing) =
|
||||
C $ eqs :< Just (K e loc)
|
||||
setConst VZ e _ (eqs :< Just (K f loc)) =
|
||||
checkConst e f $ eqs :< Just (K f loc)
|
||||
setConst VZ e loc (eqs :< Just (B i _)) =
|
||||
setConst i e loc eqs :<? Just (K e loc)
|
||||
setConst (VS i) e loc (eqs :< p) =
|
||||
setConst i e loc eqs :<? ifVar i (K e loc) p
|
||||
|
||||
mutual
|
||||
private
|
||||
setVar' : {d : Nat} ->
|
||||
(i, j : Fin d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
|
||||
setVar' FZ (FS i) LTZ loc (eqs :< Nothing) =
|
||||
C eqs :<? Just (BV i loc)
|
||||
setVar' FZ (FS i) LTZ loc (eqs :< Just (Th _ (K e eloc))) =
|
||||
setConst i e loc eqs :<? Just (KT e eloc)
|
||||
setVar' FZ (FS i) LTZ loc (eqs :< Just (Th j (B jloc))) =
|
||||
let j = j.fin in
|
||||
setVar i j loc jloc eqs :<? Just (if j > i then BV j jloc else BV i loc)
|
||||
setVar' (FS i) (FS j) (LTS lt) loc (eqs :< p) =
|
||||
setVar' i j lt loc eqs :<? ifVar i (BV j loc) p
|
||||
setVar' : (i, j : Var d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
|
||||
setVar' VZ (VS i) LTZ loc (eqs :< Nothing) =
|
||||
C eqs :<? Just (B i loc)
|
||||
setVar' VZ (VS i) LTZ loc (eqs :< Just (K e eloc)) =
|
||||
setConst i e loc eqs :<? Just (K e eloc)
|
||||
setVar' VZ (VS i) LTZ loc (eqs :< Just (B j jloc)) =
|
||||
setVar i j loc jloc eqs :<? Just (if j > i then B j jloc else B i loc)
|
||||
setVar' (VS i) (VS j) (LTS lt) loc (eqs :< p) =
|
||||
setVar' i j lt loc eqs :<? ifVar i (B j loc) p
|
||||
|
||||
export %inline
|
||||
setVar : {d : Nat} -> (i, j : Fin d) -> Loc -> Loc -> DimEq' d -> DimEq d
|
||||
setVar i j li lj eqs with (compareP i j)
|
||||
setVar i j li lj eqs | IsLT lt = setVar' i j lt lj eqs
|
||||
setVar i i li lj eqs | IsEQ = C eqs
|
||||
setVar i j li lj eqs | IsGT gt = setVar' j i gt li eqs
|
||||
setVar : (i, j : Var d) -> Loc -> Loc -> DimEq' d -> DimEq d
|
||||
setVar i j li lj eqs with (compareP i j) | (compare i.nat j.nat)
|
||||
setVar i j li lj eqs | IsLT lt | LT = setVar' i j lt lj eqs
|
||||
setVar i i li lj eqs | IsEQ | EQ = C eqs
|
||||
setVar i j li lj eqs | IsGT gt | GT = setVar' j i gt li eqs
|
||||
|
||||
|
||||
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 (Th _ (K e _)) (Th _ (K f _)) (C eqs) = checkConst e f eqs
|
||||
set (Th _ (K e el)) (Th j (B _)) (C eqs) = setConst j.fin e el eqs
|
||||
set (Th i (B _)) (Th _ (K e el)) (C eqs) = setConst i.fin e el eqs
|
||||
set (Th i (B il)) (Th j (B jl)) (C eqs) = setVar i.fin j.fin il jl eqs
|
||||
set (K e eloc) (K f floc) (C eqs) = checkConst e f eqs
|
||||
set (K e eloc) (B i iloc) (C eqs) = setConst i e eloc eqs
|
||||
set (B i iloc) (K e eloc) (C eqs) = setConst i e eloc eqs
|
||||
set (B i iloc) (B j jloc) (C eqs) = setVar i j iloc jloc eqs
|
||||
|
||||
|
||||
public export %inline
|
||||
|
@ -190,99 +185,116 @@ Split : Nat -> Type
|
|||
Split d = (DimEq' d, DSubst (S d) d)
|
||||
|
||||
export %inline
|
||||
split1 : {d : Nat} -> DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
|
||||
split1 e loc eqs = case setConst 0 e loc eqs of
|
||||
split1 : DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
|
||||
split1 e loc eqs = case setConst VZ e loc eqs of
|
||||
ZeroIsOne => Nothing
|
||||
C (eqs :< _) => Just (eqs, id (B loc) :< KT e loc)
|
||||
C (eqs :< _) => Just (eqs, K e loc ::: id)
|
||||
|
||||
export %inline
|
||||
split : {d : Nat} -> Loc -> DimEq' (S d) -> List (Split d)
|
||||
split loc eqs = toList (split1 Zero loc eqs) <+> toList (split1 One loc eqs)
|
||||
split1' : DimConst -> Loc -> DimEq' (S d) -> List (Split d)
|
||||
split1' e loc eqs = toList $ split1 e loc eqs
|
||||
|
||||
export %inline
|
||||
split : Loc -> DimEq' (S d) -> Bool -> List (Split d)
|
||||
split loc eqs False = split1' Zero loc eqs
|
||||
split loc eqs True = split1' Zero loc eqs <+> split1' One loc eqs
|
||||
|
||||
export
|
||||
splits' : {d : Nat} -> Loc -> DimEq' d -> List (DSubst d 0)
|
||||
splits' _ [<] = [[<]]
|
||||
splits' loc eqs@(_ :< _) =
|
||||
[th . ph | (eqs', th) <- split loc eqs, ph <- splits' loc eqs']
|
||||
splits' : Loc -> DimEq' d -> FreeVars d -> List (DSubst d 0)
|
||||
splits' _ [<] _ = [id]
|
||||
splits' loc eqs@(_ :< _) us = do
|
||||
let (us, u) = uncons us
|
||||
(eqs', th) <- split loc eqs u
|
||||
ph <- splits' loc eqs' us
|
||||
pure $ th . ph
|
||||
|
||||
||| the Loc is put into each of the DimConsts
|
||||
export %inline
|
||||
splits : {d : Nat} -> Loc -> DimEq d -> List (DSubst d 0)
|
||||
splits _ ZeroIsOne = []
|
||||
splits loc (C eqs) = splits' loc eqs
|
||||
splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
|
||||
splits _ ZeroIsOne _ = []
|
||||
splits loc (C eqs) fvs = splits' loc eqs fvs
|
||||
|
||||
|
||||
-- private
|
||||
-- 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)
|
||||
private
|
||||
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 : Fin d) -> get' (new' {d}) i = Nothing
|
||||
-- newGet' d i = newGetShift d i SZ
|
||||
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 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
|
||||
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 %inline
|
||||
dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec
|
||||
dimEqPrec vars eqs =
|
||||
if length vars <= 1 && maybe True null eqs then Arg else Outer
|
||||
|
||||
private
|
||||
prettyCst : {d : Nat} -> BContext d -> DimT d -> DimT d -> Eff Pretty (Doc opts)
|
||||
prettyCst dnames p q =
|
||||
hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
|
||||
private
|
||||
prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
|
||||
prettyDVars' = traverse prettyDBind . toSnocList'
|
||||
|
||||
private
|
||||
prettyCsts : {d : Nat} -> BContext d -> DimEq' d ->
|
||||
Eff Pretty (SnocList (Doc opts))
|
||||
prettyCsts [<] [<] = pure [<]
|
||||
prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs
|
||||
prettyCsts dnames (eqs :< Just q) =
|
||||
[|prettyCsts (tail dnames) eqs :<
|
||||
prettyCst dnames (BV 0 noLoc) (weak 1 q)|]
|
||||
export
|
||||
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
|
||||
prettyDVars vars =
|
||||
parensIfM (dimEqPrec vars Nothing) $
|
||||
fillSeparateTight !commaD $ !(prettyDVars' vars)
|
||||
|
||||
export
|
||||
prettyDimEq' : {d : Nat} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
|
||||
prettyDimEq' dnames eqs = do
|
||||
vars <- prettyDVars dnames
|
||||
eqs <- prettyCsts dnames eqs
|
||||
let prec = if length vars <= 1 && null eqs then Arg else Outer
|
||||
parensIfM prec $ fillSeparateTight !commaD $ toList vars ++ toList eqs
|
||||
private
|
||||
prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
|
||||
prettyCst dnames p q =
|
||||
hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
|
||||
|
||||
export
|
||||
prettyDimEq : {d : Nat} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
|
||||
prettyDimEq dnames ZeroIsOne = do
|
||||
vars <- prettyDVars dnames
|
||||
cst <- prettyCst [<] (KT Zero noLoc) (KT One noLoc)
|
||||
pure $ separateTight !commaD $ vars :< cst
|
||||
prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
|
||||
private
|
||||
prettyCsts : {opts : _} -> BContext d -> DimEq' d ->
|
||||
Eff Pretty (SnocList (Doc opts))
|
||||
prettyCsts [<] [<] = pure [<]
|
||||
prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs
|
||||
prettyCsts dnames (eqs :< Just q) =
|
||||
[|prettyCsts (tail dnames) eqs :< prettyCst dnames (BV 0 noLoc) (weakD 1 q)|]
|
||||
|
||||
export
|
||||
prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
|
||||
prettyDimEq' vars eqs = do
|
||||
vars' <- prettyDVars' vars
|
||||
eqs' <- prettyCsts vars eqs
|
||||
parensIfM (dimEqPrec vars (Just eqs)) $
|
||||
fillSeparateTight !commaD $ vars' ++ eqs'
|
||||
|
||||
export
|
||||
prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
|
||||
prettyDimEq dnames ZeroIsOne = do
|
||||
vars <- prettyDVars' dnames
|
||||
cst <- prettyCst [<] (K Zero noLoc) (K One noLoc)
|
||||
pure $ separateTight !commaD $ vars :< cst
|
||||
prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
|
||||
|
||||
|
||||
public export
|
||||
wf' : {d : Nat} -> DimEq' d -> Bool
|
||||
wf' [<] = True
|
||||
wf' (eqs :< Nothing) = wf' eqs
|
||||
wf' (eqs :< Just (Th _ (K {}))) = wf' eqs
|
||||
wf' (eqs :< Just (Th i (B _))) = isNothing (get' eqs i.fin) && wf' eqs
|
||||
wf' : DimEq' d -> Bool
|
||||
wf' [<] = True
|
||||
wf' (eqs :< Nothing) = wf' eqs
|
||||
wf' (eqs :< Just (K e _)) = wf' eqs
|
||||
wf' (eqs :< Just (B i _)) = isNothing (get' eqs i) && wf' eqs
|
||||
|
||||
public export
|
||||
wf : {d : Nat} -> DimEq d -> Bool
|
||||
wf : DimEq d -> Bool
|
||||
wf ZeroIsOne = True
|
||||
wf (C eqs) = wf' eqs
|
||||
|
|
|
@ -6,6 +6,7 @@ module Quox.Syntax.Qty
|
|||
|
||||
import Quox.Pretty
|
||||
import Quox.Decidable
|
||||
import Quox.PrettyValExtra
|
||||
import Data.DPair
|
||||
import Derive.Prelude
|
||||
|
||||
|
@ -20,7 +21,7 @@ import Derive.Prelude
|
|||
||| - ω (or #): don't care. an ω variable *can* also be used 0/1 time
|
||||
public export
|
||||
data Qty = Zero | One | Any
|
||||
%runElab derive "Qty" [Eq, Ord, Show]
|
||||
%runElab derive "Qty" [Eq, Ord, Show, PrettyVal]
|
||||
%name Qty.Qty pi, rh
|
||||
|
||||
|
||||
|
@ -78,26 +79,16 @@ lub p q = if p == q then p else Any
|
|||
||| to maintain subject reduction, only 0 or 1 can occur
|
||||
||| for the subject of a typing judgment. see @qtt, §2.3 for more detail
|
||||
public export
|
||||
isSubj : Qty -> Bool
|
||||
isSubj Zero = True
|
||||
isSubj One = True
|
||||
isSubj Any = False
|
||||
|
||||
public export
|
||||
SQty : Type
|
||||
SQty = Subset Qty $ So . isSubj
|
||||
|
||||
public export %inline
|
||||
szero, sone : SQty
|
||||
szero = Element Zero Oh
|
||||
sone = Element One Oh
|
||||
data SQty = SZero | SOne
|
||||
%runElab derive "SQty" [Eq, Ord, Show, PrettyVal]
|
||||
%name Qty.SQty sg
|
||||
|
||||
||| "σ ⨴ π"
|
||||
|||
|
||||
||| σ ⨭ π is 0 if either of σ or π are, otherwise it is σ.
|
||||
||| σ ⨴ π is 0 if either of σ or π are, otherwise it is σ.
|
||||
public export
|
||||
subjMult : SQty -> Qty -> SQty
|
||||
subjMult _ Zero = szero
|
||||
subjMult _ Zero = SZero
|
||||
subjMult sg _ = sg
|
||||
|
||||
|
||||
|
@ -105,23 +96,59 @@ subjMult sg _ = sg
|
|||
||| quantity of 1, so the only distinction is whether it is present
|
||||
||| at runtime at all or not
|
||||
public export
|
||||
isGlobal : Qty -> Bool
|
||||
isGlobal Zero = True
|
||||
isGlobal One = False
|
||||
isGlobal Any = True
|
||||
data GQty = GZero | GAny
|
||||
%runElab derive "GQty" [Eq, Ord, Show, PrettyVal]
|
||||
%name GQty rh
|
||||
|
||||
public export
|
||||
GQty : Type
|
||||
GQty = Subset Qty $ So . isGlobal
|
||||
|
||||
public export
|
||||
gzero, gany : GQty
|
||||
gzero = Element Zero Oh
|
||||
gany = Element Any Oh
|
||||
toGlobal : Qty -> Maybe GQty
|
||||
toGlobal Zero = Just GZero
|
||||
toGlobal Any = Just GAny
|
||||
toGlobal One = Nothing
|
||||
|
||||
||| when checking a definition, a 0 definition is checked at 0,
|
||||
||| but an ω definition is checked at 1 since ω isn't a subject quantity
|
||||
public export %inline
|
||||
globalToSubj : GQty -> SQty
|
||||
globalToSubj (Element Zero _) = szero
|
||||
globalToSubj (Element Any _) = sone
|
||||
globalToSubj GZero = SZero
|
||||
globalToSubj GAny = SOne
|
||||
|
||||
|
||||
public export
|
||||
DecEq Qty where
|
||||
decEq Zero Zero = Yes Refl
|
||||
decEq Zero One = No $ \case _ impossible
|
||||
decEq Zero Any = No $ \case _ impossible
|
||||
decEq One Zero = No $ \case _ impossible
|
||||
decEq One One = Yes Refl
|
||||
decEq One Any = No $ \case _ impossible
|
||||
decEq Any Zero = No $ \case _ impossible
|
||||
decEq Any One = No $ \case _ impossible
|
||||
decEq Any Any = Yes Refl
|
||||
|
||||
public export
|
||||
DecEq SQty where
|
||||
decEq SZero SZero = Yes Refl
|
||||
decEq SZero SOne = No $ \case _ impossible
|
||||
decEq SOne SZero = No $ \case _ impossible
|
||||
decEq SOne SOne = Yes Refl
|
||||
|
||||
public export
|
||||
DecEq GQty where
|
||||
decEq GZero GZero = Yes Refl
|
||||
decEq GZero GAny = No $ \case _ impossible
|
||||
decEq GAny GZero = No $ \case _ impossible
|
||||
decEq GAny GAny = Yes Refl
|
||||
|
||||
|
||||
namespace SQty
|
||||
public export %inline
|
||||
(.qty) : SQty -> Qty
|
||||
(SZero).qty = Zero
|
||||
(SOne).qty = One
|
||||
|
||||
namespace GQty
|
||||
public export %inline
|
||||
(.qty) : GQty -> Qty
|
||||
(GZero).qty = Zero
|
||||
(GAny).qty = Any
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
module Quox.Syntax.Shift
|
||||
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Thin
|
||||
import public Quox.Var
|
||||
|
||||
import Data.Nat
|
||||
import Data.So
|
||||
import Data.DPair
|
||||
import Data.Singleton
|
||||
import Syntax.PreorderReasoning
|
||||
|
||||
%default total
|
||||
|
||||
|
@ -148,6 +148,25 @@ weakViaNat s by =
|
|||
%transform "Shift.weak" Shift.weak = weakViaNat
|
||||
|
||||
|
||||
export
|
||||
getFrom : {to : Nat} -> Shift from to -> Singleton from
|
||||
getFrom SZ = Val to
|
||||
getFrom (SS by) = getFrom by
|
||||
|
||||
private
|
||||
0 getFromViaNatProof : (by : Shift from to) -> from = to `minus` by.nat
|
||||
getFromViaNatProof by = Calc $
|
||||
|~ from
|
||||
~~ minus (by.nat + from) by.nat ..<(minusPlus {})
|
||||
~~ minus to by.nat ..<(cong (flip minus by.nat) (shiftDiff by))
|
||||
|
||||
private
|
||||
getFromViaNat : {to : Nat} -> Shift from to -> Singleton from
|
||||
getFromViaNat by = rewrite getFromViaNatProof by in Val _
|
||||
|
||||
%transform "Shift.getFrom" Shift.getFrom = getFromViaNat
|
||||
|
||||
|
||||
public export
|
||||
shift : Shift from to -> Var from -> Var to
|
||||
shift SZ i = i
|
||||
|
@ -180,11 +199,12 @@ by . SS bz = SS $ by . bz
|
|||
private
|
||||
0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||
to = by.nat + bz.nat + from
|
||||
compNatProof by bz =
|
||||
trans (shiftDiff bz) $
|
||||
trans (cong (bz.nat +) (shiftDiff by)) $
|
||||
trans (plusAssociative bz.nat by.nat from) $
|
||||
cong (+ from) (plusCommutative bz.nat by.nat)
|
||||
compNatProof by bz = Calc $
|
||||
|~ to
|
||||
~~ bz.nat + mid ...(shiftDiff {})
|
||||
~~ bz.nat + (by.nat + from) ...(cong (bz.nat +) (shiftDiff {}))
|
||||
~~ bz.nat + by.nat + from ...(plusAssociative {})
|
||||
~~ by.nat + bz.nat + from ...(cong (+ from) (plusCommutative {}))
|
||||
|
||||
private %inline
|
||||
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||
|
@ -207,7 +227,7 @@ compViaNatCorrect by (SS bz) =
|
|||
%transform "Shift.(.)" Shift.(.) = compViaNat
|
||||
|
||||
|
||||
infixl 8 //
|
||||
export infixl 8 //
|
||||
public export
|
||||
interface CanShift f where
|
||||
(//) : f from -> Shift from to -> f to
|
||||
|
@ -222,15 +242,3 @@ namespace CanShift
|
|||
|
||||
public export %inline
|
||||
[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
|
||||
|
||||
import Quox.Thin
|
||||
import Quox.Loc
|
||||
import public Quox.Syntax.Shift
|
||||
import Quox.Var
|
||||
import Quox.Name
|
||||
|
||||
import Data.DPair
|
||||
import Data.Nat
|
||||
import Data.List
|
||||
import Data.SnocVect
|
||||
import Data.Singleton
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
|
@ -13,159 +15,155 @@ import Derive.Prelude
|
|||
|
||||
|
||||
public export
|
||||
Subst : (Nat -> Type) -> Nat -> Nat -> Type
|
||||
Subst env from to = SnocVect from (Lazy (Thinned env to))
|
||||
data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
|
||||
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
|
||||
Subst2 : (Nat -> Nat -> Type) -> Nat -> Nat -> Nat -> Type
|
||||
Subst2 env d from to = SnocVect from (Lazy (Thinned2 env d to))
|
||||
(!:::) : env to -> Subst env from to -> Subst env (S from) to
|
||||
t !::: ts = t ::: ts
|
||||
|
||||
|
||||
private
|
||||
Repr : (Nat -> Type) -> Nat -> Type
|
||||
Repr f to = (List (f to), Nat)
|
||||
|
||||
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)
|
||||
|
||||
|
||||
export Eq (f to) => Eq (Subst f from to) where (==) = (==) `on` repr
|
||||
export Ord (f to) => Ord (Subst f from to) where compare = compare `on` repr
|
||||
export Show (f to) => Show (Subst f from to) where show = show . repr
|
||||
|
||||
|
||||
export infixl 8 //
|
||||
public export
|
||||
interface FromVar term => CanSubstSelf term where
|
||||
(//) : term from -> Lazy (Subst term from to) -> term to
|
||||
|
||||
|
||||
public export
|
||||
get : Subst env f t -> Fin f -> Thinned env t
|
||||
get (sx :< x) FZ = x
|
||||
get (sx :< x) (FS i) = get sx i
|
||||
getLoc : FromVar term => Subst term from to -> Var from -> Loc -> term to
|
||||
getLoc (Shift by) i loc = fromVarLoc (shift by i) loc
|
||||
getLoc (t ::: th) VZ _ = t
|
||||
getLoc (t ::: th) (VS i) loc = getLoc th i loc
|
||||
|
||||
|
||||
public export
|
||||
interface FromVar (0 term : Nat -> Type) where
|
||||
var : Loc -> term 1
|
||||
|
||||
public export
|
||||
0 FromVar2 : (Nat -> Nat -> Type) -> Type
|
||||
FromVar2 t = FromVar (t 0)
|
||||
|
||||
public export
|
||||
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
|
||||
interface FromVar term => CanSubstSelf term where
|
||||
(//) : {f : Nat} -> Thinned term f -> Subst term f t -> Thinned term t
|
||||
|
||||
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
|
||||
tabulate : (n : Nat) -> SnocVect n (Fin n)
|
||||
tabulate n = go n id where
|
||||
go : (n : Nat) -> (Fin n -> Fin n') -> SnocVect n (Fin n')
|
||||
go 0 f = [<]
|
||||
go (S n) f = go n (f . FS) :< f FZ
|
||||
|
||||
public export
|
||||
id : FromVar term => {n : Nat} -> (under : Nat) -> Loc ->
|
||||
Subst term n (n + under)
|
||||
id under loc =
|
||||
map (\i => delay $ varT (weakenN under i) loc) (tabulate n)
|
||||
|
||||
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
|
||||
CanSubstSelf Var where
|
||||
i // Shift by = shift by i
|
||||
VZ // (t ::: th) = t
|
||||
VS i // (t ::: th) = i // th
|
||||
|
||||
|
||||
public export %inline
|
||||
one : Thinned f n -> Subst f 1 n
|
||||
one x = [< x]
|
||||
shift : (by : Nat) -> Subst env from (by + from)
|
||||
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
|
||||
cmpShape : SnocVect m a -> SnocVect n a -> Either Ordering (m = n)
|
||||
cmpShape [<] [<] = Right Refl
|
||||
cmpShape [<] (sx :< _) = Left LT
|
||||
cmpShape (sx :< _) [<] = Left GT
|
||||
cmpShape (sx :< _) (sy :< _) = cong S <$> cmpShape sx sy
|
||||
getFrom : {to : Nat} -> Subst _ from to -> Singleton from
|
||||
getFrom (Shift by) = getFrom by
|
||||
getFrom (t ::: th) = [|S $ getFrom th|]
|
||||
|
||||
|
||||
||| whether two substitutions with the same codomain have the same shape
|
||||
||| (the same number of terms and the same shift at the end). if so, they
|
||||
||| also have the same domain
|
||||
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
|
||||
record WithSubst tm env n where
|
||||
constructor Sub
|
||||
term : tm from
|
||||
subst : Subst env from n
|
||||
subst : Lazy (Subst env from n)
|
||||
|
||||
{-
|
||||
export
|
||||
(forall n. Eq (env n), forall n. Eq (tm n)) =>
|
||||
Eq (WithSubst tm env n) where
|
||||
(Eq (env n), forall n. Eq (tm n)) => Eq (WithSubst tm env n) where
|
||||
Sub t1 s1 == Sub t2 s2 =
|
||||
case cmpShape s1 s2 of
|
||||
Left _ => False
|
||||
Right Refl =>
|
||||
t1 == t2 && concat @{All} (zipWith ((==) `on` force) s1 s2)
|
||||
Right Refl => t1 == t2 && s1 == s2
|
||||
|
||||
export
|
||||
(forall n. Ord (env n), forall n. Ord (tm n)) =>
|
||||
Ord (WithSubst tm env n) where
|
||||
(Ord (env n), forall n. Ord (tm n)) => Ord (WithSubst tm env n) where
|
||||
Sub t1 s1 `compare` Sub t2 s2 =
|
||||
case cmpShape s1 s2 of
|
||||
Left o => o
|
||||
Right Refl =>
|
||||
compare t1 t2 <+> concat (zipWith (compare `on` force) s1 s2)
|
||||
Right Refl => compare (t1, s1) (t2, s2)
|
||||
|
||||
export %hint
|
||||
ShowWithSubst : {n : Nat} ->
|
||||
(forall n. Show (env n), forall n. Show (tm n)) =>
|
||||
ShowWithSubst : (Show (env n), forall n. Show (tm n)) =>
|
||||
Show (WithSubst tm env n)
|
||||
ShowWithSubst = deriveShow where
|
||||
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
|
||||
ShowWithSubst = deriveShow
|
||||
|
|
|
@ -3,4 +3,3 @@ module Quox.Syntax.Term
|
|||
import public Quox.Syntax.Term.Base
|
||||
import public Quox.Syntax.Term.Subst
|
||||
import public Quox.Syntax.Term.Pretty
|
||||
import public Quox.Syntax.Term.Tighten
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
module Quox.Syntax.Term.Base
|
||||
|
||||
import public Quox.Thin
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Var
|
||||
import public Quox.Scoped
|
||||
import public Quox.Syntax.Shift
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Syntax.Qty
|
||||
|
@ -19,6 +19,9 @@ import Data.Maybe
|
|||
import Data.Nat
|
||||
import public Data.So
|
||||
import Data.String
|
||||
import public Data.SortedMap
|
||||
import public Data.SortedMap.Dependent
|
||||
import public Data.SortedSet
|
||||
import Derive.Prelude
|
||||
|
||||
%default total
|
||||
|
@ -44,344 +47,406 @@ TagVal : Type
|
|||
TagVal = String
|
||||
|
||||
|
||||
||| type-checkable terms, which consists of types and constructor forms.
|
||||
|||
|
||||
||| first argument `d` is dimension scope size; second `n` is term scope size
|
||||
public export
|
||||
data Term : (d, n : Nat) -> Type
|
||||
%name Term s, t, r
|
||||
mutual
|
||||
public export
|
||||
TSubst : TSubstLike
|
||||
TSubst d = Subst $ \n => Elim d n
|
||||
|
||||
||| inferrable terms, which consists of elimination forms like application and
|
||||
||| `case` (as well as other terms with an annotation)
|
||||
|||
|
||||
||| first argument `d` is dimension scope size; second `n` is term scope size
|
||||
public export
|
||||
data Elim : (d, n : Nat) -> Type
|
||||
%name Elim e, f
|
||||
||| first argument `d` is dimension scope size;
|
||||
||| second `n` is term scope size
|
||||
public export
|
||||
data Term : (d, n : Nat) -> Type where
|
||||
||| type of types
|
||||
TYPE : (l : Universe) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| IO state token. this is a builtin because otherwise #[main] being a
|
||||
||| builtin makes no sense
|
||||
IOState : (loc : Loc) -> Term d n
|
||||
|
||||
||| function type
|
||||
Pi : (qty : Qty) -> (arg : Term d n) ->
|
||||
(res : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||
||| function term
|
||||
Lam : (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| pair type
|
||||
Sig : (fst : Term d n) -> (snd : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||
||| pair value
|
||||
Pair : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| enumeration type
|
||||
Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term d n
|
||||
||| enumeration value
|
||||
Tag : (tag : TagVal) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| equality type
|
||||
Eq : (ty : DScopeTerm d n) -> (l, r : Term d n) -> (loc : Loc) -> Term d n
|
||||
||| equality term
|
||||
DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| natural numbers (temporary until 𝐖 gets added)
|
||||
NAT : (loc : Loc) -> Term d n
|
||||
Nat : (val : Nat) -> (loc : Loc) -> Term d n
|
||||
Succ : (p : Term d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| strings
|
||||
STRING : (loc : Loc) -> Term d n
|
||||
Str : (str : String) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| "box" (package a value up with a certain quantity)
|
||||
BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
|
||||
Box : (val : Term d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
Let : (qty : Qty) -> (rhs : Elim d n) ->
|
||||
(body : ScopeTerm d n) -> (loc : Loc) -> Term d n
|
||||
|
||||
||| elimination
|
||||
E : (e : Elim d n) -> Term d n
|
||||
|
||||
||| term closure/suspended substitution
|
||||
CloT : WithSubst (Term d) (Elim d) n -> Term d n
|
||||
||| dimension closure/suspended substitution
|
||||
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
|
||||
data Elim : (d, n : Nat) -> Type where
|
||||
||| free variable, possibly with a displacement (see @crude, or @mugen for a
|
||||
||| more abstract and formalised take)
|
||||
|||
|
||||
||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
|
||||
F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim d n
|
||||
||| bound variable
|
||||
B : (i : Var n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| term application
|
||||
App : (fun : Elim d n) -> (arg : Term d n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| pair destruction
|
||||
|||
|
||||
||| `CasePair 𝜋 𝑒 ([𝑟], 𝐴) ([𝑥, 𝑦], 𝑡)` is
|
||||
||| `𝐜𝐚𝐬𝐞 𝜋 · 𝑒 𝐫𝐞𝐭𝐮𝐫𝐧 𝑟 ⇒ 𝐴 𝐨𝐟 { (𝑥, 𝑦) ⇒ 𝑡 }`
|
||||
CasePair : (qty : Qty) -> (pair : Elim d n) ->
|
||||
(ret : ScopeTerm d n) ->
|
||||
(body : ScopeTermN 2 d n) ->
|
||||
(loc : Loc) ->
|
||||
Elim d n
|
||||
|
||||
||| first element of a pair. only works in non-linear contexts.
|
||||
Fst : (pair : Elim d n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| second element of a pair. only works in non-linear contexts.
|
||||
Snd : (pair : Elim d n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| enum matching
|
||||
CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
|
||||
(ret : ScopeTerm d n) ->
|
||||
(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
|
||||
DApp : (fun : Elim d n) -> (arg : Dim d) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| type-annotated term
|
||||
Ann : (tm, ty : Term d n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| coerce a value along a type equality, or show its coherence
|
||||
||| [@xtt; §2.1.1]
|
||||
Coe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
|
||||
(val : Term d n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| "generalised composition" [@xtt; §2.1.2]
|
||||
Comp : (ty : Term d n) -> (p, q : Dim d) ->
|
||||
(val : Term d n) -> (r : Dim d) ->
|
||||
(zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
|
||||
|
||||
||| match on types. needed for b.s. of coercions [@xtt; §2.2]
|
||||
TypeCase : (ty : Elim d n) -> (ret : Term d n) ->
|
||||
(arms : TypeCaseArms d n) -> (def : Term d n) ->
|
||||
(loc : Loc) ->
|
||||
Elim d n
|
||||
|
||||
||| term closure/suspended substitution
|
||||
CloE : WithSubst (Elim d) (Elim d) n -> Elim d n
|
||||
||| dimension closure/suspended substitution
|
||||
DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
|
||||
%name Elim e, f
|
||||
|
||||
public export
|
||||
CaseEnumArms : TermLike
|
||||
CaseEnumArms d n = SortedMap TagVal (Term d n)
|
||||
|
||||
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 : Nat -> TermLike
|
||||
ScopeTermN s d n = ScopedN s (\n => Term d n) n
|
||||
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
|
||||
DScopeTermN : Nat -> TermLike
|
||||
DScopeTermN s d n = ScopedN s (\d => Term d n) d
|
||||
public export
|
||||
ScopeTerm, DScopeTerm : TermLike
|
||||
ScopeTerm = ScopeTermN 1
|
||||
DScopeTerm = DScopeTermN 1
|
||||
|
||||
public export
|
||||
ScopeTerm : TermLike
|
||||
ScopeTerm = ScopeTermN 1
|
||||
mutual
|
||||
export %hint
|
||||
EqTerm : Eq (Term d n)
|
||||
EqTerm = assert_total {a = Eq (Term d n)} deriveEq
|
||||
|
||||
public export
|
||||
DScopeTerm : TermLike
|
||||
DScopeTerm = DScopeTermN 1
|
||||
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
|
||||
|
||||
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 : (l : Universe) -> (loc : Loc) -> Term 0 0
|
||||
|
||||
||| function type
|
||||
Pi : Qty -> Subterms [Term, ScopeTerm] d n -> Loc -> Term d n
|
||||
||| function value
|
||||
Lam : ScopeTerm d n -> Loc -> Term d n
|
||||
|
||||
||| pair type
|
||||
Sig : Subterms [Term, ScopeTerm] d n -> Loc -> Term d n
|
||||
||| pair value
|
||||
Pair : Subterms [Term, Term] d n -> Loc -> Term d n
|
||||
|
||||
||| enum type
|
||||
Enum : List TagVal -> Loc -> Term 0 0
|
||||
||| enum value
|
||||
Tag : TagVal -> Loc -> Term 0 0
|
||||
|
||||
||| equality type
|
||||
Eq : Subterms [DScopeTerm, Term, Term] d n -> Loc -> Term d n
|
||||
||| equality value
|
||||
DLam : DScopeTerm d n -> Loc -> Term d n
|
||||
|
||||
||| natural numbers (temporary until 𝐖 gets added)
|
||||
Nat : Loc -> Term 0 0
|
||||
Zero : Loc -> Term 0 0
|
||||
Succ : Term d n -> Loc -> Term 0 0
|
||||
|
||||
||| package a value with a quantity
|
||||
||| e.g. a value of [ω. A], when unpacked, can be used ω times,
|
||||
||| even if the box itself is linear
|
||||
BOX : Qty -> Term d n -> Loc -> Term d n
|
||||
Box : Term d n -> Loc -> Term d n
|
||||
|
||||
E : Elim d n -> Term d n
|
||||
|
||||
||| term closure/suspended substitution
|
||||
CloT : WithSubst2 Term Elim d n -> Term d n
|
||||
||| dimension closure/suspended substitution
|
||||
DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
|
||||
|
||||
public export
|
||||
data Elim where
|
||||
||| free variable, possibly with a displacement (see @crude, or @mugen for a
|
||||
||| more abstract and formalised take)
|
||||
|||
|
||||
||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
|
||||
F : Name -> Universe -> Loc -> Elim 0 0
|
||||
||| bound variable
|
||||
B : Loc -> Elim 0 1
|
||||
|
||||
||| term application
|
||||
App : Subterms [Elim, Term] d n -> Loc -> Elim d n
|
||||
|
||||
||| pair match
|
||||
||| - the subterms are, in order: [head, return type, body]
|
||||
||| - the quantity is that of the head, and since pairs only have one
|
||||
||| constructor, can be 0
|
||||
CasePair : Qty -> Subterms [Elim, ScopeTerm, ScopeTermN 2] d n ->
|
||||
Loc -> Elim d n
|
||||
|
||||
||| enum match
|
||||
CaseEnum : Qty -> (arms : List TagVal) ->
|
||||
Subterms (Elim :: ScopeTerm :: (Term <$ arms)) d n ->
|
||||
Loc -> Elim d n
|
||||
|
||||
||| nat match
|
||||
CaseNat : Qty -> Qty ->
|
||||
Subterms [Elim, ScopeTerm, Term, ScopeTermN 2] d n ->
|
||||
Loc -> Elim d n
|
||||
|
||||
||| box match
|
||||
CaseBox : Qty -> Subterms [Elim, ScopeTerm, ScopeTerm] d n -> Loc -> Elim d n
|
||||
|
||||
||| dim application
|
||||
DApp : Subterms [Elim, DimArg] d n -> Loc -> Elim d n
|
||||
|
||||
||| type-annotated term
|
||||
Ann : Subterms [Term, Term] d n -> Loc -> Elim d n
|
||||
|
||||
||| coerce a value along a type equality, or show its coherence
|
||||
||| [@xtt; §2.1.1]
|
||||
Coe : Subterms [DScopeTerm, DimArg, DimArg, Term] d n ->
|
||||
Loc -> Elim d n
|
||||
|
||||
||| "generalised composition" [@xtt; §2.1.2]
|
||||
Comp : Subterms [Term, DimArg, DimArg, Term,
|
||||
DimArg, DScopeTerm, DScopeTerm] d n ->
|
||||
Loc -> Elim d n
|
||||
|
||||
||| match on types. needed for b.s. of coercions [@xtt; §2.2]
|
||||
TypeCase : Subterms [Elim, Term, -- head, type
|
||||
Term, -- ★
|
||||
ScopeTermN 2, -- pi
|
||||
ScopeTermN 2, -- sig
|
||||
Term, -- enum
|
||||
ScopeTermN 5, -- eq
|
||||
Term, -- nat
|
||||
ScopeTerm -- box
|
||||
] d n -> Loc -> Elim d n
|
||||
|
||||
||| term closure/suspended substitution
|
||||
CloE : WithSubst2 Elim Elim d n -> Elim d n
|
||||
||| dimension closure/suspended substitution
|
||||
DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
|
||||
|
||||
|
||||
-- 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
|
||||
makeNat : Nat -> Loc -> Term 0 0
|
||||
makeNat 0 loc = Zero loc
|
||||
makeNat (S k) loc = Succ (makeNat k loc) loc
|
||||
export %hint
|
||||
ShowElim : Show (Elim d n)
|
||||
ShowElim = assert_total {a = Show (Elim d n)} deriveShow
|
||||
|
||||
|
||||
export
|
||||
Located (Elim d n) where
|
||||
(F _ _ loc).loc = loc
|
||||
(B loc).loc = loc
|
||||
(App _ loc).loc = loc
|
||||
(CasePair _ _ loc).loc = loc
|
||||
(CaseEnum _ _ _ loc).loc = loc
|
||||
(CaseNat _ _ _ loc).loc = loc
|
||||
(CaseBox _ _ loc).loc = loc
|
||||
(DApp _ loc).loc = loc
|
||||
(Ann _ loc).loc = loc
|
||||
(Coe _ loc).loc = loc
|
||||
(Comp _ loc).loc = loc
|
||||
(TypeCase _ loc).loc = loc
|
||||
(CloE (Sub2 e _)).loc = e.loc
|
||||
(DCloE (Sub e _)).loc = e.loc
|
||||
(F _ _ loc).loc = loc
|
||||
(B _ loc).loc = loc
|
||||
(App _ _ loc).loc = loc
|
||||
(CasePair _ _ _ _ loc).loc = loc
|
||||
(Fst _ loc).loc = loc
|
||||
(Snd _ loc).loc = loc
|
||||
(CaseEnum _ _ _ _ loc).loc = loc
|
||||
(CaseNat _ _ _ _ _ _ loc).loc = loc
|
||||
(CaseBox _ _ _ _ loc).loc = loc
|
||||
(DApp _ _ loc).loc = loc
|
||||
(Ann _ _ loc).loc = loc
|
||||
(Coe _ _ _ _ loc).loc = loc
|
||||
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
||||
(TypeCase _ _ _ _ loc).loc = loc
|
||||
(CloE (Sub e _)).loc = e.loc
|
||||
(DCloE (Sub e _)).loc = e.loc
|
||||
|
||||
export
|
||||
Located (Term d n) where
|
||||
(TYPE _ loc).loc = loc
|
||||
(Pi _ _ loc).loc = loc
|
||||
(IOState loc).loc = loc
|
||||
(Pi _ _ _ loc).loc = loc
|
||||
(Lam _ loc).loc = loc
|
||||
(Sig _ loc).loc = loc
|
||||
(Pair _ loc).loc = loc
|
||||
(Sig _ _ loc).loc = loc
|
||||
(Pair _ _ loc).loc = loc
|
||||
(Enum _ loc).loc = loc
|
||||
(Tag _ loc).loc = loc
|
||||
(Eq _ loc).loc = loc
|
||||
(Eq _ _ _ loc).loc = loc
|
||||
(DLam _ loc).loc = loc
|
||||
(Nat loc).loc = loc
|
||||
(Zero loc).loc = loc
|
||||
(NAT loc).loc = loc
|
||||
(Nat _ loc).loc = loc
|
||||
(STRING loc).loc = loc
|
||||
(Str _ loc).loc = loc
|
||||
(Succ _ loc).loc = loc
|
||||
(BOX _ _ loc).loc = loc
|
||||
(Box _ loc).loc = loc
|
||||
(Let _ _ _ loc).loc = loc
|
||||
(E e).loc = e.loc
|
||||
(CloT (Sub2 t _)).loc = t.loc
|
||||
(CloT (Sub t _)).loc = t.loc
|
||||
(DCloT (Sub t _)).loc = t.loc
|
||||
|
||||
export
|
||||
Located1 f => Located (ScopedBody s f n) where
|
||||
(Y t).loc = t.loc
|
||||
(N t).loc = t.loc
|
||||
|
||||
export
|
||||
Located1 f => Located (Scoped s f n) where
|
||||
t.loc = t.body.loc
|
||||
|
||||
|
||||
export
|
||||
Relocatable (Elim d n) where
|
||||
setLoc loc (F x u _) = F x u loc
|
||||
setLoc loc (B _) = B loc
|
||||
setLoc loc (App ts _) = App ts loc
|
||||
setLoc loc (CasePair qty ts _) = CasePair qty ts loc
|
||||
setLoc loc (CaseEnum qty arms ts _) = CaseEnum qty arms ts loc
|
||||
setLoc loc (CaseNat qty qtyIH ts _) = CaseNat qty qtyIH ts loc
|
||||
setLoc loc (CaseBox qty ts _) = CaseBox qty ts loc
|
||||
setLoc loc (DApp ts _) = DApp ts loc
|
||||
setLoc loc (Ann ts _) = Ann ts loc
|
||||
setLoc loc (Coe ts _) = Coe ts loc
|
||||
setLoc loc (Comp ts _) = Comp ts loc
|
||||
setLoc loc (TypeCase ts _) = TypeCase ts loc
|
||||
setLoc loc (CloE (Sub2 term subst)) = CloE $ Sub2 (setLoc loc term) subst
|
||||
setLoc loc (DCloE (Sub term subst)) = DCloE $ Sub (setLoc loc term) subst
|
||||
setLoc loc (F x u _) = F x u loc
|
||||
setLoc loc (B i _) = B i loc
|
||||
setLoc loc (App fun arg _) = App fun arg loc
|
||||
setLoc loc (CasePair qty pair ret body _) =
|
||||
CasePair qty pair ret body loc
|
||||
setLoc loc (Fst pair _) = Fst pair loc
|
||||
setLoc loc (Snd pair _) = Fst pair loc
|
||||
setLoc loc (CaseEnum qty tag ret arms _) =
|
||||
CaseEnum qty tag ret arms loc
|
||||
setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
|
||||
CaseNat qty qtyIH nat ret zero succ loc
|
||||
setLoc loc (CaseBox qty box ret body _) =
|
||||
CaseBox qty box ret body loc
|
||||
setLoc loc (DApp fun arg _) =
|
||||
DApp fun arg loc
|
||||
setLoc loc (Ann tm ty _) =
|
||||
Ann tm ty loc
|
||||
setLoc loc (Coe ty p q val _) =
|
||||
Coe ty p q val loc
|
||||
setLoc loc (Comp ty p q val r zero one _) =
|
||||
Comp ty p q val r zero one loc
|
||||
setLoc loc (TypeCase ty ret arms def _) =
|
||||
TypeCase ty ret arms def loc
|
||||
setLoc loc (CloE (Sub term subst)) =
|
||||
CloE $ Sub (setLoc loc term) subst
|
||||
setLoc loc (DCloE (Sub term subst)) =
|
||||
DCloE $ Sub (setLoc loc term) subst
|
||||
|
||||
export
|
||||
Relocatable (Term d n) where
|
||||
setLoc loc (TYPE l _) = TYPE l loc
|
||||
setLoc loc (Pi qty ts _) = Pi qty ts loc
|
||||
setLoc loc (Lam body _) = Lam body loc
|
||||
setLoc loc (Sig ts _) = Sig ts loc
|
||||
setLoc loc (Pair ts _) = Pair ts loc
|
||||
setLoc loc (Enum cases _) = Enum cases loc
|
||||
setLoc loc (Tag tag _) = Tag tag loc
|
||||
setLoc loc (Eq ts _) = Eq ts loc
|
||||
setLoc loc (DLam body _) = DLam body loc
|
||||
setLoc loc (Nat _) = Nat loc
|
||||
setLoc loc (Zero _) = Zero loc
|
||||
setLoc loc (Succ p _) = Succ p loc
|
||||
setLoc loc (BOX qty ty _) = BOX qty ty loc
|
||||
setLoc loc (Box val _) = Box val loc
|
||||
setLoc loc (E e) = E $ setLoc loc e
|
||||
setLoc loc (CloT (Sub2 term subst)) = CloT $ Sub2 (setLoc loc term) subst
|
||||
setLoc loc (TYPE l _) = TYPE l loc
|
||||
setLoc loc (IOState _) = IOState loc
|
||||
setLoc loc (Pi qty arg res _) = Pi qty arg res loc
|
||||
setLoc loc (Lam body _) = Lam body loc
|
||||
setLoc loc (Sig fst snd _) = Sig fst snd loc
|
||||
setLoc loc (Pair fst snd _) = Pair fst snd loc
|
||||
setLoc loc (Enum cases _) = Enum cases loc
|
||||
setLoc loc (Tag tag _) = Tag tag loc
|
||||
setLoc loc (Eq ty l r _) = Eq ty l r loc
|
||||
setLoc loc (DLam body _) = DLam body loc
|
||||
setLoc loc (NAT _) = NAT loc
|
||||
setLoc loc (Nat n _) = Nat n loc
|
||||
setLoc loc (Succ p _) = Succ p loc
|
||||
setLoc loc (STRING _) = STRING loc
|
||||
setLoc loc (Str s _) = Str s loc
|
||||
setLoc loc (BOX qty ty _) = BOX qty ty loc
|
||||
setLoc loc (Box val _) = Box val loc
|
||||
setLoc loc (Let qty rhs body _) = Let qty rhs body loc
|
||||
setLoc loc (E e) = E $ setLoc loc e
|
||||
setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
|
||||
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
|
||||
|
||||
export
|
||||
Relocatable1 f => Relocatable (ScopedBody s f n) where
|
||||
setLoc loc (Y body) = Y $ setLoc loc body
|
||||
setLoc loc (N body) = N $ setLoc loc body
|
||||
|
||||
export
|
||||
Relocatable1 f => Relocatable (Scoped s f n) where
|
||||
setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
|
||||
|
||||
|
||||
||| 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
|
||||
prettyTerm : {opts : _} -> BContext d -> BContext n -> TermT d n ->
|
||||
prettyTerm : {opts : _} -> BContext d -> BContext n -> Term d n ->
|
||||
Eff Pretty (Doc opts)
|
||||
|
||||
export
|
||||
prettyElim : {opts : _} -> BContext d -> BContext n -> ElimT d n ->
|
||||
prettyElim : {opts : _} -> BContext d -> BContext n -> Elim d n ->
|
||||
Eff Pretty (Doc opts)
|
||||
|
||||
private
|
||||
|
@ -30,14 +30,6 @@ BTelescope : Nat -> Nat -> Type
|
|||
BTelescope = Telescope' BindName
|
||||
|
||||
|
||||
private
|
||||
subscript : String -> String
|
||||
subscript = pack . map sub . unpack where
|
||||
sub : Char -> Char
|
||||
sub c = case c of
|
||||
'0' => '₀'; '1' => '₁'; '2' => '₂'; '3' => '₃'; '4' => '₄'
|
||||
'5' => '₅'; '6' => '₆'; '7' => '₇'; '8' => '₈'; '9' => '₉'; _ => c
|
||||
|
||||
private
|
||||
superscript : String -> String
|
||||
superscript = pack . map sup . unpack where
|
||||
|
@ -209,8 +201,7 @@ prettyTArg dnames tnames s =
|
|||
|
||||
private
|
||||
prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
|
||||
prettyDArg dnames p =
|
||||
map (text "@" <+>) $ withPrec Arg $ prettyDim dnames p
|
||||
prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
|
||||
|
||||
private
|
||||
splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
|
||||
|
@ -238,7 +229,6 @@ prettyDTApps dnames tnames f xs = do
|
|||
private
|
||||
record CaseArm opts d n where
|
||||
constructor MkCaseArm
|
||||
{0 dinner, ninner : Nat}
|
||||
pat : Doc opts
|
||||
dbinds : BTelescope d dinner -- 🍴
|
||||
tbinds : BTelescope n ninner
|
||||
|
@ -251,12 +241,11 @@ parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
|
|||
body <- withPrec Outer $ assert_total
|
||||
prettyTerm (dnames . dbinds) (tnames . tbinds) body
|
||||
header <- (pat <++>) <$> darrowD
|
||||
pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
|
||||
pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
|
||||
|
||||
private
|
||||
prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (Doc opts)
|
||||
prettyCaseBody xs =
|
||||
braces . separateTight !semiD =<< traverse prettyCaseArm xs
|
||||
prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts))
|
||||
prettyCaseBody xs = traverse prettyCaseArm xs
|
||||
|
||||
private
|
||||
prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts)
|
||||
|
@ -283,16 +272,12 @@ layoutComp typq val r arms = do
|
|||
[typq, [val, r <++> lb], map (indent ind) arms, [rb]])
|
||||
|
||||
|
||||
export
|
||||
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
|
||||
prettyTag tag = hl Tag $ text $ "'" ++ quoteTag tag
|
||||
|
||||
export
|
||||
prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
|
||||
prettyEnum cases =
|
||||
tightBraces =<<
|
||||
fillSeparateTight !commaD <$>
|
||||
traverse (hl Tag . Doc.text . quoteTag) cases
|
||||
traverse (hl Constant . Doc.text . quoteTag) cases
|
||||
|
||||
private
|
||||
prettyCaseRet : {opts : _} ->
|
||||
|
@ -303,7 +288,7 @@ prettyCaseRet dnames tnames body = withPrec Outer $ case body of
|
|||
S [< x] (Y tm) => do
|
||||
header <- [|prettyTBind x <++> darrowD|]
|
||||
body <- assert_total prettyTerm dnames (tnames :< x) tm
|
||||
pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
|
||||
hangDSingle header body
|
||||
|
||||
private
|
||||
prettyCase_ : {opts : _} ->
|
||||
|
@ -311,10 +296,16 @@ prettyCase_ : {opts : _} ->
|
|||
Doc opts -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) ->
|
||||
Eff Pretty (Doc opts)
|
||||
prettyCase_ dnames tnames intro head ret body = do
|
||||
head <- assert_total prettyElim dnames tnames head
|
||||
ret <- prettyCaseRet dnames tnames ret
|
||||
body <- prettyCaseBody dnames tnames body
|
||||
parensIfM Outer $ sep [intro <++> head, !returnD <++> ret, !ofD <++> body]
|
||||
head <- withPrec Outer $ assert_total prettyElim dnames tnames head
|
||||
ret <- prettyCaseRet dnames tnames ret
|
||||
bodys <- prettyCaseBody dnames tnames body
|
||||
return <- returnD; of_ <- ofD
|
||||
lb <- hl Delim "{"; rb <- hl Delim "}"; semi <- semiD
|
||||
ind <- askAt INDENT
|
||||
parensIfM Outer $ ifMultiline
|
||||
(hsep [intro, head, return, ret, of_, lb, hseparateTight semi bodys, rb])
|
||||
(vsep [intro <++> head, return <++> ret, of_ <++> lb,
|
||||
indent ind $ vseparateTight semi bodys, rb])
|
||||
|
||||
private
|
||||
prettyCase : {opts : _} ->
|
||||
|
@ -325,6 +316,62 @@ prettyCase dnames tnames qty head ret body =
|
|||
prettyCase_ dnames tnames ![|caseD <+> prettyQty qty|] head ret body
|
||||
|
||||
|
||||
private
|
||||
LetBinder : Nat -> Nat -> Type
|
||||
LetBinder d n = (Qty, BindName, Elim d n)
|
||||
|
||||
private
|
||||
LetExpr : Nat -> Nat -> Nat -> Type
|
||||
LetExpr d n n' = (Telescope (LetBinder d) n n', Term d n')
|
||||
|
||||
-- [todo] factor out this and the untyped version somehow
|
||||
export
|
||||
splitLet : Telescope (LetBinder d) n n' -> Term d n' -> Exists (LetExpr d n)
|
||||
splitLet ys t@(Let qty rhs body _) =
|
||||
splitLet (ys :< (qty, body.name, rhs)) (assert_smaller t body.term)
|
||||
splitLet ys t =
|
||||
Evidence _ (ys, t)
|
||||
|
||||
private covering
|
||||
prettyLets : {opts : LayoutOpts} ->
|
||||
BContext d -> BContext a -> Telescope (LetBinder d) a b ->
|
||||
Eff Pretty (SnocList (Doc opts))
|
||||
prettyLets dnames xs lets = snd <$> go lets where
|
||||
peelAnn : forall d, n. Elim d n -> Maybe (Term d n, Term d n)
|
||||
peelAnn (Ann tm ty _) = Just (tm, ty)
|
||||
peelAnn e = Nothing
|
||||
|
||||
letHeader : Qty -> BindName -> Eff Pretty (Doc opts)
|
||||
letHeader qty x = do
|
||||
lett <- [|letD <+> prettyQty qty|]
|
||||
x <- prettyTBind x
|
||||
pure $ lett <++> x
|
||||
|
||||
letBody : forall n. BContext n ->
|
||||
Doc opts -> Elim d n -> Eff Pretty (Doc opts)
|
||||
letBody tnames hdr e = case peelAnn e of
|
||||
Just (tm, ty) => do
|
||||
ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty
|
||||
tm <- withPrec Outer $ assert_total prettyTerm dnames tnames tm
|
||||
colon <- colonD; eq <- cstD; d <- askAt INDENT
|
||||
pure $ hangSingle d (hangSingle d hdr (colon <++> ty)) (eq <++> tm)
|
||||
Nothing => do
|
||||
e <- withPrec Outer $ assert_total prettyElim dnames tnames e
|
||||
eq <- cstD; d <- askAt INDENT
|
||||
inn <- inD
|
||||
pure $ ifMultiline
|
||||
(hsep [hdr, eq, e, inn])
|
||||
(vsep [hdr, indent d $ hsep [eq, e, inn]])
|
||||
|
||||
go : forall b. Telescope (LetBinder d) a b ->
|
||||
Eff Pretty (BContext b, SnocList (Doc opts))
|
||||
go [<] = pure (xs, [<])
|
||||
go (lets :< (qty, x, rhs)) = do
|
||||
(ys, docs) <- go lets
|
||||
doc <- letBody ys !(letHeader qty x) rhs
|
||||
pure (ys :< x, docs :< doc)
|
||||
|
||||
|
||||
private
|
||||
isDefaultDir : Dim d -> Dim d -> Bool
|
||||
isDefaultDir (K Zero _) (K One _) = True
|
||||
|
@ -342,6 +389,7 @@ prettyTyCasePat : {opts : _} ->
|
|||
(k : TyConKind) -> BContext (arity k) ->
|
||||
Eff Pretty (Doc opts)
|
||||
prettyTyCasePat KTYPE [<] = typeD
|
||||
prettyTyCasePat KIOState [<] = ioStateD
|
||||
prettyTyCasePat KPi [< a, b] =
|
||||
parens . hsep =<< sequence [prettyTBind a, arrowD, prettyTBind b]
|
||||
prettyTyCasePat KSig [< a, b] =
|
||||
|
@ -350,6 +398,7 @@ prettyTyCasePat KEnum [<] = hl Syntax $ text "{}"
|
|||
prettyTyCasePat KEq [< a0, a1, a, l, r] =
|
||||
hsep <$> sequence (eqD :: map prettyTBind [a0, a1, a, l, r])
|
||||
prettyTyCasePat KNat [<] = natD
|
||||
prettyTyCasePat KString [<] = stringD
|
||||
prettyTyCasePat KBOX [< a] = bracks =<< prettyTBind a
|
||||
|
||||
|
||||
|
@ -383,13 +432,13 @@ prettyDisp u = map Just $ hl Universe =<<
|
|||
ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
|
||||
|
||||
|
||||
prettyTerm dnames tnames (TYPE l _) =
|
||||
case !(askAt FLAVOR) of
|
||||
Unicode => do
|
||||
star <- hl Syntax "★"
|
||||
level <- hl Universe $ text $ superscript $ show l
|
||||
pure $ hcat [star, level]
|
||||
Ascii => [|hl Syntax "Type" <++> hl Universe (text $ show l)|]
|
||||
prettyTerm dnames tnames (TYPE l _) = do
|
||||
type <- hl Syntax . text =<< ifUnicode "★" "Type"
|
||||
level <- prettyDisp l
|
||||
pure $ maybe type (type <+>) level
|
||||
|
||||
prettyTerm dnames tnames (IOState _) =
|
||||
ioStateD
|
||||
|
||||
prettyTerm dnames tnames (Pi qty arg res _) =
|
||||
parensIfM Outer =<< do
|
||||
|
@ -426,35 +475,31 @@ prettyTerm dnames tnames (Enum cases _) =
|
|||
prettyTerm dnames tnames (Tag tag _) =
|
||||
prettyTag tag
|
||||
|
||||
prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) = do
|
||||
l <- withPrec InEq $ prettyTerm dnames tnames l
|
||||
r <- withPrec InEq $ prettyTerm dnames tnames r
|
||||
ty <- withPrec InEq $ prettyTerm dnames tnames ty
|
||||
pure $ sep [l <++> !eqndD, r <++> !colonD, ty]
|
||||
prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) =
|
||||
parensIfM Eq =<< do
|
||||
l <- withPrec InEq $ prettyTerm dnames tnames l
|
||||
r <- withPrec InEq $ prettyTerm dnames tnames r
|
||||
ty <- withPrec InEq $ prettyTerm dnames tnames ty
|
||||
pure $ sep [l <++> !eqndD, r <++> !colonD, ty]
|
||||
|
||||
prettyTerm dnames tnames (Eq ty l r _) = do
|
||||
ty <- prettyTypeLine dnames tnames ty
|
||||
l <- withPrec Arg $ prettyTerm dnames tnames l
|
||||
r <- withPrec Arg $ prettyTerm dnames tnames r
|
||||
prettyAppD !eqD [ty, l, r]
|
||||
prettyTerm dnames tnames (Eq ty l r _) =
|
||||
parensIfM App =<< do
|
||||
ty <- prettyTypeLine dnames tnames ty
|
||||
l <- withPrec Arg $ prettyTerm dnames tnames l
|
||||
r <- withPrec Arg $ prettyTerm dnames tnames r
|
||||
prettyAppD !eqD [ty, l, r]
|
||||
|
||||
prettyTerm dnames tnames s@(DLam {}) =
|
||||
prettyLambda dnames tnames s
|
||||
|
||||
prettyTerm dnames tnames (Nat _) = natD
|
||||
prettyTerm dnames tnames (Zero _) = hl Syntax "0"
|
||||
prettyTerm dnames tnames (Succ p _) = do
|
||||
succD <- succD
|
||||
let succ : Doc opts -> Eff Pretty (Doc opts)
|
||||
succ t = prettyAppD succD [t]
|
||||
toNat : Term d n -> Eff Pretty (Either (Doc opts) Nat)
|
||||
toNat s with (pushSubsts' s)
|
||||
_ | Zero _ = pure $ Right 0
|
||||
_ | Succ d _ = bitraverse succ (pure . S) =<<
|
||||
toNat (assert_smaller s d)
|
||||
_ | s' = map Left . withPrec Arg $
|
||||
prettyTerm dnames tnames $ assert_smaller s s'
|
||||
either succ (hl Syntax . text . show . S) =<< toNat p
|
||||
prettyTerm dnames tnames (NAT _) = natD
|
||||
prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n
|
||||
prettyTerm dnames tnames (Succ p _) =
|
||||
parensIfM App =<<
|
||||
prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)]
|
||||
|
||||
prettyTerm dnames tnames (STRING _) = stringD
|
||||
prettyTerm dnames tnames (Str s _) = prettyStrLit s
|
||||
|
||||
prettyTerm dnames tnames (BOX qty ty _) =
|
||||
bracks . hcat =<<
|
||||
|
@ -464,7 +509,18 @@ prettyTerm dnames tnames (BOX qty ty _) =
|
|||
prettyTerm dnames tnames (Box val _) =
|
||||
bracks =<< withPrec Outer (prettyTerm dnames tnames val)
|
||||
|
||||
prettyTerm dnames tnames (E e) = prettyElim dnames tnames e
|
||||
prettyTerm dnames tnames (Let qty rhs body _) = do
|
||||
let Evidence _ (lets, body) = splitLet [< (qty, body.name, rhs)] body.term
|
||||
heads <- prettyLets dnames tnames lets
|
||||
let tnames = tnames . map (\(_, x, _) => x) lets
|
||||
body <- withPrec Outer $ assert_total prettyTerm dnames tnames body
|
||||
let lines = toList $ heads :< body
|
||||
pure $ ifMultiline (hsep lines) (vsep lines)
|
||||
|
||||
prettyTerm dnames tnames (E e) =
|
||||
case the (Elim d n) (pushSubsts' e) of
|
||||
Ann tm _ _ => assert_total prettyTerm dnames tnames tm
|
||||
_ => assert_total prettyElim dnames tnames e
|
||||
|
||||
prettyTerm dnames tnames t0@(CloT (Sub t ph)) =
|
||||
prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' id ph t
|
||||
|
@ -491,6 +547,16 @@ prettyElim dnames tnames (CasePair qty pair ret body _) = do
|
|||
prettyCase dnames tnames qty pair ret
|
||||
[MkCaseArm pat [<] [< x, y] body.term]
|
||||
|
||||
prettyElim dnames tnames (Fst pair _) =
|
||||
parensIfM App =<< do
|
||||
pair <- prettyTArg dnames tnames (E pair)
|
||||
prettyAppD !fstD [pair]
|
||||
|
||||
prettyElim dnames tnames (Snd pair _) =
|
||||
parensIfM App =<< do
|
||||
pair <- prettyTArg dnames tnames (E pair)
|
||||
prettyAppD !sndD [pair]
|
||||
|
||||
prettyElim dnames tnames (CaseEnum qty tag ret arms _) = do
|
||||
arms <- for (SortedMap.toList arms) $ \(tag, body) =>
|
||||
pure $ MkCaseArm !(prettyTag tag) [<] [<] body
|
||||
|
@ -501,7 +567,7 @@ prettyElim dnames tnames (CaseNat qty qtyIH nat ret zero succ _) = do
|
|||
[< p, ih] = succ.names
|
||||
spat0 <- [|succD <++> prettyTBind p|]
|
||||
ihpat0 <- map hcat $ sequence [prettyQty qtyIH, dotD, prettyTBind ih]
|
||||
spat <- if ih.name == Unused
|
||||
spat <- if ih.val == Unused
|
||||
then pure spat0
|
||||
else pure $ hsep [spat0 <+> !commaD, ihpat0]
|
||||
let sarm = MkCaseArm spat [<] [< p, ih] succ.term
|
||||
|
@ -517,35 +583,31 @@ prettyElim dnames tnames e@(DApp {}) =
|
|||
prettyDTApps dnames tnames f xs
|
||||
|
||||
prettyElim dnames tnames (Ann tm ty _) =
|
||||
parensIfM Outer =<<
|
||||
hangDSingle !(withPrec AnnL [|prettyTerm dnames tnames tm <++> annD|])
|
||||
!(withPrec Outer (prettyTerm dnames tnames ty))
|
||||
case the (Term d n) (pushSubsts' tm) of
|
||||
E e => assert_total prettyElim dnames tnames e
|
||||
_ => do
|
||||
tm <- withPrec AnnL $ assert_total prettyTerm dnames tnames tm
|
||||
ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty
|
||||
parensIfM Outer =<< hangDSingle (tm <++> !annD) ty
|
||||
|
||||
prettyElim dnames tnames (Coe ty p q val _) =
|
||||
parensIfM App =<<
|
||||
if isDefaultDir p q then do
|
||||
ty <- prettyTypeLine dnames tnames ty
|
||||
val <- prettyTArg dnames tnames val
|
||||
prettyAppD !coeD [ty, val]
|
||||
else do
|
||||
ty <- prettyTypeLine dnames tnames ty
|
||||
p <- prettyDArg dnames p
|
||||
q <- prettyDArg dnames q
|
||||
val <- prettyTArg dnames tnames val
|
||||
prettyAppD !coeD [ty, sep [p, q], val]
|
||||
parensIfM App =<< do
|
||||
ty <- prettyTypeLine dnames tnames ty
|
||||
p <- prettyDArg dnames p
|
||||
q <- prettyDArg dnames q
|
||||
val <- prettyTArg dnames tnames val
|
||||
prettyAppD !coeD [ty, sep [p, q], val]
|
||||
|
||||
prettyElim dnames tnames e@(Comp ty p q val r zero one _) =
|
||||
parensIfM App =<< do
|
||||
ty <- prettyTypeLine dnames tnames $ assert_smaller e $ SN ty
|
||||
ty <- assert_total $ prettyTypeLine dnames tnames $ SN ty
|
||||
pq <- sep <$> sequence [prettyDArg dnames p, prettyDArg dnames q]
|
||||
val <- prettyTArg dnames tnames val
|
||||
r <- prettyDArg dnames r
|
||||
arm0 <- [|prettyCompArm dnames tnames Zero zero <+> semiD|]
|
||||
arm1 <- prettyCompArm dnames tnames One one
|
||||
ind <- askAt INDENT
|
||||
if isDefaultDir p q
|
||||
then layoutComp [ty] val r [arm0, arm1]
|
||||
else layoutComp [ty, pq] val r [arm0, arm1]
|
||||
layoutComp [ty, pq] val r [arm0, arm1]
|
||||
|
||||
prettyElim dnames tnames (TypeCase ty ret arms def _) = do
|
||||
arms <- for (toList arms) $ \(k ** body) => do
|
||||
|
|
|
@ -2,462 +2,383 @@ module Quox.Syntax.Term.Subst
|
|||
|
||||
import Quox.No
|
||||
import Quox.Syntax.Term.Base
|
||||
import Quox.Syntax.Subst
|
||||
|
||||
import Data.SnocVect
|
||||
import Data.Singleton
|
||||
|
||||
%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`
|
||||
||| - deletes an identity substitution
|
||||
||| - composes (lazily) with an existing top-level dim-closure
|
||||
||| - otherwise, wraps in a new closure
|
||||
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
|
||||
|
||||
parameters {0 f : Nat -> Nat -> Type}
|
||||
private
|
||||
th0 : f 0 0 -> Thinned2 f d n
|
||||
th0 = Th2 zero zero
|
||||
private
|
||||
subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
|
||||
subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
|
||||
subDArgs e th = DCloE $ Sub e th
|
||||
|
||||
private
|
||||
th1 : {d, n : Nat} -> f d n -> Thinned2 f d n
|
||||
th1 = Th2 id' id'
|
||||
||| does the minimal reasonable work:
|
||||
||| - deletes the closure around a term variable
|
||||
||| - deletes an identity substitution
|
||||
||| - composes (lazily) with an existing top-level dim-closure
|
||||
||| - immediately looks up bound variables in a
|
||||
||| top-level sequence of dimension applications
|
||||
||| - otherwise, wraps in a new closure
|
||||
export
|
||||
CanDSubst Elim where
|
||||
e // Shift SZ = e
|
||||
F x u loc // _ = F x u loc
|
||||
B i loc // _ = B i loc
|
||||
e@(DApp {}) // th = subDArgs e th
|
||||
DCloE (Sub e ph) // th = DCloE $ Sub e $ ph . th
|
||||
e // th = DCloE $ Sub e th
|
||||
|
||||
private dsubTerm : {d1, d2, n : Nat} -> Term d1 n -> DSubst d1 d2 -> TermT d2 n
|
||||
private dsubElim : {d1, d2, n : Nat} -> Elim d1 n -> DSubst d1 d2 -> ElimT d2 n
|
||||
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
|
||||
|
||||
dsubTerm (TYPE l loc) th = th0 $ TYPE l loc
|
||||
dsubTerm (Enum strs loc) th = th0 $ Enum strs loc
|
||||
dsubTerm (Tag str loc) th = th0 $ Tag str loc
|
||||
dsubTerm (Nat loc) th = th0 $ Nat loc
|
||||
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
|
||||
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
|
||||
|
||||
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
|
||||
(///) : {d1, d2, n : Nat} -> TermT d1 n -> DSubst d1 d2 -> TermT d2 n
|
||||
Th2 dope tope term /// th =
|
||||
let Val tscope = appOpe n tope; Val dscope = appOpe d1 dope
|
||||
Th2 dope' tope' term' = dsubTerm term (select dope th)
|
||||
in
|
||||
Th2 dope' (tope . tope') term'
|
||||
export %inline FromVar (Elim d) where fromVarLoc = B
|
||||
export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
|
||||
|
||||
namespace Elim
|
||||
export
|
||||
(///) : {d1, d2, n : Nat} -> ElimT d1 n -> DSubst d1 d2 -> ElimT d2 n
|
||||
Th2 dope tope elim /// th =
|
||||
let Val tscope = appOpe n tope; Val dscope = appOpe d1 dope
|
||||
Th2 dope' tope' elim' = dsubElim elim (select dope th)
|
||||
in
|
||||
Th2 dope' (tope . tope') elim'
|
||||
|
||||
||| 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
|
||||
CanSubstSelf (Elim d) where
|
||||
F x u loc // _ = F x u 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 (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
|
||||
TSubst : Nat -> Nat -> Nat -> Type
|
||||
TSubst = Subst2 Elim
|
||||
0 CloTest : TermLike -> Type
|
||||
CloTest tm = forall d, n. tm d n -> Bool
|
||||
|
||||
public export
|
||||
interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
|
||||
pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
|
||||
tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
|
||||
|
||||
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
|
||||
private subElim : {d, n1, n2 : Nat} -> Elim d n1 -> TSubst d n1 n2 -> ElimT d n2
|
||||
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
|
||||
|
||||
subTerm (TYPE l loc) th = th0 $ TYPE l loc
|
||||
subTerm (Nat loc) th = th0 $ Nat loc
|
||||
subTerm (Zero loc) th = th0 $ Zero loc
|
||||
subTerm (E e) th = let Th2 dope tope e' = subElim e th in Th2 dope tope $ E e'
|
||||
subTerm (CloT (Sub2 s ph)) th = th1 $ CloT $ Sub2 s $ ph .% th
|
||||
subTerm s th = th1 $ CloT $ Sub2 s th
|
||||
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
|
||||
|
||||
subElim (F x k loc) th = th0 $ F x k loc
|
||||
subElim (B loc) [< e] = e
|
||||
subElim (CloE (Sub2 e ph)) th = th1 $ CloE $ Sub2 e $ ph .% th
|
||||
subElim e th = th1 $ CloE $ Sub2 e th
|
||||
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
|
||||
|
||||
export
|
||||
CanSubstSelf2 Elim where
|
||||
Th2 dope tope elim // th =
|
||||
let
|
||||
th' = select tope th
|
||||
in
|
||||
?sube2
|
||||
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 (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
|
||||
-- public export
|
||||
-- interface CanDSubst (0 tm : TermLike) where
|
||||
-- (//) : {d1 : Nat} -> Thinned2 tm d1 n -> Lazy (DSubst d1 d2) ->
|
||||
-- Thinned2 tm d2 n
|
||||
|
||||
-- ||| 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 dim-closure
|
||||
-- ||| - otherwise, wraps in a new closure
|
||||
-- export
|
||||
-- CanDSubst Term where
|
||||
-- Th2 _ _ (TYPE l loc) // _ = Th2 zero zero $ TYPE l loc
|
||||
-- Th2 i j (DCloT (Sub s ph)) // th =
|
||||
-- Th2 ?i' j $ DCloT $ Sub s $ ph . ?th'
|
||||
-- Th2 i j s // th = ?sdf -- DCloT $ Sub s th
|
||||
|
||||
-- -- private
|
||||
-- -- subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
|
||||
-- -- subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
|
||||
-- -- subDArgs e th = DCloE $ Sub e th
|
||||
|
||||
-- -- ||| does the minimal reasonable work:
|
||||
-- -- ||| - deletes the closure around a term variable
|
||||
-- -- ||| - deletes an identity substitution
|
||||
-- -- ||| - composes (lazily) with an existing top-level dim-closure
|
||||
-- -- ||| - immediately looks up bound variables in a
|
||||
-- -- ||| top-level sequence of dimension applications
|
||||
-- -- ||| - otherwise, wraps in a new closure
|
||||
-- -- export
|
||||
-- -- CanDSubst Elim where
|
||||
-- -- e // Shift SZ = e
|
||||
-- -- F x u loc // _ = F x u loc
|
||||
-- -- B i loc // _ = B i loc
|
||||
-- -- e@(DApp {}) // th = subDArgs e th
|
||||
-- -- DCloE (Sub e ph) // th = DCloE $ Sub e $ ph . th
|
||||
-- -- e // th = DCloE $ Sub e th
|
||||
|
||||
-- -- 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 th
|
||||
-- -- S ns (N body) // th = S ns $ N $ body // th
|
||||
export
|
||||
PushSubsts Term Subst.isCloT where
|
||||
pushSubstsWith th ph (TYPE l loc) =
|
||||
nclo $ TYPE l loc
|
||||
pushSubstsWith th ph (IOState loc) =
|
||||
nclo $ IOState loc
|
||||
pushSubstsWith th ph (Pi qty a body loc) =
|
||||
nclo $ Pi qty (a // th // ph) (body // th // ph) loc
|
||||
pushSubstsWith th ph (Lam body loc) =
|
||||
nclo $ Lam (body // th // ph) loc
|
||||
pushSubstsWith th ph (Sig a b loc) =
|
||||
nclo $ Sig (a // th // ph) (b // th // ph) loc
|
||||
pushSubstsWith th ph (Pair s t loc) =
|
||||
nclo $ Pair (s // th // ph) (t // th // ph) loc
|
||||
pushSubstsWith th ph (Enum tags loc) =
|
||||
nclo $ Enum tags loc
|
||||
pushSubstsWith th ph (Tag tag loc) =
|
||||
nclo $ Tag tag loc
|
||||
pushSubstsWith th ph (Eq ty l r loc) =
|
||||
nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
|
||||
pushSubstsWith th ph (DLam body loc) =
|
||||
nclo $ DLam (body // th // ph) loc
|
||||
pushSubstsWith _ _ (NAT loc) =
|
||||
nclo $ NAT loc
|
||||
pushSubstsWith _ _ (Nat n loc) =
|
||||
nclo $ Nat n loc
|
||||
pushSubstsWith th ph (Succ n loc) =
|
||||
nclo $ Succ (n // th // ph) loc
|
||||
pushSubstsWith _ _ (STRING loc) =
|
||||
nclo $ STRING loc
|
||||
pushSubstsWith _ _ (Str s loc) =
|
||||
nclo $ Str s loc
|
||||
pushSubstsWith th ph (BOX pi ty loc) =
|
||||
nclo $ BOX pi (ty // th // ph) loc
|
||||
pushSubstsWith th ph (Box val loc) =
|
||||
nclo $ Box (val // th // ph) loc
|
||||
pushSubstsWith th ph (E e) =
|
||||
let Element e nc = pushSubstsWith th ph e in nclo $ E e
|
||||
pushSubstsWith th ph (Let qty rhs body loc) =
|
||||
nclo $ Let qty (rhs // th // ph) (body // th // ph) loc
|
||||
pushSubstsWith th ph (CloT (Sub s ps)) =
|
||||
pushSubstsWith th (comp th ps ph) s
|
||||
pushSubstsWith th ph (DCloT (Sub s ps)) =
|
||||
pushSubstsWith (ps . th) ph s
|
||||
|
||||
|
||||
-- -- export %inline FromVar (Elim d) where fromVarLoc = B
|
||||
-- -- export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
|
||||
||| heterogeneous comp, in terms of Comp and Coe
|
||||
public export %inline
|
||||
CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
(r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
|
||||
CompH' {ty, p, q, val, r, zero, one, loc} =
|
||||
let ty' = SY ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
|
||||
Comp {
|
||||
ty = dsub1 ty q, p, q,
|
||||
val = E $ Coe ty p q val val.loc, r,
|
||||
zero = SY zero.names $ E $
|
||||
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
|
||||
one = SY one.names $ E $
|
||||
Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
|
||||
loc
|
||||
}
|
||||
|
||||
|
||||
-- -- ||| 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
|
||||
-- -- CanSubstSelf (Elim d) where
|
||||
-- -- F x u loc // _ = F x u 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}
|
||||
||| heterogeneous comp, in terms of Comp and Coe
|
||||
public export %inline
|
||||
CompH : (i : BindName) -> (ty : Term (S d) n) ->
|
||||
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
|
||||
(j0 : BindName) -> (zero : Term (S d) n) ->
|
||||
(j1 : BindName) -> (one : Term (S d) n) ->
|
||||
(loc : Loc) -> Elim d n
|
||||
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
|
||||
CompH' {ty = SY [< i] ty, p, q, val, r,
|
||||
zero = SY [< j0] zero, one = SY [< j1] one, loc}
|
||||
|
|
|
@ -1,334 +0,0 @@
|
|||
module Quox.Syntax.Term.Tighten
|
||||
|
||||
import Quox.Syntax.Term.Base
|
||||
import Quox.Syntax.Subst
|
||||
import public Quox.OPE
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
export
|
||||
Tighten (Shift f) where
|
||||
-- `OPE m n` is a spicy `m ≤ n`,
|
||||
-- and `Shift f n` is a (different) spicy `f ≤ n`
|
||||
-- so the value is `f ≤ m` (as a `Shift`), if that is the case
|
||||
tighten _ SZ = Nothing
|
||||
tighten Id by = Just by
|
||||
tighten (Drop p) (SS by) = tighten p by
|
||||
tighten (Keep p) (SS by) = [|SS $ tighten p by|]
|
||||
|
||||
|
||||
export
|
||||
Tighten Dim where
|
||||
tighten p (K e loc) = pure $ K e loc
|
||||
tighten p (B i loc) = B <$> tighten p i <*> pure loc
|
||||
|
||||
|
||||
export
|
||||
tightenSub : (forall m, n. OPE m n -> env n -> Maybe (env m)) ->
|
||||
OPE t1 t2 -> Subst env f t2 -> Maybe (Subst env f t1)
|
||||
tightenSub f p (Shift by) = [|Shift $ tighten p by|]
|
||||
tightenSub f p (t ::: th) = [|f p t !::: tightenSub f p th|]
|
||||
|
||||
export
|
||||
Tighten env => Tighten (Subst env f) where
|
||||
tighten p th = tightenSub tighten p th
|
||||
|
||||
|
||||
export
|
||||
tightenScope : (forall m, n. OPE m n -> f n -> Maybe (f m)) ->
|
||||
{s : Nat} -> OPE m n -> Scoped s f n -> Maybe (Scoped s f m)
|
||||
tightenScope f p (S names (Y body)) = SY names <$> f (keepN s p) body
|
||||
tightenScope f p (S names (N body)) = S names . N <$> f p body
|
||||
|
||||
export
|
||||
tightenDScope : {0 f : Nat -> Nat -> Type} ->
|
||||
(forall m, n, k. OPE m n -> f n k -> Maybe (f m k)) ->
|
||||
OPE m n -> Scoped s (f n) k -> Maybe (Scoped s (f m) k)
|
||||
tightenDScope f p (S names (Y body)) = SY names <$> f p body
|
||||
tightenDScope f p (S names (N body)) = S names . N <$> f p body
|
||||
|
||||
|
||||
mutual
|
||||
private
|
||||
tightenT : OPE n1 n2 -> Term d n2 -> Maybe (Term d n1)
|
||||
tightenT p (TYPE l loc) = pure $ TYPE l loc
|
||||
tightenT p (Pi qty arg res loc) =
|
||||
Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc
|
||||
tightenT p (Lam body loc) =
|
||||
Lam <$> tightenS p body <*> pure loc
|
||||
tightenT p (Sig fst snd loc) =
|
||||
Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc
|
||||
tightenT p (Pair fst snd loc) =
|
||||
Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc
|
||||
tightenT p (Enum cases loc) =
|
||||
pure $ Enum cases loc
|
||||
tightenT p (Tag tag loc) =
|
||||
pure $ Tag tag loc
|
||||
tightenT p (Eq ty l r loc) =
|
||||
Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc
|
||||
tightenT p (DLam body loc) =
|
||||
DLam <$> tightenDS p body <*> pure loc
|
||||
tightenT p (Nat loc) =
|
||||
pure $ Nat loc
|
||||
tightenT p (Zero loc) =
|
||||
pure $ Zero loc
|
||||
tightenT p (Succ s loc) =
|
||||
Succ <$> tightenT p s <*> pure loc
|
||||
tightenT p (BOX qty ty loc) =
|
||||
BOX qty <$> tightenT p ty <*> pure loc
|
||||
tightenT p (Box val loc) =
|
||||
Box <$> tightenT p val <*> pure loc
|
||||
tightenT p (E e) =
|
||||
assert_total $ E <$> tightenE p e
|
||||
tightenT p (CloT (Sub tm th)) = do
|
||||
th <- assert_total $ tightenSub tightenE p th
|
||||
pure $ CloT $ Sub tm th
|
||||
tightenT p (DCloT (Sub tm th)) = do
|
||||
tm <- tightenT p tm
|
||||
pure $ DCloT $ Sub tm th
|
||||
|
||||
private
|
||||
tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
|
||||
tightenE p (F x u loc) =
|
||||
pure $ F x u loc
|
||||
tightenE p (B i loc) =
|
||||
B <$> tighten p i <*> pure loc
|
||||
tightenE p (App fun arg loc) =
|
||||
App <$> tightenE p fun <*> tightenT p arg <*> pure loc
|
||||
tightenE p (CasePair qty pair ret body loc) =
|
||||
CasePair qty <$> tightenE p pair
|
||||
<*> tightenS p ret
|
||||
<*> tightenS p body
|
||||
<*> pure loc
|
||||
tightenE p (CaseEnum qty tag ret arms loc) =
|
||||
CaseEnum qty <$> tightenE p tag
|
||||
<*> tightenS p ret
|
||||
<*> traverse (tightenT p) arms
|
||||
<*> pure loc
|
||||
tightenE p (CaseNat qty qtyIH nat ret zero succ loc) =
|
||||
CaseNat qty qtyIH
|
||||
<$> tightenE p nat
|
||||
<*> tightenS p ret
|
||||
<*> tightenT p zero
|
||||
<*> tightenS p succ
|
||||
<*> pure loc
|
||||
tightenE p (CaseBox qty box ret body loc) =
|
||||
CaseBox qty <$> tightenE p box
|
||||
<*> tightenS p ret
|
||||
<*> tightenS p body
|
||||
<*> pure loc
|
||||
tightenE p (DApp fun arg loc) =
|
||||
DApp <$> tightenE p fun <*> pure arg <*> pure loc
|
||||
tightenE p (Ann tm ty loc) =
|
||||
Ann <$> tightenT p tm <*> tightenT p ty <*> pure loc
|
||||
tightenE p (Coe ty q0 q1 val loc) =
|
||||
Coe <$> tightenDS p ty
|
||||
<*> pure q0 <*> pure q1
|
||||
<*> tightenT p val
|
||||
<*> pure loc
|
||||
tightenE p (Comp ty q0 q1 val r zero one loc) =
|
||||
Comp <$> tightenT p ty
|
||||
<*> pure q0 <*> pure q1
|
||||
<*> tightenT p val
|
||||
<*> pure r
|
||||
<*> tightenDS p zero
|
||||
<*> tightenDS p one
|
||||
<*> pure loc
|
||||
tightenE p (TypeCase ty ret arms def loc) =
|
||||
TypeCase <$> tightenE p ty
|
||||
<*> tightenT p ret
|
||||
<*> traverse (tightenS p) arms
|
||||
<*> tightenT p def
|
||||
<*> pure loc
|
||||
tightenE p (CloE (Sub el th)) = do
|
||||
th <- assert_total $ tightenSub tightenE p th
|
||||
pure $ CloE $ Sub el th
|
||||
tightenE p (DCloE (Sub el th)) = do
|
||||
el <- tightenE p el
|
||||
pure $ DCloE $ Sub el th
|
||||
|
||||
export
|
||||
tightenS : {s : Nat} -> OPE m n ->
|
||||
ScopeTermN s f n -> Maybe (ScopeTermN s f m)
|
||||
tightenS = assert_total $ tightenScope tightenT
|
||||
|
||||
export
|
||||
tightenDS : OPE m n -> DScopeTermN s f n -> Maybe (DScopeTermN s f m)
|
||||
tightenDS = assert_total $ tightenDScope tightenT {f = \n, d => Term d n}
|
||||
|
||||
export Tighten (Elim d) where tighten p e = tightenE p e
|
||||
export Tighten (Term d) where tighten p t = tightenT p t
|
||||
|
||||
|
||||
mutual
|
||||
export
|
||||
dtightenT : OPE d1 d2 -> Term d2 n -> Maybe (Term d1 n)
|
||||
dtightenT p (TYPE l loc) =
|
||||
pure $ TYPE l loc
|
||||
dtightenT p (Pi qty arg res loc) =
|
||||
Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc
|
||||
dtightenT p (Lam body loc) =
|
||||
Lam <$> dtightenS p body <*> pure loc
|
||||
dtightenT p (Sig fst snd loc) =
|
||||
Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc
|
||||
dtightenT p (Pair fst snd loc) =
|
||||
Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc
|
||||
dtightenT p (Enum cases loc) =
|
||||
pure $ Enum cases loc
|
||||
dtightenT p (Tag tag loc) =
|
||||
pure $ Tag tag loc
|
||||
dtightenT p (Eq ty l r loc) =
|
||||
Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc
|
||||
dtightenT p (DLam body loc) =
|
||||
DLam <$> dtightenDS p body <*> pure loc
|
||||
dtightenT p (Nat loc) =
|
||||
pure $ Nat loc
|
||||
dtightenT p (Zero loc) =
|
||||
pure $ Zero loc
|
||||
dtightenT p (Succ s loc) =
|
||||
Succ <$> dtightenT p s <*> pure loc
|
||||
dtightenT p (BOX qty ty loc) =
|
||||
BOX qty <$> dtightenT p ty <*> pure loc
|
||||
dtightenT p (Box val loc) =
|
||||
Box <$> dtightenT p val <*> pure loc
|
||||
dtightenT p (E e) =
|
||||
assert_total $ E <$> dtightenE p e
|
||||
dtightenT p (CloT (Sub tm th)) = do
|
||||
tm <- dtightenT p tm
|
||||
th <- assert_total $ traverse (dtightenE p) th
|
||||
pure $ CloT $ Sub tm th
|
||||
dtightenT p (DCloT (Sub tm th)) = do
|
||||
th <- tighten p th
|
||||
pure $ DCloT $ Sub tm th
|
||||
|
||||
export
|
||||
dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
|
||||
dtightenE p (F x u loc) =
|
||||
pure $ F x u loc
|
||||
dtightenE p (B i loc) =
|
||||
pure $ B i loc
|
||||
dtightenE p (App fun arg loc) =
|
||||
App <$> dtightenE p fun <*> dtightenT p arg <*> pure loc
|
||||
dtightenE p (CasePair qty pair ret body loc) =
|
||||
CasePair qty <$> dtightenE p pair
|
||||
<*> dtightenS p ret
|
||||
<*> dtightenS p body
|
||||
<*> pure loc
|
||||
dtightenE p (CaseEnum qty tag ret arms loc) =
|
||||
CaseEnum qty <$> dtightenE p tag
|
||||
<*> dtightenS p ret
|
||||
<*> traverse (dtightenT p) arms
|
||||
<*> pure loc
|
||||
dtightenE p (CaseNat qty qtyIH nat ret zero succ loc) =
|
||||
CaseNat qty qtyIH
|
||||
<$> dtightenE p nat
|
||||
<*> dtightenS p ret
|
||||
<*> dtightenT p zero
|
||||
<*> dtightenS p succ
|
||||
<*> pure loc
|
||||
dtightenE p (CaseBox qty box ret body loc) =
|
||||
CaseBox qty <$> dtightenE p box
|
||||
<*> dtightenS p ret
|
||||
<*> dtightenS p body
|
||||
<*> pure loc
|
||||
dtightenE p (DApp fun arg loc) =
|
||||
DApp <$> dtightenE p fun <*> tighten p arg <*> pure loc
|
||||
dtightenE p (Ann tm ty loc) =
|
||||
Ann <$> dtightenT p tm <*> dtightenT p ty <*> pure loc
|
||||
dtightenE p (Coe ty q0 q1 val loc) =
|
||||
[|Coe (dtightenDS p ty) (tighten p q0) (tighten p q1) (dtightenT p val)
|
||||
(pure loc)|]
|
||||
dtightenE p (Comp ty q0 q1 val r zero one loc) =
|
||||
[|Comp (dtightenT p ty) (tighten p q0) (tighten p q1)
|
||||
(dtightenT p val) (tighten p r)
|
||||
(dtightenDS p zero) (dtightenDS p one) (pure loc)|]
|
||||
dtightenE p (TypeCase ty ret arms def loc) =
|
||||
[|TypeCase (dtightenE p ty) (dtightenT p ret)
|
||||
(traverse (dtightenS p) arms) (dtightenT p def) (pure loc)|]
|
||||
dtightenE p (CloE (Sub el th)) = do
|
||||
el <- dtightenE p el
|
||||
th <- assert_total $ traverse (dtightenE p) th
|
||||
pure $ CloE $ Sub el th
|
||||
dtightenE p (DCloE (Sub el th)) = do
|
||||
th <- tighten p th
|
||||
pure $ DCloE $ Sub el th
|
||||
|
||||
export
|
||||
dtightenS : OPE d1 d2 -> ScopeTermN s d2 n -> Maybe (ScopeTermN s d1 n)
|
||||
dtightenS = assert_total $ tightenDScope dtightenT {f = Term}
|
||||
|
||||
export
|
||||
dtightenDS : {s : Nat} -> OPE d1 d2 ->
|
||||
DScopeTermN s d2 n -> Maybe (DScopeTermN s d1 n)
|
||||
dtightenDS = assert_total $ tightenScope dtightenT
|
||||
|
||||
|
||||
export [TermD] Tighten (\d => Term d n) where tighten p t = dtightenT p t
|
||||
export [ElimD] Tighten (\d => Elim d n) where tighten p e = dtightenE p e
|
||||
|
||||
|
||||
-- versions of SY, etc, that try to tighten and use SN automatically
|
||||
|
||||
public export
|
||||
ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n
|
||||
ST names body =
|
||||
case tightenN s body of
|
||||
Just body => S names $ N body
|
||||
Nothing => S names $ Y body
|
||||
|
||||
public export
|
||||
DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n
|
||||
DST names body =
|
||||
case tightenN @{TermD} s body of
|
||||
Just body => S names $ N body
|
||||
Nothing => S names $ Y body
|
||||
|
||||
public export %inline
|
||||
PiT : (qty : Qty) -> (x : BindName) ->
|
||||
(arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
PiT {qty, x, arg, res, loc} = Pi {qty, arg, res = ST [< x] res, loc}
|
||||
|
||||
public export %inline
|
||||
LamT : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
LamT {x, body, loc} = Lam {body = ST [< x] body, loc}
|
||||
|
||||
public export %inline
|
||||
SigT : (x : BindName) -> (fst : Term d n) ->
|
||||
(snd : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
SigT {x, fst, snd, loc} = Sig {fst, snd = ST [< x] snd, loc}
|
||||
|
||||
public export %inline
|
||||
EqT : (i : BindName) -> (ty : Term (S d) n) ->
|
||||
(l, r : Term d n) -> (loc : Loc) -> Term d n
|
||||
EqT {i, ty, l, r, loc} = Eq {ty = DST [< i] ty, l, r, loc}
|
||||
|
||||
public export %inline
|
||||
DLamT : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
|
||||
DLamT {i, body, loc} = DLam {body = DST [< i] body, loc}
|
||||
|
||||
public export %inline
|
||||
CoeT : (i : BindName) -> (ty : Term (S d) n) ->
|
||||
(p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
|
||||
CoeT {i, ty, p, q, val, loc} = Coe {ty = DST [< i] ty, p, q, val, loc}
|
||||
|
||||
public export %inline
|
||||
typeCase1T : Elim d n -> Term d n ->
|
||||
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
|
||||
(loc : Loc) ->
|
||||
{default (Nat loc) def : Term d n} ->
|
||||
Elim d n
|
||||
typeCase1T ty ret k ns body loc {def} =
|
||||
typeCase ty ret [(k ** ST ns body)] def loc
|
||||
|
||||
|
||||
export
|
||||
squeeze : {s : Nat} -> ScopeTermN s d n -> ScopeTermN s d n
|
||||
squeeze (S names (Y body)) = S names $ maybe (Y body) N $ tightenN s body
|
||||
squeeze (S names (N body)) = S names $ N body
|
||||
|
||||
export
|
||||
dsqueeze : {s : Nat} -> DScopeTermN s d n -> DScopeTermN s d n
|
||||
dsqueeze (S names (Y body)) =
|
||||
S names $ maybe (Y body) N $ tightenN s body @{TermD}
|
||||
dsqueeze (S names (N body)) = S names $ N body
|
|
@ -9,7 +9,8 @@ import Generics.Derive
|
|||
|
||||
|
||||
public export
|
||||
data TyConKind = KTYPE | KPi | KSig | KEnum | KEq | KNat | KBOX
|
||||
data TyConKind =
|
||||
KTYPE | KIOState | KPi | KSig | KEnum | KEq | KNat | KString | KBOX
|
||||
%name TyConKind k
|
||||
%runElab derive "TyConKind" [Eq.Eq, Ord.Ord, Show.Show, Generic, Meta, DecEq]
|
||||
|
||||
|
@ -25,10 +26,12 @@ allKinds = %runElab do
|
|||
||| in `type-case`, how many variables are bound in this branch
|
||||
public export %inline
|
||||
arity : TyConKind -> Nat
|
||||
arity KTYPE = 0
|
||||
arity KPi = 2
|
||||
arity KSig = 2
|
||||
arity KEnum = 0
|
||||
arity KEq = 5
|
||||
arity KNat = 0
|
||||
arity KBOX = 1
|
||||
arity KTYPE = 0
|
||||
arity KIOState = 0
|
||||
arity KPi = 2
|
||||
arity KSig = 2
|
||||
arity KEnum = 0
|
||||
arity KEq = 5
|
||||
arity KNat = 0
|
||||
arity KString = 0
|
||||
arity KBOX = 1
|
||||
|
|
|
@ -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