├── .github └── workflows │ └── mdbook.yml ├── .gitignore ├── .ocamlformat ├── LICENCE ├── README.md ├── TODO.md ├── bin ├── dune └── khasmc.ml ├── dune-project ├── khasmc.opam ├── lib ├── dune ├── frontend │ ├── ast.ml │ ├── lexer.mll │ ├── parser.ml │ ├── token.ml │ ├── trait_resolution.ml │ ├── typecheck.ml │ └── unify.ml ├── main.ml ├── monomorph │ └── monomorphize.ml └── share │ ├── log.ml │ ├── maybe.ml │ ├── result.ml │ ├── types.ml │ └── uuid.ml └── test.kha /.github/workflows/mdbook.yml: -------------------------------------------------------------------------------- 1 | # Sample workflow for building and deploying a mdBook site to GitHub Pages 2 | # 3 | # To get started with mdBook see: https://rust-lang.github.io/mdBook/index.html 4 | # 5 | name: Deploy mdBook site to Pages 6 | 7 | on: 8 | # Runs on pushes targeting the default branch 9 | push: 10 | branches: ["main"] 11 | 12 | # Allows you to run this workflow manually from the Actions tab 13 | workflow_dispatch: 14 | 15 | # Sets permissions of the GITHUB_TOKEN to allow deployment to GitHub Pages 16 | permissions: 17 | contents: read 18 | pages: write 19 | id-token: write 20 | 21 | # Allow only one concurrent deployment, skipping runs queued between the run in-progress and latest queued. 22 | # However, do NOT cancel in-progress runs as we want to allow these production deployments to complete. 23 | concurrency: 24 | group: "pages" 25 | 26 | jobs: 27 | # Build job 28 | build: 29 | runs-on: ubuntu-latest 30 | env: 31 | MDBOOK_VERSION: 0.4.28 32 | MDBOOK_CHAPTER_NUMBER_VERSION: 0.1.2 33 | steps: 34 | - uses: actions/checkout@v3 35 | - name: Install mdBook 36 | run: | 37 | mkdir mdbin 38 | curl -sSL https://github.com/rust-lang/mdBook/releases/download/v0.4.34/mdbook-v0.4.34-x86_64-unknown-linux-gnu.tar.gz | tar -xz --directory=mdbin 39 | ls -lah 40 | ls -lah mdbin 41 | pwd 42 | - name: Setup Pages 43 | id: pages 44 | uses: actions/configure-pages@v3 45 | - name: Use OCaml 46 | uses: ocaml/setup-ocaml@v2 47 | with: 48 | ocaml-compiler: 5.x.x 49 | - run: opam install . --deps-only 50 | - run: opam install odoc 51 | - run: opam exec -- dune build @doc 52 | - name: Build with mdBook 53 | working-directory: docs/ 54 | run: | 55 | ../mdbin/mdbook build 56 | - name: Add OCaml docs 57 | run: | 58 | mkdir docs/book/ocaml 59 | cp -r _build/default/_doc/_html/* docs/book/ocaml 60 | - name: Upload artifact 61 | uses: actions/upload-pages-artifact@v1 62 | with: 63 | path: ./docs/book 64 | 65 | # Deployment job 66 | deploy: 67 | environment: 68 | name: github-pages 69 | url: ${{ steps.deployment.outputs.page_url }} 70 | runs-on: ubuntu-latest 71 | needs: build 72 | steps: 73 | - name: Deploy to GitHub Pages 74 | id: deployment 75 | uses: actions/deploy-pages@v2 76 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | input 3 | output 4 | a.out* 5 | *perf* 6 | gmon* 7 | *.svg 8 | massif* -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | if-then-else = vertical 3 | type-decl = sparse 4 | break-infix = fit-or-vertical 5 | margin = 70 6 | exp-grouping = preserve 7 | let-and = sparse 8 | 9 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Mozilla Public License Version 2.0 2 | ================================== 3 | 4 | 1. Definitions 5 | -------------- 6 | 7 | 1.1. "Contributor" 8 | means each individual or legal entity that creates, contributes to 9 | the creation of, or owns Covered Software. 10 | 11 | 1.2. "Contributor Version" 12 | means the combination of the Contributions of others (if any) used 13 | by a Contributor and that particular Contributor's Contribution. 14 | 15 | 1.3. "Contribution" 16 | means Covered Software of a particular Contributor. 17 | 18 | 1.4. "Covered Software" 19 | means Source Code Form to which the initial Contributor has attached 20 | the notice in Exhibit A, the Executable Form of such Source Code 21 | Form, and Modifications of such Source Code Form, in each case 22 | including portions thereof. 23 | 24 | 1.5. "Incompatible With Secondary Licenses" 25 | means 26 | 27 | (a) that the initial Contributor has attached the notice described 28 | in Exhibit B to the Covered Software; or 29 | 30 | (b) that the Covered Software was made available under the terms of 31 | version 1.1 or earlier of the License, but not also under the 32 | terms of a Secondary License. 33 | 34 | 1.6. "Executable Form" 35 | means any form of the work other than Source Code Form. 36 | 37 | 1.7. "Larger Work" 38 | means a work that combines Covered Software with other material, in 39 | a separate file or files, that is not Covered Software. 40 | 41 | 1.8. "License" 42 | means this document. 43 | 44 | 1.9. "Licensable" 45 | means having the right to grant, to the maximum extent possible, 46 | whether at the time of the initial grant or subsequently, any and 47 | all of the rights conveyed by this License. 48 | 49 | 1.10. "Modifications" 50 | means any of the following: 51 | 52 | (a) any file in Source Code Form that results from an addition to, 53 | deletion from, or modification of the contents of Covered 54 | Software; or 55 | 56 | (b) any new file in Source Code Form that contains any Covered 57 | Software. 58 | 59 | 1.11. "Patent Claims" of a Contributor 60 | means any patent claim(s), including without limitation, method, 61 | process, and apparatus claims, in any patent Licensable by such 62 | Contributor that would be infringed, but for the grant of the 63 | License, by the making, using, selling, offering for sale, having 64 | made, import, or transfer of either its Contributions or its 65 | Contributor Version. 66 | 67 | 1.12. "Secondary License" 68 | means either the GNU General Public License, Version 2.0, the GNU 69 | Lesser General Public License, Version 2.1, the GNU Affero General 70 | Public License, Version 3.0, or any later versions of those 71 | licenses. 72 | 73 | 1.13. "Source Code Form" 74 | means the form of the work preferred for making modifications. 75 | 76 | 1.14. "You" (or "Your") 77 | means an individual or a legal entity exercising rights under this 78 | License. For legal entities, "You" includes any entity that 79 | controls, is controlled by, or is under common control with You. For 80 | purposes of this definition, "control" means (a) the power, direct 81 | or indirect, to cause the direction or management of such entity, 82 | whether by contract or otherwise, or (b) ownership of more than 83 | fifty percent (50%) of the outstanding shares or beneficial 84 | ownership of such entity. 85 | 86 | 2. License Grants and Conditions 87 | -------------------------------- 88 | 89 | 2.1. Grants 90 | 91 | Each Contributor hereby grants You a world-wide, royalty-free, 92 | non-exclusive license: 93 | 94 | (a) under intellectual property rights (other than patent or trademark) 95 | Licensable by such Contributor to use, reproduce, make available, 96 | modify, display, perform, distribute, and otherwise exploit its 97 | Contributions, either on an unmodified basis, with Modifications, or 98 | as part of a Larger Work; and 99 | 100 | (b) under Patent Claims of such Contributor to make, use, sell, offer 101 | for sale, have made, import, and otherwise transfer either its 102 | Contributions or its Contributor Version. 103 | 104 | 2.2. Effective Date 105 | 106 | The licenses granted in Section 2.1 with respect to any Contribution 107 | become effective for each Contribution on the date the Contributor first 108 | distributes such Contribution. 109 | 110 | 2.3. Limitations on Grant Scope 111 | 112 | The licenses granted in this Section 2 are the only rights granted under 113 | this License. No additional rights or licenses will be implied from the 114 | distribution or licensing of Covered Software under this License. 115 | Notwithstanding Section 2.1(b) above, no patent license is granted by a 116 | Contributor: 117 | 118 | (a) for any code that a Contributor has removed from Covered Software; 119 | or 120 | 121 | (b) for infringements caused by: (i) Your and any other third party's 122 | modifications of Covered Software, or (ii) the combination of its 123 | Contributions with other software (except as part of its Contributor 124 | Version); or 125 | 126 | (c) under Patent Claims infringed by Covered Software in the absence of 127 | its Contributions. 128 | 129 | This License does not grant any rights in the trademarks, service marks, 130 | or logos of any Contributor (except as may be necessary to comply with 131 | the notice requirements in Section 3.4). 132 | 133 | 2.4. Subsequent Licenses 134 | 135 | No Contributor makes additional grants as a result of Your choice to 136 | distribute the Covered Software under a subsequent version of this 137 | License (see Section 10.2) or under the terms of a Secondary License (if 138 | permitted under the terms of Section 3.3). 139 | 140 | 2.5. Representation 141 | 142 | Each Contributor represents that the Contributor believes its 143 | Contributions are its original creation(s) or it has sufficient rights 144 | to grant the rights to its Contributions conveyed by this License. 145 | 146 | 2.6. Fair Use 147 | 148 | This License is not intended to limit any rights You have under 149 | applicable copyright doctrines of fair use, fair dealing, or other 150 | equivalents. 151 | 152 | 2.7. Conditions 153 | 154 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted 155 | in Section 2.1. 156 | 157 | 3. Responsibilities 158 | ------------------- 159 | 160 | 3.1. Distribution of Source Form 161 | 162 | All distribution of Covered Software in Source Code Form, including any 163 | Modifications that You create or to which You contribute, must be under 164 | the terms of this License. You must inform recipients that the Source 165 | Code Form of the Covered Software is governed by the terms of this 166 | License, and how they can obtain a copy of this License. You may not 167 | attempt to alter or restrict the recipients' rights in the Source Code 168 | Form. 169 | 170 | 3.2. Distribution of Executable Form 171 | 172 | If You distribute Covered Software in Executable Form then: 173 | 174 | (a) such Covered Software must also be made available in Source Code 175 | Form, as described in Section 3.1, and You must inform recipients of 176 | the Executable Form how they can obtain a copy of such Source Code 177 | Form by reasonable means in a timely manner, at a charge no more 178 | than the cost of distribution to the recipient; and 179 | 180 | (b) You may distribute such Executable Form under the terms of this 181 | License, or sublicense it under different terms, provided that the 182 | license for the Executable Form does not attempt to limit or alter 183 | the recipients' rights in the Source Code Form under this License. 184 | 185 | 3.3. Distribution of a Larger Work 186 | 187 | You may create and distribute a Larger Work under terms of Your choice, 188 | provided that You also comply with the requirements of this License for 189 | the Covered Software. If the Larger Work is a combination of Covered 190 | Software with a work governed by one or more Secondary Licenses, and the 191 | Covered Software is not Incompatible With Secondary Licenses, this 192 | License permits You to additionally distribute such Covered Software 193 | under the terms of such Secondary License(s), so that the recipient of 194 | the Larger Work may, at their option, further distribute the Covered 195 | Software under the terms of either this License or such Secondary 196 | License(s). 197 | 198 | 3.4. Notices 199 | 200 | You may not remove or alter the substance of any license notices 201 | (including copyright notices, patent notices, disclaimers of warranty, 202 | or limitations of liability) contained within the Source Code Form of 203 | the Covered Software, except that You may alter any license notices to 204 | the extent required to remedy known factual inaccuracies. 205 | 206 | 3.5. Application of Additional Terms 207 | 208 | You may choose to offer, and to charge a fee for, warranty, support, 209 | indemnity or liability obligations to one or more recipients of Covered 210 | Software. However, You may do so only on Your own behalf, and not on 211 | behalf of any Contributor. You must make it absolutely clear that any 212 | such warranty, support, indemnity, or liability obligation is offered by 213 | You alone, and You hereby agree to indemnify every Contributor for any 214 | liability incurred by such Contributor as a result of warranty, support, 215 | indemnity or liability terms You offer. You may include additional 216 | disclaimers of warranty and limitations of liability specific to any 217 | jurisdiction. 218 | 219 | 4. Inability to Comply Due to Statute or Regulation 220 | --------------------------------------------------- 221 | 222 | If it is impossible for You to comply with any of the terms of this 223 | License with respect to some or all of the Covered Software due to 224 | statute, judicial order, or regulation then You must: (a) comply with 225 | the terms of this License to the maximum extent possible; and (b) 226 | describe the limitations and the code they affect. Such description must 227 | be placed in a text file included with all distributions of the Covered 228 | Software under this License. Except to the extent prohibited by statute 229 | or regulation, such description must be sufficiently detailed for a 230 | recipient of ordinary skill to be able to understand it. 231 | 232 | 5. Termination 233 | -------------- 234 | 235 | 5.1. The rights granted under this License will terminate automatically 236 | if You fail to comply with any of its terms. However, if You become 237 | compliant, then the rights granted under this License from a particular 238 | Contributor are reinstated (a) provisionally, unless and until such 239 | Contributor explicitly and finally terminates Your grants, and (b) on an 240 | ongoing basis, if such Contributor fails to notify You of the 241 | non-compliance by some reasonable means prior to 60 days after You have 242 | come back into compliance. Moreover, Your grants from a particular 243 | Contributor are reinstated on an ongoing basis if such Contributor 244 | notifies You of the non-compliance by some reasonable means, this is the 245 | first time You have received notice of non-compliance with this License 246 | from such Contributor, and You become compliant prior to 30 days after 247 | Your receipt of the notice. 248 | 249 | 5.2. If You initiate litigation against any entity by asserting a patent 250 | infringement claim (excluding declaratory judgment actions, 251 | counter-claims, and cross-claims) alleging that a Contributor Version 252 | directly or indirectly infringes any patent, then the rights granted to 253 | You by any and all Contributors for the Covered Software under Section 254 | 2.1 of this License shall terminate. 255 | 256 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all 257 | end user license agreements (excluding distributors and resellers) which 258 | have been validly granted by You or Your distributors under this License 259 | prior to termination shall survive termination. 260 | 261 | ************************************************************************ 262 | * * 263 | * 6. Disclaimer of Warranty * 264 | * ------------------------- * 265 | * * 266 | * Covered Software is provided under this License on an "as is" * 267 | * basis, without warranty of any kind, either expressed, implied, or * 268 | * statutory, including, without limitation, warranties that the * 269 | * Covered Software is free of defects, merchantable, fit for a * 270 | * particular purpose or non-infringing. The entire risk as to the * 271 | * quality and performance of the Covered Software is with You. * 272 | * Should any Covered Software prove defective in any respect, You * 273 | * (not any Contributor) assume the cost of any necessary servicing, * 274 | * repair, or correction. This disclaimer of warranty constitutes an * 275 | * essential part of this License. No use of any Covered Software is * 276 | * authorized under this License except under this disclaimer. * 277 | * * 278 | ************************************************************************ 279 | 280 | ************************************************************************ 281 | * * 282 | * 7. Limitation of Liability * 283 | * -------------------------- * 284 | * * 285 | * Under no circumstances and under no legal theory, whether tort * 286 | * (including negligence), contract, or otherwise, shall any * 287 | * Contributor, or anyone who distributes Covered Software as * 288 | * permitted above, be liable to You for any direct, indirect, * 289 | * special, incidental, or consequential damages of any character * 290 | * including, without limitation, damages for lost profits, loss of * 291 | * goodwill, work stoppage, computer failure or malfunction, or any * 292 | * and all other commercial damages or losses, even if such party * 293 | * shall have been informed of the possibility of such damages. This * 294 | * limitation of liability shall not apply to liability for death or * 295 | * personal injury resulting from such party's negligence to the * 296 | * extent applicable law prohibits such limitation. Some * 297 | * jurisdictions do not allow the exclusion or limitation of * 298 | * incidental or consequential damages, so this exclusion and * 299 | * limitation may not apply to You. * 300 | * * 301 | ************************************************************************ 302 | 303 | 8. Litigation 304 | ------------- 305 | 306 | Any litigation relating to this License may be brought only in the 307 | courts of a jurisdiction where the defendant maintains its principal 308 | place of business and such litigation shall be governed by laws of that 309 | jurisdiction, without reference to its conflict-of-law provisions. 310 | Nothing in this Section shall prevent a party's ability to bring 311 | cross-claims or counter-claims. 312 | 313 | 9. Miscellaneous 314 | ---------------- 315 | 316 | This License represents the complete agreement concerning the subject 317 | matter hereof. If any provision of this License is held to be 318 | unenforceable, such provision shall be reformed only to the extent 319 | necessary to make it enforceable. Any law or regulation which provides 320 | that the language of a contract shall be construed against the drafter 321 | shall not be used to construe this License against a Contributor. 322 | 323 | 10. Versions of the License 324 | --------------------------- 325 | 326 | 10.1. New Versions 327 | 328 | Mozilla Foundation is the license steward. Except as provided in Section 329 | 10.3, no one other than the license steward has the right to modify or 330 | publish new versions of this License. Each version will be given a 331 | distinguishing version number. 332 | 333 | 10.2. Effect of New Versions 334 | 335 | You may distribute the Covered Software under the terms of the version 336 | of the License under which You originally received the Covered Software, 337 | or under the terms of any subsequent version published by the license 338 | steward. 339 | 340 | 10.3. Modified Versions 341 | 342 | If you create software not governed by this License, and you want to 343 | create a new license for such software, you may create and use a 344 | modified version of this License if you rename the license and remove 345 | any references to the name of the license steward (except to note that 346 | such modified license differs from this License). 347 | 348 | 10.4. Distributing Source Code Form that is Incompatible With Secondary 349 | Licenses 350 | 351 | If You choose to distribute Source Code Form that is Incompatible With 352 | Secondary Licenses under the terms of this version of the License, the 353 | notice described in Exhibit B of this License must be attached. 354 | 355 | Exhibit A - Source Code Form License Notice 356 | ------------------------------------------- 357 | 358 | This Source Code Form is subject to the terms of the Mozilla Public 359 | License, v. 2.0. If a copy of the MPL was not distributed with this 360 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 361 | 362 | If it is not possible or desirable to put the notice in a particular 363 | file, then You may include the notice in a location (such as a LICENSE 364 | file in a relevant directory) where a recipient would be likely to look 365 | for such a notice. 366 | 367 | You may add additional accurate notices of copyright ownership. 368 | 369 | Exhibit B - "Incompatible With Secondary Licenses" Notice 370 | --------------------------------------------------------- 371 | 372 | This Source Code Form is "Incompatible With Secondary Licenses", as 373 | defined by the Mozilla Public License, v. 2.0. 374 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Khasmc 2 | 3 | The compiler for the khasm programming language. 4 | 5 | ## NOTE: 6 | 7 | Khasm and khasmc are still in pre-beta development. 8 | The below partially writes like it is a currently working language - it is not. 9 | Consider the below, for the moment, a wishlist for what this language will hopefully eventually look like. 10 | 11 | ## What is khasm? 12 | 13 | Khasm is a functional programming language that aims to be simple, but expressive. Minimalism is *not* the name of the game - making code that's easy to understand is. 14 | 15 | ### Simple and effective type system 16 | 17 | Khasm's type system is based off the likes of Haskell and OCaml, removing global inference. While this may seem odd, the end goal of this is to improve user experience by offering better errors and allowing programmers a more finely grained control over the code they write. 18 | 19 | ## A few example programs: 20 | 21 | Here's a hello world program in khasm: 22 | 23 | ```ocaml 24 | import Stdlib 25 | fun main (): unit = 26 | println "Hello, World!" 27 | ``` 28 | 29 | The classic recursive fibonacci: 30 | ```ocaml 31 | fun fib (n: int): int = 32 | if n <= 1 then 33 | 1 34 | else fib n + fib (n - 1) 35 | (* No let rec needed! *) 36 | ``` 37 | 38 | List operations: 39 | ```ocaml 40 | import List 41 | 42 | fun process (l: List int): List int = 43 | List.map (fn x -> x + 3) l 44 | |> List.filter (fn x -> x % 2 == 0) 45 | |> List.map (fn x -> gcd x 10) 46 | |> List.fold_left (fn acc x -> acc + x) 47 | 48 | (* 49 | Piping is the most natural way of expressing many problems - and it's always optimized away. 50 | In fact, in cases like the above, it's often possible for the entire expression to be compiled down to a single loop! 51 | *) 52 | 53 | ``` 54 | Lazy list/Stream operations 55 | ```ocaml 56 | import List 57 | import Stream 58 | 59 | fun streaming_add_two (l: List Int): Stream Int = 60 | l 61 | |> Stream.from 62 | |> Stream.map (fn x -> x + 2) 63 | ``` 64 | Traits: 65 | ```ocaml 66 | trait Show a = 67 | fun show : a -> String 68 | end 69 | 70 | impl Show Int = 71 | fun show (x: Int): String = 72 | int_to_string x 73 | end 74 | 75 | fun two_ints_to_strings (x: Int) (y: Int): (String, String) = 76 | (show x, show y) 77 | 78 | (* Trait object, too: *) 79 | 80 | fun trait_object (t: dyn Show): String = show t 81 | fun returns_trait_object (): dyn Show = dyn 10 (* we use dyn in both type position, and to create a trait object *) 82 | ``` 83 | 84 | 85 | 86 | ## Goals: 87 | - Simple, but expressive, with a core featureset encompassing no more than: 88 | - Algebraic Data Types (rust's `enum`) 89 | - Easy to use records 90 | - Pattern matching 91 | - Simplified traits/typeclasses 92 | - Easy-to-use controlled local and global mutation 93 | - No inductive lists by default 94 | - Native Async capabilities, a-la Erlang and Go 95 | - Optimizations encompassing all the common functional usecases 96 | - A comprehensive (mostly) non-opinionated standard library 97 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # TODO / in progress 2 | 3 | - floating point ops 4 | - shadowing 5 | - ADTS 6 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (executable 4 | (public_name khasmc) 5 | (name khasmc) 6 | (libraries khasmc fmt batteries ppx_deriving) 7 | (modes exe) 8 | (preprocess 9 | (pps ppx_deriving.show)) 10 | (flags 11 | (-warn-error -A -g -annot)) 12 | (ocamlopt_flags 13 | (-g -annot))) 14 | -------------------------------------------------------------------------------- /bin/khasmc.ml: -------------------------------------------------------------------------------- 1 | let () = ignore @@ Khasmc__Main.main () 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.10) 2 | 3 | (name khasmc) 4 | 5 | (generate_opam_files true) 6 | 7 | (authors "wren") 8 | 9 | (maintainers "wren") 10 | 11 | (license MPL-2.0) 12 | 13 | (package 14 | (name khasmc) 15 | (synopsis "Compiler for khasm programming language") 16 | (depends ocaml sedlex angstrom dune fmt ppx_deriving batteries fileutils ppx_inline_test) 17 | (tags 18 | ("compiler" "khasm" "programming language"))) 19 | 20 | ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project 21 | 22 | (using menhir 2.1) 23 | -------------------------------------------------------------------------------- /khasmc.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Compiler for khasm programming language" 4 | maintainer: ["wren"] 5 | authors: ["wren"] 6 | license: "MPL-2.0" 7 | tags: ["compiler" "khasm" "programming language"] 8 | depends: [ 9 | "ocaml" 10 | "angstrom" 11 | "dune" {>= "3.10"} 12 | "fmt" 13 | "ppx_deriving" 14 | "batteries" 15 | "fileutils" 16 | "ppx_inline_test" 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (library 4 | (public_name khasmc) 5 | (name khasmc) 6 | (libraries angstrom sedlex fmt batteries ppx_deriving) 7 | (preprocess 8 | (pps ppx_deriving.show sedlex.ppx)) 9 | (flags 10 | (-warn-error -A -g -annot)) 11 | (ocamlopt_flags 12 | (-g -annot))) 13 | -------------------------------------------------------------------------------- /lib/frontend/ast.ml: -------------------------------------------------------------------------------- 1 | open Share.Uuid 2 | open Share.Maybe 3 | 4 | (* ideally these would be newtypes, but ocaml doesn't have those *) 5 | type resolved = R of string [@@deriving show { with_path = false }] 6 | 7 | let fresh_resolved = 8 | let i = ref (-10) in 9 | fun () -> 10 | decr i; 11 | R (string_of_int !i) 12 | 13 | type unresolved = U of string 14 | [@@deriving show { with_path = false }] 15 | 16 | (* the long and short here is that we index 17 | stuff by identifier type, for ease of figuruing out 18 | whether something is resolved, unresolved, whatever 19 | *) 20 | 21 | type 'a meta = 22 | | Unresolved 23 | | Resolved of 'a typ 24 | [@@deriving show { with_path = false }] 25 | 26 | and 'a typ = 27 | | TyInt 28 | | TyString 29 | | TyChar 30 | | TyFloat 31 | | TyBool 32 | | TyTuple of 'a typ list 33 | | TyArrow of 'a typ * 'a typ 34 | | TyPoly of 'a 35 | | TyCustom of 'a * 'a typ list 36 | | TyAssoc of 'a trait_bound * 'a (* ::B *) 37 | | TyRef of 'a typ (* mutability shock horror *) 38 | | TyMeta of 'a meta ref 39 | [@@deriving show { with_path = false }] 40 | 41 | and 'a field = 'a * 'a typ [@@deriving show { with_path = false }] 42 | 43 | and 'a trait_bound = 44 | uuid 45 | * 'a 46 | (* unique id, trait name*) 47 | * ('a * 'a typ) list (* args *) 48 | * ('a * 'a typ) list (* assocs *) 49 | [@@deriving show { with_path = false }] 50 | 51 | let do_within_trait_bound (fn : 'a typ -> 'a typ) (t : 'a trait_bound) 52 | : 'a trait_bound = 53 | let uuid, name, args, assoc = t in 54 | let snd_f (a, b) = (a, fn b) in 55 | (uuid, name, List.map snd_f args, List.map snd_f assoc) 56 | 57 | let do_within_trait_bound' (fn : 'a typ -> 'b) (t : 'a trait_bound) : 58 | 'b list = 59 | let uuid, name, args, assoc = t in 60 | List.map (fun x -> fn (snd x)) args 61 | @ List.map (fun x -> fn (snd x)) assoc 62 | 63 | let do_within_trait_bound'2 (fn : 'a typ -> 'a typ -> 'b) q w : 64 | 'b list = 65 | let uuid, name, args1, assoc1 = q in 66 | let uuid, name, args2, assoc2 = w in 67 | List.map2 (fun x y -> fn (snd x) (snd y)) args1 args2 68 | @ List.map2 (fun x y -> fn (snd x) (snd y)) assoc1 assoc2 69 | 70 | let rec regeneralize (nw : unit -> 'a) (ty : 'a typ) = 71 | let f = regeneralize nw in 72 | match ty with 73 | | TyTuple t -> TyTuple (List.map f t) 74 | | TyArrow (a, b) -> TyArrow (f a, f b) 75 | | TyCustom (c, t) -> TyCustom (c, List.map f t) 76 | | TyAssoc (trt, a) -> TyAssoc (do_within_trait_bound f trt, a) 77 | | TyRef r -> TyRef (f r) 78 | | TyMeta m -> 79 | TyMeta 80 | (ref 81 | begin 82 | match !m with 83 | | Resolved m -> Resolved m 84 | | Unresolved -> 85 | m := Resolved (TyPoly (nw ())); 86 | Resolved (TyMeta m) 87 | end) 88 | | _ -> ty 89 | 90 | let rec force (t : 'a typ) : 'a typ = 91 | match (t : 'a typ) with 92 | | TyTuple t -> TyTuple (List.map force t) 93 | | TyArrow (a, b) -> TyArrow (force a, force b) 94 | | TyCustom (a, b) -> TyCustom (a, List.map force b) 95 | | TyRef a -> TyRef (force a) 96 | | TyMeta m -> begin 97 | match !m with Unresolved -> t | Resolved t -> force t 98 | end 99 | | TyAssoc (bd, a) -> TyAssoc (do_within_trait_bound force bd, a) 100 | | _ -> t 101 | 102 | type ptr = int64 103 | 104 | let ptr_of (x : 'a) : ptr = 105 | (* SEGFAULTS IF CALLED ON AN INT *) 106 | if Obj.is_int (Obj.repr x) then 107 | failwith "ptr_of integer" 108 | else 109 | Obj.magic x 110 | 111 | let get_polys t = 112 | let rec g t = 113 | match force t with 114 | | TyTuple t -> List.map g t |> List.flatten 115 | | TyArrow (a, b) -> g a @ g b 116 | | TyCustom (_, t) -> List.map g t |> List.flatten 117 | | TyRef r -> g r 118 | | TyPoly a -> [ a ] 119 | | _ -> [] 120 | in 121 | g t 122 | 123 | let rec instantiate (map : ('a * 'a typ) list) (t : 'a typ) : 'a typ = 124 | let f = instantiate map in 125 | match force (t : 'a typ) with 126 | | TyTuple t -> TyTuple (List.map f t) 127 | | TyArrow (a, b) -> TyArrow (f a, f b) 128 | | TyPoly x -> begin 129 | match List.assoc_opt x map with Some n -> n | None -> TyPoly x 130 | end 131 | | TyCustom (x, t) -> TyCustom (x, List.map f t) 132 | | TyRef t -> TyRef (f t) 133 | | _ -> t 134 | 135 | let make_metas polys metas = 136 | List.map 137 | (fun x -> 138 | if not @@ List.mem x polys then 139 | [ (x, TyMeta (ref Unresolved)) ] 140 | else 141 | []) 142 | metas 143 | |> List.flatten 144 | 145 | let to_metas polys t = 146 | let metas = get_polys t in 147 | let map = make_metas polys metas in 148 | instantiate map t 149 | 150 | let to_metas' polys t = 151 | let metas = get_polys t in 152 | let map = make_metas polys metas in 153 | (instantiate map t, map) 154 | 155 | let rec back_to_polys gen t = 156 | let f = back_to_polys gen in 157 | match force t with 158 | | TyTuple t -> TyTuple (List.map f t) 159 | | TyArrow (q, w) -> TyArrow (f q, f w) 160 | | TyCustom (x, t) -> TyCustom (x, List.map f t) 161 | | TyRef t -> TyRef (f t) 162 | | TyMeta m -> begin 163 | match !m with 164 | | Resolved _ -> failwith "impossible" 165 | | Unresolved -> 166 | m := Resolved (TyPoly (gen ())); 167 | t 168 | end 169 | | t -> t 170 | 171 | let rec subst_polys (map : ('a * 'a typ) list) (x : 'a typ) : 'a typ = 172 | let f = subst_polys map in 173 | match force (x : 'a typ) with 174 | | TyTuple t -> TyTuple (List.map f t) 175 | | TyArrow (a, b) -> TyArrow (f a, f b) 176 | | TyPoly k -> begin 177 | match List.assoc_opt k map with Some t -> t | None -> x 178 | end 179 | | TyCustom (a, bnd) -> TyCustom (a, List.map f bnd) 180 | | TyAssoc (bnd, a) -> TyAssoc (do_within_trait_bound f bnd, a) 181 | | TyRef r -> TyRef (f r) 182 | | TyMeta m -> x 183 | | _ -> x 184 | 185 | let rec match_polys bef aft : 'a list = 186 | match (force bef, force aft) with 187 | | a, b when a = b -> [] 188 | | TyTuple a, TyTuple b -> List.flatten (List.map2 match_polys a b) 189 | | TyArrow (a, b), TyArrow (q, w) -> 190 | match_polys a q @ match_polys b w 191 | | TyCustom (_, xs), TyCustom (_, ys) -> 192 | (* we assume it's all correct *) 193 | List.flatten (List.map2 match_polys xs ys) 194 | | TyAssoc (a, _), TyAssoc (b, _) -> 195 | List.flatten (do_within_trait_bound'2 match_polys a b) 196 | | TyRef a, TyRef b -> match_polys a b 197 | | TyPoly a, b | b, TyPoly a -> [ (a, b) ] 198 | | a, b -> 199 | print_endline (show_typ pp_resolved a); 200 | print_endline (show_typ pp_resolved b); 201 | failwith "match_polys bad" 202 | 203 | type literal = 204 | | LBool of bool 205 | | LInt of string 206 | [@@deriving show { with_path = false }] 207 | 208 | type 'a case = 209 | | CaseVar of 'a 210 | | CaseTuple of 'a case list 211 | | CaseCtor of 'a * 'a case list 212 | | CaseLit of literal 213 | [@@deriving show { with_path = false }] 214 | 215 | type data = { 216 | uuid : uuid; 217 | mutable counter : int; 218 | (* file line col *) 219 | span : (string * int * int) option; 220 | } 221 | [@@deriving show { with_path = false }] 222 | 223 | let data () = { uuid = Share.Uuid.uuid (); counter = 0; span = None } 224 | 225 | type binop = 226 | | Add 227 | | Sub 228 | | Mul 229 | | Div 230 | | LAnd 231 | | LOr 232 | | Eq 233 | [@@deriving show { with_path = false }] 234 | 235 | type 'a expr = 236 | | Var of data * 'a 237 | (* For monomorphization 238 | Arguably this should warrant another AST but I don't think 239 | that's really needed 240 | *) 241 | | MGlobal of data * uuid 242 | | MLocal of data * 'a 243 | | Int of data * string 244 | | String of data * string 245 | | Char of data * string 246 | | Float of data * string 247 | | Bool of data * bool 248 | | LetIn of data * 'a case * 'a typ option * 'a expr * 'a expr 249 | | Seq of data * 'a expr * 'a expr 250 | | Funccall of data * 'a expr * 'a expr 251 | | Binop of data * binop * 'a expr * 'a expr 252 | | Lambda of data * 'a * 'a typ option * 'a expr 253 | | Tuple of data * 'a expr list 254 | | Annot of data * 'a expr * 'a typ 255 | | Match of data * 'a expr * ('a case * 'a expr) list 256 | | Project of data * 'a expr * int 257 | | Ref of data * 'a expr 258 | | Modify of data * 'a * 'a expr 259 | | Record of data * 'a * ('a * 'a expr) list 260 | [@@deriving show { with_path = false }] 261 | 262 | let get_uuid (e : 'a expr) : uuid = 263 | match e with 264 | | MLocal (i, _) 265 | | MGlobal (i, _) 266 | | Var (i, _) 267 | | Int (i, _) 268 | | String (i, _) 269 | | Char (i, _) 270 | | Float (i, _) 271 | | Bool (i, _) 272 | | LetIn (i, _, _, _, _) 273 | | Seq (i, _, _) 274 | | Funccall (i, _, _) 275 | | Binop (i, _, _, _) 276 | | Lambda (i, _, _, _) 277 | | Tuple (i, _) 278 | | Annot (i, _, _) 279 | | Match (i, _, _) 280 | | Project (i, _, _) 281 | | Ref (i, _) 282 | | Modify (i, _, _) 283 | | Record (i, _, _) -> 284 | i.uuid 285 | 286 | let data_transform f expr = 287 | let rec go e = 288 | match e with 289 | | MLocal (d, s) -> MLocal (f d, s) 290 | | MGlobal (d, p) -> MGlobal (f d, p) 291 | | Var (i, s) -> Var (f i, s) 292 | | Int (i, s) -> Int (f i, s) 293 | | String (i, s) -> String (f i, s) 294 | | Char (i, s) -> Char (f i, s) 295 | | Float (i, s) -> Float (f i, s) 296 | | Bool (i, s) -> Bool (f i, s) 297 | | LetIn (i, c, ty, e1, e2) -> LetIn (f i, c, ty, go e1, go e2) 298 | | Seq (i, a, b) -> Seq (f i, go a, go b) 299 | | Funccall (i, a, b) -> Funccall (f i, go a, go b) 300 | | Binop (i, b, e1, e2) -> Binop (f i, b, go e1, go e2) 301 | | Lambda (i, nm, t, e) -> Lambda (f i, nm, t, go e) 302 | | Tuple (i, s) -> Tuple (f i, List.map go s) 303 | | Annot (i, e, t) -> Annot (f i, go e, t) 304 | | Match (i, e, cs) -> 305 | Match (f i, go e, List.map (fun (b, a) -> (b, go a)) cs) 306 | | Project (i, e, k) -> Project (f i, go e, k) 307 | | Ref (i, e) -> Ref (f i, e) 308 | | Modify (i, a, e) -> Modify (f i, a, go e) 309 | | Record (i, a, cs) -> 310 | Record (i, a, List.map (fun (a, b) -> (a, go b)) cs) 311 | in 312 | go expr 313 | 314 | let expr_set_uuid_version v expr = 315 | let f d = { d with uuid = Share.Uuid.uuid_set_version v d.uuid } in 316 | data_transform f expr 317 | 318 | type 'a typdef_case = 319 | | Record of 'a field list 320 | | Sum of ('a * 'a typ list) list 321 | [@@deriving show { with_path = false }] 322 | 323 | let rec typ_list_to_typ (t : 'a typ list) : 'a typ = 324 | match t with 325 | | [] -> failwith "empty typ" 326 | | [ x ] -> x 327 | | x :: xs -> TyArrow (x, typ_list_to_typ xs) 328 | 329 | (* TODO: support GADTs*) 330 | type 'a typdef = { 331 | data : data; 332 | name : 'a; 333 | args : 'a list; 334 | content : 'a typdef_case; 335 | } 336 | [@@deriving show { with_path = false }] 337 | 338 | let typdef_and_ctor_to_typ (t : 'a typdef) (i : 'a) : 'a typ = 339 | match t.content with 340 | | Record _ -> failwith "shouldn't be record" 341 | | Sum s -> 342 | let ctor = List.assoc i s in 343 | let custom = 344 | TyCustom (t.name, List.map (fun x -> TyPoly x) t.args) 345 | in 346 | typ_list_to_typ (ctor @ [ custom ]) 347 | 348 | type ('a, 'p) definition = { 349 | data : data; 350 | name : 'a; 351 | typeargs : 'a list; 352 | args : ('a * 'a typ) list; 353 | bounds : 'a trait_bound list; 354 | return : 'a typ; 355 | (* essentially for cross-compatibility with other structures *) 356 | body : ('a expr, 'p) maybe; 357 | } 358 | [@@deriving show { with_path = false }] 359 | 360 | let forget_body : ('a, yes) definition -> ('a, no) definition = 361 | fun x -> { x with body = Nothing } 362 | 363 | type 'a trait = { 364 | data : data; 365 | name : 'a; 366 | args : 'a list; 367 | assocs : 'a list; 368 | requirements : 'a trait_bound list; 369 | functions : ('a, no) definition list; 370 | } 371 | [@@deriving show { with_path = false }] 372 | 373 | type 'a impl = { 374 | (* TODO: support stuff of the form impl T*) 375 | data : data; 376 | parent : 'a; 377 | args : ('a * 'a typ) list; 378 | assocs : ('a * 'a typ) list; 379 | (* we give each impl function a unique id alongside it's 380 | name predefined from the trait 381 | *) 382 | impls : (uuid * ('a, yes) definition) list; 383 | } 384 | [@@deriving show { with_path = false }] 385 | 386 | let definition_type (type a) (d : ('a, a) definition) : 'a typ = 387 | List.fold_right 388 | (fun (_, ty) acc -> TyArrow (ty, acc)) 389 | d.args d.return 390 | 391 | type 'a toplevel = 392 | | Typdef of 'a typdef 393 | | Trait of 'a trait 394 | | Impl of 'a impl 395 | | Definition of ('a, yes) definition 396 | [@@deriving show { with_path = false }] 397 | -------------------------------------------------------------------------------- /lib/frontend/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Ast 4 | 5 | } -------------------------------------------------------------------------------- /lib/frontend/parser.ml: -------------------------------------------------------------------------------- 1 | [@@@ocaml.warning "-8-28-26"] 2 | 3 | open Token 4 | open Share.Uuid 5 | open Share.Maybe 6 | open Ast 7 | 8 | let data' () : data = { uuid = uuid (); counter = 0; span = None } 9 | 10 | let lexer buf = 11 | let rec go acc = 12 | match lexer_ buf with 13 | | Ok DONE -> List.rev (DONE :: acc) 14 | | Ok s -> go (s :: acc) 15 | | Error e -> List.rev acc 16 | in 17 | go [] 18 | 19 | let next buf = 20 | match !buf with 21 | | x :: xs -> 22 | buf := xs; 23 | x 24 | | [] -> failwith "next on empty buffer" 25 | 26 | let next' buf = ignore (next buf) 27 | 28 | let peek buf = 29 | match !buf with 30 | | x :: xs -> x 31 | | [] -> failwith "peek on empty buffer" 32 | 33 | let peek2 buf = 34 | match !buf with 35 | | x :: y :: xs -> y 36 | | _ -> failwith "peek2 on emptyish buffer" 37 | 38 | exception ParseError 39 | 40 | let expect tok buf = 41 | match next buf with 42 | | s when s = tok -> () 43 | | s -> 44 | print_endline "expect failed"; 45 | print_endline ("wanted: " ^ show_t_TOKEN tok); 46 | print_endline ("got: " ^ show_t_TOKEN s); 47 | raise ParseError 48 | 49 | let prec x = 50 | match x with 51 | | PLUS | MINUS -> 20 52 | | STAR | FSLASH -> 30 53 | | AND | PIPE -> 10 54 | | EQUALS -> 0 55 | | _ -> -1 56 | 57 | let to_binop x = 58 | match x with 59 | | PLUS -> Add 60 | | MINUS -> Sub 61 | | STAR -> Mul 62 | | FSLASH -> Div 63 | | AND -> LAnd 64 | | PIPE -> LOr 65 | | EQUALS -> Eq 66 | | _ -> failwith "to_binop failed" 67 | 68 | let rec type' buf = 69 | let start = 70 | match next buf with 71 | | LEFTP -> begin 72 | match peek buf with 73 | | RIGHTP -> 74 | next' buf; 75 | TyTuple [] 76 | | _ -> 77 | let s = type' buf in 78 | begin 79 | match next buf with 80 | | RIGHTP -> s 81 | | COMMA -> 82 | (* tuple *) 83 | let rec go () = 84 | let s = type' buf in 85 | match next buf with 86 | | RIGHTP -> [] 87 | | COMMA -> s :: go () 88 | in 89 | TyTuple (s :: go ()) 90 | end 91 | end 92 | | TYINT -> TyInt 93 | | TYSTRING -> TyString 94 | | TYCHAR -> TyChar 95 | | TYFLOAT -> TyFloat 96 | | POLYID s -> TyPoly s 97 | | REF -> TyRef (type' buf) 98 | | TYPEID s -> begin 99 | match peek buf with 100 | | TYPEID _ | POLYID _ | LEFTP _ -> 101 | (* custom with args *) 102 | failwith "args" 103 | | _ -> failwith "no args" 104 | end 105 | | _ -> failwith "other type weirdness" 106 | in 107 | match peek buf with 108 | | ARROW -> 109 | next' buf; 110 | let rest = type' buf in 111 | TyArrow (start, rest) 112 | | _ -> start 113 | 114 | let rec case' buf = 115 | match next buf with 116 | | ID s -> 117 | (* maybe custom, maybe not *) 118 | let rec handle () = 119 | begin 120 | match peek buf with 121 | | LEFTP -> 122 | (* subexpr *) 123 | next' buf; 124 | let sub = case' buf in 125 | expect RIGHTP buf; 126 | sub :: handle () 127 | | ID s -> 128 | (* subvar *) 129 | next' buf; 130 | CaseVar s :: handle () 131 | | _ -> 132 | (* not any of that *) 133 | [] 134 | end 135 | in 136 | begin 137 | match handle () with [] -> CaseVar s | xs -> CaseCtor (s, xs) 138 | end 139 | | LEFTP -> 140 | (* tuple or abbrev *) 141 | failwith "tuple" 142 | | _ -> failwith "huh?" 143 | 144 | module Expr = struct 145 | let ( let* ) = Option.bind 146 | 147 | let ( let+ ) x f = 148 | match x with 149 | | None -> 150 | print_endline "let+ None"; 151 | raise ParseError 152 | | Some s -> f s 153 | 154 | let some x = Some x 155 | 156 | let rec expr curr curr_prec buf = 157 | let t = peek buf in 158 | match prec t with 159 | | -1 -> 160 | (* no valid operator char - maybe application? *) 161 | (* must be a current for this to be true *) 162 | begin 163 | match expr_small buf with 164 | | None -> 165 | (* not application *) 166 | some curr 167 | | Some s -> 168 | (* yes application *) 169 | let rec do_app () = 170 | match expr_small buf with 171 | | None -> [] 172 | | Some s -> s :: do_app () 173 | in 174 | let rest = do_app () |> List.rev in 175 | let orig = Funccall (data' (), curr, s) in 176 | some 177 | (List.fold_right 178 | (fun acc x -> Funccall (data' (), x, acc)) 179 | rest orig) 180 | end 181 | | prec -> 182 | if prec < curr_prec then 183 | some curr 184 | else begin 185 | next' buf; 186 | let* rhs = expr' prec buf in 187 | let c = Binop (data' (), to_binop t, curr, rhs) in 188 | expr c curr_prec buf 189 | end 190 | 191 | and expr' curr_prec buf = 192 | let* curr = expr_small buf in 193 | expr curr curr_prec buf 194 | 195 | and expr_small buf = 196 | let exception NoValid in 197 | try 198 | begin 199 | match peek buf with 200 | | LEFTP -> 201 | next' buf; 202 | let* e = expr' 0 buf in 203 | expect RIGHTP buf; 204 | some e 205 | | ID i -> 206 | next' buf; 207 | some @@ Var (data' (), i) 208 | | INT i -> 209 | next' buf; 210 | some @@ Int (data' (), i) 211 | | FLOAT i -> 212 | next' buf; 213 | some @@ Float (data' (), i) 214 | | STRING i -> 215 | next' buf; 216 | some @@ String (data' (), i) 217 | | BOOL b -> 218 | next' buf; 219 | some @@ Bool (data' (), b) 220 | | LET -> begin 221 | next' buf; 222 | let case = case' buf in 223 | let ty = 224 | match next buf with 225 | | COLON -> 226 | let ty = type' buf in 227 | expect EQUALS buf; 228 | Some ty 229 | | EQUALS -> None 230 | in 231 | let+ expr'' = expr' 0 buf in 232 | expect IN buf; 233 | let+ body = expr' 0 buf in 234 | some @@ LetIn (data' (), case, ty, expr'', body) 235 | end 236 | | IF -> begin 237 | next' buf; 238 | let+ c = expr' 0 buf in 239 | expect THEN buf; 240 | let+ true' = expr' 0 buf in 241 | expect ELSE buf; 242 | let+ false' = expr' 0 buf in 243 | let cases = 244 | [ 245 | (CaseLit (LBool true), true'); 246 | (CaseLit (LBool false), false'); 247 | ] 248 | in 249 | some @@ Match (data' (), c, cases) 250 | end 251 | | _ -> raise NoValid 252 | end 253 | with NoValid -> None 254 | end 255 | 256 | open Expr 257 | 258 | let trait_bound buf : 'a trait_bound = 259 | let (TYPEID s) = next buf in 260 | let rec getlist () = 261 | match peek buf with 262 | | LEFTP -> 263 | next' buf; 264 | let (POLYID main) = next buf in 265 | let ty = type' buf in 266 | expect RIGHTP buf; 267 | (main, ty) :: getlist () 268 | | _ -> [] 269 | in 270 | let a = getlist () in 271 | expect SEMICOLON buf; 272 | let b = getlist () in 273 | (uuid (), s, a, b) 274 | 275 | let definition_up_to_body buf = 276 | begin 277 | match peek buf with FUN -> next' buf | _ -> () 278 | end; 279 | let (ID name) = next buf in 280 | let targs = 281 | match peek buf with 282 | | LEFTC -> begin 283 | match peek2 buf with 284 | | TYPE -> 285 | next' buf; 286 | next' buf; 287 | let rec go () = 288 | match next buf with 289 | | POLYID t -> t :: go () 290 | | RIGHTC -> [] 291 | | t -> 292 | print_endline (show_t_TOKEN t); 293 | failwith "parsing type list weird" 294 | in 295 | Some (go ()) 296 | | _ -> None 297 | end 298 | | _ -> None 299 | in 300 | let targs = match targs with Some xs -> xs | None -> [] in 301 | let bounds = 302 | let rec go () = 303 | match peek buf with 304 | | LEFTC -> 305 | next' buf; 306 | let b = trait_bound buf in 307 | let RIGHTC = next buf in 308 | b :: go () 309 | | _ -> [] 310 | in 311 | go () 312 | in 313 | let arg_list = 314 | let rec go () = 315 | match peek buf with 316 | | LEFTP -> 317 | next' buf; 318 | let (ID argnm) = next buf in 319 | let COLON = next buf in 320 | let typ = type' buf in 321 | let RIGHTP = next buf in 322 | (argnm, typ) :: go () 323 | | _ -> [] 324 | in 325 | go () 326 | in 327 | expect COLON buf; 328 | let ret = type' buf in 329 | { 330 | data = data' (); 331 | name; 332 | typeargs = targs; 333 | args = arg_list; 334 | bounds; 335 | return = ret; 336 | body = Nothing; 337 | } 338 | 339 | let rec toplevel' buf = 340 | match next buf with 341 | | FUN -> begin 342 | let definition_main = definition_up_to_body buf in 343 | let EQUALS = next buf in 344 | let+ body = expr' 0 buf in 345 | let data = data' () in 346 | let res = 347 | Definition { definition_main with body = Just body } 348 | in 349 | res :: toplevel' buf 350 | end 351 | | TRAIT -> 352 | let (TYPEID name) = next buf in 353 | let rec list () = 354 | match peek buf with 355 | | POLYID p -> 356 | next' buf; 357 | p :: list () 358 | | _ -> [] 359 | in 360 | let args = list () in 361 | let assocs = 362 | match next buf with 363 | | SEMICOLON -> 364 | let a = list () in 365 | expect EQUALS buf; 366 | a 367 | | EQUALS -> [] 368 | | _ -> failwith "trait what is this" 369 | in 370 | let requirements = 371 | let rec go () = 372 | match peek buf with 373 | | LEFTP -> 374 | next' buf; 375 | let req = trait_bound buf in 376 | expect RIGHTP buf; 377 | req :: go () 378 | | _ -> [] 379 | in 380 | go () 381 | in 382 | let rec go () = 383 | match peek buf with 384 | | END -> 385 | next' buf; 386 | [] 387 | | _ -> 388 | let def = definition_up_to_body buf in 389 | def :: go () 390 | in 391 | let defs = go () in 392 | Trait 393 | { 394 | data = data' (); 395 | name; 396 | args; 397 | assocs; 398 | requirements; 399 | functions = defs; 400 | } 401 | :: toplevel' buf 402 | | IMPL -> 403 | let (TYPEID name) = next buf in 404 | let rec list () = 405 | match peek buf with 406 | | LEFTP -> 407 | next' buf; 408 | let (POLYID p) = next buf in 409 | let ty = type' buf in 410 | expect RIGHTP buf; 411 | (p, ty) :: list () 412 | | _ -> [] 413 | in 414 | let args = list () in 415 | let assocs = 416 | match next buf with 417 | | SEMICOLON -> 418 | let s = list () in 419 | expect EQUALS buf; 420 | s 421 | | EQUALS -> [] 422 | in 423 | let rec go () = 424 | match next buf with 425 | | FUN -> 426 | let (INT i) = next buf in 427 | let def = definition_up_to_body buf in 428 | expect EQUALS buf; 429 | let+ body = expr' 0 buf in 430 | (UUID (int_of_string i, 0), { def with body = Just body }) 431 | :: go () 432 | | END -> [] 433 | in 434 | let funs = go () in 435 | Impl 436 | { data = data' (); parent = name; args; assocs; impls = funs } 437 | :: toplevel' buf 438 | | DONE -> [] 439 | | t -> 440 | print_endline (show_t_TOKEN t); 441 | failwith "anything other than definition" 442 | 443 | let toplevel buf = 444 | let toks = ref (lexer buf) in 445 | (* 446 | List.iter (fun x -> print_string (show_t_TOKEN x ^ " ")) !toks; 447 | print_newline (); 448 | *) 449 | try 450 | let t = toplevel' toks in 451 | Ok t 452 | with exc -> 453 | print_endline (Printexc.to_string exc); 454 | print_endline "next ten tokens:"; 455 | for i = 0 to 10 do 456 | print_string (show_t_TOKEN (next toks) ^ " ") 457 | done; 458 | failwith "parser error" 459 | -------------------------------------------------------------------------------- /lib/frontend/token.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | 3 | type t_TOKEN = 4 | | LEFTP 5 | | RIGHTP 6 | | LEFTC 7 | | RIGHTC 8 | | GT 9 | | LT 10 | | DOLLAR 11 | | HASH 12 | | AT 13 | | STAR 14 | | BANG 15 | | PERCENT 16 | | PLUS 17 | | MINUS 18 | | AND 19 | | PIPE 20 | | COMMA 21 | | SEMICOLON 22 | | COLON 23 | | EQUALS 24 | | FSLASH 25 | | BSLASH 26 | | TYPE 27 | | TRAIT 28 | | REF 29 | | WHERE 30 | | LET 31 | | IN 32 | | AS 33 | | ARROW 34 | | TYINT 35 | | TYSTRING 36 | | TYCHAR 37 | | TYFLOAT 38 | | TYBOOL 39 | | IMPL 40 | | MODULE 41 | | END 42 | | MATCH 43 | | FUN 44 | | IF 45 | | THEN 46 | | ELSE 47 | | BOOL of bool 48 | | STRING of string 49 | | ID of resolved 50 | | TYPEID of resolved 51 | | POLYID of resolved 52 | | INT of string 53 | | FLOAT of string 54 | | DONE 55 | | OTHER of string 56 | [@@deriving show { with_path = false }] 57 | 58 | let digit = [%sedlex.regexp? '0' .. '9'] 59 | let num = [%sedlex.regexp? Plus digit] 60 | let id = [%sedlex.regexp? ll, Star (ll | digit)] 61 | let tid = [%sedlex.regexp? lu, Plus (ll | lu)] 62 | let polyid = [%sedlex.regexp? '\'', id] 63 | let space = [%sedlex.regexp? Plus (zs | cc)] 64 | let char = [%sedlex.regexp? Compl '"'] 65 | let string = [%sedlex.regexp? '"', Star char, '"'] 66 | let float = [%sedlex.regexp? num, '.', num] 67 | 68 | let rec lexer_ buf : (t_TOKEN, exn) Result.t = 69 | match 70 | begin 71 | match%sedlex buf with space -> () | _ -> () 72 | end; 73 | begin 74 | match%sedlex buf with 75 | | '(' -> LEFTP 76 | | ')' -> RIGHTP 77 | | '{' -> LEFTC 78 | | '}' -> RIGHTC 79 | | '>' -> GT 80 | | '<' -> LT 81 | | '$' -> DOLLAR 82 | | '#' -> HASH 83 | | '@' -> AT 84 | | '!' -> BANG 85 | | '*' -> STAR 86 | | '%' -> PERCENT 87 | | '+' -> PLUS 88 | | '-' -> MINUS 89 | | '&' -> AND 90 | | '|' -> PIPE 91 | | ',' -> COMMA 92 | | ';' -> SEMICOLON 93 | | ':' -> COLON 94 | | '/' -> FSLASH 95 | | '\\' -> BSLASH 96 | | '=' -> EQUALS 97 | | "type" -> TYPE 98 | | "trait" -> TRAIT 99 | | "ref" -> REF 100 | | "where" -> WHERE 101 | | "let" -> LET 102 | | "in" -> IN 103 | | "as" -> AS 104 | | "->" -> ARROW 105 | | "Int" -> TYINT 106 | | "String" -> TYSTRING 107 | | "Char" -> TYCHAR 108 | | "Float64" -> TYFLOAT 109 | | "Bool" -> TYBOOL 110 | | "impl" -> IMPL 111 | | "module" -> MODULE 112 | | "end" -> END 113 | | "match" -> MATCH 114 | | "fun" -> FUN 115 | | "if" -> IF 116 | | "then" -> THEN 117 | | "else" -> ELSE 118 | | "true" -> BOOL true 119 | | "false" -> BOOL false 120 | | string -> 121 | let str = Sedlexing.Utf8.lexeme buf in 122 | let str' = String.sub str 1 (String.length str - 2) in 123 | STRING str' 124 | | id -> ID (R (Sedlexing.Utf8.lexeme buf)) 125 | | tid -> TYPEID (R (Sedlexing.Utf8.lexeme buf)) 126 | | polyid -> POLYID (R (Sedlexing.Utf8.lexeme buf)) 127 | | num -> INT (Sedlexing.Utf8.lexeme buf) 128 | | float -> FLOAT (Sedlexing.Utf8.lexeme buf) 129 | | eof -> DONE 130 | | any -> failwith (Sedlexing.Utf8.lexeme buf) 131 | | _ -> failwith "IMPOSSIBLE" 132 | end 133 | with 134 | | s -> Ok s 135 | | exception e -> 136 | print_endline "ERROR!"; 137 | print_endline (Printexc.to_string e); 138 | Error e 139 | -------------------------------------------------------------------------------- /lib/frontend/trait_resolution.ml: -------------------------------------------------------------------------------- 1 | open Typecheck 2 | open Ast 3 | open Share.Uuid 4 | open Share.Result 5 | open Share.Maybe 6 | open Unify 7 | 8 | let zipby (l1 : ('a * 'b) list) (l2 : ('a * 'c) list) : 9 | (('b * 'c) list, string) result = 10 | if List.length l1 <> List.length l2 then 11 | err "lengths not equal zipby" 12 | else 13 | let h (a, _) (b, _) = compare a b in 14 | let l1 = List.sort h l1 in 15 | let l2 = List.sort h l2 in 16 | let rec go l1 l2 = 17 | match (l1, l2) with 18 | | (x, a) :: xs, (y, b) :: ys when x = y -> 19 | let* rest = go xs ys in 20 | ok @@ ((a, b) :: rest) 21 | | [], [] -> ok [] 22 | | _ :: _, [] | [], _ :: _ -> failwith "impossible" 23 | | _ -> err "keys/vals don't match up zipby" 24 | in 25 | go l1 l2 26 | 27 | type resolved_by = 28 | | Global of resolved impl 29 | | Local of resolved trait_bound (* trait bound *) 30 | [@@deriving show { with_path = false }] 31 | 32 | type ctx = { 33 | (* traits *) 34 | traits : resolved trait list; 35 | (* method / trait with method *) 36 | methods : (resolved * resolved trait) list; 37 | (* impls *) 38 | impls : resolved_by list; 39 | (* any local polys (needed?) *) 40 | local_polys : resolved list; 41 | (* functions with trait bounds *) 42 | has_bounds : (resolved * resolved trait_bound list) list; 43 | } 44 | [@@deriving show { with_path = false }] 45 | 46 | let has_bounds ctx id = List.assoc_opt id ctx.has_bounds 47 | 48 | let impls_by_trait (c : ctx) (i : resolved trait) : resolved_by list = 49 | List.filter 50 | (fun t -> 51 | match t with 52 | | Global g -> g.parent = i.name 53 | | Local (_, id, _, _) -> id = i.name) 54 | c.impls 55 | 56 | let build_ctx top = 57 | List.fold_left 58 | (fun acc -> function 59 | | Typdef _ -> acc 60 | | Trait t -> 61 | { 62 | acc with 63 | traits = t :: acc.traits; 64 | methods = 65 | List.map 66 | (fun (a : ('a, 'b) definition) -> (a.name, t)) 67 | t.functions 68 | @ acc.methods; 69 | has_bounds = 70 | (* for each function, we add its required bounds 71 | (as we allow functions to add on extra bounds if 72 | they so wish (TODO: is this valid????)) 73 | 74 | then, we add "itself" as a bound - this way, if 75 | something computes the bounds of, say, show, they 76 | get Show T as the "primary" bound, which is exactly 77 | what we want them to solve for 78 | *) 79 | (let f = List.map (fun x -> (x, TyPoly x)) in 80 | List.map 81 | (fun (a : ('a, 'b) definition) -> 82 | let t : resolved trait_bound = 83 | (uuid (), t.name, f t.args, f t.assocs) 84 | in 85 | (a.name, t :: a.bounds)) 86 | t.functions 87 | @ acc.has_bounds); 88 | } 89 | | Impl i -> { acc with impls = Global i :: acc.impls } 90 | | Definition d -> 91 | if d.bounds = [] then 92 | acc 93 | else 94 | { 95 | acc with 96 | has_bounds = (d.name, d.bounds) :: acc.has_bounds; 97 | }) 98 | { 99 | traits = []; 100 | methods = []; 101 | impls = []; 102 | local_polys = []; 103 | has_bounds = []; 104 | } 105 | top 106 | 107 | type solved = 108 | (* bound solved, how we solved it, all of the "subproblems" *) 109 | | Solution of uuid * resolved_by * solved list 110 | [@@deriving show { with_path = false }] 111 | 112 | (* the allmighty map of uuid -> solved trait bounds *) 113 | let trait_information : (uuid, solved list) Hashtbl.t = 114 | new_by_uuid 100 115 | 116 | let rec search_impls (ctx : ctx) (want : 'a trait_bound) : 117 | (solved, string) result = 118 | (* this function searches the context, trying to find a valid 119 | impl for some given trait bound 120 | *) 121 | let unique, name, args, assocs = want in 122 | let* trait = 123 | List.find_opt (fun (x : 'a trait) -> x.name = name) ctx.traits 124 | |> function 125 | | None -> err @@ "can't find trait " ^ show_resolved name 126 | | Some n -> ok n 127 | in 128 | let* impls = 129 | match impls_by_trait ctx trait with 130 | | [] -> err @@ "can't find impls for " ^ show_resolved name 131 | | xs -> ok xs 132 | in 133 | let rec go xs = 134 | match xs with 135 | | [] -> err "no matching impl found!" 136 | | impl :: xs -> ( 137 | match 138 | let uuid, impl_args, impl_assocs = 139 | match impl with 140 | | Global i -> (i.data.uuid, i.args, i.assocs) 141 | | Local (uuid, _, args, assocs) -> (uuid, args, assocs) 142 | in 143 | (* we want to figure out if we can find an 144 | impl that matches the given constraints that we have 145 | *) 146 | let twice f (a, b) = (f a, f b) in 147 | let* args' = zipby args impl_args in 148 | let* assocs' = zipby assocs impl_assocs in 149 | (* force to ensure no "cross influences" (PLACEBO) *) 150 | let args' = List.map (twice force) args' in 151 | let assocs' = List.map (twice force) assocs' in 152 | let get_both_polys (a, b) = get_polys a @ get_polys b in 153 | let all_metas = 154 | ctx.local_polys 155 | @ List.map fst impl_args 156 | @ List.map fst impl_assocs 157 | @ (List.flatten @@ List.map get_both_polys args') 158 | @ List.flatten 159 | @@ List.map get_both_polys assocs' 160 | in 161 | let map = 162 | (* make sure to keep local rigids rigid *) 163 | make_metas ctx.local_polys all_metas 164 | in 165 | (* prematurely solve all of the arguments and assocs 166 | all of these are new metas we just made with make_metas, 167 | so they should all be completely fresh 168 | 169 | if they have a matching type in the set of args, we 170 | eagerly inst that 171 | *) 172 | let args_assocs = impl_args @ impl_assocs in 173 | List.iter 174 | (fun (name, typ) -> 175 | match (List.assoc_opt name args_assocs, force typ) with 176 | (* inst the metas *) 177 | | Some t, TyMeta m -> begin 178 | match !m with 179 | | Resolved _ -> failwith "impossible" 180 | | Unresolved -> 181 | m := Resolved t; 182 | () 183 | end 184 | (* otherwise we're fine *) 185 | | _ -> ()) 186 | map; 187 | (* turn all the polys that aren't rigid into metas *) 188 | let args'inst = List.map (twice (instantiate map)) args' in 189 | let assocs'inst = 190 | List.map (twice (instantiate map)) assocs' 191 | in 192 | (* grab errors *) 193 | let* _ = 194 | List.map (fun (a, b) -> unify_h a b) args'inst 195 | |> collect 196 | |> Result.map_error (String.concat "\n") 197 | in 198 | let* _ = 199 | List.map (fun (a, b) -> unify_h a b) assocs'inst 200 | |> collect 201 | |> Result.map_error (String.concat "\n") 202 | in 203 | (* if we get to here, everything unified nicely, so 204 | we have a match! 205 | 206 | now we need to use the map that we got earlier, 207 | take the trait that we're dealing with, and 208 | find impls for all of the traits that are bounds 209 | for this one 210 | *) 211 | (* also check requirements *) 212 | let trait_subproblems = trait.requirements in 213 | (* make sure to instantiate all of those tyvars *) 214 | let f = List.map (fun (a, b) -> (a, instantiate map b)) in 215 | let subproblems_inst : 'a trait_bound list = 216 | trait_subproblems 217 | |> List.map (fun (u, i, args, assocs) -> 218 | (u, i, f args, f assocs)) 219 | in 220 | (* try all the subproblems *) 221 | let* attempts = 222 | subproblems_inst 223 | |> List.map (search_impls ctx) 224 | |> collect 225 | |> Result.map_error (String.concat "\n") 226 | in 227 | 228 | ok @@ Solution (unique, impl, attempts) 229 | with 230 | | Ok sol -> begin 231 | match go xs with 232 | | Error _ -> ok sol 233 | | Ok _ -> err "multiple solutions! no bueno :(" 234 | end 235 | | Error e -> go xs) 236 | in 237 | let* sol = go impls in 238 | ok sol 239 | 240 | let solve_all_bounds_for (ctx : ctx) (uuid : uuid) (e : resolved) 241 | (bounds : resolved trait_bound list) : (unit, string) result = 242 | (* 243 | So: We know that we're solving for , and that it's part of 244 | trait . We can fetch the type information for , which 245 | we need to do in order to figure out what instance we want to 246 | search for. So, we grab that type info, "match everything up" 247 | via taking the expected type of the function v.s. the trait's 248 | version of the type to generate a set of constraints like so: 249 | 250 | in show 5, show : Int -> String 251 | 252 | but in 253 | trait Show T = 254 | show : T -> String 255 | end 256 | 257 | show : T(bound) -> String 258 | 259 | so we generate T = Int (nothing fancy - just grabbing eagerly) 260 | 261 | and solve for Show String, which then gives us a Solution that 262 | we link to the uuid of the resolved. 263 | *) 264 | let* exp_typ = 265 | match Hashtbl.find_opt raw_type_information e with 266 | | Some s -> Ok (force s) 267 | | None -> Error ("No raw type info found for" ^ show_resolved e) 268 | in 269 | let* real_typ = 270 | match Hashtbl.find_opt type_information uuid with 271 | | Some s -> Ok (force s) 272 | | None -> Error ("No type info found for" ^ show_resolved e) 273 | in 274 | let* trait = 275 | match List.assoc_opt e ctx.methods with 276 | | Some t -> ok t 277 | | None -> Error ("No trait for " ^ show_resolved e) 278 | in 279 | let all_polys = trait.args @ trait.assocs in 280 | let rec go real exp = 281 | match (force real, force exp) with 282 | | a, b when a = b -> [] 283 | | a, TyPoly b when List.mem b all_polys -> [ (b, a) ] 284 | | TyTuple a, TyTuple b -> List.flatten (List.map2 go a b) 285 | | TyArrow (a, b), TyArrow (q, w) -> 286 | (* LHS usually smaller than rhs*) 287 | go a q @ go b w 288 | | TyCustom (_, a), TyCustom (_, b) -> 289 | List.flatten (List.map2 go a b) 290 | | TyAssoc (a, _), TyAssoc (b, _) -> 291 | do_within_trait_bound'2 go a b |> List.flatten 292 | | TyRef a, TyRef b -> go a b 293 | | TyMeta a, TyMeta b when a = b -> [] 294 | | _, _ -> failwith "impossible: solver.go no match" 295 | in 296 | let polys_to_reals = go real_typ exp_typ in 297 | let computed_bounds = 298 | List.map 299 | (do_within_trait_bound (subst_polys polys_to_reals)) 300 | bounds 301 | in 302 | let* solutions = 303 | List.map (search_impls ctx) computed_bounds 304 | |> collect 305 | |> Result.map_error (String.concat "\n") 306 | in 307 | (* add to the allmighty trait information table *) 308 | Hashtbl.replace trait_information uuid solutions; 309 | ok () 310 | 311 | let rec resolve_expr (ctx : ctx) (e : resolved expr) : 312 | (unit, string) result = 313 | match e with 314 | | MLocal _ | MGlobal _ -> 315 | failwith "monomorphization info in trait resolution" 316 | | Var (d, id) -> begin 317 | match has_bounds ctx id with 318 | | Some bounds -> solve_all_bounds_for ctx d.uuid id bounds 319 | | None -> ok () 320 | end 321 | | Int (_, _) -> ok () 322 | | String (_, _) -> ok () 323 | | Char (_, _) -> ok () 324 | | Float (_, _) -> ok () 325 | | Bool (_, _) -> ok () 326 | | LetIn (_data, _case, _ty, head, body) -> 327 | let* _ = resolve_expr ctx head in 328 | let* _ = resolve_expr ctx body in 329 | ok () 330 | | Seq (_, a, b) -> 331 | let* _ = resolve_expr ctx a in 332 | let* _ = resolve_expr ctx b in 333 | ok () 334 | | Funccall (_, a, b) -> 335 | let* _ = resolve_expr ctx a in 336 | let* _ = resolve_expr ctx b in 337 | ok () 338 | | Binop (_, op, a, b) -> 339 | let* _ = resolve_expr ctx a in 340 | let* _ = resolve_expr ctx b in 341 | ok () 342 | | Lambda (_, id, _, e) -> resolve_expr ctx e 343 | | Tuple (_, es) -> 344 | List.map (resolve_expr ctx) es 345 | |> collect 346 | |> Result.map_error (String.concat "\n") 347 | |> Result.map (fun _ -> ()) 348 | | Annot (_, e, _) -> resolve_expr ctx e 349 | | Match (_, _, xs) -> 350 | List.map (fun (c, e) -> resolve_expr ctx e) xs 351 | |> collect 352 | |> Result.map_error (String.concat "\n") 353 | |> Result.map (fun _ -> ()) 354 | | Project (_, e, _) -> resolve_expr ctx e 355 | | Ref (_, r) -> resolve_expr ctx r 356 | | Modify (_, _, e) -> resolve_expr ctx e 357 | | Record (_, _, xs) -> 358 | List.map (fun (c, e) -> resolve_expr ctx e) xs 359 | |> collect 360 | |> Result.map_error (String.concat "\n") 361 | |> Result.map (fun _ -> ()) 362 | 363 | let resolve_definition (ctx : ctx) (d : (resolved, yes) definition) : 364 | (unit, string) result = 365 | (* The most pressing thing we have to deal with 366 | (as all global impls are already in the ctx) 367 | is adding our "local" impls in, so that they can be correctly 368 | resolved & tagged. 369 | 370 | TODO: handle that trait dependencies should be avaliable when 371 | doing resolution 372 | *) 373 | let bounds = d.bounds |> List.map (fun p -> Local p) in 374 | let ctx = 375 | { 376 | ctx with 377 | impls = bounds @ ctx.impls; 378 | local_polys = d.typeargs @ ctx.local_polys; 379 | } 380 | in 381 | resolve_expr ctx (get d.body) 382 | 383 | let resolve_impl (ctx : ctx) (i : resolved impl) : 384 | (unit, string) result = 385 | List.map (fun (a, b) -> resolve_definition ctx b) i.impls 386 | |> collect 387 | |> Result.map_error (String.concat "\n") 388 | |> Result.map (fun _ -> ()) 389 | 390 | let resolve (top : resolved toplevel list) : (unit, string) result = 391 | let ctx = build_ctx top in 392 | let rec go = function 393 | | Definition d -> resolve_definition ctx d 394 | | Impl i -> resolve_impl ctx i 395 | | _ -> ok () 396 | in 397 | List.map go top 398 | |> collect 399 | |> Result.map (fun _ -> ()) 400 | |> Result.map_error (String.concat "\n") 401 | |> function 402 | | Ok () -> 403 | print_endline "resolved :D"; 404 | Ok () 405 | | x -> x 406 | -------------------------------------------------------------------------------- /lib/frontend/typecheck.ml: -------------------------------------------------------------------------------- 1 | open Share.Uuid 2 | open Ast 3 | open Share.Result 4 | open Share.Maybe 5 | open Unify 6 | 7 | let typ_pp t = print_endline (show_typ pp_resolved t) 8 | 9 | (* 10 | ASSUMPTIONS: 11 | this module makes a number of assumptions about the data being 12 | passed into it. these being violated will cause Issues. 13 | 14 | - all pieces of the same information have the same id 15 | - all pieces of unrelated information have seperate ids 16 | 17 | for example, something like this: 18 | 19 | trait Foo { 20 | type b; 21 | fun foo : Self -> b 22 | } 23 | 24 | fun dothing (type T) {T: Foo} (x: T): T.{Foo}.b = foo x 25 | 26 | must be something like 27 | 28 | trait 0 { 29 | type 1; 30 | fun 2 : 0 -> 1 31 | } 32 | 33 | fun 3 (type 4) {4: 0} (5: 4): 4.{0}.1 = 2 5 34 | 35 | *) 36 | 37 | (* 38 | general TODOs: 39 | - add meta refinement 40 | f : ? 41 | x : int 42 | f x 43 | => 44 | f : int -> ? 45 | *) 46 | 47 | type ctx = { 48 | (* name, parent *) 49 | ctors : (resolved * resolved typdef) list; 50 | types : resolved typdef list; 51 | traits : resolved trait list; 52 | traitfuns : (resolved * resolved trait) list; 53 | funs : (resolved * (resolved, no) definition) list; 54 | locals : (resolved * resolved typ) list; 55 | local_polys : resolved list; 56 | } 57 | [@@deriving show { with_path = false }] 58 | 59 | let empty_ctx () = 60 | { 61 | ctors = []; 62 | types = []; 63 | traits = []; 64 | traitfuns = []; 65 | funs = []; 66 | (* magic, for testing *) 67 | locals = 68 | [ (R "magic", TyArrow (TyPoly (R "-1"), TyPoly (R "-2"))) ]; 69 | local_polys = []; 70 | } 71 | 72 | let add_local ctx a t = { ctx with locals = (a, t) :: ctx.locals } 73 | let add_locals ctx t = { ctx with locals = t @ ctx.locals } 74 | 75 | exception Case 76 | exception DoneTy of resolved typ 77 | 78 | let case' (type t) v f = 79 | match v with Some s -> raise @@ DoneTy (f s) | None -> () 80 | 81 | let search (ctx : ctx) (id : resolved) : (resolved typ, string) result 82 | = 83 | try 84 | case' (List.assoc_opt id ctx.locals) (fun t -> t); 85 | 86 | case' (List.assoc_opt id ctx.ctors) (fun t -> 87 | match t.content with 88 | | Record _ -> failwith "shouldn't be variable-ing a record" 89 | | Sum s -> typdef_and_ctor_to_typ t id); 90 | 91 | case' (List.assoc_opt id ctx.funs) (fun d -> definition_type d); 92 | 93 | case' (List.assoc_opt id ctx.traitfuns) (fun t -> 94 | let d = 95 | List.find 96 | (fun (d : ('a, 'b) definition) -> d.name = id) 97 | t.functions 98 | in 99 | definition_type d); 100 | 101 | begin 102 | print_endline "variable not found:"; 103 | print_endline (show_resolved id); 104 | failwith "oops" 105 | end 106 | with DoneTy s -> ok s 107 | 108 | let type_information : (uuid, resolved typ) Hashtbl.t = 109 | new_by_uuid 100 110 | 111 | let add_type uuid typ = Hashtbl.replace type_information uuid typ 112 | 113 | let raw_type_information : (resolved, resolved typ) Hashtbl.t = 114 | Hashtbl.create 100 115 | 116 | let add_raw_type id typ = 117 | Hashtbl.replace raw_type_information id (force typ) 118 | 119 | let rec break_down_case_pattern (ctx : ctx) (c : resolved case) 120 | (t : resolved typ) : 121 | ((resolved * resolved typ) list, string) result = 122 | let break_and_map a b = 123 | List.map2 (break_down_case_pattern ctx) a b 124 | |> collect 125 | |> Result.map List.flatten 126 | |> Result.map_error (String.concat " ") 127 | in 128 | match c with 129 | | CaseLit p -> ok [] 130 | | CaseVar v -> ok [ (v, t) ] 131 | | CaseTuple tu -> begin 132 | match t with 133 | | TyTuple t' -> 134 | (* find all subpatterns *) 135 | break_and_map tu t' 136 | | _ -> err "not tuple but should be tuple :(" 137 | end 138 | | CaseCtor (name, args) -> begin 139 | match t with 140 | (* TODO: this has a bunch of "assertions" in it, mostly around 141 | the fact that it assumes that type arguments are properly 142 | filled in with the righ tnumber of them and whatnot 143 | - that can obviously be false, so fix that 144 | - ie don't use `combine` and `find` mostly 145 | *) 146 | | TyCustom (head, targs) -> 147 | (* find ty*) 148 | begin 149 | match 150 | List.find_opt 151 | (fun (x : 'a typdef) -> x.name = head) 152 | ctx.types 153 | with 154 | | None -> err "can't find type" 155 | | Some ty -> begin 156 | match ty.content with 157 | | Record _ -> failwith "shouldn't be a record (fun?)" 158 | | Sum s -> 159 | (* find constructor *) 160 | begin 161 | match 162 | List.find_opt (fun x -> fst x = name) s 163 | with 164 | | None -> err "can't find ctor" 165 | | Some ctor -> 166 | let map = List.combine ty.args targs in 167 | (* fill in all the type arguments *) 168 | let inst = 169 | List.map (instantiate map) (snd ctor) 170 | in 171 | break_and_map args inst 172 | end 173 | end 174 | end 175 | | _ -> err "not custom but should be" 176 | end 177 | 178 | let rec infer (ctx : ctx) (e : resolved expr) : 179 | (resolved typ, string) result = 180 | let* ty = 181 | match e with 182 | | MLocal _ | MGlobal _ -> 183 | failwith "monomorphization info in typechecking" 184 | (* try find that thing *) 185 | | Var (i, v) -> 186 | let* found = search ctx v in 187 | (* instantiate stuff now, to assist meta propogation *) 188 | to_metas ctx.local_polys found |> ok 189 | | Int (_, _) -> ok TyInt 190 | | String (_, _) -> ok TyString 191 | | Char (_, _) -> ok TyChar 192 | | Float (_, _) -> ok TyFloat 193 | | Bool (_, _) -> ok TyBool 194 | | LetIn (i, case, annot, head, body) -> 195 | (* if there's an annot, check, else infer *) 196 | let* head'ty = 197 | match annot with 198 | | Some ty -> check ctx head ty 199 | | None -> infer ctx head 200 | in 201 | (* get everything out *) 202 | let* vars = break_down_case_pattern ctx case head'ty in 203 | (* add the relevant type information to the raw type database *) 204 | ignore (List.map (fun (a, b) -> add_raw_type a b) vars); 205 | let ctx' = add_locals ctx vars in 206 | (* TODO: let generalization? *) 207 | infer ctx' body 208 | | Seq (_, a, b) -> 209 | (* we know the first branch must be unit *) 210 | let* _ = check ctx a (TyTuple []) in 211 | infer ctx b 212 | | Funccall (_, a, b) -> 213 | let* a'ty = infer ctx a in 214 | (* unify the calling type and the argument type to make sure 215 | they're actually compatible 216 | *) 217 | begin 218 | match a'ty with 219 | | TyArrow (q, w) -> 220 | let* b'ty = infer ctx b in 221 | let* _ = unify ctx.local_polys b'ty q in 222 | ok w 223 | | _ -> err "must function call on function type" 224 | end 225 | | Binop (_, op, a, b) -> begin 226 | match op with 227 | | Add | Sub | Mul | Div -> 228 | let* t = 229 | match check ctx a TyInt with 230 | | Ok _ -> ok TyInt 231 | | Error _ -> check ctx a TyFloat 232 | in 233 | let* _ = check ctx b t in 234 | ok t 235 | | LAnd | LOr -> 236 | let* _ = check ctx a TyBool in 237 | let* _ = check ctx b TyBool in 238 | ok TyBool 239 | | Eq -> 240 | let* ty = infer ctx a in 241 | let* _ = check ctx b ty in 242 | ok TyBool 243 | end 244 | | Lambda (_, v, typ, body) -> 245 | (* if we don't have a static type we can 246 | make a meta in order to try and infer the body 247 | gotta remember to "close up" the meta once we're 248 | done though, nonlocal inference is sucky 249 | *) 250 | let typ = 251 | begin 252 | match typ with 253 | | Some ty -> ty 254 | | None -> TyMeta (ref Unresolved) 255 | end 256 | in 257 | let ctx = add_local ctx v typ in 258 | let* body'ty = infer ctx body in 259 | let* _ = 260 | match typ with 261 | | TyMeta m -> 262 | (* ocaml ref patterns when *) 263 | begin 264 | match !m with 265 | (* shouldn't this return a polymorphic type? *) 266 | | Unresolved -> err "meta remained unsolved" 267 | | _ -> ok () 268 | end 269 | | _ -> ok () 270 | in 271 | add_raw_type v (force typ); 272 | ok @@ TyArrow (typ, body'ty) 273 | | Tuple (_, ts) -> 274 | (* i love fp *) 275 | List.map (infer ctx) ts 276 | |> collect 277 | |> Result.map_error (String.concat " ") 278 | |> Result.map (fun x -> TyTuple x) 279 | | Annot (_, x, t) -> 280 | (* switch directions *) 281 | check ctx x t 282 | | Match (_, scrut, cases) -> 283 | (* match is uniquely annoying because of that big old 284 | fold down at the bottom. this makes error propogation 285 | a pain, because you want to keep all of those possible 286 | erroring unifies, but you also don't want the whole thing 287 | to be a mess 288 | 289 | TODO: note that GADT "helping" cannot be done in the 290 | inference case 291 | *) 292 | let* scrut_typ = infer ctx scrut in 293 | let handle_case (case : 'a case * 'a expr) : 294 | ('a typ, string) result = 295 | let case, expr = case in 296 | let* vars = break_down_case_pattern ctx case scrut_typ in 297 | (* add raw type info for each *) 298 | ignore (List.map (fun (a, b) -> add_raw_type a b) vars); 299 | let ctx = add_locals ctx vars in 300 | infer ctx expr 301 | in 302 | let* typs = 303 | List.map handle_case cases 304 | |> collect 305 | |> Result.map_error (String.concat " ") 306 | in 307 | begin 308 | match typs with 309 | (* an empty match can return anything, because it can never be 310 | matched on 311 | *) 312 | | [] -> ok @@ TyMeta (ref Unresolved) 313 | | x :: xs -> 314 | (* TODO: don't ignore errors here *) 315 | List.fold_left 316 | (fun a b -> 317 | unify' ctx.local_polys a b; 318 | a) 319 | x xs 320 | |> ok 321 | end 322 | | Project (_, x, i) -> 323 | let* x'ty = infer ctx x in 324 | begin 325 | match x'ty with 326 | | TyCustom (nm, args) -> 327 | let typ = 328 | List.find 329 | (fun (x : 'a typdef) -> x.name = nm) 330 | ctx.types 331 | in 332 | begin 333 | match typ.content with 334 | | Record fields -> 335 | (* we have to consider the case in which the record is 336 | parameterized therefore, while we know the field we 337 | are working with, we need to up type arguments and 338 | perform an instantiation 339 | *) 340 | let map = List.combine typ.args args in 341 | let _, typ = List.nth fields i in 342 | ok @@ instantiate map typ 343 | | Sum _ -> err "should be record not sum" 344 | end 345 | | _ -> err "can't be record and not record" 346 | end 347 | | Ref (_, f) -> 348 | let* t = infer ctx f in 349 | ok @@ TyRef t 350 | | Modify (_, old, new') -> 351 | let* t = search ctx old in 352 | let* _ = check ctx new' t in 353 | ok @@ TyTuple [] 354 | | Record (_, nm, fields) -> 355 | (* this case is mildly annoying, because we have to deal 356 | with instantiation more explicitly 357 | *) 358 | (* a bit TODO *) 359 | let typ = 360 | List.find (fun (x : 'a typdef) -> x.name = nm) ctx.types 361 | in 362 | begin 363 | match typ.content with 364 | | Record r -> 365 | (* make sure that the lists contain each other 366 | TODO: make more efficient 367 | *) 368 | if 369 | not 370 | @@ (List.for_all 371 | (fun (name, value) -> 372 | match List.assoc_opt name r with 373 | | Some _ -> true 374 | | None -> false) 375 | fields 376 | && List.for_all 377 | (fun (name, typ) -> 378 | match List.assoc_opt name fields with 379 | | Some _ -> true 380 | | None -> false) 381 | r) 382 | then 383 | err "record decl does not match type" 384 | else 385 | let our_polys = typ.args in 386 | let metas = 387 | List.map 388 | (fun poly -> (poly, TyMeta (ref Unresolved))) 389 | our_polys 390 | in 391 | List.map (fun field -> infer ctx (snd field)) fields 392 | |> collect 393 | |> Result.map_error (String.concat " ") 394 | |> fun results -> 395 | let* res = results in 396 | let res = List.combine (List.map fst fields) res in 397 | List.iter 398 | (fun res -> 399 | let match' = List.assoc (fst res) r in 400 | unify' ctx.local_polys (snd res) match') 401 | res; 402 | ok @@ TyCustom (typ.name, List.map snd metas) 403 | | _ -> err "can't make a record out of a sum type" 404 | end 405 | in 406 | let uuid = get_uuid e in 407 | add_type uuid ty; 408 | ok (force ty) 409 | 410 | and check (ctx : ctx) (e : resolved expr) (t : resolved typ) : 411 | (resolved typ, string) result = 412 | (* here, we only consider the cases where checking something 413 | would actually benefit typechecking as a whole - therefore, 414 | there's a whole bunch of stuff that we just defer straight back 415 | to infer 416 | i think there's technically some trickery that can be done 417 | with regards to Funccall, but it's late and i can't think of it 418 | right now 419 | TODO: look at that later 420 | *) 421 | print_endline ("checking: " ^ show_expr pp_resolved e); 422 | print_endline (" against: " ^ show_typ pp_resolved t); 423 | let* ty = 424 | match e with 425 | | LetIn (_, case, ty, head, body) -> 426 | let* head'ty = 427 | match ty with 428 | | Some t -> check ctx head t 429 | | None -> infer ctx head 430 | in 431 | let* vars = break_down_case_pattern ctx case head'ty in 432 | ignore (List.map (fun (a, b) -> add_raw_type a b) vars); 433 | let ctx = add_locals ctx vars in 434 | check ctx body t 435 | | Seq (_, a, b) -> 436 | let* _ = check ctx a (TyTuple []) in 437 | check ctx b t 438 | | Lambda (_, v, ty, body) -> begin 439 | match t with 440 | | TyArrow (q, w) -> 441 | let* ty = 442 | begin 443 | match ty with 444 | (* logically if we're checking 445 | (fun (x: t) -> ...) 446 | against 447 | q -> w 448 | then t == q 449 | *) 450 | | Some t -> unify ctx.local_polys q t 451 | | None -> ok q 452 | end 453 | in 454 | add_raw_type v ty; 455 | let ctx = add_local ctx v ty in 456 | check ctx body w 457 | | _ -> err "lambda cannot be non-function type" 458 | end 459 | | Tuple (_, ts) -> begin 460 | match t with 461 | | TyTuple s -> 462 | if List.length ts <> List.length s then 463 | err "uneq tuple lengths" 464 | else 465 | (* i love fp round 2 *) 466 | List.map2 (check ctx) ts s 467 | |> collect 468 | |> Result.map_error (String.concat " ") 469 | |> Result.map (fun x -> TyTuple x) 470 | | _ -> err "must be tuple type" 471 | end 472 | | Match (_, scrut, cases) -> 473 | (* see comments in infer 474 | should probably factor all this out tbh 475 | 476 | TODO: add GADT "helping" so that something like 477 | let e : Eq a b -> a -> b = fun eq x -> 478 | match eq with 479 | | Refl -> x 480 | end 481 | works 482 | *) 483 | let* scrut_typ = infer ctx scrut in 484 | let handle_case (case : 'a case * 'a expr) : 485 | ('a typ, string) result = 486 | let case, expr = case in 487 | let* vars = break_down_case_pattern ctx case scrut_typ in 488 | ignore (List.map (fun (a, b) -> add_raw_type a b) vars); 489 | let ctx = add_locals ctx vars in 490 | (* only difference is that we can check this time *) 491 | check ctx expr t 492 | in 493 | let* typs = 494 | List.map handle_case cases 495 | |> collect 496 | |> Result.map_error (String.concat " ") 497 | in 498 | begin 499 | match typs with 500 | (* an empty match can return anything, because it can never be 501 | matched on 502 | *) 503 | | [] -> ok @@ TyMeta (ref Unresolved) 504 | | x :: xs -> 505 | (* TODO: don't ignore errors here *) 506 | List.fold_left 507 | (fun a b -> 508 | unify' ctx.local_polys a b; 509 | a) 510 | x xs 511 | |> ok 512 | end 513 | | Ref (_, r) -> begin 514 | match t with 515 | | TyRef r't -> check ctx r r't 516 | | _ -> err "cannot check ref against not ref" 517 | end 518 | | _ -> 519 | (* in the general case, we defer to infer (hehe) and then 520 | come back here and "check our work" with unify 521 | *) 522 | let* ty = infer ctx e in 523 | let* _ = unify ctx.local_polys ty t in 524 | ok ty 525 | in 526 | let uuid = get_uuid e in 527 | add_type uuid ty; 528 | ok (force ty) 529 | 530 | let typecheck_definition (ctx : ctx) (d : (resolved, yes) definition) 531 | : (unit, string) result = 532 | let polys = d.typeargs in 533 | let args = d.args in 534 | ignore (List.map (fun (a, b) -> add_raw_type a b) args); 535 | let ctx = 536 | { 537 | ctx with 538 | locals = ctx.locals @ args; 539 | local_polys = ctx.local_polys @ polys; 540 | } 541 | in 542 | let body = get d.body in 543 | let* _ = check ctx body d.return in 544 | ok () 545 | 546 | let typecheck_impl (ctx : ctx) (i : resolved impl) : 547 | (unit, string) result = 548 | (* TODO: check that args match the trait *) 549 | i.impls 550 | |> List.map 551 | snd (* we don't care about the unique name at the moment *) 552 | |> List.map (typecheck_definition ctx) 553 | |> collect 554 | |> Result.map_error (String.concat " ") 555 | |> Result.map (fun _ -> ()) 556 | 557 | let typecheck_toplevel (ctx : ctx) (t : resolved toplevel) : 558 | (unit, string) result = 559 | match t with 560 | | Typdef _ -> ok () 561 | | Trait f -> 562 | List.iter 563 | (fun (d : ('a, 'b) definition) -> 564 | add_raw_type d.name (definition_type d)) 565 | f.functions; 566 | ok () 567 | | Impl i -> typecheck_impl ctx i 568 | | Definition d -> typecheck_definition ctx d 569 | 570 | let gather (t : resolved toplevel list) : ctx = 571 | let ctx = empty_ctx () in 572 | List.fold_left 573 | (fun ctx a -> 574 | match a with 575 | | Typdef t -> begin 576 | match t.content with 577 | | Record r -> 578 | { 579 | ctx with 580 | ctors = (t.name, t) :: ctx.ctors; 581 | types = t :: ctx.types; 582 | } 583 | | Sum s -> 584 | List.fold_left 585 | (fun acc a -> 586 | { acc with ctors = (fst a, t) :: acc.ctors }) 587 | { ctx with types = t :: ctx.types } 588 | s 589 | end 590 | | Trait t -> 591 | List.fold_left 592 | (fun acc (a : ('a, 'b) definition) -> 593 | { acc with traitfuns = (a.name, t) :: acc.traitfuns }) 594 | ctx t.functions 595 | | Impl _ -> 596 | (* we don't do anything here *) 597 | ctx 598 | | Definition d -> 599 | { ctx with funs = (d.name, forget_body d) :: ctx.funs }) 600 | ctx t 601 | 602 | let typecheck (t : resolved toplevel list) : unit = 603 | let ctx = gather t in 604 | List.map (typecheck_toplevel ctx) t |> collect |> function 605 | | Ok _ -> 606 | (* TODO: make sure metas don't escape (iter hashtbl?) *) 607 | let gen = fresh_resolved in 608 | Hashtbl.iter 609 | (fun k v -> 610 | Hashtbl.replace type_information k (back_to_polys gen v)) 611 | type_information; 612 | print_endline "typechecked :D"; 613 | () 614 | | Error e -> 615 | List.iter print_endline e; 616 | failwith "typechecking failed :despair:" 617 | -------------------------------------------------------------------------------- /lib/frontend/unify.ml: -------------------------------------------------------------------------------- 1 | open Share.Uuid 2 | open Share.Result 3 | open Ast 4 | 5 | (* 6 | woooooooooooo unification 7 | we do a really simple forwarding-based meta system, 8 | so our unification implementation is equally simple 9 | yay 10 | *) 11 | 12 | (* pretty straightforward unification *) 13 | let rec unify_h (t1 : 'a typ) (t2 : 'a typ) : ('a typ, string) result 14 | = 15 | match (force t1, force t2) with 16 | | TyInt, TyInt -> ok TyInt 17 | | TyString, TyString -> ok TyString 18 | | TyChar, TyChar -> ok TyChar 19 | | TyFloat, TyFloat -> ok TyFloat 20 | | TyBool, TyBool -> ok TyBool 21 | | TyTuple t1, TyTuple t2 -> 22 | let* t = 23 | List.map2 unify_h t1 t2 24 | |> collect 25 | |> Result.map_error (String.concat " ") 26 | in 27 | ok @@ TyTuple t 28 | | TyArrow (a, b), TyArrow (q, w) -> 29 | let* a' = unify_h a q in 30 | let* b' = unify_h b w in 31 | ok @@ TyArrow (a', b') 32 | | TyPoly a, TyPoly b -> 33 | (* if polys are equal, they must be fine 34 | we already know that non-local polys have been instantiated 35 | by this point, so we're all good in that department 36 | *) 37 | if a = b then 38 | ok @@ TyPoly a 39 | else 40 | err "can't unify_h uneq polys" 41 | | TyCustom (x, xs), TyCustom (y, ys) -> 42 | if x <> y then 43 | err "can't unify_h not equals" 44 | else 45 | List.map2 unify_h xs ys 46 | |> collect 47 | |> Result.map_error (String.concat " ") 48 | |> fun xs -> 49 | let* xs = xs in 50 | ok @@ TyCustom (x, xs) 51 | | TyRef a, TyRef b -> unify_h a b 52 | | TyMeta a, TyMeta b -> 53 | (* we did a force, so both should be unsolved *) 54 | begin 55 | match !a with 56 | | Unresolved -> 57 | (* set one to the other *) 58 | a := Resolved t2; 59 | ok t2 60 | | Resolved _ -> failwith "impossible" 61 | end 62 | | TyMeta a, t | t, TyMeta a -> begin 63 | match !a with 64 | | Resolved _ -> failwith "impossible" 65 | | Unresolved -> 66 | a := Resolved t; 67 | ok t 68 | end 69 | | a, b -> 70 | let f = show_typ pp_resolved in 71 | err @@ "these don't unify bozo: " ^ f a ^ "\n & \n" ^ f b 72 | 73 | let unify polys a b = 74 | (* ensure that we get rid of any non-local polys so that we 75 | don't end up "losing" polymorphism 76 | *) 77 | let a = to_metas polys a in 78 | let b = to_metas polys b in 79 | (* should we be regeneralizing here? quite possibly 80 | TODO: check 81 | *) 82 | unify_h a b 83 | 84 | (* TODO: don't use this anywhere *) 85 | let unify' polys a b = ignore @@ unify polys a b 86 | -------------------------------------------------------------------------------- /lib/main.ml: -------------------------------------------------------------------------------- 1 | open Share.Uuid 2 | open Frontend.Ast 3 | open Frontend.Typecheck 4 | open Frontend.Parser 5 | open Frontend.Trait_resolution 6 | 7 | let r x = R x 8 | 9 | let main () = 10 | (* print_endline "hey hey"; *) 11 | let file = Sys.argv.(1) in 12 | let s = In_channel.with_open_bin file In_channel.input_all in 13 | (* print_endline "file:"; 14 | print_endline s; *) 15 | let lexbuf = Sedlexing.Utf8.from_string s in 16 | begin 17 | match toplevel lexbuf with 18 | | Ok e -> 19 | print_endline "parsed:"; 20 | List.iter 21 | (fun x -> print_endline (show_toplevel pp_resolved x)) 22 | e; 23 | print_endline "end\n"; 24 | 25 | typecheck e; 26 | (* 27 | print_endline "\ntypes:"; 28 | print_by_uuid (show_typ pp_resolved) type_information; 29 | print_endline "----------------\n"; 30 | *) 31 | begin 32 | match resolve e with 33 | | Ok () -> () 34 | | Error e -> print_endline e 35 | end; 36 | 37 | print_endline "\n\ntrait info:\n"; 38 | Hashtbl.iter 39 | (fun uuid t -> 40 | print_string "uuid: "; 41 | print_endline (show_uuid uuid); 42 | List.iter 43 | (fun a -> print_endline (" inst: " ^ show_solved a)) 44 | t; 45 | ()) 46 | trait_information; 47 | (* 48 | print_string "\n\ntype info:\n"; 49 | Hashtbl.iter (fun a b -> 50 | print_endline ("uuid: " ^ show_uuid a); 51 | print_endline (" type: " ^ show_typ pp_resolved b); 52 | ) type_information; 53 | *) 54 | let mono'd = Monomorph.Monomorphize.monomorphize e in 55 | print_endline "monomorph in progress"; 56 | Monomorph.Monomorphize.print_monomorph_info mono'd 57 | | Error s -> 58 | print_endline "noooo it failed :despair:"; 59 | print_endline s 60 | end; 61 | print_endline "done" 62 | -------------------------------------------------------------------------------- /lib/monomorph/monomorphize.ml: -------------------------------------------------------------------------------- 1 | open Frontend.Ast 2 | open Frontend.Typecheck 3 | open Share.Maybe 4 | open Share.Uuid 5 | 6 | type m_name = resolved 7 | type m_typ = resolved typ 8 | type m_expr = resolved expr 9 | 10 | type monomorph_info = { 11 | pre_monomorph : (m_name, (m_name, yes) definition) Hashtbl.t; 12 | monomorph_information : 13 | (m_name * m_typ, uuid * (m_name, yes) definition Lazy.t) Hashtbl.t; 14 | } 15 | 16 | let monomorph_fixpoint ctx = 17 | let rec go () = 18 | let v1 = Hashtbl.to_seq_values ctx.monomorph_information in 19 | let _ = Seq.iter (fun (_, x) -> ignore @@ Lazy.force x) v1 in 20 | let v2 = Hashtbl.to_seq_values ctx.monomorph_information in 21 | if Seq.length v1 = Seq.length v2 then 22 | () 23 | else 24 | go () 25 | in 26 | go () 27 | 28 | let print_monomorph_info ctx = 29 | print_endline "\n====== MONOMORPH INFO ======\n"; 30 | Hashtbl.iter 31 | (fun (nm, ty) (uuid, def) -> 32 | print_string (show_resolved nm ^ " : " ^ show_typ pp_resolved ty); 33 | print_string " =\n "; 34 | print_endline 35 | (show_definition pp_resolved pp_yes (Lazy.force def))) 36 | ctx.monomorph_information 37 | 38 | let new_ctx () = 39 | { 40 | pre_monomorph = Hashtbl.create 100; 41 | monomorph_information = Hashtbl.create 100; 42 | } 43 | 44 | let add_pre_monomorph top ctx = 45 | top 46 | |> List.iter (function 47 | | Definition def -> Hashtbl.add ctx.pre_monomorph def.name def 48 | | _ -> ()) 49 | 50 | let rec monomorph_e (ctx : monomorph_info) (map : 'a) (body : m_expr) 51 | : m_expr = 52 | let go = monomorph_e ctx map in 53 | (* First check what the type is *) 54 | let[@warning "-8"] (Some typ) = 55 | uuid_by_orig type_information (get_uuid body) 56 | in 57 | let new_typ = subst_polys map typ in 58 | Hashtbl.add type_information (get_uuid body) new_typ; 59 | match body with 60 | | MLocal _ | MGlobal _ -> 61 | (* theoretically impossible, but harmless *) 62 | failwith "uhh recursion?" 63 | | Int _ | String _ | Char _ | Float _ | Bool _ -> body 64 | | Var (d, a) -> 65 | (* then see if it's something we need to monomorphize *) 66 | begin 67 | match Hashtbl.find_opt ctx.pre_monomorph a with 68 | | None -> 69 | (* does not need it, simply replace type and move on *) 70 | MLocal (d, a) 71 | | Some s -> 72 | let uuid = monomorph_get ctx s new_typ in 73 | MGlobal (d, uuid) 74 | end 75 | | Funccall (d, f, x) -> Funccall (d, go f, go x) 76 | | LetIn (d, c, ty, e1, e2) -> LetIn (d, c, ty, go e1, go e2) 77 | | Seq (d, a, b) -> Seq (d, go a, go b) 78 | | Binop (i, b, a, c) -> Binop (i, b, go a, go c) 79 | | Lambda (i, nm, t, e) -> Lambda (i, nm, t, go e) 80 | | Tuple (i, s) -> Tuple (i, List.map go s) 81 | | Annot (i, e, t) -> 82 | (* We remove annotations*) 83 | go e 84 | | Match (i, e, cs) -> 85 | Match (i, go e, List.map (fun (a, b) -> (a, go b)) cs) 86 | | Project (i, e, k) -> Project (i, go e, k) 87 | | Ref (i, e) -> Ref (i, go e) 88 | | Modify (i, a, e) -> Modify (i, a, go e) 89 | | Record (i, a, cs) -> 90 | Record (i, a, List.map (fun (a, b) -> (a, go b)) cs) 91 | 92 | and proper_uuid (def : (_, _) definition) : uuid = 93 | def.data.counter <- def.data.counter + 1; 94 | uuid_set_version def.data.counter def.data.uuid 95 | 96 | and monomorph (ctx : monomorph_info) (new_uuid : uuid) 97 | (def : (_, _) definition) monotyp : (_, yes) definition = 98 | let body = get def.body in 99 | let full_typ = 100 | typ_list_to_typ (List.map snd def.args @ [ def.return ]) 101 | in 102 | let pairwise = match_polys full_typ monotyp in 103 | (*print_endline ("monomorphing " ^ show_resolved def.name); 104 | List.iter (fun (a,b) -> 105 | print_endline (show_resolved a); 106 | print_endline (" " ^ show_typ pp_resolved b); 107 | ) pairwise; 108 | *) 109 | let incr'd_body = expr_set_uuid_version def.data.counter body in 110 | let bod = monomorph_e ctx pairwise incr'd_body in 111 | { 112 | def with 113 | data = { def.data with uuid = new_uuid }; 114 | body = Just bod; 115 | args = 116 | List.map (fun (a, b) -> (a, subst_polys pairwise b)) def.args; 117 | return = subst_polys pairwise def.return; 118 | (* TODO: change bounds? *) 119 | } 120 | 121 | and monomorph_get (ctx : monomorph_info) (def : (_, _) definition) typ 122 | : uuid = 123 | match 124 | Hashtbl.find_opt ctx.monomorph_information (def.name, typ) 125 | with 126 | | Some (uuid, res) -> uuid 127 | | None -> ( 128 | let uuid = proper_uuid def in 129 | let def' = lazy (monomorph ctx uuid def typ) in 130 | try 131 | Hashtbl.add ctx.monomorph_information (def.name, typ) 132 | (uuid, def'); 133 | uuid 134 | with Stack_overflow -> 135 | failwith 136 | "you probably tried to recursively monomorphize something") 137 | 138 | let monomorphize (top : resolved toplevel list) : monomorph_info = 139 | let ctx = new_ctx () in 140 | add_pre_monomorph top ctx; 141 | (* add everything to the queue *) 142 | (* TODO: Make this more advanced *) 143 | let main = 144 | match Hashtbl.find_opt ctx.pre_monomorph (R "main") with 145 | | Some def -> def 146 | | None -> failwith "main not found >:(" 147 | in 148 | let _ = monomorph_get ctx main (TyArrow (TyInt, TyInt)) in 149 | monomorph_fixpoint ctx; 150 | ctx 151 | -------------------------------------------------------------------------------- /lib/share/log.ml: -------------------------------------------------------------------------------- 1 | let debug s = Printf.fprintf stderr "debug: %s" s 2 | -------------------------------------------------------------------------------- /lib/share/maybe.ml: -------------------------------------------------------------------------------- 1 | type no = No [@@deriving show { with_path = false }] 2 | type yes = Yes [@@deriving show { with_path = false }] 3 | 4 | type (_, _) maybe = 5 | | Nothing : ('a, no) maybe 6 | | Just : 'a -> ('a, yes) maybe 7 | 8 | let pp_maybe : type q w. 9 | ('a -> q -> unit) -> 's -> 'a -> (q, w) maybe -> unit = 10 | fun p1 _ fmt x -> 11 | match x with 12 | | Nothing -> Format.fprintf fmt "Nothing" 13 | | Just x -> Format.fprintf fmt "Just (%a)" p1 x 14 | 15 | let get (Just x) = x 16 | 17 | let to_option : type a. ('b, a) maybe -> 'b option = 18 | fun x -> match x with Nothing -> None | Just x -> Some x 19 | 20 | let try_from_option : 'b option -> ('b, yes) maybe option = 21 | fun x -> match x with None -> None | Some x -> Some (Just x) 22 | 23 | let forget : ('a, yes) maybe -> ('a, no) maybe = fun x -> Nothing 24 | -------------------------------------------------------------------------------- /lib/share/result.ml: -------------------------------------------------------------------------------- 1 | let ( let* ) (x : ('a, 'b) result) (f : 'a -> ('c, 'b) result) = 2 | match x with Ok x -> f x | Error x -> Error x 3 | 4 | let err x = Error x 5 | let ok x = Ok x 6 | 7 | let ( let** ) (x : 'a option * string) (f : 'a -> ('c, string) result) 8 | = 9 | match fst x with Some n -> f n | None -> Error (snd x) 10 | 11 | let collect (x : ('a, 'b) result list) : ('a list, 'b list) result = 12 | match 13 | List.filter (fun x -> match x with Ok _ -> false | _ -> true) x 14 | with 15 | | [] -> 16 | List.map (function Ok s -> s | _ -> failwith "bad") x |> ok 17 | | x -> 18 | List.map (function Error s -> s | _ -> failwith "bad") x 19 | |> err 20 | -------------------------------------------------------------------------------- /lib/share/types.ml: -------------------------------------------------------------------------------- 1 | open Result 2 | include Either 3 | -------------------------------------------------------------------------------- /lib/share/uuid.ml: -------------------------------------------------------------------------------- 1 | type uuid = UUID of (int * int) 2 | [@@deriving show { with_path = false }] 3 | 4 | let new_by_uuid n : (uuid, 'a) Hashtbl.t = Hashtbl.create n 5 | 6 | let uuid_by_orig tbl (UUID (a, b)) = 7 | Hashtbl.find_opt tbl (UUID (a, 0)) 8 | 9 | let print_by_uuid show p = 10 | let s = Hashtbl.to_seq p in 11 | s 12 | |> Seq.map (fun (a, b) -> show_uuid a ^ ": " ^ show b) 13 | |> List.of_seq 14 | |> String.concat "\n" 15 | |> print_endline 16 | 17 | let uuid = 18 | let x = ref 1000 in 19 | fun () -> 20 | incr x; 21 | UUID (!x, 0) 22 | 23 | let uuid_set_version v uuid = 24 | let (UUID (a, b)) = uuid in 25 | UUID (a, v) 26 | 27 | let uuid_get_version (UUID (a, b)) = b 28 | -------------------------------------------------------------------------------- /test.kha: -------------------------------------------------------------------------------- 1 | fun main (m : Int): Int = 2 | let foo = id 5 in 3 | let bar = id 3.2 in 4 | let qux = id 10 in 5 | m 6 | 7 | fun id { type 'a } (y : 'a) : 'a = id y --------------------------------------------------------------------------------