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
160 changed files with 12311 additions and 6725 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

@ -5,3 +5,6 @@ load "maybe.quox"
load "nat.quox"
load "pair.quox"
load "list.quox"
load "eta.quox"
load "fail.quox"
load "qty.quox"

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

View file

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

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 {
zero ⇒ n;
succ _, 1.p ⇒ succ p
case m return of {
zero ⇒ n;
succ _, p ⇒ succ p
};
def timesω : 1. → ω. =
#[compile-scheme "(lambda% (m n) (* m n))"]
def timesω : → ω. =
λ m n ⇒
case1 m return of {
zero ⇒ zero;
succ _, 1.t ⇒ plus n t
case m return of {
zero ⇒ zero;
succ _, t ⇒ plus n t
};
def times : 1.1. =
λ m n ⇒ case1 dup n return of { [n] ⇒ timesω m n };
def times : =
λ m n ⇒ case dup n return of { [n] ⇒ timesω m n };
def pred : 1. = λ n ⇒ case1 n return of { zero ⇒ zero; succ n ⇒ n };
def pred : = λ n ⇒ case n return of { zero ⇒ zero; succ n ⇒ n };
def pred-succ : ω.(n : ) → pred (succ n) ≡ n : =
λ n ⇒ δ 𝑖 ⇒ n;
def0 succ-inj : 0.(m n : ) → 0.(succ m ≡ succ n : ) → m ≡ n : =
def0 succ-inj : (m n : ) → succ m ≡ succ n : → m ≡ n : =
λ m n eq ⇒ δ 𝑖 ⇒ pred (eq @𝑖);
#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"]
def minus : =
λ m n ⇒
(case n return of {
zero ⇒ λ m ⇒ m;
succ _, f ⇒ λ m ⇒ f (pred m)
}) m;
def0 IsSucc : 0. → ★ =
λ n ⇒ caseω n return ★ of { zero ⇒ False; succ _ ⇒ True };
def0 IsSucc : → ★ =
λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True };
def isSucc? : ω.(n : ) → Dec (IsSucc n) =
λ n ⇒
@ -54,14 +85,15 @@ def succ-not-zero : 0.(m : ) → Not (succ m ≡ zero : ) =
λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true;
def0 not-succ-self : 0.(m : ) → Not (m ≡ succ m : ) =
def0 not-succ-self : (m : ) → Not (m ≡ succ m : ) =
λ m ⇒
caseω m return m' ⇒ Not (m' ≡ succ m' : ) of {
case m return m' ⇒ Not (m' ≡ succ m' : ) of {
zero ⇒ zero-not-succ 0;
succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq)
}
#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"]
def eq? : DecEq =
λ m ⇒
caseω m
@ -86,28 +118,48 @@ def eq? : DecEq =
def eqb : ω. → ω. → Bool = λ m n ⇒ dec.bool (m ≡ n : ) (eq? m n);
def0 plus-zero : 0.(m : ) → m ≡ plus m 0 : =
def0 plus-zero : (m : ) → m ≡ plus m 0 : =
λ m ⇒
caseω m return m' ⇒ m' ≡ plus m' 0 : of {
zero ⇒ δ _ ⇒ zero;
succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
case m return m' ⇒ m' ≡ plus m' 0 : of {
zero ⇒ δ _ ⇒ 0;
succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
};
def0 plus-succ : 0.(m n : ) → succ (plus m n) ≡ plus m (succ n) : =
def0 plus-succ : (m n : ) → succ (plus m n) ≡ plus m (succ n) : =
λ m n ⇒
caseω m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : of {
zero ⇒ δ _ ⇒ succ n;
succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
case m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : of {
zero ⇒ δ _ ⇒ succ n;
succ _, ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
};
def0 plus-comm : 0.(m n : ) → plus m n ≡ plus n m : =
def0 plus-comm : (m n : ) → plus m n ≡ plus n m : =
λ m n ⇒
caseω m return m' ⇒ plus m' n ≡ plus n m' : of {
case m return m' ⇒ plus m' n ≡ plus n m' : of {
zero ⇒ plus-zero n;
succ m', ω.ih ⇒
succ m', ih ⇒
trans (succ (plus m' n)) (succ (plus n m')) (plus n (succ m'))
𝑖 ⇒ succ (ih @𝑖))
(plus-succ n m')
};
def0 times-zero : (m : ) → 0 ≡ timesω m 0 : =
λ m ⇒
case m return m' ⇒ 0 ≡ timesω m' 0 : of {
zero ⇒ δ _ ⇒ zero;
succ m', ih ⇒ ih
};
{-
-- unfinished
def0 times-succ : (m n : ) → plus m (timesω m n) ≡ timesω m (succ n) : =
λ m n ⇒
case m
return m' ⇒ plus m' (timesω m' n) ≡ timesω m' (succ n) :
of {
zero ⇒ δ _ ⇒ 0;
succ m', ih ⇒
δ 𝑖 ⇒ plus (succ n) (ih @𝑖)
};
-}
}

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,16 +6,13 @@ import Quox.Name
import Data.DPair
import Data.Nat
import Data.Fin
import Data.Singleton
import Data.SnocList
import Data.SnocVect
import Data.Vect
import Control.Monad.Identity
import Derive.Prelude
%default total
%language ElabReflection
||| a sequence of bindings under an existing context. each successive element
@ -61,6 +58,7 @@ public export
tail : Context tm (S n) -> Context tm n
tail = fst . unsnoc
parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
export
toSnocListWith : Telescope tm _ _ -> SnocList a
@ -87,13 +85,6 @@ export %inline
toSnocList' : Telescope' a _ _ -> SnocList a
toSnocList' = toSnocListWith id
export %inline
toSnocListRelevant : {n1 : Nat} -> Telescope tm n1 n2 -> SnocList (n ** tm n)
toSnocListRelevant tel = toSnocList' $ snd $ go tel where
go : Telescope tm n1 n2' -> (Singleton n2', Telescope' (n ** tm n) n1 n2')
go [<] = (Val n1, [<])
go (tel :< x) = let (Val n, tel) = go tel in (Val (S n), tel :< (n ** x))
export %inline
toList : Telescope tm _ _ -> List (Exists tm)
toList = toListWith (Evidence _)
@ -118,10 +109,17 @@ fromSnocVect [<] = [<]
fromSnocVect (sx :< x) = fromSnocVect sx :< x
public export
tabulateLT : (n : Nat) -> ((i : Nat) -> (0 p : i `LT` n) => tm i) ->
Context tm n
tabulateLT 0 f = [<]
tabulateLT (S k) f =
tabulateLT k (\i => f i @{lteSuccRight %search}) :< f k @{reflexive}
public export
tabulate : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
tabulate f 0 = [<]
tabulate f (S k) = tabulate f k :< f k
tabulate f n = tabulateLT n (\i => f i)
-- [todo] fixup argument order lol
public export
replicate : (n : Nat) -> a -> Context' a n
@ -147,34 +145,34 @@ tel ++ (sx :< x) = (tel ++ sx) :< x
public export
getShiftWith : (forall from, to. tm from -> Shift from to -> tm to) ->
Shift len out -> Context tm len -> Fin len -> tm out
getShiftWith shft by (ctx :< t) FZ = t `shft` ssDown by
getShiftWith shft by (ctx :< t) (FS i) = getShiftWith shft (ssDown by) ctx i
Shift len out -> Context tm len -> Var len -> tm out
getShiftWith shft by (ctx :< t) VZ = t `shft` ssDown by
getShiftWith shft by (ctx :< t) (VS i) = getShiftWith shft (ssDown by) ctx i
public export %inline
getShift : CanShift tm => Shift len out -> Context tm len -> Fin len -> tm out
getShift : CanShift tm => Shift len out -> Context tm len -> Var len -> tm out
getShift = getShiftWith (//)
public export %inline
getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
Context tm len -> Fin len -> tm len
Context tm len -> Var len -> tm len
getWith shft = getShiftWith shft SZ
infixl 8 !!
export infixl 8 !!
public export %inline
(!!) : CanShift tm => Context tm len -> Fin len -> tm len
(!!) : CanShift tm => Context tm len -> Var len -> tm len
(!!) = getWith (//)
infixl 8 !!!
export infixl 8 !!!
public export %inline
(!!!) : Context' tm len -> Fin len -> tm
(!!!) : Context' tm len -> Var len -> tm
(!!!) = getWith const
public export
find : Alternative f =>
(forall n. tm n -> Bool) -> Context tm len -> f (Fin len)
(forall n. tm n -> Bool) -> Context tm len -> f (Var len)
find p [<] = empty
find p (ctx :< x) = (guard (p x) $> FZ) <|> (FS <$> find p ctx)
find p (ctx :< x) = (guard (p x) $> VZ) <|> (VS <$> find p ctx)
export
@ -191,6 +189,12 @@ export %hint
succGT = LTESucc reflexive
public export
drop : (m : Nat) -> Context term (m + n) -> Context term n
drop 0 ctx = ctx
drop (S m) (ctx :< _) = drop m ctx
parameters {auto _ : Applicative f}
export
traverse : (forall n. tm1 n -> f (tm2 n)) ->
@ -202,7 +206,7 @@ parameters {auto _ : Applicative f}
traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
traverse' f = traverse f
infixl 3 `app`
export infixl 3 `app`
||| like `(<*>)` but with effects
export
app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
@ -269,16 +273,17 @@ unzip3 (tel :< (x, y, z)) =
public export
lengthPrf : Telescope _ from to -> (len ** len + from = to)
lengthPrf [<] = (0 ** Refl)
lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
lengthPrf [<] = Element 0 Refl
lengthPrf (tel :< _) =
let len = lengthPrf tel in (S len.fst ** cong S len.snd)
let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
export
lengthPrf0 : Context _ to -> (len ** len = to)
lengthPrf0 : Context _ to -> Singleton to
lengthPrf0 ctx =
let len = lengthPrf ctx in
(len.fst ** rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
let Element len prf = lengthPrf ctx in
rewrite sym prf `trans` plusZeroRightNeutral len in
[|len|]
public export %inline
length : Telescope {} -> Nat
@ -297,6 +302,10 @@ foldl : {0 acc : Nat -> Type} ->
foldl f z [<] = z
foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
export %inline
foldl_ : (acc -> tm -> acc) -> acc -> Telescope' tm from to -> acc
foldl_ f z tel = foldl f z tel
export %inline
foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
@ -331,14 +340,6 @@ export %inline
where Show (Exists tm) where showPrec d t = showPrec d t.snd
export
implementation [ShowTelRelevant]
{n1 : Nat} -> ({n : Nat} -> Show (f n)) => Show (Telescope f n1 n2)
where
showPrec d = showPrec d . toSnocListRelevant
where Show (n : Nat ** f n) where showPrec d (_ ** t) = showPrec d t
parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
(nameHL : HL)
(pterm : forall n. BContext n -> tm n -> Eff Pretty (Doc opts))
@ -364,4 +365,4 @@ parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
namespace BContext
export
toNames : BContext n -> SnocList BaseName
toNames = foldl (\xs, x => xs :< x.name) [<]
toNames = foldl (\xs, x => xs :< x.val) [<]

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

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

View file

@ -1,44 +0,0 @@
module Quox.FinExtra
import public Data.Fin
import Quox.Decidable
public export
data LT : Rel (Fin n) where
LTZ : FZ `LT` FS i
LTS : i `LT` j -> FS i `LT` FS j
%builtin Natural FinExtra.LT
%name FinExtra.LT lt
public export %inline
GT : Rel (Fin n)
GT = flip LT
export
Transitive (Fin n) LT where
transitive LTZ (LTS _) = LTZ
transitive (LTS p) (LTS q) = LTS $ transitive p q
export Uninhabited (i `FinExtra.LT` i) where uninhabited (LTS p) = uninhabited p
export Uninhabited (FS i `LT` FZ) where uninhabited _ impossible
public export
data Compare : Rel (Fin n) where
IsLT : (lt : i `LT` j) -> Compare i j
IsEQ : Compare i i
IsGT : (gt : i `GT` j) -> Compare i j
%name Compare cmp
export
compareS : Compare i j -> Compare (FS i) (FS j)
compareS (IsLT lt) = IsLT (LTS lt)
compareS IsEQ = IsEQ
compareS (IsGT gt) = IsGT (LTS gt)
export
compareP : (i, j : Fin n) -> Compare i j
compareP FZ FZ = IsEQ
compareP FZ (FS j) = IsLT LTZ
compareP (FS i) FZ = IsGT LTZ
compareP (FS i) (FS j) = compareS $ compareP i j

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

@ -1,19 +1,13 @@
module Quox.NatExtra
import public Data.Nat
import public Data.Nat.Views
import Data.Nat.Division
import Data.SnocList
import Data.Vect
import Syntax.PreorderReasoning
import Data.String
%default total
infixl 8 `shiftL`, `shiftR`
infixl 7 .&.
infixl 6 `xor`
infixl 5 .|.
public export
data LTE' : Nat -> Nat -> Type where
@ -59,151 +53,42 @@ parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char)
showAtBase : Nat -> String
showAtBase = pack . showAtBase' []
export
showHex : Nat -> String
showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF"
namespace Nat
export
showHex : Nat -> String
showHex = showAtBase $ fromList $ unpack "0123456789abcdef"
namespace Int
export
showHex : Int -> String
showHex x =
if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x)
export
0 notEvenOdd : (a, b : Nat) -> Not (a + a = S (b + b))
notEvenOdd 0 b prf = absurd prf
notEvenOdd (S a) b prf =
notEvenOdd b a $ Calc $
|~ b + b
~~ a + S a ..<(inj S prf)
~~ S (a + a) ..<(plusSuccRightSucc {})
namespace Int
export
fromHexit : Char -> Maybe Int
fromHexit c =
if c >= '0' && c <= '9' then Just $ ord c - ord '0'
else if c >= 'a' && c <= 'f' then Just $ ord c - ord 'a' + 10
else if c >= 'A' && c <= 'F' then Just $ ord c - ord 'A' + 10
else Nothing
export
0 doubleInj : (m, n : Nat) -> m + m = n + n -> m = n
doubleInj 0 0 _ = Refl
doubleInj (S m) (S n) prf =
cong S $ doubleInj m n $
inj S $ Calc $
|~ S (m + m)
~~ m + S m ...(plusSuccRightSucc {})
~~ n + S n ...(inj S prf)
~~ S (n + n) ..<(plusSuccRightSucc {})
private
fromHex' : Int -> String -> Maybe Int
fromHex' acc str = case strM str of
StrNil => Just acc
StrCons c cs => fromHex' (16 * acc + !(fromHexit c)) (assert_smaller str cs)
export
0 halfDouble : (n : Nat) -> half (n + n) = HalfEven n
halfDouble n with (half (n + n)) | (n + n) proof nn
_ | HalfOdd k | S (k + k) = void $ notEvenOdd n k nn
_ | HalfEven k | k + k = rewrite doubleInj n k nn in Refl
export %inline
fromHex : String -> Maybe Int
fromHex str = do guard $ str /= ""; fromHex' 0 str
export
floorHalf : Nat -> Nat
floorHalf k = case half k of
HalfOdd n => n
HalfEven n => n
namespace Nat
export
fromHexit : Char -> Maybe Nat
fromHexit = map cast . Int.fromHexit
||| like in intercal ☺
|||
||| take all the bits of `subj` that are set in `mask`, and squish them down
||| towards the lsb
public export
select : (mask, subj : Nat) -> Nat
select mask subj = go 1 (halfRec mask) subj 0 where
go : forall mask. Nat -> HalfRec mask -> Nat -> Nat -> Nat
go bit HalfRecZ subj res = res
go bit (HalfRecEven _ rec) subj res = go bit rec (floorHalf subj) res
go bit (HalfRecOdd _ rec) subj res = case half subj of
HalfOdd subj => go (bit + bit) rec subj (res + bit)
HalfEven subj => go (bit + bit) rec subj res
||| take the i least significant bits of subj (where i = popCount mask),
||| and place them where mask's set bits are
|||
||| left inverse of select if mask .|. subj = mask
public export
spread : (mask, subj : Nat) -> Nat
spread mask subj = go 1 (halfRec mask) subj 0 where
go : forall mask. Nat -> HalfRec mask -> Nat -> Nat -> Nat
go bit HalfRecZ subj res = res
go bit (HalfRecEven _ rec) subj res = go (bit + bit) rec subj res
go bit (HalfRecOdd _ rec) subj res = case half subj of
HalfOdd subj => go (bit + bit) rec subj (res + bit)
HalfEven subj => go (bit + bit) rec subj res
public export
data BitwiseRec : Nat -> Nat -> Type where
BwDone : BitwiseRec 0 0
Bw00 : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
BitwiseRec (m + m) (n + n)
Bw01 : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
BitwiseRec (m + m) (S (n + n))
Bw10 : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
BitwiseRec (S (m + m)) (n + n)
Bw11 : (m, n : Nat) -> Lazy (BitwiseRec m n) ->
BitwiseRec (S (m + m)) (S (n + n))
export
bitwiseRec : (m, n : Nat) -> BitwiseRec m n
bitwiseRec m n = go (halfRec m) (halfRec n) where
go : forall m, n. HalfRec m -> HalfRec n -> BitwiseRec m n
go HalfRecZ HalfRecZ = BwDone
go HalfRecZ (HalfRecEven n nr) = Bw00 0 n $ go HalfRecZ nr
go HalfRecZ (HalfRecOdd n nr) = Bw01 0 n $ go HalfRecZ nr
go (HalfRecEven m mr) HalfRecZ = Bw00 m 0 $ go mr HalfRecZ
go (HalfRecEven m mr) (HalfRecEven n nr) = Bw00 m n $ go mr nr
go (HalfRecEven m mr) (HalfRecOdd n nr) = Bw01 m n $ go mr nr
go (HalfRecOdd m mr) HalfRecZ = Bw10 m 0 $ go mr HalfRecZ
go (HalfRecOdd m mr) (HalfRecEven n nr) = Bw10 m n $ go mr nr
go (HalfRecOdd m mr) (HalfRecOdd n nr) = Bw11 m n $ go mr nr
public export
bitwise : (Bool -> Bool -> Bool) -> Nat -> Nat -> Nat
bitwise f m n = go 1 (bitwiseRec m n) 0 where
one : Bool -> Bool -> Nat -> Nat -> Nat
one p q bit res = if f p q then bit + res else res
go : forall m, n. Nat -> BitwiseRec m n -> Nat -> Nat
go bit BwDone res = res
go bit (Bw00 m n rec) res = go (bit + bit) rec $ one False False bit res
go bit (Bw01 m n rec) res = go (bit + bit) rec $ one False True bit res
go bit (Bw10 m n rec) res = go (bit + bit) rec $ one True False bit res
go bit (Bw11 m n rec) res = go (bit + bit) rec $ one True True bit res
public export
(.&.) : Nat -> Nat -> Nat
(.&.) = bitwise $ \p, q => p && q
private %foreign "scheme:blodwen-and"
primAnd : Nat -> Nat -> Nat
%transform "NatExtra.(.&.)" NatExtra.(.&.) m n = primAnd m n
public export
(.|.) : Nat -> Nat -> Nat
(.|.) = bitwise $ \p, q => p || q
private %foreign "scheme:blodwen-or"
primOr : Nat -> Nat -> Nat
%transform "NatExtra.(.|.)" NatExtra.(.|.) m n = primOr m n
public export
xor : Nat -> Nat -> Nat
xor = bitwise (/=)
private %foreign "scheme:blodwen-xor"
primXor : Nat -> Nat -> Nat
%transform "NatExtra.xor" NatExtra.xor m n = primXor m n
public export
shiftL : Nat -> Nat -> Nat
shiftL n 0 = n
shiftL n (S i) = shiftL (n + n) i
private %foreign "scheme:blodwen-shl"
primShiftL : Nat -> Nat -> Nat
%transform "NatExtra.shiftL" NatExtra.shiftL n i = primShiftL n i
public export
shiftR : Nat -> Nat -> Nat
shiftR n 0 = n
shiftR n (S i) = shiftL (floorHalf n) i
private %foreign "scheme:blodwen-shr"
primShiftR : Nat -> Nat -> Nat
%transform "NatExtra.shiftR" NatExtra.shiftR n i = primShiftR n i
export %inline
fromHex : String -> Maybe Nat
fromHex = map cast . Int.fromHex

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
pure $ Enum set loc
else
throw $ DuplicatesInEnum loc strs
Enum strs loc => do
let set = SortedSet.fromList strs
unless (length strs == length (SortedSet.toList set)) $
throw $ DuplicatesInEnumType loc strs
pure $ Enum set loc
Tag str loc => pure $ Tag str loc
@ -238,13 +263,22 @@ mutual
<*> fromPTermDScope ds ns [< j1] val1
<*> pure loc
Let (qty, x, rhs) body loc =>
Let (fromPQty qty)
<$> fromPTermElim ds ns rhs
<*> fromPTermTScope ds ns [< x] body
<*> pure loc
private
fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n ->
List (PTagVal, PTerm) ->
Eff FromParserPure (CaseEnumArms d n)
fromPTermEnumArms ds ns =
map SortedMap.fromList .
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
fromPTermEnumArms loc ds ns arms = do
res <- SortedMap.fromList <$>
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms
unless (length (keys res) == length arms) $
throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms)
pure res
private
fromPTermElim : Context' PatVar d -> Context' PatVar n ->
@ -263,7 +297,7 @@ mutual
if all isUnused xs then
SN <$> fromPTermWith ds ns t
else
ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
private
fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
@ -271,9 +305,9 @@ mutual
Eff FromParserPure (DScopeTermN s d n)
fromPTermDScope ds ns xs t =
if all isUnused xs then
SN <$> fromPTermWith ds ns t
SN {f = \d => Term d n} <$> fromPTermWith ds ns t
else
DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
export %inline
@ -282,72 +316,110 @@ fromPTerm = fromPTermWith [<] [<]
export
globalPQty : Loc -> (q : Qty) -> Eff [Except Error] (So $ isGlobal q)
globalPQty loc pi = case choose $ isGlobal pi of
Left y => pure y
Right _ => throw $ QtyNotGlobal loc pi
globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty
globalPQty (PQ pi loc) = case toGlobal pi of
Just g => pure g
Nothing => throw $ QtyNotGlobal loc pi
export
fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name
fromPBaseNameNS : Has (StateL NS Mods) fs => PBaseName -> Eff fs Name
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
private
liftTC : TC a -> Eff FromParserPure a
liftTC act = do
res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act
rethrow $ mapFst WrapTypeError res
liftTC : Eff TC a -> Eff FromParserPure a
liftTC tc = runEff tc $ with Union.(::)
[handleExcept $ \e => throw $ WrapTypeError e,
handleReaderConst !(getAt DEFS),
\g => send g,
\g => send g]
private
liftWhnf : Eff Whnf a -> Eff FromParserPure a
liftWhnf tc = runEff tc $ with Union.(::)
[handleExcept $ \e => throw $ WrapTypeError e,
\g => send g,
\g => send g]
private
addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition
addDef name def = do
modifyAt DEFS $ insert name def
pure (name, def)
export covering
fromPDef : PDefinition -> Eff FromParserPure NDefinition
fromPDef (MkPDef qty pname ptype pterm defLoc) = do
name <- lift $ fromPBaseNameNS pname
qtyGlobal <- lift $ globalPQty qty.loc qty.val
let gqty = Element qty.val qtyGlobal
sqty = globalToSubj gqty
type <- lift $ traverse fromPTerm ptype
term <- lift $ fromPTerm pterm
case type of
Just type => do
liftTC $ checkTypeC empty type Nothing
liftTC $ ignore $ checkC empty sqty term type
let def = mkDef gqty type term defLoc
modifyAt DEFS $ insert name def
pure (name, def)
Nothing => do
let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term
res <- liftTC $ inferC empty sqty elim
let def = mkDef gqty res.type term defLoc
modifyAt DEFS $ insert name def
pure (name, def)
fromPDef def = do
name <- fromPBaseNameNS def.name
defs <- getAt DEFS
when (isJust $ lookup name defs) $ do
throw $ AlreadyExists def.loc name
gqty <- globalPQty def.qty
let sqty = globalToSubj gqty
case def.body of
PConcrete ptype pterm => do
type <- traverse fromPTerm ptype
term <- fromPTerm pterm
type <- case type of
Just type => do
ignore $ liftTC $ do
checkTypeC empty type Nothing
checkC empty sqty term type
pure type
Nothing => do
let E elim = term
| _ => throw $ AnnotationNeeded term.loc empty term
res <- liftTC $ inferC empty sqty elim
pure res.type
when def.main $ liftWhnf $ expectMainType defs type
addDef name $ mkDef gqty type term def.scheme def.main def.loc
PPostulate ptype => do
type <- fromPTerm ptype
addDef name $ mkPostulate gqty type def.scheme def.main def.loc
public export
data HasFail = NoFail | AnyFail | FailWith String
export covering
expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error
expectFail loc act = do
gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels
case fromParserPure ns gen defs (singleton lvl) act of
Left err => pure err
Right _ => throw $ ExpectedFail loc
export covering
maybeFail : Monoid a =>
PFail -> Loc -> Eff FromParserPure a -> Eff FromParserPure a
maybeFail PSucceed _ act = act
maybeFail PFailAny loc act = expectFail loc act $> neutral
maybeFail (PFailMatch str) loc act = do
err <- expectFail loc act
let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e
if str `isInfixOf` renderInfinite msg
then pure neutral
else throw $ WrongFail str err loc
export covering
fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
fromPDecl (PDef def) = singleton <$> fromPDef def
fromPDecl (PDef def) =
maybeFail def.fail def.loc $ singleton <$> fromPDef def
fromPDecl (PNs ns) =
maybeFail ns.fail ns.loc $
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
export covering
loadFile : Loc -> String -> Eff LoadFile (Maybe String)
loadFile loc file =
if contains file !(getAt SEEN) then
pure Nothing
else do
Just ifile <- firstExists (map (</> file) !ask)
| Nothing => throw $ LoadError loc file FileNotFound
case !(readFile ifile) of
Right res => modifyAt SEEN (insert file) $> Just res
Left err => throw $ LoadError loc ifile err
fromPDecl (PPrag prag) =
case prag of
PLogPush p _ => Log.push p $> []
PLogPop _ => Log.pop $> []
mutual
export covering
loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
loadProcessFile loc file =
case !(lift $ loadFile loc file) of
Just inp => do
tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
concat <$> traverse fromPTopLevel tl
case !(loadFile loc file) of
Just tl => concat <$> traverse fromPTopLevel tl
Nothing => pure []
||| populates the `defs` field of the state
@ -355,28 +427,3 @@ mutual
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
fromPTopLevel (PD decl) = lift $ fromPDecl decl
fromPTopLevel (PLoad file loc) = loadProcessFile loc file
export
fromParserPure : NameSuf -> Definitions ->
Eff FromParserPure a ->
(Either Error (a, Definitions), NameSuf)
fromParserPure suf defs act =
extract $
runStateAt GEN suf $
runExcept $
evalStateAt NS [<] $
runStateAt DEFS defs act
export
fromParserIO : (MonadRec io, HasIO io) =>
IncludePath ->
IORef SeenFiles -> IORef NameSuf -> IORef Definitions ->
Eff FromParserIO a -> io (Either Error a)
fromParserIO inc seen suf defs act =
runIO $
runStateIORefAt GEN suf $
runExcept $
evalStateAt NS [<] $
runStateIORefAt SEEN seen $
runStateIORefAt DEFS defs $
runReader inc act

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

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
(Pi _ _ _ _ loc).loc = loc
(Lam _ _ loc).loc = loc
(App _ _ loc).loc = loc
(Sig _ _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Case _ _ _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ _ loc).loc = loc
(DApp _ _ loc).loc = loc
(Nat loc).loc = loc
(Zero loc).loc = loc
(Succ _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(V _ _ loc).loc = loc
(Ann _ _ loc).loc = loc
(Coe _ _ _ _ loc).loc = loc
(Comp _ _ _ _ _ _ _ loc).loc = loc
(TYPE _ loc).loc = loc
(IOState loc).loc = loc
(Pi _ _ _ _ loc).loc = loc
(Lam _ _ loc).loc = loc
(App _ _ loc).loc = loc
(Sig _ _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Fst _ loc).loc = loc
(Snd _ loc).loc = loc
(Case _ _ _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ _ loc).loc = loc
(DApp _ _ loc).loc = loc
(NAT loc).loc = loc
(Nat _ loc).loc = loc
(Succ _ loc).loc = loc
(STRING loc).loc = loc
(Str _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(V _ _ loc).loc = loc
(Ann _ _ loc).loc = loc
(Coe _ _ _ _ loc).loc = loc
(Comp _ _ _ _ _ _ _ loc).loc = loc
(Let _ _ loc).loc = loc
export
export %inline
Located PCaseBody where
(CasePair _ _ loc).loc = loc
(CaseEnum _ loc).loc = loc
@ -137,18 +157,45 @@ Located PCaseBody where
(CaseBox _ _ loc).loc = loc
public export
data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm
%name PBody body
%runElab derive "PBody" [Eq, Ord, Show, PrettyVal]
public export
data PFail =
PSucceed
| PFailAny
| PFailMatch String
%runElab derive "PFail" [Eq, Ord, Show, PrettyVal]
public export
record PDefinition where
constructor MkPDef
qty : PQty
name : PBaseName
type : Maybe PTerm
term : PTerm
loc_ : Loc
qty : PQty
name : PBaseName
body : PBody
fail : PFail
main : Bool
scheme : Maybe String
loc_ : Loc
%name PDefinition def
%runElab derive "PDefinition" [Eq, Ord, Show]
%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
export Located PDefinition where def.loc = def.loc_
export %inline Located PDefinition where def.loc = def.loc_
public export
data PPragma =
PLogPush (List Log.PushArg) Loc
| PLogPop Loc
%name PPragma prag
%runElab derive "PPragma" [Eq, Ord, Show, PrettyVal]
export %inline
Located PPragma where
(PLogPush _ loc).loc = loc
(PLogPop loc).loc = loc
mutual
public export
@ -156,35 +203,49 @@ mutual
constructor MkPNamespace
name : Mods
decls : List PDecl
fail : PFail
loc_ : Loc
%name PNamespace ns
public export
data PDecl =
PDef PDefinition
| PNs PNamespace
PDef PDefinition
| PNs PNamespace
| PPrag PPragma
%name PDecl decl
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show]
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
export Located PNamespace where ns.loc = ns.loc_
export %inline Located PNamespace where ns.loc = ns.loc_
export
export %inline
Located PDecl where
(PDef def).loc = def.loc
(PNs ns).loc = ns.loc
(PDef d).loc = d.loc
(PNs ns).loc = ns.loc
(PPrag prag).loc = prag.loc
public export
data PTopLevel = PD PDecl | PLoad String Loc
%name PTopLevel t
%runElab derive "PTopLevel" [Eq, Ord, Show]
%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal]
export
export %inline
Located PTopLevel where
(PD decl).loc = decl.loc
(PLoad _ loc).loc = loc
public export
fromNat : Nat -> Loc -> PTerm
fromNat 0 loc = Zero loc
fromNat (S k) loc = Succ (fromNat k loc) loc
record PAttr where
constructor PA
name : PBaseName
args : List PTerm
loc_ : Loc
%name PAttr attr
%runElab derive "PAttr" [Eq, Ord, Show, PrettyVal]
export %inline Located PAttr where attr.loc = attr.loc_
public export
PFile : Type
PFile = List PTopLevel

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"
eqD = hl Syntax $ text "Eq"
colonD = hl Delim $ text ":"
commaD = hl Delim $ text ","
semiD = hl Delim $ text ";"
caseD = hl Syntax $ text "case"
typecaseD = hl Syntax $ text "type-case"
ofD = hl Syntax $ text "of"
returnD = hl Syntax $ text "return"
dotD = hl Delim $ text "."
zeroD = hl Syntax $ text "zero"
succD = hl Syntax $ text "succ"
coeD = hl Syntax $ text "coe"
compD = hl Syntax $ text "comp"
undD = hl Syntax $ text "_"
cstD = hl Syntax $ text "="
pipeD = hl Syntax $ text "|"
stringD = hl Syntax $ text "String"
eqD = hl Syntax $ text "Eq"
colonD = hl Syntax $ text ":"
commaD = hl Syntax $ text ","
semiD = hl Delim $ text ";"
atD = hl Delim $ text "@"
caseD = hl Syntax $ text "case"
typecaseD = hl Syntax $ text "type-case"
ofD = hl Syntax $ text "of"
returnD = hl Syntax $ text "return"
dotD = hl Delim $ text "."
zeroD = hl Constant $ text "zero"
succD = hl Constant $ text "succ"
coeD = hl Syntax $ text "coe"
compD = hl Syntax $ text "comp"
undD = hl Syntax $ text "_"
cstD = hl Syntax $ text "="
pipeD = hl Delim $ text "|"
fstD = hl Syntax $ text "fst"
sndD = hl Syntax $ text "snd"
letD = hl Syntax $ text "let"
inD = hl Syntax $ text "in"
export
prettyApp : {opts : _} -> Nat -> Doc opts -> List (Doc opts) -> Doc opts
prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
List (Doc opts) -> Doc opts
prettyApp ind f args =
hsep (f :: args)
<|> hsep [f, vsep args]
<|> vsep (f :: map (indent ind) args)
ifMultiline
(hsep (f :: args))
(f <++> vsep args <|> vsep (f :: map (indent ind) args))
export
prettyAppD : {opts : _} -> Doc opts -> List (Doc opts) -> Eff Pretty (Doc opts)
prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
Eff Pretty (Doc opts)
prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
@ -288,7 +334,7 @@ quoteTag tag =
"\"" ++ escapeString tag ++ "\""
export
prettyBounds : {opts : _} -> Bounds -> Eff Pretty (Doc opts)
prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
prettyBounds (MkBounds l1 c1 l2 c2) =
hcat <$> sequence
[hl TVar $ text $ show l1, colonD,
@ -297,8 +343,22 @@ prettyBounds (MkBounds l1 c1 l2 c2) =
hl DVar $ text $ show c2, colonD]
export
prettyLoc : {opts : _} -> Loc -> Eff Pretty (Doc opts)
prettyLoc : {opts : LayoutOpts} -> Loc -> Eff Pretty (Doc opts)
prettyLoc (L NoLoc) =
hcat <$> sequence [hl TVarErr "no location", colonD]
prettyLoc (L (YesLoc file b)) =
hcat <$> sequence [hl Free $ text file, colonD, prettyBounds b]
export
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
export
prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts)
prettyStrLit s =
let s = concatMap esc1 $ unpack s in
hl Constant $ hcat ["\"", text s, "\""]
where
esc1 : Char -> String
esc1 '"' = "\""; esc1 '\\' = "\\"
esc1 c = singleton c

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

@ -1,18 +1,16 @@
module Quox.Syntax.Dim
import Quox.Thin
import Quox.Syntax.Var
import Quox.Loc
import Quox.Name
import Quox.Var
import Quox.Syntax.Subst
import Quox.Pretty
import Quox.Name
import Quox.Loc
import Quox.Context
import Quox.PrettyValExtra
import Decidable.Equality
import Control.Function
import Derive.Prelude
import Data.DPair
import Data.SnocVect
%default total
%language ElabReflection
@ -21,7 +19,7 @@ import Data.SnocVect
public export
data DimConst = Zero | One
%name DimConst e
%runElab derive "DimConst" [Eq, Ord, Show]
%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal]
||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
public export
@ -42,48 +40,38 @@ DecEq DimConst where
public export
data Dim : Nat -> Type where
K : DimConst -> Loc -> Dim 0
B : Loc -> Dim 1
K : DimConst -> Loc -> Dim d
B : Var d -> Loc -> Dim d
%name Dim.Dim p, q
%runElab deriveIndexed "Dim" [Eq, Ord, Show]
public export
DimT : Nat -> Type
DimT = Thinned Dim
public export %inline
KT : DimConst -> Loc -> DimT d
KT e loc = Th zero $ K e loc
||| `endsOr l r x p` returns `ends l r ε` if `p` is a constant ε, and
||| `x` otherwise.
public export
endsOr : Lazy a -> Lazy a -> Lazy a -> Dim n -> a
endsOr l r x (K e _) = ends l r e
endsOr l r x (B _) = x
endsOr l r x (B _ _) = x
export
Located (Dim d) where
(K _ loc).loc = loc
(B loc).loc = loc
(B _ loc).loc = loc
export
Relocatable (Dim d) where
setLoc loc (K e _) = K e loc
setLoc loc (B _) = B loc
setLoc loc (B i _) = B i loc
parameters {opts : LayoutOpts}
export
prettyDimConst : DimConst -> Eff Pretty (Doc opts)
prettyDimConst = hl Dim . text . ends "0" "1"
export
prettyDimConst : {opts : _} -> DimConst -> Eff Pretty (Doc opts)
prettyDimConst = hl Dim . text . ends "0" "1"
export
prettyDim : {d : Nat} -> BContext d -> DimT d -> Eff Pretty (Doc opts)
prettyDim names (Th _ (K e _)) = prettyDimConst e
prettyDim names (Th i (B _)) = prettyDBind $ names !!! i.fin
export
prettyDim : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
prettyDim names (K e _) = prettyDimConst e
prettyDim names (B i _) = prettyDBind $ names !!! i
public export %inline
@ -96,54 +84,57 @@ DSubst : Nat -> Nat -> Type
DSubst = Subst Dim
-- public export FromVar Dim where fromVarLoc = B
public export FromVar Dim where fromVarLoc = B
-- export
-- CanShift Dim where
-- K e loc // _ = K e loc
-- B i loc // by = B (i // by) loc
export
CanShift Dim where
K e loc // _ = K e loc
B i loc // by = B (i // by) loc
export %inline FromVar Dim where var = B
export %inline
export
CanSubstSelf Dim where
Th _ (K e loc) // _ = KT e loc
Th i (B loc) // th = get th i.fin
K e loc // _ = K e loc
B i loc // th = getLoc th i loc
export Uninhabited (B loc1 = K e loc2) where uninhabited _ impossible
export Uninhabited (K e loc1 = B loc2) where uninhabited _ impossible
export Uninhabited (B i loc1 = K e loc2) where uninhabited _ impossible
export Uninhabited (K e loc1 = B i loc2) where uninhabited _ impossible
-- public export
-- data Eqv : Dim d1 -> Dim d2 -> Type where
-- EK : K e _ `Eqv` K e _
-- EB : i `Eqv` j -> B i _ `Eqv` B j _
public export
data Eqv : Dim d1 -> Dim d2 -> Type where
EK : K e _ `Eqv` K e _
EB : i `Eqv` j -> B i _ `Eqv` B j _
-- export Uninhabited (K e l1 `Eqv` B i l2) where uninhabited _ impossible
-- export Uninhabited (B i l1 `Eqv` K e l2) where uninhabited _ impossible
export Uninhabited (K e l1 `Eqv` B i l2) where uninhabited _ impossible
export Uninhabited (B i l1 `Eqv` K e l2) where uninhabited _ impossible
-- export
-- injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j
-- injectiveB (EB e) = e
export
injectiveB : B i loc1 `Eqv` B j loc2 -> i `Eqv` j
injectiveB (EB e) = e
-- export
-- injectiveK : K e loc1 `Eqv` K f loc2 -> e = f
-- injectiveK EK = Refl
export
injectiveK : K e loc1 `Eqv` K f loc2 -> e = f
injectiveK EK = Refl
-- public export
-- decEqv : Dec2 Dim.Eqv
-- decEqv (K e _) (K f _) = case decEq e f of
-- Yes Refl => Yes EK
-- No n => No $ n . injectiveK
-- decEqv (B i _) (B j _) = case decEqv i j of
-- Yes y => Yes $ EB y
-- No n => No $ \(EB y) => n y
-- decEqv (B _ _) (K _ _) = No absurd
-- decEqv (K _ _) (B _ _) = No absurd
public export
decEqv : Dec2 Dim.Eqv
decEqv (K e _) (K f _) = case decEq e f of
Yes Refl => Yes EK
No n => No $ n . injectiveK
decEqv (B i _) (B j _) = case decEqv i j of
Yes y => Yes $ EB y
No n => No $ \(EB y) => n y
decEqv (B _ _) (K _ _) = No absurd
decEqv (K _ _) (B _ _) = No absurd
||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))`
public export %inline
BV : (i : Fin d) -> (loc : Loc) -> DimT d
BV i loc = Th (one' i) $ B loc
BV : (i : Nat) -> (0 _ : LT i d) => (loc : Loc) -> Dim d
BV i loc = B (V i) loc
export
weakD : (by : Nat) -> Dim d -> Dim (by + d)
weakD by p = p // shift by

View file

@ -1,19 +1,17 @@
module Quox.Syntax.DimEq
import public Quox.Syntax.Var
import public Quox.Var
import public Quox.Syntax.Dim
import public Quox.Syntax.Subst
import public Quox.Context
import Quox.Pretty
import Quox.Name
import Quox.Thin
import Quox.FinExtra
import Quox.FreeVars
import Data.Maybe
import Data.Nat
import Data.DPair
import Data.Fun.Graph
import Data.SnocVect
import Decidable.Decidable
import Decidable.Equality
import Derive.Prelude
@ -24,7 +22,7 @@ import Derive.Prelude
public export
DimEq' : Nat -> Type
DimEq' = Context (Maybe . DimT)
DimEq' = Context (Maybe . Dim)
public export
@ -32,12 +30,7 @@ data DimEq : Nat -> Type where
ZeroIsOne : DimEq d
C : (eqs : DimEq' d) -> DimEq d
%name DimEq eqs
%runElab deriveIndexed "DimEq" [Eq]
export
Show (DimEq d) where
showPrec d ZeroIsOne = "ZeroIsOne"
showPrec d (C eq') = showCon d "C" $ showArg eq' @{ShowTelRelevant}
%runElab deriveIndexed "DimEq" [Eq, Ord, Show]
public export
@ -66,10 +59,15 @@ Traversable (IfConsistent eqs) where
traverse f Nothing = pure Nothing
traverse f (Just x) = Just <$> f x
public export
ifConsistentElse : Applicative f => (eqs : DimEq d) ->
f a -> f () -> f (IfConsistent eqs a)
ifConsistentElse ZeroIsOne yes no = Nothing <$ no
ifConsistentElse (C _) yes no = Just <$> yes
public export
ifConsistent : Applicative f => (eqs : DimEq d) -> f a -> f (IfConsistent eqs a)
ifConsistent ZeroIsOne act = pure Nothing
ifConsistent (C _) act = Just <$> act
ifConsistent eqs act = ifConsistentElse eqs act (pure ())
public export
toMaybe : IfConsistent eqs a -> Maybe a
@ -78,13 +76,13 @@ toMaybe (Just x) = Just x
export
fromGround' : Context' DimConst d -> DimEq' d
fromGround' [<] = [<]
fromGround' (ctx :< e) = fromGround' ctx :< Just (KT e noLoc)
fromGround' : BContext d -> Context' DimConst d -> DimEq' d
fromGround' [<] [<] = [<]
fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
export
fromGround : Context' DimConst d -> DimEq d
fromGround = C . fromGround'
fromGround : BContext d -> Context' DimConst d -> DimEq d
fromGround = C .: fromGround'
public export %inline
@ -102,40 +100,39 @@ new = C new'
public export %inline
get' : DimEq' d -> Fin d -> Maybe (DimT d)
get' : DimEq' d -> Var d -> Maybe (Dim d)
get' = getWith $ \p, by => map (// by) p
public export %inline
getShift' : Shift len out -> DimEq' len -> Fin len -> Maybe (DimT out)
getVar : DimEq' d -> Var d -> Loc -> Dim d
getVar eqs i loc = fromMaybe (B i loc) $ get' eqs i
public export %inline
getShift' : Shift len out -> DimEq' len -> Var len -> Maybe (Dim out)
getShift' = getShiftWith $ \p, by => map (// by) p
public export %inline
get : {d : Nat} -> DimEq' d -> DimT d -> DimT d
get eqs p@(Th _ (K {})) = p
get eqs p@(Th i (B _)) = fromMaybe p $ get' eqs i.fin
get : DimEq' d -> Dim d -> Dim d
get _ (K e loc) = K e loc
get eqs (B i loc) = getVar eqs i loc
public export %inline
equal : {d : Nat} -> DimEq d -> (p, q : DimT d) -> Bool
equal : DimEq d -> (p, q : Dim d) -> Bool
equal ZeroIsOne p q = True
equal (C eqs) p q = get eqs p == get eqs q
infixl 7 :<?
export infixl 7 :<?
export %inline
(:<?) : {d : Nat} -> DimEq d -> Maybe (DimT d) -> DimEq (S d)
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
ZeroIsOne :<? d = ZeroIsOne
C eqs :<? d = C $ eqs :< map (get eqs) d
private %inline
isVar : {d : Nat} -> Fin d -> DimT d -> Bool
isVar i (Th j (B _)) = i == j.fin
isVar i (Th _ (K {})) = False
private %inline
ifVar : {d : Nat} -> Fin d -> DimT d -> Maybe (DimT d) -> Maybe (DimT d)
ifVar i p = map $ \q => if isVar i q then p else q
ifVar : Var d -> Dim d -> Maybe (Dim d) -> Maybe (Dim d)
ifVar i p = map $ \q => if q == B i noLoc then p else q
-- (using decEq instead of (==) because of the proofs below)
private %inline
@ -144,45 +141,43 @@ checkConst e f eqs = if isYes $ e `decEq` f then C eqs else ZeroIsOne
export
setConst : {d : Nat} -> Fin d -> DimConst -> Loc -> DimEq' d -> DimEq d
setConst FZ e loc (eqs :< Nothing) =
C $ eqs :< Just (KT e loc)
setConst FZ e _ (eqs :< Just (Th _ (K f loc))) =
checkConst e f $ eqs :< Just (KT f loc)
setConst FZ e loc (eqs :< Just (Th j (B _))) =
setConst j.fin e loc eqs :<? Just (KT e loc)
setConst (FS i) e loc (eqs :< p) =
setConst i e loc eqs :<? ifVar i (KT e loc) p
setConst : Var d -> DimConst -> Loc -> DimEq' d -> DimEq d
setConst VZ e loc (eqs :< Nothing) =
C $ eqs :< Just (K e loc)
setConst VZ e _ (eqs :< Just (K f loc)) =
checkConst e f $ eqs :< Just (K f loc)
setConst VZ e loc (eqs :< Just (B i _)) =
setConst i e loc eqs :<? Just (K e loc)
setConst (VS i) e loc (eqs :< p) =
setConst i e loc eqs :<? ifVar i (K e loc) p
mutual
private
setVar' : {d : Nat} ->
(i, j : Fin d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
setVar' FZ (FS i) LTZ loc (eqs :< Nothing) =
C eqs :<? Just (BV i loc)
setVar' FZ (FS i) LTZ loc (eqs :< Just (Th _ (K e eloc))) =
setConst i e loc eqs :<? Just (KT e eloc)
setVar' FZ (FS i) LTZ loc (eqs :< Just (Th j (B jloc))) =
let j = j.fin in
setVar i j loc jloc eqs :<? Just (if j > i then BV j jloc else BV i loc)
setVar' (FS i) (FS j) (LTS lt) loc (eqs :< p) =
setVar' i j lt loc eqs :<? ifVar i (BV j loc) p
setVar' : (i, j : Var d) -> (0 _ : i `LT` j) -> Loc -> DimEq' d -> DimEq d
setVar' VZ (VS i) LTZ loc (eqs :< Nothing) =
C eqs :<? Just (B i loc)
setVar' VZ (VS i) LTZ loc (eqs :< Just (K e eloc)) =
setConst i e loc eqs :<? Just (K e eloc)
setVar' VZ (VS i) LTZ loc (eqs :< Just (B j jloc)) =
setVar i j loc jloc eqs :<? Just (if j > i then B j jloc else B i loc)
setVar' (VS i) (VS j) (LTS lt) loc (eqs :< p) =
setVar' i j lt loc eqs :<? ifVar i (B j loc) p
export %inline
setVar : {d : Nat} -> (i, j : Fin d) -> Loc -> Loc -> DimEq' d -> DimEq d
setVar i j li lj eqs with (compareP i j)
setVar i j li lj eqs | IsLT lt = setVar' i j lt lj eqs
setVar i i li lj eqs | IsEQ = C eqs
setVar i j li lj eqs | IsGT gt = setVar' j i gt li eqs
setVar : (i, j : Var d) -> Loc -> Loc -> DimEq' d -> DimEq d
setVar i j li lj eqs with (compareP i j) | (compare i.nat j.nat)
setVar i j li lj eqs | IsLT lt | LT = setVar' i j lt lj eqs
setVar i i li lj eqs | IsEQ | EQ = C eqs
setVar i j li lj eqs | IsGT gt | GT = setVar' j i gt li eqs
export %inline
set : {d : Nat} -> (p, q : DimT d) -> DimEq d -> DimEq d
set : (p, q : Dim d) -> DimEq d -> DimEq d
set _ _ ZeroIsOne = ZeroIsOne
set (Th _ (K e _)) (Th _ (K f _)) (C eqs) = checkConst e f eqs
set (Th _ (K e el)) (Th j (B _)) (C eqs) = setConst j.fin e el eqs
set (Th i (B _)) (Th _ (K e el)) (C eqs) = setConst i.fin e el eqs
set (Th i (B il)) (Th j (B jl)) (C eqs) = setVar i.fin j.fin il jl eqs
set (K e eloc) (K f floc) (C eqs) = checkConst e f eqs
set (K e eloc) (B i iloc) (C eqs) = setConst i e eloc eqs
set (B i iloc) (K e eloc) (C eqs) = setConst i e eloc eqs
set (B i iloc) (B j jloc) (C eqs) = setVar i j iloc jloc eqs
public export %inline
@ -190,99 +185,116 @@ Split : Nat -> Type
Split d = (DimEq' d, DSubst (S d) d)
export %inline
split1 : {d : Nat} -> DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
split1 e loc eqs = case setConst 0 e loc eqs of
split1 : DimConst -> Loc -> DimEq' (S d) -> Maybe (Split d)
split1 e loc eqs = case setConst VZ e loc eqs of
ZeroIsOne => Nothing
C (eqs :< _) => Just (eqs, id (B loc) :< KT e loc)
C (eqs :< _) => Just (eqs, K e loc ::: id)
export %inline
split : {d : Nat} -> Loc -> DimEq' (S d) -> List (Split d)
split loc eqs = toList (split1 Zero loc eqs) <+> toList (split1 One loc eqs)
split1' : DimConst -> Loc -> DimEq' (S d) -> List (Split d)
split1' e loc eqs = toList $ split1 e loc eqs
export %inline
split : Loc -> DimEq' (S d) -> Bool -> List (Split d)
split loc eqs False = split1' Zero loc eqs
split loc eqs True = split1' Zero loc eqs <+> split1' One loc eqs
export
splits' : {d : Nat} -> Loc -> DimEq' d -> List (DSubst d 0)
splits' _ [<] = [[<]]
splits' loc eqs@(_ :< _) =
[th . ph | (eqs', th) <- split loc eqs, ph <- splits' loc eqs']
splits' : Loc -> DimEq' d -> FreeVars d -> List (DSubst d 0)
splits' _ [<] _ = [id]
splits' loc eqs@(_ :< _) us = do
let (us, u) = uncons us
(eqs', th) <- split loc eqs u
ph <- splits' loc eqs' us
pure $ th . ph
||| the Loc is put into each of the DimConsts
export %inline
splits : {d : Nat} -> Loc -> DimEq d -> List (DSubst d 0)
splits _ ZeroIsOne = []
splits loc (C eqs) = splits' loc eqs
splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
splits _ ZeroIsOne _ = []
splits loc (C eqs) fvs = splits' loc eqs fvs
-- private
-- 0 newGetShift : (d : Nat) -> (i : Fin d) -> (by : Shift d d') ->
-- getShift' by (new' {d}) i = Nothing
-- newGetShift (S d) FZ by = Refl
-- newGetShift (S d) (FS i) by = newGetShift d i (ssDown by)
private
0 newGetShift : (d : Nat) -> (i : Var d) -> (by : Shift d d') ->
getShift' by (new' {d}) i = Nothing
newGetShift (S d) VZ by = Refl
newGetShift (S d) (VS i) by = newGetShift d i (ssDown by)
-- export
-- 0 newGet' : (d : Nat) -> (i : Fin d) -> get' (new' {d}) i = Nothing
-- newGet' d i = newGetShift d i SZ
export
0 newGet' : (d : Nat) -> (i : Var d) -> get' (new' {d}) i = Nothing
newGet' d i = newGetShift d i SZ
-- export
-- 0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p
-- newGet d (K e _) = Refl
-- newGet d (B i _) = rewrite newGet' d i in Refl
export
0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p
newGet d (K e _) = Refl
newGet d (B i _) = rewrite newGet' d i in Refl
-- export
-- 0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs
-- setSelf p ZeroIsOne = Refl
-- setSelf (K Zero _) (C eqs) = Refl
-- setSelf (K One _) (C eqs) = Refl
-- setSelf (B i _) (C eqs) with (compareP i i) | (compare i.nat i.nat)
-- _ | IsLT lt | LT = absurd lt
-- _ | IsEQ | EQ = Refl
-- _ | IsGT gt | GT = absurd gt
export
0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs
setSelf p ZeroIsOne = Refl
setSelf (K Zero _) (C eqs) = Refl
setSelf (K One _) (C eqs) = Refl
setSelf (B i _) (C eqs) with (compareP i i) | (compare i.nat i.nat)
_ | IsLT lt | LT = absurd lt
_ | IsEQ | EQ = Refl
_ | IsGT gt | GT = absurd gt
parameters {opts : LayoutOpts}
private
prettyDVars : {d : Nat} -> BContext d -> Eff Pretty (SnocList (Doc opts))
prettyDVars = traverse prettyDBind . toSnocList'
private %inline
dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec
dimEqPrec vars eqs =
if length vars <= 1 && maybe True null eqs then Arg else Outer
private
prettyCst : {d : Nat} -> BContext d -> DimT d -> DimT d -> Eff Pretty (Doc opts)
prettyCst dnames p q =
hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
private
prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
prettyDVars' = traverse prettyDBind . toSnocList'
private
prettyCsts : {d : Nat} -> BContext d -> DimEq' d ->
Eff Pretty (SnocList (Doc opts))
prettyCsts [<] [<] = pure [<]
prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs
prettyCsts dnames (eqs :< Just q) =
[|prettyCsts (tail dnames) eqs :<
prettyCst dnames (BV 0 noLoc) (weak 1 q)|]
export
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
prettyDVars vars =
parensIfM (dimEqPrec vars Nothing) $
fillSeparateTight !commaD $ !(prettyDVars' vars)
export
prettyDimEq' : {d : Nat} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
prettyDimEq' dnames eqs = do
vars <- prettyDVars dnames
eqs <- prettyCsts dnames eqs
let prec = if length vars <= 1 && null eqs then Arg else Outer
parensIfM prec $ fillSeparateTight !commaD $ toList vars ++ toList eqs
private
prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
prettyCst dnames p q =
hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
export
prettyDimEq : {d : Nat} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
prettyDimEq dnames ZeroIsOne = do
vars <- prettyDVars dnames
cst <- prettyCst [<] (KT Zero noLoc) (KT One noLoc)
pure $ separateTight !commaD $ vars :< cst
prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
private
prettyCsts : {opts : _} -> BContext d -> DimEq' d ->
Eff Pretty (SnocList (Doc opts))
prettyCsts [<] [<] = pure [<]
prettyCsts dnames (eqs :< Nothing) = prettyCsts (tail dnames) eqs
prettyCsts dnames (eqs :< Just q) =
[|prettyCsts (tail dnames) eqs :< prettyCst dnames (BV 0 noLoc) (weakD 1 q)|]
export
prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts)
prettyDimEq' vars eqs = do
vars' <- prettyDVars' vars
eqs' <- prettyCsts vars eqs
parensIfM (dimEqPrec vars (Just eqs)) $
fillSeparateTight !commaD $ vars' ++ eqs'
export
prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts)
prettyDimEq dnames ZeroIsOne = do
vars <- prettyDVars' dnames
cst <- prettyCst [<] (K Zero noLoc) (K One noLoc)
pure $ separateTight !commaD $ vars :< cst
prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs
public export
wf' : {d : Nat} -> DimEq' d -> Bool
wf' [<] = True
wf' (eqs :< Nothing) = wf' eqs
wf' (eqs :< Just (Th _ (K {}))) = wf' eqs
wf' (eqs :< Just (Th i (B _))) = isNothing (get' eqs i.fin) && wf' eqs
wf' : DimEq' d -> Bool
wf' [<] = True
wf' (eqs :< Nothing) = wf' eqs
wf' (eqs :< Just (K e _)) = wf' eqs
wf' (eqs :< Just (B i _)) = isNothing (get' eqs i) && wf' eqs
public export
wf : {d : Nat} -> DimEq d -> Bool
wf : DimEq d -> Bool
wf ZeroIsOne = True
wf (C eqs) = wf' eqs

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,11 +1,11 @@
module Quox.Syntax.Shift
import public Quox.Syntax.Var
import public Quox.Thin
import public Quox.Var
import Data.Nat
import Data.So
import Data.DPair
import Data.Singleton
import Syntax.PreorderReasoning
%default total
@ -148,6 +148,25 @@ weakViaNat s by =
%transform "Shift.weak" Shift.weak = weakViaNat
export
getFrom : {to : Nat} -> Shift from to -> Singleton from
getFrom SZ = Val to
getFrom (SS by) = getFrom by
private
0 getFromViaNatProof : (by : Shift from to) -> from = to `minus` by.nat
getFromViaNatProof by = Calc $
|~ from
~~ minus (by.nat + from) by.nat ..<(minusPlus {})
~~ minus to by.nat ..<(cong (flip minus by.nat) (shiftDiff by))
private
getFromViaNat : {to : Nat} -> Shift from to -> Singleton from
getFromViaNat by = rewrite getFromViaNatProof by in Val _
%transform "Shift.getFrom" Shift.getFrom = getFromViaNat
public export
shift : Shift from to -> Var from -> Var to
shift SZ i = i
@ -180,11 +199,12 @@ by . SS bz = SS $ by . bz
private
0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
to = by.nat + bz.nat + from
compNatProof by bz =
trans (shiftDiff bz) $
trans (cong (bz.nat +) (shiftDiff by)) $
trans (plusAssociative bz.nat by.nat from) $
cong (+ from) (plusCommutative bz.nat by.nat)
compNatProof by bz = Calc $
|~ to
~~ bz.nat + mid ...(shiftDiff {})
~~ bz.nat + (by.nat + from) ...(cong (bz.nat +) (shiftDiff {}))
~~ bz.nat + by.nat + from ...(plusAssociative {})
~~ by.nat + bz.nat + from ...(cong (+ from) (plusCommutative {}))
private %inline
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
@ -207,7 +227,7 @@ compViaNatCorrect by (SS bz) =
%transform "Shift.(.)" Shift.(.) = compViaNat
infixl 8 //
export infixl 8 //
public export
interface CanShift f where
(//) : f from -> Shift from to -> f to
@ -222,15 +242,3 @@ namespace CanShift
public export %inline
[Const] CanShift (\_ => a) where x // _ = x
export
shiftOPE : {mask : Nat} -> (0 ope : OPE m n mask) ->
Shift n n' -> Subset Nat (OPE m n')
shiftOPE ope SZ = Element _ ope
shiftOPE ope (SS by) =
let Element _ ope = shiftOPE ope by in Element _ $ drop ope
export
CanShift (Thinned f) where
Th ope tm // by = Th (shiftOPE ope by).snd tm

View file

@ -1,11 +1,13 @@
module Quox.Syntax.Subst
import Quox.Thin
import Quox.Loc
import public Quox.Syntax.Shift
import Quox.Var
import Quox.Name
import Data.DPair
import Data.Nat
import Data.List
import Data.SnocVect
import Data.Singleton
import Derive.Prelude
%default total
@ -13,159 +15,155 @@ import Derive.Prelude
public export
Subst : (Nat -> Type) -> Nat -> Nat -> Type
Subst env from to = SnocVect from (Lazy (Thinned env to))
data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
Shift : Shift from to -> Subst env from to
(:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
%name Subst th, ph, ps
export infixr 7 !:::
||| in case the automatic laziness insertion gets confused
public export
Subst2 : (Nat -> Nat -> Type) -> Nat -> Nat -> Nat -> Type
Subst2 env d from to = SnocVect from (Lazy (Thinned2 env d to))
(!:::) : env to -> Subst env from to -> Subst env (S from) to
t !::: ts = t ::: ts
private
Repr : (Nat -> Type) -> Nat -> Type
Repr f to = (List (f to), Nat)
private
repr : Subst f from to -> Repr f to
repr (Shift by) = ([], by.nat)
repr (t ::: th) = let (ts, i) = repr th in (t::ts, i)
export Eq (f to) => Eq (Subst f from to) where (==) = (==) `on` repr
export Ord (f to) => Ord (Subst f from to) where compare = compare `on` repr
export Show (f to) => Show (Subst f from to) where show = show . repr
export infixl 8 //
public export
interface FromVar term => CanSubstSelf term where
(//) : term from -> Lazy (Subst term from to) -> term to
public export
get : Subst env f t -> Fin f -> Thinned env t
get (sx :< x) FZ = x
get (sx :< x) (FS i) = get sx i
getLoc : FromVar term => Subst term from to -> Var from -> Loc -> term to
getLoc (Shift by) i loc = fromVarLoc (shift by i) loc
getLoc (t ::: th) VZ _ = t
getLoc (t ::: th) (VS i) loc = getLoc th i loc
public export
interface FromVar (0 term : Nat -> Type) where
var : Loc -> term 1
public export
0 FromVar2 : (Nat -> Nat -> Type) -> Type
FromVar2 t = FromVar (t 0)
public export
varT : FromVar term => Fin n -> Loc -> Thinned term n
varT i loc = Th (one' i) (var loc)
public export
varT2 : FromVar2 term => Fin n -> Loc -> Thinned2 term d n
varT2 i loc = Th2 zero (one' i) (var loc)
infixl 8 //
namespace CanSubstSelf
public export
interface FromVar term => CanSubstSelf term where
(//) : {f : Nat} -> Thinned term f -> Subst term f t -> Thinned term t
namespace CanSubstSelf2
public export
interface FromVar2 term => CanSubstSelf2 term where
(//) : {f : Nat} -> Thinned2 term d f ->
Subst2 term d f t -> Thinned2 term d t
public export
(.) : {mid : Nat} -> CanSubstSelf f =>
Subst f from mid -> Subst f mid to -> Subst f from to
th . ph = map (\(Delay x) => x // ph) th
infixr 9 .%
public export
(.%) : {mid : Nat} -> CanSubstSelf2 f =>
Subst2 f d from mid -> Subst2 f d mid to -> Subst2 f d from to
th .% ph = map (\(Delay x) => x // ph) th
public export
tabulate : (n : Nat) -> SnocVect n (Fin n)
tabulate n = go n id where
go : (n : Nat) -> (Fin n -> Fin n') -> SnocVect n (Fin n')
go 0 f = [<]
go (S n) f = go n (f . FS) :< f FZ
public export
id : FromVar term => {n : Nat} -> (under : Nat) -> Loc ->
Subst term n (n + under)
id under loc =
map (\i => delay $ varT (weakenN under i) loc) (tabulate n)
public export
id2 : FromVar2 term => {n : Nat} -> Loc -> Subst2 term d n n
id2 loc = map (\i => delay $ varT2 i loc) $ tabulate n
export
select : {n, mask : Nat} -> (0 ope : OPE m n mask) ->
SnocVect n a -> SnocVect m a
select ope sx with %syntactic (view ope)
select _ [<] | StopV = [<]
select _ (sx :< x) | DropV _ ope = select ope sx
select _ (sx :< x) | KeepV _ ope = select ope sx :< x
export
opeToFins : {n, mask : Nat} ->
(0 ope : OPE m n mask) -> SnocVect m (Fin n)
opeToFins ope = select ope $ tabulate n
export
shift : FromVar term => {from : Nat} ->
(n : Nat) -> Loc -> Subst term from (n + from)
shift n loc = map (\i => delay $ varT (shift n i) loc) $ tabulate from
public export
pushN : CanSubstSelf term => {to : Nat} -> (by : Nat) ->
Subst term from to -> Loc -> Subst term (by + from) (by + to)
pushN by th loc =
rewrite plusCommutative by from in
(th . shift by loc) ++ id to loc
public export %inline
push : CanSubstSelf f => {to : Nat} ->
Subst f from to -> Loc -> Subst f (S from) (S to)
push = pushN 1
CanSubstSelf Var where
i // Shift by = shift by i
VZ // (t ::: th) = t
VS i // (t ::: th) = i // th
public export %inline
one : Thinned f n -> Subst f 1 n
one x = [< x]
shift : (by : Nat) -> Subst env from (by + from)
shift by = Shift $ fromNat by
public export %inline
shift0 : (by : Nat) -> Subst env 0 by
shift0 by = rewrite sym $ plusZeroRightNeutral by in Shift $ fromNat by
public export
(.) : CanSubstSelf f => Subst f from mid -> Subst f mid to -> Subst f from to
Shift by . Shift bz = Shift $ by . bz
Shift SZ . ph = ph
Shift (SS by) . (t ::: th) = Shift by . th
(t ::: th) . ph = (t // ph) ::: (th . ph)
public export %inline
id : Subst f n n
id = shift 0
public export
traverse : Applicative m =>
(f to -> m (g to)) -> Subst f from to -> m (Subst g from to)
traverse f (Shift by) = pure $ Shift by
traverse f (t ::: th) = [|f t !::: traverse f th|]
-- not in terms of traverse because this map can maintain laziness better
public export
map : (f to -> g to) -> Subst f from to -> Subst g from to
map f (Shift by) = Shift by
map f (t ::: th) = f t ::: map f th
public export %inline
push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
push loc th = fromVarLoc VZ loc ::: (th . shift 1)
-- [fixme] a better way to do this?
public export
pushN : CanSubstSelf f => (s : Nat) -> Loc ->
Subst f from to -> Subst f (s + from) (s + to)
pushN 0 _ th = th
pushN (S s) loc th =
rewrite plusSuccRightSucc s from in
rewrite plusSuccRightSucc s to in
pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1)
public export
drop1 : Subst f (S from) to -> Subst f from to
drop1 (Shift by) = Shift $ ssDown by
drop1 (t ::: th) = th
public export
fromSnocVect : SnocVect s (f n) -> Subst f (s + n) n
fromSnocVect [<] = id
fromSnocVect (xs :< x) = x ::: fromSnocVect xs
public export %inline
one : f n -> Subst f (S n) n
one x = fromSnocVect [< x]
||| whether two substitutions with the same codomain have the same domain
export
cmpShape : SnocVect m a -> SnocVect n a -> Either Ordering (m = n)
cmpShape [<] [<] = Right Refl
cmpShape [<] (sx :< _) = Left LT
cmpShape (sx :< _) [<] = Left GT
cmpShape (sx :< _) (sy :< _) = cong S <$> cmpShape sx sy
getFrom : {to : Nat} -> Subst _ from to -> Singleton from
getFrom (Shift by) = getFrom by
getFrom (t ::: th) = [|S $ getFrom th|]
||| whether two substitutions with the same codomain have the same shape
||| (the same number of terms and the same shift at the end). if so, they
||| also have the same domain
export
cmpShape : Subst env from1 to -> Subst env from2 to ->
Either Ordering (from1 = from2)
cmpShape (Shift by) (Shift bz) = cmpLen by bz
cmpShape (Shift _) (_ ::: _) = Left LT
cmpShape (_ ::: _) (Shift _) = Left GT
cmpShape (_ ::: th) (_ ::: ph) = map (\x => cong S x) $ cmpShape th ph
public export
record WithSubst tm env n where
constructor Sub
term : tm from
subst : Subst env from n
subst : Lazy (Subst env from n)
{-
export
(forall n. Eq (env n), forall n. Eq (tm n)) =>
Eq (WithSubst tm env n) where
(Eq (env n), forall n. Eq (tm n)) => Eq (WithSubst tm env n) where
Sub t1 s1 == Sub t2 s2 =
case cmpShape s1 s2 of
Left _ => False
Right Refl =>
t1 == t2 && concat @{All} (zipWith ((==) `on` force) s1 s2)
Right Refl => t1 == t2 && s1 == s2
export
(forall n. Ord (env n), forall n. Ord (tm n)) =>
Ord (WithSubst tm env n) where
(Ord (env n), forall n. Ord (tm n)) => Ord (WithSubst tm env n) where
Sub t1 s1 `compare` Sub t2 s2 =
case cmpShape s1 s2 of
Left o => o
Right Refl =>
compare t1 t2 <+> concat (zipWith (compare `on` force) s1 s2)
Right Refl => compare (t1, s1) (t2, s2)
export %hint
ShowWithSubst : {n : Nat} ->
(forall n. Show (env n), forall n. Show (tm n)) =>
ShowWithSubst : (Show (env n), forall n. Show (tm n)) =>
Show (WithSubst tm env n)
ShowWithSubst = deriveShow where
Show (Lazy (Thinned env n)) where showPrec d = showPrec d . force
-}
public export
record WithSubst2 tm env d n where
constructor Sub2
term : tm d from
subst : Subst2 env d from n
ShowWithSubst = deriveShow

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,7 +1,7 @@
module Quox.Syntax.Term.Base
import public Quox.Thin
import public Quox.Syntax.Var
import public Quox.Var
import public Quox.Scoped
import public Quox.Syntax.Shift
import public Quox.Syntax.Subst
import public Quox.Syntax.Qty
@ -19,6 +19,9 @@ import Data.Maybe
import Data.Nat
import public Data.So
import Data.String
import public Data.SortedMap
import public Data.SortedMap.Dependent
import public Data.SortedSet
import Derive.Prelude
%default total
@ -44,344 +47,406 @@ TagVal : Type
TagVal = String
||| type-checkable terms, which consists of types and constructor forms.
|||
||| first argument `d` is dimension scope size; second `n` is term scope size
public export
data Term : (d, n : Nat) -> Type
%name Term s, t, r
mutual
public export
TSubst : TSubstLike
TSubst d = Subst $ \n => Elim d n
||| inferrable terms, which consists of elimination forms like application and
||| `case` (as well as other terms with an annotation)
|||
||| first argument `d` is dimension scope size; second `n` is term scope size
public export
data Elim : (d, n : Nat) -> Type
%name Elim e, f
||| first argument `d` is dimension scope size;
||| second `n` is term scope size
public export
data Term : (d, n : Nat) -> Type where
||| type of types
TYPE : (l : Universe) -> (loc : Loc) -> Term d n
||| IO state token. this is a builtin because otherwise #[main] being a
||| builtin makes no sense
IOState : (loc : Loc) -> Term d n
||| function type
Pi : (qty : Qty) -> (arg : Term d n) ->
(res : ScopeTerm d n) -> (loc : Loc) -> Term d n
||| function term
Lam : (body : ScopeTerm d n) -> (loc : Loc) -> Term d n
||| pair type
Sig : (fst : Term d n) -> (snd : ScopeTerm d n) -> (loc : Loc) -> Term d n
||| pair value
Pair : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
||| enumeration type
Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term d n
||| enumeration value
Tag : (tag : TagVal) -> (loc : Loc) -> Term d n
||| equality type
Eq : (ty : DScopeTerm d n) -> (l, r : Term d n) -> (loc : Loc) -> Term d n
||| equality term
DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n
||| natural numbers (temporary until 𝐖 gets added)
NAT : (loc : Loc) -> Term d n
Nat : (val : Nat) -> (loc : Loc) -> Term d n
Succ : (p : Term d n) -> (loc : Loc) -> Term d n
||| strings
STRING : (loc : Loc) -> Term d n
Str : (str : String) -> (loc : Loc) -> Term d n
||| "box" (package a value up with a certain quantity)
BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n
Box : (val : Term d n) -> (loc : Loc) -> Term d n
Let : (qty : Qty) -> (rhs : Elim d n) ->
(body : ScopeTerm d n) -> (loc : Loc) -> Term d n
||| elimination
E : (e : Elim d n) -> Term d n
||| term closure/suspended substitution
CloT : WithSubst (Term d) (Elim d) n -> Term d n
||| dimension closure/suspended substitution
DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
%name Term s, t, r
||| first argument `d` is dimension scope size, second `n` is term scope size
public export
data Elim : (d, n : Nat) -> Type where
||| free variable, possibly with a displacement (see @crude, or @mugen for a
||| more abstract and formalised take)
|||
||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim d n
||| bound variable
B : (i : Var n) -> (loc : Loc) -> Elim d n
||| term application
App : (fun : Elim d n) -> (arg : Term d n) -> (loc : Loc) -> Elim d n
||| pair destruction
|||
||| `CasePair 𝜋 𝑒 ([𝑟], 𝐴) ([𝑥, 𝑦], 𝑡)` is
||| `𝐜𝐚𝐬𝐞 𝜋 · 𝑒 𝐫𝐞𝐭𝐮𝐫𝐧 𝑟𝐴 𝐨𝐟 { (𝑥, 𝑦) ⇒ 𝑡 }`
CasePair : (qty : Qty) -> (pair : Elim d n) ->
(ret : ScopeTerm d n) ->
(body : ScopeTermN 2 d n) ->
(loc : Loc) ->
Elim d n
||| first element of a pair. only works in non-linear contexts.
Fst : (pair : Elim d n) -> (loc : Loc) -> Elim d n
||| second element of a pair. only works in non-linear contexts.
Snd : (pair : Elim d n) -> (loc : Loc) -> Elim d n
||| enum matching
CaseEnum : (qty : Qty) -> (tag : Elim d n) ->
(ret : ScopeTerm d n) ->
(arms : CaseEnumArms d n) ->
(loc : Loc) ->
Elim d n
||| nat matching
CaseNat : (qty, qtyIH : Qty) -> (nat : Elim d n) ->
(ret : ScopeTerm d n) ->
(zero : Term d n) ->
(succ : ScopeTermN 2 d n) ->
(loc : Loc) ->
Elim d n
||| unboxing
CaseBox : (qty : Qty) -> (box : Elim d n) ->
(ret : ScopeTerm d n) ->
(body : ScopeTerm d n) ->
(loc : Loc) ->
Elim d n
||| dim application
DApp : (fun : Elim d n) -> (arg : Dim d) -> (loc : Loc) -> Elim d n
||| type-annotated term
Ann : (tm, ty : Term d n) -> (loc : Loc) -> Elim d n
||| coerce a value along a type equality, or show its coherence
||| [@xtt; §2.1.1]
Coe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
(val : Term d n) -> (loc : Loc) -> Elim d n
||| "generalised composition" [@xtt; §2.1.2]
Comp : (ty : Term d n) -> (p, q : Dim d) ->
(val : Term d n) -> (r : Dim d) ->
(zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
||| match on types. needed for b.s. of coercions [@xtt; §2.2]
TypeCase : (ty : Elim d n) -> (ret : Term d n) ->
(arms : TypeCaseArms d n) -> (def : Term d n) ->
(loc : Loc) ->
Elim d n
||| term closure/suspended substitution
CloE : WithSubst (Elim d) (Elim d) n -> Elim d n
||| dimension closure/suspended substitution
DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
%name Elim e, f
public export
CaseEnumArms : TermLike
CaseEnumArms d n = SortedMap TagVal (Term d n)
public export
TypeCaseArms : TermLike
TypeCaseArms d n = SortedDMap TyConKind (\k => TypeCaseArmBody k d n)
public export
TypeCaseArm : TermLike
TypeCaseArm d n = (k ** TypeCaseArmBody k d n)
public export
TypeCaseArmBody : TyConKind -> TermLike
TypeCaseArmBody k = ScopeTermN (arity k)
public export
ScopeTermN : Nat -> TermLike
ScopeTermN s d n = ScopedN s (\n => Term d n) n
public export
ScopeTermN, DScopeTermN : Nat -> TermLike
ScopeTermN s d n = Scoped s (Term d) n
DScopeTermN s d n = Scoped s (\d => Term d n) d
public export
DScopeTermN : Nat -> TermLike
DScopeTermN s d n = ScopedN s (\d => Term d n) d
public export
ScopeTerm, DScopeTerm : TermLike
ScopeTerm = ScopeTermN 1
DScopeTerm = DScopeTermN 1
public export
ScopeTerm : TermLike
ScopeTerm = ScopeTermN 1
mutual
export %hint
EqTerm : Eq (Term d n)
EqTerm = assert_total {a = Eq (Term d n)} deriveEq
public export
DScopeTerm : TermLike
DScopeTerm = DScopeTermN 1
export %hint
EqElim : Eq (Elim d n)
EqElim = assert_total {a = Eq (Elim d n)} deriveEq
mutual
export %hint
ShowTerm : Show (Term d n)
ShowTerm = assert_total {a = Show (Term d n)} deriveShow
public export
TermT : TermLike
TermT = Thinned2 (\d, n => Term d n)
public export
ElimT : TermLike
ElimT = Thinned2 (\d, n => Elim d n)
public export
DimArg : TermLike
DimArg d n = Dim d
data Term where
||| type of types
TYPE : (l : Universe) -> (loc : Loc) -> Term 0 0
||| function type
Pi : Qty -> Subterms [Term, ScopeTerm] d n -> Loc -> Term d n
||| function value
Lam : ScopeTerm d n -> Loc -> Term d n
||| pair type
Sig : Subterms [Term, ScopeTerm] d n -> Loc -> Term d n
||| pair value
Pair : Subterms [Term, Term] d n -> Loc -> Term d n
||| enum type
Enum : List TagVal -> Loc -> Term 0 0
||| enum value
Tag : TagVal -> Loc -> Term 0 0
||| equality type
Eq : Subterms [DScopeTerm, Term, Term] d n -> Loc -> Term d n
||| equality value
DLam : DScopeTerm d n -> Loc -> Term d n
||| natural numbers (temporary until 𝐖 gets added)
Nat : Loc -> Term 0 0
Zero : Loc -> Term 0 0
Succ : Term d n -> Loc -> Term 0 0
||| package a value with a quantity
||| e.g. a value of [ω. A], when unpacked, can be used ω times,
||| even if the box itself is linear
BOX : Qty -> Term d n -> Loc -> Term d n
Box : Term d n -> Loc -> Term d n
E : Elim d n -> Term d n
||| term closure/suspended substitution
CloT : WithSubst2 Term Elim d n -> Term d n
||| dimension closure/suspended substitution
DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
public export
data Elim where
||| free variable, possibly with a displacement (see @crude, or @mugen for a
||| more abstract and formalised take)
|||
||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
F : Name -> Universe -> Loc -> Elim 0 0
||| bound variable
B : Loc -> Elim 0 1
||| term application
App : Subterms [Elim, Term] d n -> Loc -> Elim d n
||| pair match
||| - the subterms are, in order: [head, return type, body]
||| - the quantity is that of the head, and since pairs only have one
||| constructor, can be 0
CasePair : Qty -> Subterms [Elim, ScopeTerm, ScopeTermN 2] d n ->
Loc -> Elim d n
||| enum match
CaseEnum : Qty -> (arms : List TagVal) ->
Subterms (Elim :: ScopeTerm :: (Term <$ arms)) d n ->
Loc -> Elim d n
||| nat match
CaseNat : Qty -> Qty ->
Subterms [Elim, ScopeTerm, Term, ScopeTermN 2] d n ->
Loc -> Elim d n
||| box match
CaseBox : Qty -> Subterms [Elim, ScopeTerm, ScopeTerm] d n -> Loc -> Elim d n
||| dim application
DApp : Subterms [Elim, DimArg] d n -> Loc -> Elim d n
||| type-annotated term
Ann : Subterms [Term, Term] d n -> Loc -> Elim d n
||| coerce a value along a type equality, or show its coherence
||| [@xtt; §2.1.1]
Coe : Subterms [DScopeTerm, DimArg, DimArg, Term] d n ->
Loc -> Elim d n
||| "generalised composition" [@xtt; §2.1.2]
Comp : Subterms [Term, DimArg, DimArg, Term,
DimArg, DScopeTerm, DScopeTerm] d n ->
Loc -> Elim d n
||| match on types. needed for b.s. of coercions [@xtt; §2.2]
TypeCase : Subterms [Elim, Term, -- head, type
Term, -- ★
ScopeTermN 2, -- pi
ScopeTermN 2, -- sig
Term, -- enum
ScopeTermN 5, -- eq
Term, -- nat
ScopeTerm -- box
] d n -> Loc -> Elim d n
||| term closure/suspended substitution
CloE : WithSubst2 Elim Elim d n -> Elim d n
||| dimension closure/suspended substitution
DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
-- this kills the idris ☹
-- export %hint
-- EqTerm : Eq (Term d n)
-- export %hint
-- EqElim : Eq (Elim d n)
-- EqTerm = deriveEq
-- EqElim = deriveEq
-- mutual
-- export %hint
-- ShowTerm : Show (Term d n)
-- ShowTerm = assert_total {a = Show (Term d n)} deriveShow
-- export %hint
-- ShowElim : Show (Elim d n)
-- ShowElim = assert_total {a = Show (Elim d n)} deriveShow
-- ||| scope which ignores all its binders
-- public export %inline
-- SN : {s : Nat} -> f n -> Scoped s f n
-- SN = S (replicate s $ BN Unused noLoc) . N
-- ||| scope which uses its binders
-- public export %inline
-- SY : BContext s -> f (s + n) -> Scoped s f n
-- SY ns = S ns . Y
-- public export %inline
-- name : Scoped 1 f n -> BindName
-- name (S [< x] _) = x
-- public export %inline
-- (.name) : Scoped 1 f n -> BindName
-- s.name = name s
-- ||| more convenient Pi
-- public export %inline
-- PiY : (qty : Qty) -> (x : BindName) ->
-- (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
-- PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc}
-- ||| more convenient Lam
-- public export %inline
-- LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
-- LamY {x, body, loc} = Lam {body = SY [< x] body, loc}
-- public export %inline
-- LamN : (body : Term d n) -> (loc : Loc) -> Term d n
-- LamN {body, loc} = Lam {body = SN body, loc}
-- ||| non dependent function type
-- public export %inline
-- Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n
-- Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}
-- ||| more convenient Sig
-- public export %inline
-- SigY : (x : BindName) -> (fst : Term d n) ->
-- (snd : Term d (S n)) -> (loc : Loc) -> Term d n
-- SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}
-- ||| non dependent pair type
-- public export %inline
-- And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
-- And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}
-- ||| more convenient Eq
-- public export %inline
-- EqY : (i : BindName) -> (ty : Term (S d) n) ->
-- (l, r : Term d n) -> (loc : Loc) -> Term d n
-- EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}
-- ||| more convenient DLam
-- public export %inline
-- DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
-- DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}
-- public export %inline
-- DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
-- DLamN {body, loc} = DLam {body = SN body, loc}
-- ||| non dependent equality type
-- public export %inline
-- Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
-- Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
||| same as `F` but as a term
public export %inline
FT : Name -> Universe -> Loc -> Term 0 0
FT x u loc = E $ F x u loc
||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))`
public export %inline
BV : (i : Fin n) -> (loc : Loc) -> ElimT d n
BV i loc = Th2 zero (one' i) $ B loc
||| same as `BV` but as a term
public export %inline
BVT : (i : Fin n) -> (loc : Loc) -> TermT d n
BVT i loc = Th2 zero (one' i) $ E $ B loc
public export
makeNat : Nat -> Loc -> Term 0 0
makeNat 0 loc = Zero loc
makeNat (S k) loc = Succ (makeNat k loc) loc
export %hint
ShowElim : Show (Elim d n)
ShowElim = assert_total {a = Show (Elim d n)} deriveShow
export
Located (Elim d n) where
(F _ _ loc).loc = loc
(B loc).loc = loc
(App _ loc).loc = loc
(CasePair _ _ loc).loc = loc
(CaseEnum _ _ _ loc).loc = loc
(CaseNat _ _ _ loc).loc = loc
(CaseBox _ _ loc).loc = loc
(DApp _ loc).loc = loc
(Ann _ loc).loc = loc
(Coe _ loc).loc = loc
(Comp _ loc).loc = loc
(TypeCase _ loc).loc = loc
(CloE (Sub2 e _)).loc = e.loc
(DCloE (Sub e _)).loc = e.loc
(F _ _ loc).loc = loc
(B _ loc).loc = loc
(App _ _ loc).loc = loc
(CasePair _ _ _ _ loc).loc = loc
(Fst _ loc).loc = loc
(Snd _ loc).loc = loc
(CaseEnum _ _ _ _ loc).loc = loc
(CaseNat _ _ _ _ _ _ loc).loc = loc
(CaseBox _ _ _ _ loc).loc = loc
(DApp _ _ loc).loc = loc
(Ann _ _ loc).loc = loc
(Coe _ _ _ _ loc).loc = loc
(Comp _ _ _ _ _ _ _ loc).loc = loc
(TypeCase _ _ _ _ loc).loc = loc
(CloE (Sub e _)).loc = e.loc
(DCloE (Sub e _)).loc = e.loc
export
Located (Term d n) where
(TYPE _ loc).loc = loc
(Pi _ _ loc).loc = loc
(IOState loc).loc = loc
(Pi _ _ _ loc).loc = loc
(Lam _ loc).loc = loc
(Sig _ loc).loc = loc
(Pair _ loc).loc = loc
(Sig _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ loc).loc = loc
(Nat loc).loc = loc
(Zero loc).loc = loc
(NAT loc).loc = loc
(Nat _ loc).loc = loc
(STRING loc).loc = loc
(Str _ loc).loc = loc
(Succ _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(Let _ _ _ loc).loc = loc
(E e).loc = e.loc
(CloT (Sub2 t _)).loc = t.loc
(CloT (Sub t _)).loc = t.loc
(DCloT (Sub t _)).loc = t.loc
export
Located1 f => Located (ScopedBody s f n) where
(Y t).loc = t.loc
(N t).loc = t.loc
export
Located1 f => Located (Scoped s f n) where
t.loc = t.body.loc
export
Relocatable (Elim d n) where
setLoc loc (F x u _) = F x u loc
setLoc loc (B _) = B loc
setLoc loc (App ts _) = App ts loc
setLoc loc (CasePair qty ts _) = CasePair qty ts loc
setLoc loc (CaseEnum qty arms ts _) = CaseEnum qty arms ts loc
setLoc loc (CaseNat qty qtyIH ts _) = CaseNat qty qtyIH ts loc
setLoc loc (CaseBox qty ts _) = CaseBox qty ts loc
setLoc loc (DApp ts _) = DApp ts loc
setLoc loc (Ann ts _) = Ann ts loc
setLoc loc (Coe ts _) = Coe ts loc
setLoc loc (Comp ts _) = Comp ts loc
setLoc loc (TypeCase ts _) = TypeCase ts loc
setLoc loc (CloE (Sub2 term subst)) = CloE $ Sub2 (setLoc loc term) subst
setLoc loc (DCloE (Sub term subst)) = DCloE $ Sub (setLoc loc term) subst
setLoc loc (F x u _) = F x u loc
setLoc loc (B i _) = B i loc
setLoc loc (App fun arg _) = App fun arg loc
setLoc loc (CasePair qty pair ret body _) =
CasePair qty pair ret body loc
setLoc loc (Fst pair _) = Fst pair loc
setLoc loc (Snd pair _) = Fst pair loc
setLoc loc (CaseEnum qty tag ret arms _) =
CaseEnum qty tag ret arms loc
setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
CaseNat qty qtyIH nat ret zero succ loc
setLoc loc (CaseBox qty box ret body _) =
CaseBox qty box ret body loc
setLoc loc (DApp fun arg _) =
DApp fun arg loc
setLoc loc (Ann tm ty _) =
Ann tm ty loc
setLoc loc (Coe ty p q val _) =
Coe ty p q val loc
setLoc loc (Comp ty p q val r zero one _) =
Comp ty p q val r zero one loc
setLoc loc (TypeCase ty ret arms def _) =
TypeCase ty ret arms def loc
setLoc loc (CloE (Sub term subst)) =
CloE $ Sub (setLoc loc term) subst
setLoc loc (DCloE (Sub term subst)) =
DCloE $ Sub (setLoc loc term) subst
export
Relocatable (Term d n) where
setLoc loc (TYPE l _) = TYPE l loc
setLoc loc (Pi qty ts _) = Pi qty ts loc
setLoc loc (Lam body _) = Lam body loc
setLoc loc (Sig ts _) = Sig ts loc
setLoc loc (Pair ts _) = Pair ts loc
setLoc loc (Enum cases _) = Enum cases loc
setLoc loc (Tag tag _) = Tag tag loc
setLoc loc (Eq ts _) = Eq ts loc
setLoc loc (DLam body _) = DLam body loc
setLoc loc (Nat _) = Nat loc
setLoc loc (Zero _) = Zero loc
setLoc loc (Succ p _) = Succ p loc
setLoc loc (BOX qty ty _) = BOX qty ty loc
setLoc loc (Box val _) = Box val loc
setLoc loc (E e) = E $ setLoc loc e
setLoc loc (CloT (Sub2 term subst)) = CloT $ Sub2 (setLoc loc term) subst
setLoc loc (TYPE l _) = TYPE l loc
setLoc loc (IOState _) = IOState loc
setLoc loc (Pi qty arg res _) = Pi qty arg res loc
setLoc loc (Lam body _) = Lam body loc
setLoc loc (Sig fst snd _) = Sig fst snd loc
setLoc loc (Pair fst snd _) = Pair fst snd loc
setLoc loc (Enum cases _) = Enum cases loc
setLoc loc (Tag tag _) = Tag tag loc
setLoc loc (Eq ty l r _) = Eq ty l r loc
setLoc loc (DLam body _) = DLam body loc
setLoc loc (NAT _) = NAT loc
setLoc loc (Nat n _) = Nat n loc
setLoc loc (Succ p _) = Succ p loc
setLoc loc (STRING _) = STRING loc
setLoc loc (Str s _) = Str s loc
setLoc loc (BOX qty ty _) = BOX qty ty loc
setLoc loc (Box val _) = Box val loc
setLoc loc (Let qty rhs body _) = Let qty rhs body loc
setLoc loc (E e) = E $ setLoc loc e
setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
export
Relocatable1 f => Relocatable (ScopedBody s f n) where
setLoc loc (Y body) = Y $ setLoc loc body
setLoc loc (N body) = N $ setLoc loc body
export
Relocatable1 f => Relocatable (Scoped s f n) where
setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
||| more convenient Pi
public export %inline
PiY : (qty : Qty) -> (x : BindName) ->
(arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc}
||| more convenient Lam
public export %inline
LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
LamY {x, body, loc} = Lam {body = SY [< x] body, loc}
public export %inline
LamN : (body : Term d n) -> (loc : Loc) -> Term d n
LamN {body, loc} = Lam {body = SN body, loc}
||| non dependent function type
public export %inline
Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n
Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}
||| more convenient Sig
public export %inline
SigY : (x : BindName) -> (fst : Term d n) ->
(snd : Term d (S n)) -> (loc : Loc) -> Term d n
SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}
||| non dependent pair type
public export %inline
And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n
And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}
||| more convenient Eq
public export %inline
EqY : (i : BindName) -> (ty : Term (S d) n) ->
(l, r : Term d n) -> (loc : Loc) -> Term d n
EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}
||| more convenient DLam
public export %inline
DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}
public export %inline
DLamN : (body : Term d n) -> (loc : Loc) -> Term d n
DLamN {body, loc} = DLam {body = SN body, loc}
||| more convenient Coe
public export %inline
CoeY : (i : BindName) -> (ty : Term (S d) n) ->
(p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
CoeY {i, ty, p, q, val, loc} = Coe {ty = SY [< i] ty, p, q, val, loc}
||| non dependent equality type
public export %inline
Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n
Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
||| same as `F` but as a term
public export %inline
FT : Name -> Universe -> Loc -> Term d n
FT x u loc = E $ F x u loc
||| same as `B` but as a term
public export %inline
BT : Var n -> (loc : Loc) -> Term d n
BT i loc = E $ B i loc
||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))`
public export %inline
BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n
BV i loc = B (V i) loc
||| same as `BV` but as a term
public export %inline
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n
BVT i loc = E $ BV i loc
public export %inline
Zero : Loc -> Term d n
Zero = Nat 0
public export %inline
enum : List TagVal -> Loc -> Term d n
enum ts loc = Enum (SortedSet.fromList ts) loc
public export %inline
typeCase : Elim d n -> Term d n ->
List (TypeCaseArm d n) -> Term d n -> Loc -> Elim d n
typeCase ty ret arms def loc = TypeCase ty ret (fromList arms) def loc
public export %inline
typeCase1Y : Elim d n -> Term d n ->
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
(loc : Loc) ->
{default (NAT loc) def : Term d n} ->
Elim d n
typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc

View file

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

View file

@ -2,462 +2,383 @@ module Quox.Syntax.Term.Subst
import Quox.No
import Quox.Syntax.Term.Base
import Quox.Syntax.Subst
import Data.SnocVect
import Data.Singleton
%default total
namespace CanDSubst
public export
interface CanDSubst (0 tm : TermLike) where
(//) : tm d1 n -> Lazy (DSubst d1 d2) -> tm d2 n
infixl 8 ///
||| does the minimal reasonable work:
||| - deletes the closure around an atomic constant like `TYPE`
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level dim-closure
||| - otherwise, wraps in a new closure
export
CanDSubst Term where
s // Shift SZ = s
TYPE l loc // _ = TYPE l loc
DCloT (Sub s ph) // th = DCloT $ Sub s $ ph . th
s // th = DCloT $ Sub s th
parameters {0 f : Nat -> Nat -> Type}
private
th0 : f 0 0 -> Thinned2 f d n
th0 = Th2 zero zero
private
subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
subDArgs e th = DCloE $ Sub e th
private
th1 : {d, n : Nat} -> f d n -> Thinned2 f d n
th1 = Th2 id' id'
||| does the minimal reasonable work:
||| - deletes the closure around a term variable
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level dim-closure
||| - immediately looks up bound variables in a
||| top-level sequence of dimension applications
||| - otherwise, wraps in a new closure
export
CanDSubst Elim where
e // Shift SZ = e
F x u loc // _ = F x u loc
B i loc // _ = B i loc
e@(DApp {}) // th = subDArgs e th
DCloE (Sub e ph) // th = DCloE $ Sub e $ ph . th
e // th = DCloE $ Sub e th
private dsubTerm : {d1, d2, n : Nat} -> Term d1 n -> DSubst d1 d2 -> TermT d2 n
private dsubElim : {d1, d2, n : Nat} -> Elim d1 n -> DSubst d1 d2 -> ElimT d2 n
namespace DSubst.ScopeTermN
export %inline
(//) : ScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
ScopeTermN s d2 n
S ns (Y body) // th = S ns $ Y $ body // th
S ns (N body) // th = S ns $ N $ body // th
dsubTerm (TYPE l loc) th = th0 $ TYPE l loc
dsubTerm (Enum strs loc) th = th0 $ Enum strs loc
dsubTerm (Tag str loc) th = th0 $ Tag str loc
dsubTerm (Nat loc) th = th0 $ Nat loc
dsubTerm (Zero loc) th = th0 $ Zero loc
dsubTerm (E e) th =
let Th2 dope tope e' = dsubElim e th in
Th2 dope tope $ E e'
dsubTerm (DCloT (Sub t ph)) th = th1 $ DCloT $ Sub t $ ph . th
dsubTerm t th = th1 $ DCloT $ Sub t th
namespace DSubst.DScopeTermN
export %inline
(//) : {s : Nat} ->
DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
DScopeTermN s d2 n
S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
S ns (N body) // th = S ns $ N $ body // th
dsubElim (F x l loc) th = th0 $ F x l loc
dsubElim (B loc) th = Th2 zero id' $ B loc
dsubElim (DCloE (Sub e ph)) th = th1 $ DCloE $ Sub e $ ph . th
dsubElim e th = th1 $ DCloE $ Sub e th
mutual
namespace Term
export
(///) : {d1, d2, n : Nat} -> TermT d1 n -> DSubst d1 d2 -> TermT d2 n
Th2 dope tope term /// th =
let Val tscope = appOpe n tope; Val dscope = appOpe d1 dope
Th2 dope' tope' term' = dsubTerm term (select dope th)
in
Th2 dope' (tope . tope') term'
export %inline FromVar (Elim d) where fromVarLoc = B
export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
namespace Elim
export
(///) : {d1, d2, n : Nat} -> ElimT d1 n -> DSubst d1 d2 -> ElimT d2 n
Th2 dope tope elim /// th =
let Val tscope = appOpe n tope; Val dscope = appOpe d1 dope
Th2 dope' tope' elim' = dsubElim elim (select dope th)
in
Th2 dope' (tope . tope') elim'
||| does the minimal reasonable work:
||| - deletes the closure around a *free* name
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level closure
||| - immediately looks up a bound variable
||| - otherwise, wraps in a new closure
export
CanSubstSelf (Elim d) where
F x u loc // _ = F x u loc
B i loc // th = getLoc th i loc
CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th
e // th = case force th of
Shift SZ => e
th => CloE $ Sub e th
namespace CanTSubst
public export
interface CanTSubst (0 tm : TermLike) where
(//) : tm d n1 -> Lazy (TSubst d n1 n2) -> tm d n2
||| does the minimal reasonable work:
||| - deletes the closure around an atomic constant like `TYPE`
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level closure
||| - goes inside `E` in case it is a simple variable or something
||| - otherwise, wraps in a new closure
export
CanTSubst Term where
TYPE l loc // _ = TYPE l loc
E e // th = E $ e // th
CloT (Sub s ph) // th = CloT $ Sub s $ ph . th
s // th = case force th of
Shift SZ => s
th => CloT $ Sub s th
namespace ScopeTermN
export %inline
(//) : {s : Nat} ->
ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
ScopeTermN s d n2
S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th
S ns (N body) // th = S ns $ N $ body // th
namespace DScopeTermN
export %inline
(//) : {s : Nat} ->
DScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> DScopeTermN s d n2
S ns (Y body) // th = S ns $ Y $ body // map (// shift s) th
S ns (N body) // th = S ns $ N $ body // th
export %inline CanShift (Term d) where s // by = s // Shift by
export %inline CanShift (Elim d) where e // by = e // Shift by
export %inline CanShift (flip Term n) where s // by = s // Shift by
export %inline CanShift (flip Elim n) where e // by = e // Shift by
export %inline
{s : Nat} -> CanShift (ScopeTermN s d) where
b // by = b // Shift by
export %inline
comp : DSubst d1 d2 -> TSubst d1 n1 mid -> TSubst d2 mid n2 -> TSubst d2 n1 n2
comp th ps ph = map (// th) ps . ph
public export %inline
dweakT : (by : Nat) -> Term d n -> Term (by + d) n
dweakT by t = t // shift by
public export %inline
dweakS : (by : Nat) -> ScopeTermN s d n -> ScopeTermN s (by + d) n
dweakS by t = t // shift by
public export %inline
dweakDS : {s : Nat} -> (by : Nat) ->
DScopeTermN s d n -> DScopeTermN s (by + d) n
dweakDS by t = t // shift by
public export %inline
dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
dweakE by t = t // shift by
public export %inline
weakT : (by : Nat) -> Term d n -> Term d (by + n)
weakT by t = t // shift by
public export %inline
weakS : {s : Nat} -> (by : Nat) -> ScopeTermN s d n -> ScopeTermN s d (by + n)
weakS by t = t // shift by
public export %inline
weakDS : {s : Nat} -> (by : Nat) ->
DScopeTermN s d n -> DScopeTermN s d (by + n)
weakDS by t = t // shift by
public export %inline
weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
weakE by t = t // shift by
parameters {auto _ : CanShift f} {s : Nat}
export %inline
getTerm : ScopedBody s f n -> f (s + n)
getTerm (Y b) = b
getTerm (N b) = b // fromNat s
export %inline
(.term) : Scoped s f n -> f (s + n)
t.term = getTerm t.body
namespace ScopeTermBody
export %inline
getTerm0 : ScopedBody 0 f n -> f n
getTerm0 (Y b) = b
getTerm0 (N b) = b
namespace ScopeTermN
export %inline
(.term0) : Scoped 0 f n -> f n
t.term0 = getTerm0 t.body
export %inline
subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
subN (S _ (Y body)) es = body // fromSnocVect es
subN (S _ (N body)) _ = body
export %inline
sub1 : ScopeTerm d n -> Elim d n -> Term d n
sub1 t e = subN t [< e]
export %inline
dsubN : DScopeTermN s d n -> SnocVect s (Dim d) -> Term d n
dsubN (S _ (Y body)) ps = body // fromSnocVect ps
dsubN (S _ (N body)) _ = body
export %inline
dsub1 : DScopeTerm d n -> Dim d -> Term d n
dsub1 t p = dsubN t [< p]
public export %inline
(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
body.zero = dsub1 body $ K Zero loc
public export %inline
(.one) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n
body.one = dsub1 body $ K One loc
public export
TSubst : Nat -> Nat -> Nat -> Type
TSubst = Subst2 Elim
0 CloTest : TermLike -> Type
CloTest tm = forall d, n. tm d n -> Bool
public export
interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
public export %inline FromVar (Elim 0) where var = B
public export
0 NotClo : {isClo : CloTest tm} -> PushSubsts tm isClo => Pred (tm d n)
NotClo = No . isClo
export CanSubstSelf2 Elim
public export
0 NonClo : (tm : TermLike) -> {isClo : CloTest tm} ->
PushSubsts tm isClo => TermLike
NonClo tm d n = Subset (tm d n) NotClo
private subTerm : {d, n1, n2 : Nat} -> Term d n1 -> TSubst d n1 n2 -> TermT d n2
private subElim : {d, n1, n2 : Nat} -> Elim d n1 -> TSubst d n1 n2 -> ElimT d n2
public export %inline
nclo : {isClo : CloTest tm} -> (0 _ : PushSubsts tm isClo) =>
(t : tm d n) -> (0 nc : NotClo t) => NonClo tm d n
nclo t = Element t nc
subTerm (TYPE l loc) th = th0 $ TYPE l loc
subTerm (Nat loc) th = th0 $ Nat loc
subTerm (Zero loc) th = th0 $ Zero loc
subTerm (E e) th = let Th2 dope tope e' = subElim e th in Th2 dope tope $ E e'
subTerm (CloT (Sub2 s ph)) th = th1 $ CloT $ Sub2 s $ ph .% th
subTerm s th = th1 $ CloT $ Sub2 s th
parameters {0 isClo : CloTest tm} {auto _ : PushSubsts tm isClo}
||| if the input term has any top-level closures, push them under one layer of
||| syntax
export %inline
pushSubsts : tm d n -> NonClo tm d n
pushSubsts s = pushSubstsWith id id s
subElim (F x k loc) th = th0 $ F x k loc
subElim (B loc) [< e] = e
subElim (CloE (Sub2 e ph)) th = th1 $ CloE $ Sub2 e $ ph .% th
subElim e th = th1 $ CloE $ Sub2 e th
export %inline
pushSubstsWith' : DSubst d1 d2 -> TSubst d2 n1 n2 -> tm d1 n1 -> tm d2 n2
pushSubstsWith' th ph x = fst $ pushSubstsWith th ph x
export %inline
pushSubsts' : tm d n -> tm d n
pushSubsts' s = fst $ pushSubsts s
mutual
public export
isCloT : CloTest Term
isCloT (CloT {}) = True
isCloT (DCloT {}) = True
isCloT (E e) = isCloE e
isCloT _ = False
public export
isCloE : CloTest Elim
isCloE (CloE {}) = True
isCloE (DCloE {}) = True
isCloE _ = False
export
CanSubstSelf2 Elim where
Th2 dope tope elim // th =
let
th' = select tope th
in
?sube2
PushSubsts Elim Subst.isCloE where
pushSubstsWith th ph (F x u loc) =
nclo $ F x u loc
pushSubstsWith th ph (B i loc) =
let res = getLoc ph i loc in
case nchoose $ isCloE res of
Left yes => assert_total pushSubsts res
Right no => Element res no
pushSubstsWith th ph (App f s loc) =
nclo $ App (f // th // ph) (s // th // ph) loc
pushSubstsWith th ph (CasePair pi p r b loc) =
nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
pushSubstsWith th ph (Fst pair loc) =
nclo $ Fst (pair // th // ph) loc
pushSubstsWith th ph (Snd pair loc) =
nclo $ Snd (pair // th // ph) loc
pushSubstsWith th ph (CaseEnum pi t r arms loc) =
nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
(map (\b => b // th // ph) arms) loc
pushSubstsWith th ph (CaseNat pi pi' n r z s loc) =
nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph)
(z // th // ph) (s // th // ph) loc
pushSubstsWith th ph (CaseBox pi x r b loc) =
nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc
pushSubstsWith th ph (DApp f d loc) =
nclo $ DApp (f // th // ph) (d // th) loc
pushSubstsWith th ph (Ann s a loc) =
nclo $ Ann (s // th // ph) (a // th // ph) loc
pushSubstsWith th ph (Coe ty p q val loc) =
nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc
pushSubstsWith th ph (Comp ty p q val r zero one loc) =
nclo $ Comp (ty // th // ph) (p // th) (q // th)
(val // th // ph) (r // th)
(zero // th // ph) (one // th // ph) loc
pushSubstsWith th ph (TypeCase ty ret arms def loc) =
nclo $ TypeCase (ty // th // ph) (ret // th // ph)
(map (\t => t // th // ph) arms) (def // th // ph) loc
pushSubstsWith th ph (CloE (Sub e ps)) =
pushSubstsWith th (comp th ps ph) e
pushSubstsWith th ph (DCloE (Sub e ps)) =
pushSubstsWith (ps . th) ph e
-- namespace CanDSubst
-- public export
-- interface CanDSubst (0 tm : TermLike) where
-- (//) : {d1 : Nat} -> Thinned2 tm d1 n -> Lazy (DSubst d1 d2) ->
-- Thinned2 tm d2 n
-- ||| does the minimal reasonable work:
-- ||| - deletes the closure around an atomic constant like `TYPE`
-- ||| - deletes an identity substitution
-- ||| - composes (lazily) with an existing top-level dim-closure
-- ||| - otherwise, wraps in a new closure
-- export
-- CanDSubst Term where
-- Th2 _ _ (TYPE l loc) // _ = Th2 zero zero $ TYPE l loc
-- Th2 i j (DCloT (Sub s ph)) // th =
-- Th2 ?i' j $ DCloT $ Sub s $ ph . ?th'
-- Th2 i j s // th = ?sdf -- DCloT $ Sub s th
-- -- private
-- -- subDArgs : Elim d1 n -> DSubst d1 d2 -> Elim d2 n
-- -- subDArgs (DApp f d loc) th = DApp (subDArgs f th) (d // th) loc
-- -- subDArgs e th = DCloE $ Sub e th
-- -- ||| does the minimal reasonable work:
-- -- ||| - deletes the closure around a term variable
-- -- ||| - deletes an identity substitution
-- -- ||| - composes (lazily) with an existing top-level dim-closure
-- -- ||| - immediately looks up bound variables in a
-- -- ||| top-level sequence of dimension applications
-- -- ||| - otherwise, wraps in a new closure
-- -- export
-- -- CanDSubst Elim where
-- -- e // Shift SZ = e
-- -- F x u loc // _ = F x u loc
-- -- B i loc // _ = B i loc
-- -- e@(DApp {}) // th = subDArgs e th
-- -- DCloE (Sub e ph) // th = DCloE $ Sub e $ ph . th
-- -- e // th = DCloE $ Sub e th
-- -- namespace DSubst.ScopeTermN
-- -- export %inline
-- -- (//) : ScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
-- -- ScopeTermN s d2 n
-- -- S ns (Y body) // th = S ns $ Y $ body // th
-- -- S ns (N body) // th = S ns $ N $ body // th
-- -- namespace DSubst.DScopeTermN
-- -- export %inline
-- -- (//) : {s : Nat} ->
-- -- DScopeTermN s d1 n -> Lazy (DSubst d1 d2) ->
-- -- DScopeTermN s d2 n
-- -- S ns (Y body) // th = S ns $ Y $ body // pushN s th
-- -- S ns (N body) // th = S ns $ N $ body // th
export
PushSubsts Term Subst.isCloT where
pushSubstsWith th ph (TYPE l loc) =
nclo $ TYPE l loc
pushSubstsWith th ph (IOState loc) =
nclo $ IOState loc
pushSubstsWith th ph (Pi qty a body loc) =
nclo $ Pi qty (a // th // ph) (body // th // ph) loc
pushSubstsWith th ph (Lam body loc) =
nclo $ Lam (body // th // ph) loc
pushSubstsWith th ph (Sig a b loc) =
nclo $ Sig (a // th // ph) (b // th // ph) loc
pushSubstsWith th ph (Pair s t loc) =
nclo $ Pair (s // th // ph) (t // th // ph) loc
pushSubstsWith th ph (Enum tags loc) =
nclo $ Enum tags loc
pushSubstsWith th ph (Tag tag loc) =
nclo $ Tag tag loc
pushSubstsWith th ph (Eq ty l r loc) =
nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
pushSubstsWith th ph (DLam body loc) =
nclo $ DLam (body // th // ph) loc
pushSubstsWith _ _ (NAT loc) =
nclo $ NAT loc
pushSubstsWith _ _ (Nat n loc) =
nclo $ Nat n loc
pushSubstsWith th ph (Succ n loc) =
nclo $ Succ (n // th // ph) loc
pushSubstsWith _ _ (STRING loc) =
nclo $ STRING loc
pushSubstsWith _ _ (Str s loc) =
nclo $ Str s loc
pushSubstsWith th ph (BOX pi ty loc) =
nclo $ BOX pi (ty // th // ph) loc
pushSubstsWith th ph (Box val loc) =
nclo $ Box (val // th // ph) loc
pushSubstsWith th ph (E e) =
let Element e nc = pushSubstsWith th ph e in nclo $ E e
pushSubstsWith th ph (Let qty rhs body loc) =
nclo $ Let qty (rhs // th // ph) (body // th // ph) loc
pushSubstsWith th ph (CloT (Sub s ps)) =
pushSubstsWith th (comp th ps ph) s
pushSubstsWith th ph (DCloT (Sub s ps)) =
pushSubstsWith (ps . th) ph s
-- -- export %inline FromVar (Elim d) where fromVarLoc = B
-- -- export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
||| heterogeneous comp, in terms of Comp and Coe
public export %inline
CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
(r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
CompH' {ty, p, q, val, r, zero, one, loc} =
let ty' = SY ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
Comp {
ty = dsub1 ty q, p, q,
val = E $ Coe ty p q val val.loc, r,
zero = SY zero.names $ E $
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
one = SY one.names $ E $
Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
loc
}
-- -- ||| does the minimal reasonable work:
-- -- ||| - deletes the closure around a *free* name
-- -- ||| - deletes an identity substitution
-- -- ||| - composes (lazily) with an existing top-level closure
-- -- ||| - immediately looks up a bound variable
-- -- ||| - otherwise, wraps in a new closure
-- -- export
-- -- CanSubstSelf (Elim d) where
-- -- F x u loc // _ = F x u loc
-- -- B i loc // th = getLoc th i loc
-- -- CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th
-- -- e // th = case force th of
-- -- Shift SZ => e
-- -- th => CloE $ Sub e th
-- -- namespace CanTSubst
-- -- public export
-- -- interface CanTSubst (0 tm : TermLike) where
-- -- (//) : tm d n1 -> Lazy (TSubst d n1 n2) -> tm d n2
-- -- ||| does the minimal reasonable work:
-- -- ||| - deletes the closure around an atomic constant like `TYPE`
-- -- ||| - deletes an identity substitution
-- -- ||| - composes (lazily) with an existing top-level closure
-- -- ||| - goes inside `E` in case it is a simple variable or something
-- -- ||| - otherwise, wraps in a new closure
-- -- export
-- -- CanTSubst Term where
-- -- TYPE l loc // _ = TYPE l loc
-- -- E e // th = E $ e // th
-- -- CloT (Sub s ph) // th = CloT $ Sub s $ ph . th
-- -- s // th = case force th of
-- -- Shift SZ => s
-- -- th => CloT $ Sub s th
-- -- namespace ScopeTermN
-- -- export %inline
-- -- (//) : {s : Nat} ->
-- -- ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) ->
-- -- ScopeTermN s d n2
-- -- S ns (Y body) // th = S ns $ Y $ body // pushN s th
-- -- S ns (N body) // th = S ns $ N $ body // th
-- -- namespace DScopeTermN
-- -- export %inline
-- -- (//) : {s : Nat} ->
-- -- DScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> DScopeTermN s d n2
-- -- S ns (Y body) // th = S ns $ Y $ body // map (// shift s) th
-- -- S ns (N body) // th = S ns $ N $ body // th
-- -- export %inline CanShift (Term d) where s // by = s // Shift by
-- -- export %inline CanShift (Elim d) where e // by = e // Shift by
-- -- export %inline
-- -- {s : Nat} -> CanShift (ScopeTermN s d) where
-- -- b // by = b // Shift by
-- -- export %inline
-- -- comp : DSubst d1 d2 -> TSubst d1 n1 mid -> TSubst d2 mid n2 -> TSubst d2 n1 n2
-- -- comp th ps ph = map (// th) ps . ph
-- -- public export %inline
-- -- dweakT : (by : Nat) -> Term d n -> Term (by + d) n
-- -- dweakT by t = t // shift by
-- -- public export %inline
-- -- dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n
-- -- dweakE by t = t // shift by
-- -- public export %inline
-- -- weakT : (by : Nat) -> Term d n -> Term d (by + n)
-- -- weakT by t = t // shift by
-- -- public export %inline
-- -- weakE : (by : Nat) -> Elim d n -> Elim d (by + n)
-- -- weakE by t = t // shift by
-- -- parameters {s : Nat}
-- -- namespace ScopeTermBody
-- -- export %inline
-- -- (.term) : ScopedBody s (Term d) n -> Term d (s + n)
-- -- (Y b).term = b
-- -- (N b).term = weakT s b
-- -- namespace ScopeTermN
-- -- export %inline
-- -- (.term) : ScopeTermN s d n -> Term d (s + n)
-- -- t.term = t.body.term
-- -- namespace DScopeTermBody
-- -- export %inline
-- -- (.term) : ScopedBody s (\d => Term d n) d -> Term (s + d) n
-- -- (Y b).term = b
-- -- (N b).term = dweakT s b
-- -- namespace DScopeTermN
-- -- export %inline
-- -- (.term) : DScopeTermN s d n -> Term (s + d) n
-- -- t.term = t.body.term
-- -- export %inline
-- -- subN : ScopeTermN s d n -> SnocVect s (Elim d n) -> Term d n
-- -- subN (S _ (Y body)) es = body // fromSnocVect es
-- -- subN (S _ (N body)) _ = body
-- -- export %inline
-- -- sub1 : ScopeTerm d n -> Elim d n -> Term d n
-- -- sub1 t e = subN t [< e]
-- -- export %inline
-- -- dsubN : DScopeTermN s d n -> SnocVect s (Dim d) -> Term d n
-- -- dsubN (S _ (Y body)) ps = body // fromSnocVect ps
-- -- dsubN (S _ (N body)) _ = body
-- -- export %inline
-- -- dsub1 : DScopeTerm d n -> Dim d -> Term d n
-- -- dsub1 t p = dsubN t [< p]
-- -- public export %inline
-- -- (.zero) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
-- -- body.zero = dsub1 body $ K Zero loc
-- -- public export %inline
-- -- (.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n
-- -- body.one = dsub1 body $ K One loc
-- -- public export
-- -- 0 CloTest : TermLike -> Type
-- -- CloTest tm = forall d, n. tm d n -> Bool
-- -- interface PushSubsts (0 tm : TermLike) (0 isClo : CloTest tm) | tm where
-- -- pushSubstsWith : DSubst d1 d2 -> TSubst d2 n1 n2 ->
-- -- tm d1 n1 -> Subset (tm d2 n2) (No . isClo)
-- -- public export
-- -- 0 NotClo : {isClo : CloTest tm} -> PushSubsts tm isClo => Pred (tm d n)
-- -- NotClo = No . isClo
-- -- public export
-- -- 0 NonClo : (tm : TermLike) -> {isClo : CloTest tm} ->
-- -- PushSubsts tm isClo => TermLike
-- -- NonClo tm d n = Subset (tm d n) NotClo
-- -- public export %inline
-- -- nclo : {isClo : CloTest tm} -> (0 _ : PushSubsts tm isClo) =>
-- -- (t : tm d n) -> (0 nc : NotClo t) => NonClo tm d n
-- -- nclo t = Element t nc
-- -- parameters {0 isClo : CloTest tm} {auto _ : PushSubsts tm isClo}
-- -- ||| if the input term has any top-level closures, push them under one layer of
-- -- ||| syntax
-- -- export %inline
-- -- pushSubsts : tm d n -> NonClo tm d n
-- -- pushSubsts s = pushSubstsWith id id s
-- -- export %inline
-- -- pushSubstsWith' : DSubst d1 d2 -> TSubst d2 n1 n2 -> tm d1 n1 -> tm d2 n2
-- -- pushSubstsWith' th ph x = fst $ pushSubstsWith th ph x
-- -- export %inline
-- -- pushSubsts' : tm d n -> tm d n
-- -- pushSubsts' s = fst $ pushSubsts s
-- -- mutual
-- -- public export
-- -- isCloT : CloTest Term
-- -- isCloT (CloT {}) = True
-- -- isCloT (DCloT {}) = True
-- -- isCloT (E e) = isCloE e
-- -- isCloT _ = False
-- -- public export
-- -- isCloE : CloTest Elim
-- -- isCloE (CloE {}) = True
-- -- isCloE (DCloE {}) = True
-- -- isCloE _ = False
-- -- mutual
-- -- export
-- -- PushSubsts Term Subst.isCloT where
-- -- pushSubstsWith th ph (TYPE l loc) =
-- -- nclo $ TYPE l loc
-- -- pushSubstsWith th ph (Pi qty a body loc) =
-- -- nclo $ Pi qty (a // th // ph) (body // th // ph) loc
-- -- pushSubstsWith th ph (Lam body loc) =
-- -- nclo $ Lam (body // th // ph) loc
-- -- pushSubstsWith th ph (Sig a b loc) =
-- -- nclo $ Sig (a // th // ph) (b // th // ph) loc
-- -- pushSubstsWith th ph (Pair s t loc) =
-- -- nclo $ Pair (s // th // ph) (t // th // ph) loc
-- -- pushSubstsWith th ph (Enum tags loc) =
-- -- nclo $ Enum tags loc
-- -- pushSubstsWith th ph (Tag tag loc) =
-- -- nclo $ Tag tag loc
-- -- pushSubstsWith th ph (Eq ty l r loc) =
-- -- nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc
-- -- pushSubstsWith th ph (DLam body loc) =
-- -- nclo $ DLam (body // th // ph) loc
-- -- pushSubstsWith _ _ (Nat loc) =
-- -- nclo $ Nat loc
-- -- pushSubstsWith _ _ (Zero loc) =
-- -- nclo $ Zero loc
-- -- pushSubstsWith th ph (Succ n loc) =
-- -- nclo $ Succ (n // th // ph) loc
-- -- pushSubstsWith th ph (BOX pi ty loc) =
-- -- nclo $ BOX pi (ty // th // ph) loc
-- -- pushSubstsWith th ph (Box val loc) =
-- -- nclo $ Box (val // th // ph) loc
-- -- pushSubstsWith th ph (E e) =
-- -- let Element e nc = pushSubstsWith th ph e in nclo $ E e
-- -- pushSubstsWith th ph (CloT (Sub s ps)) =
-- -- pushSubstsWith th (comp th ps ph) s
-- -- pushSubstsWith th ph (DCloT (Sub s ps)) =
-- -- pushSubstsWith (ps . th) ph s
-- -- export
-- -- PushSubsts Elim Subst.isCloE where
-- -- pushSubstsWith th ph (F x u loc) =
-- -- nclo $ F x u loc
-- -- pushSubstsWith th ph (B i loc) =
-- -- let res = getLoc ph i loc in
-- -- case nchoose $ isCloE res of
-- -- Left yes => assert_total pushSubsts res
-- -- Right no => Element res no
-- -- pushSubstsWith th ph (App f s loc) =
-- -- nclo $ App (f // th // ph) (s // th // ph) loc
-- -- pushSubstsWith th ph (CasePair pi p r b loc) =
-- -- nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc
-- -- pushSubstsWith th ph (CaseEnum pi t r arms loc) =
-- -- nclo $ CaseEnum pi (t // th // ph) (r // th // ph)
-- -- (map (\b => b // th // ph) arms) loc
-- -- pushSubstsWith th ph (CaseNat pi pi' n r z s loc) =
-- -- nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph)
-- -- (z // th // ph) (s // th // ph) loc
-- -- pushSubstsWith th ph (CaseBox pi x r b loc) =
-- -- nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc
-- -- pushSubstsWith th ph (DApp f d loc) =
-- -- nclo $ DApp (f // th // ph) (d // th) loc
-- -- pushSubstsWith th ph (Ann s a loc) =
-- -- nclo $ Ann (s // th // ph) (a // th // ph) loc
-- -- pushSubstsWith th ph (Coe ty p q val loc) =
-- -- nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc
-- -- pushSubstsWith th ph (Comp ty p q val r zero one loc) =
-- -- nclo $ Comp (ty // th // ph) (p // th) (q // th)
-- -- (val // th // ph) (r // th)
-- -- (zero // th // ph) (one // th // ph) loc
-- -- pushSubstsWith th ph (TypeCase ty ret arms def loc) =
-- -- nclo $ TypeCase (ty // th // ph) (ret // th // ph)
-- -- (map (\t => t // th // ph) arms) (def // th // ph) loc
-- -- pushSubstsWith th ph (CloE (Sub e ps)) =
-- -- pushSubstsWith th (comp th ps ph) e
-- -- pushSubstsWith th ph (DCloE (Sub e ps)) =
-- -- pushSubstsWith (ps . th) ph e
-- -- private %inline
-- -- CompHY : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
-- -- (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
-- -- CompHY {ty, p, q, val, r, zero, one, loc} =
-- -- let ty' = SY ty.names $ ty.term // (B VZ ty.loc ::: shift 2) in
-- -- Comp {
-- -- ty = dsub1 ty q, p, q,
-- -- val = E $ Coe ty p q val val.loc, r,
-- -- -- [fixme] better locations for these vars?
-- -- zero = SY zero.names $ E $
-- -- Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
-- -- one = SY one.names $ E $
-- -- Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
-- -- loc
-- -- }
-- -- public export %inline
-- -- CompH' : (ty : DScopeTerm d n) ->
-- -- (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
-- -- (zero : DScopeTerm d n) ->
-- -- (one : DScopeTerm d n) ->
-- -- (loc : Loc) ->
-- -- Elim d n
-- -- CompH' {ty, p, q, val, r, zero, one, loc} =
-- -- case dsqueeze ty of
-- -- S _ (N ty) => Comp {ty, p, q, val, r, zero, one, loc}
-- -- S _ (Y _) => CompHY {ty, p, q, val, r, zero, one, loc}
-- -- ||| heterogeneous composition, using Comp and Coe (and subst)
-- -- |||
-- -- ||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ }
-- -- ||| ≔
-- -- ||| comp [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₁
-- -- ||| }
-- -- public export %inline
-- -- CompH : (i : BindName) -> (ty : Term (S d) n) ->
-- -- (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
-- -- (j0 : BindName) -> (zero : Term (S d) n) ->
-- -- (j1 : BindName) -> (one : Term (S d) n) ->
-- -- (loc : Loc) ->
-- -- Elim d n
-- -- CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
-- -- CompH' {ty = SY [< i] ty, p, q, val, r,
-- -- zero = SY [< j0] zero, one = SY [< j0] one, loc}
||| heterogeneous comp, in terms of Comp and Coe
public export %inline
CompH : (i : BindName) -> (ty : Term (S d) n) ->
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
(j0 : BindName) -> (zero : Term (S d) n) ->
(j1 : BindName) -> (one : Term (S d) n) ->
(loc : Loc) -> Elim d n
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
CompH' {ty = SY [< i] ty, p, q, val, r,
zero = SY [< j0] zero, one = SY [< j1] one, loc}

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]
@ -25,10 +26,12 @@ allKinds = %runElab do
||| in `type-case`, how many variables are bound in this branch
public export %inline
arity : TyConKind -> Nat
arity KTYPE = 0
arity KPi = 2
arity KSig = 2
arity KEnum = 0
arity KEq = 5
arity KNat = 0
arity KBOX = 1
arity KTYPE = 0
arity KIOState = 0
arity KPi = 2
arity KSig = 2
arity KEnum = 0
arity KEq = 5
arity KNat = 0
arity KString = 0
arity KBOX = 1

View file

@ -1,13 +0,0 @@
module Quox.Thin
import public Quox.Thin.Base
import public Quox.Thin.View
import public Quox.Thin.Eqv
import public Quox.Thin.Cons
import public Quox.Thin.List
import public Quox.Thin.Append
import public Quox.Thin.Comp
import public Quox.Thin.Cover
import public Quox.Thin.Coprod
import public Quox.Thin.Split
import public Quox.Thin.Term

View file

@ -1,27 +0,0 @@
module Quox.Thin.Append
import public Quox.Thin.Base
import public Quox.Thin.View
import Data.DPair
%default total
public export
app' : OPE m1 n1 mask1 -> OPE m2 n2 mask2 -> Exists (OPE (m1 + m2) (n1 + n2))
app' Stop ope2 = Evidence _ ope2
app' (Drop ope1 Refl) ope2 = Evidence _ $ Drop (app' ope1 ope2).snd Refl
app' (Keep ope1 Refl) ope2 = Evidence _ $ Keep (app' ope1 ope2).snd Refl
public export
(++) : {n1, n2, mask1, mask2 : Nat} ->
(0 ope1 : OPE m1 n1 mask1) -> (0 ope2 : OPE m2 n2 mask2) ->
Subset Nat (OPE (m1 + m2) (n1 + n2))
ope1 ++ ope2 with %syntactic (view ope1)
Stop ++ ope2 | StopV = Element _ ope2
Drop ope1 Refl ++ ope2 | DropV mask ope1 =
Element _ $ Drop (ope1 ++ ope2).snd Refl
Keep ope1 Refl ++ ope2 | KeepV mask ope1 =
Element _ $ Keep (ope1 ++ ope2).snd Refl
-- [todo] this mask is just (mask1 << n2) | mask2
-- prove it and add %transform

View file

@ -1,81 +0,0 @@
module Quox.Thin.Base
import Data.Fin
import Data.DPair
%default total
||| "order preserving embeddings", for recording a correspondence between a
||| smaller scope and part of a larger one. the third argument is a bitmask
||| representing this OPE, unique for a given `n`.
public export
data OPE : (m, n, mask : Nat) -> Type where
[search m n]
Stop : OPE 0 0 0
Drop : OPE m n mask -> mask' = mask + mask -> OPE m (S n) mask'
Keep : OPE m n mask -> mask' = (S (mask + mask)) -> OPE (S m) (S n) mask'
%name OPE ope
export
Show (OPE m n mask) where
showPrec d Stop = "Stop"
showPrec d (Drop ope Refl) = showCon d "Drop" $ showArg ope ++ " Refl"
showPrec d (Keep ope Refl) = showCon d "Keep" $ showArg ope ++ " Refl"
public export %inline
drop : OPE m n mask -> OPE m (S n) (mask + mask)
drop ope = Drop ope Refl
public export %inline
keep : OPE m n mask -> OPE (S m) (S n) (S (mask + mask))
keep ope = Keep ope Refl
public export
data IsStop : OPE m n mask -> Type where ItIsStop : IsStop Stop
public export
data IsDrop : OPE m n mask -> Type where ItIsDrop : IsDrop (Drop ope eq)
public export
data IsKeep : OPE m n mask -> Type where ItIsKeep : IsKeep (Keep ope eq)
export
0 zeroIsStop : (ope : OPE m 0 mask) -> IsStop ope
zeroIsStop Stop = ItIsStop
||| everything selected
public export
id : {m : Nat} -> Subset Nat (OPE m m)
id {m = 0} = Element _ Stop
id {m = S m} = Element _ $ Keep id.snd Refl
public export %inline
0 id' : {m : Nat} -> OPE m m (fst (Base.id {m}))
id' = id.snd
||| nothing selected
public export
zero : {m : Nat} -> OPE 0 m 0
zero {m = 0} = Stop
zero {m = S m} = Drop zero Refl
||| a single slot selected
public export
one : Fin n -> Subset Nat (OPE 1 n)
one FZ = Element _ $ keep zero
one (FS i) = Element _ $ drop (one i).snd
public export %inline
0 one' : (i : Fin n) -> OPE 1 n (one i).fst
one' i = (one i).snd
public export
record SomeOPE n where
constructor MkOPE
{0 scope : Nat}
{mask : Nat}
0 ope : OPE scope n mask

View file

@ -1,55 +0,0 @@
module Quox.Thin.Comp
import public Quox.Thin.Base
import public Quox.Thin.View
import Quox.NatExtra
import Data.Singleton
%default total
||| inductive definition of OPE composition
public export
data Comp : (l : OPE n p mask1) -> (r : OPE m n mask2) ->
(res : OPE m p mask3) -> Type where
[search l r]
StopZ : Comp Stop Stop Stop
DropZ : Comp a b c -> Comp (Drop a Refl) b (Drop c Refl)
KeepZ : Comp a b c -> Comp (Keep a Refl) (Keep b Refl) (Keep c Refl)
KDZ : Comp a b c -> Comp (Keep a Refl) (Drop b Refl) (Drop c Refl)
public export
record CompResult (ope1 : OPE n p mask1) (ope2 : OPE m n mask2) where
constructor MkComp
{mask : Nat}
{0 ope : OPE m p mask}
0 comp : Comp ope1 ope2 ope
%name CompResult comp
||| compose two OPEs, if the middle scope size is already known at runtime
export
comp' : {n, p, mask1, mask2 : Nat} ->
(0 ope1 : OPE n p mask1) -> (0 ope2 : OPE m n mask2) ->
CompResult ope1 ope2
comp' ope1 ope2 with %syntactic (view ope1) | (view ope2)
comp' Stop Stop | StopV | StopV =
MkComp StopZ
comp' (Drop ope1 Refl) ope2 | DropV _ ope1 | _ =
MkComp $ DropZ (comp' ope1 ope2).comp
comp' (Keep ope1 Refl) (Drop ope2 Refl) | KeepV _ ope1 | DropV _ ope2 =
MkComp $ KDZ (comp' ope1 ope2).comp
comp' (Keep ope1 Refl) (Keep ope2 Refl) | KeepV _ ope1 | KeepV _ ope2 =
MkComp $ KeepZ (comp' ope1 ope2).comp
||| compose two OPEs, after recomputing the middle scope size using `appOpe`
export
comp : {p, mask1, mask2 : Nat} ->
(0 ope1 : OPE n p mask1) -> (0 ope2 : OPE m n mask2) ->
CompResult ope1 ope2
comp ope1 ope2 = let Val n = appOpe p ope1 in comp' ope1 ope2
-- [todo] is there a quick way to compute the mask of comp?
export
0 (.) : (ope1 : OPE n p mask1) -> (ope2 : OPE m n mask2) ->
OPE m p (comp ope1 ope2).mask
ope1 . ope2 = (comp ope1 ope2).ope

View file

@ -1,74 +0,0 @@
module Quox.Thin.Cons
import public Quox.Thin.Base
import Quox.Thin.Eqv
import Quox.Thin.View
import Data.DPair
import Control.Relation
%default total
public export
data IsHead : (ope : OPE m (S n) mask) -> Bool -> Type where
[search ope]
DropH : IsHead (Drop ope eq) False
KeepH : IsHead (Keep ope eq) True
public export
data IsTail : (full : OPE m (S n) mask) -> OPE m' n mask' -> Type where
[search full]
DropT : IsTail (Drop ope eq) ope
KeepT : IsTail (Keep ope eq) ope
public export
record Uncons (ope : OPE m (S n) mask) where
constructor MkUncons
0 head : Bool
{tailMask : Nat}
0 tail : OPE scope n tailMask
{auto isHead : IsHead ope head}
{auto 0 isTail : IsTail ope tail}
public export
uncons : {n, mask : Nat} -> (0 ope : OPE m (S n) mask) -> Uncons ope
uncons ope with %syntactic (view ope)
uncons (Drop ope Refl) | DropV _ ope = MkUncons False ope
uncons (Keep ope Refl) | KeepV _ ope = MkUncons True ope
public export
head : {n, mask : Nat} -> (0 ope : OPE m (S n) mask) -> Exists $ IsHead ope
head ope = Evidence _ (uncons ope).isHead
public export
record Tail (ope : OPE m (S n) mask) where
constructor MkTail
{tailMask : Nat}
0 tail : OPE scope n tailMask
{auto 0 isTail : IsTail ope tail}
public export
tail : {n, mask : Nat} -> (0 ope : OPE m (S n) mask) -> Tail ope
tail ope = let u = uncons ope in MkTail u.tail @{u.isTail}
export
cons : {mask : Nat} -> (head : Bool) -> (0 tail : OPE m n mask) ->
Subset Nat (OPE (if head then S m else m) (S n))
cons False tail = Element _ $ drop tail
cons True tail = Element _ $ keep tail
export
0 consEquiv' : (self : OPE m' (S n) mask') ->
(head : Bool) -> (tail : OPE m n mask) ->
IsHead self head -> IsTail self tail ->
(cons head tail).snd `Eqv` self
consEquiv' (Drop tail _) False tail DropH DropT = EqvDrop reflexive
consEquiv' (Keep tail _) True tail KeepH KeepT = EqvKeep reflexive
export
0 consEquiv : (full : OPE m' (S n) mask') ->
(cons (uncons full).head (uncons full).tail).snd `Eqv` full
consEquiv full with %syntactic (uncons full)
_ | MkUncons head tail {isHead, isTail} =
consEquiv' full head tail isHead isTail

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