Compare commits

...

395 Commits
ope ... 🐉

Author SHA1 Message Date
rhiannon morris c9f66bb6af minor refactor 2024-04-18 11:49:19 +02:00
rhiannon morris 7f72ed56fb add test for regularity 2024-04-15 22:58:28 +02:00
rhiannon morris 67c825ab39 add coercion regularity to the equality checker (not to whnf) 2024-04-15 22:58:17 +02:00
rhiannon morris ddc2422ffb fix .gitignore 2024-04-15 22:27:55 +02:00
rhiannon morris 3f7031c613 pack bump 2024-04-15 20:54:23 +02:00
rhiannon morris 8823154973 add golden test stuff 2024-04-14 20:49:10 +02:00
rhiannon morris b7dc5ffdc4 add check for #[main] type 2024-04-14 16:20:40 +02:00
rhiannon morris dd697ba56e add CheckBuiltin 2024-04-14 16:20:25 +02:00
rhiannon morris 32b9fe124f minor tweaks in Q.Typing.Context 2024-04-14 15:48:10 +02:00
rhiannon morris 95a0b38d74 update pretty-printing tests 2024-04-12 22:00:08 +02:00
rhiannon morris 7883a3cae7 pretty printing fixes 2024-04-12 21:54:25 +02:00
rhiannon morris a1d8fd4ab5 %inline 2024-04-12 21:53:54 +02:00
rhiannon morris 9d60f366cf add #![log] pragma 2024-04-12 21:53:54 +02:00
rhiannon morris f56f594839 push multiple loglevel changes at once 2024-04-12 21:53:54 +02:00
rhiannon morris fca75377a0 MakeName ⇒ MkName for consistency 2024-04-12 21:53:50 +02:00
rhiannon morris 11b0ab6a25 remove default from `FromParser.fromParserPure` and `Main.step` 2024-04-07 03:20:42 +02:00
rhiannon morris 7a0bc73d25 approximate log stack in handleLogDiscard 2024-04-06 20:14:24 +02:00
rhiannon morris 567176e076 log refactors 2024-04-05 18:43:00 +02:00
rhiannon morris 3b6ae36e4e add logging to core 2024-04-04 19:26:41 +02:00
rhiannon morris 861bd55f94 add log effects to FromParser 2024-04-04 19:26:41 +02:00
rhiannon morris e6ad16813e add log effects to executable 2024-04-04 19:26:41 +02:00
rhiannon morris 78555711ce add Q.Log 2024-04-04 19:26:41 +02:00
rhiannon morris ec839a1d48 big Main refactor 2024-04-04 19:26:41 +02:00
rhiannon morris 727f968afb add delimited continuations to bib 2024-04-04 19:26:30 +02:00
rhiannon morris 41c8a92c97 bib fixes 2024-04-04 19:26:13 +02:00
rhiannon morris efddb1aea1 skip broken pretty-printing tests till i fix them 2024-03-27 18:21:45 +01:00
rhiannon morris 8cba73f741 bump pack collection 2024-03-27 18:21:26 +01:00
rhiannon morris 582666a254 comments in infer for coercions 2024-03-21 21:29:13 +01:00
rhiannon morris a9e8f14ad5 fix a small bug in Q.Whnf.Coercion 2024-03-21 21:29:01 +01:00
rhiannon morris a8ac6f11f7 fix a quantity in CaseBox 2024-02-28 16:49:15 +01:00
rhiannon morris b67162bda1 fix the other similar loops
closes #38, again
2024-02-24 16:04:38 +01:00
rhiannon morris 24ae5b85a2 fix a broken test???? 2024-02-24 15:45:04 +01:00
rhiannon morris 325e128063 add η for False and True 2024-02-10 11:39:07 +01:00
rhiannon morris 642ac25a71 happy new year [pack update. also idris 0.7.0] 2024-02-10 10:14:22 +01:00
rhiannon morris 05a688d49e reject "" in NatExtra.fromHex 2024-02-10 10:14:22 +01:00
rhiannon morris 1c8c50f3e2 remove some unneeded Ord impls 2024-02-10 10:14:22 +01:00
rhiannon morris f337625801 remove most noLocs 2024-02-10 10:14:22 +01:00
rhiannon morris 1f01cec322 refactor Main a whole lot 2024-02-10 10:14:22 +01:00
rhiannon morris 103f019dbd move NDefinition to Quox.Definition and add an untyped one 2024-02-10 10:14:22 +01:00
rhiannon morris 2cafb35bc1 fix some comments 2024-02-10 10:14:22 +01:00
rhiannon morris 47069a9316 fill a stray hole 2024-02-10 10:14:22 +01:00
rhiannon morris fb14b756c7 add algebraic ornaments to bib 2024-02-10 10:14:22 +01:00
rhiannon morris 81783dbae0 fix typechecker loop when coercing boxes
closes #38
2024-02-10 10:07:06 +01:00
rhiannon morris a14c4ca1cb never inline let bindings from the original source 2023-12-21 18:04:12 +01:00
rhiannon morris b7074720ad pretty printing fixes 2023-12-21 18:03:57 +01:00
rhiannon morris 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
rhiannon morris aa4ead592a allow "let x : A = e in s" with type annotation 2023-12-21 17:54:31 +01:00
rhiannon morris 54db7e27ef make #[fail] run in the current namespace 2023-12-21 17:53:46 +01:00
rhiannon morris 7afcbfe258 recognise nats other than 0 in eq checker 2023-12-21 17:48:12 +01:00
rhiannon morris 0fdd4741be print quantity on let 2023-12-07 01:43:39 +01:00
rhiannon morris 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
rhiannon morris cdf1ec6deb fix a comment 2023-12-04 23:38:17 +01:00
rhiannon morris 08a8c694b1 a usage in hello.quox. why not 2023-12-04 23:36:30 +01:00
rhiannon morris 8b8129027d update syntax.ebnf 2023-12-04 23:35:54 +01:00
rhiannon morris e48f03a61c multiple semi-sep binds in a let 2023-12-04 23:27:59 +01:00
rhiannon morris 415a823dec comment out an unfinished definition lmao 2023-12-04 22:49:32 +01:00
rhiannon morris b1699ce022 add let to the core 2023-12-04 22:47:52 +01:00
rhiannon morris 68d8019f00 add `let` to frontend syntax 2023-12-04 18:56:45 +01:00
rhiannon morris 59e7a457a6 let case be the head of an application too 2023-12-04 18:28:57 +01:00
rhiannon morris 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
rhiannon morris e2ad18ff1f hello.quox tweaks 2023-11-16 18:33:03 +01:00
rhiannon morris 310822ffa5 remove old replaced stuff 2023-11-16 18:32:38 +01:00
rhiannon morris d115672d49 example stuff 2023-11-10 15:07:19 +01:00
rhiannon morris cc78ccd940 fix some parenthesisation 2023-11-06 22:11:11 +01:00
rhiannon morris 50984aa1aa refactor #[attribute] stuff 2023-11-05 20:49:02 +01:00
rhiannon morris 246d80eea2 add io.quox 2023-11-05 15:48:01 +01:00
rhiannon morris c48b7be559 add html output highlighting 2023-11-05 15:47:52 +01:00
rhiannon morris 040a1862c3 refactor scheme prelude 2023-11-05 15:45:33 +01:00
rhiannon morris bf8cced888 swap some delim/syntax highlighting around 2023-11-05 15:45:07 +01:00
rhiannon morris 04af7ae942 highlight the @ in dim apps as a delim 2023-11-05 15:44:44 +01:00
rhiannon morris 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
rhiannon morris 6c8ebfb804 fix some comments 2023-11-05 15:41:21 +01:00
rhiannon morris da3cd404f3 handle when getTermCols returns 0 2023-11-05 15:40:19 +01:00
rhiannon morris f58fa5218f subscript numbers are no longer special 2023-11-05 15:39:52 +01:00
rhiannon morris 580fbc8fd8 add misc.refl, misc.sing, nat.minus 2023-11-05 15:38:38 +01:00
rhiannon morris e211887a34 string/nat lit stuff 2023-11-05 15:38:13 +01:00
rhiannon morris 3b9a339e5e rename "Tag" highlight to "Constant" 2023-11-05 14:30:40 +01:00
rhiannon morris 2f8a2d2cd2 fix typo in error 2023-11-04 17:45:55 +01:00
rhiannon morris 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
rhiannon morris 90cdcfe4da add \n and \t escapes to the lexer 2023-11-03 20:07:59 +01:00
rhiannon morris d4639a35c6 add hello.quox to examples 2023-11-03 18:05:54 +01:00
rhiannon morris b7e1f37b5b add some #[compile-scheme] 2023-11-03 18:05:54 +01:00
rhiannon morris 5dfefe443c more tidying of outputs 2023-11-03 18:05:54 +01:00
rhiannon morris 0514fff481 represent ℕ constants directly
instead of as huge `succ (succ (succ ⋯))` terms
2023-11-03 18:05:54 +01:00
rhiannon morris fa7f82ae5a rename Nat to NAT in AST 2023-11-03 18:05:54 +01:00
rhiannon morris e0ed37720f always vsep scheme lets, otherwise they are unreadable 2023-11-03 18:05:54 +01:00
rhiannon morris 4cc50c6bcd highlight errors even if real output is to a file
(unless told not to)
2023-11-03 18:05:54 +01:00
rhiannon morris 050346e344 add postulate, #[compile-scheme], #[main] 2023-11-03 18:05:54 +01:00
rhiannon morris cc0bade747 scheme output 2023-11-03 18:05:54 +01:00
rhiannon morris cd08a0fd98 more erasure 2023-11-03 18:05:54 +01:00
rhiannon morris 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
rhiannon morris 314e7f036d make nat elimination with erased IH non-recursive at runtime 2023-11-03 18:05:54 +01:00
rhiannon morris 6ab9637ab5 don't keep erased applications actually 2023-11-03 18:05:54 +01:00
rhiannon morris b6fd1e921e pretty printing improvements 2023-11-03 18:05:54 +01:00
rhiannon morris f4a45b6c52 keep the Except effect at the start of the list 2023-11-03 18:05:54 +01:00
rhiannon morris 8e0d66cab8 more erasure 2023-11-03 18:05:54 +01:00
rhiannon morris ea74c148b7 some of this EffExtra stuff doesn't work 2023-11-03 18:05:54 +01:00
rhiannon morris 83ab871d61 new main 2023-11-03 18:05:54 +01:00
rhiannon morris 421eb220fd erasure refactor 2023-11-03 18:05:54 +01:00
rhiannon morris fbb862c88b %default total 2023-11-03 18:05:54 +01:00
rhiannon morris b651ed5447 LoadFile does the parsing 2023-11-03 18:05:54 +01:00
rhiannon morris d6985cad55 tweak the pretty printer stuff slightly 2023-11-03 18:05:54 +01:00
rhiannon morris 52e54dcc3c add PrettyVal stuff for parser AST 2023-11-03 18:05:54 +01:00
rhiannon morris 0c1df54d62 improve handling of context lengths 2023-11-03 18:05:54 +01:00
rhiannon morris 2e9183bc14 add prettyDef 2023-11-03 18:05:54 +01:00
rhiannon morris 428397f42b erasure to untyped syntax 2023-11-03 18:05:54 +01:00
rhiannon morris 0b7bd0ef46 add locations and substitutions to untyped syntax 2023-11-03 18:05:54 +01:00
rhiannon morris 9cbd998d6f simplify isEmpty and isSubSing 2023-11-03 18:05:54 +01:00
rhiannon morris 6896c8fcc4 rename SQtys to sg (σ) 2023-11-03 18:05:54 +01:00
rhiannon morris be8797a3ef untyped λ calculus syntax 2023-11-03 18:05:54 +01:00
rhiannon morris 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
rhiannon morris 69f032584e fix constructor name in comment 2023-11-03 17:56:42 +01:00
rhiannon morris 9ecaaf72bd bump pack collection 2023-10-22 19:18:38 +02:00
rhiannon morris f04c4619ef detect reserved words inside names like 'a.λ.b' 2023-09-24 17:36:26 +02:00
rhiannon morris d4de74eab6 change it to #[..] since # is also reserved 2023-09-22 18:38:40 +02:00
rhiannon morris bcfb0d81b8 update tests 2023-09-22 18:38:32 +02:00
rhiannon morris 8395bec4cb check for duplicate cases in enum matches 2023-09-22 18:37:53 +02:00
rhiannon morris 6153b4f7f8 add a couple of failing examples 2023-09-22 14:03:22 +02:00
rhiannon morris 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
rhiannon morris ea674503c0 export PushSubsts, oops 2023-09-20 21:58:55 +02:00
rhiannon morris b1eefb0f4d move prettyTag to Quox.Pretty 2023-09-20 21:58:42 +02:00
rhiannon morris ee22486e97 rename BindName.name to .val 2023-09-20 21:58:27 +02:00
rhiannon morris 08fb686bf6 move Scoped to separate module 2023-09-20 21:58:04 +02:00
rhiannon morris cf3ed604a4 move Quox.Syntax.Var to just Quox.Var 2023-09-20 21:56:59 +02:00
rhiannon morris 4704dd0441 remove on-hold dir 2023-09-20 21:55:03 +02:00
rhiannon morris dc076b636d fix warnings 2023-09-19 18:13:45 +02:00
rhiannon morris 80b1b3581a use ST from base 2023-09-19 13:05:01 +02:00
rhiannon morris ebde478adc add η for pairs in zero contexts 2023-09-19 00:41:17 +02:00
rhiannon morris bb8d2464af add fst and snd 2023-09-18 21:53:38 +02:00
rhiannon morris e6c06a5c81 pass the subject quantity through equality etc
in preparation for non-linear η laws
2023-09-18 21:53:38 +02:00
rhiannon morris 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
rhiannon morris 244b33d786 fix some comments 2023-09-17 19:11:20 +02:00
rhiannon morris b85dcb5402 η for box
fixes #27
2023-09-17 19:11:12 +02:00
rhiannon morris e1257560b7 Show for contexts, etc 2023-09-17 19:09:54 +02:00
rhiannon morris ac518472ad bump pack db 2023-09-17 19:09:10 +02:00
rhiannon morris 4c88918ade stop throwing names away 2023-09-17 19:08:49 +02:00
rhiannon morris 7bd959e919 some example stuff 2023-09-17 14:41:29 +02:00
rhiannon morris 8221d71416 some refactors 2023-09-17 14:41:20 +02:00
rhiannon morris 7b53d56072 a few basic fv tests to make sure it's not reversed or whatever 2023-09-16 13:34:11 +02:00
rhiannon morris fa14ce1a02 add FreeVars, and split only on used dvars in Equal 2023-09-12 09:56:49 +02:00
rhiannon morris 9973f8d07b refactor elim equality error stuff 2023-09-12 06:48:51 +02:00
rhiannon morris 1e8932690b untangle big mutual block in Equal 2023-08-28 22:07:57 +02:00
rhiannon morris d5d30ee198 loosen pushCoe's type slightly 2023-08-28 20:03:06 +02:00
rhiannon morris 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
rhiannon morris 6f9d31aa0a add displacement to Definition 2023-08-28 19:59:36 +02:00
rhiannon morris 6dcd3332c1 granule & defuncn bibs 2023-08-28 19:57:42 +02:00
rhiannon morris 32f6e5a3b1 make displace total (with a few asserts) 2023-08-28 19:57:02 +02:00
rhiannon morris 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
rhiannon morris 3e3bf1b67f factor out this `case !mode of {..}` stuff 2023-08-27 19:04:30 +02:00
rhiannon morris 387d44431a add misc.coherence 2023-08-27 18:34:19 +02:00
rhiannon morris 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
rhiannon morris edfe30ff63 update compare0 for type-directed whnf 2023-08-26 21:32:15 +02:00
rhiannon morris ba77c45c64 always print the direction in coe/comp 2023-08-26 21:19:40 +02:00
rhiannon morris f3f74d581a fix Main 2023-08-26 21:07:10 +02:00
rhiannon morris 22db2724ce make coercion computation type-directed like it should be 2023-08-26 21:00:19 +02:00
rhiannon morris 0bcb8c24db make an optional Loc non-optional 2023-08-26 20:59:39 +02:00
rhiannon morris a221380d61 more effect stuff, incl. ST 2023-08-25 18:59:54 +02:00
rhiannon morris 4b6b3853a1 make uses of eff more consistent 2023-08-24 19:55:57 +02:00
rhiannon morris 8264a1bb81 split up whnf module 2023-08-24 18:42:26 +02:00
rhiannon morris a24ebe0702 tycasePi etc don't actually need a scope of (S d) 2023-08-24 17:45:37 +02:00
rhiannon morris 688204f1a4 make some things private 2023-08-24 17:45:20 +02:00
rhiannon morris 09e39d6224 add some comments 2023-08-24 17:45:12 +02:00
rhiannon morris 00d92d3f25 add missing parens in pretty printer 2023-08-12 10:25:07 +02:00
rhiannon morris c6006682ca add CREDITS.md 2023-08-10 16:44:28 +02:00
rhiannon morris cf9bfc2159 example stuff 2023-07-22 21:26:20 +02:00
rhiannon morris f6b8a12fab some more example stuff 2023-07-21 17:57:47 +02:00
rhiannon morris 932469a91e make quantities optional and default to 1 2023-07-18 23:12:04 +02:00
rhiannon morris 349cf2f477 remove unused Tighten impl 2023-07-17 18:10:13 +02:00
rhiannon morris 3c0989dcb2 maybe.quox 2023-07-17 18:10:04 +02:00
rhiannon morris b6264f388d fix #11 the easy way
tightening just pushes substitutions all the way through. bleh
2023-07-17 03:50:16 +02:00
rhiannon morris 612fb33663 bump again 2023-07-13 21:28:39 +02:00
rhiannon morris fa09aaf228 squash warnings 2023-06-23 18:32:05 +02:00
rhiannon morris 6eccfeef52 pack bump 2023-06-23 18:14:40 +02:00
rhiannon morris f0d3529f63 fix subtype stuff for Eq 2023-06-22 22:20:12 +02:00
rhiannon morris cd330c1092 remove a noLoc 2023-06-11 19:25:38 +02:00
rhiannon morris 865772d512 remove stale todos 2023-06-11 19:25:32 +02:00
rhiannon morris 00e79d4264 quote names in Show 2023-05-25 18:34:13 +02:00
rhiannon morris a11bedd62a update pack 2023-05-23 18:30:51 +02:00
rhiannon morris c5fa11bdec don't need this agda file any more 2023-05-23 18:30:44 +02:00
rhiannon morris 4aa3e5f730 some modal type bibs 2023-05-23 18:09:25 +02:00
rhiannon morris 3bbf0366c8 make 0 in ★₀ optional 2023-05-21 20:34:05 +02:00
rhiannon morris 7c68cd9098 multimodal type theory bib 2023-05-21 20:34:05 +02:00
rhiannon morris 282565c7a3 Whnf ⇒ CanWhnf; WhnfM ⇒ Eff Whnf 2023-05-21 20:34:05 +02:00
rhiannon morris 2af8ee20ea those were not meant to stay there 2023-05-21 20:34:05 +02:00
rhiannon morris 42aa07c9c8 crude but effective stratification 2023-05-21 20:34:05 +02:00
rhiannon morris e4a20cc632 remove redundancy in equality check 2023-05-20 21:38:23 +02:00
rhiannon morris 64de93a13c remove square brackets around type lines
(parens are needed if they are anything other than a `term arg`)
2023-05-16 18:14:42 +02:00
rhiannon morris d631b86be3 make p,q in coe/comp optional and default to @0 @1 2023-05-15 20:06:40 +02:00
rhiannon morris 7b93a913c7 rewrite pretty printer 2023-05-15 17:13:14 +02:00
rhiannon morris f6abf084b3 qty lub is total actually (usually ω) 2023-05-12 17:28:29 +02:00
rhiannon morris ba755a9c4b haha oops
i made this change to check an error and checked it in by accident
2023-05-02 23:08:49 +02:00
rhiannon morris 8d6ae6cc32 move location to the start of type errors 2023-05-02 19:03:05 +02:00
rhiannon morris d5f4a012c5 add source locations to inner syntax 2023-05-02 03:06:25 +02:00
rhiannon morris 30fa93ab4e refactor core syntax slightly to derive Eq/Show
add a new `WithSubst tm env to` record that packages a `tm from`
with a `Subst env from to`, and write instances for just that. the
rest of the AST can be derived
2023-04-27 21:37:20 +02:00
rhiannon morris 7e079a9668 add file locations to Parser.Syntax
they're immediately thrown away currently. but one step at a time
2023-04-26 06:12:03 +02:00
rhiannon morris 97f51b4436 all.quox 2023-04-26 02:47:02 +02:00
rhiannon morris b5f42cde64 remove big mutual blocks in parser 2023-04-26 02:28:08 +02:00
rhiannon morris adebfe090c error message tweaks 2023-04-24 23:19:15 +02:00
rhiannon morris b74ffa0077 rewrite parser
previously it backtracked too much, so instead of giving a useful
parse error, it just said "expected end of input" at the beginning of
the problem toplevel. which, if it's a namespace, could be way off.
2023-04-24 22:25:04 +02:00
rhiannon morris 6c3b82ca64 ebnf syntax 2023-04-23 17:33:50 +02:00
rhiannon morris 0a06ea1280 fix qtys on nat.eqb 2023-04-23 17:33:32 +02:00
rhiannon morris a4ffd74625 fix the most embarrassing quantity mistake ever 2023-04-20 19:29:57 +02:00
rhiannon morris 3f06e8d68b allow multiple names in a binder
e.g. "(x y : ℕ) × plus x y ≡ 10 : ℕ"

fixes #2
2023-04-19 21:37:51 +02:00
rhiannon morris b4a8438434 examples 2023-04-19 20:53:51 +02:00
rhiannon morris b666bc20cf do scope checking in FromParser where it belongs 2023-04-18 22:55:23 +02:00
rhiannon morris 55c0bf9974 fix skipping files 2023-04-18 00:10:53 +02:00
rhiannon morris 4578b30c79 namespaces work now 2023-04-18 00:10:53 +02:00
rhiannon morris 4db373a84f use constraints when checking δ
when checking δ 𝑖 ⇒ s, add 𝑖=ε to Ψ instead of checking s‹ε/𝑖›.
this has the same effect but an error message will show "𝑖, 𝑖=ε" in
the context
2023-04-17 22:02:40 +02:00
rhiannon morris ac85dc9352 don't put a ∷ℕ on nat literals that's silly 2023-04-17 22:02:40 +02:00
rhiannon morris 06b159973f pretty printing fixes 2023-04-17 21:45:05 +02:00
rhiannon morris 4ca32928fe examples 2023-04-17 21:44:16 +02:00
rhiannon morris c04c2e677c print quantity before names in main 2023-04-17 21:43:53 +02:00
rhiannon morris 682965eebd 0∨1 is not undefined it's ω 2023-04-17 21:42:33 +02:00
rhiannon morris 6428d39ce1 semicolons between decls in namespaces 2023-04-17 21:41:00 +02:00
rhiannon morris 3fb8580f85 re-add tightening and use it when messing with scopes
e.g. "coe [_ ⇒ A] @p @q s" should immediately reduce to "s",
but if the "_ ⇒ A" happened to use an SY it didn't.

this will still happen if a wrong SY sneaks in but the alternative is
re-traversing the term over and over every time whnf runs
2023-04-17 20:56:31 +02:00
rhiannon morris a5ccf0215a coercions and compositions 2023-04-15 15:13:01 +02:00
rhiannon morris 468ae7e444 qiits using containers paper 2023-04-15 14:15:07 +02:00
rhiannon morris a42e82c355 type-case 2023-04-03 17:46:23 +02:00
rhiannon morris 868550327c print ':' on same line as name always 2023-04-03 16:08:13 +02:00
rhiannon morris 29505cbc06 examples/misc.quox 2023-04-03 16:07:51 +02:00
rhiannon morris 1211272420 factor out some pretty printing stuff 2023-04-02 15:52:55 +02:00
rhiannon morris e1dbf272df rename EqualE to just Equal & add runEqual 2023-04-02 15:52:55 +02:00
rhiannon morris 38dbd275a1 add `case0` to syntax since that is possible sometimes 2023-04-02 15:52:55 +02:00
rhiannon morris 3f3079c48d bib: crude but effective stratification 2023-04-01 22:33:40 +02:00
rhiannon morris 308834a1c0 3 more tests 2023-04-01 22:07:01 +02:00
rhiannon morris ba2818a865 remove IsQty interface 2023-04-01 19:16:43 +02:00
rhiannon morris 5fdba77d04 nat example 2023-04-01 19:16:30 +02:00
rhiannon morris 924fd991f9 fix equality types 2023-04-01 16:02:02 +02:00
rhiannon morris 15f6f4c8a4 fix nat elim quantities 2023-04-01 16:01:53 +02:00
rhiannon morris 036e2bd4a5 fix case-box typing 2023-04-01 16:01:31 +02:00
rhiannon morris 1fce4d80f6 add box patterns to the parser oops 2023-04-01 15:59:16 +02:00
rhiannon morris a17752f31c fix up tests 2023-03-31 23:43:25 +02:00
rhiannon morris 5e220da2f4 a half-implemented verified dimeq 2023-03-31 19:34:24 +02:00
rhiannon morris 1ab0e42605 print a slightly better error if 'case' has no qty 2023-03-31 19:33:40 +02:00
rhiannon morris 13e9285bec some examples [that don't work yet] 2023-03-31 19:33:32 +02:00
rhiannon morris 64ac16c9f9 executable that typechecks files!! 2023-03-31 19:31:29 +02:00
rhiannon morris c8fbd73ea4 use names when pretty printing contexts 2023-03-31 19:30:55 +02:00
rhiannon morris ad942b2fd8 printing for most of FromParserError 2023-03-31 19:29:15 +02:00
rhiannon morris 2b2f79fca9 fix some typing mistakes 2023-03-31 19:26:55 +02:00
rhiannon morris 36609713ac mtl ⇒ eff 2023-03-31 19:26:24 +02:00
rhiannon morris 8a9b4c23dd box type 2023-03-31 19:26:24 +02:00
rhiannon morris 37dd1ee76d a few tests 2023-03-27 00:08:48 +02:00
rhiannon morris 7d36a7ff54 allow matching at 0 where appropriate
(for pairs, and for enums with 0 or 1 constructors)
2023-03-27 00:08:09 +02:00
rhiannon morris 137962c176 add missing %default total 2023-03-27 00:07:39 +02:00
rhiannon morris 773f6372ea quantities in case don't need to be *exactly* the same
...as long as they are all compatible with the target.
for example, given ω.n : ℕ:
```
  case double_it? return ℕ of {
    'true  ⇒ plus n n;
    'false ⇒ n
  }
```
2023-03-27 00:01:32 +02:00
rhiannon morris f620dda639 fix error message 2023-03-26 16:15:30 +02:00
rhiannon morris 5df2a4538c more tests 2023-03-26 16:15:19 +02:00
rhiannon morris 5560cb6708 move 'enum' to Syntax.Base 2023-03-26 16:14:58 +02:00
rhiannon morris e6c4203b46 print ; between case branches 2023-03-26 16:13:36 +02:00
rhiannon morris 46e13c8ca2 don't print empty contexts in errors 2023-03-26 16:11:11 +02:00
rhiannon morris 84e1cc78cc use a SnocVect for subN 2023-03-26 16:09:47 +02:00
rhiannon morris 8402da6d5e dimeq test printing fix 2023-03-26 14:45:32 +02:00
rhiannon morris 7e3a8e72bd clean up printing of contexts
- just π.x : A instead of π.(x : A)
- skip the " |" if the dctx is empty
2023-03-26 14:41:48 +02:00
rhiannon morris 78e48911d0 check that an enum case head has the right type
haha oops
2023-03-26 14:41:20 +02:00
rhiannon morris 9250789219 natural numbers 2023-03-26 14:40:54 +02:00
rhiannon morris fae534dae0 tweaks in equality checking 2023-03-26 14:38:37 +02:00
rhiannon morris 5053e9b234 remove inject stuff
injecting from m to (n+m) is just id ::: id ::: ... ::: shift n.
specifically, injecting from 0 is just the shift. so.
2023-03-25 22:44:30 +01:00
rhiannon morris 126a585c74 remove unused dep 2023-03-25 20:55:47 +01:00
rhiannon morris 5945265867 some DimEq tests 2023-03-25 20:55:38 +01:00
rhiannon morris 50c682f715 bump 2023-03-25 20:54:47 +01:00
rhiannon morris 75376619f9 move pretty stuff for DimEq 2023-03-25 20:54:31 +01:00
rhiannon morris ab73c474c3 add DimEq.wf and export some things to make it work 2023-03-25 20:51:10 +01:00
rhiannon morris 5a994ac0e2 derive Eq,Ord,Show for DimEq 2023-03-25 20:51:10 +01:00
rhiannon morris ab82883214 add weakD 2023-03-25 20:48:49 +01:00
rhiannon morris 100063ab91 add runPrettyWith, etc 2023-03-25 20:48:26 +01:00
rhiannon morris 60079d9eb9 update for tap update 2023-03-25 20:42:44 +01:00
rhiannon morris 443da20c4b print non-dependent function types as "π.A → B" 2023-03-18 23:33:18 +01:00
rhiannon morris 8f0f0c1891 "1.(x: A) → B" instead of "(1.x: A) → B"
also "1.A → B"
2023-03-18 23:27:27 +01:00
rhiannon morris ebf6aefb1d parser tweaks
qtys and dims don't allow useless parens any more. everything else
should be the same
2023-03-18 20:03:01 +01:00
rhiannon morris 51468f54fc misc parse/print tests 2023-03-18 02:47:15 +01:00
rhiannon morris ea24d00544 print non-dependent products (easy mode)
only if the AST uses SN, like with Eq
2023-03-18 02:46:41 +01:00
rhiannon morris 958bc2f8b8 quote tags in printing if they're not identifiers 2023-03-18 02:45:43 +01:00
rhiannon morris f2272da4b4 replace '≔' and '·' with '=' and (only) '.' 2023-03-18 02:43:58 +01:00
rhiannon morris 1c53b63bdf uh. fix Tests.Lexer 2023-03-17 21:51:28 +01:00
rhiannon morris 8cf260ee2e reorder some imports 2023-03-17 21:50:04 +01:00
rhiannon morris f814b01c5c quote tags in printer when needed 2023-03-16 18:39:24 +01:00
rhiannon morris be94422668 move name lexing stuff to Quox.Name 2023-03-16 18:34:49 +01:00
rhiannon morris b9825fee55 ?????? 2023-03-16 18:20:33 +01:00
rhiannon morris f5fa63a6df some pretty printing tests 2023-03-16 18:19:17 +01:00
rhiannon morris 6dc7177be5 use NContext/SnocVect for scope name lists etc 2023-03-16 18:18:49 +01:00
rhiannon morris 32f38238ef pretty printing errors 2023-03-15 15:54:51 +01:00
rhiannon morris 54ba4e237f use snoclists in pretty printing
i think the names were in the wrong sometimes!!!
2023-03-15 15:53:39 +01:00
rhiannon morris c9b9f66693 rename 'prettyTerm' to 'prettyIO'
it meant pretty*Terminal*, but,
2023-03-15 15:42:28 +01:00
rhiannon morris 86d21caf24 put names into contexts, and contexts into errors 2023-03-14 16:04:41 +01:00
rhiannon morris f4af1a5a78 split up Quox.Typing 2023-03-13 21:41:57 +01:00
rhiannon morris ecd3be8bda "WhnfErr" ⇒ "WhnfError" 2023-03-13 19:39:29 +01:00
rhiannon morris 765c62866a more FromParser 2023-03-13 19:33:09 +01:00
rhiannon morris 90232dd1f8 rename some things to get rid of warnings 2023-03-13 19:32:52 +01:00
rhiannon morris 507eb79788 consistent indexing 2023-03-13 19:31:52 +01:00
rhiannon morris 7f46537cbc "abstract" ⇒ "postulate"
abstracts still have a body, just not always visible. which i will deal
with Later
2023-03-13 19:31:05 +01:00
rhiannon morris 8e9b0abb34 Show Telescope 2023-03-13 18:25:07 +01:00
rhiannon morris c81aabcc14 more parser/FromParser stuff
- top level semicolons optional
- type optional [the def will need to be an elim]
- `load` statement
- namespaces
2023-03-12 18:28:37 +01:00
rhiannon morris cd63eb2c67 the "observational" here doesn't really say anything new 2023-03-10 23:42:39 +01:00
rhiannon morris d9bc68446f more fromparser stuff 2023-03-10 21:52:29 +01:00
rhiannon morris 426c138c2b clean up some old unused stuff 2023-03-08 22:33:52 +01:00
rhiannon morris 88985405ce change some single-character constructor names 2023-03-08 17:13:51 +01:00
rhiannon morris 47fca359f4 fix weird IsReserved issue 2023-03-06 12:04:43 +01:00
rhiannon morris 757ea89b0f add definitions to parser 2023-03-06 12:04:29 +01:00
rhiannon morris ab2508e0ce add fromPTerm, etc 2023-03-05 16:50:05 +01:00
rhiannon morris b7acf39c39 remove universe type 2023-03-05 16:48:29 +01:00
rhiannon morris 0cae84c75b add module Parser.Syntax with PTerm and toPTerm 2023-03-05 14:55:04 +01:00
rhiannon morris 8fc0b414cf fix tag stuff in test labels 2023-03-05 13:17:46 +01:00
rhiannon morris 02b94ab705 split check and checkType. UAny is kill 2023-03-05 13:14:25 +01:00
rhiannon morris 21da2d1d21 add - as an idCont char 2023-03-05 12:18:39 +01:00
rhiannon morris f6bc8cad1f add some dim app tests 2023-03-05 12:18:15 +01:00
rhiannon morris edeee68cb7 parser 2023-03-04 21:35:09 +01:00
rhiannon morris 95a6644a6c rename <&&>/<||> to andM/orM 2023-03-03 12:19:15 +01:00
rhiannon morris 841564f69f fix typo in comment 2023-03-02 19:56:22 +01:00
rhiannon morris 0a2d05818e fix fixities 2023-03-02 19:56:16 +01:00
rhiannon morris fc3c2dc8ab sop → elab-util 2023-03-02 19:52:32 +01:00
rhiannon morris 04d3c9368a replace nix with pack 2023-03-02 19:51:25 +01:00
rhiannon morris dbe248be9a lexer 2023-02-28 20:51:54 +01:00
rhiannon morris cacb3225a2 unicode stuff 2023-02-27 07:27:27 +01:00
rhiannon morris 28356200c1 pretty printer refactoring 2023-02-26 14:54:18 +01:00
rhiannon morris 75ef078b4b don't print substitutions by default 2023-02-26 11:25:11 +01:00
rhiannon morris 8447098f28 look through substitutions in Q.S.T.Split 2023-02-26 11:24:28 +01:00
rhiannon morris e896b24f58 print ` before enum types 2023-02-26 11:23:43 +01:00
rhiannon morris eaf679edf7 print dimension app with an @ 2023-02-26 11:22:44 +01:00
rhiannon morris ab63edf572 print bound vars as e.g. x#1 instead of x:1 2023-02-26 11:21:47 +01:00
rhiannon morris 4826c35ad6 rearrange some auto args for better overriding 2023-02-26 11:21:25 +01:00
rhiannon morris 82a2f92ddf pprint universes as a direct suffix
in subscript in unicode mode
2023-02-26 11:20:06 +01:00
rhiannon morris fbfbe57266 change some highlighting 2023-02-26 11:18:11 +01:00
rhiannon morris 60f07a938e move pushSubsts to Q.S.T.Subst 2023-02-26 11:17:42 +01:00
rhiannon morris 55cdb19a4c replace ⇒ with . in lambdas, etc
also remove some weird duplication in the tests
2023-02-26 11:16:29 +01:00
rhiannon morris 630832f6c7 tweak quog tongue
h-hey!
2023-02-26 10:58:48 +01:00
rhiannon morris c25b910edf fix Main.idr 2023-02-26 10:58:22 +01:00
rhiannon morris 79a828449a use ★ for Type in unicode mode 2023-02-25 19:14:26 +01:00
rhiannon morris 4b284d6e01 rename λᴰ to δ
sorry fen
2023-02-25 19:14:11 +01:00
rhiannon morris 302de6266e nicer constructors for ASTs 2023-02-25 15:26:11 +01:00
rhiannon morris 3d9b730803 some more typechecker tests 2023-02-23 10:04:16 +01:00
rhiannon morris 4b814d7502 fix quantity in CasePair typing 2023-02-23 10:04:00 +01:00
rhiannon morris abe812fc40 update tap, also other flakes 2023-02-23 10:02:45 +01:00
rhiannon morris efca9a7138 add enums, which also need whnf to be fallible :( 2023-02-22 07:45:10 +01:00
rhiannon morris 0e481a8098 new representation for scopes 2023-02-22 07:40:19 +01:00
rhiannon morris c75f1514ba add BoolExtra 2023-02-22 05:42:56 +01:00
rhiannon morris 1a7efc104e Replace subst overloading with interfaces too (mostly) 2023-02-20 22:22:49 +01:00
rhiannon morris cb5bd6c98c make overloaded reduce stuff into interfaces
this is kinda a pain so i might change it back i guess
2023-02-20 21:42:31 +01:00
rhiannon morris 56791e286d make typechecker NotClo args implicit 2023-02-20 21:42:21 +01:00
rhiannon morris f959dc28fe add Functor etc for IfConsistent 2023-02-20 21:38:47 +01:00
rhiannon morris 7895fa37e5 Q.S.T.Reduce ⇒ Q.Reduce and make it use Definition directly 2023-02-19 18:54:59 +01:00
rhiannon morris ae43c324c0 remove commented modules from ipkg 2023-02-19 18:22:27 +01:00
rhiannon morris 876a45f565 fix "make clean" 2023-02-19 18:21:52 +01:00
rhiannon morris 85a55f8123 wrap type errors in extra context 2023-02-19 17:54:39 +01:00
rhiannon morris 858b5db530 check for 0=1 in typechecker 2023-02-19 17:51:44 +01:00
rhiannon morris 195791e158 export isSubSing 2023-02-19 17:43:49 +01:00
rhiannon morris 27e61011ac %inline 2023-02-19 17:43:14 +01:00
rhiannon morris 810de09f61 zeroIsSubj/zeroIsGlobal work on all zeroes 2023-02-19 17:42:11 +01:00
rhiannon morris e375d008e5 comments etc 2023-02-19 17:04:57 +01:00
rhiannon morris d71ac8c34d rename Equal.Env to CmpContext 2023-02-19 17:02:13 +01:00
rhiannon morris cba6dafc58 remove unused confusing ClashE 2023-02-19 17:00:51 +01:00
rhiannon morris 9bfc82ca43 add a bib entry, update some links
use some unicode
2023-02-19 16:14:56 +01:00
rhiannon morris f22f194dc5 add `super` counterparts to `sub` 2023-02-14 22:29:06 +01:00
rhiannon morris bee6eeacdf pass a `TyContext` into `equal` etc, rather than its components 2023-02-14 22:28:10 +01:00
rhiannon morris 065ebedf2d use DimEq directly in typing context 2023-02-14 21:29:04 +01:00
rhiannon morris 4b7379f094 fix tiny bug in dimeq 2023-02-14 21:28:50 +01:00
rhiannon morris 802dfae493 slight simplify 2023-02-14 21:16:20 +01:00
rhiannon morris c40e6a60ff remove input qctx since it isn't used 2023-02-14 21:14:47 +01:00
rhiannon morris 846bbc9ca3 more tc tests 2023-02-13 22:06:53 +01:00
rhiannon morris 534e0d2270 return () from check0
since it always returns 𝟎 anyway
2023-02-13 22:06:03 +01:00
rhiannon morris fe8c224299 write quantities before names in binders again
also fixup comments in typechecker
2023-02-13 22:05:27 +01:00
rhiannon morris a6f43a772e more equality & tests 2023-02-12 21:30:08 +01:00
rhiannon morris 3b9da2a1e5 update TAP 2023-02-11 23:38:05 +01:00
rhiannon morris 7d2c3b5a8e more typed equality, uip, etc 2023-02-11 18:15:50 +01:00
rhiannon morris 7fd7a31635 write variables as #𝑖
previously non-coloured output was too ambiguous
2023-02-11 18:14:31 +01:00
rhiannon morris ac0334ca4c reexport needed types from Term.Split 2023-02-11 18:14:12 +01:00
rhiannon morris 8de5803cba add Context.unzip 2023-02-11 18:13:44 +01:00
rhiannon morris 42798f243f typed equality 2023-02-10 21:52:40 +01:00
rhiannon morris 3b13f0a82c silence a warning 2023-02-02 14:58:36 +01:00
rhiannon morris 4b36d8b7c8 pair stuff 2023-01-26 19:55:08 +01:00
rhiannon morris 6073ab4705 replace Split stuff with bools 2023-01-23 03:39:46 +01:00
rhiannon morris f0f49d9abf ScopeTerms that can bind multiple vars 2023-01-23 03:22:50 +01:00
rhiannon morris 92617a2e4a whnf actually reduces to whnf now (probably) 2023-01-23 03:02:55 +01:00
rhiannon morris f097e1c091 start of equality type stuff 2023-01-21 02:34:28 +01:00
rhiannon morris 8acc3aeadf visibility fix 2023-01-21 01:41:30 +01:00
rhiannon morris 8a2eea22fb make Definitions.isZero a predicate 2023-01-21 01:41:21 +01:00
rhiannon morris 1dc0c913e7 mugen in bib 2023-01-18 21:24:45 +01:00
rhiannon morris b25e5320d9 some more properties of var 2023-01-12 16:03:09 +01:00
rhiannon morris ef8b8b0da3 index Var.Compare by compare
i may go back on this if it's too annoying
2023-01-10 00:17:24 +01:00
rhiannon morris f405aeb7f9 simplify some matches 2023-01-09 23:45:21 +01:00
rhiannon morris 82795e9976 remove IsOne stuff; add timesSubj 2023-01-09 23:43:55 +01:00
rhiannon morris 28055c0f39 add Decidable-related stuff 2023-01-09 23:43:23 +01:00
rhiannon morris 84e524c978 make typechecker actually pass the dimeq to subT
also erase some length arguments
2023-01-09 19:03:21 +01:00
rhiannon morris d8df40ab39 β↘↙ test 2023-01-08 21:46:42 +01:00
rhiannon morris c45a963ba0 parameterise over qty semiring 2023-01-08 20:44:25 +01:00
rhiannon morris 961c8415b5 a skipped η test 2023-01-08 15:44:29 +01:00
rhiannon morris 28eb99c091 style tweaks 2023-01-08 15:44:20 +01:00
rhiannon morris 0c1b3a78c3 remove ope stuff too 2023-01-08 15:43:54 +01:00
rhiannon morris 9dbd0b066c AnyTerm.(.def) => (.get) 2023-01-08 15:07:01 +01:00
rhiannon morris 98fa8d9967 mode eq mode into a reader 2023-01-08 14:59:25 +01:00
rhiannon morris 8443b2f6d8 remove lex/parse stuff for now 2023-01-08 14:58:18 +01:00
rhiannon morris 44c4aea06c nix flake update 2023-01-07 14:06:19 +01:00
rhiannon morris 881b22eee6 %inline 2022-11-01 21:07:52 +01:00
rhiannon morris 68dd93c02e remove a believe_me 2022-11-01 21:05:04 +01:00
rhiannon morris ad794d4441 idris 0.6.0 [with temporary flake fork] 2022-10-30 18:05:30 +01:00
rhiannon morris 72c25ad5e7 flake fix 2022-10-30 17:20:09 +01:00
134 changed files with 16579 additions and 3760 deletions

2
.gitignore vendored
View File

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

4
CREDITS.md Normal file
View File

@ -0,0 +1,4 @@
the "logo" is an edit of [an emoji] made by [khr].
[an emoji]: https://github.com/chr-1x/dragn-emoji
[khr]: https://dragon.monster

View File

@ -1,38 +0,0 @@
all: quox
NIXFLAGS := --no-warn-dirty
# these two are real files, but always ask nix if they need remaking
.PHONY: quox
quox:
@echo [build] quox
nix build $(NIXFLAGS) --no-link '.#quox'
ln -sfL $$(nix path-info $(NIXFLAGS) '.#quox')/bin/quox quox
.PHONY: quox-tests
quox-tests:
@echo [build] quox-tests
nix build $(NIXFLAGS) --no-link '.#quox-tests'
ln -sfL $$(nix path-info $(NIXFLAGS) '.#quox-tests')/bin/quox-tests quox-tests
.PHONY: lib
lib:
@echo [build] quox-lib
nix build $(NIXFLAGS) --no-link '.#quox-lib'
.PHONY: test
test:
nix run $(NIXFLAGS) -- '.#quox-tests' -V 14 -c
.PHONY: prove
prove:
nix build $(NIXFLAGS) --no-link '.#quox-tests'
prove $$(nix path-info $(NIXFLAGS) '.#quox-tests')/bin/quox-tests
.PHONY: clean
clean:
@echo [clean]
rm -f quox quox-tests result
.SILENT:

View File

@ -1,4 +1,4 @@
# ![](qtuwu.png) quantitative observational extensional(ish) type theory
# ![](qtuwu.png) quantitative extensional(ish) type theory
hey what would happen if some idiot tried to weld qtt and xtt together?
let's find out together

View File

@ -1 +0,0 @@
(import (fetchTarball "https://github.com/edolstra/flake-compat/archive/master.tar.gz") { src = ./.; }).defaultNix

10
examples/all.quox Normal file
View File

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

39
examples/bool.quox Normal file
View File

@ -0,0 +1,39 @@
load "misc.quox";
namespace bool {
def0 Bool : ★ = {true, 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 : ★) → (b : Bool) → ω.A → ω.A → A =
λ A ⇒ if-dep (λ _ ⇒ A);
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);
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 (𝑖 ⇒ T (eq @𝑖)) 'true;
-- [todo] infix
def and : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
def or : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
}
def0 Bool = bool.Bool;

74
examples/either.quox Normal file
View File

@ -0,0 +1,74 @@
load "misc.quox";
load "bool.quox";
namespace either {
def0 Tag : ★ = {left, right};
def0 Payload : ★ → ★ → Tag → ★ =
λ A B tag ⇒ case tag return ★ of { 'left ⇒ A; 'right ⇒ B };
def0 Either : ★ → ★ → ★ =
λ A B ⇒ (tag : Tag) × Payload A B tag;
def Left : 0.(A B : ★) → A → Either A B =
λ A B x ⇒ ('left, x);
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) → ★) →
ω.((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 ⇒
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) → ★) →
ω.((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 ⇒
case e return e' ⇒ P e' of { (t, a) ⇒ elim' A B P f g t a };
}
def0 Either = either.Either;
def Left = either.Left;
def Right = either.Right;
namespace dec {
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 : ★ → ★ =
λ 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)) →
(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 : ★) → Dec A → Bool =
λ A ⇒ elim A (λ _ ⇒ Bool) (λ _ ⇒ 'true) (λ _ ⇒ 'false);
}
def0 Dec = dec.Dec;
def0 DecEq = dec.DecEq;
def Yes = dec.Yes;
def No = dec.No;

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
}

91
examples/list.quox Normal file
View File

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

68
examples/maybe.quox Normal file
View File

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

83
examples/misc.quox Normal file
View File

@ -0,0 +1,83 @@
def0 True : ★ = {true}
def0 False : ★ = {}
def0 Not : ★ → ★ = λ A ⇒ ω.A → False
def void : 0.(A : ★) → 0.False → A =
λ A v ⇒ case0 v return A of { }
def0 All : (A : ★) → (0.A → ★) → ★ =
λ A P ⇒ (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
def0 eq-f :
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
def funext :
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 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 @𝑗 }
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 @𝑖)]) }
}
}

165
examples/nat.quox Normal file
View File

@ -0,0 +1,165 @@
load "misc.quox";
load "bool.quox";
load "either.quox";
namespace nat {
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 ⇒
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 dup : → [ω.] =
λ n ⇒ appω (Sing n) (sing.val n) (dup! n);
#[compile-scheme "(lambda% (m n) (+ m n))"]
def plus : =
λ m n ⇒
case m return of {
zero ⇒ n;
succ _, p ⇒ succ p
};
#[compile-scheme "(lambda% (m n) (* m n))"]
def timesω : → ω. =
λ m n ⇒
case m return of {
zero ⇒ zero;
succ _, t ⇒ plus n t
};
def times : =
λ m n ⇒ case dup n return of { [n] ⇒ timesω m 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 : (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 : → ★ =
λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True };
def isSucc? : ω.(n : ) → Dec (IsSucc n) =
λ n ⇒
caseω n return n' ⇒ Dec (IsSucc n') of {
zero ⇒ No (IsSucc zero) (λ v ⇒ v);
succ n ⇒ Yes (IsSucc (succ n)) 'true
};
def zero-not-succ : 0.(m : ) → Not (zero ≡ succ m : ) =
λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) @1 @0 'true;
def succ-not-zero : 0.(m : ) → Not (succ m ≡ zero : ) =
λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true;
def0 not-succ-self : (m : ) → Not (m ≡ succ m : ) =
λ m ⇒
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
return m' ⇒ ω.(n : ) → Dec (m' ≡ n : )
of {
zero ⇒ λ n ⇒
caseω n return n' ⇒ Dec (zero ≡ n' : ) of {
zero ⇒ Yes (zero ≡ zero : ) (δ _ ⇒ zero);
succ n' ⇒ No (zero ≡ succ n' : ) (λ eq ⇒ zero-not-succ n' eq)
};
succ m', ω.ih ⇒ λ n ⇒
caseω n return n' ⇒ Dec (succ m' ≡ n' : ) of {
zero ⇒ No (succ m' ≡ zero : ) (λ eq ⇒ succ-not-zero m' eq);
succ n' ⇒
dec.elim (m' ≡ n' : ) (λ _ ⇒ Dec (succ m' ≡ succ n' : ))
(λ y ⇒ Yes (succ m' ≡ succ n' : ) (δ 𝑖 ⇒ succ (y @𝑖)))
(λ n ⇒ No (succ m' ≡ succ n' : ) (λ eq ⇒ n (succ-inj m' n' eq)))
(ih n')
}
};
def eqb : ω. → ω. → Bool = λ m n ⇒ dec.bool (m ≡ n : ) (eq? m n);
def0 plus-zero : (m : ) → m ≡ plus m 0 : =
λ m ⇒
case m return m' ⇒ m' ≡ plus m' 0 : of {
zero ⇒ δ _ ⇒ 0;
succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
};
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 @𝑖)
};
def0 plus-comm : (m n : ) → plus m n ≡ plus n m : =
λ m n ⇒
case m return m' ⇒ plus m' n ≡ plus n m' : of {
zero ⇒ plus-zero n;
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 @𝑖)
};
-}
}

74
examples/pair.quox Normal file
View File

@ -0,0 +1,74 @@
namespace pair {
def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x;
{-
-- 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 : 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 : 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 ⇒
case p return p' ⇒ C (fst p') (snd p') of { (x, y) ⇒ f x y };
def uncurry' :
0.(A B C : ★) → (A → B → C) → (A × B) → C =
λ A B C ⇒ uncurry A (λ _ ⇒ B) (λ _ _ ⇒ C);
def curry :
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 : ★) → (A × B → C) → A → B → C =
λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C);
def0 fst-snd :
(A : ★) → (B : A → ★) →
(p : Σ A B) → p ≡ (fst p, snd p) : Σ A B =
λ A B p ⇒
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 : 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 ⇒
case p return Σ A' B' of { (x, y) ⇒ (f x, g x y) };
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;

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,16 +1,121 @@
module Main
import public Quox.Name
import public Quox.Syntax
import public Quox.Equal
import public Quox.Pretty
import public Quox.Typechecker
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 CompileMonad
import Data.Nat
import Data.Vect
import Data.List
import Control.ANSI
import System
import System.File
import Data.IORef
import Control.Eff
%default total
%hide Doc.(>>=)
%hide Core.(>>=)
%hide FromParser.Error
%hide Erase.Error
%hide Lexer.Error
%hide Parser.Error
private
Step : Type -> Type -> Type
Step a b = OpenFile -> a -> Eff Compile b
private
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 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
(_, opts, files) <- options
case !(runCompile opts !newState $ traverse_ processFile files) of
Right () => pure ()
Left e => dieError opts e
-----------------------------------
{-
private
text : PrettyOpts -> List String
@ -22,22 +127,29 @@ text _ =
#" /_/"#,
""]
-- ["",
-- #" __ _ _ _ _____ __"#,
-- #"/ _` | || / _ \ \ /"#,
-- #"\__, |\_,_\___/_\_\"#,
-- #" |_|"#,
-- ""]
private
qtuwu : PrettyOpts -> List String
qtuwu opts =
if opts.unicode then
[#" ___,-´⎠ "#,
#"(·`──´ ◡ -´⎠"#,
#" \/´/`´ "#,
#" ⋃────,-₎ ⎞ "#,
#" (‾‾) ⎟ "#,
#" \/\/──´⎞/`──´ "#,
#" ⎜⎟───,-₎ ⎞ "#,
#" ⎝⎠ (‾‾) ⎟ "#,
#" (‾‾‾) ⎟ "#]
else
[#" ___,-´/ "#,
#"(.`--´ u -´/"#,
#" \/\/--´|/`--´ "#,
#" U----,-, \ "#,
#" (--) | "#,
#" ||---,-, \ "#,
#" `´ (--) | "#,
#" (---) | "#]
private
@ -51,16 +163,4 @@ join1 opts l r =
export
banner : PrettyOpts -> String
banner opts = unlines $ zipWith (join1 opts) (qtuwu opts) (text opts)
export
tm : Term 1 2
tm =
(Pi One "a" (BVT 0) (TUsed $ E (F "F" :@@ [BVT 0, FT "w"]))
`DCloT` (K One ::: id))
`CloT` (F "y" ::: TYPE (U 1) :# TYPE (U 2) ::: id)
main : IO Unit
main = do
putStrLn $ banner defPrettyOpts
prettyTermDef tm
prettyTermDef $ pushSubstsT tm
-}

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

View File

@ -1,588 +0,0 @@
{
"nodes": {
"Prettier": {
"flake": false,
"locked": {
"lastModified": 1639310097,
"narHash": "sha256-+eSLEJDuy2ZRkh1h0Y5IF6RUeHEcWhAHpWhwdwW65f0=",
"owner": "Z-snails",
"repo": "prettier",
"rev": "4a90663b1d586f6d6fce25873aa0f0d7bc633b89",
"type": "github"
},
"original": {
"owner": "Z-snails",
"repo": "prettier",
"type": "github"
}
},
"collie": {
"flake": false,
"locked": {
"lastModified": 1631011321,
"narHash": "sha256-goYctB+WBoLgsbjA0DlqGjD8i9wr1K0lv0agqpuwflU=",
"owner": "ohad",
"repo": "collie",
"rev": "ed2eda5e04fbd02a7728e915d396e14cc7ec298e",
"type": "github"
},
"original": {
"owner": "ohad",
"repo": "collie",
"type": "github"
}
},
"comonad": {
"flake": false,
"locked": {
"lastModified": 1638093386,
"narHash": "sha256-kxmN6XuszFLK2i76C6LSGHe5XxAURFu9NpzJbi3nodk=",
"owner": "stefan-hoeck",
"repo": "idris2-comonad",
"rev": "06d6b551db20f1f940eb24c1dae051c957de97ad",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-comonad",
"type": "github"
}
},
"dom": {
"flake": false,
"locked": {
"lastModified": 1639041519,
"narHash": "sha256-4ZYc0qaUEVARxhWuH3JgejIeT+GEDNxdS6zIGhBCk34=",
"owner": "stefan-hoeck",
"repo": "idris2-dom",
"rev": "01ab52d0ffdb3b47481413a949b8f0c0688c97e4",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-dom",
"type": "github"
}
},
"dot-parse": {
"flake": false,
"locked": {
"lastModified": 1638264571,
"narHash": "sha256-VJQITz+vuQgl5HwR5QdUGwN8SRtGcb2/lJaAVfFbiSk=",
"owner": "CodingCellist",
"repo": "idris2-dot-parse",
"rev": "48fbda8bf8adbaf9e8ebd6ea740228e4394154d9",
"type": "github"
},
"original": {
"owner": "CodingCellist",
"repo": "idris2-dot-parse",
"type": "github"
}
},
"effect": {
"flake": false,
"locked": {
"lastModified": 1637477153,
"narHash": "sha256-Ta2Vogg/IiSBkfhhD57jjPTEf3S4DOiVRmof38hmwlM=",
"owner": "russoul",
"repo": "idris2-effect",
"rev": "ea1daf53b2d7e52f9917409f5653adc557f0ee1a",
"type": "github"
},
"original": {
"owner": "russoul",
"repo": "idris2-effect",
"type": "github"
}
},
"elab-util": {
"flake": false,
"locked": {
"lastModified": 1639041013,
"narHash": "sha256-K61s/xifFiTDXJTak5NZmZL6757CTYCY+TGywRZMD7M=",
"owner": "stefan-hoeck",
"repo": "idris2-elab-util",
"rev": "7a381c7c5dc3adb7b97c8b8be17e4fb4cc63027d",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-elab-util",
"type": "github"
}
},
"flake-utils": {
"locked": {
"lastModified": 1659877975,
"narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"frex": {
"flake": false,
"locked": {
"lastModified": 1637410704,
"narHash": "sha256-BthU1t++n0ZvS76p0fCHsE33QSoXYxf0hMUSKajDY8w=",
"owner": "frex-project",
"repo": "idris-frex",
"rev": "22c480e879c757a5cebca7bb555ec3d21ae3ac28",
"type": "github"
},
"original": {
"owner": "frex-project",
"repo": "idris-frex",
"type": "github"
}
},
"fvect": {
"flake": false,
"locked": {
"lastModified": 1633247988,
"narHash": "sha256-zElIze03XpcrYL4H5Aj0ZGNplJGbtOx+iWnivJMzHm0=",
"owner": "mattpolzin",
"repo": "idris-fvect",
"rev": "1c5e3761e0cd83e711a3535ef9051bea45e6db3f",
"type": "github"
},
"original": {
"owner": "mattpolzin",
"repo": "idris-fvect",
"type": "github"
}
},
"hashable": {
"flake": false,
"locked": {
"lastModified": 1633965157,
"narHash": "sha256-Dggf5K//RCZ7uvtCyeiLNJS6mm+8/n0RFW3zAc7XqPg=",
"owner": "z-snails",
"repo": "idris2-hashable",
"rev": "d6fec8c878057909b67f3d4da334155de4f37907",
"type": "github"
},
"original": {
"owner": "z-snails",
"repo": "idris2-hashable",
"type": "github"
}
},
"hedgehog": {
"flake": false,
"locked": {
"lastModified": 1639041435,
"narHash": "sha256-893cPy7gGSQpVmm9co3QCpWsgjukafZHy8YFk9xts30=",
"owner": "stefan-hoeck",
"repo": "idris2-hedgehog",
"rev": "a66b1eb0bf84c4a7b743cfb217be69866bc49ad8",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-hedgehog",
"type": "github"
}
},
"idrall": {
"flake": false,
"locked": {
"lastModified": 1636495701,
"narHash": "sha256-aOdCRd4XsSxwqVGta1adlZBy8TVTxTwFDnJ1dyMZK8M=",
"owner": "alexhumphreys",
"repo": "idrall",
"rev": "13ef174290169d05c9e9abcd77c53412e3e0c944",
"type": "github"
},
"original": {
"owner": "alexhumphreys",
"ref": "13ef174",
"repo": "idrall",
"type": "github"
}
},
"idris-server": {
"flake": false,
"locked": {
"lastModified": 1634507315,
"narHash": "sha256-ulo23yLJXsvImoMB/1C6yRRTqmn/Odo+aUaVi+tUhJo=",
"owner": "avidela",
"repo": "idris-server",
"rev": "661a4ecf0fadaa2bd79c8e922c2d4f79b0b7a445",
"type": "gitlab"
},
"original": {
"owner": "avidela",
"repo": "idris-server",
"type": "gitlab"
}
},
"idris2": {
"flake": false,
"locked": {
"lastModified": 1639427352,
"narHash": "sha256-C1K2FM1Kio8vi9FTrivdacYCX4cywIsLBeNCsZ6ft4g=",
"owner": "idris-lang",
"repo": "idris2",
"rev": "36918e618646177b1e0c2fd01f21cc8d04d9da30",
"type": "github"
},
"original": {
"owner": "idris-lang",
"repo": "idris2",
"type": "github"
}
},
"idris2-pkgs": {
"inputs": {
"Prettier": "Prettier",
"collie": "collie",
"comonad": "comonad",
"dom": "dom",
"dot-parse": "dot-parse",
"effect": "effect",
"elab-util": "elab-util",
"flake-utils": [
"flake-utils"
],
"frex": "frex",
"fvect": "fvect",
"hashable": "hashable",
"hedgehog": "hedgehog",
"idrall": "idrall",
"idris-server": "idris-server",
"idris2": "idris2",
"indexed": "indexed",
"inigo": "inigo",
"ipkg-to-json": "ipkg-to-json",
"json": "json",
"katla": "katla",
"lsp": "lsp",
"nixpkgs": [
"nixpkgs"
],
"odf": "odf",
"pretty-show": "pretty-show",
"python": "python",
"rhone": "rhone",
"rhone-js": "rhone-js",
"snocvect": "snocvect",
"sop": "sop",
"tailrec": "tailrec",
"xml": "xml"
},
"locked": {
"lastModified": 1642030375,
"narHash": "sha256-J1uXnpPR72mjFjLBuYcvDHStBxVya6/MjBNNwqxGeD0=",
"owner": "claymager",
"repo": "idris2-pkgs",
"rev": "ac33a49d4d4bd2b50fddb040cd889733a02c8f09",
"type": "github"
},
"original": {
"owner": "claymager",
"repo": "idris2-pkgs",
"type": "github"
}
},
"indexed": {
"flake": false,
"locked": {
"lastModified": 1638685238,
"narHash": "sha256-FceB7o88yKYzjTfRC6yfhOL6oDPMmCQAsJZu/pjE2uA=",
"owner": "mattpolzin",
"repo": "idris-indexed",
"rev": "ff3ba99b0063da6a74c96178e7f3c58a4ac1693e",
"type": "github"
},
"original": {
"owner": "mattpolzin",
"repo": "idris-indexed",
"type": "github"
}
},
"inigo": {
"flake": false,
"locked": {
"lastModified": 1637596767,
"narHash": "sha256-LNx30LO0YWDVSPTxRLWGTFL4f3d5ANG6c60WPdmiYdY=",
"owner": "idris-community",
"repo": "Inigo",
"rev": "57f5b5c051222d8c630010a0a3cf7d7138910127",
"type": "github"
},
"original": {
"owner": "idris-community",
"repo": "Inigo",
"type": "github"
}
},
"ipkg-to-json": {
"flake": false,
"locked": {
"lastModified": 1634937414,
"narHash": "sha256-LhSmWRpI7vyIQE7QTo38ZTjlqYPVSvV/DIpIxzPmqS0=",
"owner": "claymager",
"repo": "ipkg-to-json",
"rev": "2969b6b83714eeddc31e41577a565778ee5922e6",
"type": "github"
},
"original": {
"owner": "claymager",
"repo": "ipkg-to-json",
"type": "github"
}
},
"json": {
"flake": false,
"locked": {
"lastModified": 1639041459,
"narHash": "sha256-TP/V1jBBP1hFPm/cJ5O2EJiaNoZ19KvBOAI0S9lvAR4=",
"owner": "stefan-hoeck",
"repo": "idris2-json",
"rev": "7c0c028acad0ba0b63b37b92199f37e6ec73864a",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-json",
"type": "github"
}
},
"katla": {
"flake": false,
"locked": {
"lastModified": 1636542431,
"narHash": "sha256-X83NA/P3k1iPcBa8g5z8JldEmFEz/jxVeViJX0/FikY=",
"owner": "idris-community",
"repo": "katla",
"rev": "d841ec243f96b4762074211ee81033e28884c858",
"type": "github"
},
"original": {
"owner": "idris-community",
"repo": "katla",
"type": "github"
}
},
"lsp": {
"flake": false,
"locked": {
"lastModified": 1639486283,
"narHash": "sha256-po396FnUu8iqiipwPxqpFZEU4rtpX3jnt3cySwjLsH8=",
"owner": "idris-community",
"repo": "idris2-lsp",
"rev": "7ebb6caf6bb4b57c5107579aba2b871408e6f183",
"type": "github"
},
"original": {
"owner": "idris-community",
"repo": "idris2-lsp",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1638239011,
"narHash": "sha256-AjhmbT4UBlJWqxY0ea8a6GU2C2HdKUREkG43oRr3TZg=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "a7ecde854aee5c4c7cd6177f54a99d2c1ff28a31",
"type": "github"
},
"original": {
"id": "nixpkgs",
"ref": "21.11",
"type": "indirect"
}
},
"odf": {
"flake": false,
"locked": {
"lastModified": 1638184051,
"narHash": "sha256-usSdPx+UqOGImHHdHcrytdzi2LXtIRZuUW0fkD/Wwnk=",
"owner": "madman-bob",
"repo": "idris2-odf",
"rev": "d2f532437321c8336f1ca786b44b6ebef4117126",
"type": "github"
},
"original": {
"owner": "madman-bob",
"repo": "idris2-odf",
"type": "github"
}
},
"pretty-show": {
"flake": false,
"locked": {
"lastModified": 1639041411,
"narHash": "sha256-BzEe1fpX+lqGEk8b1JZoQT1db5I7s7SZnLCttRVGXdY=",
"owner": "stefan-hoeck",
"repo": "idris2-pretty-show",
"rev": "a4bc6156b9dac43699f87504cbdb8dada5627863",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-pretty-show",
"type": "github"
}
},
"python": {
"flake": false,
"locked": {
"lastModified": 1635936936,
"narHash": "sha256-c9mcMApN0qgu0AXQVu0V+NXt2poP258wCPkyvtQvv4I=",
"owner": "madman-bob",
"repo": "idris2-python",
"rev": "0eab028933c65bebe744e879881416f5136d6943",
"type": "github"
},
"original": {
"owner": "madman-bob",
"repo": "idris2-python",
"type": "github"
}
},
"rhone": {
"flake": false,
"locked": {
"lastModified": 1639041532,
"narHash": "sha256-2g43shlWQIT/1ogesUBUBV9N8YiD3RwaCbbhdKLVp1s=",
"owner": "stefan-hoeck",
"repo": "idris2-rhone",
"rev": "c4d828b0b8efea495d9a5f1e842a9c67cad57724",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-rhone",
"type": "github"
}
},
"rhone-js": {
"flake": false,
"locked": {
"lastModified": 1639041546,
"narHash": "sha256-ddWVsSRbfA6ghmwiRMzDpHBPM+esGdutuqm1qQZgs88=",
"owner": "stefan-hoeck",
"repo": "idris2-rhone-js",
"rev": "520dd59549f5b14075045314b6805c7492ed636e",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-rhone-js",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"idris2-pkgs": "idris2-pkgs",
"nixpkgs": "nixpkgs",
"tap": "tap"
}
},
"snocvect": {
"flake": false,
"locked": {
"lastModified": 1641633224,
"narHash": "sha256-6zTU4sDzd/R/dFCTNZaX41H4L3/USGLFghMS0Oc9liY=",
"owner": "mattpolzin",
"repo": "idris-snocvect",
"rev": "ff1e7afba360a62f7e522e9bbb856096a79702c4",
"type": "github"
},
"original": {
"owner": "mattpolzin",
"repo": "idris-snocvect",
"type": "github"
}
},
"sop": {
"flake": false,
"locked": {
"lastModified": 1639041379,
"narHash": "sha256-PDTf1Wx6EygiWszguvoVPiqIISYFLabI4e0lXHlrjcA=",
"owner": "stefan-hoeck",
"repo": "idris2-sop",
"rev": "e4354d1883cd73616019457cb9ebf864d99df6a0",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-sop",
"type": "github"
}
},
"tailrec": {
"flake": false,
"locked": {
"lastModified": 1637146655,
"narHash": "sha256-0yi7MQIrISPvAwkgDC1M5PHDEeVyIaISF0HjKDaT0Rw=",
"owner": "stefan-hoeck",
"repo": "idris2-tailrec",
"rev": "dd0bc6381b3a2e69aa37f9a8c1b165d4b1516ad7",
"type": "github"
},
"original": {
"owner": "stefan-hoeck",
"repo": "idris2-tailrec",
"type": "github"
}
},
"tap": {
"inputs": {
"flake-utils": [
"flake-utils"
],
"idris2-pkgs": [
"idris2-pkgs"
],
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1660774921,
"narHash": "sha256-7xbw0rnQ6BFjiQvxWTkwmmSs3slSwbfKyuz4TGlOlas=",
"ref": "main",
"rev": "d0311bbca54352b45079a42e90fa292fc3748961",
"revCount": 11,
"type": "git",
"url": "https://git.rhiannon.website/rhi/idris2-tap"
},
"original": {
"ref": "main",
"type": "git",
"url": "https://git.rhiannon.website/rhi/idris2-tap"
}
},
"xml": {
"flake": false,
"locked": {
"lastModified": 1637939752,
"narHash": "sha256-yYJBhPfwYoi7amlHmeNGrVCOAc3BjZpKTCd9wDs3XEM=",
"owner": "madman-bob",
"repo": "idris2-xml",
"rev": "1292ccfcd58c551089ef699e4560343d5c473d64",
"type": "github"
},
"original": {
"owner": "madman-bob",
"repo": "idris2-xml",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

View File

@ -1,62 +0,0 @@
{ description = "quox: quantitative extensional type theory";
inputs = {
nixpkgs.url = "nixpkgs/21.11";
flake-utils = {
url = "github:numtide/flake-utils";
inputs.nixpkgs.follows = "nixpkgs";
};
idris2-pkgs = {
url = "github:claymager/idris2-pkgs";
inputs.nixpkgs.follows = "nixpkgs";
inputs.flake-utils.follows = "flake-utils";
};
tap = {
url = "git+https://git.rhiannon.website/rhi/idris2-tap?ref=main";
inputs.nixpkgs.follows = "nixpkgs";
inputs.flake-utils.follows = "flake-utils";
inputs.idris2-pkgs.follows = "idris2-pkgs";
};
};
outputs = { self, nixpkgs, idris2-pkgs, flake-utils, tap }:
let
packagePaths = {
quox-lib = ./lib;
quox = ./exe;
quox-tests = ./tests;
};
extraDeps = [ tap ];
systems = with flake-utils.lib.system;
[ x86_64-darwin x86_64-linux i686-linux ];
in
with builtins;
flake-utils.lib.eachSystem systems (system:
let
basePkgs = import nixpkgs {
inherit system;
overlays = [ idris2-pkgs.overlay ];
};
builders = basePkgs.idris2-pkgs._builders;
extraDepPkgs =
foldl' (acc: pkg: acc // pkg.packages.${system}) { } extraDeps;
mkPackage = name: path:
builders.idrisPackage path { extraPkgs = extraDepPkgs // packages; };
mkDevShell = _: pkg:
basePkgs.mkShell { buildInputs = [ (builders.devEnv pkg) ]; };
packages = mapAttrs mkPackage packagePaths;
devShells = mapAttrs mkDevShell packages;
in {
inherit packages devShells;
defaultPackage = packages.quox;
devShell = devShells.quox-lib;
}
);
}

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

12
lib/Quox/BoolExtra.idr Normal file
View File

@ -0,0 +1,12 @@
module Quox.BoolExtra
import public Data.Bool
infixr 5 `andM`
infixr 4 `orM`
public export
andM, orM : Monad m => m Bool -> m Bool -> m Bool
andM a b = if !a then b else pure False
orM a b = if not !a then b else pure True

175
lib/Quox/CharExtra.idr Normal file
View File

@ -0,0 +1,175 @@
module Quox.CharExtra
import Derive.Prelude
%default total
%language ElabReflection
namespace Letter
public export
data Letter = Uppercase | Lowercase | Titlecase | Modifier | Other
%runElab derive "Letter" [Eq, Ord, Show]
namespace Mark
public export
data Mark = NonSpacing | SpacingCombining | Enclosing
%runElab derive "Mark" [Eq, Ord, Show]
namespace Number
public export
data Number = Decimal | Letter | Other
%runElab derive "Number" [Eq, Ord, Show]
namespace Punctuation
public export
data Punctuation = Connector | Dash | Open | Close
| InitialQuote | FinalQuote | Other
%runElab derive "Punctuation" [Eq, Ord, Show]
namespace Symbol
public export
data Symbol = Math | Currency | Modifier | Other
%runElab derive "Symbol" [Eq, Ord, Show]
namespace Separator
public export
data Separator = Space | Line | Paragraph
%runElab derive "Separator" [Eq, Ord, Show]
namespace Other
public export
data Other = Control | Format | Surrogate | PrivateUse | NotAssigned
%runElab derive "Other" [Eq, Ord, Show]
public export
data GeneralCategory
= Letter Letter
| Mark Mark
| Number Number
| Punctuation Punctuation
| Symbol Symbol
| Separator Separator
| Other Other
%runElab derive "GeneralCategory" [Eq, Ord, Show]
private
%foreign "scheme:(lambda (c) (symbol->string (char-general-category c)))"
prim__genCat : Char -> String
export
genCat : Char -> GeneralCategory
genCat ch = assert_total $
case prim__genCat ch of
"Lu" => Letter Uppercase
"Ll" => Letter Lowercase
"Lt" => Letter Titlecase
"Lm" => Letter Modifier
"Lo" => Letter Other
"Mn" => Mark NonSpacing
"Mc" => Mark SpacingCombining
"Me" => Mark Enclosing
"Nd" => Number Decimal
"Nl" => Number Letter
"No" => Number Other
"Pc" => Punctuation Connector
"Pd" => Punctuation Dash
"Ps" => Punctuation Open
"Pe" => Punctuation Close
"Pi" => Punctuation InitialQuote
"Pf" => Punctuation FinalQuote
"Po" => Punctuation Other
"Sm" => Symbol Math
"Sc" => Symbol Currency
"Sk" => Symbol Modifier
"So" => Symbol Other
"Zs" => Separator Space
"Zl" => Separator Line
"Zp" => Separator Paragraph
"Cc" => Other Control
"Cf" => Other Format
"Cs" => Other Surrogate
"Co" => Other PrivateUse
"Cn" => Other NotAssigned
cat => idris_crash #"Quox.Unicode.genCat: unknown category "\{cat}""#
namespace GeneralCategory
public export %inline
isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator, isOther :
GeneralCategory -> Bool
isLetter = \case Letter _ => True; _ => False
isMark = \case Mark _ => True; _ => False
isNumber = \case Number _ => True; _ => False
isPunctuation = \case Punctuation _ => True; _ => False
isSymbol = \case Symbol _ => True; _ => False
isSeparator = \case Separator _ => True; _ => False
isOther = \case Other _ => True; _ => False
namespace Char
public export %inline
isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator, isOther :
Char -> Bool
isLetter = isLetter . genCat
isMark = isMark . genCat
isNumber = isNumber . genCat
isPunctuation = isPunctuation . genCat
isSymbol = isSymbol . genCat
isSeparator = isSeparator . genCat
isOther = isOther . genCat
export
isSupDigit : Char -> Bool
isSupDigit ch = ch `elem` unpack "⁰¹²³⁴⁵⁶⁷⁸⁹"
export
isSubDigit : Char -> Bool
isSubDigit ch = ch `elem` unpack "₀₁₂₃₄₅₆₇₈₉"
export
isAsciiDigit : Char -> Bool
isAsciiDigit ch = '0' <= ch && ch <= '9'
export
isIdStart : Char -> Bool
isIdStart ch =
(ch == '_' || isLetter ch || isNumber ch) &&
not (isSupDigit ch || isAsciiDigit ch)
export
isIdCont : Char -> Bool
isIdCont ch =
(isIdStart ch || ch == '\'' || ch == '-' || isMark ch || isNumber ch) &&
not (isSupDigit ch)
export
isIdConnector : Char -> Bool
isIdConnector ch = genCat ch == Punctuation Connector
export
isSymChar : Char -> Bool
isSymChar ch = case genCat ch of
Symbol _ => True
Punctuation Dash => True
Punctuation Other => True
_ => False
export
isWhitespace : Char -> Bool
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

@ -2,17 +2,19 @@ module Quox.Context
import Quox.Syntax.Shift
import Quox.Pretty
import public Quox.NatExtra
import Quox.Name
import Data.DPair
import Data.Nat
import Data.Singleton
import Data.SnocList
import Data.SnocVect
import Data.Vect
import Control.Monad.Identity
%default total
infixl 5 :<
||| a sequence of bindings under an existing context. each successive element
||| has one more bound variable, which correspond to all previous elements
||| as well as the surrounding context.
@ -35,40 +37,111 @@ public export
Context' : (a : Type) -> (len : Nat) -> Type
Context' a = Context (\_ => a)
public export
NContext : Nat -> Type
NContext = Context' BaseName
public export
BContext : Nat -> Type
BContext = Context' BindName
public export
unsnoc : Context tm (S n) -> (Context tm n, tm n)
unsnoc (tel :< x) = (tel, x)
public export
head : Context tm (S n) -> tm n
head = snd . unsnoc
public export
tail : Context tm (S n) -> Context tm n
tail (tel :< _) = tel
tail = fst . unsnoc
export
toSnocList : Telescope tm _ _ -> SnocList (Exists tm)
toSnocList [<] = [<]
toSnocList (tel :< t) = toSnocList tel :< Evidence _ t
private
toListAcc : Telescope tm _ _ -> List (Exists tm) -> List (Exists tm)
toListAcc [<] acc = acc
toListAcc (tel :< t) acc = toListAcc tel (Evidence _ t :: acc)
parameters {0 tm : Nat -> Type} (f : forall n. tm n -> a)
export
toSnocListWith : Telescope tm _ _ -> SnocList a
toSnocListWith [<] = [<]
toSnocListWith (tel :< t) = toSnocListWith tel :< f t
export
toListWith : Telescope tm _ _ -> List a
toListWith tel = toListAcc tel [] where
toListAcc : Telescope tm _ _ -> List a -> List a
toListAcc [<] acc = acc
toListAcc (tel :< t) acc = toListAcc tel (f t :: acc)
export
toSnocVectWith : Context tm n -> SnocVect n a
toSnocVectWith [<] = [<]
toSnocVectWith (tel :< t) = toSnocVectWith tel :< f t
export %inline
toList : Telescope tm _ _ -> List (Exists tm)
toList tel = toListAcc tel []
toSnocList : Telescope tm _ _ -> SnocList (Exists tm)
toSnocList = toSnocListWith (Evidence _)
export %inline
toSnocList' : Telescope' a _ _ -> SnocList a
toSnocList' = map snd . toSnocList
toSnocList' = toSnocListWith id
export %inline
toList : Telescope tm _ _ -> List (Exists tm)
toList = toListWith (Evidence _)
export %inline
toList' : Telescope' a _ _ -> List a
toList' = map snd . toList
toList' = toListWith id
export %inline
toSnocVect : Context tm n -> SnocVect n (Exists tm)
toSnocVect = toSnocVectWith (Evidence _)
export %inline
toSnocVect' : Context' a n -> SnocVect n a
toSnocVect' = toSnocVectWith id
export
fromSnocVect : SnocVect n a -> Context' a n
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 n = tabulateLT n (\i => f i)
-- [todo] fixup argument order lol
public export
replicate : (n : Nat) -> a -> Context' a n
replicate n x = tabulate (const x) n
infixl 9 .
public export
(.) : Telescope tm from mid -> Telescope tm mid to -> Telescope tm from to
tel1 . [<] = tel1
tel1 . (tel2 :< s) = (tel1 . tel2) :< s
export
(<><) : Telescope' a from to -> Vect n a -> Telescope' a from (n + to)
(<><) tel [] = tel
(<><) tel (x :: xs) {n = S n} =
rewrite plusSuccRightSucc n to in
(tel :< x) <>< xs
export
(++) : Telescope' a from to -> SnocVect n a -> Telescope' a from (n + to)
tel ++ [<] = tel
tel ++ (sx :< x) = (tel ++ sx) :< x
public export
getShiftWith : (forall from, to. tm from -> Shift from to -> tm to) ->
@ -86,6 +159,7 @@ getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
getWith shft = getShiftWith shft SZ
infixl 8 !!
public export %inline
(!!) : CanShift tm => Context tm len -> Var len -> tm len
(!!) = getWith (//)
@ -94,16 +168,12 @@ public export %inline
(!!!) : Context' tm len -> Var len -> tm
(!!!) = getWith const
||| a triangle of bindings. each type binding in a context counts the ues of
||| others in its type, and all of these together form a triangle.
public export
Triangle : (tm : Nat -> Type) -> (len : Nat) -> Type
Triangle = Context . Context
find : Alternative f =>
(forall n. tm n -> Bool) -> Context tm len -> f (Var len)
find p [<] = empty
find p (ctx :< x) = (guard (p x) $> VZ) <|> (VS <$> find p ctx)
public export
Triangle' : Type -> (len : Nat) -> Type
Triangle' a = Context $ Context (\_ => a)
export
0 telescopeLTE : Telescope _ from to -> from `LTE` to
@ -119,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)) ->
@ -126,6 +202,10 @@ parameters {auto _ : Applicative f}
traverse f [<] = pure [<]
traverse f (tel :< x) = [|traverse f tel :< f x|]
export %inline
traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to)
traverse' f = traverse f
infixl 3 `app`
||| like `(<*>)` but with effects
export
@ -140,6 +220,7 @@ parameters {auto _ : Applicative f}
sequence : Telescope (f . tm) from to -> f (Telescope tm from to)
sequence = traverse id
parameters {0 tm1, tm2 : Nat -> Type}
(f : forall n. tm1 n -> tm2 n)
export %inline
@ -150,33 +231,17 @@ parameters {0 tm1, tm2 : Nat -> Type}
(<$>) : Telescope tm1 from to -> Telescope tm2 from to
(<$>) = map
export %inline
(<*>) : Telescope (\n => tm1 n -> tm2 n) from to ->
Telescope tm1 from to -> Telescope tm2 from to
ftel <*> xtel = runIdentity $ (pure .) <$> ftel `app` xtel
-- ...but can't write pure without `from,to` being ω, so no idiom brackets ☹
export
teleLte' : Telescope tm from to -> from `LTE'` to
teleLte' [<] = LTERefl
teleLte' (tel :< _) = LTESuccR (teleLte' tel)
export
tabulate : ((n : Nat) -> tm n) ->
(from, to : Nat) -> from `LTE'` to => Telescope tm from to
tabulate f from from @{LTERefl} = [<]
tabulate f from (S to) @{LTESuccR _} = tabulate f from to :< f to
export
tabulate0 : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
tabulate0 f n = tabulate f 0 n
export
pure : from `LTE'` to => a -> Telescope' a from to
pure @{LTERefl} x = [<]
pure @{LTESuccR _} x = pure x :< x
export %inline
(<$) : (forall n. tm1 n) -> Telescope tm2 from to -> Telescope tm1 from to
x <$ tel = const x <$> tel
export %inline
@ -185,14 +250,6 @@ zipWith : (forall n. tm1 n -> tm2 n -> tm3 n) ->
Telescope tm3 from to
zipWith f tel1 tel2 = f <$> tel1 <*> tel2
export %inline
zipWith3 : (forall n. tm1 n -> tm2 n -> tm3 n -> tm4 n) ->
Telescope tm1 from to ->
Telescope tm2 from to ->
Telescope tm3 from to ->
Telescope tm4 from to
zipWith3 f tel1 tel2 tel3 = f <$> tel1 <*> tel2 <*> tel3
export %inline
zipWithLazy : forall tm1, tm2, tm3.
(forall n. tm1 n -> tm2 n -> tm3 n) ->
@ -200,32 +257,43 @@ zipWithLazy : forall tm1, tm2, tm3.
Telescope (\n => Lazy (tm3 n)) from to
zipWithLazy f = zipWith $ delay .: f
export %inline
zipWith3Lazy : forall tm1, tm2, tm3, tm4.
(forall n. tm1 n -> tm2 n -> tm3 n -> tm4 n) ->
Telescope tm1 from to ->
Telescope tm2 from to ->
Telescope tm3 from to ->
Telescope (\n => Lazy (tm4 n)) from to
zipWith3Lazy f = zipWith3 $ \x, y, z => delay $ f x y z
export
unzip : Telescope (\n => (tm1 n, tm2 n)) from to ->
(Telescope tm1 from to, Telescope tm2 from to)
unzip [<] = ([<], [<])
unzip (tel :< (x, y)) = let (xs, ys) = unzip tel in (xs :< x, ys :< y)
export
unzip3 : Telescope (\n => (tm1 n, tm2 n, tm3 n)) from to ->
(Telescope tm1 from to, Telescope tm2 from to, Telescope tm3 from to)
unzip3 [<] = ([<], [<], [<])
unzip3 (tel :< (x, y, z)) =
let (xs, ys, zs) = unzip3 tel in (xs :< x, ys :< y, zs :< z)
public export
lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
lengthPrf [<] = Element 0 Refl
lengthPrf (tel :< _) =
let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
export
lengthPrf0 : Context _ to -> Subset Nat (\len => len = to)
lengthPrf0 : Context _ to -> Singleton to
lengthPrf0 ctx =
let len = lengthPrf ctx in
Element 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
length = fst . lengthPrf
public export
null : Telescope _ from to -> Bool
null [<] = True
null _ = False
export
foldl : {0 acc : Nat -> Type} ->
@ -234,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
@ -249,41 +321,48 @@ foldLazy = foldMap force
export %inline
and : Telescope' (Lazy Bool) _ _ -> Bool
and = force . fold @{All}
export %inline
all : (forall n. tm n -> Bool) -> Telescope tm _ _ -> Bool
all p = and . map (delay . p)
export %inline
all2 : (forall n. tm n -> tm2 n -> Bool) ->
Telescope tm from to -> Telescope tm2 from to -> Bool
all2 p = and .: zipWithLazy p
export %inline
or : Telescope' (Lazy Bool) _ _ -> Bool
or = force . fold @{Any}
export %inline
any : (forall n. tm n -> Bool) -> Telescope tm _ _ -> Bool
any p = or . map (delay . p)
export %inline
any2 : (forall n. tm1 n -> tm2 n -> Bool) ->
Telescope tm1 from to -> Telescope tm2 from to -> Bool
any2 p = or .: zipWithLazy p
all, any : (forall n. tm n -> Bool) -> Telescope tm from to -> Bool
all p = foldMap @{All} p
any p = foldMap @{Any} p
export %inline
(forall n. Eq (tm n)) => Eq (Telescope tm from to) where
(==) = all2 (==)
(==) = foldLazy @{All} .: zipWithLazy (==)
export %inline
(forall n. Ord (tm n)) => Ord (Telescope tm from to) where
compare = foldLazy .: zipWithLazy compare
export %inline
(forall n. PrettyHL (tm n)) => PrettyHL (Telescope tm from to) where
prettyM tel = separate (hl Delim ";") <$> traverse prettyM (toList tel)
(forall n. Show (tm n)) => Show (Telescope tm from to) where
showPrec d = showPrec d . toSnocList
where Show (Exists tm) where showPrec d t = showPrec d t.snd
parameters {opts : LayoutOpts} {0 tm : Nat -> Type}
(nameHL : HL)
(pterm : forall n. BContext n -> tm n -> Eff Pretty (Doc opts))
private
prettyOne : BindName -> BContext to -> tm to -> Eff Pretty (Doc opts)
prettyOne x xs tm = hsep <$> sequence
[hl nameHL $ prettyBind' x, hl Delim $ text ":", pterm xs tm]
private
prettyEach : BContext to -> Telescope tm from to ->
Eff Pretty (Telescope' (Doc opts) from to)
prettyEach _ [<] = pure [<]
prettyEach (xs :< x) (ts :< t) = [|prettyEach xs ts :< prettyOne x xs t|]
export
prettyTel : BContext to -> Telescope tm from to -> Eff Pretty (Doc opts)
prettyTel names tel = do
docs <- prettyEach names tel
comma <- hl Delim $ text ","
pure $ separateTight comma $ toList' docs
namespace BContext
export
toNames : BContext n -> SnocList BaseName
toNames = foldl (\xs, x => xs :< x.val) [<]

53
lib/Quox/Decidable.idr Normal file
View File

@ -0,0 +1,53 @@
module Quox.Decidable
import public Data.Bool.Decidable
import public Decidable.Decidable
import public Decidable.Equality
import public Control.Relation
public export
0 REL : Type -> Type -> Type
REL a b = a -> b -> Type
public export
0 Pred : Type -> Type
Pred a = a -> Type
public export
0 Dec1 : Pred a -> Type
Dec1 p = (x : a) -> Dec (p x)
public export
0 Dec2 : REL a b -> Type
Dec2 p = (x : a) -> (y : b) -> Dec (p x y)
public export
0 Reflects1 : Pred a -> (a -> Bool) -> Type
p `Reflects1` f = (x : a) -> p x `Reflects` f x
public export
0 Reflects2 : REL a b -> (a -> b -> Bool) -> Type
p `Reflects2` f = (x : a) -> (y : b) -> p x y `Reflects` f x y
public export
(||) : Dec p -> Dec q -> Dec (Either p q)
Yes y1 || _ = Yes $ Left y1
No _ || Yes y2 = Yes $ Right y2
No n1 || No n2 = No $ \case Left y1 => n1 y1; Right y2 => n2 y2
public export
(&&) : Dec p -> Dec q -> Dec (p, q)
Yes y1 && Yes y2 = Yes (y1, y2)
Yes _ && No n2 = No $ n2 . snd
No n1 && _ = No $ n1 . fst
public export
reflectToDec : p `Reflects` b -> Dec p
reflectToDec (RTrue y) = Yes y
reflectToDec (RFalse n) = No n

View File

@ -1,52 +1,127 @@
module Quox.Definition
import public Quox.No
import public Quox.Syntax
import Quox.Displace
import public Data.SortedMap
import public Control.Monad.State
import public Quox.Loc
import Quox.Pretty
import Control.Eff
import Data.Singleton
import Decidable.Decidable
public export
record AnyTerm where
constructor T
def : forall d, n. Term d n
data DefBody =
Concrete (Term 0 0)
| Postulate
namespace DefBody
public export
(.term0) : DefBody -> Maybe (Term 0 0)
(Concrete t).term0 = Just t
(Postulate).term0 = Nothing
public export
record Definition where
constructor MkDef'
qty : Qty
0 qtyGlobal : IsGlobal qty
type : AnyTerm
term : Maybe AnyTerm
constructor MkDef
qty : GQty
type0 : Term 0 0
body0 : DefBody
scheme : Maybe String
isMain : Bool
loc_ : Loc
public export %inline
MkDef : (qty : Qty) -> (0 qtyGlobal : IsGlobal qty) =>
(type, term : forall d, n. Term d n) -> Definition
MkDef {qty, type, term} =
MkDef' {qty, qtyGlobal = %search, type = T type, term = Just (T term)}
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
MkAbstract : (qty : Qty) -> (0 qtyGlobal : IsGlobal qty) =>
(type : forall d, n. Term d n) -> Definition
MkAbstract {qty, type} =
MkDef' {qty, qtyGlobal = %search, type = T type, term = Nothing}
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}
public export %inline
(.type0) : Definition -> Term 0 0
g.type0 = g.type.def
parameters {d, n : Nat}
public export %inline
(.type) : Definition -> Term d n
g.type = g.type0 // shift0 d // shift0 n
public export %inline
(.term0) : Definition -> Maybe (Term 0 0)
g.term0 = map (\t => t.def) g.term
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
(.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
(.qtyP) : Definition -> Subset Qty IsGlobal
g.qtyP = Element g.qty g.qtyGlobal
public export %inline
isZero : Definition -> Bool
isZero g = g.qty == Zero
isZero g = g.qty == GZero
public export
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
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
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

95
lib/Quox/Displace.idr Normal file
View File

@ -0,0 +1,95 @@
module Quox.Displace
import Quox.Syntax
%default total
parameters (k : Universe)
namespace Term
export doDisplace : Term d n -> Term d n
export doDisplaceS : ScopeTermN s d n -> ScopeTermN s d n
export doDisplaceDS : DScopeTermN s d n -> DScopeTermN s d n
namespace Elim
export doDisplace : Elim d n -> Elim d n
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
doDisplace (Sig fst snd loc) = Sig (doDisplace fst) (doDisplaceS snd) loc
doDisplace (Pair fst snd loc) = Pair (doDisplace fst) (doDisplace snd) loc
doDisplace (Enum cases loc) = Enum cases loc
doDisplace (Tag tag loc) = Tag tag loc
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 (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) (assert_total $ map doDisplace th))
doDisplace (DCloT (Sub t th)) =
DCloT (Sub (doDisplace t) th)
doDisplaceS (S names (Y body)) = S names $ Y $ doDisplace body
doDisplaceS (S names (N body)) = S names $ N $ doDisplace body
doDisplaceDS (S names (Y body)) = S names $ Y $ doDisplace body
doDisplaceDS (S names (N body)) = S names $ N $ doDisplace body
namespace Elim
doDisplace (F x u loc) = F x (k + u) loc
doDisplace (B i loc) = B i loc
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)
(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
doDisplace (CaseBox qty box ret body loc) =
CaseBox qty (doDisplace box) (doDisplaceS ret) (doDisplaceS body) loc
doDisplace (DApp fun arg loc) =
DApp (doDisplace fun) arg loc
doDisplace (Ann tm ty loc) =
Ann (doDisplace tm) (doDisplace ty) loc
doDisplace (Coe ty p q val loc) =
Coe (doDisplaceDS ty) p q (doDisplace val) loc
doDisplace (Comp ty p q val r zero one loc) =
Comp (doDisplace ty) p q (doDisplace val) r
(doDisplaceDS zero) (doDisplaceDS one) loc
doDisplace (TypeCase ty ret arms def loc) =
TypeCase (doDisplace ty) (doDisplace ret)
(assert_total $ map doDisplaceS arms) (doDisplace def) loc
doDisplace (CloE (Sub e th)) =
CloE (Sub (doDisplace e) (assert_total $ map doDisplace th))
doDisplace (DCloE (Sub e th)) =
DCloE (Sub (doDisplace e) th)
namespace Term
export
displace : Universe -> Term d n -> Term d n
displace 0 t = t
displace u t = doDisplace u t
namespace Elim
export
displace : Universe -> Elim d n -> Elim d n
displace 0 t = t
displace u t = doDisplace u t

149
lib/Quox/EffExtra.idr Normal file
View File

@ -0,0 +1,149 @@
module Quox.EffExtra
import public Control.Eff
import Control.Monad.ST.Extra
import Data.IORef
export
localAt : (0 lbl : tag) -> Has (StateL lbl s) fs =>
(s -> s) -> Eff fs a -> Eff fs a
localAt lbl f act = do
old <- getAt lbl
modifyAt lbl f *> act <* putAt lbl old
export %inline
localAt_ : (0 lbl : tag) -> Has (StateL lbl s) fs =>
s -> Eff fs a -> Eff fs a
localAt_ lbl x = localAt lbl $ const x
export %inline
local : Has (State s) fs => (s -> s) -> Eff fs a -> Eff fs a
local = localAt ()
export %inline
local_ : Has (State s) fs => s -> Eff fs a -> Eff fs a
local_ = localAt_ ()
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 ()
export
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) ->
Subset xs ys
subsetWith @{Z} f = []
subsetWith @{S len} f = f Z :: subsetWith (f . S)
export
subsetSelf : Length xs => Subset xs xs
subsetSelf = subsetWith id
export
subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
subsetTail _ = subsetWith S
export
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
ioLeft : e -> IOErr e a
ioLeft = IOE . pure . Left

File diff suppressed because it is too large Load Diff

310
lib/Quox/FreeVars.idr Normal file
View File

@ -0,0 +1,310 @@
module Quox.FreeVars
import Quox.Syntax.Term.Base
import Data.Maybe
import Data.Nat
import Data.Singleton
import Data.SortedSet
import Derive.Prelude
%language ElabReflection
public export
FreeVars' : Nat -> Type
FreeVars' n = Context' Bool n
public export
record FreeVars n where
constructor FV
vars : FreeVars' n
%name FreeVars xs
%runElab deriveIndexed "FreeVars" [Eq, Ord, Show]
export %inline
(||) : FreeVars n -> FreeVars n -> FreeVars n
FV s || FV t = FV $ zipWith (\x, y => x || y) s t
export %inline
(&&) : FreeVars n -> FreeVars n -> FreeVars n
FV s && FV t = FV $ zipWith (\x, y => x && y) s t
export %inline Semigroup (FreeVars n) where (<+>) = (||)
export %inline [AndS] Semigroup (FreeVars n) where (<+>) = (&&)
export
only : {n : Nat} -> Var n -> FreeVars n
only i = FV $ only' i where
only' : {n' : Nat} -> Var n' -> FreeVars' n'
only' VZ = replicate (pred n') False :< True
only' (VS i) = only' i :< False
export %inline
all : {n : Nat} -> FreeVars n
all = FV $ replicate n True
export %inline
none : {n : Nat} -> FreeVars n
none = FV $ replicate n False
export %inline
uncons : FreeVars (S n) -> (FreeVars n, Bool)
uncons (FV (xs :< x)) = (FV xs, x)
export %inline {n : Nat} -> Monoid (FreeVars n) where neutral = none
export %inline [AndM] {n : Nat} -> Monoid (FreeVars n) where neutral = all
private
self : {n : Nat} -> Context' (FreeVars n) n
self = tabulate (\i => FV $ tabulate (== i) n) n
export
shift : forall from, to. Shift from to -> FreeVars from -> FreeVars to
shift by (FV xs) = FV $ shift' by xs where
shift' : Shift from' to' -> FreeVars' from' -> FreeVars' to'
shift' SZ ctx = ctx
shift' (SS by) ctx = shift' by ctx :< False
export
fromSet : {n : Nat} -> SortedSet (Var n) -> FreeVars n
fromSet vs = FV $ tabulateLT n $ \i => contains (V i) vs
export
toSet : {n : Nat} -> FreeVars n -> SortedSet (Var n)
toSet (FV vs) =
foldl_ (\s, i => maybe s (\i => insert i s) i) empty $
zipWith (\i, b => guard b $> i) (tabulateLT n V) vs
public export
interface HasFreeVars (0 tm : Nat -> Type) where
constructor HFV
fv : {n : Nat} -> tm n -> FreeVars n
public export
interface HasFreeDVars (0 tm : TermLike) where
constructor HFDV
fdv : {d, n : Nat} -> tm d n -> FreeVars d
public export %inline
fvWith : HasFreeVars tm => Singleton n -> tm n -> FreeVars n
fvWith (Val n) = fv
public export %inline
fdvWith : HasFreeDVars tm => Singleton d -> Singleton n -> tm d n -> FreeVars d
fdvWith (Val d) (Val n) = fdv
export
Fdv : (0 tm : TermLike) -> {n : Nat} ->
HasFreeDVars tm => HasFreeVars (\d => tm d n)
Fdv tm @{HFDV fdv} = HFV fdv
export
fvEach : {n1, n2 : Nat} -> HasFreeVars env =>
Subst env n1 n2 -> Context' (Lazy (FreeVars n2)) n1
fvEach (Shift by) = map (delay . shift by) self
fvEach (t ::: th) = fvEach th :< fv t
export
fdvEach : {d, n1, n2 : Nat} -> HasFreeDVars env =>
Subst (env d) n1 n2 -> Context' (Lazy (FreeVars d)) n1
fdvEach (Shift by) = replicate n1 none
fdvEach (t ::: th) = fdvEach th :< fdv t
export
HasFreeVars Dim where
fv (K _ _) = none
fv (B i _) = only i
export
{s : Nat} -> HasFreeVars tm => HasFreeVars (Scoped s tm) where
fv (S _ (Y body)) = FV $ drop s (fv body).vars
fv (S _ (N body)) = fv body
export
implementation [DScope]
{s : Nat} -> HasFreeDVars tm =>
HasFreeDVars (\d, n => Scoped s (\d' => tm d' n) d)
where
fdv (S _ (Y body)) = FV $ drop s (fdv body).vars
fdv (S _ (N body)) = fdv body
export
fvD : {0 tm : TermLike} -> {n : Nat} -> (forall d. HasFreeVars (tm d)) =>
Scoped s (\d => tm d n) d -> FreeVars n
fvD (S _ (Y body)) = fv body
fvD (S _ (N body)) = fv body
export
fdvT : HasFreeDVars tm => {s, d, n : Nat} -> Scoped s (tm d) n -> FreeVars d
fdvT (S _ (Y body)) = fdv body
fdvT (S _ (N body)) = fdv body
private
guardM : Monoid a => Bool -> Lazy a -> a
guardM b x = if b then x else neutral
export
implementation
(HasFreeVars tm, HasFreeVars env) =>
HasFreeVars (WithSubst tm env)
where
fv (Sub term subst) =
let Val from = getFrom subst in
foldMap (uncurry guardM) $ zipWith (,) (fv term).vars (fvEach subst)
export
implementation [WithSubst]
((forall d. HasFreeVars (tm d)), HasFreeDVars tm, HasFreeDVars env) =>
HasFreeDVars (\d => WithSubst (tm d) (env d))
where
fdv (Sub term subst) =
let Val from = getFrom subst in
fdv term <+>
foldMap (uncurry guardM) (zipWith (,) (fv term).vars (fdvEach subst))
export HasFreeVars (Term d)
export HasFreeVars (Elim d)
export
HasFreeVars (Term d) where
fv (TYPE {}) = none
fv (IOState {}) = none
fv (Pi {arg, res, _}) = fv arg <+> fv res
fv (Lam {body, _}) = fv body
fv (Sig {fst, snd, _}) = fv fst <+> fv snd
fv (Pair {fst, snd, _}) = fv fst <+> fv snd
fv (Enum {}) = none
fv (Tag {}) = none
fv (Eq {ty, l, r, _}) = fvD ty <+> fv l <+> fv r
fv (DLam {body, _}) = fvD body
fv (NAT {}) = none
fv (Nat {}) = none
fv (Succ {p, _}) = fv p
fv (STRING {}) = none
fv (Str {}) = none
fv (BOX {ty, _}) = fv ty
fv (Box {val, _}) = fv val
fv (Let {rhs, body, _}) = fv rhs <+> fv body
fv (E e) = fv e
fv (CloT s) = fv s
fv (DCloT s) = fv s.term
export
HasFreeVars (Elim d) where
fv (F {}) = none
fv (B i _) = only i
fv (App {fun, arg, _}) = fv fun <+> fv arg
fv (CasePair {pair, ret, body, _}) = fv pair <+> fv ret <+> fv body
fv (Fst pair _) = fv pair
fv (Snd pair _) = fv pair
fv (CaseEnum {tag, ret, arms, _}) =
fv tag <+> fv ret <+> foldMap fv (values arms)
fv (CaseNat {nat, ret, zero, succ, _}) =
fv nat <+> fv ret <+> fv zero <+> fv succ
fv (CaseBox {box, ret, body, _}) =
fv box <+> fv ret <+> fv body
fv (DApp {fun, _}) = fv fun
fv (Ann {tm, ty, _}) = fv tm <+> fv ty
fv (Coe {ty, val, _}) = fvD ty <+> fv val
fv (Comp {ty, val, zero, one, _}) =
fv ty <+> fv val <+> fvD zero <+> fvD one
fv (TypeCase {ty, ret, arms, def, _}) =
fv ty <+> fv ret <+> fv def <+> foldMap (\x => fv x.snd) (toList arms)
fv (CloE s) = fv s
fv (DCloE s) = fv s.term
private
expandDShift : {d1 : Nat} -> Shift d1 d2 -> Loc -> Context' (Dim d2) d1
expandDShift by loc = tabulateLT d1 (\i => BV i loc // by)
private
expandDSubst : {d1 : Nat} -> DSubst d1 d2 -> Loc -> Context' (Dim d2) d1
expandDSubst (Shift by) loc = expandDShift by loc
expandDSubst (t ::: th) loc = expandDSubst th loc :< t
private
fdvSubst' : {d1, d2, n : Nat} -> (Located2 tm, HasFreeDVars tm) =>
tm d1 n -> DSubst d1 d2 -> FreeVars d2
fdvSubst' t th =
fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th t.loc)
where
maybeOnly : {d : Nat} -> Bool -> Dim d -> FreeVars d
maybeOnly True (B i _) = only i
maybeOnly _ _ = none
private
fdvSubst : {d, n : Nat} -> (Located2 tm, HasFreeDVars tm) =>
WithSubst (\d => tm d n) Dim d -> FreeVars d
fdvSubst (Sub t th) = let Val from = getFrom th in fdvSubst' t th
export HasFreeDVars Term
export HasFreeDVars Elim
export
HasFreeDVars Term where
fdv (TYPE {}) = none
fdv (IOState {}) = none
fdv (Pi {arg, res, _}) = fdv arg <+> fdvT res
fdv (Lam {body, _}) = fdvT body
fdv (Sig {fst, snd, _}) = fdv fst <+> fdvT snd
fdv (Pair {fst, snd, _}) = fdv fst <+> fdv snd
fdv (Enum {}) = none
fdv (Tag {}) = none
fdv (Eq {ty, l, r, _}) = fdv @{DScope} ty <+> fdv l <+> fdv r
fdv (DLam {body, _}) = fdv @{DScope} body
fdv (NAT {}) = none
fdv (Nat {}) = none
fdv (Succ {p, _}) = fdv p
fdv (STRING {}) = none
fdv (Str {}) = none
fdv (BOX {ty, _}) = fdv ty
fdv (Box {val, _}) = fdv val
fdv (Let {rhs, body, _}) = fdv rhs <+> fdvT body
fdv (E e) = fdv e
fdv (CloT s) = fdv s @{WithSubst}
fdv (DCloT s) = fdvSubst s
export
HasFreeDVars Elim where
fdv (F {}) = none
fdv (B {}) = none
fdv (App {fun, arg, _}) = fdv fun <+> fdv arg
fdv (CasePair {pair, ret, body, _}) = fdv pair <+> fdvT ret <+> fdvT body
fdv (Fst pair _) = fdv pair
fdv (Snd pair _) = fdv pair
fdv (CaseEnum {tag, ret, arms, _}) =
fdv tag <+> fdvT ret <+> foldMap fdv (values arms)
fdv (CaseNat {nat, ret, zero, succ, _}) =
fdv nat <+> fdvT ret <+> fdv zero <+> fdvT succ
fdv (CaseBox {box, ret, body, _}) =
fdv box <+> fdvT ret <+> fdvT body
fdv (DApp {fun, arg, _}) =
fdv fun <+> fv arg
fdv (Ann {tm, ty, _}) =
fdv tm <+> fdv ty
fdv (Coe {ty, p, q, val, _}) =
fdv @{DScope} ty <+> fv p <+> fv q <+> fdv val
fdv (Comp {ty, p, q, val, r, zero, one, _}) =
fdv ty <+> fv p <+> fv q <+> fdv val <+>
fv r <+> fdv @{DScope} zero <+> fdv @{DScope} one
fdv (TypeCase {ty, ret, arms, def, _}) =
fdv ty <+> fdv ret <+> fdv def <+> foldMap (\x => fdvT x.snd) (toList arms)
fdv (CloE s) = fdv s @{WithSubst}
fdv (DCloE s) = fdvSubst s

View File

@ -1,102 +0,0 @@
module Quox.Lexer
import public Quox.Token
import Data.String
import Data.String.Extra
import public Text.Lexer
import public Text.Lexer.Tokenizer
import Control.Monad.Either
import Generics.Derive
%default total
%language ElabReflection
public export
record Error where
constructor Err
reason : StopReason
line, col : Int
char : Char
nameStart = pred $ \c => isAlpha c || c == '_'
nameCont = pred $ \c => isAlphaNum c || c == '_' || c == '\''
name = nameStart <+> many nameCont <+> reject nameCont
wild = is '_' <+> reject nameCont
%hide Text.Lexer.symbol
symbol = is '\'' <+> name
decimal = some digit <+> reject nameCont
natToNumber : Nat -> Number
natToNumber 0 = Zero
natToNumber 1 = One
natToNumber k = Other k
skip : Lexer -> Tokenizer (Maybe a)
skip lex = match lex $ const Nothing
simple : Char -> a -> Tokenizer (Maybe a)
simple ch = match (is ch) . const . Just
keyword : String -> Keyword -> Tokenizer (Maybe Token)
keyword str = match (exact str <+> reject nameCont) . const . Just . K
choice : (xs : List (Tokenizer a)) -> {auto 0 _ : NonEmpty xs} -> Tokenizer a
choice (t :: ts) = foldl (\a, b => a <|> b) t ts
match : Lexer -> (String -> a) -> Tokenizer (Maybe a)
match lex f = Tokenizer.match lex (Just . f)
%hide Tokenizer.match
tokens : Tokenizer (Maybe Token)
tokens = choice [
skip $ lineComment $ exact "--",
skip $ blockComment (exact "{-") (exact "-}"),
skip spaces,
simple '(' $ P LParen, simple ')' $ P RParen,
simple '[' $ P LSquare, simple ']' $ P RSquare,
simple '{' $ P LBrace, simple '}' $ P RBrace,
simple ',' $ P Comma,
simple '' $ P DblColon,
simple ':' $ P Colon, -- needs to be after '::'
simple '.' $ P Dot,
simple '' $ P Arrow,
simple '' $ P DblArrow,
simple '×' $ P Times,
simple '' $ P Triangle,
match wild $ const $ P Wild,
keyword "λ" Lam,
keyword "let" Let, keyword "in" In,
keyword "case" Case, keyword "of" Of,
keyword "ω" Omega,
keyword "Π" Pi, keyword "Σ" Sigma, keyword "W" W,
match name $ Name,
match symbol $ Symbol . assert_total strTail,
match decimal $ N . natToNumber . cast,
match (is '' <+> decimal) $ TYPE . cast . assert_total strTail
]
export
lex : String -> Either Error (List BToken)
lex str =
let (res, (reason, line, col, str)) = lex tokens str in
case reason of
EndInput => Right $ mapMaybe sequence res
_ => let char = assert_total strIndex str 0 in
Left $ Err {reason, line, col, char}

152
lib/Quox/Loc.idr Normal file
View File

@ -0,0 +1,152 @@
||| file locations
module Quox.Loc
import Quox.PrettyValExtra
import public Text.Bounded
import Data.SortedMap
import Derive.Prelude
%default total
%language ElabReflection
public export
FileName : Type
FileName = String
%runElab derive "Bounds" [Ord, PrettyVal]
public export
data Loc_ = NoLoc | YesLoc FileName Bounds
%name Loc_ loc
%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal]
||| a wrapper for locations which are always considered equal
public export
record Loc where
constructor L
val : Loc_
%name Loc loc
%runElab derive "Loc" [Show]
export %inline Eq Loc where _ == _ = True
export %inline Ord Loc where compare _ _ = EQ
public export %inline
noLoc : Loc
noLoc = L NoLoc
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_
onlyStart_ NoLoc = NoLoc
onlyStart_ (YesLoc fname (MkBounds sl sc _ _)) =
YesLoc fname $ MkBounds sl sc sl sc
export %inline
onlyStart : Loc -> Loc
onlyStart = {val $= onlyStart_}
export
onlyEnd_ : Loc_ -> Loc_
onlyEnd_ NoLoc = NoLoc
onlyEnd_ (YesLoc fname (MkBounds _ _ el ec)) =
YesLoc fname $ MkBounds el ec el ec
export %inline
onlyEnd : Loc -> Loc
onlyEnd = {val $= onlyEnd_}
export
extend_ : Loc_ -> Bounds -> Loc_
extend_ NoLoc _ = NoLoc
extend_ (YesLoc fname (MkBounds sl1 sc1 el1 ec1)) (MkBounds sl2 sc2 el2 ec2) =
let (sl, sc) = (sl1, sc1) `min` (sl2, sc2)
(el, ec) = (el1, ec1) `max` (el2, ec2)
in
YesLoc fname $ MkBounds sl sc el ec
export
extend : Loc -> Bounds -> Loc
extend l b = L $ extend_ l.val b
export
extend' : Loc -> Maybe Bounds -> Loc
extend' l b = maybe l (extend l) b
namespace Loc_
export
(.bounds) : Loc_ -> Maybe Bounds
(YesLoc _ b).bounds = Just b
(NoLoc).bounds = Nothing
namespace Loc
export
(.bounds) : Loc -> Maybe Bounds
l.bounds = l.val.bounds
export %inline
extendL : Loc -> Loc -> Loc
extendL l1 l2 = l1 `extend'` l2.bounds
infixr 1 `or_`, `or`
export %inline
or_ : Loc_ -> Loc_ -> Loc_
or_ l1@(YesLoc {}) _ = l1
or_ NoLoc l2 = l2
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
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
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

@ -1,8 +1,13 @@
module Quox.Name
import Quox.Loc
import Quox.CharExtra
import Quox.PrettyValExtra
import public Data.SnocList
import Data.List
import Generics.Derive
import Control.Eff
import Text.Lexer
import Derive.Prelude
%hide TT.Name
@ -10,42 +15,177 @@ import Generics.Derive
%language ElabReflection
public export
NameSuf : Type
NameSuf = Nat
public export
data BaseName
= UN String -- user-given name
%runElab derive "BaseName" [Generic, Meta, Eq, Ord, DecEq]
export
Show BaseName where
show (UN x) = x
= UN String -- user-given name
| MN String NameSuf -- machine-generated name
| Unused -- "_"
%runElab derive "BaseName" [Eq, Ord, PrettyVal]
export
baseStr : BaseName -> String
baseStr (UN x) = x
baseStr (UN x) = x
baseStr (MN x i) = "\{x}#\{show i}"
baseStr Unused = "_"
export
FromString BaseName where
fromString = UN
export Show BaseName where show = show . baseStr
export FromString BaseName where fromString = UN
public export
Mods : Type
Mods = SnocList String
public export
record Name where
constructor MakeName
mods : SnocList String
constructor MkName
mods : Mods
base : BaseName
%runElab derive "Name" [Generic, Meta, Eq, Ord]
%runElab derive "Name" [Eq, Ord]
public export %inline
unq : BaseName -> Name
unq = MkName [<]
||| add some namespaces to the beginning of a name
public export %inline
addMods : Mods -> Name -> Name
addMods ms = {mods $= (ms <+>)}
public export
PBaseName : Type
PBaseName = String
public export
record PName where
constructor MkPName
mods : Mods
base : PBaseName
%runElab derive "PName" [Eq, Ord, PrettyVal]
export %inline
fromPName : PName -> Name
fromPName p = MkName p.mods $ UN p.base
export %inline
toPName : Name -> PName
toPName p = MkPName p.mods $ baseStr p.base
export %inline
fromPBaseName : PBaseName -> Name
fromPBaseName = MkName [<] . UN
export
Show Name where
show (MakeName mods base) =
concat $ intersperse "." $ toList $ mods :< show base
Show PName where
show (MkPName mods base) =
show $ concat $ intersperse "." $ toList $ mods :< base
export Show Name where show = show . toPName
export FromString PName where fromString = MkPName [<]
export FromString Name where fromString = fromPBaseName
public export
record BindName where
constructor BN
val : BaseName
loc_ : Loc
%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
export
FromString Name where
fromString x = MakeName [<] (fromString x)
toDotsP : PName -> String
toDotsP x = fastConcat $ cast $ map (<+> ".") x.mods :< x.base
export
toDots : Name -> String
toDots x = fastConcat $ cast $ map (<+> ".") x.mods :< baseStr x.base
export
fromListP : List1 String -> PName
fromListP (x ::: xs) = go [<] x xs where
go : SnocList String -> String -> List String -> PName
go mods x [] = MkPName mods x
go mods x (y :: ys) = go (mods :< x) y ys
export %inline
fromList : List1 String -> Name
fromList = fromPName . fromListP
export
syntaxChars : List Char
syntaxChars = ['(', ')', '[', ']', '{', '}', '"', '\'', ',', '.', ';', '^']
export
isSymStart, isSymCont : Char -> Bool
isSymStart c = not (c `elem` syntaxChars) && isSymChar c
isSymCont c = c == '\'' || isSymStart c
export
idStart, idCont, idEnd, idContEnd : Lexer
idStart = pred isIdStart
idCont = pred isIdCont
idEnd = pred $ \c => c `elem` unpack "?!#"
idContEnd = idCont <|> idEnd
export
symStart, symCont : Lexer
symStart = pred isSymStart
symCont = pred isSymCont
export
baseName : Lexer
baseName = idStart <+> many idCont <+> many idEnd
<|> symStart <+> many symCont
export
name : Lexer
name = baseName <+> many (is '.' <+> baseName)
export
isName : String -> Bool
isName str =
case scan name [] (unpack str) of
Just (_, []) => True
_ => False
public export
data GenTag = GEN
public export
NameGen : Type -> Type
NameGen = StateL GEN NameSuf
||| generate a fresh name with the given base
export
mn : Has NameGen fs => PBaseName -> Eff fs BaseName
mn base = do
i <- getAt GEN
modifyAt GEN S
pure $ MN base i
||| generate a fresh binding name with the given base and location `loc`
export
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

View File

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

59
lib/Quox/No.idr Normal file
View File

@ -0,0 +1,59 @@
||| like Data.So, but for False instead.
||| less messing about with `not` (and constantly rewriting everything)
||| or `Not` (unfriendly to proof search).
module Quox.No
import public Data.So
import public Quox.Decidable
import Data.Bool
public export
data No : Pred Bool where
Ah : No False
export Uninhabited (No True) where uninhabited _ impossible
export %inline
soNo : So b -> No b -> Void
soNo Oh Ah impossible
private
0 orFalse : (a, b : Bool) -> (a || b) = False -> (a = False, b = False)
orFalse a b eq1 with (a || b) proof eq2
orFalse False False Refl | False = (Refl, Refl)
orFalse False True Refl | False = absurd eq2
orFalse True False Refl | False = absurd eq2
orFalse True True Refl | False = absurd eq2
parameters {0 a, b : Bool}
export %inline
noOr : No (a || b) -> (No a, No b)
noOr n with 0 (a || b) proof eq
noOr Ah | False =
let 0 eqs = orFalse a b eq in
(rewrite fst eqs in Ah, rewrite snd eqs in Ah)
export %inline
noOr1 : No (a || b) -> No a
noOr1 = fst . noOr
export %inline
noOr2 : No (a || b) -> No b
noOr2 = snd . noOr
infixr 1 `orNo`
export %inline
orNo : No a -> No b -> No (a || b)
orNo Ah Ah = Ah
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

@ -3,7 +3,6 @@
module Quox.OPE
import Quox.NatExtra
import Data.Nat
%default total
@ -39,6 +38,11 @@ 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
@ -56,141 +60,17 @@ dropInnerN (S m) = Drop $ dropInnerN m
public export
interface Tighten t where
tighten : Alternative f => OPE m n -> t n -> f (t m)
tighten : OPE m n -> t n -> Maybe (t m)
parameters {auto _ : Tighten t} {auto _ : Alternative f}
export
tightenInner : {n : Nat} -> m `LTE` n -> t n -> f (t m)
parameters {auto _ : Tighten t}
export %inline
tightenInner : {n : Nat} -> m `LTE` n -> t n -> Maybe (t m)
tightenInner = tighten . dropInner
export
tightenN : (m : Nat) -> t (m + n) -> f (t n)
export %inline
tightenN : (m : Nat) -> t (m + n) -> Maybe (t n)
tightenN m = tighten $ dropInnerN m
export
tighten1 : t (S n) -> f (t n)
export %inline
tighten1 : t (S n) -> Maybe (t n)
tighten1 = tightenN 1
-- [todo] can this be done with fancy nats too?
-- with bitmasks sure but that might not be worth the effort
-- [the next day] it probably isn't
-- public export
-- data OPE' : Nat -> Nat -> Type where
-- None : OPE' 0 0
-- Drop : OPE' m n -> OPE' m (S n)
-- Keep : OPE' m n -> OPE' (S m) (S n)
-- %name OPE' q
-- public export %inline
-- drop' : Integer -> Integer
-- drop' n = n * 2
-- public export %inline
-- keep' : Integer -> Integer
-- keep' n = 1 + 2 * n
-- public export
-- data IsOPE : Integer -> (OPE' m n) -> Type where
-- IsNone : 0 `IsOPE` None
-- IsDrop : (0 _ : m `IsOPE` q) -> drop' m `IsOPE` Drop q
-- IsKeep : (0 _ : m `IsOPE` q) -> keep' m `IsOPE` Keep q
-- %name IsOPE p
-- public export
-- record OPE m n where
-- constructor MkOPE
-- value : Integer
-- 0 spec : OPE' m n
-- 0 prf : value `IsOPE` spec
-- 0 pos : So (value >= 0)
-- private
-- 0 idrisPleaseLearnAboutIntegers : {x, y : Integer} -> x = y
-- idrisPleaseLearnAboutIntegers {x, y} = believe_me $ Refl {x}
-- private
-- 0 natIntPlus : (m, n : Nat) ->
-- natToInteger (m + n) = natToInteger m + natToInteger n
-- natIntPlus m n = idrisPleaseLearnAboutIntegers
-- private
-- 0 shiftTwice : (x : Integer) -> (m, n : Nat) ->
-- x `shiftL` (m + n) = (x `shiftL` m) `shiftL` n
-- shiftTwice x m n = idrisPleaseLearnAboutIntegers
-- private
-- 0 shift1 : (x : Integer) -> (x `shiftL` 1) = 2 * x
-- shift1 x = idrisPleaseLearnAboutIntegers
-- private
-- 0 intPlusComm : (x, y : Integer) -> (x + y) = (y + x)
-- intPlusComm x y = idrisPleaseLearnAboutIntegers
-- private
-- 0 intTimes2Minus1 : (x : Integer) -> 2 * x - 1 = 2 * (x - 1) + 1
-- intTimes2Minus1 x = idrisPleaseLearnAboutIntegers
-- private
-- 0 intPosShift : So (x > 0) -> So (x `shiftL` i > 0)
-- intPosShift p = believe_me Oh
-- private
-- 0 intNonnegDec : {x : Integer} -> So (x > 0) -> So (x - 1 >= 0)
-- intNonnegDec p = believe_me Oh
-- private
-- 0 shiftSucc : (x : Integer) -> (n : Nat) ->
-- x `shiftL` S n = 2 * (x `shiftL` n)
-- shiftSucc x n = Calc $
-- |~ x `shiftL` S n
-- ~~ x `shiftL` (n + 1)
-- ...(cong (x `shiftL`) $ sym $ plusCommutative {})
-- ~~ (x `shiftL` n) `shiftL` 1
-- ...(shiftTwice {})
-- ~~ 2 * (x `shiftL` n)
-- ...(shift1 {})
-- private
-- opeIdVal : (n : Nat) -> Integer
-- opeIdVal n = (1 `shiftL` n) - 1
-- private
-- 0 opeIdValSpec : (n : Nat) -> Integer
-- opeIdValSpec 0 = 0
-- opeIdValSpec (S n) = keep' $ opeIdValSpec n
-- private
-- 0 opeIdValOk : (n : Nat) -> opeIdVal n = opeIdValSpec n
-- opeIdValOk 0 = Refl
-- opeIdValOk (S n) = Calc $
-- |~ (1 `shiftL` S n) - 1
-- ~~ 2 * (1 `shiftL` n) - 1 ...(cong (\x => x - 1) $ shiftSucc {})
-- ~~ 2 * (1 `shiftL` n - 1) + 1 ...(intTimes2Minus1 {})
-- ~~ 1 + 2 * (1 `shiftL` n - 1) ...(intPlusComm {})
-- ~~ 1 + 2 * opeIdValSpec n ...(cong (\x => 1 + 2 * x) $ opeIdValOk {})
-- private
-- 0 opeIdSpec : (n : Nat) -> OPE' n n
-- opeIdSpec 0 = None
-- opeIdSpec (S n) = Keep $ opeIdSpec n
-- private
-- 0 opeIdProof' : (n : Nat) -> opeIdValSpec n `IsOPE` opeIdSpec n
-- opeIdProof' 0 = IsNone
-- opeIdProof' (S n) = IsKeep (opeIdProof' n)
-- private
-- 0 opeIdProof : (n : Nat) -> opeIdVal n `IsOPE` opeIdSpec n
-- opeIdProof n = rewrite opeIdValOk n in opeIdProof' n
-- export
-- opeId : {n : Nat} -> OPE n n
-- opeId {n} = MkOPE {prf = opeIdProof n, pos = intNonnegDec $ intPosShift Oh, _}

View File

@ -1,159 +1,6 @@
module Quox.Parser
import Quox.Syntax
import Quox.Token
import Quox.Lexer
import Data.Maybe
import Data.SnocVect
import Data.SnocList
import Text.Parser
%default total
public export
Vars : Nat -> Type
Vars n = SnocVect n String
public export
Grammar : Bool -> Type -> Type
Grammar = Core.Grammar () Token
%hide Core.Grammar
public export
data Error
= Lex (Lexer.Error)
| Parse (List1 (ParsingError Token))
| Leftover (List BToken)
%hide Lexer.Error
public export
parseAll : {c : Bool} -> Grammar c a -> List BToken -> Either Error a
parseAll grm input =
case parse grm input of
Right (x, []) => Right x
Right (x, rest) => Left $ Leftover rest
Left errs => Left $ Parse errs
public export
lexParseAll : {c : Bool} -> Grammar c a -> String -> Either Error a
lexParseAll grm = lex' >=> parseAll grm
where lex' : String -> Either Error (List BToken)
lex' = bimap Lex id . lex
export
punc : Punc -> Grammar True ()
punc p = terminal (show p) $ \case
P p' => if p == p' then Just () else Nothing
_ => Nothing
export
keyword : Keyword -> Grammar True ()
keyword k = terminal (show k) $ \case
K k' => if k == k' then Just () else Nothing
_ => Nothing
export
between : Punc -> Punc -> Grammar True a -> Grammar True a
between opener closer inner = punc opener *> inner <* punc closer
export
parens, squares, braces : Grammar True a -> Grammar True a
parens = between LParen RParen
squares = between LSquare RSquare
braces = between LBrace RBrace
export
number : Grammar True Nat
number = terminal "number" $ \case
N Zero => Just 0
N One => Just 1
N (Other k) => Just k
_ => Nothing
export
universe : Grammar True Nat
universe = terminal "universe" $ \case TYPE k => Just k; _ => Nothing
export
zero, one, omega : Grammar True ()
zero = terminal "0" $ \case N Zero => Just (); _ => Nothing
one = terminal "1" $ \case N One => Just (); _ => Nothing
omega = terminal "ω" $ \case K Omega => Just (); _ => Nothing
export
quantity : Grammar True Qty
quantity = Zero <$ zero <|> One <$ one <|> Any <$ omega
find1 : Eq a => SnocVect k a -> a -> Maybe (Var k)
find1 [<] y = Nothing
find1 (sx :< x) y = if x == y then Just VZ else VS <$> find1 sx y
find : Vars k -> Name -> Maybe (Var k)
find vs (MakeName [<] (UN y)) = find1 vs y
find _ _ = Nothing
export
checkAvoid1 : Vars n -> String -> Grammar False ()
checkAvoid1 avoid y =
when (isJust $ find1 avoid y) $
fail "wrong type of bound variable: \{show y}"
export
checkAvoid : Vars n -> Name -> Grammar False ()
checkAvoid avoid (MakeName [<] (UN y)) = checkAvoid1 avoid y
checkAvoid _ _ = pure ()
export
bound : (what : String) -> (bound : Vars k) -> (avoid : Vars n) ->
Grammar True (Var k)
bound what vs avoid = do
x <- terminal "bound \{what} variable" $ \case Name x => Just x; _ => Nothing
checkAvoid1 avoid x
maybe (fail "not in scope: \{x}") pure $ find1 vs x
export
sname : Grammar True String
sname = terminal "simple name" $ \case Name x => pure x; _ => Nothing
export
qname : Grammar True Name
qname = do
parts <- sepBy1 (punc Dot) sname
pure $ MakeName {mods = cast $ init parts, base = UN $ last parts}
export
nameWith : (bound : Vars k) -> (avoid : Vars n) ->
Grammar True (Either (Var k) Name)
nameWith bound avoid = do
y <- qname
checkAvoid avoid y
pure $ maybe (Right y) Left $ find bound y
export
dimension : (dvars : Vars d) -> (tvars : Vars n) -> Grammar True (Dim d)
dimension dvars tvars =
K Zero <$ zero
<|> K One <$ one
<|> B <$> bound "dimension" {bound = dvars, avoid = tvars}
mutual
export
term : (dvars : Vars d) -> (tvars : Vars n) -> Grammar True (Term d n)
term dvars tvars =
E <$> squares (elim {dvars, tvars})
<|> TYPE . U <$> universe
export
elim : (dvars : Vars d) -> (tvars : Vars n) -> Grammar True (Elim d n)
elim dvars tvars =
either B F <$> nameWith {bound = tvars, avoid = dvars}
import public Quox.Parser.Syntax
import public Quox.Parser.Lexer
import public Quox.Parser.Parser
import public Quox.Parser.FromParser

View File

@ -0,0 +1,429 @@
||| 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
%hide Typing.Error
%hide Lexer.Error
%hide Parser.Error
%default total
public export
data StateTag = NS | SEEN
public export
FromParserPure : List (Type -> Type)
FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
public export
FromParserIO : List (Type -> Type)
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 $ MkPName [<] x) b $
Context.find (\y => y.name == Just x) xs
private
fromName : PName -> m a
fromName x = if null x.mods then fromBaseName x.base else f x
export
fromPDimWith : Has (Except Error) fs =>
Context' PatVar d -> PDim -> Eff fs (Dim d)
fromPDimWith ds (K e loc) = pure $ K e loc
fromPDimWith ds (V i loc) =
fromBaseName (\i => pure $ B i loc)
(const $ throw $ DimNotInScope loc i) ds i
private
avoidDim : Has (Except Error) fs =>
Context' PatVar d -> Loc -> PName -> Eff fs Name
avoidDim ds loc x =
fromName (const $ throw $ DimNameInTerm loc x.base) (pure . fromPName) ds x
private
resolveName : Mods -> Loc -> Name -> Maybe Universe ->
Eff FromParserPure (Term d n)
resolveName ns loc x u =
let here = addMods ns x in
if isJust $ lookup here !(getAt DEFS) then
pure $ FT here (fromMaybe 0 u) loc
else do
let ns :< _ = ns
| _ => throw $ TermNotInScope loc x
resolveName ns loc x u
export
fromPatVar : PatVar -> BindName
fromPatVar (Unused loc) = BN Unused loc
fromPatVar (PV x loc) = BN (UN x) loc
export
fromPQty : PQty -> Qty
fromPQty (PQ q _) = q
export
fromPTagVal : PTagVal -> TagVal
fromPTagVal (PT t _) = t
private
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 = unless (isNothing u) (throw $ DisplacedBoundVar loc x) $> BT i loc
free : PName -> Eff FromParserPure (Term d n)
free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
mutual
export
fromPTermWith : Context' PatVar d -> Context' PatVar n ->
PTerm -> Eff FromParserPure (Term d n)
fromPTermWith ds ns t0 = case t0 of
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
<*> fromPTermTScope ds ns [< x] t
<*> pure loc
Lam x s loc =>
Lam <$> fromPTermTScope ds ns [< x] s <*> pure loc
App s t loc =>
map E $ App
<$> fromPTermElim ds ns s
<*> fromPTermWith ds ns t
<*> pure loc
Sig x s t loc =>
Sig <$> fromPTermWith ds ns s
<*> fromPTermTScope ds ns [< x] t
<*> pure loc
Pair s t loc =>
Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t <*> pure loc
Case pi pair (r, ret) (CasePair (x, y) body _) loc =>
map E $ CasePair (fromPQty pi)
<$> fromPTermElim ds ns pair
<*> fromPTermTScope ds ns [< r] ret
<*> 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 loc ds ns arms
<*> pure 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
<*> fromPTermTScope ds ns [< r] ret
<*> fromPTermWith ds ns zer
<*> fromPTermTScope ds ns [< s, ih] suc
<*> pure loc
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
Eq (i, ty) s t loc =>
Eq <$> fromPTermDScope ds ns [< i] ty
<*> fromPTermWith ds ns s
<*> fromPTermWith ds ns t
<*> pure loc
DLam i s loc =>
DLam <$> fromPTermDScope ds ns [< i] s <*> pure loc
DApp s p loc =>
map E $ DApp
<$> fromPTermElim ds ns s
<*> fromPDimWith ds p
<*> pure loc
BOX q ty loc => BOX (fromPQty q) <$> fromPTermWith ds ns ty <*> pure loc
Box val loc => Box <$> fromPTermWith ds ns val <*> pure loc
Case pi box (r, ret) (CaseBox b body _) loc =>
map E $ CaseBox (fromPQty pi)
<$> fromPTermElim ds ns box
<*> fromPTermTScope ds ns [< r] ret
<*> fromPTermTScope ds ns [< b] body
<*> pure loc
V x u loc => fromV ds ns x u loc
Ann s a loc =>
map E $ Ann
<$> fromPTermWith ds ns s
<*> fromPTermWith ds ns a
<*> pure loc
Coe (i, ty) p q val loc =>
map E $ Coe
<$> fromPTermDScope ds ns [< i] ty
<*> fromPDimWith ds p
<*> fromPDimWith ds q
<*> fromPTermWith ds ns val
<*> pure loc
Comp (i, ty) p q val r (j0, val0) (j1, val1) loc =>
map E $ CompH'
<$> fromPTermDScope ds ns [< i] ty
<*> fromPDimWith ds p
<*> fromPDimWith ds q
<*> fromPTermWith ds ns val
<*> fromPDimWith ds r
<*> fromPTermDScope ds ns [< j0] val0
<*> 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 : Loc -> Context' PatVar d -> Context' PatVar n ->
List (PTagVal, PTerm) ->
Eff FromParserPure (CaseEnumArms d n)
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 ->
PTerm -> Eff FromParserPure (Elim d n)
fromPTermElim ds ns e =
case !(fromPTermWith ds ns e) of
E e => pure e
t => let ctx = MkNameContexts (map fromPatVar ds) (map fromPatVar ns) in
throw $ AnnotationNeeded t.loc ctx t
private
fromPTermTScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
SnocVect s PatVar -> PTerm ->
Eff FromParserPure (ScopeTermN s d n)
fromPTermTScope ds ns xs t =
if all isUnused xs then
SN <$> fromPTermWith ds ns t
else
ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
private
fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
SnocVect s PatVar -> PTerm ->
Eff FromParserPure (DScopeTermN s d n)
fromPTermDScope ds ns xs t =
if all isUnused xs then
SN {f = \d => Term d n} <$> fromPTermWith ds ns t
else
DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
export %inline
fromPTerm : PTerm -> Eff FromParserPure (Term 0 0)
fromPTerm = fromPTermWith [<] [<]
export
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 : Has (StateL NS Mods) fs => PBaseName -> Eff fs Name
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
private
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 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) =
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
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 !(loadFile loc file) of
Just tl => concat <$> traverse fromPTopLevel tl
Nothing => pure []
||| populates the `defs` field of the state
export covering
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
fromPTopLevel (PD decl) = lift $ fromPDecl decl
fromPTopLevel (PLoad file loc) = loadProcessFile loc file

View File

@ -0,0 +1,146 @@
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.(<++>)
public export
TypeError, LexError, ParseError : Type
TypeError = Typing.Error
LexError = Lexer.Error
ParseError = Parser.Error
%hide Typing.Error
%hide Lexer.Error
%hide Parser.Error
public export
data Error =
AnnotationNeeded Loc (NameContexts d n) (Term d n)
| 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
| 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
reason <- case reason of
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
prettyParseError1 : {opts : _} -> String -> ParsingError _ ->
Eff Pretty (Doc opts)
prettyParseError1 file (Error msg Nothing) =
pure $ text msg
prettyParseError1 file (Error msg (Just bounds)) =
pure $ vappend !(prettyLoc $ makeLoc file bounds) (text msg)
export
prettyParseError : {opts : _} -> String -> ParseError ->
Eff Pretty (Doc opts)
prettyParseError file (LexError err) =
pure $ vsep ["lexical error:", !(prettyLexError file err)]
prettyParseError file (ParseError errs) =
map (vsep . ("parse error:" ::)) $
traverse (map ("-" <++>) . prettyParseError1 file) (toList errs)
parameters {opts : LayoutOpts} (showContext : Bool)
export
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 (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"])|]
prettyError (TermNotInScope loc x) =
[|vappend (prettyLoc loc)
(pure $ hsep ["term variable", !(prettyFree x), "not in scope"])|]
prettyError (QtyNotGlobal loc pi) = pure $
vappend !(prettyLoc loc)
(sep ["quantity" <++> !(prettyQty pi),
"can't be used on a top level declaration"])
prettyError (DimNameInTerm loc i) = pure $
vappend !(prettyLoc loc)
(sep ["dimension" <++> !(hl DVar $ text i),
"used in a term context"])
prettyError (DisplacedBoundVar loc x) = pure $
vappend !(prettyLoc loc)
(sep ["local variable" <++> !(hl TVar $ text $ toDotsP x),
"cannot be displaced"])
prettyError (WrapTypeError err) =
Typing.prettyError showContext $ trimContext 2 err
prettyError (AlreadyExists loc name) = pure $
vsep [!(prettyLoc loc),
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

342
lib/Quox/Parser/Lexer.idr Normal file
View File

@ -0,0 +1,342 @@
module Quox.Parser.Lexer
import Quox.CharExtra
import Quox.NatExtra
import Quox.Name
import Data.String.Extra
import Data.SortedMap
import public Data.String -- for singleton to reduce in IsReserved
import public Data.List.Elem
import public Text.Lexer
import public Text.Lexer.Tokenizer
import Derive.Prelude
%hide TT.Name
%default total
%language ElabReflection
||| @ Reserved reserved token
||| @ Name name, possibly qualified
||| @ Nat nat literal
||| @ Str string literal
||| @ Tag tag literal
||| @ TYPE "Type" or "★" with ascii nat directly after
||| @ Sup superscript or ^ number (displacement, or universe for ★)
public export
data Token =
Reserved String
| Name PName
| Nat Nat
| Str String
| Tag String
| TYPE Nat
| Sup Nat
%runElab derive "Token" [Eq, Ord, Show]
||| 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
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 : ErrorReason
line, col : Int
||| `Nothing` if the error is at the end of the input
char : Maybe Char
%runElab derive "StopReason" [Eq, Ord, Show]
%runElab derive "Error" [Eq, Ord, Show]
private
skip : Lexer -> Tokenizer ExtToken
skip t = match t $ const Skip
private
tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken
tmatch t f = match t (T . f)
export
fromStringLit : (String -> Token) -> String -> ExtToken
fromStringLit f str =
case go $ unpack $ drop 1 $ dropLast 1 str of
Left err => Invalid err str
Right ok => T $ f $ pack ok
where
Interpolation Char where interpolate = singleton
go, hexEscape : List Char -> Either String (List Char)
go [] = Right []
go ['\\'] = Left "string ends with \\"
go ('\\' :: 'n' :: cs) = ('\n' ::) <$> go cs
go ('\\' :: 't' :: cs) = ('\t' ::) <$> go cs
go ('\\' :: 'x' :: cs) = hexEscape cs
go ('\\' :: 'X' :: cs) = hexEscape cs
go ('\\' :: '\\' :: cs) = ('\\' ::) <$> go cs
go ('\\' :: '"' :: cs) = ('"' ::) <$> go cs
-- [todo] others
go ('\\' :: c :: _) = Left "unknown escape '\{c}'"
go (c :: cs) = (c ::) <$> go cs
hexEscape cs =
case break (== ';') cs of
(hs, ';' :: rest) => do
let hs = pack hs
let Just c = Int.fromHex hs
| Nothing => Left #"invalid hex string "\#{hs}" in escape"#
if isCodepoint c
then (chr c ::) <$> go (assert_smaller cs rest)
else Left "codepoint \{hs} out of range"
_ => Left "unterminated hex escape"
private
string : Tokenizer ExtToken
string = match stringLit $ fromStringLit Str
%hide binLit
%hide octLit
%hide hexLit
private
nat : Tokenizer ExtToken
nat = match hexLit fromHexLit
<|> tmatch decLit fromDecLit
where
withUnderscores : Lexer -> Lexer
withUnderscores l = l <+> many (opt (is '_') <+> l)
withoutUnderscores : String -> String
withoutUnderscores = pack . go . unpack where
go : List Char -> List Char
go [] = []
go ('_' :: 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 ExtToken
tag = tmatch (is '\'' <+> name) (Tag . drop 1)
<|> match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1)
private %inline
fromSup : Char -> Char
fromSup c = case c of
'' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '' => '4'
'' => '5'; '' => '6'; '' => '7'; '' => '8'; '' => '9'; _ => c
private %inline
supToNat : String -> Nat
supToNat = cast . pack . map fromSup . unpack
-- ★0, Type0. base ★/Type is a Reserved and ★¹/Type¹ are sequences of two tokens
private
universe : Tokenizer ExtToken
universe = universeWith "" <|> universeWith "Type" where
universeWith : String -> Tokenizer ExtToken
universeWith pfx =
let len = length pfx in
tmatch (exact pfx <+> digits) (TYPE . cast . drop len)
private
sup : Tokenizer ExtToken
sup = tmatch (some $ pred isSupDigit) (Sup . supToNat)
<|> tmatch (is '^' <+> digits) (Sup . cast . drop 1)
private %inline
choice : (xs : List (Tokenizer a)) -> (0 _ : NonEmpty xs) => Tokenizer a
choice (t :: ts) = foldl (\a, b => a <|> b) t ts
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);
||| also a sequence ending in one of those, like `#[`, since the
||| difference relates to lookahead
public export
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
public export
data Reserved = Only Reserved1 | Or Reserved1 Reserved1
%runElab derive "Reserved" [Eq, Ord, Show]
public export
Sym1, Word1, Punc1 : String -> Reserved
Sym1 = Only . Sym
Word1 = Only . Word
Punc1 = Only . Punc
public export
resString1 : Reserved1 -> String
resString1 (Punc x) = x
resString1 (Word w) = w
resString1 (Sym s) = s
||| return the representative string for a token description. if there are
||| two, then it's the first one, which should be the full-unicode one
public export
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 ExtToken
resTokenizer1 r str =
let res : String -> Token := const $ Reserved str in
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 ExtToken
resTokenizer (Only r) = resTokenizer1 r (resString1 r)
resTokenizer (r `Or` s) =
resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r)
||| reserved words & symbols.
||| the tokens recognised by ``a `Or` b`` will be `Reserved a`.
||| e.g. `=>` in the input (if not part of a longer name)
||| will be returned as `Reserved "⇒"`.
public export
reserved : List Reserved
reserved =
[Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}",
Punc1 ",", Punc1 ";", Punc1 "#[", Punc1 "#![",
Sym1 "@",
Sym1 ":",
Sym "" `Or` Sym "=>",
Sym "" `Or` Sym "->",
Sym "×" `Or` Sym "**",
Sym "" `Or` Sym "==",
Sym "" `Or` Sym "::",
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",
Word "δ" `Or` Word "dfun",
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 = 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 ExtToken
tokens = choice $
map skip [pred isWhitespace,
lineComment (exact "--" <+> reject symCont),
blockComment (exact "{-") (exact "-}")] <+>
[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 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 ()

886
lib/Quox/Parser/Parser.idr Normal file
View File

@ -0,0 +1,886 @@
module Quox.Parser.Parser
import public Quox.Parser.Lexer
import public Quox.Parser.Syntax
import Data.Bool
import Data.Fin
import Data.Vect
import public Text.Parser
import Derive.Prelude
%language ElabReflection
%default total
public export
0 Grammar : Bool -> Type -> Type
Grammar = Core.Grammar () Token
%hide Core.Grammar
public export
data Error =
LexError Lexer.Error
| ParseError (List1 (ParsingError Token))
%hide Lexer.Error
%runElab derive "Error" [Show]
export
lexParseWith : {c : Bool} -> Grammar c a -> String -> Either Error a
lexParseWith grm input = do
toks <- mapFst LexError $ lex input
bimap ParseError fst $ parse (grm <* eof) toks
export
withLoc : {c : Bool} -> FileName -> (Grammar c (Loc -> a)) -> Grammar c a
withLoc fname act = bounds act <&> \res =>
if res.isIrrelevant then res.val noLoc
else res.val $ makeLoc fname res.bounds
export
defLoc : FileName -> (Loc -> a) -> Grammar False a
defLoc fname f = position <&> f . makeLoc fname
export
unused : FileName -> Grammar False PatVar
unused fname = defLoc fname Unused
||| reserved token, like punctuation or keywords etc
export
res : (str : String) -> (0 _ : IsReserved str) => Grammar True ()
res str = terminal "expected \"\{str}\"" $ guard . (== Reserved str)
||| optional reserved token, e.g. trailing comma
export
optRes : (str : String) -> (0 _ : IsReserved str) => Grammar False ()
optRes str = ignore $ optional $ res str
||| reserved token, then commit
export
resC : (str : String) -> (0 _ : IsReserved str) => Grammar True ()
resC str = do res str; commit
||| reserved token or fatal error
export
needRes : (str : String) -> (0 _ : IsReserved str) => Grammar True ()
needRes str = resC str <|> fatalError "expected \"\{str}\""
private
terminalMatchN_ : String -> List (TTImp, TTImp) -> Elab (Grammar True a)
terminalMatchN_ what matches = do
func <- check $ lam (lambdaArg `{x}) $
iCase `(x) implicitFalse $
map (\(l, r) => patClause l `(Just ~(r))) matches ++
[patClause `(_) `(Nothing)]
pure $ terminal "expected \{what}" func
private %macro
terminalMatchN : String -> List (TTImp, TTImp) -> Elab (Grammar True a)
terminalMatchN = terminalMatchN_
private %macro
terminalMatch : String -> TTImp -> TTImp -> Elab (Grammar True a)
terminalMatch what l r = terminalMatchN_ what [(l, r)]
||| tag without leading `'`
export
bareTag : Grammar True TagVal
bareTag = terminalMatchN "bare tag"
[(`(Name t), `(toDotsP t)), (`(Str s), `(s))]
||| tag with leading quote
export
tag : Grammar True TagVal
tag = terminalMatch "tag" `(Tag t) `(t)
||| natural number
export
nat : Grammar True Nat
nat = terminalMatch "natural number" `(Nat n) `(n)
||| string literal
export
strLit : Grammar True String
strLit = terminalMatch "string literal" `(Str s) `(s)
||| single-token universe, like ★0 or Type1
export
universeTok : Grammar True Universe
universeTok = terminalMatch "universe" `(TYPE u) `(u)
export
super : Grammar True Nat
super = terminalMatch "superscript number or '^'" `(Sup n) `(n)
||| possibly-qualified name
export
qname : Grammar True PName
qname = terminalMatch "name" `(Name n) `(n)
||| unqualified name
export
baseName : Grammar True PBaseName
baseName = terminalMatch "unqualified name" `(Name (MkPName [<] b)) `(b)
||| dimension constant (0 or 1)
export
dimConst : Grammar True DimConst
dimConst = terminalMatchN "dimension constant"
[(`(Nat 0), `(Zero)), (`(Nat 1), `(One))]
||| quantity (0, 1, or ω)
export
qtyVal : Grammar True Qty
qtyVal = terminalMatchN "quantity"
[(`(Nat 0), `(Zero)), (`(Nat 1), `(One)), (`(Reserved "ω"), `(Any))]
||| optional superscript number
export
displacement : Grammar False (Maybe Universe)
displacement = optional super
||| quantity (0, 1, or ω)
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
patVar : FileName -> Grammar True PatVar
patVar fname = withLoc fname $
[|PV baseName|] <|> Unused <$ res "_"
||| dimension (without `@` prefix)
export
dim : FileName -> Grammar True PDim
dim fname = withLoc fname $ [|K dimConst|] <|> [|V baseName|]
||| dimension argument (with @)
export
dimArg : FileName -> Grammar True PDim
dimArg fname = do resC "@"; mustWork $ dim fname
delim : (o, c : String) -> (0 _ : IsReserved o) => (0 _ : IsReserved c) =>
{k : Bool} -> Grammar k a -> Grammar True a
delim o c p = resC o *> p <* needRes c
-- this stuff is Like This (rather than just being delim + sepEndBy{1})
-- so that it checks for the close bracket before trying another list element,
-- giving (imo) a better error
parameters (o, c, s : String)
{auto 0 _ : IsReserved o} {auto 0 _ : IsReserved c}
{auto 0 _ : IsReserved s}
(p : Grammar True a)
private
dsBeforeDelim, dsAfterDelim : Grammar True (List a)
dsBeforeDelim = [] <$ resC c <|> resC s *> assert_total dsAfterDelim
dsAfterDelim = [] <$ resC c <|> [|p :: assert_total dsBeforeDelim|]
export
delimSep1 : Grammar True (List1 a)
delimSep1 = resC o *> [|p ::: dsBeforeDelim|]
export
delimSep : Grammar True (List a)
delimSep = resC o *> dsAfterDelim
||| enum type, e.g. `{a, b, c.d, "e f g"}`
export
enumType : Grammar True (List TagVal)
enumType = delimSep "{" "}" "," bareTag
||| 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ω")
<|> do resC "case"
qty fname <* needRes "." <|> defLoc fname (PQ One)
export
qtyPatVar : FileName -> Grammar True (PQty, PatVar)
qtyPatVar fname =
[|(,) (qty fname) (needRes "." *> patVar fname)|]
<|> [|(,) (defLoc fname $ PQ One) (patVar fname)|]
export
ptag : FileName -> Grammar True PTagVal
ptag fname = withLoc fname $ [|PT tag|]
public export
data PCasePat =
PPair PatVar PatVar Loc
| PTag PTagVal Loc
| PZero Loc
| PSucc PatVar PQty PatVar Loc
| PBox PatVar Loc
%runElab derive "PCasePat" [Eq, Ord, Show]
export
Located PCasePat where
(PPair _ _ loc).loc = loc
(PTag _ loc).loc = loc
(PZero loc).loc = loc
(PSucc _ _ _ loc).loc = loc
(PBox _ loc).loc = loc
||| either `zero` or `0`
export
zeroPat : Grammar True ()
zeroPat = resC "zero" <|> terminal "expected '0'" (guard . (== Nat 0))
export
casePat : FileName -> Grammar True PCasePat
casePat fname = withLoc fname $
delim "(" ")" [|PPair (patVar fname) (needRes "," *> patVar fname)|]
<|> [|PTag (ptag fname)|]
<|> PZero <$ zeroPat
<|> do p <- resC "succ" *> patVar fname
ih <- resC "," *> qtyPatVar fname
<|> [|(,) (defLoc fname $ PQ Zero) (unused fname)|]
pure $ PSucc p (fst ih) (snd ih)
<|> delim "[" "]" [|PBox (patVar fname)|]
<|> fatalError "invalid pattern"
export
term : FileName -> Grammar True PTerm
-- defined after all the subterm parsers
||| box term `[t]` or type `[π.A]`
export
boxTerm : FileName -> Grammar True PTerm
boxTerm fname = withLoc fname $ do
res "["; commit
q <- optional $ qty fname <* res "."
t <- mustWork $ assert_total term fname <* needRes "]"
pure $ maybe (Box t) (\q => BOX q t) q
||| tuple term like `(a, b)`, or parenthesised single term.
||| allows terminating comma. more than two elements are nested on the right:
||| `(a, b, c, d) = (a, (b, (c, d)))`.
export
tupleTerm : FileName -> Grammar True PTerm
tupleTerm fname = withLoc fname $ do
terms <- delimSep1 "(" ")" "," $ assert_total term fname
pure $ \loc => foldr1 (\s, t => Pair s t loc) terms
export
universe1 : Grammar True Universe
universe1 = universeTok <|> res "" *> option 0 super
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 ""
<|> Nat 0 <$ res "zero"
<|> [|Nat nat|]
<|> STRING <$ res "String"
<|> [|Str strLit|]
<|> [|V qname displacement|]
<|> const <$> caseTerm fname
<|> const <$> tupleTerm fname
export
properTypeLine : FileName -> Grammar True (PatVar, PTerm)
properTypeLine fname = do
resC "("
i <- patVar fname <* resC "" <|> unused fname
t <- assert_total term fname <* needRes ")"
pure (i, t)
export
typeLine : FileName -> Grammar True (PatVar, PTerm)
typeLine fname =
properTypeLine fname <|> [|(,) (unused fname) (termArg fname)|]
||| optionally, two dimension arguments. if absent default to `@0 @1`
private
optDirection : FileName -> Grammar False (PDim, PDim)
optDirection fname = withLoc fname $ do
dims <- optional [|(,) (dimArg fname) (dimArg fname)|]
pure $ \loc => fromMaybe (K Zero loc, K One loc) dims
export
coeTerm : FileName -> Grammar True PTerm
coeTerm fname = withLoc fname $ do
resC "coe"
mustWork $ do
line <- typeLine fname
(p, q) <- optDirection fname
val <- termArg fname
pure $ Coe line p q val
public export
CompBranch : Type
CompBranch = (DimConst, PatVar, PTerm)
export
compBranch : FileName -> Grammar True CompBranch
compBranch fname =
[|(,,) dimConst (patVar fname) (needRes "" *> assert_total term fname)|]
private
checkCompTermBody : (PatVar, PTerm) -> PDim -> PDim -> PTerm -> PDim ->
CompBranch -> CompBranch -> Bounds ->
Grammar False (Loc -> PTerm)
checkCompTermBody a p q s r (e0, s0) (e1, s1) bounds =
case (e0, e1) of
(Zero, One) => pure $ Comp a p q s r s0 s1
(One, Zero) => pure $ Comp a p q s r s1 s0
(_, _) =>
fatalLoc bounds "body of 'comp' needs one 0 case and one 1 case"
export
compTerm : FileName -> Grammar True PTerm
compTerm fname = withLoc fname $ do
resC "comp"
mustWork $ do
a <- typeLine fname
(p, q) <- optDirection fname
s <- termArg fname; r <- dimArg fname
bodyStart <- bounds $ needRes "{"
s0 <- compBranch fname; needRes ";"
s1 <- compBranch fname; optRes ";"
bodyEnd <- bounds $ needRes "}"
let body = bounds $ mergeBounds bodyStart bodyEnd
checkCompTermBody a p q s r s0 s1 body
export
splitUniverseTerm : FileName -> Grammar True PTerm
splitUniverseTerm fname =
withLoc fname $ resC "" *> [|TYPE $ option 0 $ nat <|> super|]
-- some of this looks redundant, but when parsing a non-atomic term
-- this branch will be taken first
export
eqTerm : FileName -> Grammar True PTerm
eqTerm fname = withLoc fname $
resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (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
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 (appArg loc) head args
||| application term `f x @y z`, or other terms that look like application
||| like `succ` or `coe`.
export
appTerm : FileName -> Grammar True PTerm
appTerm fname =
coeTerm fname
<|> compTerm fname
<|> splitUniverseTerm fname
<|> eqTerm fname
<|> succTerm fname
<|> fstTerm fname
<|> sndTerm fname
<|> normalAppTerm fname
export
infixEqTerm : FileName -> Grammar True PTerm
infixEqTerm fname = withLoc fname $ do
l <- appTerm fname; commit
rest <- optional $ res "" *>
[|(,) (assert_total term fname) (needRes ":" *> appTerm fname)|]
let u = Unused $ onlyStart l.loc
pure $ \loc => maybe l (\rest => Eq (u, snd rest) l (fst rest) loc) rest
export
annTerm : FileName -> Grammar True PTerm
annTerm fname = withLoc fname $ do
tm <- infixEqTerm fname; commit
ty <- optional $ res "" *> assert_total term fname
pure $ \loc => maybe tm (\ty => Ann tm ty loc) ty
export
lamTerm : FileName -> Grammar True PTerm
lamTerm fname = withLoc fname $ do
k <- DLam <$ res "δ" <|> Lam <$ res "λ"
mustWork $ do
xs <- some $ patVar fname; needRes ""
body <- assert_total term fname; commit
pure $ \loc => foldr (\x, s => k x s loc) body xs
-- [todo] fix the backtracking in e.g. (F x y z × B)
export
properBinders : FileName -> Grammar True (List1 PatVar, PTerm)
properBinders fname = assert_total $ do
-- putting assert_total directly on `term`, in this one function,
-- doesn't work. i cannot tell why
res "("
xs <- some $ patVar fname; resC ":"
t <- term fname; needRes ")"
pure (xs, t)
export
sigmaTerm : FileName -> Grammar True PTerm
sigmaTerm fname =
(properBinders fname >>= continueDep)
<|> (annTerm fname >>= continueNondep)
where
continueDep : (List1 PatVar, PTerm) -> Grammar True PTerm
continueDep (names, fst) = withLoc fname $ do
snd <- needRes "×" *> sigmaTerm fname
pure $ \loc => foldr (\x, snd => Sig x fst snd loc) snd names
cross : PTerm -> PTerm -> PTerm
cross l r = let loc = extend' l.loc r.loc.bounds in
Sig (Unused $ onlyStart l.loc) l r loc
continueNondep : PTerm -> Grammar False PTerm
continueNondep fst = do
rest <- optional $ resC "×" *> sepBy1 (res "×") (annTerm fname)
pure $ foldr1 cross $ fst ::: maybe [] toList rest
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
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
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
-- term : FileName -> Grammar True PTerm
term fname = lamTerm fname
<|> piTerm fname
<|> sigmaTerm fname
<|> letTerm fname
export
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 "#["
export
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
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 ";"
either fatalError pure $ mkPDef attrs qty name $ PConcrete type term
export
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|]
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
load fname = withLoc fname $
resC "load" *> mustWork [|PLoad strLit|] <* optRes ";"
export
topLevel : FileName -> Grammar True PTopLevel
topLevel fname = load fname <|> [|PD $ decl fname|]
export
input : FileName -> Grammar False PFile
input fname = [] <$ eof
<|> [|(topLevel fname <* commit) :: assert_total input fname|]
export
lexParseTerm : FileName -> String -> Either Error PTerm
lexParseTerm = lexParseWith . term
export
lexParseInput : FileName -> String -> Either Error PFile
lexParseInput = lexParseWith . input

251
lib/Quox/Parser/Syntax.idr Normal file
View File

@ -0,0 +1,251 @@
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
%default total
%language ElabReflection
public export
data PatVar = Unused Loc | PV PBaseName Loc
%name PatVar v
%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal]
export %inline
Located PatVar where
(Unused loc).loc = loc
(PV _ loc).loc = loc
export
(.name) : PatVar -> Maybe PBaseName
(Unused _).name = Nothing
(PV nm _).name = Just nm
export
isUnused : PatVar -> Bool
isUnused (Unused {}) = True
isUnused _ = False
public export
record PQty where
constructor PQ
val : Qty
loc_ : Loc
%name PQty qty
%runElab derive "PQty" [Eq, Ord, Show, PrettyVal]
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, PrettyVal]
export %inline
Located PDim where
(K _ loc).loc = loc
(V _ loc).loc = loc
public export
data PTagVal = PT TagVal Loc
%name PTagVal tag
%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal]
namespace PTerm
mutual
||| terms out of the parser with BVs and bidirectionality still tangled up
public export
data PTerm =
TYPE Universe Loc
| IOState Loc
| Pi PQty PatVar PTerm PTerm Loc
| Lam PatVar PTerm Loc
| App PTerm PTerm Loc
| 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
| Eq (PatVar, PTerm) PTerm PTerm Loc
| DLam PatVar PTerm Loc
| DApp PTerm PDim 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
| V PName (Maybe Universe) Loc
| Ann PTerm PTerm Loc
| 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
data PCaseBody =
CasePair (PatVar, PatVar) PTerm Loc
| CaseEnum (List (PTagVal, PTerm)) Loc
| CaseNat PTerm (PatVar, PQty, PatVar, PTerm) Loc
| CaseBox PatVar PTerm Loc
%name PCaseBody body
public export %inline
Zero : Loc -> PTerm
Zero = Nat 0
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal]
export %inline
Located PTerm where
(TYPE _ loc).loc = loc
(IOState loc).loc = loc
(Pi _ _ _ _ loc).loc = loc
(Lam _ _ loc).loc = loc
(App _ _ loc).loc = loc
(Sig _ _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Fst _ loc).loc = loc
(Snd _ loc).loc = loc
(Case _ _ _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ _ loc).loc = loc
(DApp _ _ loc).loc = loc
(NAT loc).loc = loc
(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 %inline
Located PCaseBody where
(CasePair _ _ loc).loc = loc
(CaseEnum _ loc).loc = loc
(CaseNat _ _ loc).loc = loc
(CaseBox _ _ loc).loc = loc
public export
data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm
%name PBody body
%runElab derive "PBody" [Eq, Ord, Show, PrettyVal]
public export
data PFail =
PSucceed
| PFailAny
| PFailMatch String
%runElab derive "PFail" [Eq, Ord, Show, PrettyVal]
public export
record PDefinition where
constructor MkPDef
qty : PQty
name : PBaseName
body : PBody
fail : PFail
main : Bool
scheme : Maybe String
loc_ : Loc
%name PDefinition def
%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
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
record PNamespace where
constructor MkPNamespace
name : Mods
decls : List PDecl
fail : PFail
loc_ : Loc
%name PNamespace ns
public export
data PDecl =
PDef PDefinition
| PNs PNamespace
| PPrag PPragma
%name PDecl decl
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal]
export %inline Located PNamespace where ns.loc = ns.loc_
export %inline
Located PDecl where
(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, PrettyVal]
export %inline
Located PTopLevel where
(PD decl).loc = decl.loc
(PLoad _ loc).loc = loc
public export
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

@ -1,16 +1,18 @@
module Quox.Pretty
import Quox.Loc
import Quox.Name
import public Text.PrettyPrint.Prettyprinter.Doc
import Text.PrettyPrint.Prettyprinter.Render.String
import Text.PrettyPrint.Prettyprinter.Render.Terminal
import Control.Monad.ST.Extra
import public Text.PrettyPrint.Bernardy
import public Text.PrettyPrint.Bernardy.Core.Decorate
import public Quox.EffExtra
import public Data.String
import Data.DPair
import Control.ANSI.SGR
import public Control.Monad.Identity
import public Control.Monad.Reader
import Generics.Derive
import Data.DPair
import Data.SnocList
import Derive.Prelude
%default total
%language ElabReflection
@ -19,13 +21,17 @@ import Generics.Derive
public export
record PrettyOpts where
constructor MakePrettyOpts
unicode, color : Bool
public export
defPrettyOpts : PrettyOpts
defPrettyOpts = MakePrettyOpts {unicode = True, color = True}
data PPrec
= Outer
| Times -- "_ × _"
| InTimes -- arguments of ×
| AnnL -- left of "∷"
| Eq -- "_ ≡ _ : _"
| InEq -- arguments of ≡
-- ...
| App -- term/dimension application
| Arg -- argument to nonfix function
%runElab derive "PPrec" [Eq, Ord, Show]
public export
@ -33,169 +39,326 @@ data HL
= Delim
| Free | TVar | TVarErr
| Dim | DVar | DVarErr
| Qty
| Qty | Universe
| Syntax
%runElab derive "HL" [Generic, Meta, Eq, Ord, DecEq, Show]
| Constant
%runElab derive "HL" [Eq, Ord, Show]
public export
data PPrec
= Outer
| Ann -- right of "::"
| AnnL -- left of "::"
-- ...
| App -- term/dimension application
| SApp -- substitution application
| Arg -- argument to nonfix function
%runElab derive "PPrec" [Generic, Meta, Eq, Ord, DecEq, Show]
data Flavor = Unicode | Ascii
%runElab derive "Flavor" [Eq, Ord, Show]
export %inline
noHighlight : HL -> Highlight
noHighlight _ = MkHighlight "" ""
public export
data EffTag = PREC | FLAVOR | HIGHLIGHT | INDENT
public export
Pretty : List (Type -> Type)
Pretty = [StateL PREC PPrec, ReaderL FLAVOR Flavor,
ReaderL HIGHLIGHT (HL -> Highlight), ReaderL INDENT Nat]
export %inline
runPrettyWith : PPrec -> Flavor -> (HL -> Highlight) -> Nat ->
Eff Pretty a -> a
runPrettyWith prec flavor highlight indent act =
runST $ do
runEff act $ with Union.(::)
[handleStateSTRef !(newSTRef prec),
handleReaderConst flavor,
handleReaderConst highlight,
handleReaderConst indent]
export %inline
hl : HL -> Doc HL -> Doc HL
hl = annotate
toSGR : HL -> List SGR
toSGR Delim = []
toSGR Free = [SetForeground BrightBlue]
toSGR TVar = [SetForeground BrightYellow]
toSGR TVarErr = [SetForeground BrightYellow, SetStyle SingleUnderline]
toSGR Dim = [SetForeground BrightGreen]
toSGR DVar = [SetForeground BrightGreen]
toSGR DVarErr = [SetForeground BrightGreen, SetStyle SingleUnderline]
toSGR Qty = [SetForeground BrightMagenta]
toSGR Universe = [SetForeground BrightRed]
toSGR Syntax = [SetForeground BrightCyan]
toSGR Constant = [SetForeground BrightRed]
export %inline
hl' : HL -> Doc HL -> Doc HL
hl' h = hl h . unAnnotate
highlightSGR : HL -> Highlight
highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
export %inline
hlF : Functor f => HL -> f (Doc HL) -> f (Doc HL)
hlF = map . hl
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
hlF' : Functor f => HL -> f (Doc HL) -> f (Doc HL)
hlF' = map . hl'
highlightHtml : HL -> Highlight
highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
export %inline
parens : Doc HL -> Doc HL
parens doc = hl Delim "(" <+> doc <+> hl Delim ")"
%hide Symbols.parens
runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
runPrettyHL f = runPrettyWith Outer Unicode f 2
export %inline
parensIf : Bool -> Doc HL -> Doc HL
runPretty : Eff Pretty a -> a
runPretty = runPrettyHL noHighlight
export %inline
hl : {opts : LayoutOpts} -> HL -> Doc opts -> Eff Pretty (Doc opts)
hl h doc = asksAt HIGHLIGHT $ \f => decorate (f h) doc
export %inline
indentD : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
indentD doc = pure $ indent !(askAt INDENT) doc
export %inline
hangD : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts)
hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2
export %inline
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 : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
Eff Pretty (Doc opts)
tightDelims l r inner = do
l <- hl Delim $ text l
r <- hl Delim $ text r
pure $ hcat [l, inner, r]
export
looseDelims : {opts : LayoutOpts} -> (l, r : String) -> (inner : Doc opts) ->
Eff Pretty (Doc opts)
looseDelims l r inner = do
l <- hl Delim $ text l
r <- hl Delim $ text r
let short = hsep [l, inner, r]
long = vsep [l, !(indentD inner), r]
pure $ ifMultiline short long
export %inline
parens : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
parens = tightDelims "(" ")"
export %inline
bracks : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
bracks = tightDelims "[" "]"
export %inline
braces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
braces = looseDelims "{" "}"
export %inline
tightBraces : {opts : LayoutOpts} -> Doc opts -> Eff Pretty (Doc opts)
tightBraces = tightDelims "{" "}"
export %inline
parensIf : {opts : LayoutOpts} -> Bool -> Doc opts -> Eff Pretty (Doc opts)
parensIf True = parens
parensIf False = id
parensIf False = pure
||| uses hsep only if the whole list fits on one line
export
sepSingle : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
sepSingle xs = ifMultiline (hsep xs) (vsep xs)
export
fillSep : {opts : LayoutOpts} -> List (Doc opts) -> Doc opts
fillSep [] = empty
fillSep (x :: xs) = foldl (\x, y => sep [x, y]) x xs
export
exceptLast : {opts : LayoutOpts} -> (Doc opts -> Doc opts) ->
List (Doc opts) -> List (Doc opts)
exceptLast f [] = []
exceptLast f [x] = [x]
exceptLast f (x :: xs) = f x :: exceptLast f xs
parameters {opts : LayoutOpts} {auto _ : Foldable t}
export
separateLoose : Doc opts -> t (Doc opts) -> Doc opts
separateLoose d = sep . exceptLast (<++> d) . toList
export
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 =
asksAt FLAVOR $ \case
Unicode => uni
Ascii => asc
export %inline
parensIfM : {opts : LayoutOpts} -> PPrec -> Doc opts -> Eff Pretty (Doc opts)
parensIfM d doc = parensIf (!(getAt PREC) > d) doc
export %inline
withPrec : PPrec -> Eff Pretty a -> Eff Pretty a
withPrec = localAt_ PREC
export
separate' : Doc a -> List (Doc a) -> List (Doc a)
separate' s [] = []
separate' s [x] = [x]
separate' s (x :: xs) = x <+> s :: separate' s xs
prettyName : Name -> Doc opts
prettyName = text . toDots
export
prettyFree : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts)
prettyFree = hl Free . prettyName
export
prettyBind' : BindName -> Doc opts
prettyBind' = text . baseStr . val
export
prettyTBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
prettyTBind = hl TVar . prettyBind'
export
prettyDBind : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts)
prettyDBind = hl DVar . prettyBind'
export %inline
separate : Doc a -> List (Doc a) -> Doc a
separate s = sep . separate' s
export %inline
hseparate : Doc a -> List (Doc a) -> Doc a
hseparate s = hsep . separate' s
export %inline
vseparate : Doc a -> List (Doc a) -> Doc a
vseparate s = vsep . separate' s
public export
record PrettyEnv where
constructor MakePrettyEnv
||| names of bound dimension variables
dnames : List Name
||| names of bound term variables
tnames : List Name
||| use non-ascii characters for syntax
unicode : Bool
||| surrounding precedence level
prec : PPrec
public export
HasEnv : (Type -> Type) -> Type
HasEnv = MonadReader PrettyEnv
export %inline
ifUnicode : HasEnv m => (uni, asc : Lazy a) -> m a
ifUnicode uni asc = if (!ask).unicode then [|uni|] else [|asc|]
export %inline
parensIfM : HasEnv m => PPrec -> Doc HL -> m (Doc HL)
parensIfM d doc = pure $ parensIf ((!ask).prec > d) doc
export %inline
withPrec : HasEnv m => PPrec -> m a -> m a
withPrec d = local {prec := d}
public export data BinderSort = T | D
export %inline
under : HasEnv m => BinderSort -> Name -> m a -> m a
under T x = local {prec := Outer, tnames $= (x ::)}
under D x = local {prec := Outer, dnames $= (x ::)}
public export
interface PrettyHL a where
prettyM : HasEnv m => a -> m (Doc HL)
export %inline
pretty0M : (PrettyHL a, HasEnv m) => a -> m (Doc HL)
pretty0M = local {prec := Outer} . prettyM
export %inline
pretty0 : PrettyHL a => (unicode : Bool) -> a -> Doc HL
pretty0 unicode x =
let env = MakePrettyEnv {dnames = [], tnames = [], unicode, prec = Outer} in
runReader env $ prettyM x
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"
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 Syntax . text =<< ifUnicode "" "=="
dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun"
annD = hl Syntax . text =<< ifUnicode "" "::"
natD = hl Syntax . text =<< ifUnicode "" "Nat"
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
(forall a. PrettyHL (f a)) => PrettyHL (Exists f) where
prettyM x = prettyM x.snd
prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts ->
List (Doc opts) -> Doc opts
prettyApp ind f args =
ifMultiline
(hsep (f :: args))
(f <++> vsep args <|> vsep (f :: map (indent ind) args))
export
PrettyHL a => PrettyHL (Subset a b) where
prettyM x = prettyM x.fst
export PrettyHL BaseName where prettyM = pure . pretty . baseStr
export PrettyHL Name where prettyM = pure . pretty . toDots
export %inline
prettyStr : PrettyHL a => (unicode : Bool) -> a -> String
prettyStr unicode =
let layout = layoutSmart (MkLayoutOptions (AvailablePerLine 80 0.8)) in
renderString . layout . pretty0 unicode
prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) ->
Eff Pretty (Doc opts)
prettyAppD f args = pure $ prettyApp !(askAt INDENT) f args
export
termHL : HL -> AnsiStyle
termHL Delim = color BrightBlack
termHL TVar = color BrightYellow
termHL TVarErr = color BrightYellow <+> underline
termHL Dim = color BrightGreen <+> bold
termHL DVar = color BrightGreen
termHL DVarErr = color BrightGreen <+> underline
termHL Qty = color BrightMagenta <+> bold
termHL Free = color BrightWhite
termHL Syntax = color BrightCyan
escapeString : String -> String
escapeString = concatMap esc1 . unpack where
esc1 : Char -> String
esc1 '"' = #"\""#
esc1 '\\' = #"\\"#
esc1 '\n' = #"\n"#
esc1 c = singleton c
export %inline
prettyTerm : PrettyOpts -> PrettyHL a => a -> IO Unit
prettyTerm opts x =
let reann = if opts.color then map termHL else unAnnotate in
Terminal.putDoc $ reann $ pretty0 opts.unicode x
export
quoteTag : String -> String
quoteTag tag =
if isName tag then tag else
"\"" ++ escapeString tag ++ "\""
export %inline
prettyTermDef : PrettyHL a => a -> IO Unit
prettyTermDef = prettyTerm defPrettyOpts
export
prettyBounds : {opts : LayoutOpts} -> Bounds -> Eff Pretty (Doc opts)
prettyBounds (MkBounds l1 c1 l2 c2) =
hcat <$> sequence
[hl TVar $ text $ show l1, colonD,
hl DVar $ text $ show c1, hl Delim "-",
hl TVar $ text $ show l2, colonD,
hl DVar $ text $ show c2, colonD]
export
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]
infixr 6 <//>
export %inline
(<//>) : Doc a -> Doc a -> Doc a
a <//> b = sep [a, b]
export
prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts)
prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag
infixr 6 </>
export %inline
(</>) : Doc a -> Doc a -> Doc a
a </> b = cat [a, b]
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]

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,5 +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.Universe
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,94 +1,35 @@
module Quox.Syntax.Dim
import Quox.Syntax.Var
import Quox.Loc
import Quox.Name
import Quox.Var
import Quox.Syntax.Subst
import Quox.Pretty
import Quox.Context
import Quox.PrettyValExtra
import Decidable.Equality
import Control.Function
import Generics.Derive
import Derive.Prelude
%default total
%language ElabReflection
%hide SOP.from; %hide SOP.to
public export
data DimConst = Zero | One
%name DimConst e
%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal]
%runElab derive "DimConst" [Generic, Meta, Eq, Ord, DecEq, Show]
||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`.
public export
data Dim : Nat -> Type where
K : DimConst -> Dim d
B : Var d -> Dim d
%name Dim.Dim p, q
private %inline
drepr : Dim n -> Either DimConst (Var n)
drepr (K k) = Left k
drepr (B x) = Right x
export Eq (Dim n) where (==) = (==) `on` drepr
export Ord (Dim n) where compare = compare `on` drepr
export
Show (Dim n) where
show (K k) = showCon App "K" $ show k
show (B i) = showCon App "B" $ show i
export
PrettyHL DimConst where
prettyM Zero = hl Dim <$> ifUnicode "𝟬" "0"
prettyM One = hl Dim <$> ifUnicode "𝟭" "1"
export
PrettyHL (Dim n) where
prettyM (K e) = prettyM e
prettyM (B i) = prettyVar DVar DVarErr (!ask).dnames i
public export %inline
toConst : Dim 0 -> DimConst
toConst (K e) = e
public export
DSubst : Nat -> Nat -> Type
DSubst = Subst Dim
export %inline
prettyDSubst : Pretty.HasEnv m => DSubst from to -> m (Doc HL)
prettyDSubst th =
prettySubstM prettyM (!ask).dnames DVar
!(ifUnicode "" "<") !(ifUnicode "" ">") th
export FromVar Dim where fromVar = B
export
CanShift Dim where
K e // _ = K e
B i // by = B (i // by)
export
CanSubst Dim Dim where
K e // _ = K e
B i // th = th !! i
ends : Lazy a -> Lazy a -> DimConst -> a
ends l r Zero = l
ends l r One = r
export Uninhabited (Zero = One) where uninhabited _ impossible
export Uninhabited (One = Zero) where uninhabited _ impossible
export Uninhabited (B i = K e) where uninhabited _ impossible
export Uninhabited (K e = B i) where uninhabited _ impossible
public export %inline Injective Dim.B where injective Refl = Refl
public export %inline Injective Dim.K where injective Refl = Refl
public export
DecEq DimConst where
decEq Zero Zero = Yes Refl
@ -96,13 +37,104 @@ DecEq DimConst where
decEq One Zero = No absurd
decEq One One = Yes Refl
public export
DecEq (Dim d) where
decEq (K e) (K f) with (decEq e f)
_ | Yes prf = Yes $ cong K prf
_ | No contra = No $ contra . injective
decEq (K e) (B j) = No absurd
decEq (B i) (K f) = No absurd
decEq (B i) (B j) with (decEq i j)
_ | Yes prf = Yes $ cong B prf
_ | No contra = No $ contra . injective
data Dim : Nat -> Type where
K : DimConst -> Loc -> Dim d
B : Var d -> Loc -> Dim d
%name Dim.Dim p, q
%runElab deriveIndexed "Dim" [Eq, Ord, Show]
||| `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
export
Located (Dim d) where
(K _ loc).loc = loc
(B _ loc).loc = loc
export
Relocatable (Dim d) where
setLoc loc (K e _) = K e loc
setLoc loc (B i _) = B i loc
export
prettyDimConst : {opts : _} -> DimConst -> Eff Pretty (Doc opts)
prettyDimConst = hl Dim . text . ends "0" "1"
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
toConst : Dim 0 -> DimConst
toConst (K e _) = e
public export
DSubst : Nat -> Nat -> Type
DSubst = Subst Dim
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
CanSubstSelf Dim where
K e loc // _ = K e loc
B i loc // th = getLoc th i loc
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 _
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
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
||| 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 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,9 +1,12 @@
module Quox.Syntax.DimEq
import public Quox.Syntax.Var
import public Quox.Var
import public Quox.Syntax.Dim
import public Quox.Syntax.Subst
import public Quox.Context
import Quox.Pretty
import Quox.Name
import Quox.FreeVars
import Data.Maybe
import Data.Nat
@ -11,7 +14,9 @@ import Data.DPair
import Data.Fun.Graph
import Decidable.Decidable
import Decidable.Equality
import Derive.Prelude
%language ElabReflection
%default total
@ -24,99 +29,155 @@ public export
data DimEq : Nat -> Type where
ZeroIsOne : DimEq d
C : (eqs : DimEq' d) -> DimEq d
%name DimEq eqs
%runElab deriveIndexed "DimEq" [Eq, Ord, Show]
public export
consistent : DimEq d -> Bool
consistent ZeroIsOne = False
consistent (C eqs) = True
public export
data IfConsistent : DimEq d -> Type -> Type where
Nothing : IfConsistent ZeroIsOne a
Just : a -> IfConsistent (C eqs) a
export
Functor (IfConsistent eqs) where
map f Nothing = Nothing
map f (Just x) = Just (f x)
export
Foldable (IfConsistent eqs) where
foldr f z Nothing = z
foldr f z (Just x) = f x z
export
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 eqs act = ifConsistentElse eqs act (pure ())
public export
toMaybe : IfConsistent eqs a -> Maybe a
toMaybe Nothing = Nothing
toMaybe (Just x) = Just x
export
fromGround' : BContext d -> Context' DimConst d -> DimEq' d
fromGround' [<] [<] = [<]
fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc)
export
fromGround : BContext d -> Context' DimConst d -> DimEq d
fromGround = C .: fromGround'
public export %inline
zeroEq : DimEq 0
zeroEq = C [<]
export
public export %inline
new' : {d : Nat} -> DimEq' d
new' {d = 0} = [<]
new' {d = S d} = new' :< Nothing
export %inline
public export %inline
new : {d : Nat} -> DimEq d
new = C new'
private %inline
shiftMay : Maybe (Dim from) -> Shift from to -> Maybe (Dim to)
shiftMay p by = map (// by) p
export %inline
public export %inline
get' : DimEq' d -> Var d -> Maybe (Dim d)
get' = getWith shiftMay
get' = getWith $ \p, by => map (// by) p
private %inline
public export %inline
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 shiftMay
getShift' = getShiftWith $ \p, by => map (// by) p
export %inline
public export %inline
get : DimEq' d -> Dim d -> Dim d
get _ (K e) = K e
get eqs (B i) = fromMaybe (B i) $ get' eqs i
get _ (K e loc) = K e loc
get eqs (B i loc) = getVar eqs i loc
export %inline
public export %inline
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 5 :<?
infixl 7 :<?
export %inline
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
ZeroIsOne :<? d = ZeroIsOne
C eqs :<? d = C $ eqs :< d
C eqs :<? d = C $ eqs :< map (get eqs) d
private %inline
ifVar : Var d -> Dim d -> Maybe (Dim d) -> Maybe (Dim d)
ifVar i p = map $ \q => if isYes $ q `decEq` B i then p else q
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
checkConst : (e, f : DimConst) -> (eqs : Lazy (DimEq' d)) -> DimEq d
checkConst Zero Zero eqs = C eqs
checkConst One One eqs = C eqs
checkConst _ _ _ = ZeroIsOne
checkConst e f eqs = if isYes $ e `decEq` f then C eqs else ZeroIsOne
export
setConst : Var d -> DimConst -> DimEq' d -> DimEq d
setConst VZ e (eqs :< Nothing) = C $ eqs :< Just (K e)
setConst VZ e (eqs :< Just (K f)) = checkConst e f $ eqs :< Just (K f)
setConst VZ e (eqs :< Just (B i)) = setConst i e eqs :<? Just (K e)
setConst (VS i) e (eqs :< p) = setConst i e eqs :<? ifVar i (K e) 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' : (i, j : Var d) -> i `LT` j -> DimEq' d -> DimEq d
setVar' VZ (VS i) LTZ (eqs :< Nothing) =
C $ eqs :< Just (B i)
setVar' VZ (VS i) LTZ (eqs :< Just (K e)) =
setConst i e eqs :<? Just (K e)
setVar' VZ (VS i) LTZ (eqs :< Just (B j)) =
setVar i j eqs :<? Just (B (max i j))
setVar' (VS i) (VS j) (LTS lt) (eqs :< p) =
setVar' i j lt eqs :<? ifVar i (B j) 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 : (i, j : Var d) -> DimEq' d -> DimEq d
setVar i j eqs with (compareP i j)
_ | IsLT lt = setVar' i j lt eqs
setVar i i eqs | IsEQ = C eqs
_ | IsGT gt = setVar' j i gt 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 : (p, q : Dim d) -> DimEq d -> DimEq d
set _ _ ZeroIsOne = ZeroIsOne
set (K e) (K f) (C eqs) = checkConst e f eqs
set (K e) (B i) (C eqs) = setConst i e eqs
set (B i) (K e) (C eqs) = setConst i e eqs
set (B i) (B j) (C eqs) = setVar i j 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
@ -124,25 +185,34 @@ Split : Nat -> Type
Split d = (DimEq' d, DSubst (S d) d)
export %inline
split1 : DimConst -> DimEq' (S d) -> Maybe (Split d)
split1 e eqs = case setConst VZ e 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, K e ::: id)
C (eqs :< _) => Just (eqs, K e loc ::: id)
export %inline
split : DimEq' (S d) -> List (Split d)
split eqs = toList (split1 Zero eqs) <+> toList (split1 One 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' : DimEq' d -> List (DSubst d 0)
splits' [<] = [id]
splits' eqs@(_ :< _) = [th . ph | (eqs', th) <- split eqs, ph <- splits' 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 : DimEq d -> List (DSubst d 0)
splits ZeroIsOne = []
splits (C eqs) = splits' eqs
splits : Loc -> DimEq d -> FreeVars d -> List (DSubst d 0)
splits _ ZeroIsOne _ = []
splits loc (C eqs) fvs = splits' loc eqs fvs
private
@ -157,19 +227,74 @@ 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
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) = rewrite comparePSelf i in 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
-- [todo] "well formed" dimeqs
-- [todo] operations maintain well-formedness
-- [todo] if 'Wf eqs' then 'equal eqs' is an equivalence
-- [todo] 'set' never breaks existing equalities
private %inline
dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec
dimEqPrec vars eqs =
if length vars <= 1 && maybe True null eqs then Arg else Outer
private
prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts))
prettyDVars' = traverse prettyDBind . toSnocList'
export
prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts)
prettyDVars vars =
parensIfM (dimEqPrec vars Nothing) $
fillSeparateTight !commaD $ !(prettyDVars' vars)
private
prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts)
prettyCst dnames p q =
hsep <$> sequence [prettyDim dnames p, cstD, prettyDim dnames q]
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' : 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 : DimEq d -> Bool
wf ZeroIsOne = True
wf (C eqs) = wf' eqs

View File

@ -1,84 +1,154 @@
||| quantities count how many times a bound variable is used [@nuttin; @qtt].
|||
||| i tried grtt [@grtt] for a bit but i think it was more complex than
||| it's worth in a language that has other stuff going on too
module Quox.Syntax.Qty
import Quox.Pretty
import Data.Fin
import Generics.Derive
import Quox.Decidable
import Quox.PrettyValExtra
import Data.DPair
import Derive.Prelude
%default total
%language ElabReflection
||| the possibilities we care about are:
|||
||| - 0: a variable is used only at compile time, not run time
||| - 1: a variable is used exactly once at run time
||| - ω (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, PrettyVal]
%name Qty.Qty pi, rh
%runElab derive "Qty" [Generic, Meta, Eq, Ord, DecEq, Show]
export
PrettyHL Qty where
prettyM pi = hl Qty <$>
case pi of
Zero => ifUnicode "𝟬" "0"
One => ifUnicode "𝟭" "1"
Any => ifUnicode "𝛚" "*"
private
commas : List (Doc HL) -> List (Doc HL)
commas [] = []
commas [x] = [x]
commas (x::xs) = (x <+> hl Delim ",") :: commas xs
export %inline
prettyQtyBinds : Pretty.HasEnv m => List Qty -> m (Doc HL)
prettyQtyBinds =
map ((hl Delim "@" <++>) . align . sep . commas) . traverse pretty0M
prettyQty : {opts : _} -> Qty -> Eff Pretty (Doc opts)
prettyQty Zero = hl Qty $ text "0"
prettyQty One = hl Qty $ text "1"
prettyQty Any = hl Qty =<< ifUnicode (text "ω") (text "#")
||| prints in a form that can be a suffix of "case"
public export
plus : Qty -> Qty -> Qty
plus Zero rh = rh
plus pi Zero = pi
plus _ _ = Any
prettySuffix : {opts : _} -> Qty -> Eff Pretty (Doc opts)
prettySuffix = prettyQty
||| e.g. if in the expression `(s, t)`, the variable `x` is
||| used π times in `s` and ρ times in `t`, then it's used
||| (π + ρ) times in the whole expression
public export
times : Qty -> Qty -> Qty
times Zero _ = Zero
times _ Zero = Zero
times One rh = rh
times pi One = pi
times Any Any = Any
(+) : Qty -> Qty -> Qty
Zero + rh = rh
pi + Zero = pi
_ + _ = Any
infix 6 <=.
||| e.g. if a function `f` uses its argument π times,
||| and `f x` occurs in a σ context, then `x` is used `πσ` times overall
public export
(*) : Qty -> Qty -> Qty
Zero * _ = Zero
_ * Zero = Zero
One * rh = rh
pi * One = pi
Any * Any = Any
||| "π ≤ ρ"
|||
||| if a variable is bound with quantity ρ, then it can be used with a total
||| quantity π as long as π ≤ ρ. for example, an ω variable can be used any
||| number of times, so π ≤ ω for any π.
public export
compat : Qty -> Qty -> Bool
compat pi rh = rh == Any || pi == rh
compat pi Any = True
compat pi rh = pi == rh
||| "π ρ"
|||
||| returns a quantity τ with π ≤ τ and ρ ≤ τ.
||| if π = ρ, then it's that, otherwise it's ω.
public export
lub : Qty -> Qty -> Qty
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
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 σ.
public export
subjMult : SQty -> Qty -> SQty
subjMult _ Zero = SZero
subjMult sg _ = sg
||| it doesn't make much sense for a top level declaration to have a
||| quantity of 1, so the only distinction is whether it is present
||| at runtime at all or not
public export
data GQty = GZero | GAny
%runElab derive "GQty" [Eq, Ord, Show, PrettyVal]
%name GQty rh
public export
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 GZero = SZero
globalToSubj GAny = SOne
public export
interface IsQty q where
zero, one : q
(+), (*) : q -> q -> q
(<=.) : q -> q -> Bool
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
IsQty Qty where
zero = Zero; one = One
(+) = plus; (*) = times
(<=.) = compat
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
data IsSubj : Qty -> Type where
SZero : IsSubj Zero
SOne : IsSubj One
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
export Uninhabited (IsSubj Any) where uninhabited _ impossible
public export
data IsGlobal : Qty -> Type where
GZero : IsGlobal Zero
GAny : IsGlobal Any
namespace SQty
public export %inline
(.qty) : SQty -> Qty
(SZero).qty = Zero
(SOne).qty = One
export Uninhabited (IsGlobal One) where uninhabited _ impossible
namespace GQty
public export %inline
(.qty) : GQty -> Qty
(GZero).qty = Zero
(GAny).qty = Any

View File

@ -1,17 +1,18 @@
module Quox.Syntax.Shift
import public Quox.Syntax.Var
import Quox.Pretty
import public Quox.Var
import Data.Nat
import Data.So
import Data.Singleton
import Syntax.PreorderReasoning
%default total
||| represents the difference between a smaller scope and a larger one.
public export
data Shift : (0 from, to : Nat) -> Type where
data Shift : (from, to : Nat) -> Type where
SZ : Shift from from
SS : Shift from to -> Shift from (S to)
%name Shift by, bz
@ -35,20 +36,28 @@ public export
data Eqv : Shift from1 to1 -> Shift from2 to2 -> Type where
EqSZ : SZ `Eqv` SZ
EqSS : by `Eqv` bz -> SS by `Eqv` SS bz
%name Eqv e
%name Shift.Eqv e
using (by : Shift from to, bz : Shift from to)
||| two equivalent shifts are equal if they have the same indices.
export
0 fromEqv : by `Eqv` bz -> by = bz
fromEqv EqSZ = Refl
fromEqv (EqSS e) = cong SS $ fromEqv e
||| two equal shifts are equivalent.
export
0 toEqv : by = bz -> by `Eqv` bz
toEqv Refl {by = SZ} = EqSZ
toEqv Refl {by = (SS by)} = EqSS $ toEqv Refl
||| two equivalent shifts are equal if they have the same indices.
export
0 fromEqv : by `Eqv` bz -> by = bz
fromEqv EqSZ = Refl
fromEqv (EqSS e) = cong SS $ fromEqv e
||| two equal shifts are equivalent.
export
0 toEqv : by = bz -> by `Eqv` bz
toEqv Refl {by = SZ} = EqSZ
toEqv Refl {by = (SS by)} = EqSS $ toEqv Refl
cmpLen : Shift from1 to -> Shift from2 to -> Either Ordering (from1 = from2)
cmpLen SZ SZ = Right Refl
cmpLen SZ (SS by) = Left LT
cmpLen (SS by) SZ = Left GT
cmpLen (SS by) (SS bz) = cmpLen by bz
export
0 shiftDiff : (by : Shift from to) -> to = by.nat + from
@ -110,7 +119,52 @@ export
ssDownEqv SZ = EqSS EqSZ
ssDownEqv (SS by) = EqSS $ ssDownEqv by
%transform "Shift.ssDown" ssDown by = believe_me (SS by)
private %inline
ssDownViaNat : Shift (S from) to -> Shift from to
ssDownViaNat by =
rewrite shiftDiff by in
rewrite sym $ plusSuccRightSucc by.nat from in
fromNat $ S by.nat
%transform "Shift.ssDown" ssDown = ssDownViaNat
public export
weak : (s : Nat) -> Shift from to -> Shift (s + from) (s + to)
weak s SZ = SZ
weak s (SS by) {to = S to} =
rewrite sym $ plusSuccRightSucc s to in
SS $ weak s by
private
weakViaNat : (s : Nat) -> Shift from to -> Shift (s + from) (s + to)
weakViaNat s by =
rewrite shiftDiff by in
rewrite plusAssociative s by.nat from in
rewrite plusCommutative s by.nat in
rewrite sym $ plusAssociative by.nat s from in
fromNat by.nat
%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
@ -118,12 +172,12 @@ shift : Shift from to -> Var from -> Var to
shift SZ i = i
shift (SS by) i = VS $ shift by i
private
private %inline
shiftViaNat' : (by : Shift from to) -> (i : Var from) ->
(0 p : by.nat + i.nat `LT` to) -> Var to
shiftViaNat' by i p = V $ by.nat + i.nat
private
private %inline
shiftViaNat : Shift from to -> Var from -> Var to
shiftViaNat by i = shiftViaNat' by i $ shiftVarLT by i
@ -137,7 +191,6 @@ shiftViaNatCorrect (SS by) i (LTESucc p) = cong VS $ shiftViaNatCorrect by i p
%transform "Shift.shift" shift = shiftViaNat
infixl 9 .
public export
(.) : Shift from mid -> Shift mid to -> Shift from to
by . SZ = by
@ -146,22 +199,19 @@ 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 =
shiftDiff bz >>>
cong (bz.nat +) (shiftDiff by) >>>
plusAssociative bz.nat by.nat from >>>
cong (+ from) (plusCommutative bz.nat by.nat)
where
infixr 0 >>>
0 (>>>) : a = b -> b = c -> a = c
x >>> y = trans x y
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
private %inline
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
Shift from (by.nat + bz.nat + from)
compViaNat' by bz = fromNat $ by.nat + bz.nat
private
private %inline
compViaNat : (by : Shift from mid) -> (bz : Shift mid to) -> Shift from to
compViaNat by bz = rewrite compNatProof by bz in compViaNat' by bz
@ -177,35 +227,18 @@ compViaNatCorrect by (SS bz) =
%transform "Shift.(.)" Shift.(.) = compViaNat
||| `prettyShift bnd unicode prec by` pretty-prints the shift `by`, with the
||| following arguments:
|||
||| * `by : Shift from to`
||| * `bnd : HL` is the highlight used for bound variables of this kind
||| * `unicode : Bool` is whether to use unicode characters in the output
||| * `prec : PPrec` is the surrounding precedence level
export
prettyShift : Pretty.HasEnv m => (bnd : HL) -> Shift from to -> m (Doc HL)
prettyShift bnd by =
parensIfM Outer $ hsep $
[hl bnd !(ifUnicode "𝑖" "i"), hl Delim !(ifUnicode "" ":="),
hl bnd $ !(ifUnicode "𝑖+" "i+") <+> pretty by.nat]
||| prints using the `TVar` highlight for variables
export PrettyHL (Shift from to) where prettyM = prettyShift TVar
infixl 8 //
public export
interface CanShift f where
(//) : f from -> Shift from to -> f to
export CanShift Var where i // by = shift by i
export %inline
CanShift Var where i // by = shift by i
namespace CanShift
public export
public export %inline
[Map] (Functor f, CanShift tm) => CanShift (f . tm) where
x // by = map (// by) x
public export
public export %inline
[Const] CanShift (\_ => a) where x // _ = x

View File

@ -1,22 +1,31 @@
module Quox.Syntax.Subst
import public Quox.Syntax.Shift
import Quox.Syntax.Var
import Quox.Var
import Quox.Name
import Quox.Pretty
import Data.Nat
import Data.List
import Data.SnocVect
import Data.Singleton
import Derive.Prelude
%default total
%language ElabReflection
infixr 5 :::
public export
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
infixr 7 !:::
||| in case the automatic laziness insertion gets confused
public export
(!:::) : env to -> Subst env from to -> Subst env (S from) to
t !::: ts = t ::: ts
private
Repr : (Nat -> Type) -> Nat -> Type
@ -28,30 +37,26 @@ 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 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
infixl 8 //
public export
interface FromVar env => CanSubst env term where
(//) : term from -> Lazy (Subst env from to) -> term to
public export
CanSubst1 : (Nat -> Type) -> Type
CanSubst1 f = CanSubst f f
infixl 8 !!
public export
(!!) : FromVar term => Subst term from to -> Var from -> term to
(Shift by) !! i = fromVar $ shift by i
(t ::: th) !! VZ = t
(t ::: th) !! (VS i) = th !! i
interface FromVar term => CanSubstSelf term where
(//) : term from -> Lazy (Subst term from to) -> term to
public export
CanSubst Var Var where
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
CanSubstSelf Var where
i // Shift by = shift by i
VZ // (t ::: th) = t
VS i // (t ::: th) = i // th
@ -61,10 +66,13 @@ public export %inline
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
infixl 9 .
public export
(.) : CanSubst1 f => Subst f from mid -> Subst f mid to -> Subst f from to
(.) : 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
@ -74,6 +82,13 @@ 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
@ -81,8 +96,18 @@ map f (t ::: th) = f t ::: map f th
public export %inline
push : CanSubst1 f => Subst f from to -> Subst f (S from) (S to)
push th = fromVar VZ ::: (th . shift 1)
push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to)
push loc th = fromVarLoc VZ loc ::: (th . shift 1)
-- [fixme] a better way to do this?
public export
pushN : CanSubstSelf f => (s : Nat) -> 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
@ -90,40 +115,55 @@ 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 = x ::: id
one x = fromSnocVect [< x]
||| `prettySubst pr names bnd op cl th` pretty-prints the substitution `th`,
||| with the following arguments:
|||
||| * `th : Subst f from to`
||| * `pr : f to -> m (Doc HL)` prints a single element
||| * `names : List Name` is a list of known bound var names
||| * `bnd : HL` is the highlight to use for bound variables being subsituted
||| * `op, cl : Doc HL` are the opening and closing brackets
export
prettySubstM : Pretty.HasEnv m =>
(pr : f to -> m (Doc HL)) ->
(names : List Name) -> (bnd : HL) -> (op, cl : Doc HL) ->
Subst f from to -> m (Doc HL)
prettySubstM pr names bnd op cl th =
encloseSep (hl Delim op) (hl Delim cl) (hl Delim "; ") <$>
withPrec Outer (go 0 th)
where
go1 : Nat -> f to -> m (Doc HL)
go1 i t = pure $ hang 2 $ sep
[hsep [!(prettyVar' bnd bnd names i),
hl Delim !(ifUnicode "" ":=")],
!(pr t)]
getFrom : {to : Nat} -> Subst _ from to -> Singleton from
getFrom (Shift by) = getFrom by
getFrom (t ::: th) = [|S $ getFrom th|]
go : forall from. Nat -> Subst f from to -> m (List (Doc HL))
go _ (Shift SZ) = pure []
go _ (Shift by) = [|pure (prettyShift bnd by)|]
go i (t ::: th) = [|go1 i t :: go (S i) th|]
||| prints with [square brackets] and the `TVar` highlight for variables
||| 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
PrettyHL (f to) => PrettyHL (Subst f from to) where
prettyM th = prettySubstM prettyM (!ask).tnames TVar "[" "]" th
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 : Lazy (Subst env from n)
export
(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 && s1 == s2
export
(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, s1) (t2, s2)
export %hint
ShowWithSubst : (Show (env n), forall n. Show (tm n)) =>
Show (WithSubst tm env n)
ShowWithSubst = deriveShow

View File

@ -1,7 +1,6 @@
module Quox.Syntax.Term
import public Quox.Syntax.Term.Base
import public Quox.Syntax.Term.Split
import public Quox.Syntax.Term.Subst
import public Quox.Syntax.Term.Reduce
import public Quox.Syntax.Term.Pretty
import public Quox.Syntax.Term.Tighten

View File

@ -1,13 +1,15 @@
module Quox.Syntax.Term.Base
import public Quox.Syntax.Var
import public Quox.Var
import public Quox.Scoped
import public Quox.Syntax.Shift
import public Quox.Syntax.Subst
import public Quox.Syntax.Universe
import public Quox.Syntax.Qty
import public Quox.Syntax.Dim
import public Quox.Syntax.Term.TyConKind
import public Quox.Name
import public Quox.OPE
import public Quox.Loc
import public Quox.Context
import Quox.Pretty
@ -17,94 +19,430 @@ import Data.Maybe
import Data.Nat
import public Data.So
import Data.String
import Data.Vect
import public Data.SortedMap
import public Data.SortedMap.Dependent
import public Data.SortedSet
import Derive.Prelude
%default total
%language ElabReflection
%hide TT.Name
public export
TermLike : Type
TermLike = Nat -> Nat -> Type
public export
TSubstLike : Type
TSubstLike = Nat -> Nat -> Nat -> Type
public export
Universe : Type
Universe = Nat
public export
TagVal : Type
TagVal = String
infixl 8 :#
infixl 9 :@
infixl 9 :@, :%
mutual
public export
TSubst : Nat -> Nat -> Nat -> Type
TSubst d = Subst (\n => Elim d n)
TSubst : TSubstLike
TSubst d = Subst $ \n => Elim d n
||| first argument `d` is dimension scope size, second `n` is term scope size
||| 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) -> Term d n
TYPE : (l : Universe) -> (loc : Loc) -> Term d n
||| IO state token. this is a builtin because otherwise #[main] being a
||| builtin makes no sense
IOState : (loc : Loc) -> Term d n
||| function type
Pi : (qty : Qty) -> (x : Name) ->
(arg : Term d n) -> (res : ScopeTerm d n) -> Term d n
Pi : (qty : Qty) -> (arg : Term d n) ->
(res : ScopeTerm d n) -> (loc : Loc) -> Term d n
||| function term
Lam : (x : Name) -> (body : ScopeTerm d n) -> Term d n
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 : (tm : Term d from) -> (th : Lazy (TSubst d from to)) -> Term d to
CloT : WithSubst (Term d) (Elim d) n -> Term d n
||| dimension closure/suspended substitution
DCloT : (tm : Term dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Term dto n
DCloT : WithSubst (\d => Term d n) Dim d -> Term d n
%name Term s, t, r
||| first argument `d` is dimension scope size, second `n` is term scope size
public export
data Elim : (d, n : Nat) -> Type where
||| free variable
F : (x : Name) -> Elim d n
||| 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) -> Elim d n
B : (i : Var n) -> (loc : Loc) -> Elim d n
||| term application
(:@) : (fun : Elim d n) -> (arg : Term d n) -> Elim d n
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
(:#) : (tm, ty : Term d n) -> Elim d n
Ann : (tm, ty : Term d n) -> (loc : Loc) -> Elim d n
||| coerce a value along a type equality, or show its coherence
||| [@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 : (el : Elim d from) -> (th : Lazy (TSubst d from to)) -> Elim d to
CloE : WithSubst (Elim d) (Elim d) n -> Elim d n
||| dimension closure/suspended substitution
DCloE : (el : Elim dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Elim dto n
DCloE : WithSubst (\d => Elim d n) Dim d -> Elim d n
%name Elim e, f
||| a scope with one more bound variable
public export
data ScopeTerm : (d, n : Nat) -> Type where
||| variable is used
TUsed : (body : Term d (S n)) -> ScopeTerm d n
||| variable is unused
TUnused : (body : Term d n) -> ScopeTerm d n
CaseEnumArms : TermLike
CaseEnumArms d n = SortedMap TagVal (Term d n)
||| a scope with one more bound dimension variable
public export
data DScopeTerm : (d, n : Nat) -> Type where
||| variable is used
DUsed : (body : Term (S d) n) -> DScopeTerm d n
||| variable is unused
DUnused : (body : Term d n) -> DScopeTerm d n
TypeCaseArms : TermLike
TypeCaseArms d n = SortedDMap TyConKind (\k => TypeCaseArmBody k d n)
%name Term s, t, r
%name Elim e, f
%name ScopeTerm body
%name DScopeTerm body
public export
TypeCaseArm : TermLike
TypeCaseArm d n = (k ** TypeCaseArmBody k d n)
public export
TypeCaseArmBody : TyConKind -> TermLike
TypeCaseArmBody k = ScopeTermN (arity k)
public export
ScopeTermN, DScopeTermN : Nat -> TermLike
ScopeTermN s d n = Scoped s (Term d) n
DScopeTermN s d n = Scoped s (\d => Term d n) d
public export
ScopeTerm, DScopeTerm : TermLike
ScopeTerm = ScopeTermN 1
DScopeTerm = DScopeTermN 1
mutual
export %hint
EqTerm : Eq (Term d n)
EqTerm = assert_total {a = Eq (Term d n)} deriveEq
export %hint
EqElim : Eq (Elim d n)
EqElim = assert_total {a = Eq (Elim d n)} deriveEq
mutual
export %hint
ShowTerm : Show (Term d n)
ShowTerm = assert_total {a = Show (Term d n)} deriveShow
export %hint
ShowElim : Show (Elim d n)
ShowElim = assert_total {a = Show (Elim d n)} deriveShow
export
Located (Elim d n) where
(F _ _ loc).loc = loc
(B _ loc).loc = loc
(App _ _ loc).loc = loc
(CasePair _ _ _ _ loc).loc = loc
(Fst _ loc).loc = loc
(Snd _ loc).loc = loc
(CaseEnum _ _ _ _ loc).loc = loc
(CaseNat _ _ _ _ _ _ loc).loc = loc
(CaseBox _ _ _ _ loc).loc = loc
(DApp _ _ loc).loc = loc
(Ann _ _ loc).loc = loc
(Coe _ _ _ _ loc).loc = loc
(Comp _ _ _ _ _ _ _ loc).loc = loc
(TypeCase _ _ _ _ loc).loc = loc
(CloE (Sub e _)).loc = e.loc
(DCloE (Sub e _)).loc = e.loc
export
Located (Term d n) where
(TYPE _ loc).loc = loc
(IOState loc).loc = loc
(Pi _ _ _ loc).loc = loc
(Lam _ loc).loc = loc
(Sig _ _ loc).loc = loc
(Pair _ _ loc).loc = loc
(Enum _ loc).loc = loc
(Tag _ loc).loc = loc
(Eq _ _ _ loc).loc = loc
(DLam _ loc).loc = loc
(NAT loc).loc = loc
(Nat _ loc).loc = loc
(STRING loc).loc = loc
(Str _ loc).loc = loc
(Succ _ loc).loc = loc
(BOX _ _ loc).loc = loc
(Box _ loc).loc = loc
(Let _ _ _ loc).loc = loc
(E e).loc = e.loc
(CloT (Sub t _)).loc = t.loc
(DCloT (Sub t _)).loc = t.loc
export
Located1 f => Located (ScopedBody s f n) where
(Y t).loc = t.loc
(N t).loc = t.loc
export
Located1 f => Located (Scoped s f n) where
t.loc = t.body.loc
export
Relocatable (Elim d n) where
setLoc loc (F x u _) = F x u loc
setLoc loc (B i _) = B i loc
setLoc loc (App fun arg _) = App fun arg loc
setLoc loc (CasePair qty pair ret body _) =
CasePair qty pair ret body loc
setLoc loc (Fst pair _) = Fst pair loc
setLoc loc (Snd pair _) = Fst pair loc
setLoc loc (CaseEnum qty tag ret arms _) =
CaseEnum qty tag ret arms loc
setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
CaseNat qty qtyIH nat ret zero succ loc
setLoc loc (CaseBox qty box ret body _) =
CaseBox qty box ret body loc
setLoc loc (DApp fun arg _) =
DApp fun arg loc
setLoc loc (Ann tm ty _) =
Ann tm ty loc
setLoc loc (Coe ty p q val _) =
Coe ty p q val loc
setLoc loc (Comp ty p q val r zero one _) =
Comp ty p q val r zero one loc
setLoc loc (TypeCase ty ret arms def _) =
TypeCase ty ret arms def loc
setLoc loc (CloE (Sub term subst)) =
CloE $ Sub (setLoc loc term) subst
setLoc loc (DCloE (Sub term subst)) =
DCloE $ Sub (setLoc loc term) subst
export
Relocatable (Term d n) where
setLoc loc (TYPE l _) = TYPE l loc
setLoc loc (IOState _) = IOState loc
setLoc loc (Pi qty arg res _) = Pi qty arg res loc
setLoc loc (Lam body _) = Lam body loc
setLoc loc (Sig fst snd _) = Sig fst snd loc
setLoc loc (Pair fst snd _) = Pair fst snd loc
setLoc loc (Enum cases _) = Enum cases loc
setLoc loc (Tag tag _) = Tag tag loc
setLoc loc (Eq ty l r _) = Eq ty l r loc
setLoc loc (DLam body _) = DLam body loc
setLoc loc (NAT _) = NAT loc
setLoc loc (Nat n _) = Nat n loc
setLoc loc (Succ p _) = Succ p loc
setLoc loc (STRING _) = STRING loc
setLoc loc (Str s _) = Str s loc
setLoc loc (BOX qty ty _) = BOX qty ty loc
setLoc loc (Box val _) = Box val loc
setLoc loc (Let qty rhs body _) = Let qty rhs body loc
setLoc loc (E e) = E $ setLoc loc e
setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
export
Relocatable1 f => Relocatable (ScopedBody s f n) where
setLoc loc (Y body) = Y $ setLoc loc body
setLoc loc (N body) = N $ setLoc loc body
export
Relocatable1 f => Relocatable (Scoped s f n) where
setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)
||| 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
Arr : (qty : Qty) -> (arg, res : Term d n) -> Term d n
Arr {qty, arg, res} = Pi {qty, x = "_", arg, res = TUnused res}
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 -> Term d n
FT = E . F
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) => Elim d n
BV i = B $ V i
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) => Term d n
BVT i = E $ BV i
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

@ -1,86 +1,623 @@
module Quox.Syntax.Term.Pretty
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Split
import Quox.Syntax.Term.Subst
import Quox.Context
import Quox.Pretty
import Data.Vect
import Derive.Prelude
%default total
%language ElabReflection
parameters {auto _ : Pretty.HasEnv m}
private %inline arrowD : m (Doc HL)
arrowD = hlF Syntax $ ifUnicode "" "->"
export
prettyUniverse : {opts : _} -> Universe -> Eff Pretty (Doc opts)
prettyUniverse = hl Universe . text . show
private %inline lamD : m (Doc HL)
lamD = hlF Syntax $ ifUnicode "λ" "fun"
private %inline annD : m (Doc HL)
annD = hlF Syntax $ ifUnicode "" "::"
export
prettyTerm : {opts : _} -> BContext d -> BContext n -> Term d n ->
Eff Pretty (Doc opts)
private %inline typeD : Doc HL
typeD = hl Syntax "Type"
export
prettyElim : {opts : _} -> BContext d -> BContext n -> Elim d n ->
Eff Pretty (Doc opts)
private %inline colonD : Doc HL
colonD = hl Syntax ":"
private
BTelescope : Nat -> Nat -> Type
BTelescope = Telescope' BindName
mutual
export covering
PrettyHL (Term d n) where
prettyM (TYPE l) =
parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l)
prettyM (Pi qty x s t) =
parensIfM Outer $ hang 2 $
!(prettyBinder [qty] x s) <++> !arrowD
<//> !(under T x $ prettyM t)
prettyM (Lam x t) =
parensIfM Outer $
sep [!lamD, hl TVar !(prettyM x), !arrowD]
<//> !(under T x $ prettyM t)
prettyM (E e) =
pure $ hl Delim "[" <+> !(prettyM e) <+> hl Delim "]"
prettyM (CloT s th) =
parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM s) </> prettyTSubst th|]
prettyM (DCloT s th) =
parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM s) </> prettyDSubst th|]
export covering
PrettyHL (Elim d n) where
prettyM (F x) =
hl' Free <$> prettyM x
prettyM (B i) =
prettyVar TVar TVarErr (!ask).tnames i
prettyM (e :@ s) =
let GotArgs f args _ = getArgs' e [s] in
parensIfM App =<< withPrec Arg
[|prettyM f <//> (align . sep <$> traverse prettyM args)|]
prettyM (s :# a) =
parensIfM Ann $ hang 2 $
!(withPrec AnnL $ prettyM s) <++> !annD
<//> !(withPrec Ann $ prettyM a)
prettyM (CloE e th) =
parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM e) </> prettyTSubst th|]
prettyM (DCloE e th) =
parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM e) </> prettyDSubst th|]
private
superscript : String -> String
superscript = pack . map sup . unpack where
sup : Char -> Char
sup c = case c of
'0' => ''; '1' => '¹'; '2' => '²'; '3' => '³'; '4' => ''
'5' => ''; '6' => ''; '7' => ''; '8' => ''; '9' => ''; _ => c
export covering
PrettyHL (ScopeTerm d n) where
prettyM body = prettyM $ fromScopeTerm body
export covering
prettyTSubst : Pretty.HasEnv m => TSubst d from to -> m (Doc HL)
prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s
private
PiBind : Nat -> Nat -> Type
PiBind d n = (Qty, BindName, Term d n)
export covering
prettyBinder : Pretty.HasEnv m => List Qty -> Name -> Term d n -> m (Doc HL)
prettyBinder pis x a =
pure $ parens $ hang 2 $
hsep [hl TVar !(prettyM x),
sep [!(prettyQtyBinds pis),
hsep [colonD, !(withPrec Outer $ prettyM a)]]]
private
pbname : PiBind d n -> BindName
pbname (_, x, _) = x
private
record SplitPi d n where
constructor MkSplitPi
{0 inner : Nat}
binds : Telescope (PiBind d) n inner
cod : Term d inner
private
splitPi : Telescope (PiBind d) n n' -> Term d n' -> SplitPi d n
splitPi binds (Pi qty arg res _) =
splitPi (binds :< (qty, res.name, arg)) $
assert_smaller res $ pushSubsts' res.term
splitPi binds cod = MkSplitPi {binds, cod}
private
prettyPiBind1 : {opts : _} ->
Qty -> BindName -> BContext d -> BContext n -> Term d n ->
Eff Pretty (Doc opts)
prettyPiBind1 pi (BN Unused _) dnames tnames s =
hcat <$> sequence
[prettyQty pi, dotD,
withPrec Arg $ assert_total prettyTerm dnames tnames s]
prettyPiBind1 pi x dnames tnames s = hcat <$> sequence
[prettyQty pi, dotD,
hl Delim $ text "(",
hsep <$> sequence
[prettyTBind x, hl Delim $ text ":",
withPrec Outer $ assert_total prettyTerm dnames tnames s],
hl Delim $ text ")"]
private
prettyPiBinds : {opts : _} ->
BContext d -> BContext n ->
Telescope (PiBind d) n n' ->
Eff Pretty (SnocList (Doc opts))
prettyPiBinds _ _ [<] = pure [<]
prettyPiBinds dnames tnames (binds :< (q, x, t)) =
let tnames' = tnames . map pbname binds in
[|prettyPiBinds dnames tnames binds :<
prettyPiBind1 q x dnames tnames' t|]
private
SigBind : Nat -> Nat -> Type
SigBind d n = (BindName, Term d n)
private
record SplitSig d n where
constructor MkSplitSig
{0 inner : Nat}
binds : Telescope (SigBind d) n inner
last : Term d inner
private
splitSig : Telescope (SigBind d) n n' -> Term d n' -> SplitSig d n
splitSig binds (Sig fst snd _) =
splitSig (binds :< (snd.name, fst)) $
assert_smaller snd $ pushSubsts' snd.term
splitSig binds last = MkSplitSig {binds, last}
private
prettySigBind1 : {opts : _} ->
BindName -> BContext d -> BContext n -> Term d n ->
Eff Pretty (Doc opts)
prettySigBind1 (BN Unused _) dnames tnames s =
withPrec InTimes $ assert_total prettyTerm dnames tnames s
prettySigBind1 x dnames tnames s = hcat <$> sequence
[hl Delim $ text "(",
hsep <$> sequence
[prettyTBind x, hl Delim $ text ":",
withPrec Outer $ assert_total prettyTerm dnames tnames s],
hl Delim $ text ")"]
private
prettySigBinds : {opts : _} ->
BContext d -> BContext n ->
Telescope (SigBind d) n n' ->
Eff Pretty (SnocList (Doc opts))
prettySigBinds _ _ [<] = pure [<]
prettySigBinds dnames tnames (binds :< (x, t)) =
let tnames' = tnames . map fst binds in
[|prettySigBinds dnames tnames binds :<
prettySigBind1 x dnames tnames' t|]
private
prettyTypeLine : {opts : _} ->
BContext d -> BContext n ->
DScopeTerm d n ->
Eff Pretty (Doc opts)
prettyTypeLine dnames tnames (S _ (N body)) =
withPrec Arg (prettyTerm dnames tnames body)
prettyTypeLine dnames tnames (S [< i] (Y body)) =
parens =<< do
i' <- prettyDBind i
ty' <- withPrec Outer $ prettyTerm (dnames :< i) tnames body
pure $ sep [hsep [i', !darrowD], ty']
private
data NameSort = T | D
%runElab derive "NameSort" [Eq]
private
NameChunks : Type
NameChunks = SnocList (NameSort, SnocList BindName)
private
record SplitLams d n where
constructor MkSplitLams
{0 dinner, ninner : Nat}
dnames : BTelescope d dinner
tnames : BTelescope n ninner
chunks : NameChunks
body : Term dinner ninner
private
splitLams : Term d n -> SplitLams d n
splitLams s = go [<] [<] [<] (pushSubsts' s)
where
push : NameSort -> BindName -> NameChunks -> NameChunks
push s y [<] = [< (s, [< y])]
push s y (xss :< (s', xs)) =
if s == s' then xss :< (s', xs :< y)
else xss :< (s', xs) :< (s, [< y])
go : BTelescope d d' -> BTelescope n n' ->
SnocList (NameSort, SnocList BindName) ->
Term d' n' -> SplitLams d n
go dnames tnames chunks (Lam b _) =
go dnames (tnames :< b.name) (push T b.name chunks) $
assert_smaller b $ pushSubsts' b.term
go dnames tnames chunks (DLam b _) =
go (dnames :< b.name) tnames (push D b.name chunks) $
assert_smaller b $ pushSubsts' b.term
go dnames tnames chunks s =
MkSplitLams dnames tnames chunks s
private
splitTuple : SnocList (Term d n) -> Term d n -> SnocList (Term d n)
splitTuple ss p@(Pair t1 t2 _) =
splitTuple (ss :< t1) $ assert_smaller p $ pushSubsts' t2
splitTuple ss t = ss :< t
private
prettyTArg : {opts : _} -> BContext d -> BContext n ->
Term d n -> Eff Pretty (Doc opts)
prettyTArg dnames tnames s =
withPrec Arg $ assert_total prettyTerm dnames tnames s
private
prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts)
prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|]
private
splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n)))
splitApps e = go [] (pushSubsts' e)
where
go : List (Either (Dim d) (Term d n)) -> Elim d n ->
(Elim d n, List (Either (Dim d) (Term d n)))
go xs e@(App f s _) =
go (Right s :: xs) $ assert_smaller e $ pushSubsts' f
go xs e@(DApp f p _) =
go (Left p :: xs) $ assert_smaller e $ pushSubsts' f
go xs s = (s, xs)
private
prettyDTApps : {opts : _} ->
BContext d -> BContext n ->
Elim d n -> List (Either (Dim d) (Term d n)) ->
Eff Pretty (Doc opts)
prettyDTApps dnames tnames f xs = do
f <- withPrec Arg $ assert_total prettyElim dnames tnames f
xs <- for xs $ either (prettyDArg dnames) (prettyTArg dnames tnames)
parensIfM App =<< prettyAppD f xs
private
record CaseArm opts d n where
constructor MkCaseArm
pat : Doc opts
dbinds : BTelescope d dinner -- 🍴
tbinds : BTelescope n ninner
body : Term dinner ninner
parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n)
private
prettyCaseArm : CaseArm opts d n -> Eff Pretty (Doc opts)
prettyCaseArm (MkCaseArm pat dbinds tbinds body) = do
body <- withPrec Outer $ assert_total
prettyTerm (dnames . dbinds) (tnames . tbinds) body
header <- (pat <++>) <$> darrowD
pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)])
private
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)
prettyCompPat e x = [|prettyDimConst e <++> prettyDBind x|]
private
prettyCompArm : {opts : _} -> BContext d -> BContext n ->
DimConst -> DScopeTerm d n -> Eff Pretty (Doc opts)
prettyCompArm dnames tnames e s = prettyCaseArm dnames tnames $
MkCaseArm !(prettyCompPat e s.name) [< s.name] [<] s.term
private
layoutComp : {opts : _} ->
(typq : List (Doc opts)) -> (val, r : Doc opts) ->
(arms : List (Doc opts)) -> Eff Pretty (Doc opts)
layoutComp typq val r arms = do
comp <- compD; lb <- hl Delim "{"; rb <- hl Delim "}"
ind <- askAt INDENT
pure $ ifMultiline
(hsep $ concat {t = List} [[comp], typq, [val, r, lb], arms, [rb]]) $
(comp <++>
vsep [sep typq, val, r <++> lb, indent ind $ vsep arms, rb]) <|>
(vsep $ (comp ::) $ map (indent ind) $ concat {t = List}
[typq, [val, r <++> lb], map (indent ind) arms, [rb]])
export
prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts)
prettyEnum cases =
tightBraces =<<
fillSeparateTight !commaD <$>
traverse (hl Constant . Doc.text . quoteTag) cases
private
prettyCaseRet : {opts : _} ->
BContext d -> BContext n ->
ScopeTerm d n -> Eff Pretty (Doc opts)
prettyCaseRet dnames tnames body = withPrec Outer $ case body of
S _ (N tm) => assert_total prettyTerm dnames tnames tm
S [< x] (Y tm) => do
header <- [|prettyTBind x <++> darrowD|]
body <- assert_total prettyTerm dnames (tnames :< x) tm
hangDSingle header body
private
prettyCase_ : {opts : _} ->
BContext d -> BContext n ->
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 <- 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 : _} ->
BContext d -> BContext n ->
Qty -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) ->
Eff Pretty (Doc opts)
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
isDefaultDir _ _ = False
-- [fixme] use telescopes in Scoped
private
toTel : BContext s -> BTelescope n (s + n)
toTel [<] = [<]
toTel (ctx :< x) = toTel ctx :< x
private
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] =
parens . hsep =<< sequence [prettyTBind a, timesD, prettyTBind b]
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
prettyLambda : {opts : _} -> BContext d -> BContext n ->
Term d n -> Eff Pretty (Doc opts)
prettyLambda dnames tnames s =
parensIfM Outer =<< do
let MkSplitLams {dnames = ds, tnames = ts, chunks, body} = splitLams s
hangDSingle !(header chunks)
!(assert_total prettyTerm (dnames . ds) (tnames . ts) body)
where
introChar : NameSort -> Eff Pretty (Doc opts)
introChar T = lamD
introChar D = dlamD
prettyBind : NameSort -> BindName -> Eff Pretty (Doc opts)
prettyBind T = prettyTBind
prettyBind D = prettyDBind
header1 : NameSort -> List BindName -> Eff Pretty (Doc opts)
header1 s xs = hsep <$> sequence
[introChar s, sep <$> traverse (prettyBind s) xs, darrowD]
header : NameChunks -> Eff Pretty (Doc opts)
header cs = sep <$> traverse (\(s, xs) => header1 s (toList xs)) (toList cs)
prettyDisp : {opts : _} -> Universe -> Eff Pretty (Maybe (Doc opts))
prettyDisp 0 = pure Nothing
prettyDisp u = map Just $ hl Universe =<<
ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
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
let MkSplitPi {binds, cod} = splitPi [< (qty, res.name, arg)] res.term
arr <- arrowD
lines <- map (<++> arr) <$> prettyPiBinds dnames tnames binds
let tnames = tnames . map pbname binds
cod <- withPrec Outer $ prettyTerm dnames tnames (assert_smaller res cod)
pure $ sepSingle $ toList $ lines :< cod
prettyTerm dnames tnames s@(Lam {}) =
prettyLambda dnames tnames s
prettyTerm dnames tnames (Sig fst snd _) =
parensIfM Times =<< do
let MkSplitSig {binds, last} = splitSig [< (snd.name, fst)] snd.term
times <- timesD
lines <- map (<++> times) <$> prettySigBinds dnames tnames binds
let tnames = tnames . map Builtin.fst binds
last <- withPrec InTimes $
prettyTerm dnames tnames (assert_smaller snd last)
pure $ sepSingle $ toList $ lines :< last
prettyTerm dnames tnames p@(Pair fst snd _) =
parens =<< do
let elems = splitTuple [< fst] snd
lines <- for elems $ \t =>
withPrec Outer $ prettyTerm dnames tnames $ assert_smaller p t
pure $ separateTight !commaD lines
prettyTerm dnames tnames (Enum cases _) =
prettyEnum $ SortedSet.toList cases
prettyTerm dnames tnames (Tag tag _) =
prettyTag tag
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 _) =
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 (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 =<<
sequence [prettyQty qty, dotD,
withPrec Outer $ prettyTerm dnames tnames ty]
prettyTerm dnames tnames (Box val _) =
bracks =<< withPrec Outer (prettyTerm dnames tnames val)
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
prettyTerm dnames tnames t0@(DCloT (Sub t ph)) =
prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' ph id t
prettyElim dnames tnames (F x u _) = do
x <- prettyFree x
u <- prettyDisp u
pure $ maybe x (x <+>) u
prettyElim dnames tnames (B i _) =
prettyTBind $ tnames !!! i
prettyElim dnames tnames e@(App {}) =
let (f, xs) = splitApps e in
prettyDTApps dnames tnames f xs
prettyElim dnames tnames (CasePair qty pair ret body _) = do
let [< x, y] = body.names
pat <- parens . hsep =<< sequence
[[|prettyTBind x <+> commaD|], prettyTBind y]
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
prettyCase dnames tnames qty tag ret arms
prettyElim dnames tnames (CaseNat qty qtyIH nat ret zero succ _) = do
let zarm = MkCaseArm !zeroD [<] [<] zero
[< p, ih] = succ.names
spat0 <- [|succD <++> prettyTBind p|]
ihpat0 <- map hcat $ sequence [prettyQty qtyIH, dotD, prettyTBind ih]
spat <- if ih.val == Unused
then pure spat0
else pure $ hsep [spat0 <+> !commaD, ihpat0]
let sarm = MkCaseArm spat [<] [< p, ih] succ.term
prettyCase dnames tnames qty nat ret [zarm, sarm]
prettyElim dnames tnames (CaseBox qty box ret body _) = do
pat <- bracks =<< prettyTBind body.name
let arm = MkCaseArm pat [<] [< body.name] body.term
prettyCase dnames tnames qty box ret [arm]
prettyElim dnames tnames e@(DApp {}) =
let (f, xs) = splitApps e in
prettyDTApps dnames tnames f xs
prettyElim dnames tnames (Ann tm 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 =<< 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 <- 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
layoutComp [ty, pq] val r [arm0, arm1]
prettyElim dnames tnames (TypeCase ty ret arms def _) = do
arms <- for (toList arms) $ \(k ** body) => do
pat <- prettyTyCasePat k body.names
pure $ MkCaseArm pat [<] (toTel body.names) body.term
let darm = MkCaseArm !undD [<] [<] def
prettyCase_ dnames tnames !typecaseD ty (SN ret) $ arms ++ [darm]
prettyElim dnames tnames e0@(CloE (Sub e ph)) =
prettyElim dnames tnames $ assert_smaller e0 $ pushSubstsWith' id ph e
prettyElim dnames tnames e0@(DCloE (Sub e ph)) =
prettyElim dnames tnames $ assert_smaller e0 $ pushSubstsWith' ph id e

View File

@ -1,299 +0,0 @@
module Quox.Syntax.Term.Reduce
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
%default total
mutual
||| true if a term has a closure or dimension closure at the top level,
||| or is `E` applied to such an elimination
public export %inline
topCloT : Term d n -> Bool
topCloT (CloT _ _) = True
topCloT (DCloT _ _) = True
topCloT (E e) = topCloE e
topCloT _ = False
||| true if an elimination has a closure or dimension closure at the top level
public export %inline
topCloE : Elim d n -> Bool
topCloE (CloE _ _) = True
topCloE (DCloE _ _) = True
topCloE _ = False
public export IsNotCloT : Term d n -> Type
IsNotCloT = So . not . topCloT
||| a term which is not a top level closure
public export NotCloTerm : Nat -> Nat -> Type
NotCloTerm d n = Subset (Term d n) IsNotCloT
public export IsNotCloE : Elim d n -> Type
IsNotCloE = So . not . topCloE
||| an elimination which is not a top level closure
public export NotCloElim : Nat -> Nat -> Type
NotCloElim d n = Subset (Elim d n) IsNotCloE
public export %inline
ncloT : (t : Term d n) -> (0 _ : IsNotCloT t) => NotCloTerm d n
ncloT t @{p} = Element t p
public export %inline
ncloE : (t : Elim d n) -> (0 _ : IsNotCloE t) => NotCloElim d n
ncloE e @{p} = Element e p
mutual
||| if the input term has any top-level closures, push them under one layer of
||| syntax
export %inline
pushSubstsT : Term d n -> NotCloTerm d n
pushSubstsT s = pushSubstsTWith id id s
||| if the input elimination has any top-level closures, push them under one
||| layer of syntax
export %inline
pushSubstsE : Elim d n -> NotCloElim d n
pushSubstsE e = pushSubstsEWith id id e
export
pushSubstsTWith : DSubst dfrom dto -> TSubst dto from to ->
Term dfrom from -> NotCloTerm dto to
pushSubstsTWith th ph (TYPE l) =
ncloT $ TYPE l
pushSubstsTWith th ph (Pi qty x a body) =
ncloT $ Pi qty x (subs a th ph) (subs body th ph)
pushSubstsTWith th ph (Lam x body) =
ncloT $ Lam x $ subs body th ph
pushSubstsTWith th ph (E e) =
let Element e _ = pushSubstsEWith th ph e in ncloT $ E e
pushSubstsTWith th ph (CloT s ps) =
pushSubstsTWith th (comp' th ps ph) s
pushSubstsTWith th ph (DCloT s ps) =
pushSubstsTWith (ps . th) ph s
export
pushSubstsEWith : DSubst dfrom dto -> TSubst dto from to ->
Elim dfrom from -> NotCloElim dto to
pushSubstsEWith th ph (F x) =
ncloE $ F x
pushSubstsEWith th ph (B i) =
let res = ph !! i in
case choose $ topCloE res of
Left _ => assert_total pushSubstsE res
Right _ => ncloE res
pushSubstsEWith th ph (f :@ s) =
ncloE $ subs f th ph :@ subs s th ph
pushSubstsEWith th ph (s :# a) =
ncloE $ subs s th ph :# subs a th ph
pushSubstsEWith th ph (CloE e ps) =
pushSubstsEWith th (comp' th ps ph) e
pushSubstsEWith th ph (DCloE e ps) =
pushSubstsEWith (ps . th) ph e
parameters (th : DSubst dfrom dto) (ph : TSubst dto from to)
public export %inline
pushSubstsTWith' : Term dfrom from -> Term dto to
pushSubstsTWith' s = (pushSubstsTWith th ph s).fst
public export %inline
pushSubstsEWith' : Elim dfrom from -> Elim dto to
pushSubstsEWith' e = (pushSubstsEWith th ph e).fst
public export %inline
pushSubstsT' : Term d n -> Term d n
pushSubstsT' s = (pushSubstsT s).fst
public export %inline
pushSubstsE' : Elim d n -> Elim d n
pushSubstsE' e = (pushSubstsE e).fst
mutual
-- tightening a term/elim also causes substitutions to be pushed through.
-- this is because otherwise a variable in an unused part of the subst
-- would cause it to incorrectly fail
export covering
Tighten (Term d) where
tighten p (TYPE l) =
pure $ TYPE l
tighten p (Pi qty x arg res) =
Pi qty x <$> tighten p arg
<*> tighten p res
tighten p (Lam x body) =
Lam x <$> tighten p body
tighten p (E e) =
E <$> tighten p e
tighten p (CloT tm th) =
tighten p $ pushSubstsTWith' id th tm
tighten p (DCloT tm th) =
tighten p $ pushSubstsTWith' th id tm
export covering
Tighten (Elim d) where
tighten p (F x) =
pure $ F x
tighten p (B i) =
B <$> tighten p i
tighten p (fun :@ arg) =
[|tighten p fun :@ tighten p arg|]
tighten p (tm :# ty) =
[|tighten p tm :# tighten p ty|]
tighten p (CloE el th) =
tighten p $ pushSubstsEWith' id th el
tighten p (DCloE el th) =
tighten p $ pushSubstsEWith' th id el
export covering
Tighten (ScopeTerm d) where
tighten p (TUsed body) = TUsed <$> tighten (Keep p) body
tighten p (TUnused body) = TUnused <$> tighten p body
public export %inline
weakT : Term d n -> Term d (S n)
weakT t = t //. shift 1
public export %inline
weakE : Elim d n -> Elim d (S n)
weakE t = t //. shift 1
mutual
public export
data IsRedexT : Term d n -> Type where
IsUpsilonT : IsRedexT $ E (_ :# _)
IsCloT : IsRedexT $ CloT {}
IsDCloT : IsRedexT $ DCloT {}
IsERedex : IsRedexE e -> IsRedexT $ E e
public export %inline
NotRedexT : Term d n -> Type
NotRedexT = Not . IsRedexT
public export
data IsRedexE : Elim d n -> Type where
IsUpsilonE : IsRedexE $ E _ :# _
IsBetaLam : IsRedexE $ (Lam {} :# Pi {}) :@ _
IsCloE : IsRedexE $ CloE {}
IsDCloE : IsRedexE $ DCloE {}
public export %inline
NotRedexE : Elim d n -> Type
NotRedexE = Not . IsRedexE
mutual
export %inline
isRedexT : (t : Term d n) -> Dec (IsRedexT t)
isRedexT (E (tm :# ty)) = Yes IsUpsilonT
isRedexT (CloT {}) = Yes IsCloT
isRedexT (DCloT {}) = Yes IsDCloT
isRedexT (E (CloE {})) = Yes $ IsERedex IsCloE
isRedexT (E (DCloE {})) = Yes $ IsERedex IsDCloE
isRedexT (E e@(_ :@ _)) with (isRedexE e)
_ | Yes yes = Yes $ IsERedex yes
_ | No no = No \case IsERedex p => no p
isRedexT (TYPE {}) = No $ \x => case x of {}
isRedexT (Pi {}) = No $ \x => case x of {}
isRedexT (Lam {}) = No $ \x => case x of {}
isRedexT (E (F _)) = No $ \x => case x of IsERedex _ impossible
isRedexT (E (B _)) = No $ \x => case x of IsERedex _ impossible
export %inline
isRedexE : (e : Elim d n) -> Dec (IsRedexE e)
isRedexE (E _ :# _) = Yes IsUpsilonE
isRedexE ((Lam {} :# Pi {}) :@ _) = Yes IsBetaLam
isRedexE (CloE {}) = Yes IsCloE
isRedexE (DCloE {}) = Yes IsDCloE
isRedexE (F x) = No $ \x => case x of {}
isRedexE (B i) = No $ \x => case x of {}
isRedexE (F _ :@ _) = No $ \x => case x of {}
isRedexE (B _ :@ _) = No $ \x => case x of {}
isRedexE (_ :@ _ :@ _) = No $ \x => case x of {}
isRedexE ((TYPE _ :# _) :@ _) = No $ \x => case x of {}
isRedexE ((Pi {} :# _) :@ _) = No $ \x => case x of {}
isRedexE ((Lam {} :# TYPE _) :@ _) = No $ \x => case x of {}
isRedexE ((Lam {} :# Lam {}) :@ _) = No $ \x => case x of {}
isRedexE ((Lam {} :# E _) :@ _) = No $ \x => case x of {}
isRedexE ((Lam {} :# CloT {}) :@ _) = No $ \x => case x of {}
isRedexE ((Lam {} :# DCloT {}) :@ _) = No $ \x => case x of {}
isRedexE ((E _ :# _) :@ _) = No $ \x => case x of {}
isRedexE ((CloT {} :# _) :@ _) = No $ \x => case x of {}
isRedexE ((DCloT {} :# _) :@ _) = No $ \x => case x of {}
isRedexE (CloE {} :@ _) = No $ \x => case x of {}
isRedexE (DCloE {} :@ _) = No $ \x => case x of {}
isRedexE (TYPE _ :# _) = No $ \x => case x of {}
isRedexE (Pi {} :# _) = No $ \x => case x of {}
isRedexE (Lam {} :# _) = No $ \x => case x of {}
isRedexE (CloT {} :# _) = No $ \x => case x of {}
isRedexE (DCloT {} :# _) = No $ \x => case x of {}
public export %inline
RedexTerm : Nat -> Nat -> Type
RedexTerm d n = Subset (Term d n) IsRedexT
public export %inline
NonRedexTerm : Nat -> Nat -> Type
NonRedexTerm d n = Subset (Term d n) NotRedexT
public export %inline
RedexElim : Nat -> Nat -> Type
RedexElim d n = Subset (Elim d n) IsRedexE
public export %inline
NonRedexElim : Nat -> Nat -> Type
NonRedexElim d n = Subset (Elim d n) NotRedexE
||| substitute a term with annotation for the bound variable of a `ScopeTerm`
export %inline
substScope : (arg, argTy : Term d n) -> (body : ScopeTerm d n) -> Term d n
substScope arg argTy (TUsed body) = body // one (arg :# argTy)
substScope arg argTy (TUnused body) = body
mutual
export %inline
stepT' : (s : Term d n) -> IsRedexT s -> Term d n
stepT' (E (s :# _)) IsUpsilonT = s
stepT' (CloT s th) IsCloT = pushSubstsTWith' id th s
stepT' (DCloT s th) IsDCloT = pushSubstsTWith' th id s
stepT' (E e) (IsERedex p) = E $ stepE' e p
export %inline
stepE' : (e : Elim d n) -> IsRedexE e -> Elim d n
stepE' (E e :# _) IsUpsilonE = e
stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam =
substScope s arg body :# substScope s arg res
stepE' (CloE e th) IsCloE = pushSubstsEWith' id th e
stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e
export %inline
stepT : (s : Term d n) -> Either (NotRedexT s) (Term d n)
stepT s = case isRedexT s of Yes y => Right $ stepT' s y; No n => Left n
export %inline
stepE : (e : Elim d n) -> Either (NotRedexE e) (Elim d n)
stepE e = case isRedexE e of Yes y => Right $ stepE' e y; No n => Left n
export covering
whnfT : Term d n -> NonRedexTerm d n
whnfT s = case stepT s of
Right s' => whnfT s'
Left done => Element s done
export covering
whnfE : Elim d n -> NonRedexElim d n
whnfE e = case stepE e of
Right e' => whnfE e'
Left done => Element e done

View File

@ -1,82 +0,0 @@
module Quox.Syntax.Term.Split
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
import Data.So
import Data.Vect
%default total
public export %inline
isLam : Term d n -> Bool
isLam (Lam {}) = True
isLam _ = False
public export
NotLam : Term d n -> Type
NotLam = So . not . isLam
public export %inline
isApp : Elim d n -> Bool
isApp ((:@) {}) = True
isApp _ = False
public export
NotApp : Elim d n -> Type
NotApp = So . not . isApp
infixl 9 :@@
||| apply multiple arguments at once
public export %inline
(:@@) : Elim d n -> List (Term d n) -> Elim d n
f :@@ ss = foldl (:@) f ss
public export
record GetArgs (d, n : Nat) where
constructor GotArgs
fun : Elim d n
args : List (Term d n)
0 notApp : NotApp fun
export
getArgs' : Elim d n -> List (Term d n) -> GetArgs d n
getArgs' fun args with (choose $ isApp fun)
getArgs' (f :@ a) args | Left yes = getArgs' f (a :: args)
_ | Right no = GotArgs {fun, args, notApp = no}
||| splits an application into its head and arguments. if it's not an
||| application then the list is just empty
export %inline
getArgs : Elim d n -> GetArgs d n
getArgs e = getArgs' e []
infixr 1 :\\
public export
(:\\) : Vect m Name -> Term d (m + n) -> Term d n
[] :\\ t = t
x :: xs :\\ t = let t' = replace {p = Term _} (plusSuccRightSucc {}) t in
Lam x $ TUsed $ xs :\\ t'
public export
record GetLams (d, n : Nat) where
constructor GotLams
names : Vect lams Name
body : Term d rest
0 eq : lams + n = rest
0 notLam : NotLam body
public export
getLams : Term d n -> GetLams d n
getLams s with (choose $ isLam s)
getLams s@(Lam x body) | Left yes =
let inner = getLams $ assert_smaller s $ fromScopeTerm body in
GotLams {names = x :: inner.names,
body = inner.body,
eq = plusSuccRightSucc {} `trans` inner.eq,
notLam = inner.notLam}
_ | Right no = GotLams {names = [], body = s, eq = Refl, notLam = no}

View File

@ -1,27 +1,88 @@
module Quox.Syntax.Term.Subst
import Quox.No
import Quox.Syntax.Term.Base
import Data.SnocVect
%default total
export FromVar (Elim d) where fromVar = B
export FromVar (Term d) where fromVar = E . fromVar
namespace CanDSubst
public export
interface CanDSubst (0 tm : TermLike) where
(//) : tm d1 n -> Lazy (DSubst d1 d2) -> tm d2 n
||| does the minimal reasonable work:
||| - deletes the closure around a free name since it doesn't do anything
||| - 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
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 (locs $ toList' ns) th
S ns (N body) // th = S ns $ N $ body // th
export %inline FromVar (Elim d) where fromVarLoc = B
export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc
||| does the minimal reasonable work:
||| - deletes the closure around a *free* name
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level closure
||| - immediately looks up a bound variable
||| - otherwise, wraps in a new closure
export
CanSubst (Elim d) (Elim d) where
F x // _ = F x
B i // th = th !! i
CloE e ph // th = assert_total CloE e $ ph . th
e // th = case force th of
Shift SZ => e
th => CloE e th
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`
@ -30,106 +91,266 @@ CanSubst (Elim d) (Elim d) where
||| - goes inside `E` in case it is a simple variable or something
||| - otherwise, wraps in a new closure
export
CanSubst (Elim d) (Term d) where
TYPE l // _ = TYPE l
E e // th = E $ e // th
CloT s ph // th = CloT s $ ph . th
s // th = case force th of
Shift SZ => s
th => CloT s th
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
export
CanSubst (Elim d) (ScopeTerm d) where
TUsed body // th = TUsed $ body // push th
TUnused body // th = TUnused $ body // 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
export CanSubst Var (Term d) where s // th = s // map (B {d}) th
export CanSubst Var (Elim d) where e // th = e // map (B {d}) th
export CanSubst Var (ScopeTerm d) where s // th = s // map (B {d}) 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
infixl 8 //., ///
mutual
namespace Term
||| applies a term substitution with a less ambiguous type
export
(//.) : Term d from -> TSubst d from to -> Term d to
t //. th = t // th
export %inline CanShift (flip Term n) where s // by = s // Shift by
export %inline CanShift (flip Elim n) where e // by = e // Shift by
||| applies a dimension substitution with the same behaviour as `(//)`
||| above
export
(///) : Term dfrom n -> DSubst dfrom dto -> Term dto n
TYPE l /// _ = TYPE l
E e /// th = E $ e /// th
DCloT s ph /// th = DCloT s $ ph . th
s /// Shift SZ = s
s /// th = DCloT s th
||| applies a term and dimension substitution
public export %inline
subs : Term dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
Term dto to
subs s th ph = s /// th // ph
namespace Elim
||| applies a term substitution with a less ambiguous type
export
(//.) : Elim d from -> TSubst d from to -> Elim d to
e //. th = e // th
||| applies a dimension substitution with the same behaviour as `(//)`
||| above
export
(///) : Elim dfrom n -> DSubst dfrom dto -> Elim dto n
F x /// _ = F x
B i /// _ = B i
DCloE e ph /// th = DCloE e $ ph . th
e /// Shift SZ = e
e /// th = DCloE e th
||| applies a term and dimension substitution
public export %inline
subs : Elim dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
Elim dto to
subs e th ph = e /// th // ph
namespace ScopeTerm
||| applies a term substitution with a less ambiguous type
export
(//.) : ScopeTerm d from -> TSubst d from to -> ScopeTerm d to
body //. th = body // th
||| applies a dimension substitution with the same behaviour as `(//)`
||| above
export
(///) : ScopeTerm dfrom n -> DSubst dfrom dto -> ScopeTerm dto n
TUsed body /// th = TUsed $ body /// th
TUnused body /// th = TUnused $ body /// th
||| applies a term and dimension substitution
public export %inline
subs : ScopeTerm dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
ScopeTerm dto to
subs body th ph = body /// th // ph
export CanShift (Term d) where s // by = s //. Shift by
export CanShift (Elim d) where e // by = e //. Shift by
export CanShift (ScopeTerm d) where s // by = s //. Shift by
export %inline
{s : Nat} -> CanShift (ScopeTermN s d) where
b // by = b // Shift by
export %inline
comp' : DSubst dfrom dto -> TSubst dfrom from mid -> TSubst dto mid to ->
TSubst dto from to
comp' th ps ph = map (/// th) ps . ph
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
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
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
export
fromDScopeTerm : DScopeTerm d n -> Term (S d) n
fromDScopeTerm (DUsed body) = body
fromDScopeTerm (DUnused body) = body /// shift 1
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
export
fromScopeTerm : ScopeTerm d n -> Term d (S n)
fromScopeTerm (TUsed body) = body
fromScopeTerm (TUnused body) = body //. shift 1
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

View File

@ -0,0 +1,376 @@
module Quox.Syntax.Term.Tighten
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
import public Quox.OPE
import Quox.No
%default total
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
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 s =
let Element s' _ = pushSubsts s in
tightenT' p $ assert_smaller s s'
private
tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
tightenE p e =
let Element e' _ = pushSubsts e in
tightenE' p $ assert_smaller e e'
private
tightenT' : OPE n1 n2 -> (t : Term d n2) -> (0 nt : NotClo t) =>
Maybe (Term d n1)
tightenT' p (TYPE l loc) = pure $ TYPE l loc
tightenT' p (IOState loc) = pure $ IOState 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 (Nat n loc) =
pure $ Nat n loc
tightenT' p (Succ s loc) =
Succ <$> tightenT p s <*> pure loc
tightenT' p (STRING loc) =
pure $ STRING loc
tightenT' p (Str s loc) =
pure $ Str s 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 (Let qty rhs body loc) =
Let qty <$> assert_total tightenE p rhs <*> tightenS p body <*> pure loc
tightenT' p (E e) =
E <$> assert_total tightenE p e
private
tightenE' : OPE n1 n2 -> (e : Elim d n2) -> (0 ne : NotClo e) =>
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 (Fst pair loc) =
Fst <$> tightenE p pair <*> pure loc
tightenE' p (Snd pair loc) =
Snd <$> tightenE p pair <*> 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
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 s =
let Element s' _ = pushSubsts s in
dtightenT' p $ assert_smaller s s'
export
dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
dtightenE p e =
let Element e' _ = pushSubsts e in
dtightenE' p $ assert_smaller e e'
private
dtightenT' : OPE d1 d2 -> (t : Term d2 n) -> (0 nt : NotClo t) =>
Maybe (Term d1 n)
dtightenT' p (TYPE l loc) =
pure $ TYPE l loc
dtightenT' p (IOState loc) =
pure $ IOState 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 (Nat n loc) =
pure $ Nat n loc
dtightenT' p (Succ s loc) =
Succ <$> dtightenT p s <*> pure loc
dtightenT' p (STRING loc) =
pure $ STRING loc
dtightenT' p (Str s loc) =
pure $ Str s 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 (Let qty rhs body loc) =
Let qty <$> assert_total dtightenE p rhs <*> dtightenS p body <*> pure loc
dtightenT' p (E e) =
E <$> assert_total dtightenE p e
export
dtightenE' : OPE d1 d2 -> (e : Elim d2 n) -> (0 ne : NotClo e) =>
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 (Fst pair loc) =
Fst <$> dtightenE p pair <*> pure loc
dtightenE' p (Snd pair loc) =
Snd <$> dtightenE p pair <*> 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)|]
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 Tighten (\d => Term d n) where tighten p t = dtightenT p t
export Tighten (\d => Elim d n) where tighten p e = dtightenE p e
parameters {auto _ : Tighten f} {s : Nat}
export
squeeze : Scoped s f n -> (BContext s, Either (f (s + n)) (f n))
squeeze (S ns (N t)) = (ns, Right t)
squeeze (S ns (Y t)) = (ns, maybe (Left t) Right $ tightenN s t)
export
squeeze' : Scoped s f n -> Scoped s f n
squeeze' t = let (ns, res) = squeeze t in S ns $ either Y N res
parameters {0 f : Nat -> Nat -> Type}
{auto tt : Tighten (\d => f d n)} {s : Nat}
export
dsqueeze : Scoped s (\d => f d n) d ->
(BContext s, Either (f (s + d) n) (f d n))
dsqueeze = squeeze
export
dsqueeze' : Scoped s (\d => f d n) d -> Scoped s (\d => f d n) d
dsqueeze' = squeeze'
-- versions of SY, etc, that try to tighten and use SN automatically
public export %inline
ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n
ST names body = squeeze' $ SY names body
public export %inline
DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n
DST names body = dsqueeze' {f = Term} $ SY names 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
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' = DST 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 = DST zero.names $ E $
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
one = DST one.names $ E $
Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
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 = DST [< i] ty, p, q, val, r,
zero = DST [< j0] zero, one = DST [< j1] one, loc}

View File

@ -0,0 +1,37 @@
module Quox.Syntax.Term.TyConKind
import Decidable.Equality
import Derive.Prelude
import Generics.Derive
%language ElabReflection
%default total
public export
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]
||| a list of all `TyConKind`s
public export %inline
allKinds : List TyConKind
allKinds = %runElab do
-- as a script so it stays up to date if there are more tycon kinds
cs <- getCons $ fst !(lookupName "TyConKind")
traverse (check . var) cs
||| in `type-case`, how many variables are bound in this branch
public export %inline
arity : TyConKind -> Nat
arity KTYPE = 0
arity KIOState = 0
arity KPi = 2
arity KSig = 2
arity KEnum = 0
arity KEq = 5
arity KNat = 0
arity KString = 0
arity KBOX = 1

View File

@ -1,27 +0,0 @@
module Quox.Syntax.Universe
import Quox.Pretty
import Data.Fin
import Generics.Derive
%default total
%language ElabReflection
||| `UAny` doesn't show up in programs, but when checking something is
||| just some type (e.g. in a signature) it's checked against `Star UAny`
public export
data Universe = U Nat | UAny
%name Universe l
%runElab derive "Universe" [Generic, Meta, Eq, Ord, DecEq, Show]
export
PrettyHL Universe where
prettyM UAny = pure $ hl Delim "_"
prettyM (U l) = pure $ hl Free $ pretty l
export %inline
fromInteger : (x : Integer) -> (0 _ : So (x >= 0)) => Universe
fromInteger x = U $ fromInteger x

View File

@ -1,49 +0,0 @@
module Quox.Token
import Generics.Derive
import Text.Lexer
%default total
%language ElabReflection
public export
data Punc
= LParen | RParen
| LSquare | RSquare
| LBrace | RBrace
| Comma
| Colon | DblColon
| Dot
| Arrow | DblArrow
| Times | Triangle
| Wild
%runElab derive "Punc" [Generic, Meta, Eq, Ord, DecEq, Show]
public export
data Keyword
= Lam | Let | In | Case | Of | Omega
| Pi | Sigma | W
%runElab derive "Keyword" [Generic, Meta, Eq, Ord, DecEq, Show]
||| zero and one are separate because they are
||| quantity & dimension constants
public export
data Number = Zero | One | Other Nat
%runElab derive "Number" [Generic, Meta, Eq, Ord, DecEq, Show]
public export
data Token
= P Punc
| K Keyword
| Name String | Symbol String
| N Number | TYPE Nat
%runElab derive "Token" [Generic, Meta, Eq, Ord, DecEq, Show]
public export
BToken : Type
BToken = WithBounds Token

View File

@ -1,148 +1,566 @@
module Quox.Typechecker
import public Quox.Syntax
import public Quox.Typing
import public Quox.Equal
import public Control.Monad.Either
import Quox.Displace
import Quox.Pretty
import Data.List
import Data.SnocVect
import Data.List1
import Quox.EffExtra
%default total
private covering %inline
expectTYPE : MonadError Error m => Term d n -> m Universe
expectTYPE s =
case (whnfT s).fst of
TYPE l => pure l
_ => throwError $ ExpectedTYPE s
private covering %inline
expectPi : MonadError Error m => Term d n ->
m (Qty, Term d n, ScopeTerm d n)
expectPi ty =
case (whnfT ty).fst of
Pi qty _ arg res => pure (qty, arg, res)
_ => throwError $ ExpectedPi ty
private %inline
expectEqualQ : MonadError Error m =>
(expect, actual : Qty) -> m ()
expectEqualQ pi rh =
unless (pi == rh) $ throwError $ ClashQ pi rh
public export
0 TC : List (Type -> Type)
TC = [ErrorEff, DefsReader, NameGen, Log]
private %inline
popQ : MonadError Error m => Qty -> QOutput (S n) -> m (QOutput n)
popQ pi (qctx :< rh) = expectEqualQ pi rh $> qctx
parameters (loc : Loc)
export
popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) ->
Eff fs (QOutput n)
popQs [<] qout = pure qout
popQs (pis :< pi) (qout :< rh) = do expectCompatQ loc rh pi; popQs pis qout
export %inline
popQ : Has ErrorEff fs => Qty -> QOutput (S n) -> Eff fs (QOutput n)
popQ pi = popQs [< pi]
private %inline
tail : TyContext d (S n) -> TyContext d n
tail = {tctx $= tail, qctx $= tail}
export
lubs1 : List1 (QOutput n) -> QOutput n
lubs1 ([<] ::: _) = [<]
lubs1 ((qs :< p) ::: pqs) =
let (qss, ps) = unzip $ map unsnoc pqs in
lubs1 (qs ::: qss) :< foldl lub p ps
export
lubs : TyContext d n -> List (QOutput n) -> QOutput n
lubs ctx [] = zeroFor ctx
lubs ctx (x :: xs) = lubs1 $ x ::: xs
private %inline
weakI : InferResult d n -> InferResult d (S n)
weakI = {type $= weakT, qout $= (:< zero)}
private
lookupBound : {n : Nat} -> Qty -> Var n -> TyContext d n -> InferResult d n
lookupBound pi VZ (MkTyContext {tctx = _ :< ty, _}) =
InfRes {type = weakT ty, qout = zero :< pi}
lookupBound pi (VS i) ctx =
weakI $ lookupBound pi i (tail ctx)
prettyTermTC : {opts : LayoutOpts} ->
TyContext d n -> Term d n -> Eff Pretty (Doc opts)
prettyTermTC ctx s = prettyTerm ctx.dnames ctx.tnames s
private %inline
subjMult : Qty -> Qty -> Subset Qty IsSubj
subjMult sg qty =
if sg == Zero || qty == Zero
then Element Zero %search
else Element One %search
private
checkLogs : String -> TyContext d n -> SQty ->
Term d n -> Maybe (Term d n) -> Eff TC ()
checkLogs fun ctx sg subj ty = do
let tyDoc = delay $ maybe (text "none") (runPretty . prettyTermTC ctx) ty
sayMany "check" subj.loc
[10 :> text fun,
95 :> hsep ["ctx =", runPretty $ prettyTyContext ctx],
95 :> hsep ["sg =", runPretty $ prettyQty sg.qty],
10 :> hsep ["subj =", runPretty $ prettyTermTC ctx subj],
10 :> hsep ["ty =", tyDoc]]
mutual
||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ"
|||
||| `check ctx sg subj ty` checks that in the context `ctx`, the term
||| `subj` has the type `ty`, with quantity `sg`. if so, returns the
||| quantities of all bound variables that it used.
|||
||| if the dimension context is inconsistent, then return `Nothing`, without
||| doing any further work.
export covering %inline
check : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
Eff TC (CheckResult ctx.dctx n)
check ctx sg subj ty =
ifConsistentElse ctx.dctx
(do checkLogs "check" ctx sg subj (Just ty)
checkC ctx sg subj ty)
(say "check" 20 subj.loc "check: 0=1")
public export
CanTC : (Type -> Type) -> Type
CanTC m = (MonadError Error m, MonadReader Definitions m)
||| "Ψ | Γ ⊢₀ s ⇐ A"
|||
||| `check0 ctx subj ty` checks a term (as `check`) in a zero context.
export covering %inline
check0 : TyContext d n -> Term d n -> Term d n -> Eff TC ()
check0 ctx tm ty = ignore $ check ctx SZero tm ty
-- the output will always be 𝟎 because the subject quantity is 0
parameters {auto _ : CanTC m}
mutual
-- [todo] it seems like the options here for dealing with substitutions are
-- to either push them or parametrise the whole typechecker over ambient
-- substitutions. both of them seem like the same amount of work for the
-- computer but pushing is less work for the me
||| `check`, assuming the dimension context is consistent
export covering %inline
checkC : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
Eff TC (CheckResult' n)
checkC ctx sg subj ty =
wrapErr (WhileChecking ctx sg subj ty) $
checkCNoWrap ctx sg subj ty
export covering %inline
check : {d, n : Nat} ->
(ctx : TyContext d n) -> (sg : Qty) -> (0 _ : IsSubj sg) =>
(subj : Term d n) -> (ty : Term d n) ->
m (CheckResult n)
check ctx sg subj ty = check' ctx sg (pushSubstsT subj) ty
checkCNoWrap : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n ->
Eff TC (CheckResult' n)
checkCNoWrap ctx sg subj ty =
let Element subj nc = pushSubsts subj in
check' ctx sg subj ty
||| "Ψ | Γ ⊢₀ s ⇐ ★ᵢ"
|||
||| `checkType ctx subj ty` checks a type (in a zero context). sometimes the
||| universe doesn't matter, only that a term is _a_ type, so it is optional.
export covering %inline
checkType : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
checkType ctx subj l = do
let univ = TYPE <$> l <*> pure noLoc
ignore $ ifConsistentElse ctx.dctx
(do checkLogs "checkType" ctx SZero subj univ
checkTypeC ctx subj l)
(say "check" 20 subj.loc "checkType: 0=1")
export covering %inline
infer : {d, n : Nat} ->
(ctx : TyContext d n) -> (sg : Qty) -> (0 _ : IsSubj sg) =>
(subj : Elim d n) ->
m (InferResult d n)
infer ctx sg subj = infer' ctx sg (pushSubstsE subj)
checkTypeC : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
checkTypeC ctx subj l =
wrapErr (WhileCheckingTy ctx subj l) $ checkTypeNoWrap ctx subj l
export covering %inline
checkTypeNoWrap : TyContext d n -> Term d n -> Maybe Universe -> Eff TC ()
checkTypeNoWrap ctx subj l =
let Element subj nc = pushSubsts subj in
checkType' ctx subj l
||| "Ψ | Γ ⊢ σ · e ⇒ A ⊳ Σ"
|||
||| `infer ctx sg subj` infers the type of `subj` in the context `ctx`,
||| and returns its type and the bound variables it used.
|||
||| if the dimension context is inconsistent, then return `Nothing`, without
||| doing any further work.
export covering %inline
infer : (ctx : TyContext d n) -> SQty -> Elim d n ->
Eff TC (InferResult ctx.dctx d n)
infer ctx sg subj = do
ifConsistentElse ctx.dctx
(do checkLogs "infer" ctx sg (E subj) Nothing
inferC ctx sg subj)
(say "check" 20 subj.loc "infer: 0=1")
||| `infer`, assuming the dimension context is consistent
export covering %inline
inferC : (ctx : TyContext d n) -> SQty -> Elim d n ->
Eff TC (InferResult' d n)
inferC ctx sg subj =
wrapErr (WhileInferring ctx sg subj) $
let Element subj nc = pushSubsts subj in
infer' ctx sg subj
export covering
check' : {d, n : Nat} ->
(ctx : TyContext d n) -> (sg : Qty) -> (0 _ : IsSubj sg) =>
(subj : NotCloTerm d n) -> (ty : Term d n) ->
m (CheckResult n)
private covering
toCheckType : TyContext d n -> SQty ->
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
Eff TC (CheckResult' n)
toCheckType ctx sg t ty = do
u <- expectTYPE !(askAt DEFS) ctx sg ty.loc ty
expectEqualQ t.loc Zero sg.qty
checkTypeNoWrap ctx t (Just u)
pure $ zeroFor ctx
check' ctx sg (Element (TYPE l) _) ty = do
l' <- expectTYPE ty
expectEqualQ zero sg
unless (l < l') $ throwError $ BadUniverse l l'
pure zero
private covering
check' : TyContext d n -> SQty ->
(subj : Term d n) -> (0 nc : NotClo subj) => Term d n ->
Eff TC (CheckResult' n)
check' ctx sg (Element (Pi qty x arg res) _) ty = do
l <- expectTYPE ty
expectEqualQ zero sg
ignore $ check ctx zero arg (TYPE l)
case res of
TUsed res => ignore $ check (extendTy arg zero ctx) zero res (TYPE l)
TUnused res => ignore $ check ctx zero res (TYPE l)
pure zero
check' ctx sg t@(TYPE {}) ty = toCheckType ctx sg t ty
check' ctx sg (Element (Lam x body) _) ty = do
(qty, arg, res) <- expectPi ty
-- [todo] do this properly?
let body = fromScopeTerm body; res = fromScopeTerm res
qout <- check (extendTy arg (sg * qty) ctx) sg body res
popQ qty qout
check' ctx sg t@(IOState {}) ty = toCheckType ctx sg t ty
check' ctx sg (Element (E e) _) ty = do
infres <- infer ctx sg e
ignore $ check ctx zero ty (TYPE UAny)
subT infres.type ty
check' ctx sg t@(Pi {}) ty = toCheckType ctx sg t ty
check' ctx sg (Lam body loc) ty = do
(qty, arg, res) <- expectPi !(askAt DEFS) ctx SZero ty.loc ty
-- if Ψ | Γ, x : A ⊢ σ · t ⇐ B ⊳ Σ, ρ·x
-- with ρ ≤ σπ
let qty' = sg.qty * qty
qout <- checkC (extendTy qty' body.name arg ctx) sg body.term res.term
-- then Ψ | Γ ⊢ σ · (λx ⇒ t) ⇐ (π·x : A) → B ⊳ Σ
popQ loc qty' qout
check' ctx sg t@(Sig {}) ty = toCheckType ctx sg t ty
check' ctx sg (Pair fst snd loc) ty = do
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx SZero ty.loc ty
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ₁
qfst <- checkC ctx sg fst tfst
let tsnd = sub1 tsnd (Ann fst tfst fst.loc)
-- if Ψ | Γ ⊢ σ · t ⇐ B[s] ⊳ Σ₂
qsnd <- checkC ctx sg snd tsnd
-- then Ψ | Γ ⊢ σ · (s, t) ⇐ (x : A) × B ⊳ Σ₁ + Σ₂
pure $ qfst + qsnd
check' ctx sg t@(Enum {}) ty = toCheckType ctx sg t ty
check' ctx sg (Tag t loc) ty = do
tags <- expectEnum !(askAt DEFS) ctx SZero ty.loc ty
-- if t ∈ ts
unless (t `elem` tags) $ throw $ TagNotIn loc t tags
-- then Ψ | Γ ⊢ σ · t ⇐ {ts} ⊳ 𝟎
pure $ zeroFor ctx
check' ctx sg t@(Eq {}) ty = toCheckType ctx sg t ty
check' ctx sg (DLam body loc) ty = do
(ty, l, r) <- expectEq !(askAt DEFS) ctx SZero ty.loc ty
let ctx' = extendDim body.name ctx
ty = ty.term
body = body.term
-- if Ψ, i | Γ ⊢ σ · t ⇐ A ⊳ Σ
qout <- checkC ctx' sg body ty
-- if Ψ, i, i = 0 | Γ ⊢ t = l : A
let ctx0 = eqDim (B VZ loc) (K Zero loc) ctx'
lift $ equal loc ctx0 sg ty body $ dweakT 1 l
-- if Ψ, i, i = 1 | Γ ⊢ t = r : A
let ctx1 = eqDim (B VZ loc) (K One loc) ctx'
lift $ equal loc ctx1 sg ty body $ dweakT 1 r
-- then Ψ | Γ ⊢ σ · (δ i ⇒ t) ⇐ Eq [i ⇒ A] l r ⊳ Σ
pure qout
check' ctx sg t@(NAT {}) ty = toCheckType ctx sg t ty
check' ctx sg (Nat {}) ty = do
expectNAT !(askAt DEFS) ctx SZero ty.loc ty
pure $ zeroFor ctx
check' ctx sg (Succ n {}) ty = do
expectNAT !(askAt DEFS) ctx SZero ty.loc ty
checkC ctx sg n ty
check' ctx sg t@(STRING {}) ty = toCheckType ctx sg t ty
check' ctx sg t@(Str s {}) ty = do
expectSTRING !(askAt DEFS) ctx SZero ty.loc ty
pure $ zeroFor ctx
check' ctx sg t@(BOX {}) ty = toCheckType ctx sg t ty
check' ctx sg (Box val loc) ty = do
(q, ty) <- expectBOX !(askAt DEFS) ctx SZero ty.loc ty
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ
valout <- checkC ctx (subjMult sg q) val ty
-- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ
pure $ q * valout
check' ctx sg (Let qty rhs body loc) ty = do
eres <- inferC ctx (subjMult sg qty) rhs
let sqty = sg.qty * qty
qout <- checkC (extendTyLet sqty body.name eres.type (E rhs) ctx)
sg body.term (weakT 1 ty)
>>= popQ loc sqty
pure $ qty * eres.qout + qout
check' ctx sg (E e) ty = do
-- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ
infres <- inferC ctx sg e
-- if Ψ | Γ ⊢ A' <: A
lift $ subtype e.loc ctx infres.type ty
-- then Ψ | Γ ⊢ σ · e ⇐ A ⊳ Σ
pure infres.qout
export covering
infer' : {d, n : Nat} ->
(ctx : TyContext d n) -> (sg : Qty) -> (0 _ : IsSubj sg) =>
(subj : NotCloElim d n) ->
m (InferResult d n)
private covering
checkType' : TyContext d n ->
(subj : Term d n) -> (0 nc : NotClo subj) =>
Maybe Universe -> Eff TC ()
infer' ctx sg (Element (F x) _) = do
Just g <- asks $ lookup x | Nothing => throwError $ NotInScope x
when (isZero g) $ expectEqualQ sg Zero
pure $ InfRes {type = g.type.def, qout = zero}
checkType' ctx (TYPE k loc) u = do
-- if 𝓀 < then Ψ | Γ ⊢₀ Type 𝓀 ⇐ Type
case u of
Just l => unless (k < l) $ throw $ BadUniverse loc k l
Nothing => pure ()
infer' ctx sg (Element (B i) _) =
pure $ lookupBound sg i ctx
checkType' ctx (IOState loc) u = pure ()
-- Ψ | Γ ⊢₀ IOState ⇒ Type
infer' ctx sg (Element (fun :@ arg) _) = do
funres <- infer ctx sg fun
(qty, argty, res) <- expectPi funres.type
let Element sg' _ = subjMult sg qty
argout <- check ctx sg' arg argty
pure $ InfRes {type = fromScopeTerm res //. ((arg :# argty) ::: id),
qout = funres.qout + argout}
checkType' ctx (Pi qty arg res _) u = do
-- if Ψ | Γ ⊢₀ A ⇐ Type
checkTypeC ctx arg u
-- if Ψ | Γ, x : A ⊢₀ B ⇐ Type
checkTypeScope ctx arg res u
-- then Ψ | Γ ⊢₀ (π·x : A) → B ⇐ Type
infer' ctx sg (Element (tm :# ty) _) = do
ignore $ check ctx zero ty (TYPE UAny)
qout <- check ctx sg tm ty
pure $ InfRes {type = ty, qout}
checkType' ctx t@(Lam {}) u =
throw $ NotType t.loc ctx t
checkType' ctx (Sig fst snd _) u = do
-- if Ψ | Γ ⊢₀ A ⇐ Type
checkTypeC ctx fst u
-- if Ψ | Γ, x : A ⊢₀ B ⇐ Type
checkTypeScope ctx fst snd u
-- then Ψ | Γ ⊢₀ (x : A) × B ⇐ Type
checkType' ctx t@(Pair {}) u =
throw $ NotType t.loc ctx t
checkType' ctx (Enum {}) u = pure ()
-- Ψ | Γ ⊢₀ {ts} ⇐ Type
checkType' ctx t@(Tag {}) u =
throw $ NotType t.loc ctx t
checkType' ctx (Eq t l r _) u = do
-- if Ψ, i | Γ ⊢₀ A ⇐ Type
case t.body of
Y t' => checkTypeC (extendDim t.name ctx) t' u
N t' => checkTypeC ctx t' u
-- if Ψ | Γ ⊢₀ l ⇐ A0
check0 ctx l t.zero
-- if Ψ | Γ ⊢₀ r ⇐ A1
check0 ctx r t.one
-- then Ψ | Γ ⊢₀ Eq [i ⇒ A] l r ⇐ Type
checkType' ctx t@(DLam {}) u =
throw $ NotType t.loc ctx t
checkType' ctx (NAT {}) u = pure ()
checkType' ctx t@(Nat {}) u = throw $ NotType t.loc ctx t
checkType' ctx t@(Succ {}) u = throw $ NotType t.loc ctx t
checkType' ctx (STRING loc) u = pure ()
-- Ψ | Γ ⊢₀ STRING ⇒ Type
checkType' ctx t@(Str {}) u = throw $ NotType t.loc ctx t
checkType' ctx (BOX q ty _) u = checkType ctx ty u
checkType' ctx t@(Box {}) u = throw $ NotType t.loc ctx t
checkType' ctx (Let qty rhs body loc) u = do
expectEqualQ loc qty Zero
ety <- inferC ctx SZero rhs
checkType (extendTy Zero body.name ety.type ctx) body.term u
checkType' ctx (E e) u = do
-- if Ψ | Γ ⊢₀ E ⇒ Type
infres <- inferC ctx SZero e
-- if Ψ | Γ ⊢ Type <: Type 𝓀
case u of
Just u => lift $ subtype e.loc ctx infres.type (TYPE u e.loc)
Nothing => ignore $ expectTYPE !(askAt DEFS) ctx SZero e.loc infres.type
-- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀
private covering
checkTypeScope : TyContext d n -> Term d n ->
ScopeTerm d n -> Maybe Universe -> Eff TC ()
checkTypeScope ctx s (S _ (N body)) u = checkType ctx body u
checkTypeScope ctx s (S [< x] (Y body)) u =
checkType (extendTy Zero x s ctx) body u
private covering
infer' : TyContext d n -> SQty ->
(subj : Elim d n) -> (0 nc : NotClo subj) =>
Eff TC (InferResult' d n)
infer' ctx sg (F x u loc) = do
-- if π·x : A {≔ s} in global context
g <- lookupFree x loc !(askAt DEFS)
-- if σ ≤ π
expectCompatQ loc sg.qty g.qty.qty
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
pure $ InfRes {
type = g.typeWithAt ctx.dimLen ctx.termLen u,
qout = zeroFor ctx
}
infer' ctx sg (B i _) =
-- if x : A ∈ Γ
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ (𝟎, σ·x, 𝟎)
pure $ lookupBound sg.qty i ctx.tctx
where
lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n
lookupBound pi VZ (ctx :< var) =
InfRes {type = weakT 1 var.type, qout = zeroFor ctx :< pi}
lookupBound pi (VS i) (ctx :< _) =
let InfRes {type, qout} = lookupBound pi i ctx in
InfRes {type = weakT 1 type, qout = qout :< Zero}
infer' ctx sg (App fun arg loc) = do
-- if Ψ | Γ ⊢ σ · f ⇒ (π·x : A) → B ⊳ Σ₁
funres <- inferC ctx sg fun
(qty, argty, res) <- expectPi !(askAt DEFS) ctx SZero fun.loc funres.type
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ₂
argout <- checkC ctx (subjMult sg qty) arg argty
-- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + πΣ₂
pure $ InfRes {
type = sub1 res $ Ann arg argty arg.loc,
qout = funres.qout + qty * argout
}
infer' ctx sg (CasePair pi pair ret body loc) = do
-- no check for 1 ≤ π, since pairs have a single constructor.
-- e.g. at 0 the components are also 0 in the body
--
-- if Ψ | Γ ⊢ σ · pair ⇒ (x : A) × B ⊳ Σ₁
pairres <- inferC ctx sg pair
-- if Ψ | Γ, p : (x : A) × B ⊢₀ ret ⇐ Type
checkTypeC (extendTy Zero ret.name pairres.type ctx) ret.term Nothing
(tfst, tsnd) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
-- if Ψ | Γ, x : A, y : B ⊢ σ · body ⇐
-- ret[(x, y) ∷ (x : A) × B/p] ⊳ Σ₂, ρ₁·x, ρ₂·y
-- with ρ₁, ρ₂ ≤ πσ
let [< x, y] = body.names
pisg = pi * sg.qty
bodyctx = extendTyN [< (pisg, x, tfst), (pisg, y, tsnd.term)] ctx
bodyty = substCasePairRet body.names pairres.type ret
bodyout <- checkC bodyctx sg body.term bodyty >>=
popQs loc [< pisg, pisg]
-- then Ψ | Γ ⊢ σ · caseπ ⋯ ⇒ ret[pair/p] ⊳ πΣ₁ + Σ₂
pure $ InfRes {
type = sub1 ret pair,
qout = pi * pairres.qout + bodyout
}
infer' ctx sg (Fst pair loc) = do
-- if Ψ | Γ ⊢ σ · e ⇒ (x : A) × B ⊳ Σ
pairres <- inferC ctx sg pair
(tfst, _) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
-- then Ψ | Γ ⊢ σ · fst e ⇒ A ⊳ ωΣ
pure $ InfRes {
type = tfst,
qout = Any * pairres.qout
}
infer' ctx sg (Snd pair loc) = do
-- if Ψ | Γ ⊢ σ · e ⇒ (x : A) × B ⊳ Σ
pairres <- inferC ctx sg pair
(_, tsnd) <- expectSig !(askAt DEFS) ctx SZero pair.loc pairres.type
-- then Ψ | Γ ⊢ σ · snd e ⇒ B[fst e/x] ⊳ ωΣ
pure $ InfRes {
type = sub1 tsnd (Fst pair loc),
qout = Any * pairres.qout
}
infer' ctx sg (CaseEnum pi t ret arms loc) {d, n} = do
-- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁
tres <- inferC ctx sg t
ttags <- expectEnum !(askAt DEFS) ctx SZero t.loc tres.type
-- if 1 ≤ π, OR there is only zero or one option
unless (length (SortedSet.toList ttags) <= 1) $ expectCompatQ loc One pi
-- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type
checkTypeC (extendTy Zero ret.name tres.type ctx) ret.term Nothing
-- if for each "a ⇒ s" in arms,
-- Ψ | Γ ⊢ σ · s ⇐ A[a ∷ {ts}/x] ⊳ Σᵢ
-- with Σ₂ = lubs Σᵢ
let arms = SortedMap.toList arms
let armTags = SortedSet.fromList $ map fst arms
unless (ttags == armTags) $ throw $ BadCaseEnum loc ttags armTags
armres <- for arms $ \(a, s) =>
checkC ctx sg s $ sub1 ret $ Ann (Tag a s.loc) tres.type s.loc
pure $ InfRes {
type = sub1 ret t,
qout = pi * tres.qout + lubs ctx armres
}
infer' ctx sg (CaseNat pi pi' n ret zer suc loc) = do
-- if 1 ≤ π
expectCompatQ loc One pi
-- if Ψ | Γ ⊢ σ · n ⇒ ⊳ Σn
nres <- inferC ctx sg n
let nat = nres.type
expectNAT !(askAt DEFS) ctx SZero n.loc nat
-- if Ψ | Γ, n : ⊢₀ A ⇐ Type
checkTypeC (extendTy Zero ret.name nat ctx) ret.term Nothing
-- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ /n] ⊳ Σz
zerout <- checkC ctx sg zer $ sub1 ret $ Ann (Zero zer.loc) nat zer.loc
-- if Ψ | Γ, n : , ih : A ⊢ σ · suc ⇐ A[succ p ∷ /n] ⊳ Σs, ρ.p, ς.ih
-- with ς ≤ π'σ, (ρ + ς) ≤ πσ
let [< p, ih] = suc.names
pisg = pi * sg.qty
sucCtx = extendTyN [< (pisg, p, NAT p.loc), (pi', ih, ret.term)] ctx
sucType = substCaseSuccRet suc.names ret
sucout :< qp :< qih <- checkC sucCtx sg suc.term sucType
expectCompatQ loc qih (pi' * sg.qty)
-- [fixme] better error here
expectCompatQ loc (qp + qih) pisg
-- if ς = 0, then Σb = lubs(Σz, Σs), otherwise Σb = Σz + ωςΣs
let bodyout = case qih of
Zero => lubs ctx [zerout, sucout]
_ => zerout + Any * sucout
-- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σb
pure $ InfRes {
type = sub1 ret n,
qout = pi * nres.qout + bodyout
}
infer' ctx sg (CaseBox pi box ret body loc) = do
-- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁
boxres <- inferC ctx sg box
(rh, ty) <- expectBOX !(askAt DEFS) ctx SZero box.loc boxres.type
-- if Ψ | Γ, x : [ρ.A] ⊢₀ R ⇐ Type
checkTypeC (extendTy Zero ret.name boxres.type ctx) ret.term Nothing
-- if Ψ | Γ, x : A ⊢ σ · t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x
-- with ς ≤ ρπσ
let rhpisg = rh * pi * sg.qty
bodyCtx = extendTy rhpisg body.name ty ctx
bodyType = substCaseBoxRet body.name ty ret
bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc rhpisg
-- then Ψ | Γ ⊢ caseπ ⋯ ⇒ R[b/x] ⊳ Σ₁ + Σ₂
pure $ InfRes {
type = sub1 ret box,
qout = boxres.qout + bodyout
}
infer' ctx sg (DApp fun dim loc) = do
-- if Ψ | Γ ⊢ σ · f ⇒ Eq [𝑖 ⇒ A] l r ⊳ Σ
InfRes {type, qout} <- inferC ctx sg fun
ty <- fst <$> expectEq !(askAt DEFS) ctx SZero fun.loc type
-- then Ψ | Γ ⊢ σ · f p ⇒ Ap/𝑖 ⊳ Σ
pure $ InfRes {type = dsub1 ty dim, qout}
infer' ctx sg (Coe ty p q val loc) = do
-- if Ψ, 𝑖 | Γ ⊢₀ A ⇐ Type _
checkType (extendDim ty.name ctx) ty.term Nothing
-- if Ψ | Γ ⊢ σ · s ⇐ Ap/𝑖 ⊳ Σ
qout <- checkC ctx sg val $ dsub1 ty p
-- then Ψ | Γ ⊢ σ · coe (𝑖 ⇒ A) @p @q s ⇒ Aq/𝑖 ⊳ Σ
pure $ InfRes {type = dsub1 ty q, qout}
infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1) loc) = do
-- if Ψ | Γ ⊢₀ A ⇐ Type _
checkType ctx ty Nothing
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
qout <- checkC ctx sg val ty
-- if Ψ, 𝑗, 𝑖=0 | Γ ⊢ σ · t₀ ⇐ A ⊳ Σ₀
-- Ψ, 𝑗, 𝑖=0, 𝑗=p | Γ ⊢ t₀ = s ⇐ A
let ty' = dweakT 1 ty; val' = dweakT 1 val; p' = weakD 1 p
ctx0 = extendDim j0 $ eqDim r (K Zero j0.loc) ctx
val0 = getTerm val0
qout0 <- check ctx0 sg val0 ty'
lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) sg ty' val0 val'
-- if Ψ, 𝑗, 𝑖=1 | Γ ⊢ σ · t₁ ⇐ A ⊳ Σ₁
-- Ψ, 𝑗, 𝑖=1, 𝑗=p | Γ ⊢ t₁ = s ⇐ A
let ctx1 = extendDim j1 $ eqDim r (K One j1.loc) ctx
val1 = getTerm val1
qout1 <- check ctx1 sg val1 ty'
-- if Σ = Σ₀ = Σ₁
lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) sg ty' val1 val'
let qouts = qout :: catMaybes [toMaybe qout0, toMaybe qout1]
-- then Ψ | Γ ⊢ comp A @p @q s @r {0 𝑗 ⇒ t₀; 1 𝑗 ⇒ t₁} ⇒ A ⊳ Σ
pure $ InfRes {type = ty, qout = lubs ctx qouts}
infer' ctx sg (TypeCase ty ret arms def loc) = do
-- if σ = 0
expectEqualQ loc Zero sg.qty
-- if Ψ, Γ ⊢₀ e ⇒ Type u
u <- inferC ctx SZero ty >>=
expectTYPE !(askAt DEFS) ctx SZero ty.loc . type
-- if Ψ, Γ ⊢₀ C ⇐ Type (non-dependent return type)
checkTypeC ctx ret Nothing
-- if Ψ, Γ' ⊢₀ A ⇐ C for each rhs A
for_ allKinds $ \k =>
for_ (lookupPrecise k arms) $ \(S names t) =>
check0 (extendTyN (typecaseTel k names u) ctx)
(getTerm t) (weakT (arity k) ret)
-- then Ψ, Γ ⊢₀ type-case ⋯ ⇒ C
pure $ InfRes {type = ret, qout = zeroFor ctx}
infer' ctx sg (Ann term type loc) = do
-- if Ψ | Γ ⊢₀ A ⇐ Type
checkTypeC ctx type Nothing
-- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ
qout <- checkC ctx sg term type
-- then Ψ | Γ ⊢ σ · (s ∷ A) ⇒ A ⊳ Σ
pure $ InfRes {type, qout}

View File

@ -1,108 +1,184 @@
module Quox.Typing
import public Quox.Typing.Context as Typing
import public Quox.Typing.EqMode as Typing
import public Quox.Typing.Error as Typing
import public Quox.Syntax
import public Quox.Context
import public Quox.Definition
import public Quox.Whnf
import public Quox.Pretty
import Data.Nat
import public Data.SortedMap
import Control.Monad.Reader
import Control.Monad.State
import Generics.Derive
import Language.Reflection
import Control.Eff
%hide TT.Name
%default total
%language ElabReflection
%default total
private TTName : Type
TTName = TT.Name
%hide TT.Name
public export
data DContext : Nat -> Type where
DNil : DContext 0
DBind : DContext d -> DContext (S d)
DEq : Dim d -> Dim d -> DContext d -> DContext d
CheckResult' : Nat -> Type
CheckResult' = QOutput
public export
TContext : Nat -> Nat -> Type
TContext d = Context (Term d)
CheckResult : DimEq d -> Nat -> Type
CheckResult eqs n = IfConsistent eqs $ CheckResult' n
public export
QContext : Nat -> Type
QContext = Context' Qty
public export
QOutput : Nat -> Type
QOutput = QContext
public export
record TyContext (d, n : Nat) where
constructor MkTyContext
dctx : DContext d
tctx : TContext d n
qctx : QContext n
%name TyContext ctx
namespace TContext
export
pushD : TContext d n -> TContext (S d) n
pushD tel = map (/// shift 1) tel
namespace TyContext
export
extendTy : Term d n -> Qty -> TyContext d n -> TyContext d (S n)
extendTy s rho = {tctx $= (:< s), qctx $= (:< rho)}
export
extendDim : TyContext d n -> TyContext (S d) n
extendDim = {dctx $= DBind, tctx $= pushD}
export
eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n
eqDim p q = {dctx $= DEq p q}
namespace QOutput
export
(+) : QOutput n -> QOutput n -> QOutput n
(+) = zipWith (+)
export
(*) : Qty -> QOutput n -> QOutput n
(*) pi = map (pi *)
export
zero : {n : Nat} -> QOutput n
zero = pure Zero
public export
CheckResult : Nat -> Type
CheckResult = QOutput
public export
record InferResult d n where
record InferResult' d n where
constructor InfRes
type : Term d n
qout : QOutput n
public export
data EqMode = Equal | Sub
%runElab derive "EqMode" [Generic, Meta, Eq, Ord, DecEq, Show]
InferResult : DimEq d -> TermLike
InferResult eqs d n = IfConsistent eqs $ InferResult' d n
export
lookupFree : Has ErrorEff fs => Name -> Loc -> Definitions -> Eff fs Definition
lookupFree x loc defs = maybe (throw $ NotInScope loc x) pure $ lookup x defs
public export
data Error
= ExpectedTYPE (Term d n)
| ExpectedPi (Term d n)
| BadUniverse Universe Universe
substCasePairRet : BContext 2 -> Term d n -> ScopeTerm d n -> Term d (2 + n)
substCasePairRet [< x, y] dty retty =
let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc
arg = Ann tm (dty // fromNat 2) tm.loc in
retty.term // (arg ::: shift 2)
| ClashT EqMode (Term d n) (Term d n)
| ClashU EqMode Universe Universe
| ClashQ Qty Qty
| NotInScope Name
public export
substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n)
substCaseSuccRet [< p, ih] retty =
let loc = p.loc `extendL` ih.loc
arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT p.loc) loc in
retty.term // (arg ::: shift 2)
public export
substCaseBoxRet : BindName -> Term d n -> ScopeTerm d n -> Term d (S n)
substCaseBoxRet x dty retty =
let arg = Ann (Box (BVT 0 x.loc) x.loc) (weakT 1 dty) x.loc in
retty.term // (arg ::: shift 1)
private
0 ExpectErrorConstructor : Type
ExpectErrorConstructor =
forall d, n. Loc -> NameContexts d n -> Term d n -> Error
parameters (defs : Definitions)
{auto _ : (Has ErrorEff fs, Has NameGen fs, Has Log fs)}
namespace TyContext
parameters (ctx : TyContext d n) (sg : SQty) (loc : Loc)
export covering
whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
tm d n -> Eff fs (NonRedex tm d n defs (toWhnfContext ctx) sg)
whnf tm = do
let Val n = ctx.termLen; Val d = ctx.dimLen
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
rethrow res
private covering %macro
expect : ExpectErrorConstructor -> TTImp -> TTImp ->
Elab (Term d n -> Eff fs a)
expect err pat rhs = Prelude.do
match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
pure $ \term => do
res <- whnf term
maybe (throw $ err loc ctx.names term) pure $ match $ fst res
export covering %inline
expectTYPE : Term d n -> Eff fs Universe
expectTYPE = expect ExpectedTYPE `(TYPE {l, _}) `(l)
export covering %inline
expectPi : Term d n -> Eff fs (Qty, Term d n, ScopeTerm d n)
expectPi = expect ExpectedPi `(Pi {qty, arg, res, _}) `((qty, arg, res))
export covering %inline
expectSig : Term d n -> Eff fs (Term d n, ScopeTerm d n)
expectSig = expect ExpectedSig `(Sig {fst, snd, _}) `((fst, snd))
export covering %inline
expectEnum : Term d n -> Eff fs (SortedSet TagVal)
expectEnum = expect ExpectedEnum `(Enum {cases, _}) `(cases)
export covering %inline
expectEq : Term d n -> Eff fs (DScopeTerm d n, Term d n, Term d n)
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
export covering %inline
expectNAT : Term d n -> Eff fs ()
expectNAT = expect ExpectedNAT `(NAT {}) `(())
export covering %inline
expectSTRING : Term d n -> Eff fs ()
expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
export covering %inline
expectBOX : Term d n -> Eff fs (Qty, Term d n)
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
export covering %inline
expectIOState : Term d n -> Eff fs ()
expectIOState = expect ExpectedIOState `(IOState {}) `(())
namespace EqContext
parameters (ctx : EqContext n) (sg : SQty) (loc : Loc)
export covering
whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
tm 0 n -> Eff fs (NonRedex tm 0 n defs (toWhnfContext ctx) sg)
whnf tm = do
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
rethrow res
private covering %macro
expect : ExpectErrorConstructor -> TTImp -> TTImp ->
Elab (Term 0 n -> Eff fs a)
expect err pat rhs = do
match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing)
pure $ \term => do
res <- whnf term
let t0 = delay $ term // shift0 ctx.dimLen
maybe (throw $ err loc ctx.names t0) pure $ match $ fst res
export covering %inline
expectTYPE : Term 0 n -> Eff fs Universe
expectTYPE = expect ExpectedTYPE `(TYPE {l, _}) `(l)
export covering %inline
expectPi : Term 0 n -> Eff fs (Qty, Term 0 n, ScopeTerm 0 n)
expectPi = expect ExpectedPi `(Pi {qty, arg, res, _}) `((qty, arg, res))
export covering %inline
expectSig : Term 0 n -> Eff fs (Term 0 n, ScopeTerm 0 n)
expectSig = expect ExpectedSig `(Sig {fst, snd, _}) `((fst, snd))
export covering %inline
expectEnum : Term 0 n -> Eff fs (SortedSet TagVal)
expectEnum = expect ExpectedEnum `(Enum {cases, _}) `(cases)
export covering %inline
expectEq : Term 0 n -> Eff fs (DScopeTerm 0 n, Term 0 n, Term 0 n)
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
export covering %inline
expectNAT : Term 0 n -> Eff fs ()
expectNAT = expect ExpectedNAT `(NAT {}) `(())
export covering %inline
expectSTRING : Term 0 n -> Eff fs ()
expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
export covering %inline
expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n)
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
export covering %inline
expectIOState : Term 0 n -> Eff fs ()
expectIOState = expect ExpectedIOState `(IOState {}) `(())

402
lib/Quox/Typing/Context.idr Normal file
View File

@ -0,0 +1,402 @@
module Quox.Typing.Context
import Quox.Syntax
import Quox.Context
import Quox.Pretty
import public Data.Singleton
import Derive.Prelude
%default total
%language ElabReflection
public export
QContext : Nat -> Type
QContext = Context' Qty
public export
record LocalVar d n where
constructor MkLocal
type : Term d n
term : Maybe (Term d n) -- if from a `let`
%runElab deriveIndexed "LocalVar" [Show]
namespace LocalVar
export %inline
letVar : (type, term : Term d n) -> LocalVar d n
letVar type term = MkLocal {type, term = Just term}
export %inline
lamVar : (type : Term d n) -> LocalVar d n
lamVar type = MkLocal {type, term = Nothing}
export %inline
mapVar : (Term d n -> Term d' n') -> LocalVar d n -> LocalVar d' n'
mapVar f = {type $= f, term $= map f}
export %inline
subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n
subD th = mapVar (// th)
export %inline
weakD : LocalVar d n -> LocalVar (S d) n
weakD = subD $ shift 1
export %inline CanShift (LocalVar d) where l // by = mapVar (// by) l
export %inline CanDSubst LocalVar where l // by = mapVar (// by) l
export %inline CanTSubst LocalVar where l // by = mapVar (// by) l
public export
TContext : TermLike
TContext d = Context (LocalVar d)
public export
QOutput : Nat -> Type
QOutput = Context' Qty
public export
DimAssign : Nat -> Type
DimAssign = Context' DimConst
public export
record TyContext d n where
constructor MkTyContext
{auto dimLen : Singleton d}
{auto termLen : Singleton n}
dctx : DimEq d
dnames : BContext d -- only used for printing
tctx : TContext d n
tnames : BContext n -- only used for printing
qtys : QContext n -- only used for printing
%name TyContext ctx
%runElab deriveIndexed "TyContext" [Show]
public export
record EqContext n where
constructor MkEqContext
{dimLen : Nat}
{auto termLen : Singleton n}
dassign : DimAssign dimLen -- only used for printing
dnames : BContext dimLen -- only used for printing
tctx : TContext 0 n
tnames : BContext n -- only used for printing
qtys : QContext n -- only used for printing
%name EqContext ctx
%runElab deriveIndexed "EqContext" [Show]
public export
record WhnfContext d n where
constructor MkWhnfContext
{auto dimLen : Singleton d}
{auto termLen : Singleton n}
dnames : BContext d
tnames : BContext n
tctx : TContext d n
%name WhnfContext ctx
%runElab deriveIndexed "WhnfContext" [Show]
namespace TContext
export %inline
zeroFor : Context tm n -> QOutput n
zeroFor ctx = Zero <$ ctx
public export
extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
extendLen [<] x = x
extendLen (tel :< _) x = [|S $ extendLen tel x|]
public export
CtxExtension : Nat -> Nat -> Nat -> Type
CtxExtension d = Telescope ((Qty, BindName,) . Term d)
public export
CtxExtension0 : Nat -> Nat -> Nat -> Type
CtxExtension0 d = Telescope ((BindName,) . Term d)
public export
CtxExtensionLet : Nat -> Nat -> Nat -> Type
CtxExtensionLet d = Telescope ((Qty, BindName,) . LocalVar d)
public export
CtxExtensionLet0 : Nat -> Nat -> Nat -> Type
CtxExtensionLet0 d = Telescope ((BindName,) . LocalVar d)
namespace TyContext
public export %inline
empty : TyContext 0 0
empty = MkTyContext {
dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]
}
public export %inline
null : TyContext d n -> Bool
null ctx = null ctx.dnames && null ctx.tnames
export %inline
extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
let (qs, xs, ls) = unzip3 xss in
MkTyContext {
dctx, dnames,
termLen = extendLen xss termLen,
tctx = tctx . ls,
tnames = tnames . xs,
qtys = qtys . qs
}
export %inline
extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
export %inline
extendTyLetN0 : CtxExtensionLet0 d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
export %inline
extendTyN0 : CtxExtension0 d n1 n2 -> TyContext d n1 -> TyContext d n2
extendTyN0 xss = extendTyN (map (Zero,) xss)
export %inline
extendTyLet : Qty -> BindName -> Term d n -> Term d n ->
TyContext d n -> TyContext d (S n)
extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
export %inline
extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
extendTy q x s = extendTyN [< (q, x, s)]
export %inline
extendTy0 : BindName -> Term d n -> TyContext d n -> TyContext d (S n)
extendTy0 = extendTy Zero
export %inline
extendDim : BindName -> TyContext d n -> TyContext (S d) n
extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
MkTyContext {
dctx = dctx :<? Nothing,
dnames = dnames :< x,
dimLen = [|S dimLen|],
tctx = map weakD tctx,
tnames, qtys
}
export %inline
eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n
eqDim p q = {dctx $= set p q, dimLen $= id, termLen $= id}
export
toWhnfContext : TyContext d n -> WhnfContext d n
toWhnfContext (MkTyContext {dnames, tnames, tctx, _}) =
MkWhnfContext {dnames, tnames, tctx}
namespace QOutput
export %inline
(+) : QOutput n -> QOutput n -> QOutput n
(+) = zipWith (+)
export %inline
(*) : Qty -> QOutput n -> QOutput n
(*) pi = map (pi *)
export %inline
zeroFor : TyContext _ n -> QOutput n
zeroFor ctx = zeroFor ctx.tctx
export
makeDAssign : DSubst d 0 -> DimAssign d
makeDAssign (Shift SZ) = [<]
makeDAssign (K e _ ::: th) = makeDAssign th :< e
export
makeEqContext' : {d : Nat} -> TyContext d n -> DSubst d 0 -> EqContext n
makeEqContext' ctx th = MkEqContext {
termLen = ctx.termLen,
dassign = makeDAssign th,
dnames = ctx.dnames,
tctx = map (subD th) ctx.tctx,
tnames = ctx.tnames,
qtys = ctx.qtys
}
export
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
makeEqContext ctx@(MkTyContext {dnames, _}) th =
let Val d = lengthPrf0 dnames in makeEqContext' ctx th
namespace EqContext
public export %inline
empty : EqContext 0
empty = MkEqContext {
dassign = [<], dnames = [<], tctx = [<], tnames = [<], qtys = [<]
}
public export %inline
null : EqContext n -> Bool
null ctx = null ctx.dnames && null ctx.tnames
export %inline
extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
let (qs, xs, ls) = unzip3 xss in
MkEqContext {
termLen = extendLen xss termLen,
tctx = tctx . ls,
tnames = tnames . xs,
qtys = qtys . qs,
dassign, dnames
}
export %inline
extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s))
export %inline
extendTyLetN0 : CtxExtensionLet0 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)
export %inline
extendTyN0 : CtxExtension0 0 n1 n2 -> EqContext n1 -> EqContext n2
extendTyN0 xss = extendTyN (map (Zero,) xss)
export %inline
extendTyLet : Qty -> BindName -> Term 0 n -> Term 0 n ->
EqContext n -> EqContext (S n)
extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)]
export %inline
extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
extendTy q x s = extendTyN [< (q, x, s)]
export %inline
extendTy0 : BindName -> Term 0 n -> EqContext n -> EqContext (S n)
extendTy0 = extendTy Zero
export %inline
extendDim : BindName -> DimConst -> EqContext n -> EqContext n
extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) =
MkEqContext {dassign = dassign :< e, dnames = dnames :< x,
tctx, tnames, qtys}
export
toTyContext : (e : EqContext n) -> TyContext e.dimLen n
toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
MkTyContext {
dctx = fromGround dnames dassign,
tctx = map (subD $ shift0 dimLen) tctx,
dnames, tnames, qtys
}
export
toWhnfContext : (ectx : EqContext n) -> WhnfContext 0 n
toWhnfContext (MkEqContext {tnames, tctx, _}) =
MkWhnfContext {dnames = [<], tnames, tctx}
export
injElim : WhnfContext d n -> Elim 0 0 -> Elim d n
injElim ctx e =
let Val d = ctx.dimLen; Val n = ctx.termLen in
e // shift0 d // shift0 n
namespace WhnfContext
public export %inline
empty : WhnfContext 0 0
empty = MkWhnfContext [<] [<] [<]
export
extendTy' : BindName -> LocalVar d n -> WhnfContext d n -> WhnfContext d (S n)
extendTy' x var (MkWhnfContext {termLen, dnames, tnames, tctx}) =
MkWhnfContext {
dnames,
termLen = [|S termLen|],
tnames = tnames :< x,
tctx = tctx :< var
}
export %inline
extendTy : BindName -> Term d n -> WhnfContext d n -> WhnfContext d (S n)
extendTy x ty ctx = extendTy' x (lamVar ty) ctx
export %inline
extendTyLet : BindName -> (type, term : Term d n) ->
WhnfContext d n -> WhnfContext d (S n)
extendTyLet x type term ctx = extendTy' x (letVar {type, term}) ctx
export
extendDimN : {s : Nat} -> BContext s -> WhnfContext d n ->
WhnfContext (s + d) n
extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) =
MkWhnfContext {
dimLen = [|Val s + dimLen|],
dnames = dnames ++ toSnocVect' ns,
tctx = map (subD $ shift s) tctx,
tnames
}
export
extendDim : BindName -> WhnfContext d n -> WhnfContext (S d) n
extendDim i = extendDimN [< i]
private
prettyTContextElt : {opts : _} ->
BContext d -> BContext n ->
Doc opts -> BindName -> LocalVar d n ->
Eff Pretty (Doc opts)
prettyTContextElt dnames tnames q x s = do
dot <- dotD
x <- prettyTBind x; colon <- colonD
ty <- withPrec Outer $ prettyTerm dnames tnames s.type; eq <- cstD
tm <- traverse (withPrec Outer . prettyTerm dnames tnames) s.term
d <- askAt INDENT
let qx = hcat [q, dot, x]
pure $ case tm of
Nothing =>
ifMultiline (hsep [qx, colon, ty]) (vsep [qx, indent d $ colon <++> ty])
Just tm =>
ifMultiline (hsep [qx, colon, ty, eq, tm])
(vsep [qx, indent d $ colon <++> ty, indent d $ eq <++> tm])
private
prettyTContext' : {opts : _} ->
BContext d -> Context' (Doc opts) n -> BContext n ->
TContext d n -> Eff Pretty (SnocList (Doc opts))
prettyTContext' _ [<] [<] [<] = pure [<]
prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
[|prettyTContext' dnames qtys tnames tys :<
prettyTContextElt dnames tnames q x t|]
export
prettyTContext : {opts : _} ->
BContext d -> QContext n -> BContext n ->
TContext d n -> Eff Pretty (Doc opts)
prettyTContext dnames qtys tnames tys = do
comma <- commaD
qtys <- traverse prettyQty qtys
sepSingle . exceptLast (<+> comma) . toList <$>
prettyTContext' dnames qtys tnames tys
export
prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
case dctx of
C [<] => prettyTContext dnames qtys tnames tctx
_ => pure $
sepSingle [!(prettyDimEq dnames dctx) <++> !pipeD,
!(prettyTContext dnames qtys tnames tctx)]
export
prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts)
prettyEqContext ctx = prettyTyContext $ toTyContext ctx
export
prettyWhnfContext : {opts : _} -> WhnfContext d n -> Eff Pretty (Doc opts)
prettyWhnfContext ctx =
let Val n = ctx.termLen in
sepSingle . exceptLast (<+> comma) . toList <$>
prettyTContext' ctx.dnames (replicate n "_") ctx.tnames ctx.tctx

View File

@ -0,0 +1,22 @@
module Quox.Typing.EqMode
import Quox.Syntax
import Derive.Prelude
%language ElabReflection
%default total
public export
data EqMode = Equal | Sub | Super
%runElab derive "EqMode" [Eq, Ord, Show]
export %inline
ucmp : EqMode -> Universe -> Universe -> Bool
ucmp Equal = (==)
ucmp Sub = (<=)
ucmp Super = (>=)
export %inline
flip : EqMode -> EqMode
flip Equal = Equal
flip Sub = Super
flip Super = Sub

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