Compare commits

...

185 commits

Author SHA1 Message Date
3ab8669404 some refactoring in tests 2024-06-04 21:49:08 +02:00
2bfe3250cf remove Tighten stuff 2024-06-04 21:49:08 +02:00
f00c802336 functions returning subsings are also subsings 2024-06-02 17:35:56 +02:00
68c414a941 add vec.map 2024-06-02 17:34:58 +02:00
7b3ccfc45a comment out a partial definition in list.quox 2024-06-02 17:34:52 +02:00
519cc4779a add xtt2 and hofmann's quotient types to bib 2024-06-02 17:34:12 +02:00
3e23929b5f export infix 2024-05-27 21:29:37 +02:00
01e16e20e5 more bib stuff 2024-05-27 21:29:37 +02:00
5bf40755b5 beginning of quox stdlib 2024-05-27 21:29:27 +02:00
863849e4c4 clean up subsing η stuff 2024-05-13 01:23:14 +02:00
8fae67d4d5 check the new test actually fails in the right way 2024-05-12 20:32:32 +02:00
d276a66abd slightly improve a log message 2024-05-12 20:30:26 +02:00
b556c2f099 fix some comments 2024-05-12 20:30:18 +02:00
d2a117fe61 fix function η with subsingleton types 2024-05-12 20:30:04 +02:00
c9f66bb6af minor refactor 2024-04-18 11:49:19 +02:00
7f72ed56fb add test for regularity 2024-04-15 22:58:28 +02:00
67c825ab39 add coercion regularity to the equality checker (not to whnf) 2024-04-15 22:58:17 +02:00
ddc2422ffb fix .gitignore 2024-04-15 22:27:55 +02:00
3f7031c613 pack bump 2024-04-15 20:54:23 +02:00
8823154973 add golden test stuff 2024-04-14 20:49:10 +02:00
b7dc5ffdc4 add check for #[main] type 2024-04-14 16:20:40 +02:00
dd697ba56e add CheckBuiltin 2024-04-14 16:20:25 +02:00
32b9fe124f minor tweaks in Q.Typing.Context 2024-04-14 15:48:10 +02:00
95a0b38d74 update pretty-printing tests 2024-04-12 22:00:08 +02:00
7883a3cae7 pretty printing fixes 2024-04-12 21:54:25 +02:00
a1d8fd4ab5 %inline 2024-04-12 21:53:54 +02:00
9d60f366cf add #![log] pragma 2024-04-12 21:53:54 +02:00
f56f594839 push multiple loglevel changes at once 2024-04-12 21:53:54 +02:00
fca75377a0 MakeName ⇒ MkName for consistency 2024-04-12 21:53:50 +02:00
11b0ab6a25 remove default from FromParser.fromParserPure and Main.step 2024-04-07 03:20:42 +02:00
7a0bc73d25 approximate log stack in handleLogDiscard 2024-04-06 20:14:24 +02:00
567176e076 log refactors 2024-04-05 18:43:00 +02:00
3b6ae36e4e add logging to core 2024-04-04 19:26:41 +02:00
861bd55f94 add log effects to FromParser 2024-04-04 19:26:41 +02:00
e6ad16813e add log effects to executable 2024-04-04 19:26:41 +02:00
78555711ce add Q.Log 2024-04-04 19:26:41 +02:00
ec839a1d48 big Main refactor 2024-04-04 19:26:41 +02:00
727f968afb add delimited continuations to bib 2024-04-04 19:26:30 +02:00
41c8a92c97 bib fixes 2024-04-04 19:26:13 +02:00
efddb1aea1 skip broken pretty-printing tests till i fix them 2024-03-27 18:21:45 +01:00
8cba73f741 bump pack collection 2024-03-27 18:21:26 +01:00
582666a254 comments in infer for coercions 2024-03-21 21:29:13 +01:00
a9e8f14ad5 fix a small bug in Q.Whnf.Coercion 2024-03-21 21:29:01 +01:00
a8ac6f11f7 fix a quantity in CaseBox 2024-02-28 16:49:15 +01:00
b67162bda1 fix the other similar loops
closes #38, again
2024-02-24 16:04:38 +01:00
24ae5b85a2 fix a broken test???? 2024-02-24 15:45:04 +01:00
325e128063 add η for False and True 2024-02-10 11:39:07 +01:00
642ac25a71 happy new year [pack update. also idris 0.7.0] 2024-02-10 10:14:22 +01:00
05a688d49e reject "" in NatExtra.fromHex 2024-02-10 10:14:22 +01:00
1c8c50f3e2 remove some unneeded Ord impls 2024-02-10 10:14:22 +01:00
f337625801 remove most noLocs 2024-02-10 10:14:22 +01:00
1f01cec322 refactor Main a whole lot 2024-02-10 10:14:22 +01:00
103f019dbd move NDefinition to Quox.Definition and add an untyped one 2024-02-10 10:14:22 +01:00
2cafb35bc1 fix some comments 2024-02-10 10:14:22 +01:00
47069a9316 fill a stray hole 2024-02-10 10:14:22 +01:00
fb14b756c7 add algebraic ornaments to bib 2024-02-10 10:14:22 +01:00
81783dbae0 fix typechecker loop when coercing boxes
closes #38
2024-02-10 10:07:06 +01:00
a14c4ca1cb never inline let bindings from the original source 2023-12-21 18:04:12 +01:00
b7074720ad pretty printing fixes 2023-12-21 18:03:57 +01:00
48a050491c fix several quantity issues
- contents of box intro
- definition of let
- non-recursive ℕ case
- also make a few var names more consistent
2023-12-21 18:01:17 +01:00
aa4ead592a allow "let x : A = e in s" with type annotation 2023-12-21 17:54:31 +01:00
54db7e27ef make #[fail] run in the current namespace 2023-12-21 17:53:46 +01:00
7afcbfe258 recognise nats other than 0 in eq checker 2023-12-21 17:48:12 +01:00
0fdd4741be print quantity on let 2023-12-07 01:43:39 +01:00
03c197bd04 add local bindings to context
- without this, inside the body of `let x = e in …`, the typechecker
  would forget that `x = e`
- now bound variables can reduce, if they have a definition, so RedexTest
  needs to take the context too
2023-12-07 01:43:39 +01:00
cdf1ec6deb fix a comment 2023-12-04 23:38:17 +01:00
08a8c694b1 a usage in hello.quox. why not 2023-12-04 23:36:30 +01:00
8b8129027d update syntax.ebnf 2023-12-04 23:35:54 +01:00
e48f03a61c multiple semi-sep binds in a let 2023-12-04 23:27:59 +01:00
415a823dec comment out an unfinished definition lmao 2023-12-04 22:49:32 +01:00
b1699ce022 add let to the core 2023-12-04 22:47:52 +01:00
68d8019f00 add let to frontend syntax 2023-12-04 18:56:45 +01:00
59e7a457a6 let case be the head of an application too 2023-12-04 18:28:57 +01:00
4291afd51b allow fst/snd to take multiple arguments
also succ though that won't be well typed
2023-12-04 18:21:28 +01:00
e2ad18ff1f hello.quox tweaks 2023-11-16 18:33:03 +01:00
310822ffa5 remove old replaced stuff 2023-11-16 18:32:38 +01:00
d115672d49 example stuff 2023-11-10 15:07:19 +01:00
cc78ccd940 fix some parenthesisation 2023-11-06 22:11:11 +01:00
50984aa1aa refactor #[attribute] stuff 2023-11-05 20:49:02 +01:00
246d80eea2 add io.quox 2023-11-05 15:48:01 +01:00
c48b7be559 add html output highlighting 2023-11-05 15:47:52 +01:00
040a1862c3 refactor scheme prelude 2023-11-05 15:45:33 +01:00
bf8cced888 swap some delim/syntax highlighting around 2023-11-05 15:45:07 +01:00
04af7ae942 highlight the @ in dim apps as a delim 2023-11-05 15:44:44 +01:00
d9cdf1306d fix IsReserved
IsReserved should be true for e.g. "λ" but not "fun", since only the
first can show up in the lexer output
2023-11-05 15:43:20 +01:00
6c8ebfb804 fix some comments 2023-11-05 15:41:21 +01:00
da3cd404f3 handle when getTermCols returns 0 2023-11-05 15:40:19 +01:00
f58fa5218f subscript numbers are no longer special 2023-11-05 15:39:52 +01:00
580fbc8fd8 add misc.refl, misc.sing, nat.minus 2023-11-05 15:38:38 +01:00
e211887a34 string/nat lit stuff 2023-11-05 15:38:13 +01:00
3b9a339e5e rename "Tag" highlight to "Constant" 2023-11-05 14:30:40 +01:00
2f8a2d2cd2 fix typo in error 2023-11-04 17:45:55 +01:00
b6c435049d escape strings in scheme
the characters \, ", and everything below space or above ~ are replaced
with a \xdd;-style escape inside string literals
2023-11-03 20:17:35 +01:00
90cdcfe4da add \n and \t escapes to the lexer 2023-11-03 20:07:59 +01:00
d4639a35c6 add hello.quox to examples 2023-11-03 18:05:54 +01:00
b7e1f37b5b add some #[compile-scheme] 2023-11-03 18:05:54 +01:00
5dfefe443c more tidying of outputs 2023-11-03 18:05:54 +01:00
0514fff481 represent ℕ constants directly
instead of as huge `succ (succ (succ ⋯))` terms
2023-11-03 18:05:54 +01:00
fa7f82ae5a rename Nat to NAT in AST 2023-11-03 18:05:54 +01:00
e0ed37720f always vsep scheme lets, otherwise they are unreadable 2023-11-03 18:05:54 +01:00
4cc50c6bcd highlight errors even if real output is to a file
(unless told not to)
2023-11-03 18:05:54 +01:00
050346e344 add postulate, #[compile-scheme], #[main] 2023-11-03 18:05:54 +01:00
cc0bade747 scheme output 2023-11-03 18:05:54 +01:00
cd08a0fd98 more erasure 2023-11-03 18:05:54 +01:00
1f14e4ab9e automate more option stuff
if the elaborator writes it then it will be kept up to date
automatically
2023-11-03 18:05:54 +01:00
314e7f036d make nat elimination with erased IH non-recursive at runtime 2023-11-03 18:05:54 +01:00
6ab9637ab5 don't keep erased applications actually 2023-11-03 18:05:54 +01:00
b6fd1e921e pretty printing improvements 2023-11-03 18:05:54 +01:00
f4a45b6c52 keep the Except effect at the start of the list 2023-11-03 18:05:54 +01:00
8e0d66cab8 more erasure 2023-11-03 18:05:54 +01:00
ea74c148b7 some of this EffExtra stuff doesn't work 2023-11-03 18:05:54 +01:00
83ab871d61 new main 2023-11-03 18:05:54 +01:00
421eb220fd erasure refactor 2023-11-03 18:05:54 +01:00
fbb862c88b %default total 2023-11-03 18:05:54 +01:00
b651ed5447 LoadFile does the parsing 2023-11-03 18:05:54 +01:00
d6985cad55 tweak the pretty printer stuff slightly 2023-11-03 18:05:54 +01:00
52e54dcc3c add PrettyVal stuff for parser AST 2023-11-03 18:05:54 +01:00
0c1df54d62 improve handling of context lengths 2023-11-03 18:05:54 +01:00
2e9183bc14 add prettyDef 2023-11-03 18:05:54 +01:00
428397f42b erasure to untyped syntax 2023-11-03 18:05:54 +01:00
0b7bd0ef46 add locations and substitutions to untyped syntax 2023-11-03 18:05:54 +01:00
9cbd998d6f simplify isEmpty and isSubSing 2023-11-03 18:05:54 +01:00
6896c8fcc4 rename SQtys to sg (σ) 2023-11-03 18:05:54 +01:00
be8797a3ef untyped λ calculus syntax 2023-11-03 18:05:54 +01:00
bf605486f0 example updates
- misc.All doesn't need to be a ★¹
- add pair.map-fst and pair.map-snd
- add bool.dup!
- tweak quantities in eta.from-false
- add fail.quox to all.quox
- add qty.quox
2023-11-03 18:05:35 +01:00
69f032584e fix constructor name in comment 2023-11-03 17:56:42 +01:00
9ecaaf72bd bump pack collection 2023-10-22 19:18:38 +02:00
f04c4619ef detect reserved words inside names like 'a.λ.b' 2023-09-24 17:36:26 +02:00
d4de74eab6 change it to #[..] since # is also reserved 2023-09-22 18:38:40 +02:00
bcfb0d81b8 update tests 2023-09-22 18:38:32 +02:00
8395bec4cb check for duplicate cases in enum matches 2023-09-22 18:37:53 +02:00
6153b4f7f8 add a couple of failing examples 2023-09-22 14:03:22 +02:00
d4cfbd4045 add @[fail] modifier to declarations
- `@[fail] def foo = ...` succeeds if `foo` has some error.
- `@[fail "scope"] def foo = ...` succeeds if `foo` has some error
  containing the word "scope" somewhere
- `@[fail] namespace foo { }` works too and the error must be anywhere
  in the namespace
2023-09-22 14:03:22 +02:00
ea674503c0 export PushSubsts, oops 2023-09-20 21:58:55 +02:00
b1eefb0f4d move prettyTag to Quox.Pretty 2023-09-20 21:58:42 +02:00
ee22486e97 rename BindName.name to .val 2023-09-20 21:58:27 +02:00
08fb686bf6 move Scoped to separate module 2023-09-20 21:58:04 +02:00
cf3ed604a4 move Quox.Syntax.Var to just Quox.Var 2023-09-20 21:56:59 +02:00
4704dd0441 remove on-hold dir 2023-09-20 21:55:03 +02:00
dc076b636d fix warnings 2023-09-19 18:13:45 +02:00
80b1b3581a use ST from base 2023-09-19 13:05:01 +02:00
ebde478adc add η for pairs in zero contexts 2023-09-19 00:41:17 +02:00
bb8d2464af add fst and snd 2023-09-18 21:53:38 +02:00
e6c06a5c81 pass the subject quantity through equality etc
in preparation for non-linear η laws
2023-09-18 21:53:38 +02:00
3fe9b96f05 make function types with an empty domain subsingletons
this is useful for the base cases of W types when i try those again

closes #23
2023-09-17 20:10:51 +02:00
244b33d786 fix some comments 2023-09-17 19:11:20 +02:00
b85dcb5402 η for box
fixes #27
2023-09-17 19:11:12 +02:00
e1257560b7 Show for contexts, etc 2023-09-17 19:09:54 +02:00
ac518472ad bump pack db 2023-09-17 19:09:10 +02:00
4c88918ade stop throwing names away 2023-09-17 19:08:49 +02:00
7bd959e919 some example stuff 2023-09-17 14:41:29 +02:00
8221d71416 some refactors 2023-09-17 14:41:20 +02:00
7b53d56072 a few basic fv tests to make sure it's not reversed or whatever 2023-09-16 13:34:11 +02:00
fa14ce1a02 add FreeVars, and split only on used dvars in Equal 2023-09-12 09:56:49 +02:00
9973f8d07b refactor elim equality error stuff 2023-09-12 06:48:51 +02:00
1e8932690b untangle big mutual block in Equal 2023-08-28 22:07:57 +02:00
d5d30ee198 loosen pushCoe's type slightly 2023-08-28 20:03:06 +02:00
add2eb400c make Elim.compare0 able to pass a type to isSubSing
it now recovers from (most) errors and always returns a type, so that
isSubSing doesn't have to recalculate it

it already assumed the inputs had the same type. now it just leans on
that assumption harder
2023-08-28 20:00:54 +02:00
6f9d31aa0a add displacement to Definition 2023-08-28 19:59:36 +02:00
6dcd3332c1 granule & defuncn bibs 2023-08-28 19:57:42 +02:00
32f6e5a3b1 make displace total (with a few asserts) 2023-08-28 19:57:02 +02:00
72609bc12f Elim.compare0 infers the type
instead of calling computeElimType over and over. now there's just one
at the start
2023-08-27 19:05:25 +02:00
3e3bf1b67f factor out this case !mode of {..} stuff 2023-08-27 19:04:30 +02:00
387d44431a add misc.coherence 2023-08-27 18:34:19 +02:00
2340b14407 partly improve coercions over constant lines
still needs a real quality check, or something, for stuff like
e : (x ≡ x : A) ⊢ coe (𝑖 ⇒ e @𝑖) x
2023-08-27 18:28:08 +02:00
edfe30ff63 update compare0 for type-directed whnf 2023-08-26 21:32:15 +02:00
ba77c45c64 always print the direction in coe/comp 2023-08-26 21:19:40 +02:00
f3f74d581a fix Main 2023-08-26 21:07:10 +02:00
22db2724ce make coercion computation type-directed like it should be 2023-08-26 21:00:19 +02:00
0bcb8c24db make an optional Loc non-optional 2023-08-26 20:59:39 +02:00
a221380d61 more effect stuff, incl. ST 2023-08-25 18:59:54 +02:00
4b6b3853a1 make uses of eff more consistent 2023-08-24 19:55:57 +02:00
8264a1bb81 split up whnf module 2023-08-24 18:42:26 +02:00
a24ebe0702 tycasePi etc don't actually need a scope of (S d) 2023-08-24 17:45:37 +02:00
688204f1a4 make some things private 2023-08-24 17:45:20 +02:00
09e39d6224 add some comments 2023-08-24 17:45:12 +02:00
00d92d3f25 add missing parens in pretty printer 2023-08-12 10:25:07 +02:00
c6006682ca add CREDITS.md 2023-08-10 16:44:28 +02:00
cf9bfc2159 example stuff 2023-07-22 21:26:20 +02:00
f6b8a12fab some more example stuff 2023-07-21 17:57:47 +02:00
932469a91e make quantities optional and default to 1 2023-07-18 23:12:04 +02:00
349cf2f477 remove unused Tighten impl 2023-07-17 18:10:13 +02:00
3c0989dcb2 maybe.quox 2023-07-17 18:10:04 +02:00
b6264f388d fix #11 the easy way
tightening just pushes substitutions all the way through. bleh
2023-07-17 03:50:16 +02:00
612fb33663 bump again 2023-07-13 21:28:39 +02:00
147 changed files with 11657 additions and 4637 deletions

2
.gitignore vendored
View file

@ -5,3 +5,5 @@ result
*~
quox
quox-tests
golden-tests/tests/*/output
golden-tests/tests/*/*.ss

4
CREDITS.md Normal file
View 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

View file

@ -1,6 +1,10 @@
load "misc.quox"
load "bool.quox"
load "either.quox"
load "maybe.quox"
load "nat.quox"
load "pair.quox"
load "list.quox"
load "eta.quox"
load "fail.quox"
load "qty.quox"

View file

@ -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;
}

View file

@ -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
View 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
View 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
View 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
View 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
}

View file

@ -1,41 +1,91 @@
load "nat.quox";
namespace list {
namespace vec {
def0 Vec : 0.0.★ → ★ =
def0 Vec : → ★ → ★ =
λ n A ⇒
caseω n return ★ of {
zero ⇒ {nil};
succ _, 0.Tail ⇒ A × Tail
};
def0 List : 0.★ → ★ =
λ A ⇒ (len : ) × Vec len A;
def nil : 0.(A : ★) → List A =
λ A ⇒ (0, 'nil);
def cons : 0.(A : ★) → 1.A → 1.(List A) → List A =
λ A x xs ⇒ case1 xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
def foldr' : 0.(A B : ★) →
1.B → ω.(1.A → 1.B → B) → 1.(n : ) → 1.(Vec n A) → B =
λ A B z c n ⇒
case1 n return n' ⇒ 1.(Vec n' A) → B of {
zero ⇒
λ nil ⇒ case1 nil return B of { 'nil ⇒ z };
succ n, 1.ih ⇒
λ cons ⇒ case1 cons return B of { (first, rest) ⇒ c first (ih rest) }
def elim : 0.(A : ★) → 0.(P : (n : ) → Vec n A → ★) →
P 0 'nil →
ω.((x : A) → 0.(n : ) → 0.(xs : Vec n A) →
P n xs → P (succ n) (x, xs)) →
(n : ) → (xs : Vec n A) → P n xs =
λ A P pn pc n ⇒
case n return n' ⇒ (xs' : Vec n' A) → P n' xs' of {
zero ⇒ λ n ⇒
case n return n' ⇒ P 0 n' of { 'nil ⇒ pn };
succ n, ih ⇒ λ c ⇒
case c return c' ⇒ P (succ n) c' of {
(first, rest) ⇒ pc first n rest (ih rest)
}
};
def foldr : 0.(A B : ★) → 1.B → ω.(1.A → 1.B → B) → 1.(List A) → B =
λ A B z c xs ⇒
case1 xs return B of { (len, elems) ⇒ foldr' A B z c len elems };
def sum : 1.(List ) → = foldr 0 nat.plus;
def numbers : List = (5, (0, 1, 2, 3, 4, 'nil));
def number-sum : sum numbers ≡ 10 : = δ _ ⇒ 10;
#[compile-scheme "(lambda% (n xs) xs)"]
def up : 0.(A : ★) → (n : ) → Vec n A → Vec¹ n A =
λ A n ⇒
case n return n' ⇒ Vec n' A → Vec¹ n' A of {
zero ⇒ λ xs ⇒
case xs return Vec¹ 0 A of { 'nil ⇒ 'nil };
succ n', f' ⇒ λ xs ⇒
case xs return Vec¹ (succ n') A of {
(first, rest) ⇒ (first, f' rest)
}
}
}
def0 Vec = vec.Vec;
namespace list {
def0 List : ★ → ★ =
λ A ⇒ (len : ) × Vec len A;
def Nil : 0.(A : ★) → List A =
λ A ⇒ (0, 'nil);
def Cons : 0.(A : ★) → A → List A → List A =
λ A x xs ⇒ case xs return List A of { (len, elems) ⇒ (succ len, x, elems) };
def elim : 0.(A : ★) → 0.(P : List A → ★) →
P (Nil A) →
ω.((x : A) → 0.(xs : List A) → P xs → P (Cons A x xs)) →
(xs : List A) → P xs =
λ A P pn pc xs ⇒
case xs return xs' ⇒ P xs' of { (len, elems) ⇒
vec.elim A (λ n xs ⇒ P (n, xs))
pn (λ x n xs ih ⇒ pc x (n, xs) ih)
len elems
};
-- [fixme] List A <: List¹ A should be automatic, imo
#[compile-scheme "(lambda (xs) xs)"]
def up : 0.(A : ★) → List A → List¹ A =
λ A xs ⇒
case xs return List¹ A of { (len, elems) ⇒
case nat.dup! len return List¹ A of { [p] ⇒
caseω p return List¹ A of { (lenω, eq0) ⇒
case eq0 return List¹ A of { [eq] ⇒
(lenω, vec.up A lenω (coe (𝑖 ⇒ Vec (eq @𝑖) A) @1 @0 elems))
}
}
}
};
def foldr : 0.(A B : ★) → B → ω.(A → B → B) → List A → B =
λ A B z f xs ⇒ elim A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs;
def map : 0.(A B : ★) → ω.(A → B) → List A → List B =
λ A B f ⇒ foldr A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys);
def0 All : (A : ★) → (P : A → ★) → List A → ★ =
λ A P xs ⇒ foldr¹ A ★ True (λ x ps ⇒ P x × ps) (up A xs);
}
def0 List = list.List;

68
examples/maybe.quox Normal file
View file

@ -0,0 +1,68 @@
load "misc.quox"
load "either.quox"
namespace maybe {
def0 Tag : ★ = {nothing, just}
def0 Payload : Tag → ★ → ★ =
λ tag A ⇒ case tag return ★ of { 'nothing ⇒ True; 'just ⇒ A }
def0 Maybe : ★ → ★ =
λ A ⇒ (t : Tag) × Payload t A
def tag : 0.(A : ★) → ω.(Maybe A) → Tag =
λ _ x ⇒ caseω x return Tag of { (tag, _) ⇒ tag }
def Nothing : 0.(A : ★) → Maybe A =
λ _ ⇒ ('nothing, 'true)
def Just : 0.(A : ★) → A → Maybe A =
λ _ x ⇒ ('just, x)
def0 IsJustTag : Tag → ★ =
λ t ⇒ case t return ★ of { 'just ⇒ True; 'nothing ⇒ False }
def0 IsJust : (A : ★) → Maybe A → ★ =
λ A x ⇒ IsJustTag (tag A x)
def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) =
λ A x ⇒
caseω tag A x return t ⇒ Dec (IsJustTag t) of {
'just ⇒ Yes True 'true;
'nothing ⇒ No False (λ x ⇒ x)
}
def0 nothing-unique :
(A : ★) → (x : True) → ('nothing, x) ≡ Nothing A : Maybe A =
λ A x ⇒
case x return x' ⇒ ('nothing, x') ≡ Nothing A : Maybe A of {
'true ⇒ δ _ ⇒ ('nothing, 'true)
}
def elim :
0.(A : ★) →
0.(P : Maybe A → ★) →
ω.(P (Nothing A)) →
ω.((x : A) → P (Just A x)) →
(x : Maybe A) → P x =
λ A P n j x ⇒
case x return x' ⇒ P x' of { (tag, payload) ⇒
(case tag
return t ⇒
0.(eq : tag ≡ t : Tag) → P (t, coe (i ⇒ Payload (eq @i) A) payload)
of {
'nothing ⇒
λ eq ⇒
case coe (i ⇒ Payload (eq @i) A) payload
return p ⇒ P ('nothing, p)
of { 'true ⇒ n };
'just ⇒ λ eq ⇒ j (coe (i ⇒ Payload (eq @i) A) payload)
}) (δ _ ⇒ tag)
}
}
def0 Maybe = maybe.Maybe
def0 Just = maybe.Just
def0 Nothing = maybe.Nothing

View file

@ -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 @𝑖)]) }
}
}

View file

@ -4,41 +4,72 @@ load "either.quox";
namespace nat {
def dup : 1. → [ω.] =
def elim-0-1 :
0.(P : → ★) →
ω.(P 0) → ω.(P 1) →
ω.(0.(n : ) → P n → P (succ n)) →
(n : ) → P n =
λ P p0 p1 ps n ⇒
case n return n' ⇒ P n' of {
zero ⇒ p0;
succ n' ⇒
case n' return n'' ⇒ P (succ n'') of {
zero ⇒ p1;
succ n'', IH ⇒ ps (succ n'') IH
}
}
#[compile-scheme "(lambda (n) (cons n 'erased))"]
def dup! : (n : ) → [ω. Sing n] =
λ n ⇒
case1 n return [ω.] of {
zero ⇒ [zero];
succ _, 1.d ⇒ case1 d return [ω.] of { [d] ⇒ [succ d] }
case n return n' ⇒ [ω. Sing n'] of {
zero ⇒ [(zero, [δ _ ⇒ zero])];
succ n, d ⇒
appω (Sing n) (Sing (succ n))
(sing.app n (λ n ⇒ succ n)) d
};
def plus : 1. → 1. =
def dup : → [ω.] =
λ n ⇒ appω (Sing n) (sing.val n) (dup! n);
#[compile-scheme "(lambda% (m n) (+ m n))"]
def plus : =
λ m n ⇒
case1 m return of {
case m return of {
zero ⇒ n;
succ _, 1.p ⇒ succ p
succ _, p ⇒ succ p
};
def timesω : 1. → ω. =
#[compile-scheme "(lambda% (m n) (* m n))"]
def timesω : → ω. =
λ m n ⇒
case1 m return of {
case m return of {
zero ⇒ zero;
succ _, 1.t ⇒ plus n t
succ _, t ⇒ plus n t
};
def times : 1.1. =
λ m n ⇒ case1 dup n return of { [n] ⇒ timesω m n };
def times : =
λ m n ⇒ case dup n return of { [n] ⇒ timesω m n };
def pred : 1. = λ n ⇒ case1 n return of { zero ⇒ zero; succ n ⇒ n };
def pred : = λ n ⇒ case n return of { zero ⇒ zero; succ n ⇒ n };
def pred-succ : ω.(n : ) → pred (succ n) ≡ n : =
λ n ⇒ δ 𝑖 ⇒ n;
def0 succ-inj : 0.(m n : ) → 0.(succ m ≡ succ n : ) → m ≡ n : =
def0 succ-inj : (m n : ) → succ m ≡ succ n : → m ≡ n : =
λ m n eq ⇒ δ 𝑖 ⇒ pred (eq @𝑖);
#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"]
def minus : =
λ m n ⇒
(case n return of {
zero ⇒ λ m ⇒ m;
succ _, f ⇒ λ m ⇒ f (pred m)
}) m;
def0 IsSucc : 0. → ★ =
λ n ⇒ caseω n return ★ of { zero ⇒ False; succ _ ⇒ True };
def0 IsSucc : → ★ =
λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True };
def isSucc? : ω.(n : ) → Dec (IsSucc n) =
λ n ⇒
@ -54,14 +85,15 @@ def succ-not-zero : 0.(m : ) → Not (succ m ≡ zero : ) =
λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true;
def0 not-succ-self : 0.(m : ) → Not (m ≡ succ m : ) =
def0 not-succ-self : (m : ) → Not (m ≡ succ m : ) =
λ m ⇒
caseω m return m' ⇒ Not (m' ≡ succ m' : ) of {
case m return m' ⇒ Not (m' ≡ succ m' : ) of {
zero ⇒ zero-not-succ 0;
succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq)
}
#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"]
def eq? : DecEq =
λ m ⇒
caseω m
@ -86,28 +118,48 @@ def eq? : DecEq =
def eqb : ω. → ω. → Bool = λ m n ⇒ dec.bool (m ≡ n : ) (eq? m n);
def0 plus-zero : 0.(m : ) → m ≡ plus m 0 : =
def0 plus-zero : (m : ) → m ≡ plus m 0 : =
λ m ⇒
caseω m return m' ⇒ m' ≡ plus m' 0 : of {
zero ⇒ δ _ ⇒ zero;
succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
case m return m' ⇒ m' ≡ plus m' 0 : of {
zero ⇒ δ _ ⇒ 0;
succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
};
def0 plus-succ : 0.(m n : ) → succ (plus m n) ≡ plus m (succ n) : =
def0 plus-succ : (m n : ) → succ (plus m n) ≡ plus m (succ n) : =
λ m n ⇒
caseω m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : of {
case m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : of {
zero ⇒ δ _ ⇒ succ n;
succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
succ _, ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
};
def0 plus-comm : 0.(m n : ) → plus m n ≡ plus n m : =
def0 plus-comm : (m n : ) → plus m n ≡ plus n m : =
λ m n ⇒
caseω m return m' ⇒ plus m' n ≡ plus n m' : of {
case m return m' ⇒ plus m' n ≡ plus n m' : of {
zero ⇒ plus-zero n;
succ m', ω.ih ⇒
succ m', ih ⇒
trans (succ (plus m' n)) (succ (plus n m')) (plus n (succ m'))
𝑖 ⇒ succ (ih @𝑖))
(plus-succ n m')
};
def0 times-zero : (m : ) → 0 ≡ timesω m 0 : =
λ m ⇒
case m return m' ⇒ 0 ≡ timesω m' 0 : of {
zero ⇒ δ _ ⇒ zero;
succ m', ih ⇒ ih
};
{-
-- unfinished
def0 times-succ : (m n : ) → plus m (timesω m n) ≡ timesω m (succ n) : =
λ m n ⇒
case m
return m' ⇒ plus m' (timesω m' n) ≡ timesω m' (succ n) :
of {
zero ⇒ δ _ ⇒ 0;
succ m', ih ⇒
δ 𝑖 ⇒ plus (succ n) (ih @𝑖)
};
-}
}

View file

@ -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
View 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
View 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
View 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

View file

@ -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
View 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
View 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

View file

@ -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
View 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]

View 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
View 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" "$@"

View file

View file

View file

@ -0,0 +1,2 @@
. ../lib.sh
scheme "$1" empty.quox

View 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
}

View 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 : ★

View file

@ -0,0 +1,2 @@
. ../lib.sh
check "$1" eta-sing.quox

View file

@ -0,0 +1,3 @@
no location:
couldn't load file nonexistent.quox
File Not Found

View file

@ -0,0 +1,2 @@
. ../lib.sh
check "$1" nonexistent.quox

View 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 🐉

View 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 🐉"

View file

@ -0,0 +1,2 @@
. ../lib.sh
compile_run "$1" hello.quox hello.ss

View 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

View file

@ -0,0 +1,2 @@
#[main]
def main : = 5

View file

@ -0,0 +1,2 @@
. ../lib.sh
check "$1" ill-typed-main.quox

View file

@ -0,0 +1,2 @@
0.IsProp : 1.★ → ★
0.feq : 1.(A : ★) → 1.(f : IsProp A) → 1.(g : IsProp A) → f ≡ g : IsProp A

View 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

View file

@ -0,0 +1,2 @@
. ../lib.sh
check "$1" isprop-subsing.quox

View file

@ -0,0 +1,4 @@
ω.five :
five = 5
(define five
5)

View file

@ -0,0 +1 @@
def five : = 5

View file

@ -0,0 +1,2 @@
. ../lib.sh
scheme "$1" five.quox

18
golden-tests/tests/lib.sh Normal file
View 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"
}

View 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 🐉

View 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 🐉"
}

View file

@ -0,0 +1,4 @@
load "lib.quox"
#[main]
def main = lib.main

View file

@ -0,0 +1,2 @@
. ../lib.sh
compile_run "$1" main.quox load.ss

View 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

View file

@ -0,0 +1,12 @@
-- this definition depends on coercion regularity in xtt. which is this
-- (adapted to quox):
--
-- Ψ | Γ ⊢ 0 · A0/𝑖 = A1/𝑖 ⇐ ★
-- ---------------------------------------------------------
-- Ψ | Γ ⊢ π · coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A1/𝑖) ⇒ A1/𝑖
--
-- 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

View file

@ -0,0 +1,2 @@
. ../lib.sh
check "$1" regularity.quox

View 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

View 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

View file

@ -0,0 +1,2 @@
. ../lib.sh
check "$1" coe.quox

View 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

View file

@ -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

View file

@ -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
View 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

View file

@ -6,6 +6,7 @@ import Quox.Name
import Data.DPair
import Data.Nat
import Data.Singleton
import Data.SnocList
import Data.SnocVect
import Data.Vect
@ -57,6 +58,7 @@ public export
tail : Context tm (S n) -> Context tm n
tail = fst . unsnoc
parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
export
toSnocListWith : Telescope tm _ _ -> SnocList a
@ -107,10 +109,17 @@ fromSnocVect [<] = [<]
fromSnocVect (sx :< x) = fromSnocVect sx :< x
public export
tabulateLT : (n : Nat) -> ((i : Nat) -> (0 p : i `LT` n) => tm i) ->
Context tm n
tabulateLT 0 f = [<]
tabulateLT (S k) f =
tabulateLT k (\i => f i @{lteSuccRight %search}) :< f k @{reflexive}
public export
tabulate : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
tabulate f 0 = [<]
tabulate f (S k) = tabulate f k :< f k
tabulate f n = tabulateLT n (\i => f i)
-- [todo] fixup argument order lol
public export
replicate : (n : Nat) -> a -> Context' a n
@ -149,12 +158,12 @@ getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
Context tm len -> Var len -> tm len
getWith shft = getShiftWith shft SZ
infixl 8 !!
export infixl 8 !!
public export %inline
(!!) : CanShift tm => Context tm len -> Var len -> tm len
(!!) = getWith (//)
infixl 8 !!!
export infixl 8 !!!
public export %inline
(!!!) : Context' tm len -> Var len -> tm
(!!!) = getWith const
@ -180,6 +189,12 @@ export %hint
succGT = LTESucc reflexive
public export
drop : (m : Nat) -> Context term (m + n) -> Context term n
drop 0 ctx = ctx
drop (S m) (ctx :< _) = drop m ctx
parameters {auto _ : Applicative f}
export
traverse : (forall n. tm1 n -> f (tm2 n)) ->
@ -191,7 +206,7 @@ parameters {auto _ : Applicative f}
traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
traverse' f = traverse f
infixl 3 `app`
export infixl 3 `app`
||| like `(<*>)` but with effects
export
app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
@ -258,16 +273,17 @@ unzip3 (tel :< (x, y, z)) =
public export
lengthPrf : Telescope _ from to -> (len ** len + from = to)
lengthPrf [<] = (0 ** Refl)
lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
lengthPrf [<] = Element 0 Refl
lengthPrf (tel :< _) =
let len = lengthPrf tel in (S len.fst ** cong S len.snd)
let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
export
lengthPrf0 : Context _ to -> (len ** len = to)
lengthPrf0 : Context _ to -> Singleton to
lengthPrf0 ctx =
let len = lengthPrf ctx in
(len.fst ** rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
let Element len prf = lengthPrf ctx in
rewrite sym prf `trans` plusZeroRightNeutral len in
[|len|]
public export %inline
length : Telescope {} -> Nat
@ -286,6 +302,10 @@ foldl : {0 acc : Nat -> Type} ->
foldl f z [<] = z
foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
export %inline
foldl_ : (acc -> tm -> acc) -> acc -> Telescope' tm from to -> acc
foldl_ f z tel = foldl f z tel
export %inline
foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
@ -345,4 +365,4 @@ parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
namespace BContext
export
toNames : BContext n -> SnocList BaseName
toNames = foldl (\xs, x => xs :< x.name) [<]
toNames = foldl (\xs, x => xs :< x.val) [<]

View file

@ -2,9 +2,12 @@ module Quox.Definition
import public Quox.No
import public Quox.Syntax
import Quox.Displace
import public Data.SortedMap
import public Quox.Loc
import Quox.Pretty
import Control.Eff
import Data.Singleton
import Decidable.Decidable
@ -26,15 +29,21 @@ record Definition where
qty : GQty
type0 : Term 0 0
body0 : DefBody
scheme : Maybe String
isMain : Bool
loc_ : Loc
public export %inline
mkPostulate : GQty -> (type0 : Term 0 0) -> Loc -> Definition
mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_}
mkPostulate : GQty -> (type0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
Definition
mkPostulate qty type0 scheme isMain loc_ =
MkDef {qty, type0, body0 = Postulate, scheme, isMain, loc_}
public export %inline
mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition
mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, loc_}
mkDef : GQty -> (type0, term0 : Term 0 0) -> Maybe String -> Bool -> Loc ->
Definition
mkDef qty type0 term0 scheme isMain loc_ =
MkDef {qty, type0, body0 = Concrete term0, scheme, isMain, loc_}
export Located Definition where def.loc = def.loc_
export Relocatable Definition where setLoc loc = {loc_ := loc}
@ -45,27 +54,51 @@ parameters {d, n : Nat}
(.type) : Definition -> Term d n
g.type = g.type0 // shift0 d // shift0 n
public export %inline
(.typeAt) : Definition -> Universe -> Term d n
g.typeAt u = displace u g.type
public export %inline
(.term) : Definition -> Maybe (Term d n)
g.term = g.body0.term0 <&> \t => t // shift0 d // shift0 n
public export %inline
toElim : Definition -> Maybe $ Elim d n
toElim def = pure $ Ann !def.term def.type def.loc
(.termAt) : Definition -> Universe -> Maybe (Term d n)
g.termAt u = displace u <$> g.term
public export %inline
toElim : Definition -> Universe -> Maybe $ Elim d n
toElim def u = pure $ Ann !(def.termAt u) (def.typeAt u) def.loc
public export
(.typeWith) : Definition -> Singleton d -> Singleton n -> Term d n
g.typeWith (Val d) (Val n) = g.type
public export
(.typeWithAt) : Definition -> Singleton d -> Singleton n -> Universe -> Term d n
g.typeWithAt d n u = displace u $ g.typeWith d n
public export
(.termWith) : Definition -> Singleton d -> Singleton n -> Maybe (Term d n)
g.termWith (Val d) (Val n) = g.term
public export %inline
isZero : Definition -> Bool
isZero g = g.qty.fst == Zero
isZero g = g.qty == GZero
public export
data DefEnvTag = DEFS
NDefinition : Type
NDefinition = (Name, Definition)
public export
Definitions : Type
Definitions = SortedMap Name Definition
public export
data DefEnvTag = DEFS
public export
DefsReader : Type -> Type
DefsReader = ReaderL DEFS Definitions
@ -74,7 +107,21 @@ public export
DefsState : Type -> Type
DefsState = StateL DEFS Definitions
public export %inline
lookupElim : {d, n : Nat} -> Name -> Universe -> Definitions -> Maybe (Elim d n)
lookupElim x u defs = toElim !(lookup x defs) u
public export %inline
lookupElim : {d, n : Nat} -> Name -> Definitions -> Maybe (Elim d n)
lookupElim x defs = toElim !(lookup x defs)
lookupElim0 : Name -> Universe -> Definitions -> Maybe (Elim 0 0)
lookupElim0 = lookupElim
export
prettyDef : {opts : LayoutOpts} -> Name -> Definition -> Eff Pretty (Doc opts)
prettyDef name def = withPrec Outer $ do
qty <- prettyQty def.qty.qty
dot <- dotD
name <- prettyFree name
colon <- colonD
type <- prettyTerm [<] [<] def.type
hangDSingle (hsep [hcat [qty, dot, name], colon]) type

View file

@ -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)

View file

@ -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

File diff suppressed because it is too large Load diff

310
lib/Quox/FreeVars.idr Normal file
View 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

View file

@ -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
View 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 0100. 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

View file

@ -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

View file

@ -4,6 +4,7 @@ import public Data.Nat
import Data.Nat.Division
import Data.SnocList
import Data.Vect
import Data.String
%default total
@ -52,6 +53,42 @@ parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char)
showAtBase : Nat -> String
showAtBase = pack . showAtBase' []
export
showHex : Nat -> String
showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
namespace Nat
export
showHex : Nat -> String
showHex = showAtBase $ fromList $ unpack "0123456789abcdef"
namespace Int
export
showHex : Int -> String
showHex x =
if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x)
namespace Int
export
fromHexit : Char -> Maybe Int
fromHexit c =
if c >= '0' && c <= '9' then Just $ ord c - ord '0'
else if c >= 'a' && c <= 'f' then Just $ ord c - ord 'a' + 10
else if c >= 'A' && c <= 'F' then Just $ ord c - ord 'A' + 10
else Nothing
private
fromHex' : Int -> String -> Maybe Int
fromHex' acc str = case strM str of
StrNil => Just acc
StrCons c cs => fromHex' (16 * acc + !(fromHexit c)) (assert_smaller str cs)
export %inline
fromHex : String -> Maybe Int
fromHex str = do guard $ str /= ""; fromHex' 0 str
namespace Nat
export
fromHexit : Char -> Maybe Nat
fromHexit = map cast . Int.fromHexit
export %inline
fromHex : String -> Maybe Nat
fromHex = map cast . Int.fromHex

View file

@ -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

View file

@ -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

View file

@ -1,39 +1,31 @@
||| take freshly-parsed input, scope check, type check, add to env
module Quox.Parser.FromParser
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
import Quox.Pretty
import Quox.Parser.Syntax
import Quox.Parser.Parser
import public Quox.Parser.LoadFile
import Quox.Typechecker
import Quox.CheckBuiltin
import Data.List
import Data.Maybe
import Data.SnocVect
import Quox.EffExtra
import Control.Monad.ST.Extra
import System.File
import System.Path
import Data.IORef
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
%default total
%hide Typing.Error
%hide Lexer.Error
%hide Parser.Error
public export
NDefinition : Type
NDefinition = (Name, Definition)
public export
IncludePath : Type
IncludePath = List String
public export
SeenFiles : Type
SeenFiles = SortedSet String
%default total
public export
@ -41,27 +33,50 @@ data StateTag = NS | SEEN
public export
FromParserPure : List (Type -> Type)
FromParserPure =
[Except Error, DefsState, StateL NS Mods, NameGen]
public export
LoadFile' : List (Type -> Type)
LoadFile' = [IO, StateL SEEN SeenFiles, Reader IncludePath]
public export
LoadFile : List (Type -> Type)
LoadFile = LoadFile' ++ [Except Error]
FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
public export
FromParserIO : List (Type -> Type)
FromParserIO = FromParserPure ++ LoadFile'
FromParserIO = FromParserPure ++ [LoadFile]
public export
record PureParserResult a where
constructor MkPureParserResult
val : a
suf : NameSuf
defs : Definitions
log : SnocList LogDoc
logLevels : LevelStack
export
fromParserPure : Mods -> NameSuf -> Definitions -> LevelStack ->
Eff FromParserPure a -> Either Error (PureParserResult a)
fromParserPure ns suf defs lvls act = runSTErr $ do
suf <- newSTRef' suf
defs <- newSTRef' defs
log <- newSTRef' [<]
lvls <- newSTRef' lvls
res <- runEff act $ with Union.(::)
[handleExcept $ \e => stLeft e,
handleStateSTRef defs,
handleStateSTRef !(newSTRef' ns),
handleStateSTRef suf,
handleLogST log lvls]
pure $ MkPureParserResult {
val = res,
suf = !(readSTRef' suf),
defs = !(readSTRef' defs),
log = !(readSTRef' log),
logLevels = !(readSTRef' lvls)
}
parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
(xs : Context' PatVar n)
private
fromBaseName : PBaseName -> m a
fromBaseName x = maybe (f $ MakePName [<] x) b $
fromBaseName x = maybe (f $ MkPName [<] x) b $
Context.find (\y => y.name == Just x) xs
private
@ -113,11 +128,10 @@ fromV : Context' PatVar d -> Context' PatVar n ->
PName -> Maybe Universe -> Loc -> Eff FromParserPure (Term d n)
fromV ds ns x u loc = fromName bound free ns x where
bound : Var n -> Eff FromParserPure (Term d n)
bound i = do whenJust u $ \u => throw $ DisplacedBoundVar loc x
pure $ E $ B i loc
bound i = unless (isNothing u) (throw $ DisplacedBoundVar loc x) $> BT i loc
free : PName -> Eff FromParserPure (Term d n)
free x = do x <- avoidDim ds loc x
resolveName !(getAt NS) loc x u
free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
mutual
export
@ -127,6 +141,9 @@ mutual
TYPE k loc =>
pure $ TYPE k loc
IOState loc =>
pure $ IOState loc
Pi pi x s t loc =>
Pi (fromPQty pi)
<$> fromPTermWith ds ns s
@ -157,17 +174,26 @@ mutual
<*> fromPTermTScope ds ns [< x, y] body
<*> pure loc
Fst pair loc =>
map E $ Fst <$> fromPTermElim ds ns pair <*> pure loc
Snd pair loc =>
map E $ Snd <$> fromPTermElim ds ns pair <*> pure loc
Case pi tag (r, ret) (CaseEnum arms _) loc =>
map E $ CaseEnum (fromPQty pi)
<$> fromPTermElim ds ns tag
<*> fromPTermTScope ds ns [< r] ret
<*> assert_total fromPTermEnumArms ds ns arms
<*> assert_total fromPTermEnumArms loc ds ns arms
<*> pure loc
Nat loc => pure $ Nat loc
Zero loc => pure $ Zero loc
NAT loc => pure $ NAT loc
Nat n loc => pure $ Nat n loc
Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|]
STRING loc => pure $ STRING loc
Str str loc => pure $ Str str loc
Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
map E $ CaseNat (fromPQty pi) (fromPQty pi')
<$> fromPTermElim ds ns nat
@ -176,12 +202,11 @@ mutual
<*> fromPTermTScope ds ns [< s, ih] suc
<*> pure loc
Enum strs loc =>
let set = SortedSet.fromList strs in
if length strs == length (SortedSet.toList set) then
Enum strs loc => do
let set = SortedSet.fromList strs
unless (length strs == length (SortedSet.toList set)) $
throw $ DuplicatesInEnumType loc strs
pure $ Enum set loc
else
throw $ DuplicatesInEnum loc strs
Tag str loc => pure $ Tag str loc
@ -238,13 +263,22 @@ mutual
<*> fromPTermDScope ds ns [< j1] val1
<*> pure loc
Let (qty, x, rhs) body loc =>
Let (fromPQty qty)
<$> fromPTermElim ds ns rhs
<*> fromPTermTScope ds ns [< x] body
<*> pure loc
private
fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n ->
List (PTagVal, PTerm) ->
Eff FromParserPure (CaseEnumArms d n)
fromPTermEnumArms ds ns =
map SortedMap.fromList .
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
fromPTermEnumArms loc ds ns arms = do
res <- SortedMap.fromList <$>
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms
unless (length (keys res) == length arms) $
throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms)
pure res
private
fromPTermElim : Context' PatVar d -> Context' PatVar n ->
@ -263,7 +297,7 @@ mutual
if all isUnused xs then
SN <$> fromPTermWith ds ns t
else
ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
private
fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
@ -271,9 +305,9 @@ mutual
Eff FromParserPure (DScopeTermN s d n)
fromPTermDScope ds ns xs t =
if all isUnused xs then
SN <$> fromPTermWith ds ns t
SN {f = \d => Term d n} <$> fromPTermWith ds ns t
else
DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
export %inline
@ -282,72 +316,110 @@ fromPTerm = fromPTermWith [<] [<]
export
globalPQty : Loc -> (q : Qty) -> Eff [Except Error] (So $ isGlobal q)
globalPQty loc pi = case choose $ isGlobal pi of
Left y => pure y
Right _ => throw $ QtyNotGlobal loc pi
globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty
globalPQty (PQ pi loc) = case toGlobal pi of
Just g => pure g
Nothing => throw $ QtyNotGlobal loc pi
export
fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name
fromPBaseNameNS : Has (StateL NS Mods) fs => PBaseName -> Eff fs Name
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
private
liftTC : TC a -> Eff FromParserPure a
liftTC act = do
res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act
rethrow $ mapFst WrapTypeError res
liftTC : Eff TC a -> Eff FromParserPure a
liftTC tc = runEff tc $ with Union.(::)
[handleExcept $ \e => throw $ WrapTypeError e,
handleReaderConst !(getAt DEFS),
\g => send g,
\g => send g]
private
liftWhnf : Eff Whnf a -> Eff FromParserPure a
liftWhnf tc = runEff tc $ with Union.(::)
[handleExcept $ \e => throw $ WrapTypeError e,
\g => send g,
\g => send g]
private
addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition
addDef name def = do
modifyAt DEFS $ insert name def
pure (name, def)
export covering
fromPDef : PDefinition -> Eff FromParserPure NDefinition
fromPDef (MkPDef qty pname ptype pterm defLoc) = do
name <- lift $ fromPBaseNameNS pname
qtyGlobal <- lift $ globalPQty qty.loc qty.val
let gqty = Element qty.val qtyGlobal
sqty = globalToSubj gqty
type <- lift $ traverse fromPTerm ptype
term <- lift $ fromPTerm pterm
case type of
fromPDef def = do
name <- fromPBaseNameNS def.name
defs <- getAt DEFS
when (isJust $ lookup name defs) $ do
throw $ AlreadyExists def.loc name
gqty <- globalPQty def.qty
let sqty = globalToSubj gqty
case def.body of
PConcrete ptype pterm => do
type <- traverse fromPTerm ptype
term <- fromPTerm pterm
type <- case type of
Just type => do
liftTC $ checkTypeC empty type Nothing
liftTC $ ignore $ checkC empty sqty term type
let def = mkDef gqty type term defLoc
modifyAt DEFS $ insert name def
pure (name, def)
ignore $ liftTC $ do
checkTypeC empty type Nothing
checkC empty sqty term type
pure type
Nothing => do
let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term
let E elim = term
| _ => throw $ AnnotationNeeded term.loc empty term
res <- liftTC $ inferC empty sqty elim
let def = mkDef gqty res.type term defLoc
modifyAt DEFS $ insert name def
pure (name, def)
pure res.type
when def.main $ liftWhnf $ expectMainType defs type
addDef name $ mkDef gqty type term def.scheme def.main def.loc
PPostulate ptype => do
type <- fromPTerm ptype
addDef name $ mkPostulate gqty type def.scheme def.main def.loc
public export
data HasFail = NoFail | AnyFail | FailWith String
export covering
expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error
expectFail loc act = do
gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels
case fromParserPure ns gen defs (singleton lvl) act of
Left err => pure err
Right _ => throw $ ExpectedFail loc
export covering
maybeFail : Monoid a =>
PFail -> Loc -> Eff FromParserPure a -> Eff FromParserPure a
maybeFail PSucceed _ act = act
maybeFail PFailAny loc act = expectFail loc act $> neutral
maybeFail (PFailMatch str) loc act = do
err <- expectFail loc act
let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e
if str `isInfixOf` renderInfinite msg
then pure neutral
else throw $ WrongFail str err loc
export covering
fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
fromPDecl (PDef def) = singleton <$> fromPDef def
fromPDecl (PDef def) =
maybeFail def.fail def.loc $ singleton <$> fromPDef def
fromPDecl (PNs ns) =
maybeFail ns.fail ns.loc $
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
export covering
loadFile : Loc -> String -> Eff LoadFile (Maybe String)
loadFile loc file =
if contains file !(getAt SEEN) then
pure Nothing
else do
Just ifile <- firstExists (map (</> file) !ask)
| Nothing => throw $ LoadError loc file FileNotFound
case !(readFile ifile) of
Right res => modifyAt SEEN (insert file) $> Just res
Left err => throw $ LoadError loc ifile err
fromPDecl (PPrag prag) =
case prag of
PLogPush p _ => Log.push p $> []
PLogPop _ => Log.pop $> []
mutual
export covering
loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
loadProcessFile loc file =
case !(lift $ loadFile loc file) of
Just inp => do
tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
concat <$> traverse fromPTopLevel tl
case !(loadFile loc file) of
Just tl => concat <$> traverse fromPTopLevel tl
Nothing => pure []
||| populates the `defs` field of the state
@ -355,28 +427,3 @@ mutual
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
fromPTopLevel (PD decl) = lift $ fromPDecl decl
fromPTopLevel (PLoad file loc) = loadProcessFile loc file
export
fromParserPure : NameSuf -> Definitions ->
Eff FromParserPure a ->
(Either Error (a, Definitions), NameSuf)
fromParserPure suf defs act =
extract $
runStateAt GEN suf $
runExcept $
evalStateAt NS [<] $
runStateAt DEFS defs act
export
fromParserIO : (MonadRec io, HasIO io) =>
IncludePath ->
IORef SeenFiles -> IORef NameSuf -> IORef Definitions ->
Eff FromParserIO a -> io (Either Error a)
fromParserIO inc seen suf defs act =
runIO $
runStateIORefAt GEN suf $
runExcept $
evalStateAt NS [<] $
runStateIORefAt SEEN seen $
runStateIORefAt DEFS defs $
runReader inc act

View file

@ -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

View file

@ -1,6 +1,7 @@
module Quox.Parser.Lexer
import Quox.CharExtra
import Quox.NatExtra
import Quox.Name
import Data.String.Extra
import Data.SortedMap
@ -19,7 +20,7 @@ import Derive.Prelude
||| @ Reserved reserved token
||| @ Name name, possibly qualified
||| @ Nat nat literal
||| @ String string literal
||| @ Str string literal
||| @ Tag tag literal
||| @ TYPE "Type" or "★" with ascii nat directly after
||| @ Sup superscript or ^ number (displacement, or universe for ★)
@ -34,16 +35,27 @@ data Token =
| Sup Nat
%runElab derive "Token" [Eq, Ord, Show]
-- token or whitespace
||| token or whitespace
||| @ Skip whitespace, comments, etc
||| @ Invalid a token which failed a post-lexer check
||| (e.g. a qualified name containing a keyword)
||| @ T a well formed token
public export
0 TokenW : Type
TokenW = Maybe Token
data ExtToken = Skip | Invalid String String | T Token
%runElab derive "ExtToken" [Eq, Ord, Show]
public export
data ErrorReason =
NoRuleApply
| ComposeNotClosing (Int, Int) (Int, Int)
| Other String
%runElab derive "ErrorReason" [Eq, Ord, Show]
public export
record Error where
constructor Err
reason : StopReason
reason : ErrorReason
line, col : Int
||| `Nothing` if the error is at the end of the input
char : Maybe Char
@ -52,49 +64,94 @@ record Error where
private
skip : Lexer -> Tokenizer TokenW
skip t = match t $ const Nothing
skip : Lexer -> Tokenizer ExtToken
skip t = match t $ const Skip
private
match : Lexer -> (String -> Token) -> Tokenizer TokenW
match t f = Tokenizer.match t (Just . f)
%hide Tokenizer.match
tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
tmatch t f = match t (T . f)
private
name : Tokenizer TokenW
name = match name $ Name . fromListP . split (== '.') . normalizeNfc
||| [todo] escapes other than `\"` and (accidentally) `\\`
export
fromStringLit : String -> String
fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where
fromStringLit : (String -> Token) -> String -> ExtToken
fromStringLit f str =
case go $ unpack $ drop 1 $ dropLast 1 str of
Left err => Invalid err str
Right ok => T $ f $ pack ok
where
Interpolation Char where interpolate = singleton
go, hexEscape : List Char -> Either String (List Char)
go [] = Right []
go ['\\'] = Left "string ends with \\"
go ('\\' :: 'n' :: cs) = ('\n' ::) <$> go cs
go ('\\' :: 't' :: cs) = ('\t' ::) <$> go cs
go ('\\' :: 'x' :: cs) = hexEscape cs
go ('\\' :: 'X' :: cs) = hexEscape cs
go ('\\' :: '\\' :: cs) = ('\\' ::) <$> go cs
go ('\\' :: '"' :: cs) = ('"' ::) <$> go cs
-- [todo] others
go ('\\' :: c :: _) = Left "unknown escape '\{c}'"
go (c :: cs) = (c ::) <$> go cs
hexEscape cs =
case break (== ';') cs of
(hs, ';' :: rest) => do
let hs = pack hs
let Just c = Int.fromHex hs
| Nothing => Left #"invalid hex string "\#{hs}" in escape"#
if isCodepoint c
then (chr c ::) <$> go (assert_smaller cs rest)
else Left "codepoint \{hs} out of range"
_ => Left "unterminated hex escape"
private
string : Tokenizer ExtToken
string = match stringLit $ fromStringLit Str
%hide binLit
%hide octLit
%hide hexLit
private
nat : Tokenizer ExtToken
nat = match hexLit fromHexLit
<|> tmatch decLit fromDecLit
where
withUnderscores : Lexer -> Lexer
withUnderscores l = l <+> many (opt (is '_') <+> l)
withoutUnderscores : String -> String
withoutUnderscores = pack . go . unpack where
go : List Char -> List Char
go [] = []
go ['\\'] = ['\\'] -- i guess???
go ('\\' :: c :: cs) = c :: go cs
go ('_' :: cs) = go cs
go (c :: cs) = c :: go cs
private
string : Tokenizer TokenW
string = match stringLit (Str . fromStringLit)
decLit =
withUnderscores (range '0' '9') <+> reject idContEnd
hexLit =
approx "0x" <+>
withUnderscores (range '0' '9' <|> range 'a' 'f' <|> range 'A' 'F') <+>
reject idContEnd
fromDecLit : String -> Token
fromDecLit = Nat . cast . withoutUnderscores
fromHexLit : String -> ExtToken
fromHexLit str =
maybe (Invalid "invalid hex sequence" str) (T . Nat) $
fromHex $ withoutUnderscores $ drop 2 str
private
nat : Tokenizer TokenW
nat = match (some (range '0' '9')) (Nat . cast)
tag : Tokenizer ExtToken
tag = tmatch (is '\'' <+> name) (Tag . drop 1)
<|> match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1)
private
tag : Tokenizer TokenW
tag = match (is '\'' <+> name) (Tag . drop 1)
<|> match (is '\'' <+> stringLit) (Tag . fromStringLit . drop 1)
private %inline
fromSub : Char -> Char
fromSub c = case c of
'' => '0'; '' => '1'; '' => '2'; '' => '3'; '' => '4'
'' => '5'; '' => '6'; '' => '7'; '' => '8'; '' => '9'; _ => c
private %inline
fromSup : Char -> Char
@ -102,27 +159,23 @@ fromSup c = case c of
'' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '' => '4'
'' => '5'; '' => '6'; '' => '7'; '' => '8'; '' => '9'; _ => c
private %inline
subToNat : String -> Nat
subToNat = cast . pack . map fromSub . unpack
private %inline
supToNat : String -> Nat
supToNat = cast . pack . map fromSup . unpack
-- ★0, Type0. base ★/Type is a Reserved
-- ★0, Type0. base ★/Type is a Reserved and ★¹/Type¹ are sequences of two tokens
private
universe : Tokenizer TokenW
universe : Tokenizer ExtToken
universe = universeWith "" <|> universeWith "Type" where
universeWith : String -> Tokenizer TokenW
universeWith : String -> Tokenizer ExtToken
universeWith pfx =
let len = length pfx in
match (exact pfx <+> digits) (TYPE . cast . drop len)
tmatch (exact pfx <+> digits) (TYPE . cast . drop len)
private
sup : Tokenizer TokenW
sup = match (some $ pred isSupDigit) (Sup . supToNat)
<|> match (is '^' <+> digits) (Sup . cast . drop 1)
sup : Tokenizer ExtToken
sup = tmatch (some $ pred isSupDigit) (Sup . supToNat)
<|> tmatch (is '^' <+> digits) (Sup . cast . drop 1)
private %inline
@ -134,9 +187,11 @@ namespace Reserved
||| description of a reserved symbol
||| @ Word a reserved word (must not be followed by letters, digits, etc)
||| @ Sym a reserved symbol (must not be followed by symbolic chars)
||| @ Punc a character that doesn't show up in names (brackets, etc)
||| @ Punc a character that doesn't show up in names (brackets, etc);
||| also a sequence ending in one of those, like `#[`, since the
||| difference relates to lookahead
public export
data Reserved1 = Word String | Sym String | Punc Char
data Reserved1 = Word String | Sym String | Punc String
%runElab derive "Reserved1" [Eq, Ord, Show]
||| description of a token that might have unicode & ascii-only aliases
@ -145,17 +200,14 @@ namespace Reserved
%runElab derive "Reserved" [Eq, Ord, Show]
public export
Sym1, Word1 : String -> Reserved
Sym1, Word1, Punc1 : String -> Reserved
Sym1 = Only . Sym
Word1 = Only . Word
public export
Punc1 : Char -> Reserved
Punc1 = Only . Punc
public export
resString1 : Reserved1 -> String
resString1 (Punc x) = singleton x
resString1 (Punc x) = x
resString1 (Word w) = w
resString1 (Sym s) = s
@ -166,17 +218,23 @@ resString : Reserved -> String
resString (Only r) = resString1 r
resString (r `Or` _) = resString1 r
||| return both representative strings for a token description
public export
resString2 : Reserved -> List String
resString2 (Only r) = [resString1 r]
resString2 (r `Or` s) = [resString1 r, resString1 s]
private
resTokenizer1 : Reserved1 -> String -> Tokenizer TokenW
resTokenizer1 : Reserved1 -> String -> Tokenizer ExtToken
resTokenizer1 r str =
let res : String -> Token := const $ Reserved str in
case r of Word w => match (exact w <+> reject idContEnd) res
Sym s => match (exact s <+> reject symCont) res
Punc x => match (is x) res
case r of Word w => tmatch (exact w <+> reject idContEnd) res
Sym s => tmatch (exact s <+> reject symCont) res
Punc x => tmatch (exact x) res
||| match a reserved token
export
resTokenizer : Reserved -> Tokenizer TokenW
resTokenizer : Reserved -> Tokenizer ExtToken
resTokenizer (Only r) = resTokenizer1 r (resString1 r)
resTokenizer (r `Or` s) =
resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
@ -188,8 +246,8 @@ resTokenizer (r `Or` s) =
public export
reserved : List Reserved
reserved =
[Punc1 '(', Punc1 ')', Punc1 '[', Punc1 ']', Punc1 '{', Punc1 '}',
Punc1 ',', Punc1 ';',
[Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}",
Punc1 ",", Punc1 ";", Punc1 "#[", Punc1 "#![",
Sym1 "@",
Sym1 ":",
Sym "" `Or` Sym "=>",
@ -197,12 +255,16 @@ reserved =
Sym "×" `Or` Sym "**",
Sym "" `Or` Sym "==",
Sym "" `Or` Sym "::",
Punc1 '.',
Punc1 ".",
Word1 "case",
Word1 "case0", Word1 "case1",
Word "caseω" `Or` Word "case#",
Word1 "return",
Word1 "of",
Word1 "let", Word1 "in",
Word1 "let0", Word1 "let1",
Word "letω" `Or` Word "let#",
Word1 "fst", Word1 "snd",
Word1 "_",
Word1 "Eq",
Word "λ" `Or` Word "fun",
@ -210,35 +272,71 @@ reserved =
Word "ω" `Or` Sym "#",
Sym "" `Or` Word "Type",
Word "" `Or` Word "Nat",
Word1 "IOState",
Word1 "String",
Word1 "zero", Word1 "succ",
Word1 "coe", Word1 "comp",
Word1 "def",
Word1 "def0",
Word "defω" `Or` Word "def#",
Word1 "postulate",
Word1 "postulate0",
Word "postulateω" `Or` Word "postulate#",
Sym1 "=",
Word1 "load",
Word1 "namespace"]
public export
reservedStrings : List String
reservedStrings = map resString reserved
public export
allReservedStrings : List String
allReservedStrings = foldMap resString2 reserved
||| `IsReserved str` is true if `Reserved str` might actually show up in
||| the token stream
public export
IsReserved : String -> Type
IsReserved str = str `Elem` map resString reserved
IsReserved str = So (str `elem` reservedStrings)
private
name : Tokenizer ExtToken
name =
match name $ \str =>
let parts = split (== '.') $ normalizeNfc str in
case find (`elem` allReservedStrings) (toList parts) of
Nothing => T $ Name $ fromListP parts
Just w => Invalid "reserved word '\{w}' inside name \{str}" str
export
tokens : Tokenizer TokenW
tokens : Tokenizer ExtToken
tokens = choice $
map skip [pred isWhitespace,
lineComment (exact "--" <+> reject symCont),
blockComment (exact "{-") (exact "-}")] <+>
[universe] <+> -- ★ᵢ takes precedence over bare ★
[universe] <+> -- Type<i> takes precedence over bare Type
map resTokenizer reserved <+>
[sup, nat, string, tag, name]
export
check : Alternative f =>
WithBounds ExtToken -> Either Error (f (WithBounds Token))
check (MkBounded val irr bounds@(MkBounds line col _ _)) = case val of
Skip => Right empty
T tok => Right $ pure $ MkBounded tok irr bounds
Invalid msg tok => Left $ Err (Other msg) line col (index 0 tok)
export
toErrorReason : StopReason -> Maybe ErrorReason
toErrorReason EndInput = Nothing
toErrorReason NoRuleApply = Just NoRuleApply
toErrorReason (ComposeNotClosing s e) = Just $ ComposeNotClosing s e
export
lex : String -> Either Error (List (WithBounds Token))
lex str =
let (res, reason, line, col, str) = lex tokens str in
case reason of
EndInput => Right $ mapMaybe sequence res
_ => Left $ Err {reason, line, col, char = index 0 str}
case toErrorReason reason of
Nothing => concatMap check res @{MonoidApplicative}
Just e => Left $ Err {reason = e, line, col, char = index 0 str}

View 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 ()

View file

@ -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

View file

@ -3,6 +3,8 @@ module Quox.Parser.Syntax
import public Quox.Loc
import public Quox.Syntax
import public Quox.Definition
import Quox.PrettyValExtra
import public Quox.Log
import Derive.Prelude
%hide TT.Name
@ -14,9 +16,9 @@ import Derive.Prelude
public export
data PatVar = Unused Loc | PV PBaseName Loc
%name PatVar v
%runElab derive "PatVar" [Eq, Ord, Show]
%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
export
export %inline
Located PatVar where
(Unused loc).loc = loc
(PV _ loc).loc = loc
@ -38,17 +40,17 @@ record PQty where
val : Qty
loc_ : Loc
%name PQty qty
%runElab derive "PQty" [Eq, Ord, Show]
%runElab derive "PQty" [Eq, Ord, Show, PrettyVal]
export Located PQty where q.loc = q.loc_
export %inline Located PQty where q.loc = q.loc_
namespace PDim
public export
data PDim = K DimConst Loc | V PBaseName Loc
%name PDim p, q
%runElab derive "PDim" [Eq, Ord, Show]
%runElab derive "PDim" [Eq, Ord, Show, PrettyVal]
export
export %inline
Located PDim where
(K _ loc).loc = loc
(V _ loc).loc = loc
@ -56,7 +58,7 @@ Located PDim where
public export
data PTagVal = PT TagVal Loc
%name PTagVal tag
%runElab derive "PTagVal" [Eq, Ord, Show]
%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
namespace PTerm
@ -66,6 +68,8 @@ namespace PTerm
data PTerm =
TYPE Universe Loc
| IOState Loc
| Pi PQty PatVar PTerm PTerm Loc
| Lam PatVar PTerm Loc
| App PTerm PTerm Loc
@ -73,6 +77,7 @@ namespace PTerm
| Sig PatVar PTerm PTerm Loc
| Pair PTerm PTerm Loc
| Case PQty PTerm (PatVar, PTerm) PCaseBody Loc
| Fst PTerm Loc | Snd PTerm Loc
| Enum (List TagVal) Loc
| Tag TagVal Loc
@ -81,8 +86,11 @@ namespace PTerm
| DLam PatVar PTerm Loc
| DApp PTerm PDim Loc
| Nat Loc
| Zero Loc | Succ PTerm Loc
| NAT Loc
| Nat Nat Loc | Succ PTerm Loc
| STRING Loc -- "String" is a reserved word in idris
| Str String Loc
| BOX PQty PTerm Loc
| Box PTerm Loc
@ -93,6 +101,8 @@ namespace PTerm
| Coe (PatVar, PTerm) PDim PDim PTerm Loc
| Comp (PatVar, PTerm) PDim PDim PTerm PDim
(PatVar, PTerm) (PatVar, PTerm) Loc
| Let (PQty, PatVar, PTerm) PTerm Loc
%name PTerm s, t
public export
@ -103,33 +113,43 @@ namespace PTerm
| CaseBox PatVar PTerm Loc
%name PCaseBody body
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
public export %inline
Zero : Loc -> PTerm
Zero = Nat 0
export
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal]
export %inline
Located PTerm where
(TYPE _ loc).loc = loc
(IOState loc).loc = loc
(Pi _ _ _ _ loc).loc = loc
(Lam _ _ loc).loc = loc
(App _ _ loc).loc = loc
(Sig _ _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Fst _ loc).loc = loc
(Snd _ loc).loc = loc
(Case _ _ _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ _ loc).loc = loc
(DApp _ _ loc).loc = loc
(Nat loc).loc = loc
(Zero loc).loc = loc
(NAT loc).loc = loc
(Nat _ loc).loc = loc
(Succ _ loc).loc = loc
(STRING loc).loc = loc
(Str _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(V _ _ loc).loc = loc
(Ann _ _ loc).loc = loc
(Coe _ _ _ _ loc).loc = loc
(Comp _ _ _ _ _ _ _ loc).loc = loc
(Let _ _ loc).loc = loc
export
export %inline
Located PCaseBody where
(CasePair _ _ loc).loc = loc
(CaseEnum _ loc).loc = loc
@ -137,18 +157,45 @@ Located PCaseBody where
(CaseBox _ _ loc).loc = loc
public export
data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm
%name PBody body
%runElab derive "PBody" [Eq, Ord, Show, PrettyVal]
public export
data PFail =
PSucceed
| PFailAny
| PFailMatch String
%runElab derive "PFail" [Eq, Ord, Show, PrettyVal]
public export
record PDefinition where
constructor MkPDef
qty : PQty
name : PBaseName
type : Maybe PTerm
term : PTerm
body : PBody
fail : PFail
main : Bool
scheme : Maybe String
loc_ : Loc
%name PDefinition def
%runElab derive "PDefinition" [Eq, Ord, Show]
%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
export Located PDefinition where def.loc = def.loc_
export %inline Located PDefinition where def.loc = def.loc_
public export
data PPragma =
PLogPush (List Log.PushArg) Loc
| PLogPop Loc
%name PPragma prag
%runElab derive "PPragma" [Eq, Ord, Show, PrettyVal]
export %inline
Located PPragma where
(PLogPush _ loc).loc = loc
(PLogPop loc).loc = loc
mutual
public export
@ -156,6 +203,7 @@ mutual
constructor MkPNamespace
name : Mods
decls : List PDecl
fail : PFail
loc_ : Loc
%name PNamespace ns
@ -163,28 +211,41 @@ mutual
data PDecl =
PDef PDefinition
| PNs PNamespace
| PPrag PPragma
%name PDecl decl
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show]
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
export Located PNamespace where ns.loc = ns.loc_
export %inline Located PNamespace where ns.loc = ns.loc_
export
export %inline
Located PDecl where
(PDef def).loc = def.loc
(PDef d).loc = d.loc
(PNs ns).loc = ns.loc
(PPrag prag).loc = prag.loc
public export
data PTopLevel = PD PDecl | PLoad String Loc
%name PTopLevel t
%runElab derive "PTopLevel" [Eq, Ord, Show]
%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal]
export
export %inline
Located PTopLevel where
(PD decl).loc = decl.loc
(PLoad _ loc).loc = loc
public export
fromNat : Nat -> Loc -> PTerm
fromNat 0 loc = Zero loc
fromNat (S k) loc = Succ (fromNat k loc) loc
record PAttr where
constructor PA
name : PBaseName
args : List PTerm
loc_ : Loc
%name PAttr attr
%runElab derive "PAttr" [Eq, Ord, Show, PrettyVal]
export %inline Located PAttr where attr.loc = attr.loc_
public export
PFile : Type
PFile = List PTopLevel

View file

@ -3,6 +3,7 @@ module Quox.Pretty
import Quox.Loc
import Quox.Name
import Control.Monad.ST.Extra
import public Text.PrettyPrint.Bernardy
import public Text.PrettyPrint.Bernardy.Core.Decorate
import public Quox.EffExtra
@ -40,7 +41,7 @@ data HL
| Dim | DVar | DVarErr
| Qty | Universe
| Syntax
| Tag
| Constant
%runElab derive "HL" [Eq, Ord, Show]
@ -65,11 +66,12 @@ export %inline
runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
Eff Pretty a -> a
runPrettyWith prec flavor highlight indent act =
extract $
evalStateAt PREC prec $
runReaderAt FLAVOR flavor $
runReaderAt HIGHLIGHT highlight $
runReaderAt INDENT indent act
runST $ do
runEff act $ with Union.(::)
[handleStateSTRef !(newSTRef prec),
handleReaderConst flavor,
handleReaderConst highlight,
handleReaderConst indent]
export %inline
@ -84,43 +86,65 @@ toSGR DVarErr = [SetForeground BrightGreen, SetStyle SingleUnderline]
toSGR Qty = [SetForeground BrightMagenta]
toSGR Universe = [SetForeground BrightRed]
toSGR Syntax = [SetForeground BrightCyan]
toSGR Tag = [SetForeground BrightRed]
toSGR Constant = [SetForeground BrightRed]
export %inline
highlightSGR : HL -> Highlight
highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
export %inline
toClass : HL -> String
toClass Delim = "dl"
toClass Free = "fr"
toClass TVar = "tv"
toClass TVarErr = "tv err"
toClass Dim = "dc"
toClass DVar = "dv"
toClass DVarErr = "dv err"
toClass Qty = "qt"
toClass Universe = "un"
toClass Syntax = "sy"
toClass Constant = "co"
export %inline
highlightHtml : HL -> Highlight
highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
export %inline
runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
runPrettyHL f = runPrettyWith Outer Unicode f 2
export %inline
runPretty : Eff Pretty a -> a
runPretty = runPrettyWith Outer Unicode noHighlight 2
export %inline
runPrettyColor : Eff Pretty a -> a
runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
runPretty = runPrettyHL noHighlight
export %inline
hl : {opts : _} -> HL -> Doc opts -> Eff Pretty (Doc opts)
hl : {opts : LayoutOpts} -> HL -> Doc opts -> Eff Pretty (Doc opts)
hl h doc = asksAt HIGHLIGHT $ \f => decorate (f h) doc
export %inline
indentD : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
indentD : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
indentD doc = pure $ indent !(askAt INDENT) doc
export %inline
hangD : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
hangD : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
export %inline
hangDSingle : {opts : _} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
hangDSingle d1 d2 =
pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2))
hangSingle : {opts : LayoutOpts} -> Nat -> Doc opts -> Doc opts -> Doc opts
hangSingle n d1 d2 = ifMultiline (d1 <++> d2) (vappend d1 (indent n d2))
export %inline
hangDSingle : {opts : LayoutOpts} -> Doc opts -> Doc opts ->
Eff Pretty (Doc opts)
hangDSingle d1 d2 = pure $ hangSingle !(askAt INDENT) d1 d2
export
tightDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
tightDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
Eff Pretty (Doc opts)
tightDelims l r inner = do
l <- hl Delim $ text l
@ -128,7 +152,7 @@ tightDelims l r inner = do
pure $ hcat [l, inner, r]
export
looseDelims : {opts : _} -> (l, r : String) -> (inner : Doc opts) ->
looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
Eff Pretty (Doc opts)
looseDelims l r inner = do
l <- hl Delim $ text l
@ -138,39 +162,39 @@ looseDelims l r inner = do
pure $ ifMultiline short long
export %inline
parens : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
parens = tightDelims "(" ")"
export %inline
bracks : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
bracks = tightDelims "[" "]"
export %inline
braces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
braces = looseDelims "{" "}"
export %inline
tightBraces : {opts : _} -> Doc opts -> Eff Pretty (Doc opts)
tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
tightBraces = tightDelims "{" "}"
export %inline
parensIf : {opts : _} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
parensIf : {opts : LayoutOpts} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
parensIf True = parens
parensIf False = pure
||| uses hsep only if the whole list fits on one line
export
sepSingle : {opts : _} -> List (Doc opts) -> Doc opts
sepSingle : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
sepSingle xs = ifMultiline (hsep xs) (vsep xs)
export
fillSep : {opts : _} -> List (Doc opts) -> Doc opts
fillSep : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
fillSep [] = empty
fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
export
exceptLast : {opts : _} -> (Doc opts -> Doc opts) ->
exceptLast : {opts : LayoutOpts} -> (Doc opts -> Doc opts) ->
List (Doc opts) -> List (Doc opts)
exceptLast f [] = []
exceptLast f [x] = [x]
@ -185,11 +209,24 @@ parameters {opts : LayoutOpts} {auto _ : Foldable t}
separateTight : Doc opts -> t (Doc opts) -> Doc opts
separateTight d = sep . exceptLast (<+> d) . toList
export
hseparateTight : Doc opts -> t (Doc opts) -> Doc opts
hseparateTight d = hsep . exceptLast (<+> d) . toList
export
vseparateTight : Doc opts -> t (Doc opts) -> Doc opts
vseparateTight d = vsep . exceptLast (<+> d) . toList
export
fillSeparateTight : Doc opts -> t (Doc opts) -> Doc opts
fillSeparateTight d = fillSep . exceptLast (<+> d) . toList
export %inline
pshow : {opts : LayoutOpts} -> Show a => a -> Doc opts
pshow = text . show
export %inline
ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a
ifUnicode uni asc =
@ -198,7 +235,7 @@ ifUnicode uni asc =
Ascii => asc
export %inline
parensIfM : {opts : _} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
parensIfM d doc = parensIf (!(getAt PREC) > d) doc
export %inline
@ -211,64 +248,73 @@ prettyName : Name -> Doc opts
prettyName = text . toDots
export
prettyFree : {opts : _} -> Name -> Eff Pretty (Doc opts)
prettyFree : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts)
prettyFree = hl Free . prettyName
export
prettyBind' : BindName -> Doc opts
prettyBind' = text . baseStr . name
prettyBind' = text . baseStr . val
export
prettyTBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
prettyTBind = hl TVar . prettyBind'
export
prettyDBind : {opts : _} -> BindName -> Eff Pretty (Doc opts)
prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
prettyDBind = hl DVar . prettyBind'
export %inline
typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD :
{opts : _} -> Eff Pretty (Doc opts)
typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD,
stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD,
zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD :
{opts : LayoutOpts} -> Eff Pretty (Doc opts)
typeD = hl Syntax . text =<< ifUnicode "" "Type"
arrowD = hl Delim . text =<< ifUnicode "" "->"
darrowD = hl Delim . text =<< ifUnicode "" "=>"
timesD = hl Delim . text =<< ifUnicode "×" "**"
ioStateD = hl Syntax $ text "IOState"
arrowD = hl Syntax . text =<< ifUnicode "" "->"
darrowD = hl Syntax . text =<< ifUnicode "" "=>"
timesD = hl Syntax . text =<< ifUnicode "×" "**"
lamD = hl Syntax . text =<< ifUnicode "λ" "fun"
eqndD = hl Delim . text =<< ifUnicode "" "=="
eqndD = hl Syntax . text =<< ifUnicode "" "=="
dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun"
annD = hl Delim . text =<< ifUnicode "" "::"
annD = hl Syntax . text =<< ifUnicode "" "::"
natD = hl Syntax . text =<< ifUnicode "" "Nat"
stringD = hl Syntax $ text "String"
eqD = hl Syntax $ text "Eq"
colonD = hl Delim $ text ":"
commaD = hl Delim $ text ","
colonD = hl Syntax $ text ":"
commaD = hl Syntax $ text ","
semiD = hl Delim $ text ";"
atD = hl Delim $ text "@"
caseD = hl Syntax $ text "case"
typecaseD = hl Syntax $ text "type-case"
ofD = hl Syntax $ text "of"
returnD = hl Syntax $ text "return"
dotD = hl Delim $ text "."
zeroD = hl Syntax $ text "zero"
succD = hl Syntax $ text "succ"
zeroD = hl Constant $ text "zero"
succD = hl Constant $ text "succ"
coeD = hl Syntax $ text "coe"
compD = hl Syntax $ text "comp"
undD = hl Syntax $ text "_"
cstD = hl Syntax $ text "="
pipeD = hl Syntax $ text "|"
pipeD = hl Delim $ text "|"
fstD = hl Syntax $ text "fst"
sndD = hl Syntax $ text "snd"
letD = hl Syntax $ text "let"
inD = hl Syntax $ text "in"
export
prettyApp : {opts : _} -> Nat -> Doc opts -> List (Doc opts) -> Doc opts
prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
List (Doc opts) -> Doc opts
prettyApp ind f args =
hsep (f :: args)
<|> hsep [f, vsep args]
<|> vsep (f :: map (indent ind) args)
ifMultiline
(hsep (f :: args))
(f <++> vsep args <|> vsep (f :: map (indent ind) args))
export
prettyAppD : {opts : _} -> Doc opts -> List (Doc opts) -> Eff Pretty (Doc opts)
prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
Eff Pretty (Doc opts)
prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
@ -288,7 +334,7 @@ quoteTag tag =
"\"" ++ escapeString tag ++ "\""
export
prettyBounds : {opts : _} -> Bounds -> Eff Pretty (Doc opts)
prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
prettyBounds (MkBounds l1 c1 l2 c2) =
hcat <$> sequence
[hl TVar $ text $ show l1, colonD,
@ -297,8 +343,22 @@ prettyBounds (MkBounds l1 c1 l2 c2) =
hl DVar $ text $ show c2, colonD]
export
prettyLoc : {opts : _} -> Loc -> Eff Pretty (Doc opts)
prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
prettyLoc (L NoLoc) =
hcat <$> sequence [hl TVarErr "no location", colonD]
prettyLoc (L (YesLoc file b)) =
hcat <$> sequence [hl Free $ text file, colonD, prettyBounds b]
export
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
export
prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
prettyStrLit s =
let s = concatMap esc1 $ unpack s in
hl Constant $ hcat ["\"", text s, "\""]
where
esc1 : Char -> String
esc1 '"' = "\""; esc1 '\\' = "\\"
esc1 c = singleton c

View 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]

View file

@ -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 (A0/i, A1/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 ⇒ Aj/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 ⇒ Ar/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[(A0/i ∷ ★ᵢ)/a₀, (A1/i ∷ ★ᵢ)/a₁,
-- ((δ i ⇒ A) ∷ Eq [★ᵢ] A0/i A1/i)/a,
-- (L ∷ A0/i)/l, (R ∷ A1/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) ∷ Aq/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 ⇒ Aj/i] @p @i s)/x]] @p @q t)
-- ∷ (x : Aq/i) × Bq/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) ∷ Aq/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] ∷ [π. Aq/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 ∷ A0/𝑗
-- e : Eq (𝑗 ⇒ A) t u ⊢ e @1 ⇝ u ∷ A1/𝑗
--
-- ((δ 𝑖 ⇒ 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; ⋯ } ⇝ tq/j ∷ A
-- comp [A] @p @q s @1 { 1 j ⇒ t; ⋯ } ⇝ tq/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
View 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

View file

@ -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

View 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

View file

@ -2,10 +2,11 @@ module Quox.Syntax.Dim
import Quox.Loc
import Quox.Name
import Quox.Syntax.Var
import Quox.Var
import Quox.Syntax.Subst
import Quox.Pretty
import Quox.Context
import Quox.PrettyValExtra
import Decidable.Equality
import Control.Function
@ -18,7 +19,7 @@ import Derive.Prelude
public export
data DimConst = Zero | One
%name DimConst e
%runElab derive "DimConst" [Eq, Ord, Show]
%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal]
||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
public export

View file

@ -1,11 +1,12 @@
module Quox.Syntax.DimEq
import public Quox.Syntax.Var
import public Quox.Var
import public Quox.Syntax.Dim
import public Quox.Syntax.Subst
import public Quox.Context
import Quox.Pretty
import Quox.Name
import Quox.FreeVars
import Data.Maybe
import Data.Nat
@ -58,10 +59,15 @@ Traversable (IfConsistent eqs) where
traverse f Nothing = pure Nothing
traverse f (Just x) = Just <$> f x
public export
ifConsistentElse : Applicative f => (eqs : DimEq d) ->
f a -> f () -> f (IfConsistent eqs a)
ifConsistentElse ZeroIsOne yes no = Nothing <$ no
ifConsistentElse (C _) yes no = Just <$> yes
public export
ifConsistent : Applicative f => (eqs : DimEq d) -> f a -> f (IfConsistent eqs a)
ifConsistent ZeroIsOne act = pure Nothing
ifConsistent (C _) act = Just <$> act
ifConsistent eqs act = ifConsistentElse eqs act (pure ())
public export
toMaybe : IfConsistent eqs a -> Maybe a
@ -70,13 +76,13 @@ toMaybe (Just x) = Just x
export
fromGround' : Context' DimConst d -> DimEq' d
fromGround' [<] = [<]
fromGround' (ctx :< e) = fromGround' ctx :< Just (K e noLoc)
fromGround' : BContext d -> Context' DimConst d -> DimEq' d
fromGround' [<] [<] = [<]
fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
export
fromGround : Context' DimConst d -> DimEq d
fromGround = C . fromGround'
fromGround : BContext d -> Context' DimConst d -> DimEq d
fromGround = C .: fromGround'
public export %inline
@ -117,7 +123,7 @@ equal ZeroIsOne p q = True
equal (C eqs) p q = get eqs p == get eqs q
infixl 7 :<?
export infixl 7 :<?
export %inline
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
ZeroIsOne :<? d = ZeroIsOne
@ -185,20 +191,28 @@ split1 e loc eqs = case setConst VZ e loc eqs of
C (eqs :< _) => Just (eqs, K e loc ::: id)
export %inline
split : Loc -> DimEq' (S d) -> List (Split d)
split loc eqs = toList (split1 Zero loc eqs) <+> toList (split1 One loc eqs)
split1' : DimConst -> Loc -> DimEq' (S d) -> List (Split d)
split1' e loc eqs = toList $ split1 e loc eqs
export %inline
split : Loc -> DimEq' (S d) -> Bool -> List (Split d)
split loc eqs False = split1' Zero loc eqs
split loc eqs True = split1' Zero loc eqs <+> split1' One loc eqs
export
splits' : Loc -> DimEq' d -> List (DSubst d 0)
splits' _ [<] = [id]
splits' loc eqs@(_ :< _) =
[th . ph | (eqs', th) <- split loc eqs, ph <- splits' loc eqs']
splits' : Loc -> DimEq' d -> FreeVars d -> List (DSubst d 0)
splits' _ [<] _ = [id]
splits' loc eqs@(_ :< _) us = do
let (us, u) = uncons us
(eqs', th) <- split loc eqs u
ph <- splits' loc eqs' us
pure $ th . ph
||| the Loc is put into each of the DimConsts
export %inline
splits : Loc -> DimEq d -> List (DSubst d 0)
splits _ ZeroIsOne = []
splits loc (C eqs) = splits' loc eqs
splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
splits _ ZeroIsOne _ = []
splits loc (C eqs) fvs = splits' loc eqs fvs
private
@ -228,9 +242,20 @@ setSelf (B i _) (C eqs) with (compareP i i) | (compare i.nat i.nat)
_ | IsGT gt | GT = absurd gt
private %inline
dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec
dimEqPrec vars eqs =
if length vars <= 1 && maybe True null eqs then Arg else Outer
private
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
prettyDVars = traverse prettyDBind . toSnocList'
prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
prettyDVars' = traverse prettyDBind . toSnocList'
export
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
prettyDVars vars =
parensIfM (dimEqPrec vars Nothing) $
fillSeparateTight !commaD $ !(prettyDVars' vars)
private
prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
@ -247,16 +272,16 @@ prettyCsts dnames (eqs :< Just q) =
export
prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
prettyDimEq' dnames eqs = do
vars <- prettyDVars dnames
eqs <- prettyCsts dnames eqs
let prec = if length vars <= 1 && null eqs then Arg else Outer
parensIfM prec $ fillSeparateTight !commaD $ toList vars ++ toList eqs
prettyDimEq' vars eqs = do
vars' <- prettyDVars' vars
eqs' <- prettyCsts vars eqs
parensIfM (dimEqPrec vars (Just eqs)) $
fillSeparateTight !commaD $ vars' ++ eqs'
export
prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
prettyDimEq dnames ZeroIsOne = do
vars <- prettyDVars dnames
vars <- prettyDVars' dnames
cst <- prettyCst [<] (K Zero noLoc) (K One noLoc)
pure $ separateTight !commaD $ vars :< cst
prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs

View file

@ -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

View file

@ -1,9 +1,11 @@
module Quox.Syntax.Shift
import public Quox.Syntax.Var
import public Quox.Var
import Data.Nat
import Data.So
import Data.Singleton
import Syntax.PreorderReasoning
%default total
@ -146,6 +148,25 @@ weakViaNat s by =
%transform "Shift.weak" Shift.weak = weakViaNat
export
getFrom : {to : Nat} -> Shift from to -> Singleton from
getFrom SZ = Val to
getFrom (SS by) = getFrom by
private
0 getFromViaNatProof : (by : Shift from to) -> from = to `minus` by.nat
getFromViaNatProof by = Calc $
|~ from
~~ minus (by.nat + from) by.nat ..<(minusPlus {})
~~ minus to by.nat ..<(cong (flip minus by.nat) (shiftDiff by))
private
getFromViaNat : {to : Nat} -> Shift from to -> Singleton from
getFromViaNat by = rewrite getFromViaNatProof by in Val _
%transform "Shift.getFrom" Shift.getFrom = getFromViaNat
public export
shift : Shift from to -> Var from -> Var to
shift SZ i = i
@ -178,11 +199,12 @@ by . SS bz = SS $ by . bz
private
0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
to = by.nat + bz.nat + from
compNatProof by bz =
trans (shiftDiff bz) $
trans (cong (bz.nat +) (shiftDiff by)) $
trans (plusAssociative bz.nat by.nat from) $
cong (+ from) (plusCommutative bz.nat by.nat)
compNatProof by bz = Calc $
|~ to
~~ bz.nat + mid ...(shiftDiff {})
~~ bz.nat + (by.nat + from) ...(cong (bz.nat +) (shiftDiff {}))
~~ bz.nat + by.nat + from ...(plusAssociative {})
~~ by.nat + bz.nat + from ...(cong (+ from) (plusCommutative {}))
private %inline
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
@ -205,7 +227,7 @@ compViaNatCorrect by (SS bz) =
%transform "Shift.(.)" Shift.(.) = compViaNat
infixl 8 //
export infixl 8 //
public export
interface CanShift f where
(//) : f from -> Shift from to -> f to

View file

@ -1,12 +1,13 @@
module Quox.Syntax.Subst
import public Quox.Syntax.Shift
import Quox.Syntax.Var
import Quox.Var
import Quox.Name
import Data.Nat
import Data.List
import Data.SnocVect
import Data.Singleton
import Derive.Prelude
%default total
@ -19,7 +20,7 @@ data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
(:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
%name Subst th, ph, ps
infixr 7 !:::
export infixr 7 !:::
||| in case the automatic laziness insertion gets confused
public export
(!:::) : env to -> Subst env from to -> Subst env (S from) to
@ -41,7 +42,7 @@ export Ord (f to) => Ord (Subst f from to) where compare = compare `on` repr
export Show (f to) => Show (Subst f from to) where show = show . repr
infixl 8 //
export infixl 8 //
public export
interface FromVar term => CanSubstSelf term where
(//) : term from -> Lazy (Subst term from to) -> term to
@ -95,18 +96,18 @@ map f (t ::: th) = f t ::: map f th
public export %inline
push : CanSubstSelf f => Subst f from to -> Subst f (S from) (S to)
push th = fromVar VZ ::: (th . shift 1)
push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
push loc th = fromVarLoc VZ loc ::: (th . shift 1)
-- [fixme] a better way to do this?
public export
pushN : CanSubstSelf f => (s : Nat) ->
pushN : CanSubstSelf f => (s : Nat) -> Loc ->
Subst f from to -> Subst f (s + from) (s + to)
pushN 0 th = th
pushN (S s) th =
pushN 0 _ th = th
pushN (S s) loc th =
rewrite plusSuccRightSucc s from in
rewrite plusSuccRightSucc s to in
pushN s $ fromVar VZ ::: (th . shift 1)
pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
public export
drop1 : Subst f (S from) to -> Subst f from to
@ -124,6 +125,12 @@ one : f n -> Subst f (S n) n
one x = fromSnocVect [< x]
export
getFrom : {to : Nat} -> Subst _ from to -> Singleton from
getFrom (Shift by) = getFrom by
getFrom (t ::: th) = [|S $ getFrom th|]
||| whether two substitutions with the same codomain have the same shape
||| (the same number of terms and the same shift at the end). if so, they
||| also have the same domain
@ -133,7 +140,7 @@ cmpShape : Subst env from1 to -> Subst env from2 to ->
cmpShape (Shift by) (Shift bz) = cmpLen by bz
cmpShape (Shift _) (_ ::: _) = Left LT
cmpShape (_ ::: _) (Shift _) = Left GT
cmpShape (_ ::: th) (_ ::: ph) = cong S <$> cmpShape th ph
cmpShape (_ ::: th) (_ ::: ph) = map (\x => cong S x) $ cmpShape th ph
public export

View file

@ -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

View file

@ -1,6 +1,7 @@
module Quox.Syntax.Term.Base
import public Quox.Syntax.Var
import public Quox.Var
import public Quox.Scoped
import public Quox.Syntax.Shift
import public Quox.Syntax.Subst
import public Quox.Syntax.Qty
@ -46,39 +47,6 @@ TagVal : Type
TagVal = String
public export
data ScopedBody : Nat -> (Nat -> Type) -> Nat -> Type where
Y : (body : f (s + n)) -> ScopedBody s f n
N : (body : f n) -> ScopedBody s f n
%name ScopedBody body
export %inline %hint
EqScopedBody : (forall n. Eq (f n)) => Eq (ScopedBody s f n)
EqScopedBody = deriveEq
export %inline %hint
ShowScopedBody : (forall n. Show (f n)) => Show (ScopedBody s f n)
ShowScopedBody = deriveShow
||| a scoped term with names
public export
record Scoped (s : Nat) (f : Nat -> Type) (n : Nat) where
constructor S
names : BContext s
body : ScopedBody s f n
%name Scoped body
export %inline
(forall n. Eq (f n)) => Eq (Scoped s f n) where
s == t = s.body == t.body
export %inline %hint
ShowScoped : (forall n. Show (f n)) => Show (Scoped s f n)
ShowScoped = deriveShow
infixl 8 :#
infixl 9 :@, :%
mutual
public export
TSubst : TSubstLike
@ -91,6 +59,10 @@ mutual
||| type of types
TYPE : (l : Universe) -> (loc : Loc) -> Term d n
||| IO state token. this is a builtin because otherwise #[main] being a
||| builtin makes no sense
IOState : (loc : Loc) -> Term d n
||| function type
Pi : (qty : Qty) -> (arg : Term d n) ->
(res : ScopeTerm d n) -> (loc : Loc) -> Term d n
@ -113,15 +85,21 @@ mutual
DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
||| natural numbers (temporary until 𝐖 gets added)
Nat : (loc : Loc) -> Term d n
-- [todo] can these be elims?
Zero : (loc : Loc) -> Term d n
NAT : (loc : Loc) -> Term d n
Nat : (val : Nat) -> (loc : Loc) -> Term d n
Succ : (p : Term d n) -> (loc : Loc) -> Term d n
||| strings
STRING : (loc : Loc) -> Term d n
Str : (str : String) -> (loc : Loc) -> Term d n
||| "box" (package a value up with a certain quantity)
BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
Box : (val : Term d n) -> (loc : Loc) -> Term d n
Let : (qty : Qty) -> (rhs : Elim d n) ->
(body : ScopeTerm d n) -> (loc : Loc) -> Term d n
||| elimination
E : (e : Elim d n) -> Term d n
@ -155,6 +133,12 @@ mutual
(loc : Loc) ->
Elim d n
||| first element of a pair. only works in non-linear contexts.
Fst : (pair : Elim d n) -> (loc : Loc) -> Elim d n
||| second element of a pair. only works in non-linear contexts.
Snd : (pair : Elim d n) -> (loc : Loc) -> Elim d n
||| enum matching
CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
(ret : ScopeTerm d n) ->
@ -250,23 +234,123 @@ mutual
ShowElim : Show (Elim d n)
ShowElim = assert_total {a = Show (Elim d n)} deriveShow
||| scope which ignores all its binders
public export %inline
SN : {s : Nat} -> f n -> Scoped s f n
SN = S (replicate s $ BN Unused noLoc) . N
||| scope which uses its binders
public export %inline
SY : BContext s -> f (s + n) -> Scoped s f n
SY ns = S ns . Y
export
Located (Elim d n) where
(F _ _ loc).loc = loc
(B _ loc).loc = loc
(App _ _ loc).loc = loc
(CasePair _ _ _ _ loc).loc = loc
(Fst _ loc).loc = loc
(Snd _ loc).loc = loc
(CaseEnum _ _ _ _ loc).loc = loc
(CaseNat _ _ _ _ _ _ loc).loc = loc
(CaseBox _ _ _ _ loc).loc = loc
(DApp _ _ loc).loc = loc
(Ann _ _ loc).loc = loc
(Coe _ _ _ _ loc).loc = loc
(Comp _ _ _ _ _ _ _ loc).loc = loc
(TypeCase _ _ _ _ loc).loc = loc
(CloE (Sub e _)).loc = e.loc
(DCloE (Sub e _)).loc = e.loc
public export %inline
name : Scoped 1 f n -> BindName
name (S [< x] _) = x
export
Located (Term d n) where
(TYPE _ loc).loc = loc
(IOState loc).loc = loc
(Pi _ _ _ loc).loc = loc
(Lam _ loc).loc = loc
(Sig _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ loc).loc = loc
(NAT loc).loc = loc
(Nat _ loc).loc = loc
(STRING loc).loc = loc
(Str _ loc).loc = loc
(Succ _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(Let _ _ _ loc).loc = loc
(E e).loc = e.loc
(CloT (Sub t _)).loc = t.loc
(DCloT (Sub t _)).loc = t.loc
export
Located1 f => Located (ScopedBody s f n) where
(Y t).loc = t.loc
(N t).loc = t.loc
export
Located1 f => Located (Scoped s f n) where
t.loc = t.body.loc
export
Relocatable (Elim d n) where
setLoc loc (F x u _) = F x u loc
setLoc loc (B i _) = B i loc
setLoc loc (App fun arg _) = App fun arg loc
setLoc loc (CasePair qty pair ret body _) =
CasePair qty pair ret body loc
setLoc loc (Fst pair _) = Fst pair loc
setLoc loc (Snd pair _) = Fst pair loc
setLoc loc (CaseEnum qty tag ret arms _) =
CaseEnum qty tag ret arms loc
setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
CaseNat qty qtyIH nat ret zero succ loc
setLoc loc (CaseBox qty box ret body _) =
CaseBox qty box ret body loc
setLoc loc (DApp fun arg _) =
DApp fun arg loc
setLoc loc (Ann tm ty _) =
Ann tm ty loc
setLoc loc (Coe ty p q val _) =
Coe ty p q val loc
setLoc loc (Comp ty p q val r zero one _) =
Comp ty p q val r zero one loc
setLoc loc (TypeCase ty ret arms def _) =
TypeCase ty ret arms def loc
setLoc loc (CloE (Sub term subst)) =
CloE $ Sub (setLoc loc term) subst
setLoc loc (DCloE (Sub term subst)) =
DCloE $ Sub (setLoc loc term) subst
export
Relocatable (Term d n) where
setLoc loc (TYPE l _) = TYPE l loc
setLoc loc (IOState _) = IOState loc
setLoc loc (Pi qty arg res _) = Pi qty arg res loc
setLoc loc (Lam body _) = Lam body loc
setLoc loc (Sig fst snd _) = Sig fst snd loc
setLoc loc (Pair fst snd _) = Pair fst snd loc
setLoc loc (Enum cases _) = Enum cases loc
setLoc loc (Tag tag _) = Tag tag loc
setLoc loc (Eq ty l r _) = Eq ty l r loc
setLoc loc (DLam body _) = DLam body loc
setLoc loc (NAT _) = NAT loc
setLoc loc (Nat n _) = Nat n loc
setLoc loc (Succ p _) = Succ p loc
setLoc loc (STRING _) = STRING loc
setLoc loc (Str s _) = Str s loc
setLoc loc (BOX qty ty _) = BOX qty ty loc
setLoc loc (Box val _) = Box val loc
setLoc loc (Let qty rhs body _) = Let qty rhs body loc
setLoc loc (E e) = E $ setLoc loc e
setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
export
Relocatable1 f => Relocatable (ScopedBody s f n) where
setLoc loc (Y body) = Y $ setLoc loc body
setLoc loc (N body) = N $ setLoc loc body
export
Relocatable1 f => Relocatable (Scoped s f n) where
setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
public export %inline
(.name) : Scoped 1 f n -> BindName
s.name = name s
||| more convenient Pi
public export %inline
@ -314,6 +398,12 @@ public export %inline
DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
DLamN {body, loc} = DLam {body = SN body, loc}
||| more convenient Coe
public export %inline
CoeY : (i : BindName) -> (ty : Term (S d) n) ->
(p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
CoeY {i, ty, p, q, val, loc} = Coe {ty = SY [< i] ty, p, q, val, loc}
||| non dependent equality type
public export %inline
Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
@ -324,6 +414,11 @@ public export %inline
FT : Name -> Universe -> Loc -> Term d n
FT x u loc = E $ F x u loc
||| same as `B` but as a term
public export %inline
BT : Var n -> (loc : Loc) -> Term d n
BT i loc = E $ B i loc
||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))`
public export %inline
@ -335,10 +430,9 @@ public export %inline
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
BVT i loc = E $ BV i loc
public export
makeNat : Nat -> Loc -> Term d n
makeNat 0 loc = Zero loc
makeNat (S k) loc = Succ (makeNat k loc) loc
public export %inline
Zero : Loc -> Term d n
Zero = Nat 0
public export %inline
enum : List TagVal -> Loc -> Term d n
@ -353,111 +447,6 @@ public export %inline
typeCase1Y : Elim d n -> Term d n ->
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
(loc : Loc) ->
{default (Nat loc) def : Term d n} ->
{default (NAT loc) def : Term d n} ->
Elim d n
typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc
export
Located (Elim d n) where
(F _ _ loc).loc = loc
(B _ loc).loc = loc
(App _ _ loc).loc = loc
(CasePair _ _ _ _ loc).loc = loc
(CaseEnum _ _ _ _ loc).loc = loc
(CaseNat _ _ _ _ _ _ loc).loc = loc
(CaseBox _ _ _ _ loc).loc = loc
(DApp _ _ loc).loc = loc
(Ann _ _ loc).loc = loc
(Coe _ _ _ _ loc).loc = loc
(Comp _ _ _ _ _ _ _ loc).loc = loc
(TypeCase _ _ _ _ loc).loc = loc
(CloE (Sub e _)).loc = e.loc
(DCloE (Sub e _)).loc = e.loc
export
Located (Term d n) where
(TYPE _ loc).loc = loc
(Pi _ _ _ loc).loc = loc
(Lam _ loc).loc = loc
(Sig _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ loc).loc = loc
(Nat loc).loc = loc
(Zero loc).loc = loc
(Succ _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(E e).loc = e.loc
(CloT (Sub t _)).loc = t.loc
(DCloT (Sub t _)).loc = t.loc
export
Located1 f => Located (ScopedBody s f n) where
(Y t).loc = t.loc
(N t).loc = t.loc
export
Located1 f => Located (Scoped s f n) where
t.loc = t.body.loc
export
Relocatable (Elim d n) where
setLoc loc (F x u _) = F x u loc
setLoc loc (B i _) = B i loc
setLoc loc (App fun arg _) = App fun arg loc
setLoc loc (CasePair qty pair ret body _) =
CasePair qty pair ret body loc
setLoc loc (CaseEnum qty tag ret arms _) =
CaseEnum qty tag ret arms loc
setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
CaseNat qty qtyIH nat ret zero succ loc
setLoc loc (CaseBox qty box ret body _) =
CaseBox qty box ret body loc
setLoc loc (DApp fun arg _) =
DApp fun arg loc
setLoc loc (Ann tm ty _) =
Ann tm ty loc
setLoc loc (Coe ty p q val _) =
Coe ty p q val loc
setLoc loc (Comp ty p q val r zero one _) =
Comp ty p q val r zero one loc
setLoc loc (TypeCase ty ret arms def _) =
TypeCase ty ret arms def loc
setLoc loc (CloE (Sub term subst)) =
CloE $ Sub (setLoc loc term) subst
setLoc loc (DCloE (Sub term subst)) =
DCloE $ Sub (setLoc loc term) subst
export
Relocatable (Term d n) where
setLoc loc (TYPE l _) = TYPE l loc
setLoc loc (Pi qty arg res _) = Pi qty arg res loc
setLoc loc (Lam body _) = Lam body loc
setLoc loc (Sig fst snd _) = Sig fst snd loc
setLoc loc (Pair fst snd _) = Pair fst snd loc
setLoc loc (Enum cases _) = Enum cases loc
setLoc loc (Tag tag _) = Tag tag loc
setLoc loc (Eq ty l r _) = Eq ty l r loc
setLoc loc (DLam body _) = DLam body loc
setLoc loc (Nat _) = Nat loc
setLoc loc (Zero _) = Zero loc
setLoc loc (Succ p _) = Succ p loc
setLoc loc (BOX qty ty _) = BOX qty ty loc
setLoc loc (Box val _) = Box val loc
setLoc loc (E e) = E $ setLoc loc e
setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
export
Relocatable1 f => Relocatable (ScopedBody s f n) where
setLoc loc (Y body) = Y $ setLoc loc body
setLoc loc (N body) = N $ setLoc loc body
export
Relocatable1 f => Relocatable (Scoped s f n) where
setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)

View file

@ -30,14 +30,6 @@ BTelescope : Nat -> Nat -> Type
BTelescope = Telescope' BindName
private
subscript : String -> String
subscript = pack . map sub . unpack where
sub : Char -> Char
sub c = case c of
'0' => ''; '1' => ''; '2' => ''; '3' => ''; '4' => ''
'5' => ''; '6' => ''; '7' => ''; '8' => ''; '9' => ''; _ => c
private
superscript : String -> String
superscript = pack . map sup . unpack where
@ -209,8 +201,7 @@ prettyTArg dnames tnames s =
private
prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
prettyDArg dnames p =
map (text "@" <+>) $ withPrec Arg $ prettyDim dnames p
prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
private
splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
@ -238,7 +229,6 @@ prettyDTApps dnames tnames f xs = do
private
record CaseArm opts d n where
constructor MkCaseArm
{0 dinner, ninner : Nat}
pat : Doc opts
dbinds : BTelescope d dinner -- 🍴
tbinds : BTelescope n ninner
@ -251,12 +241,11 @@ parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
body <- withPrec Outer $ assert_total
prettyTerm (dnames . dbinds) (tnames . tbinds) body
header <- (pat <++>) <$> darrowD
pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
private
prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (Doc opts)
prettyCaseBody xs =
braces . separateTight !semiD =<< traverse prettyCaseArm xs
prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts))
prettyCaseBody xs = traverse prettyCaseArm xs
private
prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts)
@ -283,16 +272,12 @@ layoutComp typq val r arms = do
[typq, [val, r <++> lb], map (indent ind) arms, [rb]])
export
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
prettyTag tag = hl Tag $ text $ "'" ++ quoteTag tag
export
prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
prettyEnum cases =
tightBraces =<<
fillSeparateTight !commaD <$>
traverse (hl Tag . Doc.text . quoteTag) cases
traverse (hl Constant . Doc.text . quoteTag) cases
private
prettyCaseRet : {opts : _} ->
@ -303,7 +288,7 @@ prettyCaseRet dnames tnames body = withPrec Outer $ case body of
S [< x] (Y tm) => do
header <- [|prettyTBind x <++> darrowD|]
body <- assert_total prettyTerm dnames (tnames :< x) tm
pure $ hsep [header, body] <|> vsep [header, !(indentD body)]
hangDSingle header body
private
prettyCase_ : {opts : _} ->
@ -311,10 +296,16 @@ prettyCase_ : {opts : _} ->
Doc opts -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) ->
Eff Pretty (Doc opts)
prettyCase_ dnames tnames intro head ret body = do
head <- assert_total prettyElim dnames tnames head
head <- withPrec Outer $ assert_total prettyElim dnames tnames head
ret <- prettyCaseRet dnames tnames ret
body <- prettyCaseBody dnames tnames body
parensIfM Outer $ sep [intro <++> head, !returnD <++> ret, !ofD <++> body]
bodys <- prettyCaseBody dnames tnames body
return <- returnD; of_ <- ofD
lb <- hl Delim "{"; rb <- hl Delim "}"; semi <- semiD
ind <- askAt INDENT
parensIfM Outer $ ifMultiline
(hsep [intro, head, return, ret, of_, lb, hseparateTight semi bodys, rb])
(vsep [intro <++> head, return <++> ret, of_ <++> lb,
indent ind $ vseparateTight semi bodys, rb])
private
prettyCase : {opts : _} ->
@ -325,6 +316,62 @@ prettyCase dnames tnames qty head ret body =
prettyCase_ dnames tnames ![|caseD <+> prettyQty qty|] head ret body
private
LetBinder : Nat -> Nat -> Type
LetBinder d n = (Qty, BindName, Elim d n)
private
LetExpr : Nat -> Nat -> Nat -> Type
LetExpr d n n' = (Telescope (LetBinder d) n n', Term d n')
-- [todo] factor out this and the untyped version somehow
export
splitLet : Telescope (LetBinder d) n n' -> Term d n' -> Exists (LetExpr d n)
splitLet ys t@(Let qty rhs body _) =
splitLet (ys :< (qty, body.name, rhs)) (assert_smaller t body.term)
splitLet ys t =
Evidence _ (ys, t)
private covering
prettyLets : {opts : LayoutOpts} ->
BContext d -> BContext a -> Telescope (LetBinder d) a b ->
Eff Pretty (SnocList (Doc opts))
prettyLets dnames xs lets = snd <$> go lets where
peelAnn : forall d, n. Elim d n -> Maybe (Term d n, Term d n)
peelAnn (Ann tm ty _) = Just (tm, ty)
peelAnn e = Nothing
letHeader : Qty -> BindName -> Eff Pretty (Doc opts)
letHeader qty x = do
lett <- [|letD <+> prettyQty qty|]
x <- prettyTBind x
pure $ lett <++> x
letBody : forall n. BContext n ->
Doc opts -> Elim d n -> Eff Pretty (Doc opts)
letBody tnames hdr e = case peelAnn e of
Just (tm, ty) => do
ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty
tm <- withPrec Outer $ assert_total prettyTerm dnames tnames tm
colon <- colonD; eq <- cstD; d <- askAt INDENT
pure $ hangSingle d (hangSingle d hdr (colon <++> ty)) (eq <++> tm)
Nothing => do
e <- withPrec Outer $ assert_total prettyElim dnames tnames e
eq <- cstD; d <- askAt INDENT
inn <- inD
pure $ ifMultiline
(hsep [hdr, eq, e, inn])
(vsep [hdr, indent d $ hsep [eq, e, inn]])
go : forall b. Telescope (LetBinder d) a b ->
Eff Pretty (BContext b, SnocList (Doc opts))
go [<] = pure (xs, [<])
go (lets :< (qty, x, rhs)) = do
(ys, docs) <- go lets
doc <- letBody ys !(letHeader qty x) rhs
pure (ys :< x, docs :< doc)
private
isDefaultDir : Dim d -> Dim d -> Bool
isDefaultDir (K Zero _) (K One _) = True
@ -342,6 +389,7 @@ prettyTyCasePat : {opts : _} ->
(k : TyConKind) -> BContext (arity k) ->
Eff Pretty (Doc opts)
prettyTyCasePat KTYPE [<] = typeD
prettyTyCasePat KIOState [<] = ioStateD
prettyTyCasePat KPi [< a, b] =
parens . hsep =<< sequence [prettyTBind a, arrowD, prettyTBind b]
prettyTyCasePat KSig [< a, b] =
@ -350,6 +398,7 @@ prettyTyCasePat KEnum [<] = hl Syntax $ text "{}"
prettyTyCasePat KEq [< a0, a1, a, l, r] =
hsep <$> sequence (eqD :: map prettyTBind [a0, a1, a, l, r])
prettyTyCasePat KNat [<] = natD
prettyTyCasePat KString [<] = stringD
prettyTyCasePat KBOX [< a] = bracks =<< prettyTBind a
@ -383,13 +432,13 @@ prettyDisp u = map Just $ hl Universe =<<
ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
prettyTerm dnames tnames (TYPE l _) =
case !(askAt FLAVOR) of
Unicode => do
star <- hl Syntax ""
level <- hl Universe $ text $ superscript $ show l
pure $ hcat [star, level]
Ascii => [|hl Syntax "Type" <++> hl Universe (text $ show l)|]
prettyTerm dnames tnames (TYPE l _) = do
type <- hl Syntax . text =<< ifUnicode "" "Type"
level <- prettyDisp l
pure $ maybe type (type <+>) level
prettyTerm dnames tnames (IOState _) =
ioStateD
prettyTerm dnames tnames (Pi qty arg res _) =
parensIfM Outer =<< do
@ -426,13 +475,15 @@ prettyTerm dnames tnames (Enum cases _) =
prettyTerm dnames tnames (Tag tag _) =
prettyTag tag
prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) = do
prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) =
parensIfM Eq =<< do
l <- withPrec InEq $ prettyTerm dnames tnames l
r <- withPrec InEq $ prettyTerm dnames tnames r
ty <- withPrec InEq $ prettyTerm dnames tnames ty
pure $ sep [l <++> !eqndD, r <++> !colonD, ty]
prettyTerm dnames tnames (Eq ty l r _) = do
prettyTerm dnames tnames (Eq ty l r _) =
parensIfM App =<< do
ty <- prettyTypeLine dnames tnames ty
l <- withPrec Arg $ prettyTerm dnames tnames l
r <- withPrec Arg $ prettyTerm dnames tnames r
@ -441,20 +492,14 @@ prettyTerm dnames tnames (Eq ty l r _) = do
prettyTerm dnames tnames s@(DLam {}) =
prettyLambda dnames tnames s
prettyTerm dnames tnames (Nat _) = natD
prettyTerm dnames tnames (Zero _) = hl Syntax "0"
prettyTerm dnames tnames (Succ p _) = do
succD <- succD
let succ : Doc opts -> Eff Pretty (Doc opts)
succ t = prettyAppD succD [t]
toNat : Term d n -> Eff Pretty (Either (Doc opts) Nat)
toNat s with (pushSubsts' s)
_ | Zero _ = pure $ Right 0
_ | Succ d _ = bitraverse succ (pure . S) =<<
toNat (assert_smaller s d)
_ | s' = map Left . withPrec Arg $
prettyTerm dnames tnames $ assert_smaller s s'
either succ (hl Syntax . text . show . S) =<< toNat p
prettyTerm dnames tnames (NAT _) = natD
prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n
prettyTerm dnames tnames (Succ p _) =
parensIfM App =<<
prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)]
prettyTerm dnames tnames (STRING _) = stringD
prettyTerm dnames tnames (Str s _) = prettyStrLit s
prettyTerm dnames tnames (BOX qty ty _) =
bracks . hcat =<<
@ -464,7 +509,18 @@ prettyTerm dnames tnames (BOX qty ty _) =
prettyTerm dnames tnames (Box val _) =
bracks =<< withPrec Outer (prettyTerm dnames tnames val)
prettyTerm dnames tnames (E e) = prettyElim dnames tnames e
prettyTerm dnames tnames (Let qty rhs body _) = do
let Evidence _ (lets, body) = splitLet [< (qty, body.name, rhs)] body.term
heads <- prettyLets dnames tnames lets
let tnames = tnames . map (\(_, x, _) => x) lets
body <- withPrec Outer $ assert_total prettyTerm dnames tnames body
let lines = toList $ heads :< body
pure $ ifMultiline (hsep lines) (vsep lines)
prettyTerm dnames tnames (E e) =
case the (Elim d n) (pushSubsts' e) of
Ann tm _ _ => assert_total prettyTerm dnames tnames tm
_ => assert_total prettyElim dnames tnames e
prettyTerm dnames tnames t0@(CloT (Sub t ph)) =
prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' id ph t
@ -491,6 +547,16 @@ prettyElim dnames tnames (CasePair qty pair ret body _) = do
prettyCase dnames tnames qty pair ret
[MkCaseArm pat [<] [< x, y] body.term]
prettyElim dnames tnames (Fst pair _) =
parensIfM App =<< do
pair <- prettyTArg dnames tnames (E pair)
prettyAppD !fstD [pair]
prettyElim dnames tnames (Snd pair _) =
parensIfM App =<< do
pair <- prettyTArg dnames tnames (E pair)
prettyAppD !sndD [pair]
prettyElim dnames tnames (CaseEnum qty tag ret arms _) = do
arms <- for (SortedMap.toList arms) $ \(tag, body) =>
pure $ MkCaseArm !(prettyTag tag) [<] [<] body
@ -501,7 +567,7 @@ prettyElim dnames tnames (CaseNat qty qtyIH nat ret zero succ _) = do
[< p, ih] = succ.names
spat0 <- [|succD <++> prettyTBind p|]
ihpat0 <- map hcat $ sequence [prettyQty qtyIH, dotD, prettyTBind ih]
spat <- if ih.name == Unused
spat <- if ih.val == Unused
then pure spat0
else pure $ hsep [spat0 <+> !commaD, ihpat0]
let sarm = MkCaseArm spat [<] [< p, ih] succ.term
@ -517,17 +583,15 @@ prettyElim dnames tnames e@(DApp {}) =
prettyDTApps dnames tnames f xs
prettyElim dnames tnames (Ann tm ty _) =
parensIfM Outer =<<
hangDSingle !(withPrec AnnL [|prettyTerm dnames tnames tm <++> annD|])
!(withPrec Outer (prettyTerm dnames tnames ty))
case the (Term d n) (pushSubsts' tm) of
E e => assert_total prettyElim dnames tnames e
_ => do
tm <- withPrec AnnL $ assert_total prettyTerm dnames tnames tm
ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty
parensIfM Outer =<< hangDSingle (tm <++> !annD) ty
prettyElim dnames tnames (Coe ty p q val _) =
parensIfM App =<<
if isDefaultDir p q then do
ty <- prettyTypeLine dnames tnames ty
val <- prettyTArg dnames tnames val
prettyAppD !coeD [ty, val]
else do
parensIfM App =<< do
ty <- prettyTypeLine dnames tnames ty
p <- prettyDArg dnames p
q <- prettyDArg dnames q
@ -536,16 +600,14 @@ prettyElim dnames tnames (Coe ty p q val _) =
prettyElim dnames tnames e@(Comp ty p q val r zero one _) =
parensIfM App =<< do
ty <- prettyTypeLine dnames tnames $ assert_smaller e $ SN ty
ty <- assert_total $ prettyTypeLine dnames tnames $ SN ty
pq <- sep <$> sequence [prettyDArg dnames p, prettyDArg dnames q]
val <- prettyTArg dnames tnames val
r <- prettyDArg dnames r
arm0 <- [|prettyCompArm dnames tnames Zero zero <+> semiD|]
arm1 <- prettyCompArm dnames tnames One one
ind <- askAt INDENT
if isDefaultDir p q
then layoutComp [ty] val r [arm0, arm1]
else layoutComp [ty, pq] val r [arm0, arm1]
layoutComp [ty, pq] val r [arm0, arm1]
prettyElim dnames tnames (TypeCase ty ret arms def _) = do
arms <- for (toList arms) $ \(k ** body) => do

View file

@ -2,7 +2,6 @@ module Quox.Syntax.Term.Subst
import Quox.No
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Tighten
import Data.SnocVect
%default total
@ -57,12 +56,12 @@ namespace DSubst.DScopeTermN
(//) : {s : Nat} ->
DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
DScopeTermN s d2 n
S ns (Y body) // th = S ns $ Y $ body // pushN s th
S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
S ns (N body) // th = S ns $ N $ body // th
export %inline FromVar (Elim d) where fromVarLoc = B
export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
||| does the minimal reasonable work:
@ -105,7 +104,7 @@ namespace ScopeTermN
(//) : {s : Nat} ->
ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
ScopeTermN s d n2
S ns (Y body) // th = S ns $ Y $ body // pushN s th
S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
S ns (N body) // th = S ns $ N $ body // th
namespace DScopeTermN
@ -118,6 +117,9 @@ namespace DScopeTermN
export %inline CanShift (Term d) where s // by = s // Shift by
export %inline CanShift (Elim d) where e // by = e // Shift by
export %inline CanShift (flip Term n) where s // by = s // Shift by
export %inline CanShift (flip Elim n) where e // by = e // Shift by
export %inline
{s : Nat} -> CanShift (ScopeTermN s d) where
b // by = b // Shift by
@ -132,6 +134,15 @@ public export %inline
dweakT : (by : Nat) -> Term d n -> Term (by + d) n
dweakT by t = t // shift by
public export %inline
dweakS : (by : Nat) -> ScopeTermN s d n -> ScopeTermN s (by + d) n
dweakS by t = t // shift by
public export %inline
dweakDS : {s : Nat} -> (by : Nat) ->
DScopeTermN s d n -> DScopeTermN s (by + d) n
dweakDS by t = t // shift by
public export %inline
dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
dweakE by t = t // shift by
@ -141,34 +152,40 @@ public export %inline
weakT : (by : Nat) -> Term d n -> Term d (by + n)
weakT by t = t // shift by
public export %inline
weakS : {s : Nat} -> (by : Nat) -> ScopeTermN s d n -> ScopeTermN s d (by + n)
weakS by t = t // shift by
public export %inline
weakDS : {s : Nat} -> (by : Nat) ->
DScopeTermN s d n -> DScopeTermN s d (by + n)
weakDS by t = t // shift by
public export %inline
weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
weakE by t = t // shift by
parameters {s : Nat}
namespace ScopeTermBody
parameters {auto _ : CanShift f} {s : Nat}
export %inline
(.term) : ScopedBody s (Term d) n -> Term d (s + n)
(Y b).term = b
(N b).term = weakT s b
getTerm : ScopedBody s f n -> f (s + n)
getTerm (Y b) = b
getTerm (N b) = b // fromNat s
namespace ScopeTermN
export %inline
(.term) : ScopeTermN s d n -> Term d (s + n)
t.term = t.body.term
(.term) : Scoped s f n -> f (s + n)
t.term = getTerm t.body
namespace DScopeTermBody
namespace ScopeTermBody
export %inline
(.term) : ScopedBody s (\d => Term d n) d -> Term (s + d) n
(Y b).term = b
(N b).term = dweakT s b
getTerm0 : ScopedBody 0 f n -> f n
getTerm0 (Y b) = b
getTerm0 (N b) = b
namespace DScopeTermN
namespace ScopeTermN
export %inline
(.term) : DScopeTermN s d n -> Term (s + d) n
t.term = t.body.term
(.term0) : Scoped 0 f n -> f n
t.term0 = getTerm0 t.body
export %inline
subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
@ -190,11 +207,11 @@ dsub1 t p = dsubN t [< p]
public export %inline
(.zero) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
body.zero = dsub1 body $ K Zero loc
public export %inline
(.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
(.one) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
body.one = dsub1 body $ K One loc
@ -202,6 +219,7 @@ public export
0 CloTest : TermLike -> Type
CloTest tm = forall d, n. tm d n -> Bool
public export
interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
@ -249,46 +267,8 @@ mutual
isCloE (DCloE {}) = True
isCloE _ = False
mutual
export
PushSubsts Term Subst.isCloT where
pushSubstsWith th ph (TYPE l loc) =
nclo $ TYPE l loc
pushSubstsWith th ph (Pi qty a body loc) =
nclo $ Pi qty (a // th // ph) (body // th // ph) loc
pushSubstsWith th ph (Lam body loc) =
nclo $ Lam (body // th // ph) loc
pushSubstsWith th ph (Sig a b loc) =
nclo $ Sig (a // th // ph) (b // th // ph) loc
pushSubstsWith th ph (Pair s t loc) =
nclo $ Pair (s // th // ph) (t // th // ph) loc
pushSubstsWith th ph (Enum tags loc) =
nclo $ Enum tags loc
pushSubstsWith th ph (Tag tag loc) =
nclo $ Tag tag loc
pushSubstsWith th ph (Eq ty l r loc) =
nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
pushSubstsWith th ph (DLam body loc) =
nclo $ DLam (body // th // ph) loc
pushSubstsWith _ _ (Nat loc) =
nclo $ Nat loc
pushSubstsWith _ _ (Zero loc) =
nclo $ Zero loc
pushSubstsWith th ph (Succ n loc) =
nclo $ Succ (n // th // ph) loc
pushSubstsWith th ph (BOX pi ty loc) =
nclo $ BOX pi (ty // th // ph) loc
pushSubstsWith th ph (Box val loc) =
nclo $ Box (val // th // ph) loc
pushSubstsWith th ph (E e) =
let Element e nc = pushSubstsWith th ph e in nclo $ E e
pushSubstsWith th ph (CloT (Sub s ps)) =
pushSubstsWith th (comp th ps ph) s
pushSubstsWith th ph (DCloT (Sub s ps)) =
pushSubstsWith (ps . th) ph s
export
PushSubsts Elim Subst.isCloE where
export
PushSubsts Elim Subst.isCloE where
pushSubstsWith th ph (F x u loc) =
nclo $ F x u loc
pushSubstsWith th ph (B i loc) =
@ -300,6 +280,10 @@ mutual
nclo $ App (f // th // ph) (s // th // ph) loc
pushSubstsWith th ph (CasePair pi p r b loc) =
nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
pushSubstsWith th ph (Fst pair loc) =
nclo $ Fst (pair // th // ph) loc
pushSubstsWith th ph (Snd pair loc) =
nclo $ Snd (pair // th // ph) loc
pushSubstsWith th ph (CaseEnum pi t r arms loc) =
nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
(map (\b => b // th // ph) arms) loc
@ -326,16 +310,61 @@ mutual
pushSubstsWith th ph (DCloE (Sub e ps)) =
pushSubstsWith (ps . th) ph e
export
PushSubsts Term Subst.isCloT where
pushSubstsWith th ph (TYPE l loc) =
nclo $ TYPE l loc
pushSubstsWith th ph (IOState loc) =
nclo $ IOState loc
pushSubstsWith th ph (Pi qty a body loc) =
nclo $ Pi qty (a // th // ph) (body // th // ph) loc
pushSubstsWith th ph (Lam body loc) =
nclo $ Lam (body // th // ph) loc
pushSubstsWith th ph (Sig a b loc) =
nclo $ Sig (a // th // ph) (b // th // ph) loc
pushSubstsWith th ph (Pair s t loc) =
nclo $ Pair (s // th // ph) (t // th // ph) loc
pushSubstsWith th ph (Enum tags loc) =
nclo $ Enum tags loc
pushSubstsWith th ph (Tag tag loc) =
nclo $ Tag tag loc
pushSubstsWith th ph (Eq ty l r loc) =
nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
pushSubstsWith th ph (DLam body loc) =
nclo $ DLam (body // th // ph) loc
pushSubstsWith _ _ (NAT loc) =
nclo $ NAT loc
pushSubstsWith _ _ (Nat n loc) =
nclo $ Nat n loc
pushSubstsWith th ph (Succ n loc) =
nclo $ Succ (n // th // ph) loc
pushSubstsWith _ _ (STRING loc) =
nclo $ STRING loc
pushSubstsWith _ _ (Str s loc) =
nclo $ Str s loc
pushSubstsWith th ph (BOX pi ty loc) =
nclo $ BOX pi (ty // th // ph) loc
pushSubstsWith th ph (Box val loc) =
nclo $ Box (val // th // ph) loc
pushSubstsWith th ph (E e) =
let Element e nc = pushSubstsWith th ph e in nclo $ E e
pushSubstsWith th ph (Let qty rhs body loc) =
nclo $ Let qty (rhs // th // ph) (body // th // ph) loc
pushSubstsWith th ph (CloT (Sub s ps)) =
pushSubstsWith th (comp th ps ph) s
pushSubstsWith th ph (DCloT (Sub s ps)) =
pushSubstsWith (ps . th) ph s
private %inline
CompHY : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
||| heterogeneous comp, in terms of Comp and Coe
public export %inline
CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
(r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
CompHY {ty, p, q, val, r, zero, one, loc} =
let ty' = SY ty.names $ ty.term // (B VZ ty.loc ::: shift 2) in
CompH' {ty, p, q, val, r, zero, one, loc} =
let ty' = SY ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
Comp {
ty = dsub1 ty q, p, q,
val = E $ Coe ty p q val val.loc, r,
-- [fixme] better locations for these vars?
zero = SY zero.names $ E $
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
one = SY one.names $ E $
@ -343,33 +372,13 @@ CompHY {ty, p, q, val, r, zero, one, loc} =
loc
}
public export %inline
CompH' : (ty : DScopeTerm d n) ->
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
(zero : DScopeTerm d n) ->
(one : DScopeTerm d n) ->
(loc : Loc) ->
Elim d n
CompH' {ty, p, q, val, r, zero, one, loc} =
case dsqueeze ty of
S _ (N ty) => Comp {ty, p, q, val, r, zero, one, loc}
S _ (Y _) => CompHY {ty, p, q, val, r, zero, one, loc}
||| heterogeneous composition, using Comp and Coe (and subst)
|||
||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ }
||| ≔
||| comp [Aq/i] @p @q (coe [i ⇒ A] @p @q s) @r {
||| 0 j ⇒ coe [i ⇒ A] @j @q t₀;
||| 1 j ⇒ coe [i ⇒ A] @j @q t₁
||| }
||| heterogeneous comp, in terms of Comp and Coe
public export %inline
CompH : (i : BindName) -> (ty : Term (S d) n) ->
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
(j0 : BindName) -> (zero : Term (S d) n) ->
(j1 : BindName) -> (one : Term (S d) n) ->
(loc : Loc) ->
Elim d n
(loc : Loc) -> Elim d n
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
CompH' {ty = SY [< i] ty, p, q, val, r,
zero = SY [< j0] zero, one = SY [< j0] one, loc}
zero = SY [< j0] zero, one = SY [< j1] one, loc}

View file

@ -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

View file

@ -9,7 +9,8 @@ import Generics.Derive
public export
data TyConKind = KTYPE | KPi | KSig | KEnum | KEq | KNat | KBOX
data TyConKind =
KTYPE | KIOState | KPi | KSig | KEnum | KEq | KNat | KString | KBOX
%name TyConKind k
%runElab derive "TyConKind" [Eq.Eq, Ord.Ord, Show.Show, Generic, Meta, DecEq]
@ -26,9 +27,11 @@ allKinds = %runElab do
public export %inline
arity : TyConKind -> Nat
arity KTYPE = 0
arity KIOState = 0
arity KPi = 2
arity KSig = 2
arity KEnum = 0
arity KEq = 5
arity KNat = 0
arity KString = 0
arity KBOX = 1

View file

@ -3,6 +3,7 @@ module Quox.Typechecker
import public Quox.Typing
import public Quox.Equal
import Quox.Displace
import Quox.Pretty
import Data.List
import Data.SnocVect
@ -13,25 +14,14 @@ import Quox.EffExtra
public export
0 TCEff : List (Type -> Type)
TCEff = [ErrorEff, DefsReader, NameGen]
public export
0 TC : Type -> Type
TC = Eff TCEff
export
runTCWith : NameSuf -> Definitions -> TC a -> (Either Error a, NameSuf)
runTCWith = runEqualWith
export
runTC : Definitions -> TC a -> Either Error a
runTC = runEqual
0 TC : List (Type -> Type)
TC = [ErrorEff, DefsReader, NameGen, Log]
parameters (loc : Loc)
export
popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) -> Eff fs (QOutput n)
popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) ->
Eff fs (QOutput n)
popQs [<] qout = pure qout
popQs (pis :< pi) (qout :< rh) = do expectCompatQ loc rh pi; popQs pis qout
@ -52,34 +42,24 @@ lubs ctx [] = zeroFor ctx
lubs ctx (x :: xs) = lubs1 $ x ::: xs
export
typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe ->
CtxExtension d n (arity k + n)
typecaseTel k xs u = case k of
KTYPE => [<]
-- A : ★ᵤ, B : 0.A → ★ᵤ
KPi =>
let [< a, b] = xs in
[< (Zero, a, TYPE u a.loc),
(Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
KSig =>
let [< a, b] = xs in
[< (Zero, a, TYPE u a.loc),
(Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)]
KEnum => [<]
-- A₀ : ★ᵤ, A₁ : ★ᵤ, A : (A₀ ≡ A₁ : ★ᵤ), L : A₀, R : A₀
KEq =>
let [< a0, a1, a, l, r] = xs in
[< (Zero, a0, TYPE u a0.loc),
(Zero, a1, TYPE u a1.loc),
(Zero, a, Eq0 (TYPE u a.loc) (BVT 1 a.loc) (BVT 0 a.loc) a.loc),
(Zero, l, BVT 2 l.loc),
(Zero, r, BVT 2 r.loc)]
KNat => [<]
-- A : ★ᵤ
KBOX => let [< a] = xs in [< (Zero, a, TYPE u a.loc)]
private
prettyTermTC : {opts : LayoutOpts} ->
TyContext d n -> Term d n -> Eff Pretty (Doc opts)
prettyTermTC ctx s = prettyTerm ctx.dnames ctx.tnames s
private
checkLogs : String -> TyContext d n -> SQty ->
Term d n -> Maybe (Term d n) -> Eff TC ()
checkLogs fun ctx sg subj ty = do
let tyDoc = delay $ maybe (text "none") (runPretty . prettyTermTC ctx) ty
sayMany "check" subj.loc
[10 :> text fun,
95 :> hsep ["ctx =", runPretty $ prettyTyContext ctx],
95 :> hsep ["sg =", runPretty $ prettyQty sg.qty],
10 :> hsep ["subj =", runPretty $ prettyTermTC ctx subj],
10 :> hsep ["ty =", tyDoc]]
mutual
||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ"
|||
@ -91,28 +71,32 @@ mutual
||| doing any further work.
export covering %inline
check : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
TC (CheckResult ctx.dctx n)
check ctx sg subj ty = ifConsistent ctx.dctx $ checkC ctx sg subj ty
Eff TC (CheckResult ctx.dctx n)
check ctx sg subj ty =
ifConsistentElse ctx.dctx
(do checkLogs "check" ctx sg subj (Just ty)
checkC ctx sg subj ty)
(say "check" 20 subj.loc "check: 0=1")
||| "Ψ | Γ ⊢₀ s ⇐ A"
|||
||| `check0 ctx subj ty` checks a term (as `check`) in a zero context.
export covering %inline
check0 : TyContext d n -> Term d n -> Term d n -> TC ()
check0 ctx tm ty = ignore $ check ctx szero tm ty
check0 : TyContext d n -> Term d n -> Term d n -> Eff TC ()
check0 ctx tm ty = ignore $ check ctx SZero tm ty
-- the output will always be 𝟎 because the subject quantity is 0
||| `check`, assuming the dimension context is consistent
export covering %inline
checkC : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
TC (CheckResult' n)
Eff TC (CheckResult' n)
checkC ctx sg subj ty =
wrapErr (WhileChecking ctx sg.fst subj ty) $
wrapErr (WhileChecking ctx sg subj ty) $
checkCNoWrap ctx sg subj ty
export covering %inline
checkCNoWrap : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
TC (CheckResult' n)
Eff TC (CheckResult' n)
checkCNoWrap ctx sg subj ty =
let Element subj nc = pushSubsts subj in
check' ctx sg subj ty
@ -122,16 +106,21 @@ mutual
||| `checkType ctx subj ty` checks a type (in a zero context). sometimes the
||| universe doesn't matter, only that a term is _a_ type, so it is optional.
export covering %inline
checkType : TyContext d n -> Term d n -> Maybe Universe -> TC ()
checkType ctx subj l = ignore $ ifConsistent ctx.dctx $ checkTypeC ctx subj l
checkType : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
checkType ctx subj l = do
let univ = TYPE <$> l <*> pure noLoc
ignore $ ifConsistentElse ctx.dctx
(do checkLogs "checkType" ctx SZero subj univ
checkTypeC ctx subj l)
(say "check" 20 subj.loc "checkType: 0=1")
export covering %inline
checkTypeC : TyContext d n -> Term d n -> Maybe Universe -> TC ()
checkTypeC : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
checkTypeC ctx subj l =
wrapErr (WhileCheckingTy ctx subj l) $ checkTypeNoWrap ctx subj l
export covering %inline
checkTypeNoWrap : TyContext d n -> Term d n -> Maybe Universe -> TC ()
checkTypeNoWrap : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
checkTypeNoWrap ctx subj l =
let Element subj nc = pushSubsts subj in
checkType' ctx subj l
@ -145,15 +134,19 @@ mutual
||| doing any further work.
export covering %inline
infer : (ctx : TyContext d n) -> SQty -> Elim d n ->
TC (InferResult ctx.dctx d n)
infer ctx sg subj = ifConsistent ctx.dctx $ inferC ctx sg subj
Eff TC (InferResult ctx.dctx d n)
infer ctx sg subj = do
ifConsistentElse ctx.dctx
(do checkLogs "infer" ctx sg (E subj) Nothing
inferC ctx sg subj)
(say "check" 20 subj.loc "infer: 0=1")
||| `infer`, assuming the dimension context is consistent
export covering %inline
inferC : (ctx : TyContext d n) -> SQty -> Elim d n ->
TC (InferResult' d n)
Eff TC (InferResult' d n)
inferC ctx sg subj =
wrapErr (WhileInferring ctx sg.fst subj) $
wrapErr (WhileInferring ctx sg subj) $
let Element subj nc = pushSubsts subj in
infer' ctx sg subj
@ -161,27 +154,29 @@ mutual
private covering
toCheckType : TyContext d n -> SQty ->
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
TC (CheckResult' n)
Eff TC (CheckResult' n)
toCheckType ctx sg t ty = do
u <- expectTYPE !(askAt DEFS) ctx ty.loc ty
expectEqualQ t.loc Zero sg.fst
u <- expectTYPE !(askAt DEFS) ctx sg ty.loc ty
expectEqualQ t.loc Zero sg.qty
checkTypeNoWrap ctx t (Just u)
pure $ zeroFor ctx
private covering
check' : TyContext d n -> SQty ->
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
TC (CheckResult' n)
Eff TC (CheckResult' n)
check' ctx sg t@(TYPE {}) ty = toCheckType ctx sg t ty
check' ctx sg t@(IOState {}) ty = toCheckType ctx sg t ty
check' ctx sg t@(Pi {}) ty = toCheckType ctx sg t ty
check' ctx sg (Lam body loc) ty = do
(qty, arg, res) <- expectPi !(askAt DEFS) ctx ty.loc ty
(qty, arg, res) <- expectPi !(askAt DEFS) ctx SZero ty.loc ty
-- if Ψ | Γ, x : A ⊢ σ · t ⇐ B ⊳ Σ, ρ·x
-- with ρ ≤ σπ
let qty' = sg.fst * qty
let qty' = sg.qty * qty
qout <- checkC (extendTy qty' body.name arg ctx) sg body.term res.term
-- then Ψ | Γ ⊢ σ · (λx ⇒ t) ⇐ (π·x : A) → B ⊳ Σ
popQ loc qty' qout
@ -189,7 +184,7 @@ mutual
check' ctx sg t@(Sig {}) ty = toCheckType ctx sg t ty
check' ctx sg (Pair fst snd loc) ty = do
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx ty.loc ty
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx SZero ty.loc ty
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ₁
qfst <- checkC ctx sg fst tfst
let tsnd = sub1 tsnd (Ann fst tfst fst.loc)
@ -201,7 +196,7 @@ mutual
check' ctx sg t@(Enum {}) ty = toCheckType ctx sg t ty
check' ctx sg (Tag t loc) ty = do
tags <- expectEnum !(askAt DEFS) ctx ty.loc ty
tags <- expectEnum !(askAt DEFS) ctx SZero ty.loc ty
-- if t ∈ ts
unless (t `elem` tags) $ throw $ TagNotIn loc t tags
-- then Ψ | Γ ⊢ σ · t ⇐ {ts} ⊳ 𝟎
@ -210,38 +205,54 @@ mutual
check' ctx sg t@(Eq {}) ty = toCheckType ctx sg t ty
check' ctx sg (DLam body loc) ty = do
(ty, l, r) <- expectEq !(askAt DEFS) ctx ty.loc ty
(ty, l, r) <- expectEq !(askAt DEFS) ctx SZero ty.loc ty
let ctx' = extendDim body.name ctx
ty = ty.term
body = body.term
-- if Ψ, i | Γ ⊢ σ · t ⇐ A ⊳ Σ
qout <- checkC ctx' sg body ty
-- if Ψ, i, i = 0 | Γ ⊢ t = l : A
lift $ equal loc (eqDim (B VZ loc) (K Zero loc) ctx') ty body (dweakT 1 l)
let ctx0 = eqDim (B VZ loc) (K Zero loc) ctx'
lift $ equal loc ctx0 sg ty body $ dweakT 1 l
-- if Ψ, i, i = 1 | Γ ⊢ t = r : A
lift $ equal loc (eqDim (B VZ loc) (K One loc) ctx') ty body (dweakT 1 r)
let ctx1 = eqDim (B VZ loc) (K One loc) ctx'
lift $ equal loc ctx1 sg ty body $ dweakT 1 r
-- then Ψ | Γ ⊢ σ · (δ i ⇒ t) ⇐ Eq [i ⇒ A] l r ⊳ Σ
pure qout
check' ctx sg t@(Nat {}) ty = toCheckType ctx sg t ty
check' ctx sg t@(NAT {}) ty = toCheckType ctx sg t ty
check' ctx sg (Zero {}) ty = do
expectNat !(askAt DEFS) ctx ty.loc ty
check' ctx sg (Nat {}) ty = do
expectNAT !(askAt DEFS) ctx SZero ty.loc ty
pure $ zeroFor ctx
check' ctx sg (Succ n {}) ty = do
expectNat !(askAt DEFS) ctx ty.loc ty
expectNAT !(askAt DEFS) ctx SZero ty.loc ty
checkC ctx sg n ty
check' ctx sg t@(STRING {}) ty = toCheckType ctx sg t ty
check' ctx sg t@(Str s {}) ty = do
expectSTRING !(askAt DEFS) ctx SZero ty.loc ty
pure $ zeroFor ctx
check' ctx sg t@(BOX {}) ty = toCheckType ctx sg t ty
check' ctx sg (Box val loc) ty = do
(q, ty) <- expectBOX !(askAt DEFS) ctx ty.loc ty
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
valout <- checkC ctx sg val ty
(q, ty) <- expectBOX !(askAt DEFS) ctx SZero ty.loc ty
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ
valout <- checkC ctx (subjMult sg q) val ty
-- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ
pure $ q * valout
check' ctx sg (Let qty rhs body loc) ty = do
eres <- inferC ctx (subjMult sg qty) rhs
let sqty = sg.qty * qty
qout <- checkC (extendTyLet sqty body.name eres.type (E rhs) ctx)
sg body.term (weakT 1 ty)
>>= popQ loc sqty
pure $ qty * eres.qout + qout
check' ctx sg (E e) ty = do
-- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ
infres <- inferC ctx sg e
@ -253,7 +264,7 @@ mutual
private covering
checkType' : TyContext d n ->
(subj : Term d n) -> (0 nc : NotClo subj) =>
Maybe Universe -> TC ()
Maybe Universe -> Eff TC ()
checkType' ctx (TYPE k loc) u = do
-- if 𝓀 < then Ψ | Γ ⊢₀ Type 𝓀 ⇐ Type
@ -261,6 +272,9 @@ mutual
Just l => unless (k < l) $ throw $ BadUniverse loc k l
Nothing => pure ()
checkType' ctx (IOState loc) u = pure ()
-- Ψ | Γ ⊢₀ IOState ⇒ Type
checkType' ctx (Pi qty arg res _) u = do
-- if Ψ | Γ ⊢₀ A ⇐ Type
checkTypeC ctx arg u
@ -301,26 +315,35 @@ mutual
checkType' ctx t@(DLam {}) u =
throw $ NotType t.loc ctx t
checkType' ctx (Nat {}) u = pure ()
checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t
checkType' ctx (NAT {}) u = pure ()
checkType' ctx t@(Nat {}) u = throw $ NotType t.loc ctx t
checkType' ctx t@(Succ {}) u = throw $ NotType t.loc ctx t
checkType' ctx (STRING loc) u = pure ()
-- Ψ | Γ ⊢₀ STRING ⇒ Type
checkType' ctx t@(Str {}) u = throw $ NotType t.loc ctx t
checkType' ctx (BOX q ty _) u = checkType ctx ty u
checkType' ctx t@(Box {}) u = throw $ NotType t.loc ctx t
checkType' ctx (Let qty rhs body loc) u = do
expectEqualQ loc qty Zero
ety <- inferC ctx SZero rhs
checkType (extendTy Zero body.name ety.type ctx) body.term u
checkType' ctx (E e) u = do
-- if Ψ | Γ ⊢₀ E ⇒ Type
infres <- inferC ctx szero e
infres <- inferC ctx SZero e
-- if Ψ | Γ ⊢ Type <: Type 𝓀
case u of
Just u => lift $ subtype e.loc ctx infres.type (TYPE u noLoc)
Nothing => ignore $ expectTYPE !(askAt DEFS) ctx e.loc infres.type
Just u => lift $ subtype e.loc ctx infres.type (TYPE u e.loc)
Nothing => ignore $ expectTYPE !(askAt DEFS) ctx SZero e.loc infres.type
-- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀
private covering
checkTypeScope : TyContext d n -> Term d n ->
ScopeTerm d n -> Maybe Universe -> TC ()
ScopeTerm d n -> Maybe Universe -> Eff TC ()
checkTypeScope ctx s (S _ (N body)) u = checkType ctx body u
checkTypeScope ctx s (S [< x] (Y body)) u =
checkType (extendTy Zero x s ctx) body u
@ -329,25 +352,27 @@ mutual
private covering
infer' : TyContext d n -> SQty ->
(subj : Elim d n) -> (0 nc : NotClo subj) =>
TC (InferResult' d n)
Eff TC (InferResult' d n)
infer' ctx sg (F x u loc) = do
-- if π·x : A {≔ s} in global context
g <- lookupFree x loc !(askAt DEFS)
-- if σ ≤ π
expectCompatQ loc sg.fst g.qty.fst
expectCompatQ loc sg.qty g.qty.qty
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
let Val d = ctx.dimLen; Val n = ctx.termLen
pure $ InfRes {type = displace u g.type, qout = zeroFor ctx}
pure $ InfRes {
type = g.typeWithAt ctx.dimLen ctx.termLen u,
qout = zeroFor ctx
}
infer' ctx sg (B i _) =
-- if x : A ∈ Γ
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ (𝟎, σ·x, 𝟎)
pure $ lookupBound sg.fst i ctx.tctx
pure $ lookupBound sg.qty i ctx.tctx
where
lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n
lookupBound pi VZ (ctx :< type) =
InfRes {type = weakT 1 type, qout = zeroFor ctx :< pi}
lookupBound pi VZ (ctx :< var) =
InfRes {type = weakT 1 var.type, qout = zeroFor ctx :< pi}
lookupBound pi (VS i) (ctx :< _) =
let InfRes {type, qout} = lookupBound pi i ctx in
InfRes {type = weakT 1 type, qout = qout :< Zero}
@ -355,7 +380,7 @@ mutual
infer' ctx sg (App fun arg loc) = do
-- if Ψ | Γ ⊢ σ · f ⇒ (π·x : A) → B ⊳ Σ₁
funres <- inferC ctx sg fun
(qty, argty, res) <- expectPi !(askAt DEFS) ctx fun.loc funres.type
(qty, argty, res) <- expectPi !(askAt DEFS) ctx SZero fun.loc funres.type
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ₂
argout <- checkC ctx (subjMult sg qty) arg argty
-- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + πΣ₂
@ -372,12 +397,12 @@ mutual
pairres <- inferC ctx sg pair
-- if Ψ | Γ, p : (x : A) × B ⊢₀ ret ⇐ Type
checkTypeC (extendTy Zero ret.name pairres.type ctx) ret.term Nothing
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx pair.loc pairres.type
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
-- if Ψ | Γ, x : A, y : B ⊢ σ · body ⇐
-- ret[(x, y) ∷ (x : A) × B/p] ⊳ Σ₂, ρ₁·x, ρ₂·y
-- with ρ₁, ρ₂ ≤ πσ
let [< x, y] = body.names
pisg = pi * sg.fst
pisg = pi * sg.qty
bodyctx = extendTyN [< (pisg, x, tfst), (pisg, y, tsnd.term)] ctx
bodyty = substCasePairRet body.names pairres.type ret
bodyout <- checkC bodyctx sg body.term bodyty >>=
@ -388,10 +413,30 @@ mutual
qout = pi * pairres.qout + bodyout
}
infer' ctx sg (Fst pair loc) = do
-- if Ψ | Γ ⊢ σ · e ⇒ (x : A) × B ⊳ Σ
pairres <- inferC ctx sg pair
(tfst, _) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
-- then Ψ | Γ ⊢ σ · fst e ⇒ A ⊳ ωΣ
pure $ InfRes {
type = tfst,
qout = Any * pairres.qout
}
infer' ctx sg (Snd pair loc) = do
-- if Ψ | Γ ⊢ σ · e ⇒ (x : A) × B ⊳ Σ
pairres <- inferC ctx sg pair
(_, tsnd) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
-- then Ψ | Γ ⊢ σ · snd e ⇒ B[fst e/x] ⊳ ωΣ
pure $ InfRes {
type = sub1 tsnd (Fst pair loc),
qout = Any * pairres.qout
}
infer' ctx sg (CaseEnum pi t ret arms loc) {d, n} = do
-- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁
tres <- inferC ctx sg t
ttags <- expectEnum !(askAt DEFS) ctx t.loc tres.type
ttags <- expectEnum !(askAt DEFS) ctx SZero t.loc tres.type
-- if 1 ≤ π, OR there is only zero or one option
unless (length (SortedSet.toList ttags) <= 1) $ expectCompatQ loc One pi
-- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type
@ -415,39 +460,43 @@ mutual
-- if Ψ | Γ ⊢ σ · n ⇒ ⊳ Σn
nres <- inferC ctx sg n
let nat = nres.type
expectNat !(askAt DEFS) ctx n.loc nat
expectNAT !(askAt DEFS) ctx SZero n.loc nat
-- if Ψ | Γ, n : ⊢₀ A ⇐ Type
checkTypeC (extendTy Zero ret.name nat ctx) ret.term Nothing
-- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ /n] ⊳ Σz
zerout <- checkC ctx sg zer $ sub1 ret $ Ann (Zero zer.loc) nat zer.loc
-- if Ψ | Γ, n : , ih : A ⊢ σ · suc ⇐ A[succ p ∷ /n] ⊳ Σs, ρ₁.p, ρ₂.ih
-- with ρ₂ ≤ π'σ, (ρ₁ + ρ₂) ≤ πσ
-- if Ψ | Γ, n : , ih : A ⊢ σ · suc ⇐ A[succ p ∷ /n] ⊳ Σs, ρ.p, ς.ih
-- with ς ≤ π'σ, (ρ + ς) ≤ πσ
let [< p, ih] = suc.names
pisg = pi * sg.fst
sucCtx = extendTyN [< (pisg, p, Nat p.loc), (pi', ih, ret.term)] ctx
pisg = pi * sg.qty
sucCtx = extendTyN [< (pisg, p, NAT p.loc), (pi', ih, ret.term)] ctx
sucType = substCaseSuccRet suc.names ret
sucout :< qp :< qih <- checkC sucCtx sg suc.term sucType
expectCompatQ loc qih (pi' * sg.fst)
expectCompatQ loc qih (pi' * sg.qty)
-- [fixme] better error here
expectCompatQ loc (qp + qih) pisg
-- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σz + ωΣs
-- if ς = 0, then Σb = lubs(Σz, Σs), otherwise Σb = Σz + ωςΣs
let bodyout = case qih of
Zero => lubs ctx [zerout, sucout]
_ => zerout + Any * sucout
-- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σb
pure $ InfRes {
type = sub1 ret n,
qout = pi * nres.qout + zerout + Any * sucout
qout = pi * nres.qout + bodyout
}
infer' ctx sg (CaseBox pi box ret body loc) = do
-- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁
boxres <- inferC ctx sg box
(q, ty) <- expectBOX !(askAt DEFS) ctx box.loc boxres.type
(rh, ty) <- expectBOX !(askAt DEFS) ctx SZero box.loc boxres.type
-- if Ψ | Γ, x : [ρ.A] ⊢₀ R ⇐ Type
checkTypeC (extendTy Zero ret.name boxres.type ctx) ret.term Nothing
-- if Ψ | Γ, x : A ⊢ t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x
-- if Ψ | Γ, x : A ⊢ σ · t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x
-- with ς ≤ ρπσ
let qpisg = q * pi * sg.fst
bodyCtx = extendTy qpisg body.name ty ctx
let rhpisg = rh * pi * sg.qty
bodyCtx = extendTy rhpisg body.name ty ctx
bodyType = substCaseBoxRet body.name ty ret
bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc qpisg
bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc rhpisg
-- then Ψ | Γ ⊢ caseπ ⋯ ⇒ R[b/x] ⊳ Σ₁ + Σ₂
pure $ InfRes {
type = sub1 ret box,
@ -457,42 +506,54 @@ mutual
infer' ctx sg (DApp fun dim loc) = do
-- if Ψ | Γ ⊢ σ · f ⇒ Eq [𝑖 ⇒ A] l r ⊳ Σ
InfRes {type, qout} <- inferC ctx sg fun
ty <- fst <$> expectEq !(askAt DEFS) ctx fun.loc type
ty <- fst <$> expectEq !(askAt DEFS) ctx SZero fun.loc type
-- then Ψ | Γ ⊢ σ · f p ⇒ Ap/𝑖 ⊳ Σ
pure $ InfRes {type = dsub1 ty dim, qout}
infer' ctx sg (Coe ty p q val loc) = do
-- if Ψ, 𝑖 | Γ ⊢₀ A ⇐ Type _
checkType (extendDim ty.name ctx) ty.term Nothing
-- if Ψ | Γ ⊢ σ · s ⇐ Ap/𝑖 ⊳ Σ
qout <- checkC ctx sg val $ dsub1 ty p
-- then Ψ | Γ ⊢ σ · coe (𝑖 ⇒ A) @p @q s ⇒ Aq/𝑖 ⊳ Σ
pure $ InfRes {type = dsub1 ty q, qout}
infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1) loc) = do
-- if Ψ | Γ ⊢₀ A ⇐ Type _
checkType ctx ty Nothing
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
qout <- checkC ctx sg val ty
-- if Ψ, 𝑗, 𝑖=0 | Γ ⊢ σ · t₀ ⇐ A ⊳ Σ₀
-- Ψ, 𝑗, 𝑖=0, 𝑗=p | Γ ⊢ t₀ = s ⇐ A
let ty' = dweakT 1 ty; val' = dweakT 1 val; p' = weakD 1 p
ctx0 = extendDim j0 $ eqDim r (K Zero j0.loc) ctx
val0 = val0.term
val0 = getTerm val0
qout0 <- check ctx0 sg val0 ty'
lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) ty' val0 val'
lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) sg ty' val0 val'
-- if Ψ, 𝑗, 𝑖=1 | Γ ⊢ σ · t₁ ⇐ A ⊳ Σ₁
-- Ψ, 𝑗, 𝑖=1, 𝑗=p | Γ ⊢ t₁ = s ⇐ A
let ctx1 = extendDim j1 $ eqDim r (K One j1.loc) ctx
val1 = val1.term
val1 = getTerm val1
qout1 <- check ctx1 sg val1 ty'
lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) ty' val1 val'
-- if Σ = Σ₀ = Σ₁
lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) sg ty' val1 val'
let qouts = qout :: catMaybes [toMaybe qout0, toMaybe qout1]
-- then Ψ | Γ ⊢ comp A @p @q s @r {0 𝑗 ⇒ t₀; 1 𝑗 ⇒ t₁} ⇒ A ⊳ Σ
pure $ InfRes {type = ty, qout = lubs ctx qouts}
infer' ctx sg (TypeCase ty ret arms def loc) = do
-- if σ = 0
expectEqualQ loc Zero sg.fst
expectEqualQ loc Zero sg.qty
-- if Ψ, Γ ⊢₀ e ⇒ Type u
u <- expectTYPE !(askAt DEFS) ctx ty.loc . type =<< inferC ctx szero ty
u <- inferC ctx SZero ty >>=
expectTYPE !(askAt DEFS) ctx SZero ty.loc . type
-- if Ψ, Γ ⊢₀ C ⇐ Type (non-dependent return type)
checkTypeC ctx ret Nothing
-- if Ψ, Γ' ⊢₀ A ⇐ C for each rhs A
for_ allKinds $ \k =>
for_ (lookupPrecise k arms) $ \(S names t) =>
check0 (extendTyN (typecaseTel k names u) ctx)
t.term (weakT (arity k) ret)
(getTerm t) (weakT (arity k) ret)
-- then Ψ, Γ ⊢₀ type-case ⋯ ⇒ C
pure $ InfRes {type = ret, qout = zeroFor ctx}

View file

@ -6,7 +6,8 @@ import public Quox.Typing.Error as Typing
import public Quox.Syntax
import public Quox.Definition
import public Quox.Reduce
import public Quox.Whnf
import public Quox.Pretty
import Language.Reflection
import Control.Eff
@ -47,15 +48,14 @@ public export
substCasePairRet : BContext 2 -> Term d n -> ScopeTerm d n -> Term d (2 + n)
substCasePairRet [< x, y] dty retty =
let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc
arg = Ann tm (dty // fromNat 2) tm.loc
in
arg = Ann tm (dty // fromNat 2) tm.loc in
retty.term // (arg ::: shift 2)
public export
substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n)
substCaseSuccRet [< p, ih] retty =
let arg = Ann (Succ (BVT 1 p.loc) p.loc) (Nat noLoc) $ p.loc `extendL` ih.loc
in
let loc = p.loc `extendL` ih.loc
arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT p.loc) loc in
retty.term // (arg ::: shift 2)
public export
@ -65,23 +65,31 @@ substCaseBoxRet x dty retty =
retty.term // (arg ::: shift 1)
parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
private
0 ExpectErrorConstructor : Type
ExpectErrorConstructor =
forall d, n. Loc -> NameContexts d n -> Term d n -> Error
parameters (defs : Definitions)
{auto _ : (Has ErrorEff fs, Has NameGen fs, Has Log fs)}
namespace TyContext
parameters (ctx : TyContext d n) (loc : Loc)
parameters (ctx : TyContext d n) (sg : SQty) (loc : Loc)
export covering
whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
tm d n -> Eff fs (NonRedex tm d n defs)
tm d n -> Eff fs (NonRedex tm d n defs (toWhnfContext ctx) sg)
whnf tm = do
let Val n = ctx.termLen; Val d = ctx.dimLen
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
rethrow res
private covering %macro
expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
TTImp -> TTImp -> Elab (Term d n -> Eff fs a)
expect k l r = do
f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
pure $ \t => maybe (throw $ k loc ctx.names t) pure . f . fst =<< whnf t
expect : ExpectErrorConstructor -> TTImp -> TTImp ->
Elab (Term d n -> Eff fs a)
expect err pat rhs = Prelude.do
match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
pure $ \term => do
res <- whnf term
maybe (throw $ err loc ctx.names term) pure $ match $ fst res
export covering %inline
expectTYPE : Term d n -> Eff fs Universe
@ -104,32 +112,40 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
export covering %inline
expectNat : Term d n -> Eff fs ()
expectNat = expect ExpectedNat `(Nat {}) `(())
expectNAT : Term d n -> Eff fs ()
expectNAT = expect ExpectedNAT `(NAT {}) `(())
export covering %inline
expectSTRING : Term d n -> Eff fs ()
expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
export covering %inline
expectBOX : Term d n -> Eff fs (Qty, Term d n)
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
export covering %inline
expectIOState : Term d n -> Eff fs ()
expectIOState = expect ExpectedIOState `(IOState {}) `(())
namespace EqContext
parameters (ctx : EqContext n) (loc : Loc)
parameters (ctx : EqContext n) (sg : SQty) (loc : Loc)
export covering
whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
tm 0 n -> Eff fs (NonRedex tm 0 n defs)
tm 0 n -> Eff fs (NonRedex tm 0 n defs (toWhnfContext ctx) sg)
whnf tm = do
let Val n = ctx.termLen
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) tm
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
rethrow res
private covering %macro
expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
TTImp -> TTImp -> Elab (Term 0 n -> Eff fs a)
expect k l r = do
f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
pure $ \t =>
let err = throw $ k loc ctx.names (t // shift0 ctx.dimLen) in
maybe err pure . f . fst =<< whnf t
expect : ExpectErrorConstructor -> TTImp -> TTImp ->
Elab (Term 0 n -> Eff fs a)
expect err pat rhs = do
match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
pure $ \term => do
res <- whnf term
let t0 = delay $ term // shift0 ctx.dimLen
maybe (throw $ err loc ctx.names t0) pure $ match $ fst res
export covering %inline
expectTYPE : Term 0 n -> Eff fs Universe
@ -152,9 +168,17 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
export covering %inline
expectNat : Term 0 n -> Eff fs ()
expectNat = expect ExpectedNat `(Nat {}) `(())
expectNAT : Term 0 n -> Eff fs ()
expectNAT = expect ExpectedNAT `(NAT {}) `(())
export covering %inline
expectSTRING : Term 0 n -> Eff fs ()
expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
export covering %inline
expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n)
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
export covering %inline
expectIOState : Term 0 n -> Eff fs ()
expectIOState = expect ExpectedIOState `(IOState {}) `(())

View file

@ -4,17 +4,51 @@ import Quox.Syntax
import Quox.Context
import Quox.Pretty
import public Data.Singleton
import Derive.Prelude
%default total
%language ElabReflection
public export
QContext : Nat -> Type
QContext = Context' Qty
public export
record LocalVar d n where
constructor MkLocal
type : Term d n
term : Maybe (Term d n) -- if from a `let`
%runElab deriveIndexed "LocalVar" [Show]
namespace LocalVar
export %inline
letVar : (type, term : Term d n) -> LocalVar d n
letVar type term = MkLocal {type, term = Just term}
export %inline
lamVar : (type : Term d n) -> LocalVar d n
lamVar type = MkLocal {type, term = Nothing}
export %inline
mapVar : (Term d n -> Term d' n') -> LocalVar d n -> LocalVar d' n'
mapVar f = {type $= f, term $= map f}
export %inline
subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n
subD th = mapVar (// th)
export %inline
weakD : LocalVar d n -> LocalVar (S d) n
weakD = subD $ shift 1
export %inline CanShift (LocalVar d) where l // by = mapVar (// by) l
export %inline CanDSubst LocalVar where l // by = mapVar (// by) l
export %inline CanTSubst LocalVar where l // by = mapVar (// by) l
public export
TContext : TermLike
TContext d = Context (Term d)
TContext d = Context (LocalVar d)
public export
QOutput : Nat -> Type
@ -31,11 +65,12 @@ record TyContext d n where
{auto dimLen : Singleton d}
{auto termLen : Singleton n}
dctx : DimEq d
dnames : BContext d
dnames : BContext d -- only used for printing
tctx : TContext d n
tnames : BContext n
tnames : BContext n -- only used for printing
qtys : QContext n -- only used for printing
%name TyContext ctx
%runElab deriveIndexed "TyContext" [Show]
public export
@ -46,29 +81,29 @@ record EqContext n where
dassign : DimAssign dimLen -- only used for printing
dnames : BContext dimLen -- only used for printing
tctx : TContext 0 n
tnames : BContext n
tnames : BContext n -- only used for printing
qtys : QContext n -- only used for printing
%name EqContext ctx
%runElab deriveIndexed "EqContext" [Show]
public export
record WhnfContext d n where
constructor MkWhnfContext
{auto dimLen : Singleton d}
{auto termLen : Singleton n}
dnames : BContext d
tnames : BContext n
tctx : TContext d n
%name WhnfContext ctx
%runElab deriveIndexed "WhnfContext" [Show]
namespace TContext
export %inline
pushD : TContext d n -> TContext (S d) n
pushD tel = map (// shift 1) tel
export %inline
zeroFor : Context tm n -> QOutput n
zeroFor ctx = Zero <$ ctx
private
public export
extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
extendLen [<] x = x
extendLen (tel :< _) x = [|S $ extendLen tel x|]
@ -78,32 +113,66 @@ public export
CtxExtension : Nat -> Nat -> Nat -> Type
CtxExtension d = Telescope ((Qty, BindName,) . Term d)
public export
CtxExtension0 : Nat -> Nat -> Nat -> Type
CtxExtension0 d = Telescope ((BindName,) . Term d)
public export
CtxExtensionLet : Nat -> Nat -> Nat -> Type
CtxExtensionLet d = Telescope ((Qty, BindName,) . LocalVar d)
public export
CtxExtensionLet0 : Nat -> Nat -> Nat -> Type
CtxExtensionLet0 d = Telescope ((BindName,) . LocalVar d)
namespace TyContext
public export %inline
empty : TyContext 0 0
empty =
MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}
empty = MkTyContext {
dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]
}
public export %inline
null : TyContext d n -> Bool
null ctx = null ctx.dnames && null ctx.tnames
export %inline
extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
let (qs, xs, ss) = unzip3 xss in
extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
let (qs, xs, ls) = unzip3 xss in
MkTyContext {
dctx, dnames,
termLen = extendLen xss termLen,
tctx = tctx . ss,
tctx = tctx . ls,
tnames = tnames . xs,
qtys = qtys . qs
}
export %inline
extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
export %inline
extendTyLetN0 : CtxExtensionLet0 d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
export %inline
extendTyN0 : CtxExtension0 d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyN0 xss = extendTyN (map (Zero,) xss)
export %inline
extendTyLet : Qty -> BindName -> Term d n -> Term d n ->
TyContext d n -> TyContext d (S n)
extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
export %inline
extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
extendTy q x s = extendTyN [< (q, x, s)]
export %inline
extendTy0 : BindName -> Term d n -> TyContext d n -> TyContext d (S n)
extendTy0 = extendTy Zero
export %inline
extendDim : BindName -> TyContext d n -> TyContext (S d) n
extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
@ -111,7 +180,7 @@ namespace TyContext
dctx = dctx :<? Nothing,
dnames = dnames :< x,
dimLen = [|S dimLen|],
tctx = pushD tctx,
tctx = map weakD tctx,
tnames, qtys
}
@ -150,7 +219,7 @@ makeEqContext' ctx th = MkEqContext {
termLen = ctx.termLen,
dassign = makeDAssign th,
dnames = ctx.dnames,
tctx = map (// th) ctx.tctx,
tctx = map (subD th) ctx.tctx,
tnames = ctx.tnames,
qtys = ctx.qtys
}
@ -158,7 +227,7 @@ makeEqContext' ctx th = MkEqContext {
export
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
makeEqContext ctx@(MkTyContext {dnames, _}) th =
let (d' ** Refl) = lengthPrf0 dnames in makeEqContext' ctx th
let Val d = lengthPrf0 dnames in makeEqContext' ctx th
namespace EqContext
public export %inline
@ -172,21 +241,42 @@ namespace EqContext
null ctx = null ctx.dnames && null ctx.tnames
export %inline
extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
let (qs, xs, ss) = unzip3 xss in
extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
let (qs, xs, ls) = unzip3 xss in
MkEqContext {
termLen = extendLen xss termLen,
tctx = tctx . ss,
tctx = tctx . ls,
tnames = tnames . xs,
qtys = qtys . qs,
dassign, dnames
}
export %inline
extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
export %inline
extendTyLetN0 : CtxExtensionLet0 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
export %inline
extendTyN0 : CtxExtension0 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyN0 xss = extendTyN (map (Zero,) xss)
export %inline
extendTyLet : Qty -> BindName -> Term 0 n -> Term 0 n ->
EqContext n -> EqContext (S n)
extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
export %inline
extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
extendTy q x s = extendTyN [< (q, x, s)]
export %inline
extendTy0 : BindName -> Term 0 n -> EqContext n -> EqContext (S n)
extendTy0 = extendTy Zero
export %inline
extendDim : BindName -> DimConst -> EqContext n -> EqContext n
extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) =
@ -197,8 +287,8 @@ namespace EqContext
toTyContext : (e : EqContext n) -> TyContext e.dimLen n
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
MkTyContext {
dctx = fromGround dassign,
tctx = map (// shift0 dimLen) tctx,
dctx = fromGround dnames dassign,
tctx = map (subD $ shift0 dimLen) tctx,
dnames, tnames, qtys
}
@ -207,18 +297,44 @@ namespace EqContext
toWhnfContext (MkEqContext {tnames, tctx, _}) =
MkWhnfContext {dnames = [<], tnames, tctx}
export
injElim : WhnfContext d n -> Elim 0 0 -> Elim d n
injElim ctx e =
let Val d = ctx.dimLen; Val n = ctx.termLen in
e // shift0 d // shift0 n
namespace WhnfContext
public export %inline
empty : WhnfContext 0 0
empty = MkWhnfContext [<] [<] [<]
export
extendTy' : BindName -> LocalVar d n -> WhnfContext d n -> WhnfContext d (S n)
extendTy' x var (MkWhnfContext {termLen, dnames, tnames, tctx}) =
MkWhnfContext {
dnames,
termLen = [|S termLen|],
tnames = tnames :< x,
tctx = tctx :< var
}
export %inline
extendTy : BindName -> Term d n -> WhnfContext d n -> WhnfContext d (S n)
extendTy x ty ctx = extendTy' x (lamVar ty) ctx
export %inline
extendTyLet : BindName -> (type, term : Term d n) ->
WhnfContext d n -> WhnfContext d (S n)
extendTyLet x type term ctx = extendTy' x (letVar {type, term}) ctx
export
extendDimN : {s : Nat} -> BContext s -> WhnfContext d n ->
WhnfContext (s + d) n
extendDimN ns (MkWhnfContext {dnames, tnames, tctx}) =
extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) =
MkWhnfContext {
dimLen = [|Val s + dimLen|],
dnames = dnames ++ toSnocVect' ns,
tctx = dweakT s <$> tctx,
tctx = map (subD $ shift s) tctx,
tnames
}
@ -230,14 +346,25 @@ namespace WhnfContext
private
prettyTContextElt : {opts : _} ->
BContext d -> BContext n ->
Qty -> BindName -> Term d n -> Eff Pretty (Doc opts)
prettyTContextElt dnames tnames q x s =
pure $ hsep [hcat [!(prettyQty q), !dotD, !(prettyTBind x)], !colonD,
!(withPrec Outer $ prettyTerm dnames tnames s)]
Doc opts -> BindName -> LocalVar d n ->
Eff Pretty (Doc opts)
prettyTContextElt dnames tnames q x s = do
dot <- dotD
x <- prettyTBind x; colon <- colonD
ty <- withPrec Outer $ prettyTerm dnames tnames s.type; eq <- cstD
tm <- traverse (withPrec Outer . prettyTerm dnames tnames) s.term
d <- askAt INDENT
let qx = hcat [q, dot, x]
pure $ case tm of
Nothing =>
ifMultiline (hsep [qx, colon, ty]) (vsep [qx, indent d $ colon <++> ty])
Just tm =>
ifMultiline (hsep [qx, colon, ty, eq, tm])
(vsep [qx, indent d $ colon <++> ty, indent d $ eq <++> tm])
private
prettyTContext' : {opts : _} ->
BContext d -> QContext n -> BContext n ->
BContext d -> Context' (Doc opts) n -> BContext n ->
TContext d n -> Eff Pretty (SnocList (Doc opts))
prettyTContext' _ [<] [<] [<] = pure [<]
prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
@ -248,8 +375,11 @@ export
prettyTContext : {opts : _} ->
BContext d -> QContext n -> BContext n ->
TContext d n -> Eff Pretty (Doc opts)
prettyTContext dnames qtys tnames tys =
separateTight !commaD <$> prettyTContext' dnames qtys tnames tys
prettyTContext dnames qtys tnames tys = do
comma <- commaD
qtys <- traverse prettyQty qtys
sepSingle . exceptLast (<+> comma) . toList <$>
prettyTContext' dnames qtys tnames tys
export
prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
@ -257,9 +387,16 @@ prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
case dctx of
C [<] => prettyTContext dnames qtys tnames tctx
_ => pure $
sep [!(prettyDimEq dnames dctx) <++> !pipeD,
sepSingle [!(prettyDimEq dnames dctx) <++> !pipeD,
!(prettyTContext dnames qtys tnames tctx)]
export
prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts)
prettyEqContext ctx = prettyTyContext $ toTyContext ctx
export
prettyWhnfContext : {opts : _} -> WhnfContext d n -> Eff Pretty (Doc opts)
prettyWhnfContext ctx =
let Val n = ctx.termLen in
sepSingle . exceptLast (<+> comma) . toList <$>
prettyTContext' ctx.dnames (replicate n "_") ctx.tnames ctx.tctx

View file

@ -2,12 +2,19 @@ module Quox.Typing.Error
import Quox.Loc
import Quox.Syntax
import Quox.Syntax.Builtin
import Quox.Typing.Context
import Quox.Typing.EqMode
import Quox.Pretty
import Data.List
import Control.Eff
import Derive.Prelude
%language ElabReflection
%hide TT.Name
%default total
public export
@ -15,6 +22,7 @@ record NameContexts d n where
constructor MkNameContexts
dnames : BContext d
tnames : BContext n
%runElab deriveIndexed "NameContexts" [Show]
namespace NameContexts
export
@ -60,8 +68,10 @@ data Error
| ExpectedSig Loc (NameContexts d n) (Term d n)
| ExpectedEnum Loc (NameContexts d n) (Term d n)
| ExpectedEq Loc (NameContexts d n) (Term d n)
| ExpectedNat Loc (NameContexts d n) (Term d n)
| ExpectedNAT Loc (NameContexts d n) (Term d n)
| ExpectedSTRING Loc (NameContexts d n) (Term d n)
| ExpectedBOX Loc (NameContexts d n) (Term d n)
| ExpectedIOState Loc (NameContexts d n) (Term d n)
| BadUniverse Loc Universe Universe
| TagNotIn Loc TagVal (SortedSet TagVal)
| BadCaseEnum Loc (SortedSet TagVal) (SortedSet TagVal)
@ -78,11 +88,14 @@ data Error
| NotType Loc (TyContext d n) (Term d n)
| WrongType Loc (EqContext n) (Term 0 n) (Term 0 n)
| WrongBuiltinType Builtin Error
| ExpectedSingleEnum Loc (NameContexts d n) (Term d n)
| MissingEnumArm Loc TagVal (List TagVal)
-- extra context
| WhileChecking
(TyContext d n) Qty
(TyContext d n) SQty
(Term d n) -- term
(Term d n) -- type
Error
@ -92,19 +105,20 @@ data Error
(Maybe Universe)
Error
| WhileInferring
(TyContext d n) Qty
(TyContext d n) SQty
(Elim d n)
Error
| WhileComparingT
(EqContext n) EqMode
(EqContext n) EqMode SQty
(Term 0 n) -- type
(Term 0 n) (Term 0 n) -- lhs/rhs
Error
| WhileComparingE
(EqContext n) EqMode
(EqContext n) EqMode SQty
(Elim 0 n) (Elim 0 n)
Error
%name Error err
%runElab derive "Error" [Show]
public export
ErrorEff : Type -> Type
@ -118,8 +132,10 @@ Located Error where
(ExpectedSig loc _ _).loc = loc
(ExpectedEnum loc _ _).loc = loc
(ExpectedEq loc _ _).loc = loc
(ExpectedNat loc _ _).loc = loc
(ExpectedNAT loc _ _).loc = loc
(ExpectedSTRING loc _ _).loc = loc
(ExpectedBOX loc _ _).loc = loc
(ExpectedIOState loc _ _).loc = loc
(BadUniverse loc _ _).loc = loc
(TagNotIn loc _ _).loc = loc
(BadCaseEnum loc _ _).loc = loc
@ -132,12 +148,14 @@ Located Error where
(NotInScope loc _).loc = loc
(NotType loc _ _).loc = loc
(WrongType loc _ _ _).loc = loc
(WrongBuiltinType _ err).loc = err.loc
(ExpectedSingleEnum loc _ _).loc = loc
(MissingEnumArm loc _ _).loc = loc
(WhileChecking _ _ _ _ err).loc = err.loc
(WhileCheckingTy _ _ _ err).loc = err.loc
(WhileInferring _ _ _ err).loc = err.loc
(WhileComparingT _ _ _ _ _ err).loc = err.loc
(WhileComparingE _ _ _ _ err).loc = err.loc
(WhileComparingT _ _ _ _ _ _ err).loc = err.loc
(WhileComparingE _ _ _ _ _ err).loc = err.loc
||| separates out all the error context layers
@ -150,10 +168,10 @@ explodeContext (WhileCheckingTy ctx s k err) =
mapFst (WhileCheckingTy ctx s k ::) $ explodeContext err
explodeContext (WhileInferring ctx x e err) =
mapFst (WhileInferring ctx x e ::) $ explodeContext err
explodeContext (WhileComparingT ctx x s t r err) =
mapFst (WhileComparingT ctx x s t r ::) $ explodeContext err
explodeContext (WhileComparingE ctx x e f err) =
mapFst (WhileComparingE ctx x e f ::) $ explodeContext err
explodeContext (WhileComparingT ctx x sg s t r err) =
mapFst (WhileComparingT ctx x sg s t r ::) $ explodeContext err
explodeContext (WhileComparingE ctx x sg e f err) =
mapFst (WhileComparingE ctx x sg e f ::) $ explodeContext err
explodeContext err = ([], err)
||| leaves the outermost context layer, and the innermost (up to) n, and removes
@ -240,10 +258,26 @@ where
hangDSingle "with quantities" $
separateTight !commaD $ toSnocList' !(traverse prettyQty qs)]
export
prettyErrorNoLoc : {opts : _} -> (showContext : Bool) -> Error ->
Eff Pretty (Doc opts)
prettyErrorNoLoc showContext = \case
parameters {opts : LayoutOpts} (showContext : Bool)
export
inContext' : Bool -> a -> (a -> Eff Pretty (Doc opts)) ->
Doc opts -> Eff Pretty (Doc opts)
inContext' null ctx f doc =
if showContext && not null then
vappend doc <$> hangDSingle "in context" !(f ctx)
else pure doc
export %inline
inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
inTContext ctx = inContext' (null ctx) ctx prettyTyContext
export %inline
inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
inEContext ctx = inContext' (null ctx) ctx prettyEqContext
export
prettyErrorNoLoc : Error -> Eff Pretty (Doc opts)
prettyErrorNoLoc err0 = case err0 of
ExpectedTYPE _ ctx s =>
hangDSingle "expected a type universe, but got"
!(prettyTerm ctx.dnames ctx.tnames s)
@ -261,19 +295,29 @@ prettyErrorNoLoc showContext = \case
!(prettyTerm ctx.dnames ctx.tnames s)
ExpectedEq _ ctx s =>
hangDSingle "expected an enumeration type, but got"
hangDSingle "expected an equality type, but got"
!(prettyTerm ctx.dnames ctx.tnames s)
ExpectedNat _ ctx s =>
ExpectedNAT _ ctx s =>
hangDSingle
("expected the type" <++>
!(prettyTerm [<] [<] $ Nat noLoc) <+> ", but got")
!(prettyTerm [<] [<] $ NAT noLoc) <+> ", but got")
!(prettyTerm ctx.dnames ctx.tnames s)
ExpectedSTRING _ ctx s =>
hangDSingle
("expected the type" <++>
!(prettyTerm [<] [<] $ STRING noLoc) <+> ", but got")
!(prettyTerm ctx.dnames ctx.tnames s)
ExpectedBOX _ ctx s =>
hangDSingle "expected a box type, but got"
!(prettyTerm ctx.dnames ctx.tnames s)
ExpectedIOState _ ctx s =>
hangDSingle "expected IOState, but got"
!(prettyTerm ctx.dnames ctx.tnames s)
BadUniverse _ k l => pure $
sep ["the universe level" <++> !(prettyUniverse k),
"is not strictly less than" <++> !(prettyUniverse l)]
@ -332,68 +376,68 @@ prettyErrorNoLoc showContext = \case
[hangDSingle "the term" !(prettyTerm [<] ctx.tnames s),
hangDSingle "cannot have type" !(prettyTerm [<] ctx.tnames ty)]
WrongBuiltinType b err => pure $
vappend
(sep [sep ["when checking", text $ builtinDesc b],
sep ["has type", !(builtinTypeDoc b)]])
!(prettyErrorNoLoc err)
ExpectedSingleEnum _ ctx s =>
hangDSingle "expected an enumeration type with one case, but got"
!(prettyTerm ctx.dnames ctx.tnames s)
MissingEnumArm _ tag tags => pure $
sep [hsep ["the tag", !(prettyTag tag), "is not contained in"],
!(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)]
WhileChecking ctx pi s a err =>
WhileChecking ctx sg s a err =>
[|vappendBlank
(inTContext ctx . sep =<< sequence
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s),
hangDSingle "has type" !(prettyTerm ctx.dnames ctx.tnames a),
hangDSingle "with quantity" !(prettyQty pi)])
(prettyErrorNoLoc showContext err)|]
hangDSingle "with quantity" !(prettyQty sg.qty)])
(prettyErrorNoLoc err)|]
WhileCheckingTy ctx a k err =>
[|vappendBlank
(inTContext ctx . sep =<< sequence
[hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a),
pure $ text $ isTypeInUniverse k])
(prettyErrorNoLoc showContext err)|]
(prettyErrorNoLoc err)|]
WhileInferring ctx pi e err =>
WhileInferring ctx sg e err =>
[|vappendBlank
(inTContext ctx . sep =<< sequence
[hangDSingle "while inferring the type of"
!(prettyElim ctx.dnames ctx.tnames e),
hangDSingle "with quantity" !(prettyQty pi)])
(prettyErrorNoLoc showContext err)|]
hangDSingle "with quantity" !(prettyQty sg.qty)])
(prettyErrorNoLoc err)|]
WhileComparingT ctx mode a s t err =>
WhileComparingT ctx mode sg a s t err =>
[|vappendBlank
(inEContext ctx . sep =<< sequence
[hangDSingle "while checking that" !(prettyTerm [<] ctx.tnames s),
hangDSingle (text "is \{prettyMode mode}")
!(prettyTerm [<] ctx.tnames t),
hangDSingle "at type" !(prettyTerm [<] ctx.tnames a)])
(prettyErrorNoLoc showContext err)|]
hangDSingle "at type" !(prettyTerm [<] ctx.tnames a),
hangDSingle "with quantity" !(prettyQty sg.qty)])
(prettyErrorNoLoc err)|]
WhileComparingE ctx mode e f err =>
WhileComparingE ctx mode sg e f err =>
[|vappendBlank
(inEContext ctx . sep =<< sequence
[hangDSingle "while checking that" !(prettyElim [<] ctx.tnames e),
hangDSingle (text "is \{prettyMode mode}")
!(prettyElim [<] ctx.tnames f)])
(prettyErrorNoLoc showContext err)|]
!(prettyElim [<] ctx.tnames f),
hangDSingle "with quantity" !(prettyQty sg.qty)])
(prettyErrorNoLoc err)|]
where
where
vappendBlank : Doc opts -> Doc opts -> Doc opts
vappendBlank a b = flush a `vappend` b
inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts)
inTContext ctx doc =
if showContext && not (null ctx) then
pure $ vappend doc (sep ["in context", !(prettyTyContext ctx)])
else pure doc
inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts)
inEContext ctx doc =
if showContext && not (null ctx) then
pure $ vappend doc (sep ["in context", !(prettyEqContext ctx)])
else pure doc
export
prettyError : {opts : _} -> (showContext : Bool) ->
Error -> Eff Pretty (Doc opts)
prettyError showContext err = sep <$> sequence
[prettyLoc err.loc, indentD =<< prettyErrorNoLoc showContext err]
export
prettyError : Error -> Eff Pretty (Doc opts)
prettyError err = hangDSingle
!(prettyLoc err.loc)
!(indentD =<< prettyErrorNoLoc err)

568
lib/Quox/Untyped/Erase.idr Normal file
View file

@ -0,0 +1,568 @@
module Quox.Untyped.Erase
import Quox.Definition as Q
import Quox.Pretty
import Quox.Syntax.Term.Base as Q
import Quox.Syntax.Term.Subst
import Quox.Typing
import Quox.Untyped.Syntax as U
import Quox.Whnf
import Quox.EffExtra
import Data.List1
import Data.Singleton
import Data.SnocVect
import Language.Reflection
%default total
%language ElabReflection
%hide TT.Name
%hide AppView.(.head)
public export
data IsErased = Erased | Kept
public export
isErased : Qty -> IsErased
isErased Zero = Erased
isErased One = Kept
isErased Any = Kept
public export
ErasureContext : Nat -> Nat -> Type
ErasureContext = TyContext
public export
TypeError : Type
TypeError = Typing.Error.Error
%hide Typing.Error.Error
public export
data Error =
CompileTimeOnly (ErasureContext d n) (Q.Term d n)
| WrapTypeError TypeError
| Postulate Loc Name
| WhileErasing Name Q.Definition Error
| MainIsErased Loc Name
%name Error err
private %inline
notInScope : Loc -> Name -> Error
notInScope = WrapTypeError .: NotInScope
export
Located Error where
(CompileTimeOnly _ s).loc = s.loc
(WrapTypeError err).loc = err.loc
(Postulate loc _).loc = loc
(WhileErasing _ def e).loc = e.loc `or` def.loc
(MainIsErased loc _).loc = loc
parameters {opts : LayoutOpts} (showContext : Bool)
export
prettyErrorNoLoc : Error -> Eff Pretty (Doc opts)
prettyErrorNoLoc (CompileTimeOnly ctx s) =
inTContext showContext ctx $
sep ["the term", !(prettyTerm ctx.dnames ctx.tnames s),
"only exists at compile time"]
prettyErrorNoLoc (WrapTypeError err) =
prettyErrorNoLoc showContext err
prettyErrorNoLoc (Postulate _ x) =
pure $ sep [!(prettyFree x), "is a postulate with no definition"]
prettyErrorNoLoc (WhileErasing x def err) = pure $
vsep [hsep ["while erasing the definition", !(prettyFree x)],
!(prettyErrorNoLoc err)]
prettyErrorNoLoc (MainIsErased _ x) =
pure $ hsep [!(prettyFree x), "is marked #[main] but is erased"]
export
prettyError : Error -> Eff Pretty (Doc opts)
prettyError err = sep <$> sequence
[prettyLoc err.loc, indentD =<< prettyErrorNoLoc err]
public export
Erase : List (Type -> Type)
Erase = [Except Error, NameGen, Log]
export
liftWhnf : Eff Whnf a -> Eff Erase a
liftWhnf act = lift $ wrapErr WrapTypeError act
export covering
computeElimType : Q.Definitions -> ErasureContext d n -> SQty ->
Elim d n -> Eff Erase (Term d n)
computeElimType defs ctx sg e = do
let ctx = toWhnfContext ctx
liftWhnf $ do
Element e _ <- whnf defs ctx sg e
computeElimType defs ctx sg e
private %macro
wrapExpect : TTImp ->
Elab (Q.Definitions -> TyContext d n -> Loc ->
Term d n -> Eff Erase a)
wrapExpect f_ = do
f <- check `(\x => ~(f_) x)
pure $ \defs, ctx, loc, s => liftWhnf $ f defs ctx SZero loc s
public export
record EraseElimResult d n where
constructor EraRes
type : Lazy (Q.Term d n)
term : U.Term n
export covering
eraseTerm' : (defs : Q.Definitions) -> (ctx : ErasureContext d n) ->
(ty, tm : Q.Term d n) ->
(0 _ : NotRedex defs (toWhnfContext ctx) SZero ty) =>
Eff Erase (U.Term n)
-- "Ψ | Γ | Σ ⊢ s ⤋ s' ⇐ A" for `s' <- eraseTerm (Ψ,Γ,Σ) A s`
--
-- in the below comments, Ψ, Γ, Σ are implicit and
-- only their extensions are written
export covering
eraseTerm : Q.Definitions -> ErasureContext d n ->
(ty, tm : Q.Term d n) -> Eff Erase (U.Term n)
eraseTerm defs ctx ty tm = do
Element ty _ <- liftWhnf $ Interface.whnf defs (toWhnfContext ctx) SZero ty
eraseTerm' defs ctx ty tm
-- "Ψ | Γ | Σ ⊢ e ⤋ e' ⇒ A" for `EraRes A e' <- eraseElim (Ψ,Γ,Σ) e`
export covering
eraseElim : Q.Definitions -> ErasureContext d n -> (tm : Q.Elim d n) ->
Eff Erase (EraseElimResult d n)
eraseTerm' defs ctx _ s@(TYPE {}) =
throw $ CompileTimeOnly ctx s
eraseTerm' defs ctx _ s@(IOState {}) =
throw $ CompileTimeOnly ctx s
eraseTerm' defs ctx _ s@(Pi {}) =
throw $ CompileTimeOnly ctx s
-- x : A | 0.x ⊢ s ⤋ s' ⇐ B
-- -------------------------------------
-- (λ x ⇒ s) ⤋ s'[⌷/x] ⇐ 0.(x : A) → B
--
-- x : A | π.x ⊢ s ⤋ s' ⇐ B π ≠ 0
-- ----------------------------------------
-- (λ x ⇒ s) ⤋ (λ x ⇒ s') ⇐ π.(x : A) → B
eraseTerm' defs ctx ty (Lam body loc) = do
let x = body.name
(qty, arg, res) <- wrapExpect `(expectPi) defs ctx loc ty
body <- eraseTerm defs (extendTy qty x arg ctx) res.term body.term
pure $ case isErased qty of
Kept => U.Lam x body loc
Erased => sub1 (Erased loc) body
eraseTerm' defs ctx _ s@(Sig {}) =
throw $ CompileTimeOnly ctx s
-- s ⤋ s' ⇐ A t ⤋ t' ⇐ B[s/x]
-- ---------------------------------
-- (s, t) ⤋ (s', t') ⇐ (x : A) × B
eraseTerm' defs ctx ty (Pair fst snd loc) = do
(a, b) <- wrapExpect `(expectSig) defs ctx loc ty
let b = sub1 b (Ann fst a a.loc)
fst <- eraseTerm defs ctx a fst
snd <- eraseTerm defs ctx b snd
pure $ Pair fst snd loc
eraseTerm' defs ctx _ s@(Enum {}) =
throw $ CompileTimeOnly ctx s
-- '𝐚 ⤋ '𝐚 ⇐ {⋯}
eraseTerm' defs ctx _ (Tag tag loc) =
pure $ Tag tag loc
eraseTerm' defs ctx ty s@(Eq {}) =
throw $ CompileTimeOnly ctx s
-- 𝑖 ⊢ s ⤋ s' ⇐ A
-- ---------------------------------
-- (δ 𝑖 ⇒ s) ⤋ s' ⇐ Eq (𝑖 ⇒ A) l r
eraseTerm' defs ctx ty (DLam body loc) = do
a <- fst <$> wrapExpect `(expectEq) defs ctx loc ty
eraseTerm defs (extendDim body.name ctx) a.term body.term
eraseTerm' defs ctx _ s@(NAT {}) =
throw $ CompileTimeOnly ctx s
-- n ⤋ n ⇐
eraseTerm' _ _ _ (Nat n loc) =
pure $ Nat n loc
-- s ⤋ s' ⇐
-- -----------------------
-- succ s ⤋ succ s' ⇐
eraseTerm' defs ctx ty (Succ p loc) = do
p <- eraseTerm defs ctx ty p
pure $ Succ p loc
eraseTerm' defs ctx ty s@(STRING {}) =
throw $ CompileTimeOnly ctx s
-- s ⤋ s ⇐ String
eraseTerm' _ _ _ (Str s loc) =
pure $ Str s loc
eraseTerm' defs ctx ty s@(BOX {}) =
throw $ CompileTimeOnly ctx s
-- [s] ⤋ ⌷ ⇐ [0.A]
--
-- π ≠ 0 s ⤋ s' ⇐ A
-- --------------------
-- [s] ⤋ s' ⇐ [π.A]
eraseTerm' defs ctx ty (Box val loc) = do
(qty, a) <- wrapExpect `(expectBOX) defs ctx loc ty
case isErased qty of
Erased => pure $ Erased loc
Kept => eraseTerm defs ctx a val
-- s ⤋ s' ⇐ A
-- ---------------------------------
-- let0 x = e in s ⤋ s'[⌷/x] ⇐ A
--
-- e ⤋ e' ⇒ E π ≠ 0
-- x : E ≔ e ⊢ s ⤋ s' ⇐ A
-- -------------------------------------
-- letπ x = e in s ⤋ let x = e' in s'
eraseTerm' defs ctx ty (Let pi e s loc) = do
let x = s.name
case isErased pi of
Erased => do
ety <- computeElimType defs ctx SZero e
s' <- eraseTerm defs (extendTyLet pi x ety (E e) ctx) (weakT 1 ty) s.term
pure $ sub1 (Erased e.loc) s'
Kept => do
EraRes ety e' <- eraseElim defs ctx e
s' <- eraseTerm defs (extendTyLet pi x ety (E e) ctx) (weakT 1 ty) s.term
pure $ Let True x e' s' loc
-- e ⤋ e' ⇒ B
-- ------------
-- e ⤋ e' ⇐ A
eraseTerm' defs ctx ty (E e) =
term <$> eraseElim defs ctx e
eraseTerm' defs ctx ty (CloT (Sub term th)) =
eraseTerm defs ctx ty $ pushSubstsWith' id th term
eraseTerm' defs ctx ty (DCloT (Sub term th)) =
eraseTerm defs ctx ty $ pushSubstsWith' th id term
-- defω x : A = s
-- ----------------
-- x ⤋ x ⇒ A
eraseElim defs ctx e@(F x u loc) = do
let Just def = lookup x defs
| Nothing => throw $ notInScope loc x
case isErased def.qty.qty of
Erased => throw $ CompileTimeOnly ctx $ E e
Kept => pure $ EraRes (def.typeWith ctx.dimLen ctx.termLen) $ F x loc
-- π.x ∈ Σ π ≠ 0
-- -----------------
-- x ⤋ x ⇒ A
eraseElim defs ctx e@(B i loc) = do
case isErased $ ctx.qtys !!! i of
Erased => throw $ CompileTimeOnly ctx $ E e
Kept => pure $ EraRes (ctx.tctx !! i).type $ B i loc
-- f ⤋ f' ⇒ π.(x : A) → B s ⤋ s' ⇒ A π ≠ 0
-- ---------------------------------------------
-- f s ⤋ f' s' ⇒ B[s/x]
--
-- f ⤋ f' ⇒ 0.(x : A) → B
-- -------------------------
-- f s ⤋ f' ⇒ B[s/x]
eraseElim defs ctx (App fun arg loc) = do
efun <- eraseElim defs ctx fun
(qty, targ, tres) <- wrapExpect `(expectPi) defs ctx loc efun.type
let ty = sub1 tres (Ann arg targ arg.loc)
case isErased qty of
Erased => pure $ EraRes ty efun.term
Kept => do arg <- eraseTerm defs ctx targ arg
pure $ EraRes ty $ App efun.term arg loc
-- e ⇒ (x : A) × B
-- x : A, y : B | ρ.x, ρ.y ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z]
-- -------------------------------------------------------------------
-- (case0 e return z ⇒ R of {(x, y) ⇒ s}) ⤋ s'[⌷/x, ⌷/y] ⇒ R[e/z]
--
-- e ⤋ e' ⇒ (x : A) × B ρ ≠ 0
-- x : A, y : B | ρ.x, ρ.y ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z]
-- ----------------------------------------------------------------------------
-- (caseρ e return z ⇒ R of {(x, y) ⇒ s}) ⤋
-- ⤋
-- let xy = e' in let x = fst xy in let y = snd xy in s' ⇒ R[e/z]
eraseElim defs ctx (CasePair qty pair ret body loc) = do
let [< x, y] = body.names
case isErased qty of
Kept => do
EraRes ety eterm <- eraseElim defs ctx pair
let ty = sub1 (ret // shift 2) $
Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 ety) loc
(tfst, tsnd) <- wrapExpect `(expectSig) defs ctx loc ety
let ctx' = extendTyN [< (qty, x, tfst), (qty, y, tsnd.term)] ctx
body' <- eraseTerm defs ctx' ty body.term
p <- mnb "p" loc
pure $ EraRes (sub1 ret pair) $
Let False p eterm
(Let False x (Fst (B VZ loc) loc)
(Let False y (Snd (B (VS VZ) loc) loc)
(body' // (B VZ loc ::: B (VS VZ) loc ::: shift 3))
loc) loc) loc
Erased => do
ety <- computeElimType defs ctx SOne pair
let ty = sub1 (ret // shift 2) $
Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 ety) loc
(tfst, tsnd) <- wrapExpect `(expectSig) defs ctx loc ety
let ctx' = extendTyN0 [< (x, tfst), (y, tsnd.term)] ctx
body' <- eraseTerm defs ctx' ty body.term
pure $ EraRes (sub1 ret pair) $ subN [< Erased loc, Erased loc] body'
-- e ⤋ e' ⇒ (x : A) × B
-- ----------------------
-- fst e ⤋ fst e' ⇒ A
eraseElim defs ctx (Fst pair loc) = do
epair <- eraseElim defs ctx pair
a <- fst <$> wrapExpect `(expectSig) defs ctx loc epair.type
pure $ EraRes a $ Fst epair.term loc
-- e ⤋ e' ⇒ (x : A) × B
-- -----------------------------
-- snd e ⤋ snd e' ⇒ B[fst e/x]
eraseElim defs ctx (Snd pair loc) = do
epair <- eraseElim defs ctx pair
b <- snd <$> wrapExpect `(expectSig) defs ctx loc epair.type
pure $ EraRes (sub1 b (Fst pair loc)) $ Snd epair.term loc
-- caseρ e return z ⇒ R of {} ⤋ absurd ⇒ R[e/z]
--
-- s ⤋ s' ⇐ R[𝐚∷{𝐚}/z]
-- -----------------------------------------------
-- case0 e return z ⇒ R of {𝐚 ⇒ s} ⤋ s' ⇒ R[e/z]
--
-- e ⤋ e' ⇒ A sᵢ ⤋ s'ᵢ ⇐ R[𝐚ᵢ/z] ρ ≠ 0 i ≠ 0
-- -------------------------------------------------------------------
-- caseρ e return z ⇒ R of {𝐚ᵢ ⇒ sᵢ} ⤋ case e of {𝐚ᵢ ⇒ s'ᵢ} ⇒ R[e/z]
eraseElim defs ctx e@(CaseEnum qty tag ret arms loc) = do
let ty = sub1 ret tag
case isErased qty of
Erased => case SortedMap.toList arms of
[] => pure $ EraRes ty $ Absurd loc
[(t, rhs)] => do
let ty' = sub1 ret (Ann (Tag t loc) (enum [t] loc) loc)
rhs' <- eraseTerm defs ctx ty' rhs
pure $ EraRes ty rhs'
_ => throw $ CompileTimeOnly ctx $ E e
Kept => case List1.fromList $ SortedMap.toList arms of
Nothing => pure $ EraRes ty $ Absurd loc
Just arms => do
etag <- eraseElim defs ctx tag
arms <- for arms $ \(t, rhs) => do
let ty' = sub1 ret (Ann (Tag t loc) etag.type loc)
rhs' <- eraseTerm defs ctx ty' rhs
pure (t, rhs')
pure $ EraRes ty $ CaseEnum etag.term arms loc
-- n ⤋ n' ⇒ z ⤋ z' ⇐ R[zero∷/z] ς ≠ 0
-- m : , ih : R[m/z] | ρ.m, ς.ih ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z]
-- -----------------------------------------------------------
-- caseρ n return z ⇒ R of {0 ⇒ z; succ m, ς.ih ⇒ s}
-- ⤋
-- case n' of {0 ⇒ z'; succ m, ih ⇒ s'} ⇒ R[n/z]
--
-- n ⤋ n' ⇒ z ⤋ z' ⇐ R[zero∷/z]
-- m : , ih : R[m/z] | ρ.m, 0.ih ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z]
-- -----------------------------------------------------------
-- caseρ n return z ⇒ R of {0 ⇒ z; succ m, 0.ih ⇒ s}
-- ⤋
-- case n' of {0 ⇒ z'; succ m ⇒ s'[⌷/ih]} ⇒ R[n/z]
eraseElim defs ctx (CaseNat qty qtyIH nat ret zero succ loc) = do
let ty = sub1 ret nat
enat <- eraseElim defs ctx nat
zero <- eraseTerm defs ctx (sub1 ret (Ann (Zero loc) (NAT loc) loc)) zero
let [< p, ih] = succ.names
succ' <- eraseTerm defs
(extendTyN [< (qty, p, NAT loc),
(qtyIH, ih, sub1 (ret // shift 1) (BV 0 loc))] ctx)
(sub1 (ret // shift 2) (Ann (Succ (BVT 1 loc) loc) (NAT loc) loc))
succ.term
let succ = case isErased qtyIH of
Kept => NSRec p ih succ'
Erased => NSNonrec p (sub1 (Erased loc) succ')
pure $ EraRes ty $ CaseNat enat.term zero succ loc
-- b ⤋ b' ⇒ [π.A] πρ ≠ 0 x : A | πρ.x ⊢ s ⤋ s' ⇐ R[[x]∷[π.A]/z]
-- ------------------------------------------------------------------
-- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ let x = b' in s' ⇒ R[b/z]
--
-- b ⇒ [π.A] x : A | 0.x ⊢ s ⤋ s' ⇐ R[[x]∷[0.A]/z] πρ = 0
-- -------------------------------------------------------------
-- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[⌷/x] ⇒ R[b/z]
eraseElim defs ctx (CaseBox qty box ret body loc) = do
tbox <- computeElimType defs ctx SOne box
(pi, tinner) <- wrapExpect `(expectBOX) defs ctx loc tbox
let ctx' = extendTy (pi * qty) body.name tinner ctx
bty = sub1 (ret // shift 1) $
Ann (Box (BVT 0 loc) loc) (weakT 1 tbox) loc
case isErased $ qty * pi of
Kept => do
ebox <- eraseElim defs ctx box
ebody <- eraseTerm defs ctx' bty body.term
pure $ EraRes (sub1 ret box) $ Let False body.name ebox.term ebody loc
Erased => do
body' <- eraseTerm defs ctx' bty body.term
pure $ EraRes (sub1 ret box) $ body' // one (Erased loc)
-- f ⤋ f' ⇒ Eq (𝑖 ⇒ A) l r
-- ------------------------------
-- f @r ⤋ f' ⇒ Ar/𝑖
eraseElim defs ctx (DApp fun arg loc) = do
efun <- eraseElim defs ctx fun
a <- fst <$> wrapExpect `(expectEq) defs ctx loc efun.type
pure $ EraRes (dsub1 a arg) efun.term
-- s ⤋ s' ⇐ A
-- ----------------
-- s ∷ A ⤋ s' ⇒ A
eraseElim defs ctx (Ann tm ty loc) =
EraRes ty <$> eraseTerm defs ctx ty tm
-- s ⤋ s' ⇐ Ap/𝑖
-- -----------------------------------
-- coe (𝑖 ⇒ A) @p @q s ⤋ s' ⇒ Aq/𝑖
eraseElim defs ctx (Coe ty p q val loc) = do
val <- eraseTerm defs ctx (dsub1 ty p) val
pure $ EraRes (dsub1 ty q) val
-- s ⤋ s' ⇐ A
-- --------------------------------
-- comp A @p @q s @r {⋯} ⤋ s' ⇒ A
eraseElim defs ctx (Comp ty p q val r zero one loc) =
EraRes ty <$> eraseTerm defs ctx ty val
eraseElim defs ctx t@(TypeCase ty ret arms def loc) =
throw $ CompileTimeOnly ctx $ E t
eraseElim defs ctx (CloE (Sub term th)) =
eraseElim defs ctx $ pushSubstsWith' id th term
eraseElim defs ctx (DCloE (Sub term th)) =
eraseElim defs ctx $ pushSubstsWith' th id term
export
uses : Var n -> Term n -> Nat
uses i (F {}) = 0
uses i (B j _) = if i == j then 1 else 0
uses i (Lam x body _) = uses (VS i) body
uses i (App fun arg _) = uses i fun + uses i arg
uses i (Pair fst snd _) = uses i fst + uses i snd
uses i (Fst pair _) = uses i pair
uses i (Snd pair _) = uses i pair
uses i (Tag tag _) = 0
uses i (CaseEnum tag cases _) =
uses i tag + foldl max 0 (map (assert_total uses i . snd) cases)
uses i (Absurd {}) = 0
uses i (Nat {}) = 0
uses i (Succ nat _) = uses i nat
uses i (CaseNat nat zer suc _) = uses i nat + max (uses i zer) (uses' suc)
where uses' : CaseNatSuc n -> Nat
uses' (NSRec _ _ s) = uses (VS (VS i)) s
uses' (NSNonrec _ s) = uses (VS i) s
uses i (Str {}) = 0
uses i (Let _ x rhs body _) = uses i rhs + uses (VS i) body
uses i (Erased {}) = 0
export
inlineable : U.Term n -> Bool
inlineable (F {}) = True
inlineable (B {}) = True
inlineable (Tag {}) = True
inlineable (Nat {}) = True
inlineable (Str {}) = True
inlineable (Absurd {}) = True
inlineable (Erased {}) = True
inlineable _ = False
export
droppable : U.Term n -> Bool
droppable (F {}) = True
droppable (B {}) = True
droppable (Fst e _) = droppable e
droppable (Snd e _) = droppable e
droppable (Tag {}) = True
droppable (Nat {}) = True
droppable (Str {}) = True
droppable (Absurd {}) = True
droppable (Erased {}) = True
droppable _ = False
export
trimLets : U.Term n -> U.Term n
trimLets (F x loc) = F x loc
trimLets (B i loc) = B i loc
trimLets (Lam x body loc) = Lam x (trimLets body) loc
trimLets (App fun arg loc) = App (trimLets fun) (trimLets arg) loc
trimLets (Pair fst snd loc) = Pair (trimLets fst) (trimLets snd) loc
trimLets (Fst pair loc) = Fst (trimLets pair) loc
trimLets (Snd pair loc) = Snd (trimLets pair) loc
trimLets (Tag tag loc) = Tag tag loc
trimLets (CaseEnum tag cases loc) =
let tag = trimLets tag
cases = map (map $ \c => trimLets $ assert_smaller cases c) cases in
if droppable tag && length cases == 1
then snd cases.head
else CaseEnum tag cases loc
trimLets (Absurd loc) = Absurd loc
trimLets (Nat n loc) = Nat n loc
trimLets (Succ nat loc) = Succ (trimLets nat) loc
trimLets (CaseNat nat zer suc loc) =
CaseNat (trimLets nat) (trimLets zer) (trimLets' suc) loc
where trimLets' : CaseNatSuc n -> CaseNatSuc n
trimLets' (NSRec x ih s) = NSRec x ih $ trimLets s
trimLets' (NSNonrec x s) = NSNonrec x $ trimLets s
trimLets (Str s loc) = Str s loc
trimLets (Let True x rhs body loc) =
Let True x (trimLets rhs) (trimLets body) loc
trimLets (Let False x rhs body loc) =
let rhs' = trimLets rhs
body' = trimLets body
uses = uses VZ body in
if inlineable rhs' || uses == 1 || (droppable rhs' && uses == 0)
then sub1 rhs' body'
else Let False x rhs' body' loc
trimLets (Erased loc) = Erased loc
export covering
eraseDef : Q.Definitions -> Name -> Q.Definition -> Eff Erase U.Definition
eraseDef defs name def@(MkDef qty type body scheme isMain loc) =
wrapErr (WhileErasing name def) $
case isErased qty.qty of
Erased => do
when isMain $ throw $ MainIsErased loc name
pure ErasedDef
Kept =>
case scheme of
Just str => pure $ SchemeDef isMain str
Nothing => case body of
Postulate => throw $ Postulate loc name
Concrete body => KeptDef isMain . trimLets <$>
eraseTerm defs empty type body

378
lib/Quox/Untyped/Scheme.idr Normal file
View file

@ -0,0 +1,378 @@
module Quox.Untyped.Scheme
import Quox.Name
import Quox.Context
import Quox.Untyped.Syntax
import Quox.Pretty
import Quox.EffExtra
import Quox.CharExtra
import Quox.NatExtra
import Data.DPair
import Data.List1
import Data.String
import Data.SortedSet
import Data.Vect
import Derive.Prelude
%default total
%language ElabReflection
%hide TT.Name
export
isSchemeInitial : Char -> Bool
isSchemeInitial c =
let gc = genCat c in
isLetter gc || isSymbol gc && c /= '|' ||
gc == Number Letter ||
gc == Number Other ||
gc == Mark NonSpacing ||
gc == Punctuation Dash ||
gc == Punctuation Connector ||
gc == Punctuation Other && c /= '\'' && c /= '\\' ||
gc == Other PrivateUse ||
(c `elem` unpack "!$%&*/:<=>?~_^")
export
isSchemeSubsequent : Char -> Bool
isSchemeSubsequent c =
let gc = genCat c in
isSchemeInitial c ||
isNumber gc ||
isMark gc ||
(c `elem` unpack ".+-@")
export
isSchemeId : String -> Bool
isSchemeId str =
str == "1+" || str == "1-" ||
case unpack str of
[] => False
c :: cs => isSchemeInitial c && all isSchemeSubsequent cs
export
escId : String -> String
escId str =
let str' = concatMap doEsc $ unpack str in
if isSchemeId str' then str' else "|\{str}|"
where
doEsc : Char -> String
doEsc '\\' = "\\\\"
doEsc '|' = "\\|"
doEsc '\'' = "^"
doEsc c = singleton c
public export
data Id = I String Nat
%runElab derive "Id" [Eq, Ord]
export
prettyId' : {opts : LayoutOpts} -> Id -> Doc opts
prettyId' (I str 0) = text $ escId str
prettyId' (I str k) = text $ escId "\{str}:\{show k}"
export
prettyId : {opts : LayoutOpts} -> Id -> Eff Pretty (Doc opts)
prettyId x = hl TVar $ prettyId' x
public export
data StateTag = AVOID | MAIN
public export
Scheme : List (Type -> Type)
Scheme = [StateL AVOID (SortedSet Id), StateL MAIN (List Id)]
-- names to avoid, and functions with #[main] (should only be one)
public export
data Sexp =
V Id
| L (List Sexp)
| Q Sexp
| N Nat
| S String
| Lambda (List Id) Sexp
| LambdaC (List Id) Sexp -- curried lambda
| Let Id Sexp Sexp
| Case Sexp (List1 (List Sexp, Sexp))
| Define Id Sexp
| Literal String
export
FromString Sexp where fromString s = V $ I s 0
private
makeIdBase : Mods -> String -> String
makeIdBase mods str = joinBy "." $ toList $ mods :< str
export
makeId : Name -> Id
makeId (MkName mods (UN str)) = I (makeIdBase mods str) 0
makeId (MkName mods (MN str k)) = I (makeIdBase mods str) 0
makeId (MkName mods Unused) = I (makeIdBase mods "_") 0
export
makeIdB : BindName -> Id
makeIdB (BN name _) = makeId $ MkName [<] name
private
bump : Id -> Id
bump (I x i) = I x (S i)
export covering
getFresh : SortedSet Id -> Id -> Id
getFresh used x =
if contains x used then getFresh used (bump x) else x
export covering
freshIn : Id -> (Id -> Eff Scheme a) -> Eff Scheme a
freshIn x k =
let x = getFresh !(getAt AVOID) x in
localAt AVOID (insert x) $ k x
export covering
freshInB : BindName -> (Id -> Eff Scheme a) -> Eff Scheme a
freshInB x = freshIn (makeIdB x)
export covering
freshInBT : Telescope' BindName m n ->
(Telescope' Id m n -> Eff Scheme a) ->
Eff Scheme a
freshInBT xs act = do
let (xs', used') = go (map makeIdB xs) !(getAt AVOID)
localAt_ AVOID used' $ act xs'
where
go : forall n. Telescope' Id m n ->
SortedSet Id -> (Telescope' Id m n, SortedSet Id)
go [<] used = ([<], used)
go (xs :< x) used =
let x = getFresh used x
(xs, used) = go xs (insert x used)
in
(xs :< x, used)
export covering
freshInBC : Context' BindName n -> (Context' Id n -> Eff Scheme a) ->
Eff Scheme a
freshInBC = freshInBT
export covering
toScheme : Context' Id n -> Term n -> Eff Scheme Sexp
toScheme xs (F x _) = pure $ V $ makeId x
toScheme xs (B i _) = pure $ V $ xs !!! i
toScheme xs (Lam x body _) =
let Evidence n' (ys, body) = splitLam [< x] body in
freshInBT ys $ \ys => do
pure $ LambdaC (toList' ys) !(toScheme (xs . ys) body)
toScheme xs (App fun arg _) = do
let (fun, args) = splitApp fun
fun <- toScheme xs fun
args <- traverse (toScheme xs) args
arg <- toScheme xs arg
pure $ if null args
then L [fun, arg]
else L $ "%" :: fun :: toList (args :< arg)
toScheme xs (Pair fst snd _) =
pure $ L ["cons", !(toScheme xs fst), !(toScheme xs snd)]
toScheme xs (Fst pair _) =
pure $ L ["car", !(toScheme xs pair)]
toScheme xs (Snd pair _) =
pure $ L ["cdr", !(toScheme xs pair)]
toScheme xs (Tag tag _) =
pure $ Q $ fromString tag
toScheme xs (CaseEnum tag cases _) =
Case <$> toScheme xs tag
<*> for cases (\(t, rhs) => ([fromString t],) <$> toScheme xs rhs)
toScheme xs (Absurd _) =
pure $ Q "absurd"
toScheme xs (Nat n _) =
pure $ N n
toScheme xs (Succ nat _) =
pure $ L ["+", !(toScheme xs nat), N 1]
toScheme xs (CaseNat nat zer (NSRec p ih suc) _) =
freshInBC [< p, ih] $ \[< p, ih] =>
pure $
L ["case-nat-rec",
Lambda [] !(toScheme xs zer),
Lambda [p, ih] !(toScheme (xs :< p :< ih) suc),
!(toScheme xs nat)]
toScheme xs (Str s _) = pure $ S s
toScheme xs (CaseNat nat zer (NSNonrec p suc) _) =
freshInB p $ \p =>
pure $
L ["case-nat-nonrec",
Lambda [] !(toScheme xs zer),
Lambda [p] !(toScheme (xs :< p) suc),
!(toScheme xs nat)]
toScheme xs (Let _ x rhs body _) =
freshInB x $ \x =>
pure $ Let x !(toScheme xs rhs) !(toScheme (xs :< x) body)
toScheme xs (Erased _) =
pure $ Q "erased"
export
prelude : String
prelude = """
#!r6rs
(import (rnrs))
; curried lambda
(define-syntax lambda%
(syntax-rules ()
[(_ (x . xs) . body) (lambda (x) (lambda% xs . body))]
[(_ () . body) (begin . body)]))
; curried application
(define-syntax %
(syntax-rules ()
[(_ e0 e1 . es) (% (e0 e1) . es)]
[(_ e) e]))
; curried function definition
(define-syntax define%
(syntax-rules ()
[(_ (f . xs) . body) (define f (lambda% xs . body))]
[(_ f . body) (define f . body)]))
(define-syntax builtin-io
(syntax-rules ()
[(_ . body) (lambda (s) (cons (begin . body) s))]))
(define (case-nat-rec z s n)
(do [(i 0 (+ i 1)) (acc (z) (s i acc))]
[(= i n) acc]))
(define (case-nat-nonrec z s n)
(if (= n 0) (z) (s (- n 1))))
(define (run-main f) (f 'io-state))
"""
export
escape : String -> String
escape = foldMap esc1 . unpack where
esc1 : Char -> String
esc1 c =
if c == '\\' || c == '"' then
"\\" ++ singleton c
else if c < ' ' || c > '~' then
"\\x" ++ showHex (ord c) ++ ";"
else singleton c
export covering
defToScheme : Name -> Definition -> Eff Scheme (Maybe Sexp)
defToScheme x ErasedDef = pure Nothing
defToScheme x (KeptDef isMain def) = do
let x = makeId x
when isMain $ modifyAt MAIN (x ::)
modifyAt AVOID $ insert x
pure $ Just $ Define x !(toScheme [<] def)
defToScheme x (SchemeDef isMain str) = do
let x = makeId x
when isMain $ modifyAt MAIN (x ::)
modifyAt AVOID $ insert x
pure $ Just $ Define x $ Literal str
orIndent : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
orIndent a b = do
one <- parens $ a <++> b
two <- parens $ a `vappend` indent 2 b
pure $ ifMultiline one two
export covering
prettySexp : {opts : LayoutOpts} -> Sexp -> Eff Pretty (Doc opts)
private covering
prettyLambda : {opts : LayoutOpts} ->
String -> List Id -> Sexp -> Eff Pretty (Doc opts)
prettyLambda lam xs e =
orIndent
(hsep [!(hl Syntax $ text lam), !(prettySexp $ L $ map V xs)])
!(prettySexp e)
private covering
prettyBind : {opts : LayoutOpts} -> (Id, Sexp) -> Eff Pretty (Doc opts)
prettyBind (x, e) = parens $ sep [!(prettyId x), !(prettySexp e)]
private covering
prettyLet : {opts : LayoutOpts} ->
SnocList (Id, Sexp) -> Sexp -> Eff Pretty (Doc opts)
prettyLet ps (Let x rhs body) = prettyLet (ps :< (x, rhs)) body
prettyLet ps e =
orIndent
(hsep [!(hl Syntax "let*"),
!(bracks . vsep . toList =<< traverse prettyBind ps)])
!(prettySexp e)
private covering
prettyDefine : {opts : LayoutOpts} ->
String -> Either Id (List Id) -> Sexp -> Eff Pretty (Doc opts)
prettyDefine def xs body =
parens $ vappend
(hsep [!(hl Syntax $ text def),
!(either prettyId (prettySexp . L . map V) xs)])
(indent 2 !(prettySexp body))
prettySexp (V x) = prettyId x
prettySexp (L []) = hl Delim "()"
prettySexp (L (x :: xs)) = do
d <- prettySexp x
ds <- traverse prettySexp xs
parens $ ifMultiline
(hsep $ d :: ds)
(hsep [d, vsep ds] <|> vsep (d :: map (indent 2) ds))
prettySexp (Q (V x)) = hl Constant $ "'" <+> prettyId' x
prettySexp (Q x) = pure $ hcat [!(hl Constant "'"), !(prettySexp x)]
prettySexp (N n) = hl Constant $ pshow n
prettySexp (S s) = prettyStrLit $ escape s
prettySexp (Lambda xs e) = prettyLambda "lambda" xs e
prettySexp (LambdaC xs e) = prettyLambda "lambda%" xs e
prettySexp (Let x rhs e) = prettyLet [< (x, rhs)] e
prettySexp (Case h as) = do
header' <- prettySexp h
case_ <- caseD
let header = ifMultiline (case_ <++> header')
(case_ `vappend` indent 2 header')
arms <- traverse prettyCase $ toList as
pure $ ifMultiline
(parens $ header <++> hsep arms)
(parens $ vsep $ header :: map (indent 2) arms)
where
prettyCase : (List Sexp, Sexp) -> Eff Pretty (Doc opts)
prettyCase (ps, e) = bracks $
ifMultiline
(hsep [!(parens . hsep =<< traverse prettySexp ps), !(prettySexp e)])
(vsep [!(parens . sep =<< traverse prettySexp ps), !(prettySexp e)])
prettySexp (Define x e) = case e of
LambdaC xs e => prettyDefine "define%" (Right $ x :: xs) e
Lambda xs e => prettyDefine "define" (Right $ x :: xs) e
_ => prettyDefine "define" (Left x) e
prettySexp (Literal sexp) =
pure $ text sexp
export covering
makeRunMain : {opts : LayoutOpts} -> Id -> Eff Pretty (Doc opts)
makeRunMain x = prettySexp $ L ["run-main", V x]

Some files were not shown because too many files have changed in this diff Show more