├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── leantc.cabal ├── src ├── Frontend │ └── Parser.hs ├── Kernel │ ├── Expr.hs │ ├── Expr │ │ └── Internal.hs │ ├── Inductive.hs │ ├── Inductive │ │ └── Internal.hs │ ├── Level.hs │ ├── Level │ │ └── Internal.hs │ ├── Name.hs │ ├── Name │ │ └── Internal.hs │ ├── Quotient.hs │ ├── TypeChecker.hs │ └── TypeChecker │ │ └── Internal.hs └── Lib.hs ├── stack.yaml └── test ├── ExprSpec.hs ├── Integration.hs ├── LevelSpec.hs ├── Spec.hs └── TypeCheckerSpec.hs /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 | # Lean reference type-checker 2 | 3 | This project will eventually be a reference type-checker for the Lean theorem prover: a simple and small program that can type-check fully elaborated Lean terms, exported in the following low-level format: 4 | 5 | https://github.com/leanprover/lean/blob/master/doc/export_format.md 6 | 7 | The main Lean repository can be found at: 8 | 9 | https://github.com/leanprover/lean 10 | 11 | The code follows the design of the Lean kernel closely, except can be made simpler since it does not need to integrate with parsing and elaboration, and because it need not be as performant. 12 | 13 | #### Build Instructions 14 | 15 | This project uses the new Stack Haskell build system. More information can be found at: 16 | 17 | http://docs.haskellstack.org/en/stable/README/ 18 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Frontend.Parser 4 | 5 | import System.Environment 6 | import Data.List (isSuffixOf) 7 | 8 | printUsage = putStrLn "usage: leantc .[h]out" 9 | 10 | main = do 11 | args <- getArgs 12 | case args of 13 | [] -> printUsage 14 | (_:_:_) -> printUsage 15 | [filename] -> do 16 | fileContents <- readFile filename 17 | case typeCheckExportFile filename fileContents of 18 | Left err -> putStrLn err 19 | Right _ -> putStrLn "Congratulations!" 20 | -------------------------------------------------------------------------------- /leantc.cabal: -------------------------------------------------------------------------------- 1 | name: leantc 2 | version: 0.1.0.0 3 | synopsis: Reference type checker for Lean Theorem Prover 4 | description: Please see README.md 5 | homepage: http://github.com/dselsam/leantc#readme 6 | license: GPL-3 7 | license-file: LICENSE 8 | author: Daniel Selsam 9 | maintainer: daniel.selsam@gmail.com 10 | copyright: 2016 Daniel Selsam 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Lib, Kernel.Name, Kernel.Name.Internal, Kernel.Level, Kernel.Level.Internal, Kernel.Expr, Kernel.Expr.Internal, Kernel.TypeChecker.Internal, Kernel.TypeChecker, Kernel.Inductive.Internal, Kernel.Inductive, Frontend.Parser, Kernel.Quotient 18 | build-depends: base >= 4.7 && < 5 19 | , containers 20 | , lens-simple 21 | , mtl 22 | , transformers 23 | , text 24 | , parsec 25 | default-language: Haskell2010 26 | ghc-options: -O3 -threaded 27 | 28 | executable leantc-exe 29 | hs-source-dirs: app 30 | main-is: Main.hs 31 | -- ghc-options: -O3 -threaded -rtsopts -with-rtsopts=-N 32 | ghc-options: -O3 -threaded 33 | build-depends: base 34 | , leantc 35 | default-language: Haskell2010 36 | 37 | test-suite leantc-test 38 | type: exitcode-stdio-1.0 39 | hs-source-dirs: test 40 | main-is: Spec.hs 41 | -- other-modules: LevelSpec.hs, ExprSpec.hs, TypeCheckerSpec.hs, Integration.hs 42 | build-depends: base 43 | , leantc 44 | , hspec 45 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 46 | default-language: Haskell2010 47 | 48 | source-repository head 49 | type: git 50 | location: https://github.com/githubuser/leantc 51 | -------------------------------------------------------------------------------- /src/Frontend/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Frontend.Parser where 3 | 4 | import System.Environment 5 | import Text.Parsec 6 | 7 | import Kernel.Name 8 | import Kernel.Level 9 | import Kernel.Expr 10 | 11 | import Kernel.TypeChecker 12 | import Kernel.Inductive 13 | import Kernel.Quotient 14 | 15 | import Control.Monad 16 | import qualified Control.Monad.State as S 17 | import Control.Monad.Reader 18 | import Control.Monad.Trans.Except 19 | 20 | import Numeric 21 | import Lens.Simple (makeLenses, view, over, use, uses, (%=), (.=), (<~), (+=)) 22 | 23 | import qualified Data.Map as Map 24 | import Data.Map (Map) 25 | 26 | import qualified Data.Set as Set 27 | import Data.Set (Set) 28 | 29 | import Debug.Trace 30 | data IdxType = IdxName | IdxLevel | IdxExpr | IdxUni deriving (Show) 31 | 32 | data ExportError = RepeatedIdx IdxType 33 | | UnknownIdx IdxType 34 | | TError TypeError 35 | | QError QuotientError 36 | | IDeclError IndDeclError deriving (Show) 37 | 38 | data Context = Context { 39 | _ctxNameMap :: Map Integer Name, 40 | _ctxLevelMap :: Map Integer Level, 41 | _ctxExprMap :: Map Integer Expr, 42 | _ctxEnv :: Env, 43 | _ctxDefId :: Integer, 44 | _ctxIndId :: Integer 45 | } 46 | 47 | makeLenses ''Context 48 | 49 | blank = char ' ' 50 | 51 | mkStdContext = Context (Map.insert 0 noName Map.empty) (Map.insert 0 mkZero Map.empty) Map.empty mkStdEnv 0 0 52 | 53 | type ParserMethod = ParsecT String () (ExceptT ExportError (S.State Context)) 54 | 55 | parseInteger :: ParserMethod Integer 56 | parseInteger = do 57 | digits <- many1 digit 58 | return . fst $ ((readDec digits)!!0) 59 | 60 | parseInt :: ParserMethod Int 61 | parseInt = liftM read (many1 digit) 62 | 63 | assertUndefined :: Integer -> IdxType -> Map Integer a -> ExceptT ExportError (S.State Context) () 64 | assertUndefined idx idxType m = if Map.member idx m then throwE (RepeatedIdx idxType) else return () 65 | 66 | parseExportFile :: ParserMethod () 67 | parseExportFile = sepEndBy1 parseStatement newline >> eof 68 | where 69 | parseStatement :: ParserMethod () 70 | parseStatement = do 71 | try parseDefinition <|> try parseValue <|> parseNotation 72 | 73 | parseDefinition :: ParserMethod () 74 | parseDefinition = char '#' >> ((string "DEF " >> parseDEF) <|> (string "AX " >> parseAX) <|> (string "IND " >> parseIND) <|> (string "QUOT" >> parseQUOT)) 75 | 76 | parseDEF :: ParserMethod () 77 | parseDEF = do 78 | nameIdx <- parseInteger <* blank 79 | typeIdx <- parseInteger <* blank 80 | valueIdx <- parseInteger 81 | lpNameIdxs <- manyTill (blank >> parseInteger) (lookAhead newline) 82 | lift $ do 83 | name <- uses ctxNameMap (Map.! nameIdx) 84 | lpNames <- uses ctxNameMap (\m -> map (m Map.!) lpNameIdxs) 85 | ty <- uses ctxExprMap (Map.! typeIdx) 86 | val <- uses ctxExprMap (Map.! valueIdx) 87 | ctxDefId += 1 88 | env <- use ctxEnv 89 | use ctxDefId >>= (\did -> trace ("DEF(" ++ show did ++ "): " ++ show name) (return ())) 90 | case envAddDefinition name lpNames ty val env of 91 | Left err -> throwE $ TError err 92 | Right env -> ctxEnv .= env 93 | 94 | parseAX :: ParserMethod () 95 | parseAX = do 96 | nameIdx <- parseInteger <* blank 97 | typeIdx <- parseInteger 98 | lpNameIdxs <- manyTill (blank >> parseInteger) (lookAhead newline) 99 | lift $ do 100 | name <- uses ctxNameMap (Map.! nameIdx) 101 | lpNames <- uses ctxNameMap (\m -> map (m Map.!) lpNameIdxs) 102 | ty <- uses ctxExprMap (Map.! typeIdx) 103 | ctxDefId += 1 104 | env <- use ctxEnv 105 | use ctxDefId >>= (\did -> trace ("AX(" ++ show did ++ "): " ++ show name) (return ())) 106 | case envAddAxiom name lpNames ty env of 107 | Left err -> throwE $ TError err 108 | Right env -> ctxEnv .= env 109 | 110 | parseQUOT :: ParserMethod () 111 | parseQUOT = do 112 | lift $ do 113 | env <- use ctxEnv 114 | case declareQuotient env of 115 | Left err -> throwE $ QError err 116 | Right env -> ctxEnv .= env 117 | 118 | parseIND :: ParserMethod () 119 | parseIND = do 120 | numParams <- parseInt <* blank 121 | indNameIdx <- parseInteger <* blank 122 | indTypeIdx <- parseInteger <* blank 123 | numIntroRules <- parseInt 124 | introRules <- count numIntroRules (blank >> parseIntroRule) 125 | lpNameIdxs <- manyTill (blank >> parseInteger) (lookAhead newline) 126 | lift $ do 127 | indName <- uses ctxNameMap (Map.! indNameIdx) 128 | lpNames <- uses ctxNameMap (\m -> map (m Map.!) lpNameIdxs) 129 | indType <- uses ctxExprMap (Map.! indTypeIdx) 130 | ctxIndId += 1 131 | use ctxIndId >>= (\did -> trace ("IND(" ++ show did ++ "): " ++ show indName ++ show lpNames) (return ())) 132 | env <- use ctxEnv 133 | case addInductive env (IndDecl numParams lpNames indName indType introRules) of 134 | Left err -> throwE $ IDeclError err 135 | Right env -> ctxEnv .= env 136 | 137 | parseIntroRule :: ParserMethod IntroRule 138 | parseIntroRule = do 139 | irNameIdx <- parseInteger <* blank 140 | irTypeIdx <- parseInteger 141 | lift $ do 142 | irName <- uses ctxNameMap (Map.! irNameIdx) 143 | irType <- uses ctxExprMap (Map.! irTypeIdx) 144 | return $ IntroRule irName irType 145 | 146 | parseValue :: ParserMethod () 147 | parseValue = do 148 | try parseN <|> try parseU <|> parseE 149 | 150 | parseN = try parseNI <|> parseNS 151 | parseU = try parseUS <|> try parseUM <|> try parseUIM <|> try parseUP <|> parseUG 152 | parseE = try parseEV <|> try parseES <|> try parseEC <|> try parseEA <|> try parseEL <|> try parseEP <|> parseEZ 153 | 154 | parseNI = do 155 | newIdx <- parseInteger <* blank 156 | string "#NI" >> blank 157 | oldIdx <- parseInteger <* blank 158 | i <- parseInteger 159 | lift $ do 160 | use ctxNameMap >>= assertUndefined newIdx IdxName 161 | ctxNameMap <~ (uses ctxNameMap (\m -> Map.insert newIdx (nameRConsI (m Map.! oldIdx) i) m)) 162 | 163 | parseNS = do 164 | newIdx <- parseInteger <* blank 165 | string "#NS" >> blank 166 | oldIdx <- parseInteger <* blank 167 | s <- manyTill anyChar (lookAhead newline) 168 | lift $ do 169 | use ctxNameMap >>= assertUndefined newIdx IdxName 170 | ctxNameMap <~ (uses ctxNameMap (\m -> Map.insert newIdx (nameRConsS (m Map.! oldIdx) s) m)) 171 | 172 | parseUS = do 173 | newIdx <- parseInteger <* blank 174 | string "#US" >> blank 175 | oldIdx <- parseInteger 176 | s <- many (blank *> alphaNum) 177 | lift $ do 178 | use ctxLevelMap >>= assertUndefined newIdx IdxLevel 179 | ctxLevelMap <~ (uses ctxLevelMap (\m -> Map.insert newIdx (mkSucc (m Map.! oldIdx)) m)) 180 | 181 | parseUM = do 182 | newIdx <- parseInteger <* blank 183 | string "#UM" >> blank 184 | lhsIdx <- parseInteger <* blank 185 | rhsIdx <- parseInteger 186 | lift $ do 187 | use ctxLevelMap >>= assertUndefined newIdx IdxLevel 188 | ctxLevelMap <~ (uses ctxLevelMap (\m -> Map.insert newIdx (mkMax (m Map.! lhsIdx) (m Map.! rhsIdx)) m)) 189 | 190 | parseUIM = do 191 | newIdx <- parseInteger <* blank 192 | string "#UIM" >> blank 193 | lhsIdx <- parseInteger <* blank 194 | rhsIdx <- parseInteger 195 | lift $ do 196 | use ctxLevelMap >>= assertUndefined newIdx IdxLevel 197 | ctxLevelMap <~ (uses ctxLevelMap (\m -> Map.insert newIdx (mkIMax (m Map.! lhsIdx) (m Map.! rhsIdx)) m)) 198 | 199 | parseUP = do 200 | newIdx <- parseInteger <* blank 201 | string "#UP" >> blank 202 | nameIdx <- parseInteger 203 | lift $ do 204 | use ctxLevelMap >>= assertUndefined newIdx IdxLevel 205 | name <- uses ctxNameMap (Map.! nameIdx) 206 | ctxLevelMap %= Map.insert newIdx (mkLevelParam name) 207 | 208 | parseUG = do 209 | newIdx <- parseInteger <* blank 210 | string "#UG" >> blank 211 | nameIdx <- parseInteger 212 | lift $ do 213 | use ctxLevelMap >>= assertUndefined newIdx IdxLevel 214 | name <- uses ctxNameMap (Map.! nameIdx) 215 | ctxLevelMap %= Map.insert newIdx (mkGlobalLevel name) 216 | 217 | parseEV = do 218 | newIdx <- parseInteger <* blank 219 | string "#EV" >> blank 220 | varIdx <- parseInt 221 | lift $ do 222 | use ctxExprMap >>= assertUndefined newIdx IdxExpr 223 | ctxExprMap %= Map.insert newIdx (mkVar varIdx) 224 | 225 | parseES = do 226 | newIdx <- parseInteger <* blank 227 | string "#ES" >> blank 228 | levelIdx <- parseInteger 229 | lift $ do 230 | use ctxExprMap >>= assertUndefined newIdx IdxExpr 231 | level <- uses ctxLevelMap (Map.! levelIdx) 232 | ctxExprMap %= Map.insert newIdx (mkSort level) 233 | 234 | parseEC = do 235 | newIdx <- parseInteger <* blank 236 | string "#EC" >> blank 237 | nameIdx <- parseInteger 238 | levelIdxs <- many (blank *> parseInteger) 239 | lift $ do 240 | use ctxExprMap >>= assertUndefined newIdx IdxExpr 241 | name <- uses ctxNameMap (Map.! nameIdx) 242 | levels <- uses ctxLevelMap (\m -> map (m Map.!) levelIdxs) 243 | ctxExprMap %= Map.insert newIdx (mkConstant name levels) 244 | 245 | parseEA = do 246 | newIdx <- parseInteger <* blank 247 | string "#EA" >> blank 248 | fnIdx <- parseInteger <* blank 249 | argIdx <- parseInteger 250 | lift $ do 251 | use ctxExprMap >>= assertUndefined newIdx IdxExpr 252 | ctxExprMap <~ (uses ctxExprMap (\m -> Map.insert newIdx (mkApp (m Map.! fnIdx) (m Map.! argIdx)) m)) 253 | 254 | parseEL = do 255 | newIdx <- parseInteger <* blank 256 | string "#EL" >> blank 257 | binderInfo <- parseB <* blank 258 | nameIdx <- parseInteger <* blank 259 | domainIdx <- parseInteger <* blank 260 | bodyIdx <- parseInteger 261 | lift $ do 262 | use ctxExprMap >>= assertUndefined newIdx IdxExpr 263 | name <- uses ctxNameMap (Map.! nameIdx) 264 | domain <- uses ctxExprMap (Map.! domainIdx) 265 | body <- uses ctxExprMap (Map.! bodyIdx) 266 | ctxExprMap %= Map.insert newIdx (mkLambda name domain body binderInfo) 267 | 268 | parseEP = do 269 | newIdx <- parseInteger <* blank 270 | string "#EP" >> blank 271 | binderInfo <- parseB <* blank 272 | nameIdx <- parseInteger <* blank 273 | domainIdx <- parseInteger <* blank 274 | bodyIdx <- parseInteger 275 | lift $ do 276 | use ctxExprMap >>= assertUndefined newIdx IdxExpr 277 | name <- uses ctxNameMap (Map.! nameIdx) 278 | domain <- uses ctxExprMap (Map.! domainIdx) 279 | body <- uses ctxExprMap (Map.! bodyIdx) 280 | ctxExprMap %= Map.insert newIdx (mkPi name domain body binderInfo) 281 | 282 | parseEZ = do 283 | newIdx <- parseInteger <* blank 284 | string "#EZ" >> blank 285 | nameIdx <- parseInteger <* blank 286 | typeIdx <- parseInteger <* blank 287 | valIdx <- parseInteger <* blank 288 | bodyIdx <- parseInteger 289 | lift $ do 290 | use ctxExprMap >>= assertUndefined newIdx IdxExpr 291 | name <- uses ctxNameMap (Map.! nameIdx) 292 | ty <- uses ctxExprMap (Map.! typeIdx) 293 | val <- uses ctxExprMap (Map.! valIdx) 294 | body <- uses ctxExprMap (Map.! bodyIdx) 295 | ctxExprMap %= Map.insert newIdx (mkLet name ty val body) 296 | 297 | parseB :: ParserMethod BinderInfo 298 | parseB = try parseBD <|> try parseBI <|> try parseBS <|> parseBC 299 | parseBD = string "#BD" >> return BinderDefault 300 | parseBI = string "#BI" >> return BinderImplicit 301 | parseBS = string "#BS" >> return BinderStrict 302 | parseBC = string "#BC" >> return BinderClass 303 | 304 | parseNotation :: ParserMethod () 305 | parseNotation = try parsePREFIX <|> try parsePOSTFIX <|> parseINFIX 306 | 307 | parsePREFIX = string "#PREFIX " >> parseInteger >> blank >> parseInteger >> blank >> manyTill anyChar (lookAhead newline) >> return () 308 | parsePOSTFIX = string "#POSTFIX " >> parseInteger >> blank >> parseInteger >> blank >> manyTill anyChar (lookAhead newline) >> return () 309 | parseINFIX = string "#INFIX " >> parseInteger >> blank >> parseInteger >> blank >> manyTill anyChar (lookAhead newline) >> return () 310 | 311 | typeCheckExportFile :: String -> String -> Either String () 312 | typeCheckExportFile filename fileContents = 313 | case S.evalState (runExceptT (runParserT parseExportFile () filename fileContents)) mkStdContext of 314 | Left parseErr -> Left $ show parseErr 315 | Right (Left kernelErr) -> Left $ show kernelErr 316 | Right (Right _) -> Right () 317 | -------------------------------------------------------------------------------- /src/Kernel/Expr.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Expr 3 | Description : Expressions 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | API for expressions 9 | -} 10 | module Kernel.Expr ( 11 | Expr(..) 12 | , LocalData(LocalData), VarData, SortData, ConstantData(ConstantData), BindingData, AppData, LetData 13 | , BinderInfo(..) 14 | , mkVar, mkLocal, mkLocalDefault, mkLocalData, mkLocalDataDefault, mkConstant, mkSort 15 | , mkLambda, mkLambdaDefault, mkPi, mkPiDefault, mkArrow, mkLet 16 | , mkApp, mkAppSeq 17 | , varIdx 18 | , sortLevel 19 | , localName, localType 20 | , constName, constLevels 21 | , bindingName, bindingDomain, bindingBody, bindingInfo 22 | , letName, letType, letVal, letBody 23 | , appFn, appArg, getOperator, getAppArgs, getAppOpArgs, getAppRevArgs, getAppOpRevArgs, mkRevAppSeq 24 | , exprHasLocal, exprHasLevelParam, hasFreeVars, closed 25 | , abstractPi, abstractPiSeq, abstractLambda, abstractLambdaSeq 26 | , instantiate, instantiateSeq, instantiateLevelParams 27 | , findInExpr 28 | , isConstant, maybeConstant 29 | , innerBodyOfLambda 30 | , mkProp 31 | ) where 32 | import Kernel.Expr.Internal 33 | -------------------------------------------------------------------------------- /src/Kernel/Expr/Internal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Expr 3 | Description : Expressions 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | Implementation for expressions 9 | -} 10 | module Kernel.Expr.Internal where 11 | 12 | import Kernel.Name 13 | import Kernel.Level 14 | 15 | import qualified Data.Maybe as Maybe 16 | import qualified Data.List as List 17 | import Control.Monad (mplus) 18 | 19 | data BinderInfo = BinderDefault | BinderImplicit | BinderStrict | BinderClass deriving (Eq,Show,Ord) 20 | data ExprCache = ExprCache { cacheHasLocal :: !Bool, 21 | cacheHasLevelParam :: !Bool, 22 | cacheFreeVarRange :: !Int } deriving (Eq,Show,Ord) 23 | 24 | data VarData = VarData { varIdx :: !Int } deriving (Eq,Show,Ord) 25 | 26 | data LocalData = LocalData { localName :: !Name , 27 | localPPName :: !Name, 28 | localType :: Expr, 29 | localInfo :: !BinderInfo, 30 | localCache :: !ExprCache } deriving (Eq,Show,Ord) 31 | 32 | data SortData = SortData { sortLevel :: !Level } deriving (Eq,Show,Ord) 33 | 34 | data ConstantData = ConstantData { constName :: !Name , constLevels :: ![Level] } deriving (Eq,Show,Ord) 35 | 36 | data AppData = AppData { appFn :: Expr, appArg :: Expr, appCache :: !ExprCache } deriving (Eq,Show,Ord) 37 | 38 | data BindingData = BindingData { bindingName :: !Name, 39 | bindingDomain :: Expr, 40 | bindingBody :: Expr, 41 | bindingInfo :: !BinderInfo, 42 | bindingCache :: !ExprCache } deriving (Eq,Show,Ord) 43 | 44 | data LetData = LetData { letName :: !Name, 45 | letType :: Expr, 46 | letVal :: Expr, 47 | letBody :: Expr, 48 | letCache :: !ExprCache } deriving (Eq,Show,Ord) 49 | 50 | data Expr = Var VarData 51 | | Local !LocalData 52 | | Sort !SortData 53 | | Constant !ConstantData 54 | | Lambda !BindingData 55 | | Pi !BindingData 56 | | App !AppData 57 | | Let !LetData 58 | deriving (Eq,Ord) 59 | 60 | -- TODO(dhs): replace with pretty-printer 61 | showExpression :: Expr -> String 62 | showExpression e = case e of 63 | Var var -> "#" ++ show (varIdx var) 64 | Local local -> "(Local <" ++ show (localName local) ++ ">)" 65 | Sort sort -> if isZero (sortLevel sort) then "Prop" else "Type.{" ++ show (sortLevel sort) ++ "}" 66 | Constant const -> "'" ++ show (constName const) ++ "'" 67 | Lambda lam -> "(Lambda: " ++ show (bindingDomain lam) ++ " ==> " ++ show (bindingBody lam) ++ ")" 68 | Pi pi -> "(Pi: " ++ show (bindingDomain pi) ++ " -> " ++ show (bindingBody pi) ++ ")" 69 | App app -> let (f,args) = getAppOpArgs e in "(App: " ++ show f ++ " @ " ++ show args ++ ")" 70 | Let lett -> "(Let: " ++ show (letName lett) ++ " : " ++ showExpression (letType lett) ++ " :=\n" ++ showExpression (letVal lett) ++ "\n in " ++ showExpression (letBody lett) ++ ")" 71 | 72 | instance Show Expr where show e = showExpression e 73 | 74 | {- Free variables -} 75 | 76 | getFreeVarRange :: Expr -> Int 77 | getFreeVarRange e = case e of 78 | Var var -> 1 + varIdx var 79 | Local local -> cacheFreeVarRange $ localCache local 80 | Constant _ -> 0 81 | Sort _ -> 0 82 | Lambda lam -> cacheFreeVarRange $ bindingCache lam 83 | Pi pi -> cacheFreeVarRange $ bindingCache pi 84 | App app -> cacheFreeVarRange $ appCache app 85 | Let lett -> cacheFreeVarRange $ letCache lett 86 | 87 | hasFreeVars :: Expr -> Bool 88 | hasFreeVars e = getFreeVarRange e > 0 89 | 90 | closed :: Expr -> Bool 91 | closed e = not $ hasFreeVars e 92 | 93 | {- `has` functions -} 94 | 95 | exprHasLocal :: Expr -> Bool 96 | exprHasLocal e = case e of 97 | Var _ -> False 98 | Local _ -> True 99 | Sort _ -> False 100 | Constant _ -> False 101 | Lambda lam -> cacheHasLocal $ bindingCache lam 102 | Pi pi -> cacheHasLocal $ bindingCache pi 103 | App app -> cacheHasLocal $ appCache app 104 | Let lett -> cacheHasLocal $ letCache lett 105 | 106 | exprHasLevelParam :: Expr -> Bool 107 | exprHasLevelParam e = case e of 108 | Var var -> False 109 | Local local -> cacheHasLevelParam $ localCache local 110 | Constant const -> any (==True) (map levelHasParam (constLevels const)) 111 | Sort sort -> levelHasParam (sortLevel sort) 112 | Lambda lam -> cacheHasLevelParam $ bindingCache lam 113 | Pi pi -> cacheHasLevelParam $ bindingCache pi 114 | App app -> cacheHasLevelParam $ appCache app 115 | Let lett -> cacheHasLevelParam $ letCache lett 116 | 117 | {- N-ary applications -} 118 | 119 | getOperator :: Expr -> Expr 120 | getOperator e = case e of 121 | App app -> getOperator (appFn app) 122 | _ -> e 123 | 124 | getAppArgs :: Expr -> [Expr] 125 | getAppArgs e = reverse (getAppRevArgs e) 126 | 127 | getAppOpArgs :: Expr -> (Expr, [Expr]) 128 | getAppOpArgs e = (getOperator e, getAppArgs e) 129 | 130 | getAppRevArgs :: Expr -> [Expr] 131 | getAppRevArgs (App app) = appArg app : getAppRevArgs (appFn app) 132 | getAppRevArgs _ = [] 133 | 134 | getAppOpRevArgs :: Expr -> (Expr, [Expr]) 135 | getAppOpRevArgs e = (getOperator e, getAppRevArgs e) 136 | 137 | {- Constructors -} 138 | 139 | mkVar :: Int -> Expr 140 | mkVar v_idx = Var (VarData v_idx) 141 | 142 | mkLocal :: Name -> Name -> Expr -> BinderInfo -> Expr 143 | mkLocal name pp_name ty binfo = Local $ mkLocalData name pp_name ty binfo 144 | 145 | mkLocalDefault :: Name -> Expr -> Expr 146 | mkLocalDefault name ty = Local $ mkLocalDataDefault name ty 147 | 148 | mkLocalData :: Name -> Name -> Expr -> BinderInfo -> LocalData 149 | mkLocalData name pp_name ty binfo = LocalData name pp_name ty binfo 150 | (ExprCache True (exprHasLevelParam ty) (getFreeVarRange ty)) 151 | 152 | mkLocalDataDefault :: Name -> Expr -> LocalData 153 | mkLocalDataDefault name ty = LocalData name name ty BinderDefault 154 | (ExprCache True (exprHasLevelParam ty) (getFreeVarRange ty)) 155 | 156 | mkSort :: Level -> Expr 157 | mkSort l = Sort (SortData l) 158 | 159 | mkConstant :: Name -> [Level] -> Expr 160 | mkConstant name levels = Constant (ConstantData name levels) 161 | 162 | mkApp :: Expr -> Expr -> Expr 163 | mkApp fn arg = App (AppData fn arg (ExprCache 164 | (exprHasLocal fn || exprHasLocal arg) 165 | (exprHasLevelParam fn || exprHasLevelParam arg) 166 | (max (getFreeVarRange fn) (getFreeVarRange arg)))) 167 | 168 | mkAppSeq :: Expr -> [Expr] -> Expr 169 | mkAppSeq op [] = op 170 | mkAppSeq op (arg:args) = mkAppSeq (mkApp op arg) args 171 | 172 | mkRevAppSeq :: Expr -> [Expr] -> Expr 173 | mkRevAppSeq op [] = op 174 | mkRevAppSeq op (arg:args) = mkApp (mkRevAppSeq op args) arg 175 | 176 | dec :: Int -> Int 177 | dec x = if x <= 0 then x else x - 1 178 | 179 | mkBinding :: Bool -> Name -> Expr -> Expr -> BinderInfo -> Expr 180 | mkBinding isPi name domain body binfo = 181 | let ecache = ExprCache 182 | (exprHasLocal domain || exprHasLocal body) 183 | (exprHasLevelParam domain || exprHasLevelParam body) 184 | (max (getFreeVarRange domain) (dec $ getFreeVarRange body)) in 185 | case isPi of 186 | True -> Pi (BindingData name domain body binfo ecache) 187 | False -> Lambda (BindingData name domain body binfo ecache) 188 | 189 | mkPi :: Name -> Expr -> Expr -> BinderInfo -> Expr 190 | mkPi = mkBinding True 191 | 192 | mkPiDefault :: Expr -> Expr -> Expr 193 | mkPiDefault domain body = mkPi noName domain body BinderDefault 194 | 195 | mkLambda :: Name -> Expr -> Expr -> BinderInfo -> Expr 196 | mkLambda = mkBinding False 197 | 198 | mkLambdaDefault :: Expr -> Expr -> Expr 199 | mkLambdaDefault domain body = mkLambda noName domain body BinderDefault 200 | 201 | mkLet :: Name -> Expr -> Expr -> Expr -> Expr 202 | mkLet n ty val body = 203 | let ecache = ExprCache 204 | (exprHasLocal ty || exprHasLocal val || exprHasLocal body) 205 | (exprHasLevelParam ty || exprHasLevelParam val || exprHasLevelParam body) 206 | (max (getFreeVarRange ty) (max (getFreeVarRange val) (dec $ getFreeVarRange body))) in 207 | Let (LetData n ty val body ecache) 208 | 209 | mkArrow :: Expr -> Expr -> Expr 210 | mkArrow = mkPiDefault 211 | 212 | {- Updaters -} 213 | 214 | updateLocal :: LocalData -> Expr -> Expr 215 | updateLocal local new_type = mkLocal (localName local) (localPPName local) new_type (localInfo local) 216 | 217 | updateBinding :: Bool -> BindingData -> Expr -> Expr -> Expr 218 | updateBinding isPi bind new_domain new_body = 219 | mkBinding isPi (bindingName bind) new_domain new_body (bindingInfo bind) 220 | 221 | updatePi :: BindingData -> Expr -> Expr -> Expr 222 | updatePi = updateBinding True 223 | 224 | updateLambda :: BindingData -> Expr -> Expr -> Expr 225 | updateLambda = updateBinding False 226 | 227 | updateApp :: AppData -> Expr -> Expr -> Expr 228 | updateApp app new_fn new_arg = mkApp new_fn new_arg 229 | 230 | updateLet :: LetData -> Expr -> Expr -> Expr -> Expr 231 | updateLet lett newTy newVal newBody = mkLet (letName lett) newTy newVal newBody 232 | 233 | updateConstant const levels = mkConstant (constName const) levels 234 | updateSort sort level = mkSort level 235 | 236 | 237 | {- Traversals -} 238 | 239 | -- Replace 240 | type Offset = Int 241 | type ReplaceFn = (Expr -> Offset -> Maybe Expr) 242 | 243 | replaceInExpr :: ReplaceFn -> Expr -> Expr 244 | replaceInExpr f t = replaceInExprCore f t 0 245 | where 246 | replaceInExprCore :: ReplaceFn -> Expr -> Offset -> Expr 247 | replaceInExprCore f t offset = 248 | case f t offset of 249 | Just t0 -> t0 250 | Nothing -> 251 | case t of 252 | Local local -> updateLocal local (replaceInExprCore f (localType local) offset) 253 | App app -> updateApp app (replaceInExprCore f (appFn app) offset) 254 | (replaceInExprCore f (appArg app) offset) 255 | Lambda lam -> updateLambda lam (replaceInExprCore f (bindingDomain lam) offset) 256 | (replaceInExprCore f (bindingBody lam) (1+offset)) 257 | Pi pi -> updatePi pi (replaceInExprCore f (bindingDomain pi) offset) 258 | (replaceInExprCore f (bindingBody pi) (1+offset)) 259 | Let lett -> updateLet lett (replaceInExprCore f (letType lett) offset) 260 | (replaceInExprCore f (letVal lett) (offset)) 261 | (replaceInExprCore f (letBody lett) (offset+1)) 262 | _ -> t 263 | 264 | 265 | -- Find 266 | type FindFn = (Expr -> Offset -> Bool) 267 | findInExpr :: FindFn -> Expr -> Maybe Expr 268 | findInExpr f t = findInExprCore f t 0 269 | where 270 | findInExprCore :: FindFn -> Expr -> Offset -> Maybe Expr 271 | findInExprCore f t offset = 272 | if f t offset then Just t else 273 | case t of 274 | Local local -> findInExprCore f (localType local) offset 275 | App app -> findInExprCore f (appFn app) offset `mplus` findInExprCore f (appArg app) offset 276 | Lambda lam -> findInExprCore f (bindingDomain lam) offset `mplus` findInExprCore f (bindingBody lam) (offset+1) 277 | Pi pi -> findInExprCore f (bindingDomain pi) offset `mplus` findInExprCore f (bindingBody pi) (offset+1) 278 | Let lett -> findInExprCore f (letType lett) offset `mplus` findInExprCore f (letVal lett) (offset) `mplus` findInExprCore f (letBody lett) (offset+1) 279 | _ -> Nothing 280 | 281 | -- Instantiate 282 | instantiateSeq :: Expr -> [Expr] -> Expr 283 | instantiateSeq e substs = replaceInExpr (instantiateSeqFn substs) e 284 | where 285 | instantiateSeqFn :: [Expr] -> ReplaceFn 286 | instantiateSeqFn substs e offset 287 | | offset >= getFreeVarRange e = Just e 288 | 289 | instantiateSeqFn substs (Var var) offset 290 | | varIdx var >= offset && varIdx var < offset + length substs = 291 | Just $ liftFreeVars (substs !! (varIdx var - offset)) offset 292 | | varIdx var > offset = Just $ mkVar (varIdx var - length substs) 293 | 294 | instantiateSeqFn _ _ _ = Nothing 295 | 296 | instantiate :: Expr -> Expr -> Expr 297 | instantiate e subst = instantiateSeq e [subst] 298 | 299 | -- Lift free vars 300 | liftFreeVars :: Expr -> Int -> Expr 301 | liftFreeVars e shift = replaceInExpr (liftFreeVarsFn shift) e 302 | where 303 | liftFreeVarsFn :: Offset -> ReplaceFn 304 | liftFreeVarsFn shift e offset 305 | | offset >= getFreeVarRange e = Just e 306 | 307 | liftFreeVarsFn shift (Var var) offset 308 | | varIdx var >= offset = Just $ mkVar (varIdx var + shift) 309 | 310 | liftFreeVarsFn _ _ _ = Nothing 311 | 312 | 313 | -- Instantiate universe params 314 | instantiateLevelParams :: Expr -> [Name] -> [Level] -> Expr 315 | instantiateLevelParams e levelParamNames levels = 316 | replaceInExpr (instantiateLevelParamsFn levelParamNames levels) e 317 | where 318 | instantiateLevelParamsFn :: [Name] -> [Level] -> ReplaceFn 319 | instantiateLevelParamsFn levelParamNames levels e _ 320 | | not (exprHasLevelParam e) = Just e 321 | 322 | instantiateLevelParamsFn levelParamNames levels (Constant const) _ = 323 | Just $ updateConstant const (map (instantiateLevel levelParamNames levels) (constLevels const)) 324 | 325 | instantiateLevelParamsFn levelParamNames levels (Sort sort) _ = 326 | Just $ updateSort sort (instantiateLevel levelParamNames levels (sortLevel sort)) 327 | 328 | instantiateLevelParamsFn _ _ _ _ = Nothing 329 | 330 | -- Abstract locals 331 | 332 | abstractPi local body = abstractBindingSeq True [local] body 333 | abstractLambda local body = abstractBindingSeq False [local] body 334 | 335 | abstractPiSeq locals body = abstractBindingSeq True locals body 336 | abstractLambdaSeq locals body = abstractBindingSeq False locals body 337 | 338 | abstractBindingSeq isPi locals body = 339 | let abstractBody = abstractLocals locals body 340 | abstractTypes = map (\(local,i) -> abstractLocals (List.take i locals) (localType local)) (zip locals [0..]) 341 | in 342 | foldr (\(abstractType,local) new_body -> mkBinding isPi (localName local) abstractType new_body (localInfo local)) 343 | abstractBody (zip abstractTypes locals) 344 | 345 | abstractLocals locals body = replaceInExpr (abstractLocalsFn locals) body 346 | where 347 | abstractLocalsFn :: [LocalData] -> ReplaceFn 348 | abstractLocalsFn locals e offset 349 | | not (exprHasLocal e) = Just e 350 | 351 | abstractLocalsFn locals e@(Local l) offset = 352 | case List.findIndex (\local -> localName local == localName l) locals of 353 | Nothing -> Just e 354 | Just idx -> Just (mkVar $ offset + (length locals - 1 - idx)) 355 | 356 | abstractLocalsFn _ _ _ = Nothing 357 | 358 | -- Misc 359 | 360 | mkProp :: Expr 361 | mkProp = mkSort mkZero 362 | 363 | innerBodyOfLambda :: Expr -> Expr 364 | innerBodyOfLambda e = case e of 365 | Lambda lam -> innerBodyOfLambda (bindingBody lam) 366 | _ -> e 367 | 368 | isConstant :: Expr -> Bool 369 | isConstant (Constant _) = True 370 | isConstant _ = False 371 | 372 | maybeConstant :: Expr -> Maybe ConstantData 373 | maybeConstant (Constant c) = Just c 374 | maybeConstant _ = Nothing 375 | -------------------------------------------------------------------------------- /src/Kernel/Inductive.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.Inductive 3 | Description : Inductive type declarations 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | API for inductive types 9 | -} 10 | module Kernel.Inductive (IndDeclError, addInductive) where 11 | import Kernel.Inductive.Internal 12 | -------------------------------------------------------------------------------- /src/Kernel/Inductive/Internal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.Inductive.Internal 3 | Description : Inductive type declarations 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | Implementation of inductive type declaration processing. 9 | The main roles of this module are: 10 | 1. To validate inductive type declarations 11 | 2. To compute the corresponding eliminator 12 | 3. To compute the corresponding computation rule 13 | -} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TupleSections #-} 16 | module Kernel.Inductive.Internal where 17 | 18 | import Control.Monad 19 | import Control.Monad.State 20 | import Control.Monad.Reader 21 | import Control.Monad.Trans.Except 22 | import Control.Monad.Trans.Maybe 23 | 24 | import Kernel.Name 25 | import Kernel.Level 26 | import Kernel.Expr 27 | import Kernel.TypeChecker (IndDecl(IndDecl) 28 | , indDeclNumParams, indDeclLPNames, indDeclName, indDeclType, indDeclIntroRules 29 | , IntroRule(IntroRule) 30 | , CompRule(CompRule) 31 | , Env 32 | , envAddIndDecl, envAddIntroRule, envAddElimInfo, envAddCompRule, envLookupDecl 33 | , TypeError, TCMethod) 34 | 35 | import qualified Kernel.TypeChecker as TypeChecker 36 | 37 | import qualified Data.Map as Map 38 | import Data.Map (Map) 39 | 40 | import qualified Data.Set as Set 41 | import Data.Set (Set) 42 | 43 | import Lens.Simple (Lens, lens, makeLenses, use, uses, view, over, (%=), (.=), (%%=)) 44 | 45 | import Data.List (genericIndex,genericLength,genericTake,genericDrop,genericSplitAt) 46 | import qualified Data.Maybe as Maybe 47 | 48 | type Eventually = Maybe 49 | 50 | -- (Unsafe) Maybe lenses. Note that 51 | _Elem :: Lens (Eventually a) (Eventually b) a b 52 | _Elem = lens Maybe.fromJust (\ma b' -> Just b') 53 | 54 | data IndDeclError = NumParamsMismatchInIndDecl Int Int 55 | | ArgDoesNotMatchInductiveParameters Int Name 56 | | UniLevelOfArgTooBig Int Name Level Level 57 | | InvalidRecArg Int Name 58 | | InvalidReturnType Name 59 | | NonPosOccurrence Int Name 60 | | NonValidOccurrence Int Name 61 | | TypeCheckError TypeChecker.TypeError String 62 | deriving (Eq,Show) 63 | 64 | data ElimInfo = ElimInfo { 65 | _elimInfoC :: LocalData, -- type former constant 66 | _elimInfoIndices :: [LocalData], --local constant for each index 67 | _elimInfoMajorPremise :: LocalData, -- major premise for each inductive decl 68 | _elimInfoMinorPremises :: [LocalData] -- minor premise for each introduction rule 69 | } deriving (Eq,Show) 70 | 71 | makeLenses ''ElimInfo 72 | 73 | data AddInductiveS = AddInductiveS { 74 | _addIndEnv :: Env, 75 | _addIndIDecl :: IndDecl, 76 | 77 | _addIndIsDefinitelyNotZero :: Bool, 78 | _addIndNextId :: Integer, 79 | _addIndDepElim :: Bool, 80 | 81 | _addIndElimLevel :: Eventually Level, 82 | _addIndParamLocals :: Eventually [LocalData], -- local constants used to represent global parameters 83 | _addIndIndIndexLocals :: Eventually [LocalData], -- local constants used to represent indices 84 | _addIndIndBody :: Eventually Expr, -- inner body of indType 85 | _addIndIndLevel :: Eventually Level, -- the levels for each inductive datatype in [m_idecls] 86 | _addIndIndConst :: Eventually ConstantData, -- the constants for each inductive datatype in [m_idecls] 87 | _addIndNumArgs :: Eventually Int, -- total number of arguments (params + indices) for each inductive datatype in m_idecls 88 | 89 | _addIndElimInfo :: Eventually ElimInfo, 90 | _addIndKTarget :: Bool 91 | } 92 | 93 | makeLenses ''AddInductiveS 94 | 95 | mkAddInductiveS :: Env -> IndDecl -> AddInductiveS 96 | mkAddInductiveS env idecl = AddInductiveS { 97 | _addIndEnv = env, 98 | _addIndIDecl = idecl, 99 | 100 | _addIndNextId = 0, 101 | 102 | _addIndIsDefinitelyNotZero = False, 103 | _addIndDepElim = False, 104 | _addIndElimLevel = Nothing, 105 | 106 | _addIndParamLocals = Nothing, 107 | _addIndIndIndexLocals = Nothing, 108 | _addIndIndBody = Nothing, 109 | _addIndIndLevel = Nothing, 110 | _addIndIndConst = Nothing, 111 | _addIndNumArgs = Nothing, 112 | _addIndElimInfo = Nothing, 113 | _addIndKTarget = False 114 | } 115 | 116 | type AddInductiveMethod = ExceptT IndDeclError (State AddInductiveS) 117 | 118 | {- Misc -} 119 | 120 | gensym :: AddInductiveMethod Integer 121 | gensym = addIndNextId %%= \n -> (n, n + 1) 122 | 123 | mkLocalFor :: BindingData -> AddInductiveMethod LocalData 124 | mkLocalFor bind = do 125 | nextId <- gensym 126 | return $ mkLocalData (mkSystemNameI nextId) (bindingName bind) (bindingDomain bind) (bindingInfo bind) 127 | 128 | indAssert :: IndDeclError -> Bool -> AddInductiveMethod () 129 | indAssert err b = if b then return () else throwE err 130 | 131 | -- TODO(dhs): why did old version add another layer to this? 132 | mkFreshName :: AddInductiveMethod Name 133 | mkFreshName = gensym >>= return . mkSystemNameI 134 | 135 | addInductive :: Env -> IndDecl -> Either IndDeclError Env 136 | addInductive env idecl = 137 | let (a, s) = runState (runExceptT addInductiveCore) (mkAddInductiveS env idecl) in 138 | case a of 139 | Left err -> Left err 140 | Right () -> Right $ view addIndEnv s 141 | 142 | addInductiveCore :: AddInductiveMethod () 143 | addInductiveCore = do 144 | checkIndType 145 | declareIndType 146 | checkIntroRules 147 | declareIntroRules 148 | computeElimRule 149 | declareElimRule 150 | mkCompRules 151 | 152 | checkIndType :: AddInductiveMethod () 153 | checkIndType = do 154 | (IndDecl numParams lpNames name ty introRules) <- use addIndIDecl 155 | checkType ty lpNames 156 | -- The first [numParams] arguments represent the "parameters" 157 | (paramLocals, rest) <- telescopePiN numParams ty 158 | indAssert (NumParamsMismatchInIndDecl (length paramLocals) numParams) (length paramLocals == numParams) 159 | -- The remaining arguments represent the "indices" 160 | (indIndexLocals, body) <- telescopePi rest 161 | -- The inner body must be a Sort 162 | sort <- ensureSort body lpNames 163 | lpNames <- uses addIndIDecl (map mkLevelParam . view indDeclLPNames) 164 | addIndIsDefinitelyNotZero .= isDefinitelyNotZero (sortLevel sort) 165 | addIndIndConst .= Just (ConstantData name lpNames) 166 | addIndIndLevel .= Just (sortLevel sort) 167 | addIndNumArgs .= Just (numParams + length indIndexLocals) 168 | addIndParamLocals .= Just paramLocals 169 | addIndIndIndexLocals .= Just indIndexLocals 170 | addIndIndBody .= Just body 171 | where 172 | telescopePiN :: Int -> Expr -> AddInductiveMethod ([LocalData], Expr) 173 | telescopePiN numTake e = telescopePiNCore numTake [] e 174 | 175 | telescopePiNCore :: Int -> [LocalData] -> Expr -> AddInductiveMethod ([LocalData], Expr) 176 | telescopePiNCore numTake locals e = 177 | case e of 178 | _ | numTake <= 0 -> return (locals, e) 179 | Pi pi -> do local <- mkLocalFor pi 180 | telescopePiNCore (numTake - 1) (locals ++ [local]) (instantiate (bindingBody pi) (Local local)) 181 | _ -> return (locals, e) 182 | 183 | telescopePi :: Expr -> AddInductiveMethod ([LocalData], Expr) 184 | telescopePi e = telescopePiCore [] e 185 | 186 | telescopePiCore :: [LocalData] -> Expr -> AddInductiveMethod ([LocalData], Expr) 187 | telescopePiCore locals e = 188 | case e of 189 | Pi pi -> do local <- mkLocalFor pi 190 | telescopePiCore (locals ++ [local]) (instantiate (bindingBody pi) (Local local)) 191 | _ -> return (locals, e) 192 | 193 | 194 | -- Add all datatype declarations to environment. 195 | declareIndType :: AddInductiveMethod () 196 | declareIndType = do 197 | idecl@(IndDecl numParams lpNames name ty introRules) <- use addIndIDecl 198 | envAddAxiom name lpNames ty 199 | addIndEnv %= envAddIndDecl idecl 200 | 201 | {- Check if 202 | - all introduction rules start with the same parameters 203 | - the type of all arguments (which are not datatype global params) live in universes <= level of the corresponding datatype 204 | - all inductive datatype occurrences are positive 205 | - all introduction rules are well typed 206 | 207 | Note: this method must be executed after declareIndType 208 | -} 209 | checkIntroRules :: AddInductiveMethod () 210 | checkIntroRules = do 211 | (IndDecl numParams lpNames name ty introRules) <- use addIndIDecl 212 | mapM_ (checkIntroRule lpNames) introRules 213 | where 214 | checkIntroRule :: [Name] -> IntroRule -> AddInductiveMethod () 215 | checkIntroRule lpNames (IntroRule name ty) = do 216 | checkType ty lpNames 217 | checkIntroRuleCore 0 False name ty 218 | 219 | checkIntroRuleCore :: Int -> Bool -> Name -> Expr -> AddInductiveMethod () 220 | checkIntroRuleCore paramNum foundRec name ty = 221 | case ty of 222 | Pi pi -> do 223 | numParams <- use (addIndIDecl . indDeclNumParams) 224 | lpNames <- use (addIndIDecl . indDeclLPNames) 225 | paramLocals <- use (addIndParamLocals . _Elem) 226 | if paramNum < numParams 227 | then -- We instantiate the first [numParams] arguments with the *shared* parameters 228 | do let local = paramLocals !! paramNum 229 | isDefEq (bindingDomain pi) (localType local) lpNames >>= 230 | indAssert (ArgDoesNotMatchInductiveParameters paramNum name) 231 | checkIntroRuleCore (paramNum+1) foundRec name (instantiate (bindingBody pi) (Local local)) 232 | else -- The remaining arguments are unique to this introduction rule 233 | do sort <- ensureType (bindingDomain pi) lpNames 234 | indLevel <- use (addIndIndLevel . _Elem) 235 | env <- use addIndEnv 236 | -- The universe level of each argument must not exceed that of the inductive type itself 237 | indAssert (UniLevelOfArgTooBig paramNum name (sortLevel sort) indLevel) 238 | (levelNotBiggerThan (sortLevel sort) indLevel || (isZero indLevel)) 239 | domainTy <- whnf (bindingDomain pi) 240 | -- All occurrences of the inductive type itself must be "positive" 241 | checkPositivity domainTy name paramNum 242 | argIsRec <- isRecArg domainTy 243 | ty <- if argIsRec 244 | then indAssert (InvalidRecArg paramNum name) (closed (bindingBody pi)) >> return (bindingBody pi) 245 | else mkLocalFor pi >>= return . instantiate (bindingBody pi) . Local 246 | checkIntroRuleCore (paramNum+1) argIsRec name ty 247 | _ -> isValidIndApp ty >>= indAssert (InvalidReturnType name) -- add to [irIndices]? 248 | 249 | checkPositivity :: Expr -> Name -> Int -> AddInductiveMethod () 250 | checkPositivity ty name paramNum = do 251 | ty <- whnf ty 252 | itOccurs <- indTypeOccurs ty 253 | if not itOccurs then return () else 254 | case ty of 255 | Pi pi -> do indTypeOccurs (bindingDomain pi) >>= indAssert (NonPosOccurrence paramNum name) . not 256 | local <- mkLocalFor pi 257 | checkPositivity (instantiate (bindingBody pi) $ Local local) name paramNum 258 | _ -> isValidIndApp ty >>= indAssert (NonValidOccurrence paramNum name) 259 | 260 | indTypeOccurs :: Expr -> AddInductiveMethod Bool 261 | indTypeOccurs e = do 262 | indTypeConst <- use (addIndIndConst . _Elem) 263 | return . Maybe.isJust $ findInExpr (\e _ -> case e of 264 | Constant const -> constName const == constName indTypeConst 265 | _ -> False) e 266 | 267 | isValidIndApp :: Expr -> AddInductiveMethod Bool 268 | isValidIndApp e = do 269 | indTypeConst <- use (addIndIndConst . _Elem) 270 | paramLocals <- use (addIndParamLocals . _Elem) 271 | lpNames <- use (addIndIDecl . indDeclLPNames) 272 | numParams <- use (addIndIDecl . indDeclNumParams) 273 | numArgs <- use (addIndNumArgs . _Elem) 274 | let (op, args) = getAppOpArgs e 275 | opEq <- isDefEq op (Constant indTypeConst) lpNames 276 | return $ opEq && length args == numArgs && all (uncurry (==)) (zip (take numParams args) (map Local paramLocals)) 277 | 278 | isRecArg :: Expr -> AddInductiveMethod Bool 279 | isRecArg e = do 280 | e <- whnf e 281 | case e of 282 | Pi pi -> mkLocalFor pi >>= isRecArg . (instantiate (bindingBody pi)) . Local 283 | _ -> isValidIndApp e 284 | 285 | declareIntroRules :: AddInductiveMethod () 286 | declareIntroRules = do 287 | (IndDecl _ lpNames indName _ introRules) <- use addIndIDecl 288 | mapM_ (\(IntroRule irName irType) -> do envAddAxiom irName lpNames irType 289 | addIndEnv %= envAddIntroRule irName indName) introRules 290 | 291 | computeElimRule :: AddInductiveMethod () 292 | computeElimRule = do 293 | initDepElim 294 | initElimLevel 295 | initCIndicesMajor 296 | initMinorPremises 297 | where 298 | initDepElim :: AddInductiveMethod () 299 | initDepElim = do 300 | env <- use addIndEnv 301 | indLevel <- use (addIndIndLevel . _Elem) 302 | addIndDepElim .= not (isZero indLevel) 303 | 304 | initElimLevel :: AddInductiveMethod () 305 | initElimLevel = do 306 | onlyAtZero <- elimOnlyAtLevelZero 307 | if onlyAtZero 308 | then addIndElimLevel .= Just mkZero 309 | else addIndElimLevel .= Just (mkLevelParam (mkSystemNameS "elimLevel")) 310 | 311 | -- Return true if type formers C in the recursors can only map to Type.{0} 312 | elimOnlyAtLevelZero :: AddInductiveMethod Bool 313 | elimOnlyAtLevelZero = do 314 | env <- use addIndEnv 315 | isDefinitelyNotZero <- use addIndIsDefinitelyNotZero 316 | if isDefinitelyNotZero then return False else do 317 | (IndDecl _ _ _ _ introRules) <- use addIndIDecl 318 | case introRules of 319 | [] -> return False 320 | (_:_:_) -> return True 321 | [IntroRule irName irType] -> do 322 | {- We have only one introduction rule, the final check is, the type of each argument that is not a parameter: 323 | 1- It must live in Type.{0}, *OR* 324 | 2- It must occur in the return type. (this is essentially what is called a non-uniform parameter in Coq). 325 | We can justify 2 by observing that this information is not a *secret* it is part of the type. 326 | By eliminating to a non-proposition, we would not be revealing anything that is not already known. -} 327 | (irBodyType, argsToCheck) <- collectArgsToCheck irType 0 328 | let resultArgs = getAppArgs irBodyType 329 | let results = map (not . flip elem resultArgs) $ map Local argsToCheck 330 | return $ any (==True) results 331 | 332 | {- We proceed through the arguments to the introRule, 333 | and return (innerBody, [locals for all (non-param) args that do not live in Prop]) -} 334 | collectArgsToCheck :: Expr -> Int -> AddInductiveMethod (Expr, [LocalData]) 335 | collectArgsToCheck ty paramNum = 336 | case ty of 337 | Pi pi -> do local <- mkLocalFor pi 338 | let body = instantiate (bindingBody pi) (Local local) 339 | (ty, rest) <- collectArgsToCheck body (paramNum+1) 340 | numParams <- use (addIndIDecl . indDeclNumParams) 341 | lpNames <- use (addIndIDecl . indDeclLPNames) 342 | if paramNum >= numParams 343 | then do sort <- ensureType (bindingDomain pi) lpNames 344 | return $ if not (isZero (sortLevel sort)) then (ty, local : rest) else (ty, rest) 345 | else return (ty, rest) 346 | _ -> return (ty, []) 347 | 348 | initCIndicesMajor :: AddInductiveMethod () 349 | initCIndicesMajor = do (IndDecl _ _ indName indType introRules) <- use addIndIDecl 350 | paramLocals <- use $ addIndParamLocals . _Elem 351 | indIndexLocals <- use $ addIndIndIndexLocals . _Elem 352 | indBody <-use $ addIndIndBody . _Elem 353 | indConst <- use $ addIndIndConst . _Elem 354 | majorName <- mkFreshName 355 | let majorPremise = mkLocalData majorName (mkName ["major"]) 356 | (mkAppSeq (mkAppSeq (Constant indConst) (map Local paramLocals)) 357 | (map Local indIndexLocals)) 358 | BinderDefault 359 | elimLevel <- use $ addIndElimLevel . _Elem 360 | depElim <- use addIndDepElim 361 | let cType0 = mkSort elimLevel 362 | let cType1 = if depElim then abstractPi majorPremise cType0 else cType0 363 | let cType2 = abstractPiSeq indIndexLocals cType1 364 | let cPPName = mkName ["C"] 365 | cName <- mkFreshName 366 | let c = mkLocalData cName cPPName cType2 BinderDefault 367 | addIndElimInfo .= (Just $ ElimInfo c indIndexLocals majorPremise []) 368 | 369 | initMinorPremises :: AddInductiveMethod() 370 | initMinorPremises = 371 | do 372 | (IndDecl _ _ indName indType introRules) <- use addIndIDecl 373 | env <- use addIndEnv 374 | indLevel <- use $ addIndIndLevel . _Elem 375 | -- Note: this is not the final K-Target check 376 | addIndKTarget .= (isZero indLevel && length introRules == 1) 377 | mapM_ initMinorPremise introRules 378 | 379 | initMinorPremise :: IntroRule -> AddInductiveMethod () 380 | initMinorPremise (IntroRule irName irType) = 381 | do 382 | paramLocals <- use $ addIndParamLocals . _Elem 383 | elimInfo <- use $ addIndElimInfo . _Elem 384 | depElim <- use addIndDepElim 385 | indLevel <- use $ addIndIndLevel . _Elem 386 | levels <- uses (addIndIDecl . indDeclLPNames) (map mkLevelParam) 387 | (nonRecAndRecArgs, recArgs, irBody) <- splitIntroRuleType irType 388 | irIndices <- getIndices irBody 389 | c <- use (addIndElimInfo . _Elem . elimInfoC) 390 | indArgs <- constructIndArgs recArgs [0..] 391 | minorPremiseName <- mkFreshName 392 | let minorPremiseType0 = mkAppSeq (Local c) irIndices 393 | let minorPremiseType1 = if depElim 394 | then let introApp = mkAppSeq 395 | (mkAppSeq (mkConstant irName levels) 396 | (map Local paramLocals)) 397 | (map Local nonRecAndRecArgs) in 398 | mkApp minorPremiseType0 introApp 399 | else minorPremiseType0 400 | let minorPremiseType2 = abstractPiSeq nonRecAndRecArgs 401 | (abstractPiSeq indArgs minorPremiseType1) 402 | let minorPremise = mkLocalData minorPremiseName (mkName ["e"]) minorPremiseType2 BinderDefault 403 | (addIndElimInfo . _Elem . elimInfoMinorPremises) %= (++ [minorPremise]) 404 | 405 | splitIntroRuleType :: Expr -> AddInductiveMethod ([LocalData], [LocalData], Expr) 406 | splitIntroRuleType irType = splitIntroRuleTypeCore [] [] irType 0 407 | where 408 | splitIntroRuleTypeCore :: [LocalData] -> [LocalData] -> Expr -> Int -> AddInductiveMethod ([LocalData], [LocalData], Expr) 409 | splitIntroRuleTypeCore nonRecAndRecArgs recArgs irType paramNum = 410 | do 411 | numParams <- use (addIndIDecl . indDeclNumParams) 412 | case irType of 413 | Pi pi | paramNum < numParams -> do 414 | paramLocal <- uses (addIndParamLocals . _Elem) (!! paramNum) 415 | splitIntroRuleTypeCore nonRecAndRecArgs recArgs (instantiate (bindingBody pi) (Local paramLocal)) (paramNum+1) 416 | | otherwise -> 417 | do 418 | -- intro rule has an argument, so we set KTarget to False 419 | addIndKTarget .= False 420 | local <- mkLocalFor pi 421 | argIsRec <- isRecArg (bindingDomain pi) 422 | let (newNonRecAndRecArgs, newRecArgs) = if argIsRec then (nonRecAndRecArgs ++ [local], recArgs ++ [local]) else (nonRecAndRecArgs ++ [local], recArgs) 423 | splitIntroRuleTypeCore newNonRecAndRecArgs newRecArgs (instantiate (bindingBody pi) (Local local)) (paramNum+1) 424 | _ -> return (nonRecAndRecArgs, recArgs, irType) 425 | 426 | constructIndArgs :: [LocalData] -> [Int] -> AddInductiveMethod [LocalData] 427 | constructIndArgs [] _ = return [] 428 | constructIndArgs (recArg : recArgs) (recArgNum : recArgNums) = 429 | do 430 | restIndArgs <- constructIndArgs recArgs recArgNums 431 | recArgType <- whnf (localType recArg) 432 | (xs, recArgBody) <- constructIndArgArgs recArgType 433 | c <- use (addIndElimInfo . _Elem . elimInfoC) 434 | recArgIndices <- getIndices recArgBody 435 | let cApp0 = mkAppSeq (Local c) recArgIndices 436 | depElim <- use addIndDepElim 437 | let cApp1 = if depElim 438 | then mkApp cApp0 (mkAppSeq (Local recArg) (map Local xs)) 439 | else cApp0 440 | let indArgType = abstractPiSeq xs cApp1 441 | indArgName <- mkFreshName 442 | let indArg = mkLocalData indArgName (nameRConsI (mkName ["v"]) $ toInteger recArgNum) indArgType BinderDefault 443 | return $ indArg : restIndArgs 444 | 445 | constructIndArgArgs :: Expr -> AddInductiveMethod ([LocalData], Expr) 446 | constructIndArgArgs recArgType = constructIndArgArgsCore [] recArgType 447 | where 448 | constructIndArgArgsCore :: [LocalData] -> Expr -> AddInductiveMethod ([LocalData], Expr) 449 | constructIndArgArgsCore xs recArgType = 450 | case recArgType of 451 | Pi pi -> do local <- mkLocalFor pi 452 | constructIndArgArgsCore (xs ++ [local]) (instantiate (bindingBody pi) (Local local)) 453 | _ -> return (xs, recArgType) 454 | 455 | getIndices :: Expr -> AddInductiveMethod [Expr] 456 | getIndices e = do 457 | e_n <- whnf e 458 | isValid <- isValidIndApp e_n 459 | case isValid of 460 | True -> do 461 | numParams <- use (addIndIDecl . indDeclNumParams) 462 | return $ drop numParams (getAppArgs e_n) 463 | 464 | declareElimRule :: AddInductiveMethod () 465 | declareElimRule = 466 | do 467 | (IndDecl numParams lpNames indName indType introRules) <- use addIndIDecl 468 | elimInfo <- use (addIndElimInfo . _Elem) 469 | let c = view elimInfoC elimInfo 470 | let majorPremise = view elimInfoMajorPremise elimInfo 471 | let minorPremises = view elimInfoMinorPremises elimInfo 472 | kTarget <- use addIndKTarget 473 | paramLocals <- use (addIndParamLocals . _Elem) 474 | indIndexLocals <- use (addIndIndIndexLocals . _Elem) 475 | depElim <- use addIndDepElim 476 | elimLPNames <- getElimLPNames 477 | let elimType0 = mkAppSeq (Local c) (map Local indIndexLocals) 478 | let elimType1 = if depElim then mkApp elimType0 (Local majorPremise) else elimType0 479 | let elimType2 = abstractPi majorPremise elimType1 480 | let elimType3 = abstractPiSeq indIndexLocals elimType2 481 | let elimType4 = foldr abstractPi elimType3 minorPremises 482 | let elimType5 = abstractPi c elimType4 483 | let elimType6 = abstractPiSeq paramLocals elimType5 484 | envAddAxiom (getElimName indName) elimLPNames elimType6 485 | let tcElimInfo = TypeChecker.ElimInfo indName elimLPNames numParams (numParams + 1 + length introRules) 486 | (length indIndexLocals) kTarget depElim 487 | addIndEnv %= envAddElimInfo (getElimName indName) tcElimInfo 488 | 489 | getElimName :: Name -> Name 490 | getElimName indName = nameRConsS indName "rec" 491 | 492 | getElimLPNames :: AddInductiveMethod [Name] 493 | getElimLPNames = do 494 | lpNames <- use (addIndIDecl . indDeclLPNames) 495 | elimLevel <- use (addIndElimLevel . _Elem) 496 | case maybeParamName elimLevel of 497 | Just n -> return $ n : lpNames 498 | Nothing -> return lpNames 499 | 500 | mkCompRules :: AddInductiveMethod () 501 | mkCompRules = do 502 | (IndDecl _ _ indName _ introRules) <- use addIndIDecl 503 | (ElimInfo _ _ _ minorPremises) <- use (addIndElimInfo . _Elem) 504 | mapM_ (uncurry $ mkCompRule indName) (zip introRules minorPremises) 505 | 506 | mkCompRule :: Name -> IntroRule -> LocalData -> AddInductiveMethod () 507 | mkCompRule indName (IntroRule irName irType) minorPremise = do 508 | elimInfo <- use $ addIndElimInfo . _Elem 509 | let c = view elimInfoC elimInfo 510 | let majorPremise = view elimInfoMajorPremise elimInfo 511 | let minorPremises = view elimInfoMinorPremises elimInfo 512 | paramLocals <- use (addIndParamLocals . _Elem) 513 | elimLPNames <- getElimLPNames 514 | (nonRecAndRecArgs, recArgs, _) <- splitIntroRuleType irType 515 | recApps <- constructRecApps recArgs 516 | let compRHS0 = mkAppSeq (mkAppSeq (Local minorPremise) (map Local nonRecAndRecArgs)) recApps 517 | let compRHS1 = abstractLambdaSeq paramLocals 518 | (abstractLambda c 519 | (abstractLambdaSeq minorPremises 520 | (abstractLambdaSeq nonRecAndRecArgs compRHS0))) 521 | checkType compRHS1 elimLPNames 522 | addIndEnv %= envAddCompRule irName (CompRule (getElimName indName) (length nonRecAndRecArgs) compRHS1) 523 | where 524 | constructRecApps :: [LocalData] -> AddInductiveMethod [Expr] 525 | constructRecApps [] = return [] 526 | constructRecApps (recArg:recArgs) = do 527 | elimInfo <- use $ addIndElimInfo . _Elem 528 | let c = view elimInfoC elimInfo 529 | let majorPremise = view elimInfoMajorPremise elimInfo 530 | let minorPremises = view elimInfoMinorPremises elimInfo 531 | paramLocals <- use (addIndParamLocals . _Elem) 532 | indIndexLocals <- use (addIndIndIndexLocals . _Elem) 533 | restApps <- constructRecApps recArgs 534 | recArgType <- whnf . localType $ recArg 535 | (xs, recArgBody) <- constructIndArgArgs recArgType 536 | recArgIndices <- getIndices recArgBody 537 | let elimName = getElimName indName 538 | elimLPNames <- map mkLevelParam <$> getElimLPNames 539 | let recApp0 = mkConstant elimName elimLPNames 540 | let recApp1 = mkApp (mkAppSeq (mkAppSeq (mkApp (mkAppSeq recApp0 (map Local paramLocals)) 541 | (Local c)) 542 | (map Local minorPremises)) 543 | recArgIndices) 544 | (mkAppSeq (Local recArg) (map Local xs)) 545 | let recApp2 = abstractLambdaSeq xs recApp1 546 | return $ recApp2 : restApps 547 | 548 | {- Wrappers for the type checker -} 549 | 550 | wrapTC :: Expr -> [Name] -> (Expr -> TCMethod a) -> String -> AddInductiveMethod a 551 | wrapTC e lpNames tcFn msg = do 552 | env <- use addIndEnv 553 | nextId <- use addIndNextId 554 | case TypeChecker.tcEval env lpNames nextId (tcFn e) of 555 | Left tcErr -> throwE $ TypeCheckError tcErr msg 556 | Right (val, next) -> addIndNextId .= next >> return val 557 | 558 | checkType :: Expr -> [Name] -> AddInductiveMethod Expr 559 | checkType e lpNames = wrapTC e lpNames TypeChecker.inferType "inferType" 560 | 561 | ensureSort :: Expr -> [Name] -> AddInductiveMethod SortData 562 | ensureSort e lpNames = wrapTC e lpNames TypeChecker.ensureSort "ensureSort" 563 | 564 | ensureType :: Expr -> [Name] -> AddInductiveMethod SortData 565 | ensureType e lpNames = wrapTC e lpNames TypeChecker.ensureType "ensureType" 566 | 567 | whnf :: Expr -> AddInductiveMethod Expr 568 | whnf e = wrapTC e [] TypeChecker.whnf "whnf" 569 | 570 | isDefEq :: Expr -> Expr -> [Name] -> AddInductiveMethod Bool 571 | isDefEq e1 e2 lpNames = do 572 | env <- use addIndEnv 573 | nextId <- use addIndNextId 574 | case TypeChecker.tcEval env lpNames nextId (TypeChecker.isDefEq e1 e2) of 575 | Left tcErr -> throwE $ TypeCheckError tcErr "isDefEq" 576 | Right (b, next) -> addIndNextId .= next >> return b 577 | 578 | envAddAxiom :: Name -> [Name] -> Expr -> AddInductiveMethod () 579 | envAddAxiom name lpNames ty = do 580 | env <- use addIndEnv 581 | case TypeChecker.envAddAxiom name lpNames ty env of 582 | Left tcErr -> throwE $ TypeCheckError tcErr "envAddAxiom" 583 | Right env -> addIndEnv .= env 584 | -------------------------------------------------------------------------------- /src/Kernel/Level.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.Level 3 | Description : Universe levels 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | API for universe levels 9 | -} 10 | module Kernel.Level ( 11 | Level 12 | , mkZero, mkSucc, mkMax, mkIMax, mkLevelParam, mkGlobalLevel 13 | , isZero, isDefinitelyNotZero 14 | , levelHasParam 15 | , instantiateLevel 16 | , getUndefParam, getUndefGlobal 17 | , levelEquiv 18 | , levelNotBiggerThan 19 | , maybeParamName 20 | ) where 21 | import Kernel.Level.Internal 22 | -------------------------------------------------------------------------------- /src/Kernel/Level/Internal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.Level.Internal 3 | Description : Universe levels 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | Implementation of universe levels 9 | -} 10 | module Kernel.Level.Internal where 11 | 12 | import Kernel.Name 13 | import Lens.Simple 14 | import Data.List as List 15 | import Control.Monad 16 | 17 | import qualified Data.Map as Map 18 | import Data.Map (Map) 19 | 20 | import qualified Data.Set as Set 21 | import Data.Set (Set) 22 | 23 | import Data.List (elemIndex, sortBy, genericLength) 24 | 25 | newtype SuccData = SuccData { succOf :: Level } deriving (Eq,Show,Ord) 26 | data MaxCoreData = MaxCoreData { isImax :: Bool, maxLHS :: Level, maxRHS :: Level } deriving (Eq,Show,Ord) 27 | 28 | data Level = Zero 29 | | Succ SuccData 30 | | Max MaxCoreData 31 | | IMax MaxCoreData 32 | | LevelParam Name 33 | | GlobalLevel Name 34 | deriving (Eq, Ord) 35 | 36 | showLevel :: Level -> String 37 | showLevel l = case toLevelOffset l of 38 | (l,0) -> "{ " ++ showLevelCore l ++ " }" 39 | (l,k) -> "{ <" ++ show k ++ "> " ++ showLevelCore l ++ " }" 40 | where 41 | showLevelCore :: Level -> String 42 | showLevelCore l = case l of 43 | Zero -> "0" 44 | Max max -> "(max " ++ showLevel (maxLHS max) ++ " " ++ showLevel (maxRHS max) ++ ")" 45 | IMax imax -> "(max " ++ showLevel (maxLHS imax) ++ " " ++ showLevel (maxRHS imax) ++ ")" 46 | LevelParam lp -> show lp 47 | GlobalLevel gl -> "!" ++ show gl 48 | 49 | instance Show Level where show e = showLevel e 50 | 51 | 52 | getUndefParam :: Level -> [Name] -> Maybe Name 53 | getUndefParam l ns = case l of 54 | Zero -> Nothing 55 | Succ succ -> getUndefParam (succOf succ) ns 56 | Max max -> getUndefParam (maxLHS max) ns `mplus` getUndefParam (maxRHS max) ns 57 | IMax imax -> getUndefParam (maxLHS imax) ns `mplus` getUndefParam (maxRHS imax) ns 58 | LevelParam n -> if elem n ns then Nothing else Just n 59 | GlobalLevel n -> Nothing 60 | 61 | getUndefGlobal :: Level -> Set Name -> Maybe Name 62 | getUndefGlobal l ns = case l of 63 | Zero -> Nothing 64 | Succ succ -> getUndefGlobal (succOf succ) ns 65 | Max max -> getUndefGlobal (maxLHS max) ns `mplus` getUndefGlobal (maxRHS max) ns 66 | IMax imax -> getUndefGlobal (maxLHS imax) ns `mplus` getUndefGlobal (maxRHS imax) ns 67 | LevelParam n -> Nothing 68 | GlobalLevel n -> if Set.member n ns then Nothing else Just n 69 | 70 | -- A level is explicit if it is of the form 'Succ^k Zero' for some 'k'. 71 | isExplicit l = case l of 72 | Zero -> True 73 | Succ succ -> isExplicit (succOf succ) 74 | Max max -> False 75 | IMax imax -> False 76 | LevelParam n -> False 77 | GlobalLevel n -> False 78 | 79 | getDepth l = case l of 80 | Zero -> 0 81 | Succ succ -> 1 + getDepth (succOf succ) 82 | Max max -> 0 83 | IMax imax -> 0 84 | LevelParam n -> 0 85 | GlobalLevel n -> 0 86 | 87 | -- Factors out outermost sequence of 'mkSucc' applications. 88 | toLevelOffset l = case l of 89 | Succ succ -> over _2 (+1) $ toLevelOffset (succOf succ) 90 | otherwise -> (l,0) 91 | 92 | isZero l = case l of 93 | Zero -> True 94 | _ -> False 95 | 96 | mkZero = Zero 97 | mkSucc l = Succ (SuccData l) 98 | 99 | mkLevelOne = mkSucc mkZero 100 | mkLevelTwo = mkSucc $ mkSucc mkZero 101 | 102 | mkIteratedSucc l k 103 | | k == 0 = l 104 | | k > 0 = Succ (SuccData (mkIteratedSucc l (k-1))) 105 | 106 | mkMax l1 l2 107 | | isExplicit l1 && isExplicit l2 = if getDepth l1 >= getDepth l2 then l1 else l2 108 | | l1 == l2 = l1 109 | | isZero l1 = l2 110 | | isZero l2 = l1 111 | | otherwise = 112 | case l1 of 113 | Max max | maxLHS max == l2 || maxRHS max == l2 -> l1 114 | otherwise -> 115 | case l2 of 116 | Max max | maxLHS max == l1 || maxRHS max == l1 -> l2 117 | otherwise -> 118 | let (l1',k1) = toLevelOffset l1 119 | (l2',k2) = toLevelOffset l2 120 | in 121 | if l1' == l2' then (if k1 >= k2 then l1 else l2) else Max (MaxCoreData False l1 l2) 122 | 123 | mkIMax l1 l2 124 | | isDefinitelyNotZero l2 = mkMax l1 l2 125 | | isZero l2 = l2 126 | | isZero l1 = l2 127 | | l1 == l2 = l1 128 | | otherwise = IMax (MaxCoreData True l1 l2) 129 | 130 | mkLevelParam = LevelParam 131 | mkGlobalLevel = GlobalLevel 132 | 133 | isDefinitelyNotZero l = case l of 134 | Zero -> False 135 | LevelParam _ -> False 136 | GlobalLevel _ -> False 137 | Succ _ -> True 138 | Max max -> isDefinitelyNotZero (maxLHS max) || isDefinitelyNotZero (maxRHS max) 139 | IMax imax -> isDefinitelyNotZero (maxRHS imax) 140 | 141 | levelHasParam l = case l of 142 | LevelParam _ -> True 143 | Succ succ -> levelHasParam (succOf succ) 144 | Max max -> levelHasParam (maxLHS max) || levelHasParam (maxRHS max) 145 | IMax imax -> levelHasParam (maxLHS imax) || levelHasParam (maxRHS imax) 146 | _ -> False 147 | 148 | 149 | levelKindRank l = case l of 150 | Zero -> 0 151 | Succ _ -> 1 152 | Max _ -> 2 153 | IMax _ -> 3 154 | LevelParam _ -> 4 155 | GlobalLevel _ -> 5 156 | 157 | levelNormCmp l1 l2 = if l1 == l2 then EQ else levelNormCmpCore (toLevelOffset l1) (toLevelOffset l2) 158 | 159 | levelNormCmpCore (l1,k1) (l2,k2) 160 | | l1 == l2 = compare k1 k2 161 | | levelKindRank l1 /= levelKindRank l2 = compare (levelKindRank l1) (levelKindRank l2) 162 | | otherwise = 163 | case (l1,l2) of 164 | (LevelParam n1,LevelParam n2) -> compare n1 n2 165 | (GlobalLevel n1,GlobalLevel n2) -> compare n1 n2 166 | (Max max1,Max max2) -> levelNormCmpMaxCore max1 max2 167 | (IMax max1,IMax max2) -> levelNormCmpMaxCore max1 max2 168 | 169 | levelNormCmpMaxCore (MaxCoreData _ l1a l2a) (MaxCoreData _ l1b l2b) 170 | | l1a /= l1b = levelNormCmp l1a l1b 171 | | otherwise = levelNormCmp l2a l2b 172 | 173 | collectMaxArgs (Max (MaxCoreData False l1 l2)) = collectMaxArgs l1 ++ collectMaxArgs l2 174 | collectMaxArgs l = [l] 175 | 176 | -- called on sorted explicits 177 | removeSmallExplicits [] = Nothing 178 | removeSmallExplicits [l] = Just l 179 | removeSmallExplicits (l:ls) = removeSmallExplicits ls 180 | 181 | normalizeLevel l = let p = toLevelOffset l in case fst p of 182 | Zero -> l 183 | LevelParam _ -> l 184 | GlobalLevel _ -> l 185 | IMax (MaxCoreData True l1 l2) -> 186 | let l1_n = normalizeLevel l1 187 | l2_n = normalizeLevel l2 188 | in 189 | if l1 /= l1_n || l2 /= l2_n then mkIteratedSucc (mkIMax l1_n l2_n) (snd p) else l 190 | Max max -> 191 | let maxArgs = (sortBy levelNormCmp) . concat . (map (collectMaxArgs . normalizeLevel)) $ collectMaxArgs (Max max) 192 | explicit = removeSmallExplicits $ filter isExplicit maxArgs 193 | nonExplicits = let rest = filter (not . isExplicit) maxArgs 194 | (butLast,last) = foldl (\ (keep,prev) curr -> 195 | if fst (toLevelOffset prev) == fst (toLevelOffset curr) 196 | then (keep,curr) 197 | else (keep ++ [prev],curr)) 198 | ([],head rest) 199 | (tail rest) 200 | in butLast ++ [last] 201 | explicits = case explicit of 202 | Nothing -> [] 203 | Just x -> if snd (toLevelOffset x) <= maximum (map (snd . toLevelOffset) nonExplicits) then [] else [x] 204 | allArgs = explicits ++ nonExplicits 205 | liftedArgs = map (flip mkIteratedSucc (snd p)) allArgs 206 | in 207 | mkBigMax liftedArgs 208 | 209 | mkBigMax [] = mkZero 210 | mkBigMax [l] = l 211 | mkBigMax (x:xs) = mkMax x (mkBigMax xs) 212 | 213 | -- Check whether two levels are equivalent (modulo normalizing 'max') 214 | levelEquiv l1 l2 = l1 == l2 || normalizeLevel l1 == normalizeLevel l2 215 | 216 | -- Replace 217 | 218 | type LevelReplaceFn = (Level -> Maybe Level) 219 | 220 | replaceInLevel :: LevelReplaceFn -> Level -> Level 221 | replaceInLevel f l = 222 | case f l of 223 | Just l0 -> l0 224 | Nothing -> 225 | case l of 226 | Zero -> l 227 | Succ succ -> mkSucc (replaceInLevel f $ succOf succ) 228 | Max max -> mkMax (replaceInLevel f $ maxLHS max) (replaceInLevel f $ maxRHS max) 229 | IMax imax -> mkIMax (replaceInLevel f $ maxLHS imax) (replaceInLevel f $ maxRHS imax) 230 | LevelParam _ -> l 231 | GlobalLevel _ -> l 232 | 233 | 234 | instantiateLevel :: [Name] -> [Level] -> Level -> Level 235 | instantiateLevel lpNames levels level = 236 | replaceInLevel (instantiateLevelFn lpNames levels) level 237 | where 238 | instantiateLevelFn :: [Name] -> [Level] -> LevelReplaceFn 239 | instantiateLevelFn lpNames levels level 240 | | not (genericLength lpNames == genericLength levels) = error "Wrong number of level params" 241 | | not (levelHasParam level) = Just level 242 | 243 | instantiateLevelFn lpNames levels (LevelParam name) = 244 | case elemIndex name lpNames of 245 | Nothing -> Nothing 246 | Just idx -> Just (levels!!idx) 247 | 248 | instantiateLevelFn _ _ _ = Nothing 249 | 250 | -- Order 251 | levelNotBiggerThan l1 l2 = levelNotBiggerThanCore (normalizeLevel l1) (normalizeLevel l2) where 252 | levelNotBiggerThanCore l1 l2 253 | | l1 == l2 || isZero l1 = True 254 | 255 | levelNotBiggerThanCore (Max max) l2 = levelNotBiggerThan (maxLHS max) l2 && levelNotBiggerThan (maxRHS max) l2 256 | levelNotBiggerThanCore l1 (Max max) 257 | | levelNotBiggerThan l1 (maxLHS max) || levelNotBiggerThan l1 (maxRHS max) = True 258 | 259 | levelNotBiggerThanCore (IMax imax) l2 = levelNotBiggerThan (maxLHS imax) l2 && levelNotBiggerThan (maxRHS imax) l2 260 | levelNotBiggerThanCore l1 (IMax imax) = levelNotBiggerThan l1 (maxRHS imax) 261 | 262 | levelNotBiggerThanCore l1 l2 = 263 | let (l1',k1) = toLevelOffset l1 264 | (l2',k2) = toLevelOffset l2 265 | in 266 | if l1' == l2' || isZero l1' then k1 <= k2 else 267 | if k1 == k2 && k1 > 0 then levelNotBiggerThan l1' l2' else 268 | False 269 | 270 | maybeParamName :: Level -> Maybe Name 271 | maybeParamName l = case l of 272 | LevelParam n -> Just n 273 | _ -> Nothing 274 | -------------------------------------------------------------------------------- /src/Kernel/Name.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.Name 3 | Description : Hierarchical names 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | API for hierarchical names 9 | -} 10 | module Kernel.Name ( 11 | Name 12 | , noName 13 | , mkName, mkSystemNameI, mkSystemNameS 14 | , nameRConsI, nameRConsS 15 | ) where 16 | import Kernel.Name.Internal 17 | -------------------------------------------------------------------------------- /src/Kernel/Name/Internal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.Name.Internal 3 | Description : Hierarchical names 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | Implementation of hierarchical names 9 | -} 10 | module Kernel.Name.Internal where 11 | import Data.Text (Text, pack, unpack) 12 | 13 | data Name = NoName | RConsText Name Text | RConsInteger Name Integer deriving (Eq,Ord) 14 | 15 | showName :: Name -> String 16 | showName NoName = "" 17 | showName (RConsText n s) = showName n ++ "." ++ unpack s 18 | showName (RConsInteger n i) = showName n ++ "." ++ show i 19 | 20 | instance Show Name where show n = showName n 21 | 22 | mkName :: [String] -> Name 23 | mkName ns = mkNameCore (reverse ns) where 24 | mkNameCore [] = NoName 25 | mkNameCore (n:ns) = RConsText (mkNameCore ns) (pack n) 26 | 27 | systemPrefix :: Name 28 | systemPrefix = mkName ["#_system"] 29 | 30 | mkSystemNameI :: Integer -> Name 31 | mkSystemNameI i = RConsInteger systemPrefix i 32 | 33 | mkSystemNameS :: String -> Name 34 | mkSystemNameS = RConsText systemPrefix . pack 35 | 36 | noName :: Name 37 | noName = NoName 38 | 39 | nameRConsS :: Name -> String -> Name 40 | nameRConsS n = RConsText n . pack 41 | 42 | nameRConsI :: Name -> Integer -> Name 43 | nameRConsI = RConsInteger 44 | -------------------------------------------------------------------------------- /src/Kernel/Quotient.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.Quotients 3 | Description : Declare quotient. 4 | Copyright : (c) Daniel Selsam, 2017 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | Declare quotient. 9 | -} 10 | module Kernel.Quotient (QuotientError, declareQuotient) where 11 | 12 | import Control.Monad.State 13 | import Control.Monad.Reader 14 | import Control.Monad.Trans.Except 15 | import Control.Monad.Trans.Maybe 16 | 17 | import Kernel.Name 18 | import Kernel.Level 19 | import Kernel.Expr 20 | import Kernel.TypeChecker (Env, TypeError) 21 | 22 | import qualified Kernel.TypeChecker as TypeChecker 23 | 24 | data QuotientError = TypeError TypeChecker.TypeError 25 | deriving (Eq, Show) 26 | 27 | type QuotientMethod = ExceptT QuotientError (State Env) 28 | 29 | gQuotient = mkName ["quot"] 30 | gQuotientLift = mkName["quot", "lift"] 31 | gQuotientInd = mkName["quot", "ind"] 32 | gQuotientMk = mkName ["quot", "mk"] 33 | 34 | declareQuotient :: Env -> Either QuotientError Env 35 | declareQuotient env = evalState (runExceptT declareQuotientCore) env 36 | 37 | checkEqType :: QuotientMethod () 38 | checkEqType = return () -- TODO(dhs): check 39 | 40 | addConstant :: Name -> [Name] -> Expr -> QuotientMethod () 41 | addConstant n lpNames ty = do 42 | env <- get 43 | case TypeChecker.envAddAxiom n lpNames ty env of 44 | Left err -> throwE (TypeError err) 45 | Right newEnv -> put newEnv 46 | 47 | initializeQuotExt :: QuotientMethod () 48 | initializeQuotExt = do 49 | env <- get 50 | put (TypeChecker.initQuotients env) 51 | 52 | declareQuotientCore :: QuotientMethod Env 53 | declareQuotientCore = do 54 | checkEqType 55 | let uName = mkName ["u"] 56 | let u = mkLevelParam uName 57 | let sortU = mkSort u 58 | let alpha = mkLocalData (mkName ["alpha"]) (mkName ["alpha"]) sortU BinderImplicit 59 | let r = mkLocalDataDefault (mkName ["r"]) (mkArrow (Local alpha) (mkArrow (Local alpha) mkProp)) 60 | addConstant gQuotient [uName] (abstractPi alpha (abstractPi r sortU)) 61 | let quotR = mkAppSeq (mkConstant gQuotient [u]) [Local alpha, Local r] 62 | let a = mkLocalDataDefault (mkName ["a"]) (Local alpha) 63 | addConstant gQuotientMk [uName] (abstractPi alpha (abstractPi r (abstractPi a quotR))) 64 | let r = mkLocalData (mkName ["r"]) (mkName ["r"]) (mkArrow (Local alpha) (mkArrow (Local alpha) mkProp)) BinderImplicit 65 | let vName = mkName ["v"] 66 | let v = mkLevelParam vName 67 | let sortV = mkSort v 68 | let beta = mkLocalData (mkName ["beta"]) (mkName ["beta"]) sortV BinderImplicit 69 | let f = mkLocalDataDefault (mkName ["f"]) (mkArrow (Local alpha) (Local beta)) 70 | let b = mkLocalDataDefault (mkName ["b"]) (Local alpha) 71 | let r_a_b = mkAppSeq (Local r) [Local a, Local b] 72 | let f_a_eq_f_b = mkAppSeq (mkConstant (mkName ["eq"]) [v]) [Local beta, mkApp (Local f) (Local a), mkApp (Local f) (Local b)] 73 | let sanity = abstractPi a (abstractPi b (mkArrow r_a_b f_a_eq_f_b)) 74 | addConstant gQuotientLift [uName, vName] 75 | (abstractPi alpha (abstractPi r (abstractPi beta (abstractPi f (mkArrow sanity (mkArrow quotR (Local beta))))))) 76 | let beta = mkLocalData (mkName ["beta"]) (mkName ["beta"]) (mkArrow quotR mkProp) BinderImplicit 77 | let quotMk_a = mkAppSeq (mkConstant gQuotientMk [mkLevelParam uName]) [Local alpha, Local r, Local a] 78 | let allQuot = abstractPi a (mkApp (Local beta) quotMk_a) 79 | let q = mkLocalDataDefault (mkName ["q"]) quotR 80 | let beta_q = mkApp (Local beta) (Local q) 81 | addConstant gQuotientInd [uName] 82 | (abstractPi alpha (abstractPi r (abstractPi beta (mkArrow allQuot (abstractPi q beta_q))))) 83 | initializeQuotExt 84 | get 85 | -------------------------------------------------------------------------------- /src/Kernel/TypeChecker.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.TypeChecker 3 | Description : Type checker 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | API for type checker 9 | -} 10 | module Kernel.TypeChecker ( 11 | IndDecl(IndDecl), indDeclNumParams, indDeclLPNames, indDeclName, indDeclType, indDeclIntroRules 12 | , IntroRule(IntroRule) 13 | , CompRule(CompRule) 14 | , ElimInfo(ElimInfo) 15 | , Env 16 | , mkStdEnv, initQuotients 17 | , envAddIndDecl, envAddIntroRule, envAddElimInfo, envAddCompRule 18 | , envHasGlobalLevel, envAddGlobalLevel 19 | , envLookupDecl 20 | , envAddAxiom, envAddDefinition 21 | , TypeError, TCMethod 22 | , ensureSort, ensureType 23 | , tcEval, tcRun 24 | , check, whnf, isDefEq, inferType 25 | ) where 26 | import Kernel.TypeChecker.Internal 27 | -------------------------------------------------------------------------------- /src/Kernel/TypeChecker/Internal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kernel.TypeChecker.Internal 3 | Description : Type checker 4 | Copyright : (c) Daniel Selsam, 2016 5 | License : GPL-3 6 | Maintainer : daniel.selsam@gmail.com 7 | 8 | Implementation of type checker 9 | -} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TupleSections #-} 12 | module Kernel.TypeChecker.Internal where 13 | 14 | import Control.Monad.State 15 | import Control.Monad.Reader 16 | import Control.Monad.Trans.Except 17 | import Control.Monad.Trans.Maybe 18 | 19 | import Data.List (nub, (!!), take, drop, splitAt, length) 20 | import Lens.Simple (makeLenses, set, over, view, use, (.=), (%=), (<~), (%%=)) 21 | 22 | import qualified Data.Set as Set 23 | import Data.Set (Set) 24 | 25 | import qualified Data.Map as Map 26 | import Data.Map (Map) 27 | 28 | import qualified Data.Maybe as Maybe 29 | 30 | import Kernel.Name 31 | import Kernel.Level 32 | import Kernel.Expr 33 | 34 | {- Inductive extension -} 35 | 36 | data IntroRule = IntroRule Name Expr deriving (Show) 37 | 38 | data IndDecl = IndDecl { 39 | _indDeclNumParams :: Int, 40 | _indDeclLPNames :: [Name], 41 | _indDeclName :: Name, 42 | _indDeclType :: Expr, 43 | _indDeclIntroRules :: [IntroRule] 44 | } deriving (Show) 45 | 46 | makeLenses ''IndDecl 47 | 48 | data ElimInfo = ElimInfo { 49 | elimInfoIndName :: Name, -- ^ name of the inductive datatype associated with eliminator 50 | elimInfoLevelParamNames :: [Name], -- ^ level parameter names used in computational rule 51 | elimInfoNumParams :: Int, -- ^ number of global parameters A 52 | elimInfoNumACe :: Int, -- ^ sum of number of global parameters A, type formers C, and minor preimises e. 53 | elimInfoNumIndices :: Int, -- ^ number of inductive datatype indices 54 | -- | We support K-like reduction when the inductive datatype is in Type.{0} (aka Prop), proof irrelevance is enabled, 55 | -- it has only one introduction rule, the introduction rule has "0 arguments". 56 | elimInfoKTarget :: Bool, 57 | elimInfoDepElim :: Bool -- ^ elimInfoDepElim == true if dependent elimination is used for this eliminator 58 | } deriving (Show) 59 | 60 | -- | Represents a single computation rule 61 | data CompRule = CompRule { 62 | compRuleElimName :: Name, -- ^ name of the corresponding eliminator 63 | compRuleNumArgs :: Int, -- ^ sum of number of rec_args and nonrec_args in the corresponding introduction rule. 64 | compRuleRHS :: Expr -- ^ computational rule RHS: Fun (A, C, e, b, u), (e_k_i b u v) 65 | } deriving (Show) 66 | 67 | data InductiveExt = InductiveExt { 68 | _indExtElimInfos :: Map Name ElimInfo, 69 | _indExtCompRules :: Map Name CompRule, 70 | _indExtIntroNameToIndName :: Map Name Name, 71 | _indExtIndDecls :: Map Name IndDecl 72 | } deriving (Show) 73 | 74 | makeLenses ''InductiveExt 75 | 76 | mkEmptyInductiveExt = InductiveExt Map.empty Map.empty Map.empty Map.empty 77 | 78 | {- Environments -} 79 | 80 | data Decl = Decl { 81 | declName :: Name, 82 | declLPNames :: [Name], 83 | declType :: Expr, 84 | declVal :: Maybe Expr 85 | } deriving (Eq,Show) 86 | 87 | data Env = Env { 88 | _envDecls :: Map Name Decl, 89 | _envGlobalNames :: Set Name, 90 | _envIndExt :: InductiveExt, 91 | _envQuotEnabled :: Bool 92 | } deriving (Show) 93 | 94 | makeLenses ''Env 95 | 96 | mkStdEnv = Env Map.empty Set.empty mkEmptyInductiveExt False 97 | 98 | initQuotients :: Env -> Env 99 | initQuotients env = set envQuotEnabled True env 100 | 101 | {- Decls -} 102 | 103 | mkDefinition :: Env -> Name -> [Name] -> Expr -> Expr -> Decl 104 | mkDefinition env name levelParamNames ty val = 105 | Decl name levelParamNames ty (Just val) 106 | 107 | mkAxiom :: Name -> [Name] -> Expr -> Decl 108 | mkAxiom name lpNames ty = Decl name lpNames ty Nothing 109 | 110 | isDefinition :: Decl -> Bool 111 | isDefinition decl = Maybe.isJust $ declVal decl 112 | 113 | envLookupDecl :: Name -> Env -> Maybe Decl 114 | envLookupDecl name = Map.lookup name . view envDecls 115 | 116 | 117 | envHasGlobalLevel :: Name -> Env -> Bool 118 | envHasGlobalLevel name = Set.member name . view envGlobalNames 119 | 120 | envAddGlobalLevel :: Name -> Env -> Env 121 | envAddGlobalLevel name env = case envHasGlobalLevel name env of 122 | False -> over envGlobalNames (Set.insert name) env 123 | 124 | envAddIndDecl :: IndDecl -> Env -> Env 125 | envAddIndDecl idecl = over (envIndExt . indExtIndDecls) $ Map.insert (view indDeclName idecl) idecl 126 | 127 | envAddIntroRule :: Name -> Name -> Env -> Env 128 | envAddIntroRule irName indName = over (envIndExt . indExtIntroNameToIndName) $ Map.insert irName indName 129 | 130 | envAddElimInfo :: Name -> ElimInfo -> Env -> Env 131 | envAddElimInfo elimName elimInfo = over (envIndExt . indExtElimInfos) $ Map.insert elimName elimInfo 132 | 133 | envAddCompRule :: Name -> CompRule -> Env -> Env 134 | envAddCompRule irName compRule = over (envIndExt . indExtCompRules) $ Map.insert irName compRule 135 | 136 | 137 | {- TCMethods -} 138 | 139 | data TypeError = UndefGlobalLevel Name 140 | | UndefLevelParam Name 141 | | TypeExpected Expr 142 | | FunctionExpected Expr 143 | | TypeMismatchAtApp Expr Expr 144 | | TypeMismatchAtDef Expr Expr 145 | | DeclHasFreeVars Expr 146 | | DeclHasLocals Expr 147 | | NameAlreadyDeclared Decl 148 | | DuplicateLevelParamName 149 | | ConstNotFound Name 150 | | ConstHasWrongNumLevels Name [Name] [Level] 151 | | LetNoName LetData 152 | | LetTypeMismatch LetData 153 | deriving (Eq,Show) 154 | 155 | data TypeCheckerR = TypeCheckerR { 156 | _tcrEnv :: Env , 157 | _tcrLPNames :: [Name] 158 | } 159 | 160 | makeLenses ''TypeCheckerR 161 | 162 | data TypeCheckerS = TypeCheckerS { 163 | _tcsNextId :: Integer, 164 | _tcsInferTypeCache :: Map Expr Expr, 165 | _tcsWhnfCache :: Map Expr Expr 166 | } 167 | 168 | makeLenses ''TypeCheckerS 169 | 170 | mkTypeCheckerR :: Env -> [Name] -> TypeCheckerR 171 | mkTypeCheckerR env levelParamNames = TypeCheckerR env levelParamNames 172 | 173 | mkTypeCheckerS :: Integer -> TypeCheckerS 174 | mkTypeCheckerS nextId = TypeCheckerS nextId Map.empty Map.empty 175 | 176 | type TCMethod = ExceptT TypeError (StateT TypeCheckerS (Reader TypeCheckerR)) 177 | 178 | tcEval :: Env -> [Name] -> Integer -> TCMethod a -> Either TypeError (a, Integer) 179 | tcEval env lpNames nextId tcFn = 180 | let (x, tc) = runReader (runStateT (runExceptT tcFn) (mkTypeCheckerS nextId)) (mkTypeCheckerR env lpNames) in 181 | (, view tcsNextId tc) <$> x 182 | 183 | tcRun :: Env -> [Name] -> Integer -> TCMethod a -> Either TypeError a 184 | tcRun env lpNames nextId = fmap fst . (tcEval env lpNames nextId) 185 | 186 | check :: Env -> Decl -> Either TypeError () 187 | check env d = tcRun env (declLPNames d) 0 (checkMain d) 188 | 189 | checkMain :: Decl -> TCMethod () 190 | checkMain d = do 191 | checkNoLocal (declType d) 192 | maybe (return ()) checkNoLocal (declVal d) 193 | checkName (declName d) 194 | checkDuplicatedParams 195 | sort <- inferType (declType d) 196 | ensureSort sort 197 | maybe (return ()) (checkValMatchesType (declType d)) (declVal d) 198 | 199 | tcAssert :: Bool -> TypeError -> TCMethod () 200 | tcAssert b err = if b then return () else throwE err 201 | 202 | {- Checkers -} 203 | 204 | checkNoLocal :: Expr -> TCMethod () 205 | checkNoLocal e = tcAssert (not $ exprHasLocal e) (DeclHasLocals e) 206 | 207 | checkName :: Name -> TCMethod() 208 | checkName name = do 209 | env <- asks _tcrEnv 210 | maybe (return ()) (throwE . NameAlreadyDeclared) (envLookupDecl name env) 211 | 212 | checkDuplicatedParams :: TCMethod () 213 | checkDuplicatedParams = do 214 | lpNames <- asks _tcrLPNames 215 | tcAssert (lpNames == nub lpNames) DuplicateLevelParamName 216 | 217 | checkValMatchesType :: Expr -> Expr -> TCMethod() 218 | checkValMatchesType ty val = do 219 | valTy <- inferType val 220 | isDefEq ty valTy >>= flip tcAssert (TypeMismatchAtDef ty valTy) 221 | 222 | checkClosed :: Expr -> TCMethod () 223 | checkClosed e = tcAssert (not $ hasFreeVars e) (DeclHasFreeVars e) 224 | 225 | checkLevel :: Level -> TCMethod () 226 | checkLevel level = do 227 | tcr <- ask 228 | maybe (return ()) (throwE . UndefLevelParam) $ getUndefParam level (view tcrLPNames tcr) 229 | maybe (return ()) (throwE . UndefGlobalLevel) $ getUndefGlobal level (view (tcrEnv . envGlobalNames) tcr) 230 | 231 | ensureSort :: Expr -> TCMethod SortData 232 | ensureSort e = case e of 233 | Sort sort -> return sort 234 | _ -> do 235 | eWhnf <- whnf e 236 | case eWhnf of 237 | Sort sort -> return sort 238 | _ -> throwE $ TypeExpected eWhnf 239 | 240 | ensureType :: Expr -> TCMethod SortData 241 | ensureType e = inferType e >>= ensureSort 242 | 243 | ensurePi :: Expr -> TCMethod BindingData 244 | ensurePi e = case e of 245 | Pi pi -> return pi 246 | _ -> do 247 | eWhnf <- whnf e 248 | case eWhnf of 249 | Pi pi -> return pi 250 | _ -> throwE $ FunctionExpected eWhnf 251 | 252 | {- Infer type -} 253 | 254 | inferType :: Expr -> TCMethod Expr 255 | inferType e = {-# SCC "inferType" #-} do 256 | checkClosed e 257 | inferTypeCache <- use tcsInferTypeCache 258 | case Map.lookup e inferTypeCache of 259 | Just ty -> return ty 260 | Nothing -> do 261 | ty <- case e of 262 | Local local -> return $ localType local 263 | Sort sort -> checkLevel (sortLevel sort) >> (return . mkSort . mkSucc . sortLevel) sort 264 | Constant constant -> inferConstant constant 265 | Lambda lambda -> inferLambda lambda 266 | Pi pi -> inferPi pi 267 | App app -> inferApp app 268 | Let lett -> inferLet lett 269 | tcsInferTypeCache %= Map.insert e ty 270 | return ty 271 | 272 | inferConstant :: ConstantData -> TCMethod Expr 273 | inferConstant c = do 274 | env <- asks _tcrEnv 275 | case envLookupDecl (constName c) env of 276 | Nothing -> throwE . ConstNotFound . constName $ c 277 | Just d -> do 278 | let (dLPNames, cLevels) = (declLPNames d, constLevels c) 279 | tcAssert (length dLPNames == length cLevels) $ ConstHasWrongNumLevels (constName c) dLPNames cLevels 280 | mapM_ checkLevel cLevels 281 | return $ instantiateLevelParams (declType d) dLPNames cLevels 282 | 283 | mkLocalFor :: BindingData -> TCMethod LocalData 284 | mkLocalFor bind = do 285 | nextId <- gensym 286 | return $ mkLocalData (mkSystemNameI nextId) (bindingName bind) (bindingDomain bind) (bindingInfo bind) 287 | 288 | inferLambda :: BindingData -> TCMethod Expr 289 | inferLambda lam = do 290 | domainTy <- inferType (bindingDomain lam) 291 | ensureSort domainTy 292 | local <- mkLocalFor lam 293 | bodyTy <- inferType (instantiate (bindingBody lam) (Local local)) 294 | return $ abstractPi local bodyTy 295 | 296 | inferPi :: BindingData -> TCMethod Expr 297 | inferPi pi = do 298 | domainTy <- inferType (bindingDomain pi) 299 | domainTyAsSort <- ensureSort domainTy 300 | local <- mkLocalFor pi 301 | bodyTy <- inferType (instantiate (bindingBody pi) (Local local)) 302 | bodyTyAsSort <- ensureSort bodyTy 303 | env <- asks _tcrEnv 304 | return $ mkSort (mkIMax (sortLevel domainTyAsSort) (sortLevel bodyTyAsSort)) 305 | 306 | inferApp :: AppData -> TCMethod Expr 307 | inferApp app = do 308 | fnTy <- inferType (appFn app) 309 | fnTyAsPi <- ensurePi fnTy 310 | argTy <- inferType (appArg app) 311 | isEq <- isDefEq (bindingDomain fnTyAsPi) argTy 312 | if isEq then return $ instantiate (bindingBody fnTyAsPi) (appArg app) 313 | else throwE $ TypeMismatchAtApp (bindingDomain fnTyAsPi) argTy 314 | 315 | inferLet :: LetData -> TCMethod Expr 316 | inferLet lett = do 317 | tcAssert (letName lett /= noName) (LetNoName lett) 318 | ensureType (letType lett) 319 | valType <- inferType (letVal lett) 320 | isEq <- isDefEq (letType lett) valType 321 | tcAssert isEq (LetTypeMismatch lett) 322 | inferType $ instantiate (letBody lett) (letVal lett) 323 | 324 | {- Weak-head normal form (whnf) -} 325 | 326 | whnf :: Expr -> TCMethod Expr 327 | whnf e = {-# SCC "whnf" #-} 328 | case e of 329 | Var _ -> return e 330 | Sort _ -> return e 331 | Local _ -> return e 332 | Pi _ -> return e 333 | _ -> do 334 | whnfCache <- use tcsWhnfCache 335 | case Map.lookup e whnfCache of 336 | Just ty -> return ty 337 | Nothing -> do 338 | e_n <- do 339 | e1 <- whnfCoreDelta e 340 | e2Maybe <- normalizeExt e1 341 | case e2Maybe of 342 | Nothing -> return e1 343 | Just e2 -> whnf e2 344 | tcsWhnfCache %= Map.insert e e_n 345 | return e_n 346 | 347 | whnfCoreDelta :: Expr -> TCMethod Expr 348 | whnfCoreDelta e = do 349 | e1 <- whnfCore e 350 | e2 <- unfoldNames e1 351 | if e == e2 then return e else whnfCoreDelta e2 352 | 353 | whnfCore :: Expr -> TCMethod Expr 354 | whnfCore e = case e of 355 | App app -> do 356 | let (op, revArgs) = getAppOpRevArgs e 357 | op_n <- whnfCore op 358 | case op_n of 359 | Lambda _ -> let (m, body) = bodyOfLambdaN (length revArgs) op_n 360 | argsToInstantiate = drop (length revArgs - m) revArgs 361 | remainingArgs = take (length revArgs - m) revArgs in 362 | whnfCore (mkRevAppSeq (instantiateSeq body argsToInstantiate) remainingArgs) 363 | _ -> if op_n == op then return e else whnfCore (mkRevAppSeq op_n revArgs) 364 | Let lett -> whnfCore (instantiate (letBody lett) (letVal lett)) 365 | _ -> return e 366 | where 367 | bodyOfLambdaN :: Int -> Expr -> (Int, Expr) 368 | bodyOfLambdaN maxArgs e = bodyOfLambdaNCore maxArgs 0 e 369 | 370 | bodyOfLambdaNCore :: Int -> Int -> Expr -> (Int, Expr) 371 | bodyOfLambdaNCore maxArgs numArgs e = case e of 372 | Lambda lam | numArgs < maxArgs -> bodyOfLambdaNCore maxArgs (numArgs+1) (bindingBody lam) 373 | _ -> (numArgs, e) 374 | 375 | unfoldNames :: Expr -> TCMethod Expr 376 | unfoldNames e = case e of 377 | App app -> let (op, args) = getAppOpArgs e in 378 | flip mkAppSeq args <$> unfoldNameCore op 379 | _ -> unfoldNameCore e 380 | 381 | unfoldNameCore :: Expr -> TCMethod Expr 382 | unfoldNameCore e = case e of 383 | Constant const -> do 384 | env <- asks _tcrEnv 385 | maybe (return e) 386 | (\d -> case declVal d of 387 | Just dVal 388 | | length (constLevels const) == length (declLPNames d) -> unfoldNameCore (instantiateLevelParams dVal (declLPNames d) $ constLevels const) 389 | Nothing -> return e) 390 | (envLookupDecl (constName const) env) 391 | _ -> return e 392 | 393 | -- TODO(dhs): check for bools and support HoTT 394 | normalizeExt :: Expr -> TCMethod (Maybe Expr) 395 | normalizeExt e = runMaybeT (inductiveNormExt e `mplus` quotientNormExt e) 396 | 397 | gensym :: TCMethod Integer 398 | gensym = tcsNextId %%= \n -> (n, n + 1) 399 | 400 | -- isDefEq 401 | 402 | isDefEq :: Expr -> Expr -> TCMethod Bool 403 | isDefEq t s = {-# SCC "isDefEq" #-} do 404 | success <- runExceptT (isDefEqCore t s) 405 | case success of 406 | Left answer -> return answer 407 | Right () -> return False 408 | 409 | -- | If 'deqFn' short-circuits, then 'deqCommitTo deqFn' short-circuits with the same value, otherwise it shortcircuits with False. 410 | deqCommitTo :: DefEqMethod () -> DefEqMethod () 411 | deqCommitTo deqFn = deqFn >> throwE False 412 | 413 | -- | 'deqTryAnd' proceeds through its arguments, and short-circuits with True if all arguments short-circuit with True, otherwise it does nothing. 414 | deqTryAnd :: [DefEqMethod ()] -> DefEqMethod () 415 | deqTryAnd [] = throwE True 416 | deqTryAnd (deqFn:deqFns) = do 417 | success <- lift $ runExceptT deqFn 418 | case success of 419 | Left True -> deqTryAnd deqFns 420 | _ -> return () 421 | 422 | -- | 'deqTryOr' proceeds through its arguments, and short-circuits with True if any of its arguments short-circuit with True, otherwise it does nothing. 423 | deqTryOr :: [DefEqMethod ()] -> DefEqMethod () 424 | deqTryOr [] = return () 425 | deqTryOr (deqFn:deqFns) = do 426 | success <- lift $ runExceptT deqFn 427 | case success of 428 | Left True -> throwE True 429 | _ -> deqTryOr deqFns 430 | 431 | -- This exception means we know if they are equal or not 432 | type DefEqMethod = ExceptT Bool TCMethod 433 | 434 | deqAssert b err = lift $ tcAssert b err 435 | 436 | -- | 'deqTryIf b check' tries 'check' only if 'b' is true, otherwise does nothing. 437 | deqTryIf :: Bool -> DefEqMethod () -> DefEqMethod () 438 | deqTryIf b check = if b then check else return () 439 | 440 | isDefEqCore :: Expr -> Expr -> DefEqMethod () 441 | isDefEqCore t s = do 442 | quickIsDefEq t s 443 | t_n <- lift $ whnfCore t 444 | s_n <- lift $ whnfCore s 445 | deqTryIf (t_n /= t || s_n /= s) $ quickIsDefEq t_n s_n 446 | (t_nn, s_nn) <- reduceDefEq t_n s_n 447 | 448 | case (t_nn, s_nn) of 449 | (Constant const1, Constant const2) | constName const1 == constName const2 && 450 | isDefEqLevels (constLevels const1) (constLevels const2) -> throwE True 451 | (Local local1, Local local2) | localName local1 == localName local2 -> throwE True 452 | (App app1,App app2) -> deqCommitTo (isDefEqApp t_nn s_nn) 453 | _ -> return () 454 | 455 | isDefEqEta t_nn s_nn 456 | env <- asks _tcrEnv 457 | isDefEqProofIrrel t_nn s_nn 458 | 459 | reduceDefEq :: Expr -> Expr -> DefEqMethod (Expr, Expr) 460 | reduceDefEq t s = do 461 | (t, s, status) <- lazyDeltaReduction t s >>= uncurry extReductionStep 462 | case status of 463 | DefUnknown -> return (t, s) 464 | Continue -> reduceDefEq t s 465 | 466 | extReductionStep :: Expr -> Expr -> DefEqMethod (Expr, Expr, ReductionStatus) 467 | extReductionStep t s = do 468 | mb_t <- lift $ normalizeExt t 469 | mb_s <- lift $ normalizeExt s 470 | 471 | (t_nn, s_nn, status) <- 472 | case (mb_t, mb_s) of 473 | (Nothing, Nothing) -> return (t, s, DefUnknown) 474 | (Just t_n, Nothing) -> (, s, Continue) <$> (lift . whnfCore) t_n 475 | (Nothing, Just s_n) -> (t, , Continue) <$> (lift . whnfCore) s_n 476 | (Just t_n, Just s_n) -> do t_nn <- lift $ whnfCore t_n 477 | s_nn <- lift $ whnfCore s_n 478 | return (t_nn, s_nn, Continue) 479 | 480 | case status of 481 | DefUnknown -> return (t_nn, s_nn, DefUnknown) 482 | Continue -> quickIsDefEq t_nn s_nn >> return (t_nn, s_nn, Continue) 483 | 484 | lazyDeltaReduction :: Expr -> Expr -> DefEqMethod (Expr,Expr) 485 | lazyDeltaReduction t s = do 486 | (t_n, s_n, status) <- lazyDeltaReductionStep t s 487 | case status of 488 | DefUnknown -> return (t_n, s_n) 489 | Continue -> lazyDeltaReduction t_n s_n 490 | 491 | data ReductionStatus = Continue | DefUnknown 492 | appendToPair :: (a, b) -> c -> (a, b, c) 493 | appendToPair (x, y) z = (x, y, z) 494 | 495 | isDelta :: Env -> Expr -> Maybe Decl 496 | isDelta env e = do 497 | const <- maybeConstant . getOperator $ e 498 | decl <- flip envLookupDecl env . constName $ const 499 | guard . isDefinition $ decl 500 | return decl 501 | 502 | -- | Perform one lazy delta-reduction step. 503 | lazyDeltaReductionStep :: Expr -> Expr -> DefEqMethod (Expr, Expr, ReductionStatus) 504 | lazyDeltaReductionStep t s = do 505 | env <- asks _tcrEnv 506 | (t_n, s_n, status) <- 507 | case (isDelta env t, isDelta env s) of 508 | (Nothing, Nothing) -> return (t, s, DefUnknown) 509 | (Just d_t, Nothing) -> (, s, Continue) <$> lift (unfoldNames t >>= whnfCore) 510 | (Nothing, Just d_s) -> (t, , Continue) <$> lift (unfoldNames s >>= whnfCore) 511 | (Just d_t, Just d_s) -> case (t, s) of 512 | (App t_app, App s_app) -> isDefEqApp t s >> (, s, Continue) <$> lift (unfoldNames t >>= whnfCore) 513 | _ -> (, s, Continue) <$> lift (unfoldNames t >>= whnfCore) 514 | case status of 515 | DefUnknown -> return (t_n, s_n, DefUnknown) 516 | Continue -> quickIsDefEq t_n s_n >> return (t_n,s_n,Continue) 517 | 518 | {- | Throw true if 't' and 's' are definitionally equal because they are applications of the form 519 | '(f a_1 ... a_n)' and '(g b_1 ... b_n)', where 'f' and 'g' are definitionally equal, and 520 | 'a_i' and 'b_i' are also definitionally equal for every 1 <= i <= n. 521 | Throw 'False' otherwise. 522 | -} 523 | isDefEqApp :: Expr -> Expr -> DefEqMethod () 524 | isDefEqApp t s = 525 | deqTryAnd [isDefEqCore (getOperator t) (getOperator s), 526 | throwE (length (getAppArgs t) == length (getAppArgs s)), 527 | mapM_ (uncurry isDefEqCore) (zip (getAppArgs t) (getAppArgs s))] 528 | 529 | isDefEqEta :: Expr -> Expr -> DefEqMethod () 530 | isDefEqEta t s = deqTryOr [isDefEqEtaCore t s, isDefEqEtaCore s t] 531 | 532 | -- | Try to solve (fun (x : A), B) =?= s by trying eta-expansion on s 533 | -- The 'by' indicates that it short-circuits False 't' and 's' are not equal by eta-expansion, even though they may be equal for another reason. The enclosing 'deq_any_of' ignores any 'False's. 534 | isDefEqEtaCore :: Expr -> Expr -> DefEqMethod () 535 | isDefEqEtaCore t s = go t s where 536 | go (Lambda lam1) (Lambda lam2) = throwE False 537 | go (Lambda lam1) s = do 538 | s_ty_n <- lift $ inferType s >>= whnf 539 | case s_ty_n of 540 | Pi pi -> let new_s = mkLambda (bindingName pi) (bindingDomain pi) (mkApp s (mkVar 0)) (bindingInfo pi) in 541 | deqCommitTo (isDefEqCore t new_s) 542 | _ -> throwE False 543 | go _ _ = throwE False 544 | 545 | isProp :: Expr -> TCMethod Bool 546 | isProp e = do 547 | e_ty <- inferType e 548 | e_ty_whnf <- whnf e_ty 549 | if e_ty_whnf == mkProp then return True else return False 550 | 551 | isDefEqProofIrrel :: Expr -> Expr -> DefEqMethod () 552 | isDefEqProofIrrel t s = do 553 | t_ty <- lift $ inferType t 554 | t_ty_is_prop <- lift $ isProp t_ty 555 | deqTryIf t_ty_is_prop $ do 556 | s_ty <- lift $ inferType s 557 | isDefEqCore t_ty s_ty 558 | 559 | quickIsDefEq :: Expr -> Expr -> DefEqMethod () 560 | quickIsDefEq t s = do 561 | case (t, s) of 562 | (Lambda lam1, Lambda lam2) -> deqCommitTo (isDefEqBinding lam1 lam2) 563 | (Pi pi1, Pi pi2) -> deqCommitTo (isDefEqBinding pi1 pi2) 564 | (Sort sort1, Sort sort2) -> throwE (levelEquiv (sortLevel sort1) (sortLevel sort2)) 565 | _ -> return () 566 | 567 | -- | Given lambda/Pi expressions 't' and 's', return true iff 't' is def eq to 's', which holds iff 'domain(t)' is definitionally equal to 'domain(s)' and 'body(t)' is definitionally equal to 'body(s)' 568 | isDefEqBinding :: BindingData -> BindingData -> DefEqMethod () 569 | isDefEqBinding bind1 bind2 = do 570 | deqTryAnd [(isDefEqCore (bindingDomain bind1) (bindingDomain bind2)), 571 | do local <- lift $ Local <$> mkLocalFor bind1 572 | isDefEqCore (instantiate (bindingBody bind1) local) (instantiate (bindingBody bind2) local)] 573 | 574 | isDefEqLevels :: [Level] -> [Level] -> Bool 575 | isDefEqLevels ls1 ls2 = all (uncurry levelEquiv) (zip ls1 ls2) 576 | 577 | {- extensions -} 578 | 579 | liftMaybe :: (MonadPlus m) => Maybe a -> m a 580 | liftMaybe = maybe mzero return 581 | 582 | -- | Reduce terms 'e' of the form 'elim_k A C e p[A,b] (intro_k_i A b u)' 583 | inductiveNormExt :: Expr -> MaybeT TCMethod Expr 584 | inductiveNormExt e = do 585 | elimInfos <- liftM (view $ tcrEnv . envIndExt . indExtElimInfos) $ ask 586 | elimOpConst <- liftMaybe . maybeConstant . getOperator $ e 587 | einfo@(ElimInfo indName lpNames numParams numACe numIndices kTarget depElim) <- 588 | liftMaybe $ Map.lookup (constName elimOpConst) elimInfos 589 | guard $ length (getAppArgs e) >= numACe + numIndices + 1 590 | let majorIdx = numACe + numIndices 591 | let major = (getAppArgs e) !! majorIdx 592 | (introApp,compRule) <- findCompRule einfo elimOpConst major 593 | let elimArgs = getAppArgs e 594 | let introArgs = getAppArgs introApp 595 | guard $ length introArgs == numParams + (compRuleNumArgs compRule) 596 | guard $ length (constLevels elimOpConst) == length lpNames 597 | let rhsArgs = reverse ((take numACe elimArgs) ++ (take (compRuleNumArgs compRule) $ drop numParams introArgs)) 598 | let rhsBody = instantiateLevelParams (innerBodyOfLambda . compRuleRHS $ compRule) lpNames (constLevels elimOpConst) 599 | let rhsBodyInstantiated = instantiateSeq rhsBody rhsArgs 600 | let extraArgs = drop (majorIdx + 1) elimArgs 601 | return $ mkAppSeq rhsBodyInstantiated extraArgs 602 | where 603 | findCompRule :: ElimInfo -> ConstantData -> Expr -> MaybeT TCMethod (Expr, CompRule) 604 | findCompRule einfo elimOpConst major 605 | | elimInfoKTarget einfo = do 606 | mb_result <- lift . runMaybeT $ 607 | (do introApp <- toIntroWhenK einfo major 608 | compRules <- liftM (view $ tcrEnv . envIndExt . indExtCompRules) ask 609 | introAppOpConst <- liftMaybe . maybeConstant . getOperator $ introApp 610 | compRule <- liftMaybe $ Map.lookup (constName introAppOpConst) compRules 611 | return (introApp, compRule)) 612 | case mb_result of 613 | Nothing -> regularCompRule einfo elimOpConst major 614 | Just result -> return result 615 | | otherwise = regularCompRule einfo elimOpConst major 616 | regularCompRule :: ElimInfo -> ConstantData -> Expr -> MaybeT TCMethod (Expr, CompRule) 617 | regularCompRule einfo elimOpConst major = do 618 | introApp <- lift $ whnf major 619 | compRule <- isIntroFor (constName elimOpConst) introApp 620 | return (introApp, compRule) 621 | 622 | -- | Return 'True' if 'e' is an introduction rule for an eliminator named 'elim' 623 | isIntroFor :: Name -> Expr -> MaybeT TCMethod CompRule 624 | isIntroFor elimName e = do 625 | compRules <- liftM (view $ tcrEnv . envIndExt . indExtCompRules) ask 626 | introFnConst <- liftMaybe $ maybeConstant (getOperator e) 627 | compRule <- liftMaybe $ Map.lookup (constName introFnConst) compRules 628 | guard (compRuleElimName compRule == elimName) 629 | return compRule 630 | 631 | -- | For datatypes that support K-axiom, given e an element of that type, we convert (if possible) 632 | -- to the default constructor. For example, if (e : a = a), then this method returns (eq.refl a) 633 | toIntroWhenK :: ElimInfo -> Expr -> MaybeT TCMethod Expr 634 | toIntroWhenK einfo e = do 635 | env <- asks _tcrEnv 636 | appType <- lift $ inferType e >>= whnf 637 | let appTypeOp = getOperator appType 638 | appTypeOpConst <- liftMaybe $ maybeConstant appTypeOp 639 | guard (constName appTypeOpConst == elimInfoIndName einfo) 640 | newIntroApp <- liftMaybe $ mkNullaryIntro env appType (elimInfoNumParams einfo) 641 | newType <- lift $ inferType newIntroApp 642 | (lift $ isDefEq appType newType) >>= guard 643 | return newIntroApp 644 | 645 | -- | If 'op_name' is the name of a non-empty inductive datatype, then return the 646 | -- name of the first introduction rule. Return 'Nothing' otherwise. 647 | getFirstIntro :: Env -> Name -> Maybe Name 648 | getFirstIntro env opName = do 649 | IndDecl _ _ _ _ [IntroRule irName _] <- Map.lookup opName $ view (envIndExt . indExtIndDecls) env 650 | return irName 651 | 652 | mkNullaryIntro :: Env -> Expr -> Int -> Maybe Expr 653 | mkNullaryIntro env appType numParams = 654 | let (op, args) = getAppOpArgs appType in do 655 | opConst <- maybeConstant op 656 | introName <- getFirstIntro env (constName opConst) 657 | return $ mkAppSeq (mkConstant introName (constLevels opConst)) (take numParams args) 658 | 659 | {- Quotient -} 660 | 661 | quotientNormExt :: Expr -> MaybeT TCMethod Expr 662 | quotientNormExt e = do 663 | env <- asks _tcrEnv 664 | guard $ view envQuotEnabled env 665 | op <- liftMaybe $ maybeConstant (getOperator e) 666 | (mkPos, argPos) <- if constName op == quotLift then return (5,3) else 667 | if constName op == quotInd then return (4,3) else 668 | fail "no quot comp rule applies" 669 | args <- return $ getAppArgs e 670 | guard $ length args > mkPos 671 | mk <- lift . whnf $ args !! mkPos 672 | case mk of 673 | App mkAsApp -> do 674 | let mkOp = getOperator mk 675 | mkOpConst <- liftMaybe $ maybeConstant mkOp 676 | guard $ constName mkOpConst == quotMk 677 | let f = args !! argPos 678 | let elimArity = mkPos + 1 679 | let extraArgs = drop elimArity args 680 | return $ mkAppSeq (mkApp f (appArg mkAsApp)) extraArgs 681 | _ -> fail "element of type 'quot' not constructed with 'quot.mk'" 682 | where 683 | quotLift = mkName ["quot","lift"] 684 | quotInd = mkName ["quot","ind"] 685 | quotMk = mkName ["quot","mk"] 686 | 687 | {- Adding to the environment -} 688 | 689 | envAddDecl :: Decl -> Env -> Either TypeError Env 690 | envAddDecl decl env = 691 | case check env decl of 692 | Left err -> Left err 693 | Right () -> case envLookupDecl (declName decl) env of 694 | Nothing -> Right $ over envDecls (Map.insert (declName decl) decl) env 695 | 696 | envAddAxiom :: Name -> [Name] -> Expr -> Env -> Either TypeError Env 697 | envAddAxiom name lpNames ty = envAddDecl (mkAxiom name lpNames ty) 698 | 699 | envAddDefinition :: Name -> [Name] -> Expr -> Expr -> Env -> Either TypeError Env 700 | envAddDefinition name lpNames ty val env = envAddDecl (mkDefinition env name lpNames ty val) env 701 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | import Kernel.Name 5 | import Kernel.Level 6 | import Kernel.Expr 7 | import Kernel.TypeChecker 8 | 9 | someFunc :: IO () 10 | someFunc = do 11 | print $ mkName ["eq","rec"] 12 | print $ mkSucc mkZero 13 | print $ mkConstant (mkName ["foo"]) [mkZero, mkSucc mkZero] 14 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-5.4 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /test/ExprSpec.hs: -------------------------------------------------------------------------------- 1 | module ExprSpec where 2 | import Test.Hspec 3 | 4 | import Kernel.Name.Internal 5 | import Kernel.Level.Internal 6 | import Kernel.Expr.Internal 7 | 8 | mkType = mkSort mkLevelOne 9 | 10 | getFreeVarRangeSpec = 11 | let e1 = mkConstant (mkName ["c1"]) [] 12 | e2 = mkApp e1 (mkVar 1) 13 | e3 = mkSort mkZero 14 | e4 = mkLambdaDefault e3 e2 15 | e5 = mkPiDefault e3 e4 in do 16 | describe "getFreeVarRange" $ do 17 | it "should be 0 for constants" $ do 18 | getFreeVarRange e1 `shouldBe` 0 19 | it "should be 1+vIdx for Vars inside Apps" $ do 20 | getFreeVarRange e2 `shouldBe` 2 21 | it "should be 0 for sorts" $ do 22 | getFreeVarRange e3 `shouldBe` 0 23 | it "should decrement for each lambda" $ do 24 | getFreeVarRange e4 `shouldBe` 1 25 | it "should decrement for each pi" $ do 26 | getFreeVarRange e5 `shouldBe` 0 27 | 28 | 29 | exprHasLevelParamSpec = 30 | let lp1 = mkLevelParam (mkName ["l1"]) 31 | gp1 = mkGlobalLevel (mkName ["g1"]) 32 | level1 = mkIteratedSucc (mkIMax lp1 mkLevelTwo) 2 33 | level2 = mkIteratedSucc (mkMax (mkSucc mkZero) gp1) 3 34 | const1 = mkConstant (mkName ["c1"]) [level1] 35 | const2 = mkConstant (mkName ["c2"]) [level2] 36 | const12 = mkConstant (mkName ["c12"]) [level1,level2] 37 | e1 = mkLambdaDefault mkProp const1 38 | e2 = mkPiDefault const2 const2 39 | e12 = mkPiDefault const12 e2 40 | e3 = mkPiDefault (mkSort lp1) const2 in do 41 | describe "exprHasLevelParam" $ do 42 | it "should be True for constants with level params" $ do 43 | exprHasLevelParam e1 `shouldBe` True 44 | it "should be False for constants with no level params" $ do 45 | exprHasLevelParam e2 `shouldBe` False 46 | it "should be True for constants with some level params" $ do 47 | exprHasLevelParam e12 `shouldBe` True 48 | it "should be True if there is a sort with a level param" $ do 49 | exprHasLevelParam e3 `shouldBe` True 50 | 51 | instantiateSpec :: Spec 52 | instantiateSpec = 53 | let c1 = mkConstant (mkName ["c1"]) [] 54 | c2 = mkConstant (mkName ["c2"]) [] 55 | 56 | e1 = mkLambdaDefault (mkApp c1 c2) (mkVar 1) 57 | subst1 = mkApp (mkVar 10) mkType 58 | ret1 = instantiate e1 subst1 59 | expectedRet1 = mkLambdaDefault (mkApp c1 c2) (mkApp (mkVar 11) mkType) 60 | 61 | e2 = mkLambdaDefault mkType (mkAppSeq (mkVar 0) [mkVar 1,mkVar 2]) 62 | subst2 = c1 63 | ret2 = instantiate e2 subst2 64 | expectedRet2 = mkLambdaDefault mkType (mkAppSeq (mkVar 0) [c1,mkVar 1]) 65 | 66 | ret3 = instantiate ret2 c2 67 | expectedRet3 = mkLambdaDefault mkType (mkAppSeq (mkVar 0) [c1,c2]) 68 | 69 | ret4 = instantiate (mkPiDefault (mkVar 3) (mkVar 4)) (mkVar 0) 70 | expectedRet4 = mkPiDefault (mkVar 2) (mkVar 3) 71 | in do 72 | describe "instantiate" $ do 73 | it "should lift free vars in subst" $ do 74 | ret1 `shouldBe` expectedRet1 75 | it "should lift free vars in subst" $ do 76 | ret2 `shouldBe` expectedRet2 77 | it "should lift free vars in subst" $ do 78 | ret3 `shouldBe` expectedRet3 79 | it "should decrement untouched free vars in e" $ do 80 | ret4 `shouldBe` expectedRet4 81 | 82 | instantiateLevelParamsSpec :: Spec 83 | instantiateLevelParamsSpec = 84 | let lp1 = mkLevelParam (mkName ["l1"]) 85 | gp1 = mkGlobalLevel (mkName ["g1"]) 86 | level1 = mkIteratedSucc (mkIMax lp1 mkLevelTwo) 2 87 | level2 = mkIteratedSucc (mkMax (mkSucc mkZero) gp1) 3 88 | const1 = mkConstant (mkName ["c1"]) [level1] 89 | const2 = mkConstant (mkName ["c2"]) [level2] 90 | const12 = mkConstant (mkName ["c12"]) [level1,level2] 91 | e1 = mkLambdaDefault mkProp const1 92 | e2 = mkPiDefault const2 const2 93 | e12 = mkPiDefault const12 e2 94 | e3 = mkPiDefault (mkSort lp1) const2 in do 95 | describe "instantiateLevelParams" $ do 96 | it "sanity test" $ do 97 | instantiateLevelParams e1 [mkName ["l1"]] [level2] `shouldBe` 98 | (mkLambdaDefault mkProp (mkConstant (mkName ["c1"]) [mkIteratedSucc (mkIMax level2 mkLevelTwo) 2])) 99 | it "should work even if subst contains the same level params" $ do 100 | instantiateLevelParams e1 [mkName ["l1"]] [level1] `shouldBe` 101 | (mkLambdaDefault mkProp (mkConstant (mkName ["c1"]) [mkIteratedSucc (mkIMax level1 mkLevelTwo) 2])) 102 | 103 | 104 | appSeqSpec :: Spec 105 | appSeqSpec = 106 | let cs = map (\s -> mkConstant (mkName [s]) []) ["c1","c2","c3","c4"] 107 | 108 | e = mkApp (mkApp (mkApp (cs!!0) (cs!!1)) (cs!!2)) (cs!!3) 109 | op = getOperator e 110 | args = getAppArgs e 111 | e' = mkAppSeq op args 112 | 113 | s = mkLambdaDefault mkProp (mkVar 2) 114 | in do 115 | describe "appSeq" $ do 116 | it "mkAppSeq (getOperator e) (getAppArgs e) should yield e" $ do 117 | e `shouldBe` e' 118 | it "getOperator e = e if e is not app" $ do 119 | (getOperator s) `shouldBe` s 120 | it "getAppArgs e = [] if e is not app" $ do 121 | (getAppArgs s) `shouldBe` [] 122 | 123 | innerBodyOfLambdaSpec :: Spec 124 | innerBodyOfLambdaSpec = 125 | let c = mkConstant (mkName ["c"]) [] 126 | e = mkLambdaDefault mkProp (mkLambdaDefault mkType c) in do 127 | describe "innerBodyOfLambda" $ do 128 | it "should return body of nested lambdas" $ do 129 | (innerBodyOfLambda e) `shouldBe` c 130 | it "should do nothing on constants" $ do 131 | (innerBodyOfLambda (innerBodyOfLambda e)) `shouldBe` (innerBodyOfLambda e) 132 | 133 | 134 | spec :: Spec 135 | spec = do 136 | getFreeVarRangeSpec 137 | exprHasLevelParamSpec 138 | instantiateSpec 139 | instantiateLevelParamsSpec 140 | appSeqSpec 141 | innerBodyOfLambdaSpec 142 | -------------------------------------------------------------------------------- /test/Integration.hs: -------------------------------------------------------------------------------- 1 | module Integration where 2 | 3 | import Test.Hspec 4 | import Frontend.Parser 5 | 6 | stdFilename = "data/all.out" 7 | hottFilename = "data/all.hout" 8 | 9 | test :: IO () 10 | test = do 11 | testStd 12 | testHott 13 | 14 | testStd = do 15 | stdContents <- readFile stdFilename 16 | case typeCheckExportFile True stdFilename stdContents of 17 | Right _ -> return () 18 | 19 | testHott = do 20 | hottContents <- readFile hottFilename 21 | case typeCheckExportFile False hottFilename hottContents of 22 | Right _ -> return () 23 | -------------------------------------------------------------------------------- /test/LevelSpec.hs: -------------------------------------------------------------------------------- 1 | module LevelSpec where 2 | import Test.Hspec 3 | 4 | import Kernel.Name.Internal 5 | import Kernel.Level.Internal 6 | 7 | levelHasParamSpec :: Spec 8 | levelHasParamSpec = do 9 | let lp1 = mkLevelParam (mkName ["l1"]) 10 | lp2 = mkLevelParam (mkName ["l2"]) 11 | gp1 = mkGlobalLevel (mkName ["g1"]) 12 | gp2 = mkGlobalLevel (mkName ["g2"]) 13 | l0 = mkIteratedSucc gp1 3 14 | l1 = mkIteratedSucc lp1 4 15 | l2 = mkIteratedSucc (mkMax lp1 gp1) 2 16 | l3 = mkIteratedSucc (mkMax gp1 gp2) 2 17 | l4 = mkMax gp1 (mkMax gp2 mkZero) 18 | l5 = mkIMax gp1 (mkIMax lp1 lp2) in do 19 | describe "levelHasParam" $ do 20 | it "global should not count" $ do 21 | (levelHasParam l0) `shouldBe` False 22 | it "should recurse under Succ" $ do 23 | (levelHasParam l1) `shouldBe` True 24 | it "should recurse under succ and max when true" $ do 25 | (levelHasParam l2) `shouldBe` True 26 | it "should recurse under succ and max when false" $ do 27 | (levelHasParam l3) `shouldBe` False 28 | it "should recurse under nested max when false" $ do 29 | (levelHasParam l4) `shouldBe` False 30 | it "should recurse under nested max when true" $ do 31 | (levelHasParam l5) `shouldBe` True 32 | 33 | replaceInLevelSpec :: Spec 34 | replaceInLevelSpec = 35 | let f1 = (\level -> case level of 36 | LevelParam param -> Just (GlobalLevel param) 37 | _ -> Nothing) 38 | f2 = (\level -> Just (mkSucc level)) 39 | gp1 = mkGlobalLevel (mkName ["l1"]) 40 | lp2 = mkLevelParam (mkName ["l2"]) 41 | gp2 = mkGlobalLevel (mkName ["l2"]) 42 | level = mkIteratedSucc (mkMax gp1 (mkIMax lp2 (mkIteratedSucc mkZero 3))) 2 43 | ret1 = replaceInLevel f1 level 44 | expected1 = mkIteratedSucc (mkMax gp1 (mkIMax gp2 (mkIteratedSucc mkZero 3))) 2 45 | ret2 = replaceInLevel f2 level 46 | expected2 = mkIteratedSucc (mkMax gp1 (mkIMax lp2 (mkIteratedSucc mkZero 3))) 3 in do 47 | describe "replaceInLevel" $ do 48 | it "should only replace when `f` returns Just" $ do 49 | ret1 `shouldBe` expected1 50 | it "should not recurse if f always returns Just" $ do 51 | ret2 `shouldBe` expected2 52 | 53 | 54 | instantiateLevelSpec :: Spec 55 | instantiateLevelSpec = 56 | let lpNames = map (\s -> mkName [s]) ["lp1","lp2"] 57 | lp1 = mkLevelParam (mkName ["lp1"]) 58 | lp2 = mkLevelParam (mkName ["lp2"]) 59 | lp3 = mkLevelParam (mkName ["lp3"]) 60 | oldLevel = mkMax lp1 (mkMax lp2 lp3) 61 | 62 | newLevels1 = [mkZero,lp3] 63 | newLevel1 = instantiateLevel lpNames newLevels1 oldLevel 64 | expectedNewLevel1 = lp3 65 | 66 | newLevels2 = [lp2,lp1] 67 | newLevel2 = instantiateLevel lpNames newLevels2 oldLevel 68 | expectedNewLevel2 = mkMax lp2 (mkMax lp1 lp3) 69 | in do 70 | describe "instantiateLevel" $ do 71 | it "sanity test" $ do 72 | newLevel1 `shouldBe` expectedNewLevel1 73 | it "should work when substituting existing level param" $ do 74 | newLevel2 `shouldBe` expectedNewLevel2 75 | 76 | 77 | levelsMiscSpec :: Spec 78 | levelsMiscSpec = 79 | let zero = mkZero 80 | one = mkSucc zero 81 | two = mkSucc one 82 | p1 = mkLevelParam (mkName ["p1"]) 83 | p2 = mkLevelParam (mkName ["p2"]) 84 | in describe "levels misc" $ do 85 | it "basic" $ do 86 | (mkMax one two) `shouldBe` two 87 | (mkIMax one two) `shouldBe` two 88 | (mkIMax two zero) `shouldBe` zero 89 | (mkIMax p1 zero) `shouldBe` zero 90 | (mkMax zero p1) `shouldBe` p1 91 | (mkMax p1 zero) `shouldBe` p1 92 | (mkMax p1 one) `shouldNotBe` p1 93 | levelEquiv one (mkSucc zero) `shouldBe` True 94 | levelEquiv zero two `shouldBe` False 95 | levelEquiv zero p2 `shouldBe` False 96 | it "should normalize max" $ do 97 | (levelEquiv (mkSucc p2) (mkMax p2 (mkSucc p2))) `shouldBe` True 98 | (levelEquiv (mkMax p1 p2) (mkMax p2 p1)) `shouldBe` True 99 | it "should not normalize imax" $ do 100 | levelEquiv (mkIMax p1 p2) (mkIMax p2 p1) `shouldBe` False 101 | it "mkIMax should call mkMax" $ do 102 | levelEquiv (mkIMax (mkSucc p1) (mkSucc p2)) (mkIMax (mkSucc p2) (mkSucc p1)) `shouldBe` True 103 | 104 | normalizeSpec1 :: Spec 105 | normalizeSpec1 = 106 | let u = mkGlobalLevel (mkName ["u"]) 107 | v = mkGlobalLevel (mkName ["v"]) 108 | z = mkZero 109 | one = mkSucc z 110 | two = mkSucc one in do 111 | describe "normalize1" $ do 112 | it "max should ignore zeros" $ do 113 | (normalizeLevel $ mkMax z (mkMax u (mkSucc z))) 114 | `shouldBe` 115 | (mkMax (mkSucc z) u) 116 | it "basic1" $ do 117 | (normalizeLevel $ mkMax (mkMax (mkSucc v) u) (mkMax v (mkSucc u))) 118 | `shouldBe` 119 | (mkMax (mkSucc u) (mkSucc v)) 120 | it "basic" $ do 121 | (normalizeLevel $ mkMax (mkSucc mkZero) u) `shouldBe` (mkMax (mkSucc mkZero) u) 122 | it "basic2" $ do 123 | (normalizeLevel $ mkMax (mkSucc (mkMax (mkSucc v) u)) (mkMax v (mkSucc (mkSucc u)))) 124 | `shouldBe` 125 | (mkMax (mkSucc (mkSucc u)) (mkSucc (mkSucc v))) 126 | it "should remove irrelevant explicit levels" $ do 127 | (normalizeLevel $ mkMax (mkSucc u) (mkMax (mkMax u one) (mkMax one u))) 128 | `shouldBe` 129 | (mkSucc u) 130 | 131 | levelNotBiggerThanSpec1 :: Spec 132 | levelNotBiggerThanSpec1 = do 133 | let u = mkLevelParam (mkName ["u"]) in 134 | describe "levelNotBiggerThan" $ do 135 | it "should work with max on the rhs" $ do 136 | levelNotBiggerThan u (mkMax (mkSucc mkZero) u) `shouldBe` True 137 | 138 | spec :: Spec 139 | spec = do 140 | levelHasParamSpec 141 | replaceInLevelSpec 142 | instantiateLevelSpec 143 | levelsMiscSpec 144 | normalizeSpec1 145 | levelNotBiggerThanSpec1 146 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Hspec 4 | import qualified LevelSpec 5 | import qualified ExprSpec 6 | import qualified TypeCheckerSpec 7 | import qualified Integration 8 | 9 | main :: IO () 10 | main = do 11 | Integration.test 12 | hspec $ do 13 | LevelSpec.spec 14 | ExprSpec.spec 15 | TypeCheckerSpec.spec 16 | -------------------------------------------------------------------------------- /test/TypeCheckerSpec.hs: -------------------------------------------------------------------------------- 1 | module TypeCheckerSpec where 2 | import Test.Hspec 3 | 4 | import Kernel.Name.Internal 5 | import Kernel.Level.Internal 6 | import Kernel.Expr.Internal 7 | import Kernel.TypeChecker.Internal 8 | 9 | mkType = mkSort mkLevelOne 10 | mkType2 = mkSort mkLevelTwo 11 | 12 | inferLambda1 = 13 | let env = mkStdEnv 14 | lam1 = mkLambdaDefault mkProp mkProp 15 | result1 = tcRun env [] 0 (inferType lam1) 16 | in 17 | describe "inferLambda1" $ do 18 | it "basic" $ do 19 | case result1 of 20 | Right e -> 21 | case e of 22 | Pi pi -> do 23 | (bindingDomain pi) `shouldBe` mkProp 24 | (bindingBody pi) `shouldBe` mkType 25 | 26 | inferApp1 = 27 | let env = mkStdEnv 28 | lam1 = mkLambdaDefault mkType mkType 29 | app1 = mkApp lam1 mkProp 30 | result1 = tcRun env [] 0 (inferType app1) 31 | in 32 | describe "inferApp1" $ do 33 | it "basic" $ do 34 | case result1 of 35 | Right e -> e `shouldBe` mkType2 36 | 37 | inferConst1 = 38 | let env = mkStdEnv 39 | axType = mkPiDefault mkType mkProp 40 | axName = mkName ["ax1"] in 41 | case envAddAxiom axName [] axType env of 42 | Right newEnv -> 43 | describe "inferConst1" $ do 44 | it "basic" $ do 45 | case tcRun newEnv [] 0 (inferType (mkConstant axName [])) of 46 | Right e -> e `shouldBe` axType 47 | 48 | 49 | hpass = return () 50 | hfail = True `shouldBe` False 51 | 52 | triggerExceptions = describe "TypeChecker exceptions" $ do 53 | it "UndefGlobalLevel" $ do 54 | let n = mkName ["undef"] 55 | uni = mkGlobalLevel n 56 | d = mkAxiom noName [] (mkSort uni) in 57 | case check mkStdEnv d of 58 | Left err -> err `shouldBe` (UndefGlobalLevel n) 59 | it "UndefLevelParam" $ do 60 | let n = mkName ["undef"] 61 | lp = mkLevelParam n 62 | d = mkAxiom noName [] (mkSort lp) in 63 | case check mkStdEnv d of 64 | Left err -> err `shouldBe` (UndefLevelParam n) 65 | it "TypeExpected" $ do 66 | let e = mkLambdaDefault mkProp mkProp 67 | t = mkPiDefault mkProp mkType 68 | d = mkAxiom noName [] e in 69 | case check mkStdEnv d of 70 | Left (TypeExpected _) -> hpass 71 | _ -> hfail 72 | it "FunctionExpected" $ do 73 | let d = mkAxiom noName [] (mkApp mkProp mkProp) in 74 | case check mkStdEnv d of 75 | Left (FunctionExpected _) -> hpass 76 | _ -> hfail 77 | it "TypeMismatchAtApp" $ do 78 | let e = mkApp (mkLambdaDefault mkProp mkProp) mkProp 79 | d = mkAxiom noName [] e in 80 | case check mkStdEnv d of 81 | Left (TypeMismatchAtApp _ _) -> hpass 82 | _ -> hfail 83 | it "TypeMismatchAtDef" $ do 84 | let e = mkLambdaDefault mkProp mkProp 85 | t = mkPiDefault mkType mkType 86 | d = mkDefinition mkStdEnv noName [] t e in 87 | case check mkStdEnv d of 88 | Left (TypeMismatchAtDef _ _) -> hpass 89 | it "DeclHasFreeVars" $ do 90 | let d = mkAxiom noName [] (mkVar 0) in 91 | case check mkStdEnv d of 92 | Left (DeclHasFreeVars _) -> hpass 93 | it "DeclHasLocals" $ do 94 | let d = mkAxiom noName [] (mkLocal noName noName mkProp BinderDefault) in 95 | case check mkStdEnv d of 96 | Left (DeclHasLocals _) -> hpass 97 | it "NameAlreadyDeclared" $ do 98 | case envAddAxiom noName [] mkProp mkStdEnv of 99 | Right newEnv -> case envAddAxiom noName [] mkProp newEnv of 100 | Left (NameAlreadyDeclared _) -> hpass 101 | it "DuplicateLevelParamName" $ do 102 | let n = mkName ["undef"] 103 | lp = mkLevelParam n 104 | d = mkAxiom noName [n,n] (mkSort lp) in 105 | case check mkStdEnv d of 106 | Left DuplicateLevelParamName -> hpass 107 | _ -> hfail 108 | it "ConstNotFound" $ do 109 | let c = mkConstant (mkName ["not-found"]) [] 110 | d = mkAxiom noName [] c in 111 | case check mkStdEnv d of 112 | Left (ConstNotFound _) -> hpass 113 | _ -> hfail 114 | it "ConstHasWrongNumLevels" $ do 115 | case envAddAxiom noName [] mkProp mkStdEnv of 116 | Right newEnv -> case envAddAxiom (mkName ["n"]) [] (mkConstant noName [mkZero]) newEnv of 117 | Left (ConstHasWrongNumLevels _ _ _) -> hpass 118 | _ -> hfail 119 | 120 | spec :: Spec 121 | spec = do 122 | inferLambda1 123 | inferApp1 124 | inferConst1 125 | triggerExceptions 126 | --------------------------------------------------------------------------------