├── .gitignore ├── LICENSE ├── README.md ├── create-local-switch.sh ├── dune ├── dune-project ├── melitte.opam ├── src ├── Core.ml ├── Core.mli ├── DeBruijn.ml ├── DeBruijn.mli ├── Elaborator.ml ├── Elaborator.mli ├── Error.ml ├── ExtPrint.ml ├── Lex.ml ├── Monad.ml ├── Monad.mli ├── Name.ml ├── Name.mli ├── Options.ml ├── Parse.mly ├── Position.ml ├── Position.mli ├── Raw.ml ├── Raw.mli ├── Semantics.ml ├── Semantics.mli ├── Sigs.ml ├── UnicodeSigil.ml ├── UnicodeSigil.mli ├── UniverseLevel.ml ├── UniverseLevel.mli ├── Var.ml ├── Var.mli ├── dune └── melitte.ml └── tests ├── dune └── simple.t ├── run.t ├── simple.melitte ├── t1.melitte ├── t2.melitte ├── t3.melitte ├── t4.melitte └── t5.melitte /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild and dune working directory 12 | _build/ 13 | 14 | # ocamlbuild and dune targets 15 | *.byte 16 | *.native 17 | *.exe 18 | 19 | # oasis generated files 20 | setup.data 21 | setup.log 22 | 23 | # Merlin configuring file for Vim and Emacs 24 | .merlin 25 | 26 | # Dune generated files 27 | *.install 28 | 29 | # Local OPAM switch 30 | _opam/ 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mélitte 2 | 3 | This is *Mélitte*, a toy implementation of Martin-Löf Type Theory (MLTT) written 4 | in the OCaml language. 5 | 6 | ## Compiling 7 | 8 | To compile Mélitte, you need a working OCaml development environment and some 9 | libraries. The easiest and cleanest way to install them is to create a local 10 | OPAM switch. The repository provides a script to do so. 11 | 12 | ```shell 13 | $ ./create-local-switch.sh 14 | $ dune build 15 | ``` 16 | 17 | (The script also installs Tuareg and Merlin for developer convenience.) 18 | 19 | Some example programs to exercise the type-checker can be found in the 20 | [test](test/) directory. Run them using `dune test`. 21 | 22 | ## Inspirations 23 | 24 | Mélitte is strongly inspired from existing tutorial implementation of dependent 25 | type theory. Here are the ones I looked at: 26 | 27 | - Andràs Kovàcs' [elaboration 28 | zoo](https://github.com/AndrasKovacs/elaboration-zoo/). 29 | 30 | - Daniel Gratzer's [Normalization-by-Evaluation for 31 | MLTT](https://github.com/jozefg/nbe-for-mltt). 32 | 33 | - Jon Sterling's [DreamTT](https://github.com/jonsterling/dreamtt). 34 | 35 | ## Future Additions 36 | 37 | ### Foundations 38 | 39 | - inductive types (W-types, a universe of descriptions à la McBride-Dagand?) 40 | - universe of definitionally-irrelevant propositions 41 | 42 | ### Engineering 43 | 44 | - explicit telescopes as arguments of pi and sigma 45 | 46 | ### Usability 47 | 48 | - built-in non-dependent arrow and product types for better printing 49 | - basic module system 50 | - minimalistic Emacs mode with basic interaction facilities 51 | 52 | ### Refinement 53 | 54 | - unification facilities for metavariables and implicit arguments 55 | -------------------------------------------------------------------------------- /create-local-switch.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | set -e 4 | 5 | opam switch create --deps-only --with-doc --with-test -y . 6 | eval $(opam env) 7 | opam install -y tuareg merlin 8 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags (:standard -w -32 -w -37)))) 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.2) 2 | (using menhir 2.0) 3 | (cram enable) 4 | 5 | (name melitte) 6 | (version 0.0.1) 7 | 8 | (generate_opam_files true) 9 | 10 | (source 11 | (github username/reponame)) 12 | 13 | (authors "Adrien Guatto") 14 | (maintainers "Adrien Guatto") 15 | 16 | (license GPL-3.0-or-later) 17 | 18 | (package 19 | (name melitte) 20 | (synopsis "A toy implementation of Martin-Löf Type Theory") 21 | (description "") 22 | (depends (ocaml (> 4.14.0)) dune pprint menhir sedlex ppx_deriving sexplib 23 | ppx_sexp_conv)) 24 | -------------------------------------------------------------------------------- /melitte.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.0.1" 4 | synopsis: "A toy implementation of Martin-Löf Type Theory" 5 | description: "" 6 | maintainer: ["Adrien Guatto"] 7 | authors: ["Adrien Guatto"] 8 | license: "GPL-3.0-or-later" 9 | homepage: "https://github.com/username/reponame" 10 | bug-reports: "https://github.com/username/reponame/issues" 11 | depends: [ 12 | "ocaml" {> "4.14.0"} 13 | "dune" {>= "3.2"} 14 | "pprint" 15 | "menhir" 16 | "sedlex" 17 | "ppx_deriving" 18 | "sexplib" 19 | "ppx_sexp_conv" 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/username/reponame.git" 37 | -------------------------------------------------------------------------------- /src/Core.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | type cterm_desc = 4 | | Infer of iterm 5 | | Let of { def : cterm; ty : cterm; body : bound1; } 6 | | Pi of cterm * bound1 7 | | Lam of bound1 8 | | Sigma of cterm * bound1 9 | | Pair of cterm * cterm 10 | | Nat 11 | | Type of int 12 | 13 | and cterm = 14 | { 15 | c_desc : cterm_desc; 16 | c_loc : Position.t; 17 | [@equal fun _ _ -> true] 18 | [@sexp_drop_if fun _ -> true] 19 | } 20 | 21 | and iterm_desc = 22 | | Var of DeBruijn.Ix.t 23 | | App of iterm * cterm 24 | | Fst of iterm 25 | | Snd of iterm 26 | | Zero 27 | | Suc of cterm 28 | | Natelim of { scrut : cterm; 29 | motive : bound1; 30 | case_zero : cterm; 31 | case_suc : bound2; } 32 | | Annot of { tm : cterm; ty : cterm; } 33 | 34 | and iterm = 35 | { 36 | i_desc : iterm_desc; 37 | i_loc : Position.t; 38 | [@equal fun _ _ -> true] 39 | [@sexp_drop_if fun _ -> true] 40 | } 41 | 42 | and bound1 = 43 | Bound1 of { 44 | body : cterm; 45 | user : Name.t option; 46 | [@equal fun _ _ -> true] 47 | } 48 | 49 | and bound2 = 50 | Bound2 of { 51 | body : cterm; 52 | user1 : Name.t option; 53 | [@equal fun _ _ -> true] 54 | user2 : Name.t option; 55 | [@equal fun _ _ -> true] 56 | } 57 | 58 | and phrase_desc = 59 | | Val of { user : Name.t option; ty : cterm; def : cterm; } 60 | | Eval of { def : iterm; } 61 | 62 | and phrase = 63 | { 64 | ph_desc : phrase_desc; 65 | ph_loc : Position.t; 66 | [@equal fun _ _ -> true] 67 | [@sexp_drop_if fun _ -> true] 68 | } 69 | 70 | and t = phrase list [@@deriving sexp_of, eq] 71 | 72 | type ty = cterm 73 | 74 | type telescope = (Name.t option * ty) list 75 | 76 | module ToRaw = struct 77 | type env = Name.t DeBruijn.Env.t 78 | 79 | module M = Monad.Reader(struct type t = env end) 80 | open Monad.Notation(M) 81 | 82 | let lookup ix env = DeBruijn.Env.lookup env ix 83 | 84 | let (let$) p f env = 85 | let name = 86 | match p with 87 | | Some name -> name 88 | | None -> Name.internal @@ string_of_int @@ DeBruijn.Env.width env 89 | in 90 | f (Raw.Build.pvar ~name ()) (DeBruijn.Env.extend name env) 91 | 92 | let rec cterm { c_desc; c_loc; } = 93 | let* desc = 94 | match c_desc with 95 | | Infer tm -> 96 | let* tm = iterm tm in 97 | return @@ Position.value tm 98 | | Lam b -> 99 | let* b = bound1 b in 100 | return @@ Raw.Lam b 101 | | Pi (a, f) -> 102 | let* a = cterm a in 103 | let* f = bound1 f in 104 | return @@ Raw.Pi (a, f) 105 | | Sigma (a, f) -> 106 | let* a = cterm a in 107 | let* f = bound1 f in 108 | return @@ Raw.Sigma (a, f) 109 | | Pair (l, r) -> 110 | let* l = cterm l in 111 | let* r = cterm r in 112 | return @@ Raw.Pair (l, r) 113 | | Let { def; ty; body; } -> 114 | let* def = cterm def in 115 | let* ty = cterm ty in 116 | let* body = bound1 body in 117 | return @@ Raw.Let { def; ty; body; } 118 | | Type l -> 119 | return @@ Raw.Type l 120 | | Nat -> 121 | return Raw.Nat 122 | in 123 | return @@ Position.with_pos c_loc desc 124 | 125 | and iterm { i_desc; i_loc; } = 126 | let* desc = 127 | match i_desc with 128 | | Var ix -> 129 | let* x = DeBruijn.Env.lookup ix in 130 | return @@ Raw.Var x 131 | | App (t, u) -> 132 | let* t = iterm t in 133 | let* u = cterm u in 134 | return @@ Raw.App (t, u) 135 | | Fst m -> 136 | let* m = iterm m in 137 | return @@ Raw.Fst m 138 | | Snd m -> 139 | let* m = iterm m in 140 | return @@ Raw.Snd m 141 | | Zero -> 142 | return Raw.Zero 143 | | Suc t -> 144 | let* t = cterm t in 145 | return @@ Raw.Suc t 146 | | Natelim { scrut; motive; case_zero; case_suc; } -> 147 | let* scrut = cterm scrut in 148 | let* motive = bound1 motive in 149 | let* case_zero = cterm case_zero in 150 | let* case_suc = bound2 case_suc in 151 | return @@ Raw.Natelim { scrut; motive; case_zero; case_suc; } 152 | | Annot { tm; ty; } -> 153 | let* tm = cterm tm in 154 | let* ty = cterm ty in 155 | return @@ Raw.Annot { tm; ty; } 156 | in 157 | return @@ Position.with_pos i_loc desc 158 | 159 | and bound1 (Bound1 { body; user; }) = 160 | let$ pat = user in 161 | let* body = cterm body in 162 | return @@ Raw.Bound1 { pat; body; } 163 | 164 | and bound2 (Bound2 { body; user1; user2; }) = 165 | let$ pat1 = user1 in 166 | let$ pat2 = user2 in 167 | let* body = cterm body in 168 | return @@ Raw.Bound2 { pat1; pat2; body; } 169 | ;; 170 | 171 | let phrase { ph_desc; ph_loc; } = 172 | let* desc, env = 173 | match ph_desc with 174 | | Val { user; ty; def; } -> 175 | let name = Name.of_option user in 176 | let* ty = cterm ty in 177 | let* def = cterm def in 178 | let* env = M.get in 179 | return (Raw.Val { name; args = []; ty; def; }, 180 | DeBruijn.Env.extend name env) 181 | | Eval { def; } -> 182 | let* def = iterm def in 183 | let* env = M.get in 184 | return (Raw.Eval { def; }, env) 185 | in 186 | return @@ (Position.with_pos ph_loc desc, env) 187 | 188 | let file file env = 189 | let file, _ = 190 | List.fold_left 191 | (fun (file, env) ph -> let ph, env = phrase ph env in ph :: file, env) 192 | ([], env) 193 | file 194 | in 195 | List.rev file 196 | end 197 | 198 | module Build = struct 199 | let cdesc ?loc c_desc = 200 | { c_desc; c_loc = Option.value ~default:Position.dummy loc; } 201 | 202 | let idesc ?loc i_desc = 203 | { i_desc; i_loc = Option.value ~default:Position.dummy loc; } 204 | 205 | let infer ?loc tm = cdesc ?loc @@ Infer tm 206 | 207 | let let_ ?loc ~def ~ty ~body () = cdesc ?loc @@ Let { def; ty; body; } 208 | 209 | let bind_n mk ?loc tele body = 210 | List.fold_right 211 | (fun (user, a) body -> mk ?loc a (Bound1 { body; user; })) 212 | tele 213 | body 214 | 215 | let pi ?loc a f = cdesc ?loc @@ Pi (a, f) 216 | 217 | let pi_n ?loc tele body = bind_n pi ?loc tele body 218 | 219 | let lam ?loc bound = cdesc ?loc @@ Lam bound 220 | 221 | let sigma ?loc a f = cdesc ?loc @@ Sigma (a, f) 222 | 223 | let sigma_n ?loc tele body = bind_n sigma ?loc tele body 224 | 225 | let pair ?loc left right = cdesc ?loc @@ Pair (left, right) 226 | 227 | let nat ?loc () = cdesc ?loc Nat 228 | 229 | let typ ?loc ~level () = cdesc ?loc @@ Type level 230 | 231 | let var ?loc ix = idesc ?loc @@ Var ix 232 | 233 | let app ?loc t u = idesc ?loc @@ App (t, u) 234 | 235 | let fst ?loc arg = idesc ?loc @@ Fst arg 236 | 237 | let snd ?loc arg = idesc ?loc @@ Snd arg 238 | 239 | let zero ?loc () = idesc ?loc Zero 240 | 241 | let suc ?loc t = idesc ?loc @@ Suc t 242 | 243 | let natelim ?loc ~scrut ~motive ~case_zero ~case_suc () = 244 | idesc ?loc @@ Natelim { scrut; motive; case_zero; case_suc; } 245 | 246 | let annot ?loc ~tm ~ty () = 247 | idesc ?loc @@ Annot { tm; ty; } 248 | 249 | let val_ ?(loc = Position.dummy) ?user ~ty ~def () = 250 | { ph_loc = loc; ph_desc = Val { user; ty; def; } } 251 | 252 | let eval ?(loc = Position.dummy) ~def () = 253 | { ph_loc = loc; ph_desc = Eval { def; } } 254 | end 255 | 256 | module PPrint = struct 257 | let file file = Raw.PPrint.file (ToRaw.file file DeBruijn.Env.empty) 258 | end 259 | -------------------------------------------------------------------------------- /src/Core.mli: -------------------------------------------------------------------------------- 1 | (** {1 Core Syntax} *) 2 | 3 | (** This module defines well-typed syntax, as produced by the elaborator. Here 4 | variables are implemented by De Bruijn indices. *) 5 | 6 | (** The type of a checkable term, or [cterm], must be provided. *) 7 | type cterm_desc = 8 | | Infer of iterm 9 | | Let of { def : cterm; ty : cterm; body : bound1; } 10 | | Pi of cterm * bound1 11 | | Lam of bound1 12 | | Sigma of cterm * bound1 13 | | Pair of cterm * cterm 14 | | Nat 15 | | Type of int 16 | 17 | and cterm = 18 | { 19 | c_desc : cterm_desc; 20 | c_loc : Position.position; 21 | } 22 | 23 | (** The type of an inferrable term, or [cterm], can be computed from the term 24 | itself (in a given environment). *) 25 | and iterm_desc = 26 | | Var of DeBruijn.Ix.t 27 | | App of iterm * cterm 28 | | Fst of iterm 29 | | Snd of iterm 30 | | Zero 31 | | Suc of cterm 32 | | Natelim of { scrut : cterm; 33 | motive : bound1; 34 | case_zero : cterm; 35 | case_suc : bound2; } 36 | | Annot of { tm : cterm; ty : cterm; } 37 | 38 | and iterm = 39 | { 40 | i_desc : iterm_desc; 41 | i_loc : Position.position; 42 | } 43 | 44 | and bound1 = 45 | Bound1 of { 46 | body : cterm; (* cterm under binder *) 47 | user : Name.t option; (* for pretty-printing only *) 48 | } 49 | 50 | and bound2 = 51 | Bound2 of { 52 | body : cterm; (* cterm under binder *) 53 | user1 : Name.t option; (* for pretty-printing only *) 54 | user2 : Name.t option; (* for pretty-printing only *) 55 | } 56 | 57 | and phrase_desc = 58 | | Val of { user : Name.t option; ty : cterm; def : cterm; } 59 | | Eval of { def : iterm; } 60 | 61 | and phrase = 62 | { 63 | ph_desc : phrase_desc; 64 | ph_loc : Position.position; 65 | } 66 | 67 | and t = phrase list 68 | 69 | type ty = cterm 70 | 71 | and telescope = (Name.t option * ty) list 72 | 73 | val sexp_of_cterm : cterm -> Sexplib.Sexp.t 74 | val sexp_of_iterm : iterm -> Sexplib.Sexp.t 75 | val sexp_of_bound1 : bound1 -> Sexplib.Sexp.t 76 | val sexp_of_bound2 : bound2 -> Sexplib.Sexp.t 77 | val sexp_of_phrase : phrase -> Sexplib.Sexp.t 78 | val sexp_of_t : t -> Sexplib.Sexp.t 79 | 80 | val equal_cterm : cterm -> cterm -> bool 81 | val equal_iterm : iterm -> iterm -> bool 82 | 83 | module Build : sig 84 | val infer : ?loc:Position.t -> iterm -> cterm 85 | val let_ : ?loc:Position.t -> 86 | def:cterm -> 87 | ty:cterm -> 88 | body:bound1 -> 89 | unit -> 90 | cterm 91 | val pi : ?loc:Position.t -> cterm -> bound1 -> cterm 92 | val pi_n : ?loc:Position.t -> telescope -> cterm -> cterm 93 | val lam : ?loc:Position.t -> bound1 -> cterm 94 | val sigma : ?loc:Position.t -> cterm -> bound1 -> cterm 95 | val sigma_n : ?loc:Position.t -> telescope -> cterm -> cterm 96 | val pair : ?loc:Position.t -> cterm -> cterm -> cterm 97 | val nat : ?loc:Position.t -> unit -> cterm 98 | val var : ?loc:Position.t -> DeBruijn.Ix.t -> iterm 99 | val typ : ?loc:Position.t -> level:int -> unit -> cterm 100 | 101 | val app : ?loc:Position.t -> iterm -> cterm -> iterm 102 | val fst : ?loc:Position.t -> iterm -> iterm 103 | val snd : ?loc:Position.t -> iterm -> iterm 104 | val zero : ?loc:Position.t -> unit -> iterm 105 | val suc : ?loc:Position.t -> cterm -> iterm 106 | val natelim : ?loc:Position.t -> 107 | scrut:cterm -> 108 | motive:bound1 -> 109 | case_zero:cterm -> 110 | case_suc:bound2 -> 111 | unit -> iterm 112 | val annot : ?loc:Position.t -> tm:cterm -> ty:cterm -> unit -> iterm 113 | 114 | val val_ : ?loc:Position.t -> 115 | ?user:Name.t -> 116 | ty:cterm -> 117 | def:cterm -> 118 | unit -> 119 | phrase 120 | val eval : ?loc:Position.t -> 121 | def:iterm -> 122 | unit -> 123 | phrase 124 | end 125 | 126 | module ToRaw : sig 127 | type env = Name.t DeBruijn.Env.t 128 | module M : Monad.Plain with type 'a t = env -> 'a 129 | val cterm : cterm -> env -> Raw.term 130 | val iterm : iterm -> env -> Raw.term 131 | val bound1 : bound1 -> Raw.bound1 M.t 132 | val bound2 : bound2 -> Raw.bound2 M.t 133 | val phrase : phrase -> (Raw.phrase * env) M.t 134 | val file : t -> Raw.t M.t 135 | end 136 | 137 | module PPrint : sig 138 | val file : t -> PPrint.document 139 | end 140 | -------------------------------------------------------------------------------- /src/DeBruijn.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Conv 2 | 3 | type width = int 4 | 5 | module type DB = sig 6 | type t 7 | val sexp_of_t : t -> Sexplib.Sexp.t 8 | val equal : t -> t -> bool 9 | val to_int : t -> int 10 | val fresh : free:width -> t 11 | end 12 | 13 | module Ix = struct 14 | type t = int [@@deriving eq, sexp_of] 15 | let to_int i = i 16 | let fresh ~free = ignore free; 0 17 | let shift n = n + 1 18 | end 19 | 20 | module Lv = struct 21 | type t = int [@@deriving eq, sexp_of] 22 | let to_int i = i 23 | let fresh ~free = free 24 | end 25 | 26 | let lv_of_ix ~free l = 27 | if l >= free then invalid_arg "lv_of_ix"; 28 | free - l - 1 29 | 30 | let ix_of_lv ~free n = 31 | if n >= free then invalid_arg "ix_of_lv"; 32 | free - n - 1 33 | 34 | module Env = struct 35 | type 'a t = { w : int; c : 'a list; } [@@deriving sexp_of] 36 | 37 | let width { w; _ } = w 38 | 39 | let well_scoped_lv { w; _ } lv = 40 | assert (lv >= 0); 41 | lv < w 42 | 43 | let empty = { w = 0; c = []; } 44 | 45 | let extend v env = { w = env.w + 1; c = v :: env.c; } 46 | 47 | let lookup ix env = 48 | if ix >= env.w then raise Not_found; 49 | List.nth env.c ix 50 | 51 | let find p { c; w; } = 52 | let rec loop ix = function 53 | | [] -> assert (ix = w); raise Not_found 54 | | x :: c -> if p x then ix, x else loop (ix + 1) c 55 | in 56 | loop 0 c 57 | 58 | let fold f { c; _ } acc = 59 | List.fold_right f c acc 60 | 61 | let rec fold_cons f env acc = 62 | match env.c with 63 | | [] -> 64 | acc 65 | | entry :: c -> 66 | let env' = { c; w = env.w - 1; } in 67 | f entry env @@ fold_cons f env' acc 68 | 69 | let map f { c; w; } = 70 | { c = List.map f c; w; } 71 | 72 | let to_seq { c; _ } = 73 | List.to_seq c 74 | end 75 | -------------------------------------------------------------------------------- /src/DeBruijn.mli: -------------------------------------------------------------------------------- 1 | type width = int 2 | 3 | module type DB = sig 4 | type t 5 | val sexp_of_t : t -> Sexplib.Sexp.t 6 | val equal : t -> t -> bool 7 | val to_int : t -> int 8 | val fresh : free:width -> t 9 | end 10 | 11 | module Ix : sig 12 | include DB 13 | val shift : t -> t 14 | end 15 | 16 | module Lv : sig 17 | include DB 18 | end 19 | 20 | val lv_of_ix : free:width -> Ix.t -> Lv.t 21 | 22 | val ix_of_lv : free:width -> Lv.t -> Ix.t 23 | 24 | module Env : sig 25 | (** An environment, to be accessed in a last-in first-out fashion. *) 26 | type 'a t 27 | 28 | (** The number of entries in the environment. *) 29 | val width : 'a t -> width 30 | 31 | (** [well_scoped env lv] checks that the De Bruijn level [lv] is well-scoped 32 | in [env]. *) 33 | val well_scoped_lv : 'a t -> Lv.t -> bool 34 | 35 | (** The empty environment. *) 36 | val empty : 'a t 37 | 38 | (** Extend an environment with a new entry, considered as the latest one. *) 39 | val extend : 'a -> 'a t -> 'a t 40 | 41 | (** [lookup ix env] returns the value at De Bruijn index [ix] in [env]. It 42 | raises [Not_found] if [ix] is not well-scoped in [env]. *) 43 | val lookup : Ix.t -> 'a t -> 'a 44 | 45 | (** [find p env] returns the first value satisfying the predicate [p] in 46 | [env]. It raises [Not_found] in the absence of such a value. *) 47 | val find : ('a -> bool) -> 'a t -> Ix.t * 'a 48 | 49 | (** See {! List.map}. *) 50 | val map : ('a -> 'b) -> 'a t -> 'b t 51 | 52 | (** See {! List.fold_right}. *) 53 | val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b 54 | 55 | (** A variant of {! fold} providing easy access to the environment following 56 | each extension. *) 57 | val fold_cons : ('a -> 'a t -> 'b -> 'b) -> 'a t -> 'b -> 'b 58 | 59 | (** See {! List.to_seq}. *) 60 | val to_seq : 'a t -> 'a Seq.t 61 | 62 | val sexp_of_t : ('a -> Sexplib.Sexp.t) -> 'a t -> Sexplib.Sexp.t 63 | end 64 | 65 | -------------------------------------------------------------------------------- /src/Elaborator.ml: -------------------------------------------------------------------------------- 1 | module R = Raw 2 | module C = Core 3 | module S = Semantics 4 | module L = UniverseLevel 5 | 6 | module Env = DeBruijn.Env 7 | 8 | (* {2 Utilities} *) 9 | 10 | let bound1_name R.(Bound1 { pat; _ }) = 11 | R.name_of_pattern pat 12 | 13 | let bound2_name_1 R.(Bound2 { pat1; _ }) = 14 | R.name_of_pattern pat1 15 | 16 | let bound2_name_2 R.(Bound2 { pat2; _ }) = 17 | R.name_of_pattern pat2 18 | 19 | (* {2 Type checking} *) 20 | 21 | type state = 22 | { 23 | env : S.env; 24 | on_check_pre : Semantics.env -> expected:S.ty -> R.term -> unit; 25 | on_infer_pre : Semantics.env -> Raw.term -> unit; 26 | on_conversion_pre : Semantics.env -> 27 | expected:Semantics.ty -> actual:Semantics.ty -> 28 | Position.t -> unit; 29 | on_check_post : Semantics.env -> expected:S.ty -> R.term -> unit; 30 | on_infer_post : Semantics.env -> Raw.term -> actual:S.ty -> unit; 31 | on_conversion_post : Semantics.env -> 32 | expected:Semantics.ty -> actual:Semantics.ty -> 33 | Position.t -> unit; 34 | } 35 | 36 | module M = struct 37 | include Monad.Reader(struct type t = state end) 38 | end 39 | open Monad.Notation(M) 40 | 41 | let run 42 | ?(on_check_pre = fun _ ~expected _ -> ignore expected) 43 | ?(on_infer_pre = fun _ _ -> ()) 44 | ?(on_conversion_pre = fun _ ~expected ~actual _ -> 45 | ignore expected; ignore actual) 46 | ?(on_check_post = fun _ ~expected _ -> ignore expected) 47 | ?(on_infer_post = fun _ _ ~actual -> ignore actual) 48 | ?(on_conversion_post = fun _ ~expected ~actual _ -> 49 | ignore expected; ignore actual) 50 | x = 51 | x { 52 | env = Env.empty; 53 | on_check_pre; 54 | on_infer_pre; 55 | on_conversion_pre; 56 | on_check_post; 57 | on_infer_post; 58 | on_conversion_post; 59 | } 60 | 61 | let on_check_pre ~expected tm st = 62 | st.on_check_pre st.env ~expected tm 63 | 64 | let on_infer_pre tm st = 65 | st.on_infer_pre st.env tm 66 | 67 | let on_conversion_pre ~expected ~actual loc st = 68 | st.on_conversion_pre st.env ~expected ~actual loc 69 | 70 | let on_check_post ~expected tm st = 71 | st.on_check_post st.env ~expected tm 72 | 73 | let on_infer_post tm ~actual st = 74 | st.on_infer_post st.env tm ~actual 75 | 76 | let on_conversion_post ~expected ~actual loc st = 77 | st.on_conversion_post st.env ~expected ~actual loc 78 | 79 | let find loc x { env; _ } = 80 | try Env.find (fun en -> en.S.user = x) env 81 | with Not_found -> Error.unbound_identifier loc x 82 | 83 | let (let$) : S.entry M.t -> (S.value -> 'a M.t) -> 'a M.t = 84 | fun x k st -> 85 | let en = x st in 86 | k en.def { st with env = Env.extend en st.env; } 87 | 88 | let get_env { env; _ } = env 89 | 90 | let liftE : 'a S.Eval.M.t -> 'a M.t = 91 | fun x st -> x st.env 92 | 93 | let liftR : 'a C.ToRaw.M.t -> 'a M.t = 94 | fun x st -> x (Env.map (fun S.{ user; _ } -> user) st.env) 95 | 96 | let incompatible_types ~expected ~actual loc = 97 | let* expected = liftE @@ S.PPrint.value expected in 98 | let* actual = liftE @@ S.PPrint.value actual in 99 | Error.incompatible_types ~expected ~actual loc 100 | 101 | let unexpected_type ~expected loc = 102 | let* expected = liftE @@ S.PPrint.value expected in 103 | Error.unexpected_type ~expected loc 104 | 105 | let unexpected_head_constr ~expected ~actual loc = 106 | let* actual = liftE @@ S.PPrint.value actual in 107 | Error.unexpected_head_constr ~expected ~actual loc 108 | 109 | let quote_ty tysem = 110 | let open S.Quote in 111 | liftE @@ lift @@ typ tysem 112 | 113 | let fresh ?def ~ty user = 114 | let open S.Quote in 115 | liftE @@ lift @@ fresh ~user ?def ty 116 | 117 | let ceval tm = liftE @@ S.Eval.cterm tm 118 | let ieval tm = liftE @@ S.Eval.iterm tm 119 | 120 | let check_conv ~expected ~actual loc = 121 | let* () = on_conversion_pre ~expected ~actual loc in 122 | let* conv = liftE @@ S.Quote.lift @@ S.Conv.ty ~lo:actual ~hi:expected in 123 | if conv 124 | then on_conversion_post ~expected ~actual loc 125 | else incompatible_types ~expected ~actual loc 126 | 127 | let rec check : expected:S.ty -> R.term -> C.cterm M.t = 128 | fun ~expected (Position.{ value = r; position = loc; } as tm) -> 129 | let* () = on_check_pre ~expected tm in 130 | match r with 131 | | Let { def; ty; body; } -> 132 | check_def ~name:(bound1_name body) ~ty ~def 133 | (fun ~ty ~def -> 134 | let* body = check_bound1 ~expected body in 135 | return @@ C.Build.let_ ~loc ~def ~ty ~body ()) 136 | 137 | | Pi (a, f) | Sigma (a, f) -> 138 | let binder = 139 | match r with 140 | | Pi _ -> C.Build.pi | Sigma _ -> C.Build.sigma 141 | | _ -> assert false (* absurd *) 142 | in 143 | begin match expected with 144 | | S.Type _ -> 145 | let* a = check ~expected a in 146 | let* f = 147 | let* asem = ceval a in 148 | let$ _ = fresh ~ty:asem (bound1_name f) in 149 | check_bound1 ~expected f 150 | in 151 | return @@ binder ~loc a f 152 | 153 | | actual -> 154 | unexpected_head_constr ~expected:`Univ ~actual loc 155 | end 156 | 157 | | Lam body -> 158 | begin match expected with 159 | | Pi (a, f) -> 160 | let$ x = fresh ~ty:a @@ bound1_name body in 161 | let* body = check_bound1 ~expected:(S.Eval.clo1 f x) body in 162 | return @@ C.Build.lam ~loc body 163 | 164 | | _ -> 165 | unexpected_type ~expected loc 166 | end 167 | 168 | | Pair (left, right) -> 169 | begin match expected with 170 | | Sigma (a, f) -> 171 | let* left = check ~expected:a left in 172 | let* right = 173 | let* leftsem = ceval left in 174 | check ~expected:(S.Eval.clo1 f leftsem) right 175 | in 176 | return @@ C.Build.pair ~loc left right 177 | 178 | | _ -> 179 | unexpected_type ~expected loc 180 | end 181 | 182 | | Nat -> 183 | begin match expected with 184 | | Type _ -> 185 | return @@ C.Build.nat ~loc () 186 | 187 | | _ -> 188 | unexpected_type ~expected loc 189 | end 190 | 191 | | Type l_actual -> 192 | begin match expected with 193 | | Type l_expected -> 194 | if !Options.type_in_type || L.(fin l_actual <= l_expected) 195 | then return @@ C.Build.typ ~loc ~level:l_actual () 196 | else Error.universe_inconsistency loc 197 | 198 | | _ -> 199 | unexpected_type ~expected loc 200 | 201 | end 202 | 203 | | Var _ | App _ | Zero | Suc _ | Natelim _ | Fst _ | Snd _ | Annot _ -> 204 | let* tm, actual = infer tm in 205 | let* () = check_conv ~expected ~actual loc in 206 | return @@ C.Build.infer ~loc tm 207 | 208 | and check_is_ty : R.ty -> C.ty M.t = 209 | fun tm -> check ~expected:S.limtype tm 210 | 211 | and infer : R.term -> (C.iterm * S.ty) M.t = 212 | fun (Position.{ value = r; position = loc; } as tm) -> 213 | let* () = on_infer_pre tm in 214 | let* tm', ty = 215 | match r with 216 | | Var x -> 217 | let* ix, { ty; _ } = find loc x in 218 | return @@ (C.Build.var ix, Option.get ty) 219 | 220 | | App (m, n) -> 221 | let* m, mty = infer m in 222 | begin match mty with 223 | | Pi (a, f) -> 224 | let* n = check ~expected:a n in 225 | let* nsem = ceval n in 226 | return @@ (C.Build.app ~loc m n, S.Eval.clo1 f nsem) 227 | 228 | | actual -> 229 | unexpected_head_constr ~expected:`Pi ~actual loc 230 | end 231 | 232 | | Fst m -> 233 | let* m, mty = infer m in 234 | begin match mty with 235 | | Sigma (a, _) -> 236 | return @@ (C.Build.fst ~loc m, a) 237 | 238 | | actual -> 239 | unexpected_head_constr ~expected:`Sigma ~actual m.C.i_loc 240 | end 241 | 242 | | Snd m -> 243 | let* m, mty = infer m in 244 | begin match mty with 245 | | Sigma (_, f) -> 246 | let* msem = ieval m in 247 | return @@ (C.Build.snd ~loc m, S.Eval.(clo1 f (fst msem))) 248 | 249 | | actual -> 250 | unexpected_head_constr ~expected:`Sigma ~actual m.C.i_loc 251 | end 252 | 253 | | Zero -> 254 | return @@ (C.Build.zero ~loc (), S.Nat) 255 | 256 | | Suc m -> 257 | let* m = check ~expected:S.Nat m in 258 | return @@ (C.Build.suc ~loc m, S.Nat) 259 | 260 | | Natelim { scrut; motive; case_zero; case_suc; } -> 261 | let* scrut = check ~expected:Nat scrut in 262 | let* motive = 263 | let$ _ = fresh ~ty:Nat @@ bound1_name motive in 264 | check_bound1_is_ty motive 265 | in 266 | let* motsem = liftE @@ S.close1 motive in 267 | let* case_zero = check ~expected:(S.Eval.clo1 motsem Zero) case_zero in 268 | let* case_suc = 269 | let$ x1 = fresh ~ty:Nat @@ bound2_name_1 case_suc in 270 | let$ _ = fresh ~ty:(S.Eval.clo1 motsem x1) @@ bound2_name_2 case_suc in 271 | check_bound2 ~expected:(S.Eval.clo1 motsem (Suc x1)) case_suc 272 | in 273 | let* resty = 274 | let* scrutsem = ceval scrut in 275 | return @@ S.Eval.clo1 motsem scrutsem 276 | in 277 | return @@ (C.Build.natelim ~loc ~scrut ~motive ~case_zero ~case_suc (), 278 | resty) 279 | 280 | | Annot { tm; ty; } -> 281 | let* ty = check_is_ty ty in 282 | let* expected = ceval ty in 283 | let* tm = check ~expected tm in 284 | return @@ (C.Build.annot ~loc ~ty ~tm (), expected) 285 | 286 | | Let _ | Pi _ | Sigma _ | Lam _ | Pair _ | Nat | Type _ -> 287 | Error.could_not_synthesize loc 288 | in 289 | let* () = on_infer_post ~actual:ty tm in 290 | return (tm', ty) 291 | 292 | and check_bound1_is_ty : R.bound1 -> C.bound1 M.t = 293 | fun (R.Bound1 { pat; body; }) -> 294 | let* body = check_is_ty body in 295 | return @@ C.Bound1 { user = Raw.name_option_of_pattern pat; body; } 296 | 297 | and check_bound1 : expected:S.ty -> R.bound1 -> C.bound1 M.t = 298 | fun ~expected (R.Bound1 { pat; body; }) -> 299 | let* body = check ~expected body in 300 | return @@ C.Bound1 { user = Raw.name_option_of_pattern pat; body; } 301 | 302 | and check_bound2 : expected:S.ty -> R.bound2 -> C.bound2 M.t = 303 | fun ~expected (R.Bound2 { pat1; pat2; body; }) -> 304 | let* body = check ~expected body in 305 | return @@ C.Bound2 { user1 = Raw.name_option_of_pattern pat1; 306 | user2 = Raw.name_option_of_pattern pat2; 307 | body; } 308 | 309 | and check_def : 'a. name:Name.t -> ?ty:R.ty -> def:R.term -> 310 | (ty:C.ty -> def:C.cterm -> 'a M.t) -> 'a M.t = 311 | fun ~name ?ty ~def k -> 312 | let* ty, tysem, def = 313 | match ty with 314 | | Some ty -> 315 | let* ty = check_is_ty ty in 316 | let* tysem = ceval ty in 317 | let* def = check ~expected:tysem def in 318 | return (ty, tysem, def) 319 | | None -> 320 | let* def, tysem = infer def in 321 | let* ty = quote_ty tysem in 322 | return (ty, tysem, C.Build.infer def) 323 | in 324 | let* defsem = ceval def in 325 | let$ _ = fresh ~def:defsem ~ty:tysem name in 326 | k ~ty ~def 327 | 328 | let phrase : R.phrase -> C.t M.t -> C.t M.t = 329 | fun Position.{ value; position = loc; } file -> 330 | match value with 331 | | Val { name; args; ty; def; } -> 332 | let ty = R.Build.pi_n ~loc ~params:args ~body:ty () in 333 | let def = 334 | R.Build.lam_n ~loc ~params:(R.patterns_of_telescope args) ~body:def () 335 | in 336 | check_def ~name ~ty ~def 337 | (fun ~ty ~def -> 338 | let* file = file in 339 | return @@ C.Build.val_ ~loc ~user:name ~def ~ty () :: file) 340 | | Eval { def; } -> 341 | let* def, tysem = infer def in 342 | let* def = liftE @@ S.Conv.normalize ~ty:tysem ~tm:(C.Build.infer def) in 343 | let* ty = quote_ty tysem in 344 | let* file = file in 345 | return @@ C.Build.eval ~loc ~def:(C.Build.annot ~tm:def ~ty ()) () :: file 346 | 347 | let rec check = function 348 | | [] -> 349 | return [] 350 | | ph :: file -> 351 | phrase ph (check file) 352 | -------------------------------------------------------------------------------- /src/Elaborator.mli: -------------------------------------------------------------------------------- 1 | (** The elaborator performs type-checking and elaboration of source programs, as 2 | represented by module {! Raw}, into the core well-scoped and well-typed 3 | representation, as represented by module {! Core}. This process might 4 | freely raise the exceptions defined in {! Error}. *) 5 | 6 | module M : Monad.Plain 7 | 8 | val run : 9 | ?on_check_pre:(Semantics.env -> expected:Semantics.ty -> Raw.term -> unit) -> 10 | ?on_infer_pre:(Semantics.env -> Raw.term -> unit) -> 11 | ?on_conversion_pre:(Semantics.env -> 12 | expected:Semantics.ty -> actual:Semantics.ty -> 13 | Position.t -> unit) -> 14 | ?on_check_post:(Semantics.env -> expected:Semantics.ty -> Raw.term -> unit) -> 15 | ?on_infer_post:(Semantics.env -> Raw.term -> actual:Semantics.ty -> unit) -> 16 | ?on_conversion_post:(Semantics.env -> 17 | expected:Semantics.ty -> actual:Semantics.ty -> 18 | Position.t -> unit) -> 19 | 'a M.t -> 20 | 'a 21 | 22 | val check : Raw.t -> Core.t M.t 23 | -------------------------------------------------------------------------------- /src/Error.ml: -------------------------------------------------------------------------------- 1 | type error = 2 | | Internal of string 3 | | Syntax of Position.t * string 4 | | Unbound_identifier of Position.t * Name.t 5 | | Could_not_synthesize of Position.t 6 | | Incompatible_types of { loc : Position.t; 7 | expected : PPrint.document; 8 | actual : PPrint.document; } 9 | | Unexpected_type of { loc : Position.t; expected : PPrint.document; } 10 | | Unexpected_head_constr of { loc : Position.t; 11 | expected : [`Pi | `Sigma | `Nat | `Univ]; 12 | actual : PPrint.document; } 13 | | Universe_inconsistency of Position.t 14 | 15 | let print fmt = function 16 | | Internal message -> 17 | Format.fprintf fmt "internal error (%s), please open an issue at %s@\n%s" 18 | message 19 | "https://github.com/adrieng/melitte/issues" 20 | (Printexc.get_backtrace ()) 21 | | Syntax (loc, s) -> 22 | Format.fprintf fmt "@[%s:@ %s@]" (Position.to_string loc) s 23 | | Unbound_identifier (loc, s) -> 24 | Format.fprintf fmt "@[%s:@ unbound identifier %a@]" 25 | (Position.to_string loc) 26 | (ExtPrint.to_fmt Name.pp) s 27 | | Could_not_synthesize loc -> 28 | Format.fprintf fmt "@[%s:@ could not synthesize type (add annotation)@]" 29 | (Position.to_string loc) 30 | | Incompatible_types { loc; expected; actual; } -> 31 | Format.fprintf fmt 32 | "@[%s:@ this expression has type @[%a@] but type @[%a@] was expected@]" 33 | (Position.to_string loc) 34 | ExtPrint.pp actual 35 | ExtPrint.pp expected 36 | | Unexpected_type { loc; expected; } -> 37 | Format.fprintf fmt 38 | "@[%s:@ this expression was expected to have type @[%a@]@]" 39 | (Position.to_string loc) 40 | ExtPrint.pp expected 41 | | Unexpected_head_constr { loc; expected; actual; } -> 42 | let open UnicodeSigil in 43 | let head_constr = function 44 | | `Pi -> PPrint.(doc forall ^^ space ^^ underscore) 45 | | `Sigma -> PPrint.(doc sigma ^^ space ^^ underscore) 46 | | `Nat -> doc nat 47 | | `Univ -> doc typ 48 | in 49 | Format.fprintf fmt 50 | "@[%s:@ this expression has type @[%a@] but a type of shape @[%a@] \ 51 | was expected@]" 52 | (Position.to_string loc) 53 | ExtPrint.pp actual 54 | (ExtPrint.to_fmt head_constr) expected 55 | | Universe_inconsistency loc -> 56 | Format.fprintf fmt "@[%s:@ universe inconsistency@]" 57 | (Position.to_string loc) 58 | 59 | exception Error of error 60 | 61 | let internal message = 62 | raise (Error (Internal message)) 63 | 64 | let syntax reason startp endp = 65 | raise (Error (Syntax (Position.lex_join startp endp, reason))) 66 | 67 | let unbound_identifier loc name = 68 | raise (Error (Unbound_identifier (loc, name))) 69 | 70 | let could_not_synthesize loc = 71 | raise (Error (Could_not_synthesize loc)) 72 | 73 | let incompatible_types ~expected ~actual loc = 74 | raise (Error (Incompatible_types { loc; expected; actual; })) 75 | 76 | let unexpected_type ~expected loc = 77 | raise (Error (Unexpected_type { loc; expected; })) 78 | 79 | let unexpected_head_constr ~expected ~actual loc = 80 | raise (Error (Unexpected_head_constr { loc; expected; actual; })) 81 | 82 | let universe_inconsistency loc = 83 | raise (Error (Universe_inconsistency loc)) 84 | -------------------------------------------------------------------------------- /src/ExtPrint.ml: -------------------------------------------------------------------------------- 1 | type 'a printer = 'a -> PPrint.document 2 | 3 | let ribbon = 1.0 4 | 5 | let width = 80 6 | 7 | let int i = PPrint.string @@ string_of_int i 8 | 9 | let to_out ?(out = stdout) d = 10 | PPrint.ToChannel.pretty ribbon width out d 11 | 12 | let to_string d = 13 | let b = Buffer.create 100 in 14 | PPrint.ToBuffer.pretty ribbon width b d; 15 | Buffer.contents b 16 | 17 | let pp fmt doc = PPrint.ToFormatter.pretty ribbon width fmt doc 18 | 19 | let to_fmt to_doc fmt x = pp fmt (to_doc x) 20 | 21 | -------------------------------------------------------------------------------- /src/Lex.ml: -------------------------------------------------------------------------------- 1 | open Parse 2 | 3 | (** {1 Utilities} *) 4 | 5 | let utf8_string_of_lexbuf lexbuf = 6 | Sigs.Unicode.utf8_string_of_uchar_array @@ Sedlexing.lexeme lexbuf 7 | 8 | let int_of_lexbuf lexbuf = 9 | int_of_string @@ utf8_string_of_lexbuf lexbuf 10 | 11 | let tabulate default table = 12 | let ht = Hashtbl.create 100 in 13 | List.iter (fun (ns, s) -> List.iter (fun n -> Hashtbl.add ht n s) ns) table; 14 | fun n -> try Hashtbl.find ht n with Not_found -> default n 15 | 16 | let keyword_or_ident = 17 | tabulate (fun n -> ID n) 18 | [ 19 | ["forall"; "∀"], FORALL; 20 | ["sig"; "Σ"], SIGMA; 21 | ["let"], LET; 22 | ["in"], IN; 23 | ["Type"; "𝕌"], TYPE; 24 | ["Nat"; "ℕ"], NAT; 25 | ["zero"], ZERO; 26 | ["suc"], SUC; 27 | ["elim"], ELIM; 28 | ["with"], WITH; 29 | ["val"], VAL; 30 | ["eval"], EVAL; 31 | ["fst"; "π₁"], FST; 32 | ["snd"; "π₂"], SND; 33 | ["×"], TIMES; 34 | ] 35 | 36 | (** {1 Error handling} *) 37 | 38 | let error reason lexbuf = 39 | let startp, endp = Sedlexing.lexing_positions lexbuf in 40 | Error.syntax reason startp endp 41 | 42 | let invalid_character lexbuf = 43 | let reason = 44 | match Sedlexing.next lexbuf with 45 | | None -> "unknown character" 46 | | Some c -> 47 | let s = Sigs.Unicode.utf8_string_of_uchar_array [| c |] in 48 | Printf.sprintf "invalid character '%s'" s 49 | in 50 | error reason lexbuf 51 | 52 | (** {1 Lexing} *) 53 | 54 | let quark = [%sedlex.regexp? alphabetic | other_alphabetic 55 | | math | other_math | '_'] 56 | 57 | let atom = [%sedlex.regexp? quark, Star (quark | ascii_hex_digit | '-')] 58 | 59 | let nat = [%sedlex.regexp? Plus ('0' .. '9')] 60 | 61 | let comment_start = [%sedlex.regexp? "{-"] 62 | 63 | let comment_stop = [%sedlex.regexp? "-}"] 64 | 65 | let rec token lexbuf = match%sedlex lexbuf with 66 | | white_space -> token lexbuf 67 | 68 | | comment_start -> comments 1 lexbuf 69 | 70 | | '(' -> LPAREN 71 | | ')' -> RPAREN 72 | | "{" -> LBRACE 73 | | '}' -> RBRACE 74 | 75 | | '=' -> EQ 76 | | "->" | 8594 -> ARR 77 | | "=>" | 8658 -> DARR 78 | | "_" -> UNDERSCORE 79 | | ":" -> COLON 80 | | "|" -> BAR 81 | | "," -> COMMA 82 | | "*" -> TIMES 83 | | '\\' | 955 -> LAM 84 | 85 | | nat -> INT (int_of_lexbuf lexbuf) 86 | | atom -> keyword_or_ident (utf8_string_of_lexbuf lexbuf) 87 | 88 | | eof -> EOF 89 | 90 | | _ -> invalid_character lexbuf 91 | 92 | and comments n lexbuf = 93 | if n <= 0 then token lexbuf 94 | else 95 | match%sedlex lexbuf with 96 | | comment_start -> comments (n + 1) lexbuf 97 | | comment_stop -> comments (n - 1) lexbuf 98 | | eof -> error "unterminated comment" lexbuf 99 | | any -> comments n lexbuf 100 | | _ -> error "bad token" lexbuf 101 | -------------------------------------------------------------------------------- /src/Monad.ml: -------------------------------------------------------------------------------- 1 | module type Plain = sig 2 | type 'a t 3 | val return : 'a -> 'a t 4 | val bind : 'a t -> ('a -> 'b t) -> 'b t 5 | end 6 | 7 | module type Runnable = sig 8 | include Plain 9 | val run : 'a t -> 'a 10 | end 11 | 12 | module Notation (M : Plain) = struct 13 | let return = M.return 14 | 15 | let ( let* ) = M.bind 16 | 17 | let ( and* ) x y = 18 | let* z = x in 19 | let* m = y in 20 | M.return (z, m) 21 | 22 | let ( let+ ) x f = 23 | let* y = x in 24 | M.return (f y) 25 | 26 | let ( and+ ) = ( and* ) 27 | end 28 | 29 | module type TYPE = sig 30 | type t 31 | end 32 | 33 | module Reader (M : sig type t end) = struct 34 | type 'a t = M.t -> 'a 35 | let return x _ = x 36 | let bind x f s = f (x s) s 37 | let get s = s 38 | let run s x = x s 39 | end 40 | 41 | module State(T : TYPE) = struct 42 | type 'a t = T.t -> 'a * T.t 43 | 44 | let return x = fun s -> x, s 45 | 46 | let bind (type a b) (x : a t) (f : a -> b t) : b t = 47 | fun s -> let y, s = x s in f y s 48 | 49 | let run s x = let y, _ = x s in y 50 | 51 | let get s = s, s 52 | 53 | let set s _ = (), s 54 | end 55 | 56 | module Error(T : TYPE) = struct 57 | type 'a t = ('a, T.t) Result.t 58 | 59 | let return x = Ok x 60 | 61 | let bind (type a b) (x : a t) (f : a -> b t) : b t = 62 | match x with 63 | | Ok x -> f x 64 | | Error err -> Error err 65 | 66 | let fail err = Error err 67 | 68 | let run x = x 69 | end 70 | 71 | module ErrorT(T : TYPE)(M : Plain) = struct 72 | type 'a t = ('a, T.t) Result.t M.t 73 | 74 | let return x = M.return (Ok x) 75 | 76 | let bind (type a b) (x : a t) (f : a -> b t) : b t = 77 | M.bind x 78 | (function 79 | | Ok x -> f x 80 | | Error err -> M.return (Error err)) 81 | 82 | let fail err = M.return @@ Error err 83 | 84 | let lift x = M.bind x (fun v -> M.return @@ Ok v) 85 | end 86 | 87 | -------------------------------------------------------------------------------- /src/Monad.mli: -------------------------------------------------------------------------------- 1 | module type Plain = sig 2 | type 'a t 3 | val return : 'a -> 'a t 4 | val bind : 'a t -> ('a -> 'b t) -> 'b t 5 | end 6 | 7 | module type Runnable = sig 8 | include Plain 9 | val run : 'a t -> 'a 10 | end 11 | 12 | module Notation (M : Plain) : sig 13 | val return : 'a -> 'a M.t 14 | val (let*) : 'a M.t -> ('a -> 'b M.t) -> 'b M.t 15 | val (and*) : 'a M.t -> 'b M.t -> ('a * 'b) M.t 16 | val (let+) : 'a M.t -> ('a -> 'b) -> 'b M.t 17 | val (and+) : 'a M.t -> 'b M.t -> ('a * 'b) M.t 18 | end 19 | 20 | module type TYPE = sig 21 | type t 22 | end 23 | 24 | module Reader (T : TYPE) : sig 25 | include Plain with type 'a t = T.t -> 'a 26 | val get : T.t t 27 | val run : T.t -> 'a t -> 'a 28 | end 29 | 30 | module State(T : TYPE) : sig 31 | include Plain with type 'a t = T.t -> 'a * T.t 32 | val get : T.t t 33 | val set : T.t -> unit t 34 | val run : T.t -> 'a t -> 'a 35 | end 36 | 37 | module Error(T : TYPE) : sig 38 | include Plain 39 | val fail : T.t -> 'a t 40 | val run : 'a t -> ('a, T.t) Result.t 41 | end 42 | 43 | module ErrorT(T : TYPE)(M : Plain) : sig 44 | include Plain with type 'a t = ('a, T.t) Result.t M.t 45 | val lift : 'a M.t -> 'a t 46 | val fail : T.t -> 'a t 47 | end 48 | -------------------------------------------------------------------------------- /src/Name.ml: -------------------------------------------------------------------------------- 1 | (** Strings are represented as unique identifiers. *) 2 | 3 | type t = int 4 | 5 | let compare (x : t) y = Stdlib.compare x y 6 | 7 | let equal x y = x = y 8 | 9 | let fwd_table : (string, int) Hashtbl.t = Hashtbl.create 100 10 | let bwd_table : (int, string) Hashtbl.t = Hashtbl.create 100 11 | let free = ref 0 12 | 13 | let of_string = 14 | fun s -> 15 | try Hashtbl.find fwd_table s 16 | with Not_found -> 17 | let id = !free in 18 | Hashtbl.add fwd_table s id; 19 | Hashtbl.add bwd_table id s; 20 | incr free; 21 | id 22 | 23 | let to_string n = Hashtbl.find bwd_table n 24 | 25 | let sexp_of_t n = Sexplib.Conv.sexp_of_string (to_string n) 26 | 27 | let pp n = PPrint.utf8string (to_string n) 28 | 29 | let dummy_prefix = "_" 30 | 31 | let dummy = of_string dummy_prefix 32 | 33 | let of_option = Option.value ~default:dummy 34 | 35 | let internal s = of_string (dummy_prefix ^ s) 36 | -------------------------------------------------------------------------------- /src/Name.mli: -------------------------------------------------------------------------------- 1 | (** An abstract type of name supporting constant-time equality testing, 2 | comparison, pretty-printing, and conversion to S-expressions. *) 3 | include Sigs.PrintableComparableType 4 | 5 | val sexp_of_t : t -> Sexplib.Sexp.t 6 | 7 | (** Names are isomorphic to strings. *) 8 | 9 | val of_string : string -> t 10 | 11 | val to_string : t -> string 12 | 13 | (** [dummy] is a name that can never appear in source code. *) 14 | val dummy : t 15 | 16 | (** [of_option name] sends [None] to [dummy] and [Some x] to [x]. *) 17 | val of_option : t option -> t 18 | 19 | (** [internal s] returns a name that is guaranteed never to appear in source 20 | code, due to lexing convention. This function is injective, but it differs 21 | from [of_string] in that [to_string (internal s)] is never equal to [s]. *) 22 | val internal : string -> t 23 | -------------------------------------------------------------------------------- /src/Options.ml: -------------------------------------------------------------------------------- 1 | let use_unicode = ref true 2 | 3 | let type_in_type = ref false 4 | 5 | let debug = ref false 6 | 7 | let verbose = ref false 8 | -------------------------------------------------------------------------------- /src/Parse.mly: -------------------------------------------------------------------------------- 1 | %{ (* -*- mode: tuareg -*- *) 2 | open Raw 3 | 4 | module B = Build 5 | %} 6 | 7 | %token ID 8 | %token INT 9 | 10 | %token LAM FORALL SIGMA LET IN TYPE NAT ZERO SUC ELIM WITH VAL EVAL FST SND 11 | %token LPAREN RPAREN LBRACE RBRACE 12 | %token EQ ARR DARR TIMES 13 | %token UNDERSCORE COLON BAR COMMA 14 | %token EOF 15 | 16 | %nonassoc IN DARR 17 | %right ARR 18 | %right TIMES 19 | 20 | %start whole_file 21 | %start whole_phrase 22 | %start whole_term 23 | 24 | %type hypothesis 25 | %type telescope 26 | 27 | %% 28 | 29 | %inline parens(X): 30 | | LPAREN x = X RPAREN { x } 31 | 32 | %inline located(X): 33 | | x = X { x ~loc:(Position.lex_join $startpos $endpos) () } 34 | 35 | %inline name: 36 | | id = ID { Name.of_string id } 37 | 38 | very_simple_term_: 39 | | name = name { B.var ~name } 40 | | TYPE level = INT { B.typ ~level } 41 | | NAT { B.nat } 42 | | k = INT { B.lit ~k } 43 | | ZERO { B.zero } 44 | | SUC t = very_simple_term { B.suc ~t } 45 | | FST arg = very_simple_term { B.fst ~arg } 46 | | SND arg = very_simple_term { B.snd ~arg } 47 | | te = parens(term_) { te } 48 | 49 | %inline very_simple_term: 50 | | located(very_simple_term_) { $1 } 51 | 52 | simple_term_: 53 | | te = very_simple_term_ { te } 54 | | func = simple_term arg = very_simple_term { B.app ~func ~arg } 55 | 56 | %inline simple_term: 57 | | located(simple_term_) { $1 } 58 | 59 | weakened_term(X): 60 | | b = hyp X te = term { (b, te) } 61 | 62 | motive: 63 | | WITH p = pattern DARR ty = ty { B.bound1 p ty } 64 | 65 | term_: 66 | | t = simple_term_ 67 | { t } 68 | | LAM params = pattern+ DARR body = term 69 | { B.lam_n ~params ~body } 70 | | LET p = pattern COLON ty = ty EQ def = term IN body = term 71 | { B.let_ ~def ~ty ~body:(B.bound1 p body) } 72 | | FORALL params = telescope ARR body = ty 73 | { B.pi_n ~params ~body } 74 | | SIGMA params = telescope TIMES body = ty 75 | { B.sigma_n ~params ~body } 76 | | dom = term ARR cod = term 77 | { B.arrow ~dom ~cod } 78 | | left = term TIMES right = term 79 | { B.product ~left ~right } 80 | | ELIM scrut = term motive = motive 81 | LBRACE 82 | BAR? ZERO DARR case_zero = term 83 | BAR SUC case_suc = bind2(DARR) 84 | RBRACE 85 | { B.natelim ~scrut ~motive ~case_zero ~case_suc } 86 | | LPAREN left = term COMMA right = term RPAREN 87 | { B.pair ~left ~right } 88 | | LPAREN tm = term COLON ty = ty RPAREN 89 | { B.annot ~tm ~ty } 90 | 91 | %inline term: 92 | | located(term_) { $1 } 93 | 94 | %inline ty: term { $1 } 95 | 96 | bind1(SEP): 97 | | p = pattern SEP t = term { B.bound1 p t } 98 | 99 | bind2(SEP): 100 | | p1 = pattern COMMA p2 = pattern SEP t = term { B.bound2 p1 p2 t } 101 | 102 | pattern_: 103 | | UNDERSCORE { B.pwildcard } 104 | | name = name { B.pvar ~name } 105 | 106 | %inline pattern: 107 | | located(pattern_) { $1 } 108 | 109 | hyp: 110 | | p = pattern COLON ty = ty { (p, ty) } 111 | 112 | hypothesis_: 113 | | LPAREN pat = pattern COLON ty = ty RPAREN { B.hypothesis ~pat ~ty } 114 | 115 | (* Workaround for a bug in Menhir and/or Dune. TODO investigate *) 116 | %inline hypothesis: 117 | | h = hypothesis_ { h ~loc:(Position.lex_join $startpos $endpos) () } 118 | 119 | telescope: 120 | | hypothesis* { $1 } 121 | 122 | phrase_desc: 123 | | VAL name = name args = telescope COLON ty = ty EQ def = term 124 | { B.val_ ~name ~args ~ty ~def } 125 | | EVAL def = term 126 | { B.eval ~def } 127 | 128 | %inline phrase: 129 | | p = located(phrase_desc) { p } 130 | 131 | file: 132 | | phrase* { $1 } 133 | 134 | whole(X): 135 | | x = X EOF { x } 136 | | error { Error.syntax "syntax error" $startpos $endpos } 137 | 138 | whole_file: 139 | | whole(file) { $1 } 140 | 141 | whole_phrase: 142 | | whole(phrase) { $1 } 143 | 144 | whole_term: 145 | | whole(term) { $1 } 146 | 147 | %% 148 | -------------------------------------------------------------------------------- /src/Position.ml: -------------------------------------------------------------------------------- 1 | open Lexing 2 | 3 | type lexing_position = Lexing.position 4 | 5 | (* let lexing_position_of_sexp p = *) 6 | (* [%of_sexp: string * int * int * int] p *) 7 | (* |> fun (pos_fname, pos_lnum, pos_bol, pos_cnum) -> *) 8 | (* { pos_fname; pos_lnum; pos_bol; pos_cnum } *) 9 | 10 | let sexp_of_lexing_position p = 11 | let open Sexplib.Std in 12 | [%sexp_of: string * int * int * int] 13 | (p.pos_fname, p.pos_lnum, p.pos_bol, p.pos_cnum) 14 | 15 | type t = 16 | { 17 | start_p : lexing_position; 18 | end_p : lexing_position; 19 | } [@@deriving sexp_of] 20 | 21 | type position = t 22 | 23 | type 'a located = 24 | { 25 | value : 'a; 26 | position : t; 27 | } 28 | 29 | let value { value = v; _ } = 30 | v 31 | 32 | let position { position = p; _ } = 33 | p 34 | 35 | let destruct p = 36 | (p.value, p.position) 37 | 38 | let located f x = 39 | f (value x) 40 | 41 | let with_pos p v = 42 | { 43 | value = v; 44 | position = p; 45 | } 46 | 47 | let with_poss p1 p2 v = 48 | with_pos { start_p = p1; end_p = p2 } v 49 | 50 | let map f v = 51 | { 52 | value = f v.value; 53 | position = v.position; 54 | } 55 | 56 | let iter f { value = v; _ } = 57 | f v 58 | 59 | let mapd f v = 60 | let w1, w2 = f v.value in 61 | let pos = v.position in 62 | ({ value = w1; position = pos }, { value = w2; position = pos }) 63 | 64 | let dummy = 65 | { 66 | start_p = Lexing.dummy_pos; 67 | end_p = Lexing.dummy_pos 68 | } 69 | 70 | let unknown_pos v = 71 | { 72 | value = v; 73 | position = dummy 74 | } 75 | 76 | let pp_located pp fmt x = 77 | pp fmt x.value 78 | 79 | let start_of_position p = p.start_p 80 | 81 | let end_of_position p = p.end_p 82 | 83 | let filename_of_position p = 84 | p.start_p.Lexing.pos_fname 85 | 86 | let line p = 87 | p.pos_lnum 88 | 89 | let column p = 90 | p.pos_cnum - p.pos_bol 91 | 92 | let characters p1 p2 = 93 | (column p1, p2.pos_cnum - p1.pos_bol) (* intentionally [p1.pos_bol] *) 94 | 95 | let join x1 x2 = 96 | { 97 | start_p = if x1 = dummy then x2.start_p else x1.start_p; 98 | end_p = if x2 = dummy then x1.end_p else x2.end_p 99 | } 100 | 101 | let lex_join x1 x2 = 102 | { 103 | start_p = x1; 104 | end_p = x2 105 | } 106 | 107 | let join_located l1 l2 f = 108 | { 109 | value = f l1.value l2.value; 110 | position = join l1.position l2.position; 111 | } 112 | 113 | let string_of_lex_pos p = 114 | let c = p.pos_cnum - p.pos_bol in 115 | (string_of_int p.pos_lnum)^":"^(string_of_int c) 116 | 117 | let to_string p = 118 | let filename = filename_of_position p in 119 | let l = line p.start_p in 120 | let c1, c2 = characters p.start_p p.end_p in 121 | if filename = "" then 122 | Printf.sprintf "Line %d, characters %d-%d" l c1 c2 123 | else 124 | Printf.sprintf "File \"%s\", line %d, characters %d-%d" filename l c1 c2 125 | 126 | let pos_or_undef = function 127 | | None -> dummy 128 | | Some x -> x 129 | 130 | let cpos lexbuf = 131 | { 132 | start_p = Lexing.lexeme_start_p lexbuf; 133 | end_p = Lexing.lexeme_end_p lexbuf; 134 | } 135 | 136 | let with_cpos lexbuf v = 137 | with_pos (cpos lexbuf) v 138 | 139 | let string_of_cpos lexbuf = 140 | to_string (cpos lexbuf) 141 | 142 | let joinf f t1 t2 = 143 | join (f t1) (f t2) 144 | 145 | let ljoinf f = 146 | List.fold_left (fun p t -> join p (f t)) dummy 147 | 148 | let join_located_list ls f = 149 | { 150 | value = f (List.map (fun l -> l.value) ls); 151 | position = ljoinf (fun x -> x.position) ls 152 | } 153 | -------------------------------------------------------------------------------- /src/Position.mli: -------------------------------------------------------------------------------- 1 | (** Extension of standard library's positions. *) 2 | 3 | (** {2 Extended lexing positions} *) 4 | 5 | (** Abstract type for pairs of positions in the lexing stream. *) 6 | type t 7 | type position = t 8 | 9 | (** Decoration of a value with a position. *) 10 | type 'a located = 11 | { 12 | value : 'a; 13 | position : t; 14 | } 15 | 16 | (** [value dv] returns the raw value that underlies the 17 | decorated value [dv]. *) 18 | val value: 'a located -> 'a 19 | 20 | (** [position dv] returns the position that decorates the 21 | decorated value [dv]. *) 22 | val position: 'a located -> t 23 | 24 | (** [destruct dv] returns the couple of position and value 25 | of a decorated value [dv]. *) 26 | val destruct: 'a located -> 'a * t 27 | 28 | (** [located f x] applies [f] to the value of [x]. *) 29 | val located : ('a -> 'b) -> 'a located -> 'b 30 | 31 | (** [with_pos p v] decorates [v] with a position [p]. *) 32 | val with_pos : t -> 'a -> 'a located 33 | 34 | (** [with_cpos p v] decorates [v] with a lexical position [p]. *) 35 | val with_cpos: Lexing.lexbuf -> 'a -> 'a located 36 | 37 | (** [with_poss start stop v] decorates [v] with a position [(start, stop)]. *) 38 | val with_poss : Lexing.position -> Lexing.position -> 'a -> 'a located 39 | 40 | (** [unknown_pos x] decorates [v] with an unknown position. *) 41 | val unknown_pos : 'a -> 'a located 42 | 43 | (** [pp_locate pp fmt x] pretty-prints [x] using [pp], discarding locations. *) 44 | val pp_located : 45 | (Format.formatter -> 'a -> unit) -> 46 | Format.formatter -> 'a located -> unit 47 | 48 | (** This value is used when an object does not come from a particular 49 | input location. *) 50 | val dummy: t 51 | 52 | (** [of_sexp s] converts from an S-expression. *) 53 | val sexp_of_t : t -> Sexplib.Sexp.t 54 | 55 | (** [map f v] extends the decoration from [v] to [f v]. *) 56 | val map: ('a -> 'b) -> 'a located -> 'b located 57 | 58 | (** [iter f dv] applies [f] to the value inside [dv]. *) 59 | val iter: ('a -> unit) -> 'a located -> unit 60 | 61 | (** [mapd f v] extends the decoration from [v] to both members of the pair 62 | [f v]. *) 63 | val mapd: ('a -> 'b1 * 'b2) -> 'a located -> 'b1 located * 'b2 located 64 | 65 | (** {2 Accessors} *) 66 | 67 | (** [column p] returns the number of characters from the 68 | beginning of the line of the Lexing.position [p]. *) 69 | val column : Lexing.position -> int 70 | 71 | (** [column p] returns the line number of to the Lexing.position [p]. *) 72 | val line : Lexing.position -> int 73 | 74 | (** [characters p1 p2] returns the character interval 75 | between [p1] and [p2] assuming they are located in the same 76 | line. *) 77 | val characters : Lexing.position -> Lexing.position -> int * int 78 | 79 | (** [start_of_position p] returns the beginning of a position [p]. *) 80 | val start_of_position: t -> Lexing.position 81 | 82 | (** [end_of_position p] returns the end of a position [p]. *) 83 | val end_of_position: t -> Lexing.position 84 | 85 | (** [filename_of_position p] returns the filename of a position [p]. *) 86 | val filename_of_position: t -> string 87 | 88 | (** {2 Position handling} *) 89 | 90 | (** [join p1 p2] returns a position that starts where [p1] 91 | starts and stops where [p2] stops. *) 92 | val join : t -> t -> t 93 | 94 | (** [lex_join l1 l2] returns a position that starts at [l1] and stops 95 | at [l2]. *) 96 | val lex_join : Lexing.position -> Lexing.position -> t 97 | 98 | (** [string_of_lex_pos p] returns a string representation for 99 | the lexing position [p]. *) 100 | val string_of_lex_pos : Lexing.position -> string 101 | 102 | (** [string_of_pos p] returns the standard (Emacs-like) representation 103 | of the position [p]. *) 104 | val to_string : t -> string 105 | 106 | (** [pos_or_undef po] is the identity function except if po = None, 107 | in that case, it returns [undefined_position]. *) 108 | val pos_or_undef : t option -> t 109 | 110 | (** {2 Interaction with the lexer runtime} *) 111 | 112 | (** [cpos lexbuf] returns the current position of the lexer. *) 113 | val cpos : Lexing.lexbuf -> t 114 | 115 | (** [string_of_cpos p] returns a string representation of 116 | the lexer's current position. *) 117 | val string_of_cpos : Lexing.lexbuf -> string 118 | -------------------------------------------------------------------------------- /src/Raw.ml: -------------------------------------------------------------------------------- 1 | type pattern_desc = 2 | | PWildcard 3 | | PVar of Name.t 4 | 5 | and pattern = pattern_desc Position.located 6 | 7 | type term_desc = 8 | | Var of Name.t 9 | | Let of { def : term; ty : ty; body : bound1; } 10 | | Pi of ty * bound1 11 | | Lam of bound1 12 | | App of term * term 13 | | Sigma of ty * bound1 14 | | Pair of term * term 15 | | Fst of term 16 | | Snd of term 17 | | Nat 18 | | Zero 19 | | Suc of term 20 | | Natelim of { scrut : term; 21 | motive : bound1; 22 | case_zero : term; 23 | case_suc : bound2; } 24 | | Type of int 25 | | Annot of { tm : term; ty : term; } 26 | 27 | and term = term_desc Position.located 28 | 29 | and bound1 = 30 | Bound1 of { 31 | pat : pattern; 32 | body : term; 33 | } 34 | 35 | and bound2 = 36 | Bound2 of { 37 | pat1 : pattern; 38 | pat2 : pattern; 39 | body : term; 40 | } 41 | 42 | and ty = term 43 | 44 | and telescope = hypothesis list 45 | 46 | and hypothesis_desc = Hyp of { pat : pattern; ty : ty; } 47 | 48 | and hypothesis = hypothesis_desc Position.located 49 | 50 | type phrase_desc = 51 | | Val of { name : Name.t; args : telescope; ty : ty; def : term; } 52 | | Eval of { def : term; } 53 | 54 | and phrase = phrase_desc Position.located 55 | 56 | type t = phrase list 57 | 58 | module Build = struct 59 | let pvar ?(loc = Position.dummy) ~name () = 60 | Position.with_pos loc @@ PVar name 61 | 62 | let pwildcard ?(loc = Position.dummy) () = 63 | Position.with_pos loc @@ PWildcard 64 | 65 | let bound1 pat body = 66 | Bound1 { pat; body; } 67 | 68 | let bound2 pat1 pat2 body = 69 | Bound2 { pat1; pat2; body; } 70 | 71 | let var ?(loc = Position.dummy) ~name () = 72 | Position.with_pos loc @@ Var name 73 | 74 | let let_ ?(loc = Position.dummy) ~def ~ty ~body () = 75 | Position.with_pos loc @@ Let { def; ty; body; } 76 | 77 | let binder_n ?(loc = Position.dummy) ~binder ~params ~body () = 78 | Position.{ 79 | (List.fold_right 80 | (fun { Position.value = Hyp { pat; ty = a; }; _ } b -> 81 | with_pos (join (join pat.position a.position) b.position) 82 | (binder a (bound1 pat b))) params body) 83 | with position = loc; 84 | } 85 | 86 | let pi ?(loc = Position.dummy) ~dom ~cod () = 87 | Position.with_pos loc @@ Pi (dom, cod) 88 | 89 | let pi_n = 90 | binder_n ~binder:(fun dom cod -> Pi (dom, cod)) 91 | 92 | let arrow ?(loc = Position.dummy) ~dom ~cod () = 93 | pi ~loc ~dom ~cod:(bound1 (pwildcard ~loc ()) cod) () 94 | 95 | let lam ?(loc = Position.dummy) ~param ~body () = 96 | Position.with_pos loc @@ Lam (bound1 param body) 97 | 98 | let lam_n ?(loc = Position.dummy) ~params ~body () = 99 | List.fold_right (fun param body -> lam ~loc ~param ~body ()) params body 100 | 101 | let app ?(loc = Position.dummy) ~func ~arg () = 102 | Position.with_pos loc @@ App (func, arg) 103 | 104 | let app_n ?(loc = Position.dummy) ~func ~args () = 105 | List.fold_left (fun func arg -> app ~loc ~func ~arg ()) func args 106 | 107 | let sigma ?(loc = Position.dummy) ~base ~total () = 108 | Position.with_pos loc @@ Sigma (base, total) 109 | 110 | let sigma_n = 111 | binder_n ~binder:(fun dom cod -> Sigma (dom, cod)) 112 | 113 | let product ?(loc = Position.dummy) ~left ~right () = 114 | sigma ~loc ~base:left ~total:(bound1 (pwildcard ~loc ()) right) () 115 | 116 | let pair ?(loc = Position.dummy) ~left ~right () = 117 | Position.with_pos loc @@ Pair (left, right) 118 | 119 | let fst ?(loc = Position.dummy) ~arg () = 120 | Position.with_pos loc @@ Fst arg 121 | 122 | let snd ?(loc = Position.dummy) ~arg () = 123 | Position.with_pos loc @@ Snd arg 124 | 125 | let nat ?(loc = Position.dummy) () = 126 | Position.with_pos loc @@ Nat 127 | 128 | let zero ?(loc = Position.dummy) () = 129 | Position.with_pos loc @@ Zero 130 | 131 | let suc ?(loc = Position.dummy) ~t () = 132 | Position.with_pos loc @@ Suc t 133 | 134 | let lit ?(loc = Position.dummy) ~k () = 135 | Sigs.Int.fold (fun t -> suc ~loc ~t ()) k (zero ~loc ()) 136 | 137 | let natelim ?(loc = Position.dummy) ~scrut ~motive ~case_zero ~case_suc () = 138 | Position.with_pos loc @@ Natelim { scrut; motive; case_zero; case_suc; } 139 | 140 | let annot ?(loc = Position.dummy) ~tm ~ty () = 141 | Position.with_pos loc @@ Annot { tm; ty; } 142 | 143 | let hypothesis ?(loc = Position.dummy) ~pat ~ty () = 144 | Position.with_pos loc @@ Hyp { pat; ty; } 145 | 146 | let typ ?(loc = Position.dummy) ~level () = 147 | if level < 0 then invalid_arg "typ"; 148 | Position.with_pos loc @@ Type level 149 | 150 | let val_ ?(loc = Position.dummy) ~name ~args ~ty ~def () = 151 | Position.with_pos loc @@ Val { name; args; ty; def; } 152 | 153 | let eval ?(loc = Position.dummy) ~def () = 154 | Position.with_pos loc @@ Eval { def; } 155 | end 156 | 157 | module PPrint = struct 158 | open PPrint 159 | module U = UnicodeSigil 160 | 161 | let name = Name.pp 162 | 163 | let pattern_desc = function 164 | | PWildcard -> !^ "_" 165 | | PVar x -> name x 166 | 167 | let pattern = Position.located pattern_desc 168 | 169 | let rec term_desc = function 170 | | (Var _ | Type _ | Nat | Zero | Suc _ | App _ | Fst _ | Snd _) as t -> 171 | group (simple_term_desc t) 172 | 173 | | Lam _ as t -> 174 | let rec lam = function 175 | | Lam (Bound1 { pat; body; }) -> 176 | let pats, body = lam body.Position.value in 177 | pattern pat :: pats, body 178 | | body -> 179 | [], body 180 | in 181 | let patterns, body = lam t in 182 | bindN 183 | U.(doc lambda) 184 | U.(doc drarrow) 185 | patterns 186 | (term_desc body) 187 | 188 | | Let { def; ty; body = Bound1 { pat; body; }; } -> 189 | group 190 | ( 191 | (group (!^ "let" ^/^ hyp ~ty pat 192 | ^/^ !^ " =" ^/^ term def ^/^ !^ "in")) 193 | ^/^ term body 194 | ) 195 | 196 | | Pi (_, Bound1 { pat = { Position.value = PVar _; _ }; _ }) as t -> 197 | let rec print_forall = function 198 | | Pi (a, Bound1 { pat = { Position.value = PVar _; _ } as pat; 199 | body; }) -> 200 | parens (hyp ~ty:a pat) ^/^ print_forall body.Position.value 201 | | t -> 202 | U.(doc srarrow) ^/^ typ_desc t 203 | in 204 | group (U.(doc forall) ^/^ print_forall t) 205 | 206 | | Pi (_, Bound1 { pat = { Position.value = PWildcard; _ }; _ }) as t -> 207 | let rec print_fun = function 208 | | Pi (a, Bound1 { pat = { Position.value = PWildcard; _ }; 209 | body; }) -> 210 | typ a ^^ space ^^ U.(doc srarrow) ^/^ print_fun body.Position.value 211 | | t -> 212 | typ_desc t 213 | in 214 | group (print_fun t) 215 | 216 | | Sigma (_, Bound1 { pat = { Position.value = PVar _; _ }; _ }) as t -> 217 | let rec print_forall = function 218 | | Sigma (a, Bound1 { pat = { Position.value = PVar _; _ } as pat; 219 | body; }) -> 220 | parens (hyp ~ty:a pat) ^/^ print_forall body.Position.value 221 | | t -> 222 | dot ^/^ typ_desc t 223 | in 224 | group (U.(doc sigma) ^/^ print_forall t) 225 | 226 | | Sigma (_, Bound1 { pat = { Position.value = PWildcard; _ }; _ }) as t -> 227 | let rec print_prod = function 228 | | Sigma (a, Bound1 { pat = { Position.value = PWildcard; _ }; 229 | body; }) -> 230 | typ a ^^ space ^^ U.(doc times) ^/^ print_prod body.Position.value 231 | | t -> 232 | typ_desc t 233 | in 234 | group (print_prod t) 235 | 236 | | Natelim { scrut; motive; case_zero; case_suc; } -> 237 | let m = bind1 (!^ " with") U.(doc drarrow) motive in 238 | prefix 2 1 239 | (group (!^ "elim" ^/^ term scrut ^^ m)) 240 | (braces @@ separate (break 1 ^^ bar) 241 | [ 242 | bind0 (!^ " zero") U.(doc drarrow) case_zero; 243 | bind2 (!^ " suc") U.(doc drarrow) case_suc; 244 | ] ^^ break 1) 245 | 246 | | Pair (left, right) -> 247 | parens @@ group @@ term left ^^ comma ^/^ term right 248 | 249 | | Annot { tm; ty; } -> 250 | (* TODO factor into some `hypothesis` function. *) 251 | parens @@ group @@ term tm ^^ space ^^ colon ^/^ term ty 252 | 253 | and simple_term_desc = function 254 | | (Var _ | Type _ | Nat | Zero | Suc _ | Fst _ | Snd _) as t -> 255 | very_simple_term_desc t 256 | 257 | | App (t, u) -> 258 | simple_term t ^/^ very_simple_term u 259 | 260 | | _ -> 261 | assert false 262 | 263 | and very_simple_term_desc = function 264 | | Var x -> 265 | name x 266 | 267 | | Type l -> 268 | U.(doc typ ^^ space ^^ if l = max_int then !^ "top" else ExtPrint.int l) 269 | 270 | | Nat -> 271 | U.(doc nat) 272 | 273 | | Zero -> 274 | !^ "0" 275 | 276 | | Suc t -> 277 | let rec loop = function 278 | | Zero -> 279 | 1, None 280 | | Suc t -> 281 | let k, r = loop t.Position.value in 282 | k + 1, r 283 | | r -> 284 | 1, Some r 285 | in 286 | let k, r = loop t.Position.value in 287 | begin match r with 288 | | None -> 289 | !^ (string_of_int k) 290 | | Some t -> 291 | Sigs.Int.fold (prefix 2 1 (!^ "suc")) k (simple_term_desc t) 292 | end 293 | 294 | | Fst t -> 295 | prefix 2 1 (!^ "fst") (very_simple_term t) 296 | 297 | | Snd t -> 298 | prefix 2 1 (!^ "snd") (very_simple_term t) 299 | 300 | | t -> 301 | parens (term_desc t) 302 | 303 | and term t : PPrint.document = Position.located term_desc t 304 | 305 | and simple_term t = Position.located simple_term_desc t 306 | 307 | and very_simple_term t = Position.located very_simple_term_desc t 308 | 309 | and typ ty = Position.located typ_desc ty 310 | 311 | and typ_desc tyd = term_desc tyd 312 | 313 | and bindN kw sep (heads : document list) body = 314 | prefix 2 1 315 | (prefix 2 1 kw (group @@ separate (break 1) (heads @ [sep]))) 316 | body 317 | 318 | and bind0 kw sep body = 319 | bindN kw sep [] (term body) 320 | 321 | and bind1 kw sep (Bound1 { pat; body; }) = 322 | bindN kw sep [pattern pat] (term body) 323 | 324 | and bind2 kw sep (Bound2 { pat1; pat2; body; }) = 325 | bindN kw sep [pattern pat1 ^^ comma; pattern pat2] (term body) 326 | 327 | and bound1 (Bound1 { pat; body; }) = 328 | pattern pat ^^ dot ^^ term body 329 | 330 | and bound2 (Bound2 { pat1; pat2; body; }) = 331 | parens (group (pattern pat1 ^^ comma ^/^ pattern pat2)) ^^ dot ^^ term body 332 | 333 | and hyp ?ty (p : pattern) = 334 | match ty with 335 | | None -> pattern p 336 | | Some ty -> group @@ pattern p ^^ space ^^ colon ^/^ typ ty 337 | 338 | and hypothesis_desc (Hyp { pat; ty }) = 339 | group @@ pattern pat ^^ space ^^ colon ^/^ typ ty 340 | 341 | and hypothesis h = Position.located hypothesis_desc h 342 | 343 | and telescope tele = 344 | group @@ concat @@ List.map (fun h -> break 1 ^^ hypothesis h) tele 345 | 346 | and phrase_desc = function 347 | | Val { name = n; args; ty; def; } -> 348 | (* TODO rationalize *) 349 | prefix 2 1 350 | (group @@ !^ "val" ^^ space ^^ name n ^^ telescope args 351 | ^/^ colon ^^ space ^^ typ ty ^/^ !^ "=") 352 | (group @@ term def) 353 | | Eval { def; } -> 354 | prefix 2 1 (!^ "eval") (term def) 355 | 356 | and phrase p = Position.located phrase_desc p 357 | 358 | and file phrs = separate_map hardline phrase phrs 359 | end 360 | 361 | let name_option_of_pattern Position.{ value; _ } = 362 | match value with 363 | | PWildcard -> None 364 | | PVar x -> Some x 365 | 366 | let name_of_pattern p = 367 | Name.of_option @@ name_option_of_pattern p 368 | 369 | let patterns_of_telescope tele = 370 | List.map (fun { Position.value = Hyp { pat; _ }; _ } -> pat) tele 371 | -------------------------------------------------------------------------------- /src/Raw.mli: -------------------------------------------------------------------------------- 1 | (** {1 Raw terms} *) 2 | 3 | (** This module defines raw terms, as produced by the parser. *) 4 | 5 | (** At this level, names are simply strings. The transformation from strings to 6 | DeBruijn indices happens during elaboration. *) 7 | 8 | type pattern_desc = 9 | | PWildcard 10 | | PVar of Name.t 11 | 12 | and pattern = pattern_desc Position.located 13 | 14 | type term_desc = 15 | | Var of Name.t 16 | (** Variable occurence *) 17 | | Let of { def : term; 18 | ty : ty; 19 | body : bound1; } 20 | (** Let statement, annotated with its type. *) 21 | | Pi of ty * bound1 22 | (** Dependent function type *) 23 | | Lam of bound1 24 | (** Anonymous (dependent) function *) 25 | | App of term * term 26 | (** Application *) 27 | | Sigma of ty * bound1 28 | (** Dependent sum type *) 29 | | Pair of term * term 30 | (** Sum constructor *) 31 | | Fst of term 32 | (** First projection *) 33 | | Snd of term 34 | (** Second projection *) 35 | | Nat 36 | (** Type of natural numbers. *) 37 | | Zero 38 | (** Nullary constructor of [Nat]. *) 39 | | Suc of term 40 | (** Unary constructor of [Nat]. *) 41 | | Natelim of { scrut : term; 42 | motive : bound1; 43 | case_zero : term; 44 | case_suc : bound2; } 45 | (** Dependent elimination form for natural numbers. *) 46 | | Type of int 47 | (** Universe hierarchy. *) 48 | | Annot of { tm : term; ty : term; } 49 | (** Type annotation. *) 50 | 51 | and term = term_desc Position.located 52 | 53 | and bound1 = 54 | Bound1 of { 55 | pat : pattern; 56 | body : term; 57 | } 58 | 59 | and bound2 = 60 | Bound2 of { 61 | pat1 : pattern; 62 | pat2 : pattern; 63 | body : term; 64 | } 65 | 66 | and ty = term 67 | 68 | and telescope = hypothesis list 69 | 70 | and hypothesis_desc = Hyp of { pat : pattern; ty : ty; } 71 | 72 | and hypothesis = hypothesis_desc Position.located 73 | 74 | type phrase_desc = 75 | | Val of { name : Name.t; args : telescope; ty : ty; def : term; } 76 | | Eval of { def : term; } 77 | 78 | and phrase = phrase_desc Position.located 79 | 80 | type t = phrase list 81 | 82 | module Build : sig 83 | (* The functions declared in this submodule have all their arguments labelled 84 | except for a trailing unit argument. This ensures that the optional [loc] 85 | argument is never erased, making it possible to deal with locations in a 86 | uniform way in {! Parse}. *) 87 | 88 | val pvar : ?loc:Position.t -> name:Name.t -> unit -> pattern 89 | val pwildcard : ?loc:Position.t -> unit -> pattern 90 | val var : ?loc:Position.t -> name:Name.t -> unit -> term 91 | val let_ : ?loc:Position.t -> def:term -> ty:ty -> body:bound1 -> unit -> term 92 | val pi : ?loc:Position.t -> dom:ty -> cod:bound1 -> unit -> ty 93 | val pi_n : ?loc:Position.t -> params:telescope -> body:ty -> 94 | unit -> ty 95 | val arrow : ?loc:Position.t -> dom:ty -> cod:ty -> unit -> ty 96 | val lam : ?loc:Position.t -> param:pattern -> body:term -> unit -> term 97 | val lam_n : ?loc:Position.t -> 98 | params:pattern list -> 99 | body:term -> 100 | unit -> term 101 | val app : ?loc:Position.t -> func:term -> arg:term -> unit -> term 102 | val app_n : ?loc:Position.t -> func:term -> args:term list -> unit -> term 103 | val sigma : ?loc:Position.t -> base:ty -> total:bound1 -> unit -> ty 104 | val sigma_n : ?loc:Position.t -> params:telescope -> body:ty -> 105 | unit -> ty 106 | val product : ?loc:Position.t -> left:ty -> right:ty -> unit -> ty 107 | val pair : ?loc:Position.t -> left:term -> right:term -> unit -> term 108 | val fst : ?loc:Position.t -> arg:term -> unit -> term 109 | val snd : ?loc:Position.t -> arg:term -> unit -> term 110 | val nat : ?loc:Position.t -> unit -> term 111 | val zero : ?loc:Position.t -> unit -> term 112 | val suc : ?loc:Position.t -> t:term -> unit -> term 113 | val lit : ?loc:Position.t -> k:int -> unit -> term 114 | val natelim : ?loc:Position.t -> 115 | scrut:term -> 116 | motive:bound1 -> 117 | case_zero:term -> 118 | case_suc:bound2 -> 119 | unit -> term 120 | val typ : ?loc:Position.t -> level:int -> unit -> term 121 | val annot : ?loc:Position.t -> tm:term -> ty:ty -> unit -> term 122 | val hypothesis : ?loc:Position.t -> pat:pattern -> ty:ty -> unit -> hypothesis 123 | val bound1 : pattern -> term -> bound1 124 | val bound2 : pattern -> pattern -> term -> bound2 125 | val val_ : ?loc:Position.t -> 126 | name:Name.t -> 127 | args:telescope -> 128 | ty:term -> 129 | def:term -> 130 | unit -> phrase 131 | val eval : ?loc:Position.t -> def:term -> unit -> phrase 132 | end 133 | 134 | module PPrint : sig 135 | val pattern_desc : pattern_desc -> PPrint.document 136 | val pattern : pattern -> PPrint.document 137 | val term_desc : term_desc -> PPrint.document 138 | val term : term -> PPrint.document 139 | val bound1 : bound1 -> PPrint.document 140 | val bound2 : bound2 -> PPrint.document 141 | val phrase : phrase -> PPrint.document 142 | val hypothesis : hypothesis -> PPrint.document 143 | val telescope : telescope -> PPrint.document 144 | val file : t -> PPrint.document 145 | end 146 | 147 | val name_option_of_pattern : pattern -> Name.t option 148 | 149 | (** [name_of_pattern p] sends [PWildcard] to [Name.dummy] and [PVar x] to 150 | [x]. *) 151 | val name_of_pattern : pattern -> Name.t 152 | 153 | val patterns_of_telescope : telescope -> pattern list 154 | -------------------------------------------------------------------------------- /src/Semantics.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Conv 2 | 3 | module C = Core 4 | module E = DeBruijn.Env 5 | module L = UniverseLevel 6 | 7 | type value = 8 | | Reflect of { ty : value; tm : neutral; } 9 | | Lam of clo1 10 | | Pi of value * clo1 11 | | Sigma of value * clo1 12 | | Pair of value * value 13 | | Type of L.t 14 | | Nat 15 | | Zero 16 | | Suc of value 17 | 18 | and neutral = 19 | | Var of DeBruijn.Lv.t 20 | | App of neutral * normal 21 | | Natelim of neutral * clo1 * value * clo2 22 | | Fst of neutral 23 | | Snd of neutral 24 | 25 | and normal = 26 | | Reify of { ty : value; tm : value; } 27 | 28 | and clo1 = C1 of env * C.bound1 29 | 30 | and clo2 = C2 of env * C.bound2 31 | 32 | and entry = 33 | { 34 | def : value; 35 | ty : value option; 36 | user : Name.t; 37 | } 38 | 39 | and env = entry DeBruijn.Env.t [@@deriving sexp_of] 40 | 41 | type ty = value 42 | 43 | (* Utility functions *) 44 | 45 | let clo1_name (C1 (_, C.Bound1 { user; _ })) = 46 | Option.value ~default:Name.dummy user 47 | 48 | let close1 b1 env = C1 (env, b1) 49 | 50 | let close2 b2 env = C2 (env, b2) 51 | 52 | let limtype = Type UniverseLevel.inf 53 | 54 | module Eval = struct 55 | module M = Monad.Reader(struct type t = env end) 56 | open Monad.Notation(M) 57 | 58 | let extend_eval ?(user = Name.dummy) def env = 59 | DeBruijn.Env.extend { def; ty = None; user; } env 60 | 61 | let rec cterm : C.cterm -> value M.t = 62 | fun tm -> 63 | match tm.c_desc with 64 | | C.Infer tm -> 65 | iterm tm 66 | 67 | | C.Lam body -> 68 | let* body = close1 body in 69 | return @@ Lam body 70 | 71 | | C.Pi (dom, cod) -> 72 | let* dom = cterm dom in 73 | let* cod = close1 cod in 74 | return @@ Pi (dom, cod) 75 | 76 | | C.Sigma (dom, cod) -> 77 | let* dom = cterm dom in 78 | let* cod = close1 cod in 79 | return @@ Sigma (dom, cod) 80 | 81 | | C.Pair (left, right) -> 82 | let* left = cterm left in 83 | let* right = cterm right in 84 | return @@ Pair (left, right) 85 | 86 | | C.Let { def; body; _ } -> 87 | let* def = cterm def in 88 | let* body = close1 body in 89 | return @@ clo1 body def 90 | 91 | | C.Type l -> 92 | return @@ Type (UniverseLevel.fin l) 93 | 94 | | C.Nat -> 95 | return Nat 96 | 97 | and iterm : C.iterm -> value M.t = 98 | fun tm -> 99 | match tm.i_desc with 100 | | C.Var ix -> 101 | begin 102 | try 103 | let* entry = DeBruijn.Env.lookup ix in 104 | return entry.def 105 | with Not_found -> Error.internal "ill-scoped evaluation" 106 | end 107 | 108 | | C.App (t, u) -> 109 | let* t = iterm t in 110 | let* u = cterm u in 111 | return @@ app t u 112 | 113 | | C.Fst t -> 114 | let* t = iterm t in 115 | return @@ fst t 116 | 117 | | C.Snd t -> 118 | let* t = iterm t in 119 | return @@ snd t 120 | 121 | | C.Zero -> 122 | return Zero 123 | 124 | | C.Suc t -> 125 | let* t = cterm t in 126 | return @@ Suc t 127 | 128 | | C.Natelim { scrut; motive; case_zero; case_suc; } -> 129 | let* scrut = cterm scrut in 130 | let* motive = close1 motive in 131 | let* case_zero = cterm case_zero in (* probably suboptimal *) 132 | let* case_suc = close2 case_suc in 133 | return @@ nat_elim scrut motive case_zero case_suc 134 | 135 | | C.Annot { tm; _ } -> 136 | cterm tm 137 | 138 | and app v w = 139 | match v with 140 | | Lam c -> 141 | clo1 c w 142 | | Reflect { ty = Pi (a, b); tm; } -> 143 | Reflect { ty = clo1 b w; tm = App (tm, Reify { ty = a; tm = w; }); } 144 | | _ -> 145 | Error.internal "ill-typed evaluation" 146 | 147 | and fst = function 148 | | Pair (l, _) -> 149 | l 150 | | Reflect { ty = Sigma (a, _); tm; } -> 151 | Reflect { ty = a; tm = Fst tm; } 152 | | _ -> 153 | Error.internal "ill-typed evaluation" 154 | 155 | and snd = function 156 | | Pair (_, r) -> 157 | r 158 | | Reflect { ty = Sigma (_, f); tm; } as tot -> 159 | Reflect { ty = clo1 f (fst tot); tm = Snd tm; } 160 | | _ -> 161 | Error.internal "ill-typed evaluation" 162 | 163 | and nat_elim d m u0 uN = 164 | match d with 165 | | Zero -> 166 | u0 167 | | Suc n -> 168 | let vp = nat_elim n m u0 uN in 169 | clo2 uN n vp 170 | | Reflect { ty = Nat; tm; } -> 171 | Reflect { ty = Nat; tm = Natelim (tm, m, u0, uN); } 172 | | _ -> 173 | Error.internal "ill-typed evaluation" 174 | 175 | and clo1 (C1 (env, Bound1 { body; user; })) v = 176 | cterm body (extend_eval ?user v env) 177 | 178 | and clo2 (C2 (env, Bound2 { body; user1; user2; })) v1 v2 = 179 | cterm body (extend_eval ?user:user2 v2 (extend_eval ?user:user1 v1 env)) 180 | end 181 | 182 | module Quote = struct 183 | type state = { eta : bool; free : int; } 184 | module M = Monad.Reader(struct type t = state end) 185 | open Monad.Notation(M) 186 | 187 | let run ~eta ~free x = x { eta; free; } 188 | 189 | let lift : 'a M.t -> 'a Eval.M.t = 190 | fun x env -> run ~eta:true ~free:(DeBruijn.Env.width env) x 191 | 192 | let fresh ?(user = Name.dummy) ?def ty { free; _ } = 193 | let def = 194 | Option.value 195 | ~default:(Reflect { ty; tm = Var DeBruijn.Lv.(fresh ~free); }) 196 | def 197 | in 198 | { user; def; ty = Some ty; } 199 | 200 | let (let$) : entry M.t -> (value -> 'a M.t) -> 'a M.t = 201 | fun x k state -> 202 | let en = x state in 203 | k en.def { state with free = state.free + 1; } 204 | 205 | let weaken : 'a M.t -> 'a M.t = 206 | fun x { eta; free; } -> x { eta; free = free + 1; } 207 | 208 | let rec neutral ne = 209 | match ne with 210 | | Var lv -> 211 | let* { free; _ } = M.get in 212 | return (C.Build.var (DeBruijn.ix_of_lv ~free lv)) 213 | 214 | | App (ne, nf) -> 215 | let* ne = neutral ne in 216 | let* nf = normal nf in 217 | return @@ C.Build.app ne nf 218 | 219 | | Fst ne -> 220 | let* ne = neutral ne in 221 | return @@ C.Build.fst ne 222 | 223 | | Snd ne -> 224 | let* ne = neutral ne in 225 | return @@ C.Build.snd ne 226 | 227 | | Natelim (scrut, motive, case_zero, case_succ) -> 228 | let user = clo1_name motive in 229 | let* scrut = neutral scrut in 230 | let* case_zero = normal_ ~ty:(Eval.clo1 motive Zero) ~tm:case_zero in 231 | let$ x1 = fresh ~user Nat in 232 | let* case_suc = 233 | let$ x2 = fresh ~user (Eval.clo1 motive x1) in 234 | normal_clo2 ~ty:(Eval.clo1 motive (Suc x1)) case_succ x1 x2 235 | in 236 | let* motive = normal_clo1 ~ty:(Type L.inf) motive x1 in 237 | return @@ C.Build.natelim 238 | ~scrut:(C.Build.infer scrut) 239 | ~motive ~case_zero ~case_suc () 240 | 241 | and normal_eta ~ty ~tm = 242 | match ty, tm with 243 | | Reflect _, Reflect { tm; _ } -> 244 | let* tm = neutral tm in 245 | return @@ C.Build.infer tm 246 | 247 | | Type _, Type Inf -> 248 | Error.internal "limit universe quotation" 249 | 250 | | Type l1, Type (Fin level) -> 251 | if not !Options.type_in_type && L.(l1 <= fin level) 252 | then Error.internal "ill-typed normal quotation: universe level" 253 | else return @@ C.Build.typ ~level () 254 | 255 | | Type _, Nat -> 256 | return @@ C.Build.nat () 257 | 258 | | Type _, Pi (a, f) -> 259 | let user = clo1_name f in 260 | let* a' = typ a in 261 | let* f = 262 | let$ x_a = fresh ~user a in 263 | normal_clo1 ~ty f x_a 264 | in 265 | return @@ C.Build.pi a' f 266 | 267 | | Pi (a, f), _ -> 268 | let user = clo1_name f in 269 | let$ x = fresh ~user a in 270 | let* body = normal_ ~ty:(Eval.clo1 f x) ~tm:(Eval.app tm x) in 271 | return @@ C.Build.lam (Bound1 { body; user = None; }) 272 | 273 | | Sigma (a, f), _ -> 274 | let base = Eval.fst tm in 275 | let* left = normal_ ~ty:a ~tm:base in 276 | let* right = normal_ ~ty:(Eval.clo1 f base) ~tm:(Eval.snd tm) in 277 | return @@ C.Build.pair left right 278 | 279 | | Nat, Zero -> 280 | return @@ C.Build.(infer @@ zero ()) 281 | 282 | | Nat, Suc tm -> 283 | let* tm = normal_ ~ty ~tm in 284 | return @@ C.Build.(infer @@ suc tm) 285 | 286 | | _ -> 287 | Error.internal "ill-typed normal quotation" 288 | 289 | and normal_ ~ty ~tm = 290 | let* { eta; _ } = M.get in 291 | if eta then normal_eta ~ty ~tm else value tm 292 | 293 | and normal (Reify { ty; tm; }) = 294 | normal_ ~ty ~tm 295 | 296 | and typ tm = 297 | normal_ ~ty:limtype ~tm 298 | 299 | and normal_clo1 ~ty (C1 (_, Bound1 { user; _ }) as clo) x = 300 | let* body = normal_ ~ty ~tm:(Eval.clo1 clo x) in 301 | return @@ C.Bound1 { body; user; } 302 | 303 | and normal_clo2 ~ty (C2 (_, Bound2 { user1; user2; _ }) as clo) x1 x2 = 304 | let* body = normal_ ~ty ~tm:(Eval.clo2 clo x1 x2) in 305 | return @@ C.Bound2 { body; user1; user2; } 306 | 307 | (* This function avoids calling typ directly, since typ is type-directed and 308 | we might be acting on an ill-typed value here. *) 309 | and value = function 310 | | Reflect { tm; _ } -> 311 | let* tm = neutral tm in 312 | return @@ C.Build.infer tm 313 | 314 | | Lam (C1 (env, body)) -> 315 | (* This could be written in direct style, but for the sake of consistency 316 | uses monadic style. Having a generic monadic fold in DeBruijn.Env 317 | would remove the need for the explicit recurion here, but I believe 318 | that this is this is too unpleasant to write in current OCaml. *) 319 | let rec wrap_env envseq = 320 | match envseq () with 321 | | Seq.Nil -> return @@ C.Build.lam body 322 | | Seq.Cons ({ def; ty; user; }, envseq) -> 323 | let* def = value def in 324 | let* ty = 325 | match ty with 326 | | None -> return @@ C.Build.nat () (* dummy type *) 327 | | Some ty -> value ty 328 | in 329 | let* body = weaken @@ wrap_env envseq in 330 | return @@ C.Build.let_ ~def ~ty 331 | ~body:(C.Bound1 { user = Some user; body; }) () 332 | in 333 | return @@ run ~eta:false ~free:0 @@ wrap_env (DeBruijn.Env.to_seq env) 334 | 335 | | (Pi (a, f) | Sigma (a, f) as s) -> 336 | let binder = 337 | (* TODO refactor *) 338 | match s with 339 | | Pi _ -> C.Build.pi | Sigma _ -> C.Build.sigma 340 | | _ -> assert false (* absurd *) 341 | in 342 | let user = clo1_name f in 343 | let* f = let$ x_a = fresh ~user a in normal_clo1 ~ty:limtype f x_a in 344 | let* a = normal_ ~ty:limtype ~tm:a in 345 | return @@ binder a f 346 | 347 | | Pair (left, right) -> 348 | let* left = value left in 349 | let* right = value right in 350 | return @@ C.Build.pair left right 351 | 352 | | Type (Fin level) -> 353 | return @@ C.Build.typ ~level () 354 | 355 | | Type Inf -> 356 | (* /!\ This function should only ever be used for printing, in which case 357 | this clause is not problematic even if the returned quotation is 358 | nonsensical. /!\ *) 359 | return @@ C.Build.typ ~level:max_int () 360 | 361 | | Nat -> 362 | return @@ C.Build.nat () 363 | 364 | | Zero -> 365 | return @@ C.Build.(infer @@ zero ()) 366 | 367 | | Suc tm -> 368 | let* tm = value tm in 369 | return @@ C.Build.(infer @@ suc tm) 370 | end 371 | 372 | module Conv = struct 373 | open Monad.Notation(Quote.M) 374 | 375 | (* TODO factor out somehow *) 376 | let (let$) = Quote.(let$) 377 | 378 | let (&&&) x y = let* b = x in if b then y else return false 379 | 380 | let level ~allow_subtype ~lo ~hi = 381 | let open UniverseLevel in 382 | return @@ if allow_subtype then lo <= hi else lo = hi 383 | 384 | let rec normal_ ~allow_subtype ~ty ~lo ~hi = 385 | match ty, lo, hi with 386 | | _, 387 | Reflect { tm = lo; _ }, 388 | Reflect { tm = hi; _ } -> 389 | neutral ~allow_subtype ~lo ~hi 390 | 391 | | Type _, 392 | Nat, 393 | Nat -> 394 | return true 395 | 396 | | Type _, 397 | Type l_lo, 398 | Type l_hi -> 399 | level ~allow_subtype ~lo:l_lo ~hi:l_hi 400 | 401 | | Type _, 402 | Pi (lo_dom, lo_cod), 403 | Pi (hi_dom, hi_cod) -> 404 | binder1 ~allow_subtype ~ty ~lo_dom ~lo_cod ~hi_dom ~hi_cod 405 | 406 | | Type _, 407 | Sigma (lo_dom, lo_cod), 408 | Sigma (hi_dom, hi_cod) -> 409 | binder1 ~allow_subtype ~ty ~lo_dom ~lo_cod ~hi_dom ~hi_cod 410 | 411 | | Nat, 412 | Zero, 413 | Zero -> 414 | return true 415 | 416 | | Nat, 417 | Suc lo, 418 | Suc hi -> 419 | normal_ ~allow_subtype ~ty ~lo ~hi 420 | 421 | | Pi (dom, cod), 422 | _, 423 | _ -> 424 | let$ x = Quote.fresh ~user:(clo1_name cod) dom in 425 | normal_ 426 | ~allow_subtype 427 | ~ty:(Eval.clo1 cod x) 428 | ~lo:(Eval.app lo x) 429 | ~hi:(Eval.app hi x) 430 | 431 | | Sigma (dom, cod), 432 | _, 433 | _ -> 434 | normal_ ~allow_subtype ~ty:dom ~lo:(Eval.fst lo) ~hi:(Eval.fst hi) 435 | &&& normal_ ~allow_subtype 436 | ~ty:(Eval.clo1 cod (Eval.fst lo)) 437 | ~lo:(Eval.snd lo) 438 | ~hi:(Eval.snd hi) 439 | 440 | | _ -> 441 | return false 442 | 443 | and binder1 ~allow_subtype ~ty ~lo_dom ~lo_cod ~hi_dom ~hi_cod = 444 | normal_ ~allow_subtype ~ty ~lo:hi_dom ~hi:lo_dom 445 | &&& 446 | let$ x = Quote.fresh ~user:(clo1_name lo_cod) lo_dom in 447 | normal_ ~allow_subtype 448 | ~ty 449 | ~lo:(Eval.clo1 lo_cod x) 450 | ~hi:(Eval.clo1 hi_cod x) 451 | 452 | and normal ~allow_subtype ~lo ~hi = 453 | let Reify { tm = lo; ty = lo_ty; } = lo in 454 | let Reify { tm = hi; ty = hi_ty; } = hi in 455 | normal_ ~allow_subtype ~ty:limtype ~lo:lo_ty ~hi:hi_ty 456 | &&& normal_ ~allow_subtype ~ty:lo ~lo ~hi 457 | 458 | and neutral ~allow_subtype ~lo ~hi = 459 | match lo, hi with 460 | | Var lv1, 461 | Var lv2 -> 462 | return @@ DeBruijn.Lv.equal lv1 lv2 463 | 464 | | App (lo_ne, lo_nf), 465 | App (hi_ne, hi_nf) -> 466 | neutral ~allow_subtype ~lo:lo_ne ~hi:hi_ne 467 | &&& normal ~allow_subtype ~lo:lo_nf ~hi:hi_nf 468 | 469 | | Natelim (lo_scrut, lo_motive, lo_case_zero, lo_case_succ), 470 | Natelim (hi_scrut, hi_motive, hi_case_zero, hi_case_succ) -> 471 | neutral ~allow_subtype ~lo:lo_scrut ~hi:hi_scrut 472 | &&& (let$ x1 = Quote.fresh ~user:(clo1_name lo_motive) Nat in 473 | normal_clo1 ~allow_subtype 474 | ~ty:limtype ~lo:lo_motive ~hi:hi_motive x1) 475 | &&& normal_ ~allow_subtype 476 | ~ty:(Eval.clo1 lo_motive Zero) ~lo:lo_case_zero ~hi:hi_case_zero 477 | &&& 478 | let$ x1 = Quote.fresh ~user:(clo1_name lo_motive) Nat in 479 | let$ x2 = 480 | Quote.fresh ~user:(clo1_name lo_motive) (Eval.clo1 lo_motive x1) 481 | in 482 | normal_clo2 483 | ~allow_subtype 484 | ~ty:(Eval.clo1 lo_motive (Suc x1)) 485 | ~lo:lo_case_succ ~hi:hi_case_succ x1 x2 486 | 487 | | _ -> 488 | return false 489 | 490 | and normal_clo1 ~allow_subtype ~ty ~lo ~hi arg = 491 | normal_ ~allow_subtype ~ty ~lo:(Eval.clo1 lo arg) ~hi:(Eval.clo1 hi arg) 492 | 493 | and normal_clo2 ~allow_subtype ~ty ~lo ~hi arg1 arg2 = 494 | normal_ ~allow_subtype ~ty 495 | ~lo:(Eval.clo2 lo arg1 arg2) 496 | ~hi:(Eval.clo2 hi arg1 arg2) 497 | 498 | let ty ~lo ~hi = 499 | normal_ ~allow_subtype:true ~ty:limtype ~lo ~hi 500 | 501 | let normalize ~ty ~tm = 502 | let open Monad.Notation(Eval.M) in 503 | let* tm = Eval.cterm tm in 504 | let* tm = Quote.(lift @@ normal @@ Reify { tm; ty; }) in 505 | return tm 506 | end 507 | 508 | module PPrint = struct 509 | let value tm env = 510 | let tm = 511 | Quote.(run ~eta:false ~free:(DeBruijn.Env.width env) @@ value tm) 512 | in 513 | Core.ToRaw.cterm tm (DeBruijn.Env.map (fun { user; _ } -> user) env) 514 | |> Raw.PPrint.term 515 | 516 | let entry { def; ty; user; } env doc = 517 | let open PPrint in 518 | let ty = match ty with 519 | | None -> empty 520 | | Some ty -> group @@ colon ^/^ value ty env ^^ space 521 | in 522 | group @@ 523 | prefix 2 1 524 | (prefix 2 1 (Name.pp user) (ty ^^ equals)) 525 | (value def env) 526 | ^^ (if DeBruijn.Env.width env > 1 then semi ^^ space else empty) 527 | ^^ doc 528 | 529 | let env env = 530 | DeBruijn.Env.fold_cons entry env PPrint.empty 531 | 532 | let clo1 (C1 (cenv, bound1)) = 533 | let doc = 534 | Core.ToRaw.bound1 bound1 (E.map (fun { user; _ } -> user) cenv) 535 | |> Raw.PPrint.bound1 536 | in 537 | PPrint.(doc ^^ braces (env cenv)) 538 | 539 | let clo2 (C2 (cenv, bound2)) = 540 | let doc = 541 | Core.ToRaw.bound2 bound2 (E.map (fun { user; _ } -> user) cenv) 542 | |> Raw.PPrint.bound2 543 | in 544 | PPrint.(doc ^^ braces (env cenv)) 545 | end 546 | -------------------------------------------------------------------------------- /src/Semantics.mli: -------------------------------------------------------------------------------- 1 | (** {1 Semantics} *) 2 | 3 | (** This module handles the normalization-by-evaluation (NbE) algorithm for the 4 | language defined in {! Core}. This relies on three key notions: values, 5 | neutrals, and normals. NbE consists in two main steps: 6 | 7 | - evaluation, which turns a piece of source code into a semantic value, and 8 | 9 | - quotation, which maps a semantic value back to source code. 10 | 11 | In contrast with what happens in classical evaluators for non-dependent 12 | languages, here evaluation is extended to deal with open terms. The 13 | quotation process is type-directed and guaranteed to return η-long, β-short 14 | normal forms. 15 | *) 16 | 17 | (** {2 Type declarations} *) 18 | 19 | (** Values are results of evaluation. Since we evaluate open terms, they include 20 | neutrals, which are blocked computations. We use closures to represent 21 | not-yet-evaluated pieces of code. *) 22 | type value = 23 | | Reflect of { ty : value; tm : neutral; } 24 | | Lam of clo1 25 | | Pi of value * clo1 26 | | Sigma of value * clo1 27 | | Pair of value * value 28 | | Type of UniverseLevel.t 29 | | Nat 30 | | Zero 31 | | Suc of value 32 | 33 | (** Neutrals are left abstract. *) 34 | and neutral 35 | 36 | (** A normal form is a value "reified" at some type. *) 37 | and normal = Reify of { ty : value; tm : value; } 38 | 39 | and clo1 = C1 of env * Core.bound1 40 | 41 | and clo2 = C2 of env * Core.bound2 42 | 43 | and entry = 44 | { 45 | def : value; (** Not used during quotation. *) 46 | ty : value option; (** Only used during type-checking. *) 47 | user : Name.t; (** Only used during elaboration *) 48 | } 49 | 50 | and env = entry DeBruijn.Env.t 51 | 52 | type ty = value 53 | 54 | (** {2 Evaluation, from syntax to semantics} *) 55 | 56 | module Eval : sig 57 | module M : Monad.Plain with type 'a t = env -> 'a 58 | 59 | val cterm : Core.cterm -> value M.t 60 | 61 | val iterm : Core.iterm -> value M.t 62 | 63 | val clo1 : clo1 -> value -> value 64 | 65 | val clo2 : clo2 -> value -> value -> value 66 | 67 | val fst : value -> value 68 | end 69 | 70 | (** {2 Quotation, from semantics to syntax} *) 71 | 72 | module Quote : sig 73 | module M : Monad.Plain 74 | 75 | (** [run ~eta ~free] runs the quotation monad, with the parameters controling 76 | the number of free variables as well as whether to perform η-expansion. *) 77 | val run : eta:bool -> free:int -> 'a M.t -> 'a 78 | 79 | (** The quotation monad has access to strictly less information than the 80 | evaluation monad. *) 81 | val lift : 'a M.t -> 'a Eval.M.t 82 | 83 | (** [fresh ~user ~def ty] generates a fresh name in the current 84 | environment. The user-supplied name [user] is optional, and so is the 85 | definition [def], which is otherwise replaced with a fresh variable of 86 | type [ty]. *) 87 | val fresh : ?user:Name.t -> ?def:value -> ty -> entry M.t 88 | 89 | val normal : normal -> Core.cterm M.t 90 | 91 | val typ : value -> Core.cterm M.t 92 | 93 | val neutral : neutral -> Core.iterm M.t 94 | 95 | (** [value] does not perform η-expansion, hence it should not be used when 96 | checking convertibility or, more generally, when performing normalization 97 | by evaluation. Nonetheless, it is useful, as it does not rely on typing 98 | information and can be used to print error messages in case of 99 | ill-typed. *) 100 | val value : value -> Core.cterm M.t 101 | end 102 | 103 | (** {2 Convertibility and normalization} *) 104 | 105 | module Conv : sig 106 | (** The [normalize] function composes reflection and reification to obtain 107 | normal forms. *) 108 | val normalize : ty:ty -> tm:Core.cterm -> Core.cterm Eval.M.t 109 | 110 | (** The [ty ~lo ~hi] tests whether [lo] is a subtype to [hi] for the subtyping 111 | relation induced by universe levels. Conceptually, this works by comparing 112 | normal forms, but the algorithm here is more efficient. *) 113 | val ty : lo:value -> hi:value -> bool Quote.M.t 114 | end 115 | 116 | (** {2 Utility functions} *) 117 | 118 | val close1 : Core.bound1 -> env -> clo1 119 | 120 | val close2 : Core.bound2 -> env -> clo2 121 | 122 | (** [limtype] is the top of our universe hierarchy. It does not exist in the 123 | syntax but allows for a simpler formulation of the elaboration algorithm. *) 124 | val limtype : value 125 | 126 | (** {2 Printing} *) 127 | 128 | module PPrint : sig 129 | val value : value -> env -> PPrint.document 130 | val env : env -> PPrint.document 131 | val clo1 : clo1 -> PPrint.document 132 | val clo2 : clo2 -> PPrint.document 133 | end 134 | -------------------------------------------------------------------------------- /src/Sigs.ml: -------------------------------------------------------------------------------- 1 | module type HashedOrderedType = sig 2 | type t 3 | include Hashtbl.HashedType with type t := t 4 | include Map.OrderedType with type t := t 5 | end 6 | 7 | module String = struct 8 | type t = string 9 | let hash (x : t) = Hashtbl.hash x 10 | let compare (x : t) (y : t) = Stdlib.compare x y 11 | let equal (x : t) (y : t) = x = y 12 | end 13 | 14 | type 'a cmp = 'a -> 'a -> int 15 | 16 | type 'a hash = 'a -> int 17 | 18 | module type Signature = sig 19 | type 'a t 20 | val map : ('a -> 'b) -> 'a t -> 'b t 21 | val compare : 'a cmp -> 'a t cmp 22 | val hash : 'a hash -> 'a t hash 23 | end 24 | 25 | module type PrintableType = sig 26 | type t 27 | val pp : t -> PPrint.document 28 | end 29 | 30 | module type PrintableComparableType = sig 31 | include PrintableType 32 | include Map.OrderedType with type t := t 33 | val equal : t -> t -> bool 34 | end 35 | 36 | module Formatter = struct 37 | type 'a t = Format.formatter -> 'a -> unit 38 | let pp_if enabled pp fmt x = if enabled then pp fmt x else () 39 | end 40 | 41 | module Unicode = struct 42 | let utf8_string_of_uchar_array a = 43 | let b = Buffer.create (Array.length a) in 44 | Array.iter (Buffer.add_utf_8_uchar b) a; 45 | Buffer.contents b 46 | end 47 | 48 | module Int = struct 49 | let rec fold f n acc = if n = 0 then acc else f (fold f (n - 1) acc) 50 | end 51 | -------------------------------------------------------------------------------- /src/UnicodeSigil.ml: -------------------------------------------------------------------------------- 1 | type encoding = 2 | | ASCII 3 | | UTF8 4 | 5 | let encoding_of_string = function 6 | | "ascii" -> Some ASCII 7 | | "utf8" -> Some UTF8 8 | | _ -> None 9 | 10 | let encoding = ref UTF8 11 | 12 | let set_encoding s = encoding := s 13 | 14 | type t = 15 | { 16 | utf8 : string; 17 | ascii : string; 18 | } 19 | 20 | let string s = 21 | match !encoding with 22 | | ASCII -> s.ascii 23 | | UTF8 -> s.utf8 24 | 25 | let doc s = 26 | match !encoding with 27 | | ASCII -> PPrint.string s.ascii 28 | | UTF8 -> PPrint.utf8string s.utf8 29 | 30 | let pp = ExtPrint.to_fmt doc 31 | 32 | let make codepoints ascii_fallback = 33 | { utf8 = Array.map Uchar.of_int codepoints 34 | |> Sigs.Unicode.utf8_string_of_uchar_array; 35 | ascii = ascii_fallback; } 36 | 37 | let lambda = make [| 955 |] "\\" 38 | 39 | let forall = make [| 8704 |] "forall" 40 | 41 | let srarrow = make [| 8594 |] "->" 42 | 43 | let drarrow = make [| 8658 |] "=>" 44 | 45 | let slarrow = make [| 8592 |] "<-" 46 | 47 | let dlarrow = make [| 8656 |] "<=" 48 | 49 | let typ = make [| 120140 |] "Type" 50 | 51 | let nat = make [| 8469 |] "Nat" 52 | 53 | let tripleq = make [| 0x2261 |] "==" 54 | 55 | let checkmark = make [| 0x2713 |] "ok" 56 | 57 | let langle = make [| 0x27E8 |] "<" 58 | 59 | let rangle = make [| 0x27E9 |] ">" 60 | 61 | let omega = make [| 0x03C9 |] "omega" 62 | 63 | let times = make [| 0x00D7 |] "*" 64 | 65 | let sigma = make [| 0x03A3 |] "sigma" 66 | -------------------------------------------------------------------------------- /src/UnicodeSigil.mli: -------------------------------------------------------------------------------- 1 | type encoding = 2 | | ASCII 3 | | UTF8 4 | 5 | val encoding_of_string : string -> encoding option 6 | 7 | val set_encoding : encoding -> unit 8 | 9 | type t 10 | 11 | val string : t -> string 12 | 13 | val doc : t -> PPrint.document 14 | 15 | val pp : Format.formatter -> t -> unit 16 | 17 | val lambda : t 18 | 19 | val forall : t 20 | 21 | val srarrow : t 22 | 23 | val drarrow : t 24 | 25 | val slarrow : t 26 | 27 | val dlarrow : t 28 | 29 | val typ : t 30 | 31 | val nat : t 32 | 33 | val tripleq : t 34 | 35 | val checkmark : t 36 | 37 | val langle : t 38 | 39 | val rangle : t 40 | 41 | val omega : t 42 | 43 | val times : t 44 | 45 | val sigma : t 46 | -------------------------------------------------------------------------------- /src/UniverseLevel.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Conv 2 | 3 | type t = 4 | | Fin of int 5 | | Inf 6 | [@@deriving sexp_of] 7 | 8 | let fin l = 9 | if l < 0 then invalid_arg "finite"; 10 | Fin l 11 | 12 | let inf = Inf 13 | 14 | let max l1 l2 = 15 | match l1, l2 with 16 | | _, Inf | Inf, _ -> Inf 17 | | Fin i, Fin j -> Fin (max i j) 18 | 19 | let ( = ) (l1 : t) l2 = l1 = l2 20 | 21 | let ( <= ) l1 l2 = 22 | match l1, l2 with 23 | | _, Inf -> true 24 | | Inf, _ -> false 25 | | Fin i, Fin j -> i <= j 26 | 27 | let ( < ) l1 l2 = 28 | match l1, l2 with 29 | | Fin _, Inf -> true 30 | | Inf, _ -> false 31 | | Fin i, Fin j -> i < j 32 | 33 | module PPrint = struct 34 | let level = function 35 | | Fin i -> PPrint.string @@ string_of_int i 36 | | Inf -> UnicodeSigil.(doc omega) 37 | end 38 | -------------------------------------------------------------------------------- /src/UniverseLevel.mli: -------------------------------------------------------------------------------- 1 | type t = private 2 | | Fin of int 3 | | Inf 4 | 5 | val fin : int -> t 6 | 7 | val inf : t 8 | 9 | val max : t -> t -> t 10 | 11 | val ( = ) : t -> t -> bool 12 | 13 | val ( <= ) : t -> t -> bool 14 | 15 | val ( < ) : t -> t -> bool 16 | 17 | val sexp_of_t : t -> Sexplib.Sexp.t 18 | 19 | module PPrint : sig 20 | val level : t -> PPrint.document 21 | end 22 | -------------------------------------------------------------------------------- /src/Var.ml: -------------------------------------------------------------------------------- 1 | module M = Symbol.Make() 2 | include M 3 | -------------------------------------------------------------------------------- /src/Var.mli: -------------------------------------------------------------------------------- 1 | include Symbol.S 2 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name melitte) 3 | (name melitte) 4 | (libraries menhirLib pprint sexplib) 5 | (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving.ord sedlex.ppx 6 | ppx_sexp_conv)) 7 | (promote (until-clean))) 8 | 9 | (menhir (modules Parse) (flags --explain --table)) 10 | -------------------------------------------------------------------------------- /src/melitte.ml: -------------------------------------------------------------------------------- 1 | let parse inp = 2 | let fname, ic = 3 | match inp with 4 | | `Stdin -> "*stdin*", stdin 5 | | `File fname -> fname, open_in fname 6 | in 7 | let lexbuf = Sedlexing.Utf8.from_channel ic in 8 | Sedlexing.set_filename lexbuf fname; 9 | let token = Sedlexing.with_tokenizer Lex.token lexbuf in 10 | let file = 11 | MenhirLib.Convert.Simplified.traditional2revised 12 | Parse.whole_file 13 | in 14 | let raw = file token in 15 | close_in ic; 16 | raw 17 | 18 | let pass banner pp f input = 19 | let output = f input in 20 | if !Options.verbose 21 | then 22 | begin 23 | Printf.printf "{- %s -}\n" banner; 24 | ExtPrint.to_out (pp output); 25 | print_newline (); flush stdout; 26 | end; 27 | output 28 | 29 | let pp_env fmt env = 30 | Format.fprintf fmt " in [@[%a@]]" 31 | (ExtPrint.to_fmt Semantics.PPrint.env) env 32 | 33 | let on_check_pre env ~expected tm = 34 | if !Options.debug 35 | then 36 | Format.eprintf "@[@[%a@]@ %a? @[%a@]@[%a@]@]@." 37 | (ExtPrint.to_fmt Raw.PPrint.term) tm 38 | UnicodeSigil.pp UnicodeSigil.dlarrow 39 | (ExtPrint.to_fmt (fun v -> Semantics.PPrint.value v env)) expected 40 | (Sigs.Formatter.pp_if !Options.verbose pp_env) env 41 | 42 | let on_infer_pre env tm = 43 | if !Options.debug 44 | then 45 | Format.eprintf "@[@[%a@]@ %a?@[%a@]@]@." 46 | (ExtPrint.to_fmt Raw.PPrint.term) tm 47 | UnicodeSigil.pp UnicodeSigil.drarrow 48 | (Sigs.Formatter.pp_if !Options.verbose pp_env) env 49 | 50 | let on_conversion_pre env ~expected ~actual _loc = 51 | if !Options.debug 52 | then 53 | Format.eprintf "@[@[%a@]@ <:? @[%a@]@]@." 54 | (ExtPrint.to_fmt (fun v -> Semantics.PPrint.value v env)) actual 55 | (ExtPrint.to_fmt (fun v -> Semantics.PPrint.value v env)) expected 56 | 57 | let on_check_post env ~expected tm = 58 | if !Options.debug 59 | then 60 | Format.eprintf "@[@[%a@]@ %a%a @[%a@]@]@." 61 | (ExtPrint.to_fmt Raw.PPrint.term) tm 62 | UnicodeSigil.pp UnicodeSigil.dlarrow 63 | UnicodeSigil.pp UnicodeSigil.checkmark 64 | (ExtPrint.to_fmt (fun v -> Semantics.PPrint.value v env)) expected 65 | 66 | let on_infer_post env tm ~actual = 67 | if !Options.debug 68 | then 69 | Format.eprintf "@[@[%a@]@ %a%a @[%a@]@]@." 70 | (ExtPrint.to_fmt Raw.PPrint.term) tm 71 | UnicodeSigil.pp UnicodeSigil.drarrow 72 | UnicodeSigil.pp UnicodeSigil.checkmark 73 | (ExtPrint.to_fmt (fun v -> Semantics.PPrint.value v env)) actual 74 | 75 | let on_conversion_post env ~expected ~actual _loc = 76 | if !Options.debug 77 | then 78 | Format.eprintf "@[@[%a@]@ <:%a @[%a@]@]@." 79 | (ExtPrint.to_fmt (fun v -> Semantics.PPrint.value v env)) actual 80 | UnicodeSigil.pp UnicodeSigil.checkmark 81 | (ExtPrint.to_fmt (fun v -> Semantics.PPrint.value v env)) expected 82 | 83 | let process inp = 84 | try 85 | pass "Raw code" Raw.PPrint.file parse inp 86 | |> pass 87 | "Elaborated code" 88 | Core.PPrint.file 89 | Elaborator.(fun x -> run 90 | ~on_check_pre 91 | ~on_infer_pre 92 | ~on_conversion_pre 93 | ~on_check_post 94 | ~on_infer_post 95 | ~on_conversion_post 96 | @@ check x) 97 | |> ignore 98 | with Error.Error err -> 99 | Format.eprintf "%a@." Error.print err; 100 | exit 1 101 | 102 | let () = 103 | let open Arg in 104 | let process_stdin = ref false in 105 | let inputs = ref [] in 106 | parse 107 | (align 108 | [ 109 | "-stdin", Set process_stdin, " read standard input"; 110 | "-encoding", Symbol (["utf8"; "ascii"], 111 | fun s -> UnicodeSigil.encoding_of_string s 112 | |> Option.get 113 | |> UnicodeSigil.set_encoding), 114 | " set output encoding"; 115 | "-type-in-type", Set Options.type_in_type, 116 | " accept type-in-type (inconsistent)"; 117 | "-d", Set Options.debug, 118 | " enable debugging features"; 119 | "-v", Set Options.verbose, 120 | " print actions during elaboration"; 121 | ] 122 | ) 123 | (fun s -> inputs := `File s :: !inputs) 124 | (Printf.sprintf "Usage: %s [OPTIONS] file1.tt ... fileN.tt" Sys.argv.(0)); 125 | Printexc.record_backtrace !Options.debug; 126 | if !process_stdin then inputs := !inputs @ [`Stdin]; 127 | List.iter process !inputs 128 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps %{bin:melitte})) 3 | -------------------------------------------------------------------------------- /tests/simple.t/run.t: -------------------------------------------------------------------------------- 1 | $ melitte -v t1.melitte 2 | {- Raw code -} 3 | val id : ∀ (A : 𝕌 0) → A → A = λ A x ⇒ x 4 | {- Elaborated code -} 5 | val id : ∀ (A : 𝕌 0) (_1 : A) → A = λ A x ⇒ x 6 | $ melitte -v t2.melitte 7 | {- Raw code -} 8 | val c : ℕ → ℕ = λ n ⇒ n 9 | eval suc c 0 10 | val add : ℕ → ℕ → ℕ = λ n m ⇒ elim n with _ ⇒ ℕ { zero ⇒ m | suc _, r ⇒ suc r } 11 | eval add 2 5 12 | val mul : ℕ → ℕ → ℕ = 13 | λ n m ⇒ elim n with _ ⇒ ℕ { zero ⇒ 0 | suc _, r ⇒ add m r } 14 | eval mul 3 10 15 | {- Elaborated code -} 16 | val c : ∀ (_0 : ℕ) → ℕ = λ n ⇒ n 17 | eval (1 : ℕ) 18 | val add : ∀ (_1 : ℕ) (_2 : ℕ) → ℕ = 19 | λ n m ⇒ elim n with _3 ⇒ ℕ { zero ⇒ m | suc _3, r ⇒ suc r } 20 | eval (7 : ℕ) 21 | val mul : ∀ (_2 : ℕ) (_3 : ℕ) → ℕ = 22 | λ n m ⇒ elim n with _4 ⇒ ℕ { zero ⇒ 0 | suc _4, r ⇒ add m r } 23 | eval (30 : ℕ) 24 | $ melitte -v t3.melitte 25 | File "t3.melitte", line 1, characters 19-20: syntax error 26 | [1] 27 | $ melitte -v simple.melitte 28 | {- Raw code -} 29 | val x : 𝕌 0 = ℕ 30 | val three : x = 3 31 | val const : ℕ → ℕ = λ x ⇒ 0 32 | val id : ∀ (A : 𝕌 0) → A → A = λ A x ⇒ x 33 | val iter : ∀ (A : 𝕌 0) (f : A → A) → A → ℕ → A = 34 | λ A f z n ⇒ elim n with _ ⇒ A { zero ⇒ z | suc _, r ⇒ f r } 35 | val add : ℕ → ℕ → ℕ = iter ℕ (λ n ⇒ suc n) 36 | val mul : ℕ → ℕ → ℕ = λ n ⇒ iter ℕ (add n) 0 37 | val exp : ℕ → ℕ → ℕ = λ n ⇒ iter ℕ (mul n) 1 38 | {- Elaborated code -} 39 | val x : 𝕌 0 = ℕ 40 | val three : x = 3 41 | val const : ∀ (_2 : ℕ) → ℕ = λ x ⇒ 0 42 | val id : ∀ (A : 𝕌 0) (_4 : A) → A = λ A x ⇒ x 43 | val iter : ∀ (A : 𝕌 0) (f : ∀ (_5 : A) → A) (_6 : A) (_7 : ℕ) → A = 44 | λ A f z n ⇒ elim n with _8 ⇒ A { zero ⇒ z | suc _8, r ⇒ f r } 45 | val add : ∀ (_5 : ℕ) (_6 : ℕ) → ℕ = iter ℕ (λ n ⇒ suc n) 46 | val mul : ∀ (_6 : ℕ) (_7 : ℕ) → ℕ = λ n ⇒ iter ℕ (add n) 0 47 | val exp : ∀ (_7 : ℕ) (_8 : ℕ) → ℕ = λ n ⇒ iter ℕ (mul n) 1 48 | 49 | Melitte contains a hierarchy of universes. 50 | 51 | $ melitte t4.melitte 52 | File "t4.melitte", line 1, characters 23-26: universe inconsistency 53 | [1] 54 | 55 | Melitte contains Σ types. 56 | 57 | $ melitte t5.melitte 58 | -------------------------------------------------------------------------------- /tests/simple.t/simple.melitte: -------------------------------------------------------------------------------- 1 | val x : 𝕌 0 = Nat 2 | 3 | val three : x = suc suc suc zero 4 | 5 | val const : ℕ → ℕ = λ x ⇒ zero 6 | 7 | val id : ∀ (A : 𝕌 0) → A → A = λ A x ⇒ x 8 | 9 | val iter : ∀ (A : 𝕌 0) (f : A → A) → A → ℕ → A = 10 | λ A f z n ⇒ elim n with _ ⇒ A { zero ⇒ z | suc _, r ⇒ f r } 11 | 12 | val add : ℕ → ℕ → ℕ = iter ℕ (λ n ⇒ suc n) 13 | 14 | val mul : ℕ → ℕ → ℕ = λ n ⇒ iter ℕ (add n) zero 15 | 16 | val exp : ℕ → ℕ → ℕ = λ n ⇒ iter ℕ (mul n) 1 17 | 18 | {- 19 | val exp_n : ℕ → 𝕌 = 20 | let exp_once : 𝕌 → 𝕌 = λ t ⇒ ℕ → t in 21 | iter 𝕌 exp_once n ℕ 22 | -} 23 | -------------------------------------------------------------------------------- /tests/simple.t/t1.melitte: -------------------------------------------------------------------------------- 1 | {-val c1 : ℕ → ℕ = λ n ⇒ n-} 2 | 3 | val id : ∀ (A : 𝕌 0) → A → A = λ A x ⇒ x 4 | 5 | {- 6 | val abs : 𝕌 0 = ∀ (A : 𝕌 0) → A 7 | 8 | val c2 : ℕ → ℕ = id (ℕ → ℕ) (λ n ⇒ n) 9 | -} 10 | -------------------------------------------------------------------------------- /tests/simple.t/t2.melitte: -------------------------------------------------------------------------------- 1 | val c : ℕ → ℕ = λ n ⇒ n 2 | 3 | eval suc (c 0) 4 | 5 | val add : ℕ → ℕ → ℕ = 6 | λ n m ⇒ elim n with _ ⇒ ℕ { zero ⇒ m | suc _, r ⇒ suc r } 7 | 8 | eval add 2 5 9 | 10 | val mul : ℕ → ℕ → ℕ = 11 | λ n m ⇒ elim n with _ ⇒ ℕ { zero ⇒ 0 | suc _, r ⇒ add m r } 12 | 13 | eval mul 3 10 14 | -------------------------------------------------------------------------------- /tests/simple.t/t3.melitte: -------------------------------------------------------------------------------- 1 | val iter : ∀ (A : 𝕌) (f : A → A) → ℕ → A → A = 2 | λ A f n z ⇒ z 3 | 4 | val c : ℕ → ℕ → ℕ = iter ℕ (λ m ⇒ m) 5 | -------------------------------------------------------------------------------- /tests/simple.t/t4.melitte: -------------------------------------------------------------------------------- 1 | val bad : 𝕌 0 = ∀ (A : 𝕌 1) → A 2 | -------------------------------------------------------------------------------- /tests/simple.t/t5.melitte: -------------------------------------------------------------------------------- 1 | val MagmaStruct : 𝕌 0 → 𝕌 0 = λ A ⇒ A × (A → A → A) 2 | 3 | val Magma : 𝕌 1 = Σ(A : 𝕌 0) × MagmaStruct A 4 | 5 | val add : ℕ → ℕ → ℕ = λ n m ⇒ elim n with _ ⇒ ℕ { zero ⇒ 0 | suc _, r ⇒ suc r } 6 | 7 | val Magma-ℕ : Magma = (ℕ, (zero, add)) 8 | --------------------------------------------------------------------------------