├── .gitignore ├── .ocp-indent ├── LICENSE ├── Makefile ├── README.md ├── auto-format.el ├── common ├── basicClasses.ml ├── concreteSyntax.ml ├── dune ├── failure.ml ├── id.ml ├── monadic.ml ├── name.ml ├── qNameMap.ml ├── syntax.ml ├── unique.ml └── util.ml ├── dune ├── dune-project ├── heart ├── dune ├── expr.ml ├── kind.ml ├── type.ml ├── typeKind.ml └── typeVar.ml ├── kekka.ml ├── kekka.opam ├── kindEngine ├── dune ├── importMap.ml ├── infer.ml ├── inferKind.ml ├── inferMonad.ml ├── kGamma.ml ├── kGamma.mli ├── synonyms.ml └── unify.ml ├── misc ├── expr.ml └── expr.mli ├── synonyms.ml ├── test_runner.ml └── typeEngine ├── dune ├── typeOperations.ml └── unify.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | # -*- conf -*- 2 | # This is a configuration file for ocp-indent 3 | 4 | # Starting the configuration file with a preset ensures you won't fallback to 5 | # definitions from "~/.ocp/ocp-indent.conf". 6 | # These are `normal`, `apprentice` and `JaneStreet` and set different defaults. 7 | normal 8 | 9 | # 10 | # INDENTATION VALUES 11 | # 12 | 13 | # Number of spaces used in all base cases, for example: 14 | # let foo = 15 | # ^^bar 16 | base = 2 17 | 18 | # Indent for type definitions: 19 | # type t = 20 | # ^^int 21 | type = 2 22 | 23 | # Indent after `let in` (unless followed by another `let`): 24 | # let foo = () in 25 | # ^^bar 26 | in = 0 27 | 28 | # Indent after `match/try with` or `function`: 29 | # match foo with 30 | # ^^| _ -> bar 31 | with = 0 32 | 33 | # Indent for clauses inside a pattern-match (after the arrow): 34 | # match foo with 35 | # | _ -> 36 | # ^^^^bar 37 | # the default is 2, which aligns the pattern and the expression 38 | match_clause = 4 39 | 40 | ppx_stritem_ext=2 41 | 42 | # When nesting expressions on the same line, their indentation are in 43 | # some cases stacked, so that it remains correct if you close them one 44 | # at a line. This may lead to large indents in complex code though, so 45 | # this parameter can be used to set a maximum value. Note that it only 46 | # affects indentation after function arrows and opening parens at end 47 | # of line. 48 | # 49 | # for example (left: `none`; right: `4`) 50 | # let f = g (h (i (fun x -> # let f = g (h (i (fun x -> 51 | # x) # x) 52 | # ) # ) 53 | # ) # ) 54 | max_indent = 4 55 | 56 | 57 | # 58 | # INDENTATION TOGGLES 59 | # 60 | 61 | # Wether the `with` parameter should be applied even when in a sub-block. 62 | # Can be `always`, `never` or `auto`. 63 | # if `always`, there are no exceptions 64 | # if `auto`, the `with` parameter is superseded when seen fit (most of the time, 65 | # but not after `begin match` for example) 66 | # if `never`, `with` is only applied if the match block starts a line. 67 | # 68 | # For example, the following is not indented if set to `always`: 69 | # let f = function 70 | # ^^| Foo -> bar 71 | strict_with = auto 72 | 73 | # Controls indentation after the `else` keyword. `always` indents after the 74 | # `else` keyword normally, like after `then`. 75 | # If set to `never', the `else` keyword won't indent when followed by a newline. 76 | # `auto` indents after `else` unless in a few "unclosable" cases (`let in`, 77 | # `match`...). 78 | # 79 | # For example, with `strict_else=never`: 80 | # if cond then 81 | # foo 82 | # else 83 | # bar; 84 | # baz 85 | # `never` is discouraged if you may encounter code like this example, 86 | # because it hides the scoping error (`baz` is always executed) 87 | strict_else = always 88 | 89 | # Ocp-indent will normally try to preserve your in-comment indentation, as long 90 | # as it respects the left-margin or starts with `(*\n`. Setting this to `true` 91 | # forces alignment within comments. 92 | strict_comments = false 93 | 94 | # Toggles preference of column-alignment over line indentation for most 95 | # of the common operators and after mid-line opening parentheses. 96 | # 97 | # for example (left: `false'; right: `true') 98 | # let f x = x # let f x = x 99 | # + y # + y 100 | align_ops = true 101 | 102 | # Function parameters are normally indented one level from the line containing 103 | # the function. This option can be used to have them align relative to the 104 | # column of the function body instead. 105 | # if set to `always`, always align below the function 106 | # if `auto`, only do that when seen fit (mainly, after arrows) 107 | # if `never`, no alignment whatsoever 108 | # 109 | # for example (left: `never`; right: `always or `auto) 110 | # match foo with # match foo with 111 | # | _ -> some_fun # | _ -> some_fun 112 | # ^^parameter # ^^parameter 113 | align_params = always 114 | 115 | 116 | # semi_as_op = false 117 | 118 | # 119 | # SYNTAX EXTENSIONS 120 | # 121 | 122 | # You can also add syntax extensions (as per the --syntax command-line option): 123 | # syntax = mll lwt 124 | 125 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Koka: Copyright (C) 2012 Microsoft Corporation, Daan Leijen. 2 | 3 | Koka is free software; You can redistribute it and/or modify it under 4 | the terms of this license. 5 | 6 | 7 | Apache License 8 | Version 2.0, January 2004 9 | http://www.apache.org/licenses/ 10 | 11 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 12 | 13 | 1. Definitions. 14 | 15 | "License" shall mean the terms and conditions for use, reproduction, 16 | and distribution as defined by Sections 1 through 9 of this document. 17 | 18 | "Licensor" shall mean the copyright owner or entity authorized by 19 | the copyright owner that is granting the License. 20 | 21 | "Legal Entity" shall mean the union of the acting entity and all 22 | other entities that control, are controlled by, or are under common 23 | control with that entity. For the purposes of this definition, 24 | "control" means (i) the power, direct or indirect, to cause the 25 | direction or management of such entity, whether by contract or 26 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 27 | outstanding shares, or (iii) beneficial ownership of such entity. 28 | 29 | "You" (or "Your") shall mean an individual or Legal Entity 30 | exercising permissions granted by this License. 31 | 32 | "Source" form shall mean the preferred form for making modifications, 33 | including but not limited to software source code, documentation 34 | source, and configuration files. 35 | 36 | "Object" form shall mean any form resulting from mechanical 37 | transformation or translation of a Source form, including but 38 | not limited to compiled object code, generated documentation, 39 | and conversions to other media types. 40 | 41 | "Work" shall mean the work of authorship, whether in Source or 42 | Object form, made available under the License, as indicated by a 43 | copyright notice that is included in or attached to the work 44 | (an example is provided in the Appendix below). 45 | 46 | "Derivative Works" shall mean any work, whether in Source or Object 47 | form, that is based on (or derived from) the Work and for which the 48 | editorial revisions, annotations, elaborations, or other modifications 49 | represent, as a whole, an original work of authorship. For the purposes 50 | of this License, Derivative Works shall not include works that remain 51 | separable from, or merely link (or bind by name) to the interfaces of, 52 | the Work and Derivative Works thereof. 53 | 54 | "Contribution" shall mean any work of authorship, including 55 | the original version of the Work and any modifications or additions 56 | to that Work or Derivative Works thereof, that is intentionally 57 | submitted to Licensor for inclusion in the Work by the copyright owner 58 | or by an individual or Legal Entity authorized to submit on behalf of 59 | the copyright owner. For the purposes of this definition, "submitted" 60 | means any form of electronic, verbal, or written communication sent 61 | to the Licensor or its representatives, including but not limited to 62 | communication on electronic mailing lists, source code control systems, 63 | and issue tracking systems that are managed by, or on behalf of, the 64 | Licensor for the purpose of discussing and improving the Work, but 65 | excluding communication that is conspicuously marked or otherwise 66 | designated in writing by the copyright owner as "Not a Contribution." 67 | 68 | "Contributor" shall mean Licensor and any individual or Legal Entity 69 | on behalf of whom a Contribution has been received by Licensor and 70 | subsequently incorporated within the Work. 71 | 72 | 2. Grant of Copyright License. Subject to the terms and conditions of 73 | this License, each Contributor hereby grants to You a perpetual, 74 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 75 | copyright license to reproduce, prepare Derivative Works of, 76 | publicly display, publicly perform, sublicense, and distribute the 77 | Work and such Derivative Works in Source or Object form. 78 | 79 | 3. Grant of Patent License. Subject to the terms and conditions of 80 | this License, each Contributor hereby grants to You a perpetual, 81 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 82 | (except as stated in this section) patent license to make, have made, 83 | use, offer to sell, sell, import, and otherwise transfer the Work, 84 | where such license applies only to those patent claims licensable 85 | by such Contributor that are necessarily infringed by their 86 | Contribution(s) alone or by combination of their Contribution(s) 87 | with the Work to which such Contribution(s) was submitted. If You 88 | institute patent litigation against any entity (including a 89 | cross-claim or counterclaim in a lawsuit) alleging that the Work 90 | or a Contribution incorporated within the Work constitutes direct 91 | or contributory patent infringement, then any patent licenses 92 | granted to You under this License for that Work shall terminate 93 | as of the date such litigation is filed. 94 | 95 | 4. Redistribution. You may reproduce and distribute copies of the 96 | Work or Derivative Works thereof in any medium, with or without 97 | modifications, and in Source or Object form, provided that You 98 | meet the following conditions: 99 | 100 | (a) You must give any other recipients of the Work or 101 | Derivative Works a copy of this License; and 102 | 103 | (b) You must cause any modified files to carry prominent notices 104 | stating that You changed the files; and 105 | 106 | (c) You must retain, in the Source form of any Derivative Works 107 | that You distribute, all copyright, patent, trademark, and 108 | attribution notices from the Source form of the Work, 109 | excluding those notices that do not pertain to any part of 110 | the Derivative Works; and 111 | 112 | (d) If the Work includes a "NOTICE" text file as part of its 113 | distribution, then any Derivative Works that You distribute must 114 | include a readable copy of the attribution notices contained 115 | within such NOTICE file, excluding those notices that do not 116 | pertain to any part of the Derivative Works, in at least one 117 | of the following places: within a NOTICE text file distributed 118 | as part of the Derivative Works; within the Source form or 119 | documentation, if provided along with the Derivative Works; or, 120 | within a display generated by the Derivative Works, if and 121 | wherever such third-party notices normally appear. The contents 122 | of the NOTICE file are for informational purposes only and 123 | do not modify the License. You may add Your own attribution 124 | notices within Derivative Works that You distribute, alongside 125 | or as an addendum to the NOTICE text from the Work, provided 126 | that such additional attribution notices cannot be construed 127 | as modifying the License. 128 | 129 | You may add Your own copyright statement to Your modifications and 130 | may provide additional or different license terms and conditions 131 | for use, reproduction, or distribution of Your modifications, or 132 | for any such Derivative Works as a whole, provided Your use, 133 | reproduction, and distribution of the Work otherwise complies with 134 | the conditions stated in this License. 135 | 136 | 5. Submission of Contributions. Unless You explicitly state otherwise, 137 | any Contribution intentionally submitted for inclusion in the Work 138 | by You to the Licensor shall be under the terms and conditions of 139 | this License, without any additional terms or conditions. 140 | Notwithstanding the above, nothing herein shall supersede or modify 141 | the terms of any separate license agreement you may have executed 142 | with Licensor regarding such Contributions. 143 | 144 | 6. Trademarks. This License does not grant permission to use the trade 145 | names, trademarks, service marks, or product names of the Licensor, 146 | except as required for reasonable and customary use in describing the 147 | origin of the Work and reproducing the content of the NOTICE file. 148 | 149 | 7. Disclaimer of Warranty. Unless required by applicable law or 150 | agreed to in writing, Licensor provides the Work (and each 151 | Contributor provides its Contributions) on an "AS IS" BASIS, 152 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 153 | implied, including, without limitation, any warranties or conditions 154 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 155 | PARTICULAR PURPOSE. You are solely responsible for determining the 156 | appropriateness of using or redistributing the Work and assume any 157 | risks associated with Your exercise of permissions under this License. 158 | 159 | 8. Limitation of Liability. In no event and under no legal theory, 160 | whether in tort (including negligence), contract, or otherwise, 161 | unless required by applicable law (such as deliberate and grossly 162 | negligent acts) or agreed to in writing, shall any Contributor be 163 | liable to You for damages, including any direct, indirect, special, 164 | incidental, or consequential damages of any character arising as a 165 | result of this License or out of the use or inability to use the 166 | Work (including but not limited to damages for loss of goodwill, 167 | work stoppage, computer failure or malfunction, or any and all 168 | other commercial damages or losses), even if such Contributor 169 | has been advised of the possibility of such damages. 170 | 171 | 9. Accepting Warranty or Additional Liability. While redistributing 172 | the Work or Derivative Works thereof, You may choose to offer, 173 | and charge a fee for, acceptance of support, warranty, indemnity, 174 | or other liability obligations and/or rights consistent with this 175 | License. However, in accepting such obligations, You may act only 176 | on Your own behalf and on Your sole responsibility, not on behalf 177 | of any other Contributor, and only if You agree to indemnify, 178 | defend, and hold each Contributor harmless for any liability 179 | incurred by, or claims asserted against, such Contributor by reason 180 | of your accepting any such warranty or additional liability. 181 | 182 | END OF TERMS AND CONDITIONS 183 | 184 | APPENDIX: How to apply the Apache License to your work. 185 | 186 | To apply the Apache License to your work, attach the following 187 | boilerplate notice, with the fields enclosed by brackets "{}" 188 | replaced with your own identifying information. (Don't include 189 | the brackets!) The text should be enclosed in the appropriate 190 | comment syntax for the file format. We also recommend that a 191 | file or class name and description of purpose be included on the 192 | same "printed page" as the copyright notice for easier 193 | identification within third-party archives. 194 | 195 | Copyright {yyyy} {name of copyright owner} 196 | 197 | Licensed under the Apache License, Version 2.0 (the "License"); 198 | you may not use this file except in compliance with the License. 199 | You may obtain a copy of the License at 200 | 201 | http://www.apache.org/licenses/LICENSE-2.0 202 | 203 | Unless required by applicable law or agreed to in writing, software 204 | distributed under the License is distributed on an "AS IS" BASIS, 205 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 206 | See the License for the specific language governing permissions and 207 | limitations under the License. 208 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | # Default rule 4 | default: 5 | dune build @install 6 | 7 | install: 8 | dune install $(INSTALL_ARGS) 9 | 10 | uninstall: 11 | dune uninstall $(INSTALL_ARGS) 12 | 13 | reinstall: uninstall reinstall 14 | 15 | clean: 16 | rm -rf _build 17 | 18 | .PHONY: default install uninstall reinstall clean 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Kekka - 結果 2 | ============ 3 | Kekka is a λ-k implementation ported from Daan Leijen's Kōka compiler, that will eventually act as Brick's type-inference engine. Kōka (効果) means 'effect' or 'effective', and in recognition of both that and the ultimate purpose of the type system, the name Kekka (結果) was chosen, meaning 'effect' (in the sense of a result or consequence of an action, a slightly different connotation). 4 | 5 | Unlike Kōka, which is a complete language, Kekka only strives to act as an inference and unification system, an intermediary step in the full process of compilation. Because of that, the goal is to have a completely AST-independent typing module that is not just usable by Brick/Kiln, but in other projects as well, like for error-checking and semantic analysis tools. 6 | 7 | ## Documentation 8 | Part of the reason I am porting this is to have a much better understanding of the internals of the system, as it is relatively complex when compared to something like a [simple HM engine](https://github.com/toroidal-code/hm-rb). I also want to explore the possibility of integrating function fragmentation and calling semantics similar to my experimentation in [HMc](https://github.com/toroidal-code/hm-ml), and see how far the effect recogniction can go in the area of concurrency and parallelization. 9 | 10 | As I go, I will be documenting what I learn and understand, in hopes that it may also be helpful for other people. Documentation will be sparsely annotated with LaTeX, which can (will be able to) be formatted using [YODA](https://github.com/toroidal-code/yoda). This will not be literate programming, but I hope to add a large amount of documentation on the things that I _do_ understand, as being very new to the field of programming language/type theory, I know from experience how hard it can be to get into. 11 | 12 | ## Licensing 13 | Kōka is licensed under the Apache License version 2.0. Because this is currently a direct port from Haskell to OCaml (for now), I consider Kekka to be a true derivative work, so it is also licensed under the APLv2. 14 | 15 | ## Development 16 | To get started working with Kekka, follow standard procedure for developing a project using OPAM: 17 | ```bash 18 | $ git clone https://github.com/brick-lang/kekka 19 | $ cd kekka 20 | $ opam install . --deps-only 21 | ``` 22 | The project can be built simply using 23 | ```bash 24 | $ dune build 25 | ``` 26 | or installed using 27 | ```bash 28 | $ opam install . 29 | ``` 30 | -------------------------------------------------------------------------------- /auto-format.el: -------------------------------------------------------------------------------- 1 | ;; Requires ocp-indent to be installed with opam 2 | ;; Run this file using: 3 | ;; emacs -q -batch **/*.ml -l [full path to kiln]/untabify.el 4 | 5 | (load-file "~/.opam/4.02.3/share/emacs/site-lisp/ocp-indent.el") 6 | 7 | (if (< 1 (count-windows)) 8 | (delete-other-windows (selected-window))) 9 | (catch 'tag 10 | (while t 11 | (untabify (point-min) (point-max)) 12 | (ocp-indent-region (point-min) (point-max)) 13 | (if buffer-file-name ; nil for *scratch* buffer 14 | (progn 15 | (write-file buffer-file-name) 16 | (kill-buffer (current-buffer))) 17 | (throw 'tag t)))) 18 | -------------------------------------------------------------------------------- /common/basicClasses.ml: -------------------------------------------------------------------------------- 1 | 2 | module type Eq = sig 3 | type t 4 | val equal : t -> t -> bool 5 | end 6 | 7 | (* let equal {E:Eq} x y = E.equal x y *) 8 | 9 | module type Ord = sig 10 | type t 11 | module Eq : Eq with type t = t 12 | val compare : t -> t -> int 13 | end 14 | 15 | (* let compare {O:Ord} x y = O.compare x y *) 16 | 17 | module type Show = sig 18 | type t 19 | val show : t -> string 20 | end 21 | 22 | (* let show {S:Show} x = S.show x *) 23 | 24 | -------------------------------------------------------------------------------- /common/concreteSyntax.ml: -------------------------------------------------------------------------------- 1 | 2 | module Expr = struct type 'a t end 3 | 4 | (***************************************************************** 5 | * Definitions 6 | *****************************************************************) 7 | 8 | module ValueBinder = struct 9 | type ('t,'e) t = { 10 | name : Name.t; 11 | typ : 't; (* Type. Always present for constructors. *) 12 | expr : 'e; (* Expression: always present for definitions as 'Expr t' 13 | * Function and constructor parameters use 'Maybe (Expr t)' for default values. 14 | * Pattern bindings ('PatVar') use unit '()'. *) 15 | } 16 | end 17 | 18 | (***************************************************************** 19 | * type definitions 20 | *****************************************************************) 21 | 22 | module TypeBinder = struct 23 | type 'a t = { 24 | name : Name.t; 25 | kind : 'a; 26 | (* name_range : Range.t; 27 | * range : Range.t; *) 28 | } 29 | end 30 | 31 | (** Constructor: name, existentials, type parameters, name range, total range, and visibility *) 32 | module UserCon = struct 33 | type ('t,'u,'k) t = { 34 | name : Name.t; 35 | exists : 'k TypeBinder.t list; 36 | params : (Syntax.Visibility.t * ('t, 'u Expr.t option) ValueBinder.t) list; 37 | vis : Syntax.Visibility.t; 38 | doc : string; 39 | } 40 | end 41 | 42 | module TypeDef = struct 43 | type ('t,'u,'k) t = 44 | | Synonym of { 45 | binder : 'k TypeBinder.t; 46 | params : 'k TypeBinder.t list; 47 | synonym : 't; 48 | vis : Syntax.Visibility.t; 49 | doc : string; 50 | } 51 | 52 | | DataType of { 53 | binder : 'k TypeBinder.t; 54 | params : 'k TypeBinder.t list; 55 | constrs : ('t, 'u, 'k) UserCon.t list; 56 | vis : Syntax.Visibility.t; 57 | sort : Syntax.DataKind.t; 58 | def : Syntax.DataDef.t; 59 | is_extend: bool; 60 | doc : string; 61 | } 62 | let is_extend = function DataType{is_extend=true} -> true | _ -> false 63 | let binder = function DataType{binder} | Synonym{binder} -> binder 64 | let is_datatype = function DataType _ -> true | _ -> false 65 | let is_synonym = function Synonym _ -> true | _ -> false 66 | end 67 | 68 | module TypeDefGroup = struct 69 | type ('t,'k) t = 70 | | Rec of ('t,'t,'k) TypeDef.t list 71 | | NonRec of ('t,'t,'k) TypeDef.t 72 | end 73 | 74 | 75 | (***************************************************************** 76 | * Types and Kinds 77 | *****************************************************************) 78 | module UserQuantifier = struct 79 | type t = Some | Forall | Exists 80 | let show = function 81 | | Some -> "some" 82 | | Forall -> "forall" 83 | | Exists -> "exists" 84 | end 85 | 86 | (** (Higher ranked) types *) 87 | module KindedUserType = struct 88 | type 'k t = 89 | | Quan of UserQuantifier.t * 'k TypeBinder.t * 'k t 90 | | Qual of 'k t list * 'k t 91 | | Fun of (Name.t * 'k t) list * 'k t * 'k t 92 | | App of 'k t * 'k t list 93 | | Var of Name.t 94 | | Con of Name.t 95 | | Parens of 'k t 96 | | Ann of 'k t * 'k 97 | end 98 | 99 | (** A kind *) 100 | module UserKind = struct 101 | type t = 102 | | Con of Name.t 103 | | Arrow of t * t 104 | | Parens of t 105 | | None (* flags that there is no explicit kind annotation *) 106 | end 107 | 108 | module UserType = struct 109 | type t = UserKind.t KindedUserType.t 110 | end 111 | 112 | (***************************************************************** 113 | * Core Program 114 | *****************************************************************) 115 | module Program = struct 116 | type ('t,'k) t = { 117 | name : Name.t; 118 | typedefs : ('t, 'k) TypeDefGroup.t list; 119 | } 120 | end 121 | -------------------------------------------------------------------------------- /common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name common) 3 | (public_name kekka.common) 4 | (library_flags -linkall) 5 | (libraries core ppx_inline_test.runtime-lib) 6 | (inline_tests) 7 | (preprocess 8 | (pps ppx_deriving.std ppx_sexp_conv ppx_inline_test))) 9 | -------------------------------------------------------------------------------- /common/failure.ml: -------------------------------------------------------------------------------- 1 | 2 | let assertwith msg test x = 3 | if test then x else failwith msg 4 | 5 | let todo msg = 6 | failwith ("todo: " ^ msg) 7 | 8 | let match_fail msg = 9 | failwith ("unmatched pattern: " ^ msg) 10 | -------------------------------------------------------------------------------- /common/id.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (* Types *) 4 | 5 | (** Identifiers are unique compiler generated identities *) 6 | type t = int 7 | [@@deriving show, sexp] 8 | 9 | let equal = Int.equal 10 | let compare = Int.compare 11 | 12 | (** A list of identifiers *) 13 | type ids = t list 14 | 15 | (** show quotes around the id *) 16 | let rec pp fmt id = 17 | Format.pp_print_string fmt @@ "\"" ^ (Int.to_string id) ^ "\"" 18 | 19 | (** create a fresh identifier *) 20 | let create (i:int) : t = i 21 | 22 | let create_from_id (id:t) : t = id + 1 23 | 24 | (** Generate an 'Id' with a certain base name (which is ignored) :) *) 25 | let generate base_name (id:t) = create id 26 | 27 | (* dummy identifier *) 28 | let nil : t = 0 29 | 30 | let number (i:t) : int = i 31 | 32 | module Map = Int.Map 33 | module Set = Int.Set 34 | -------------------------------------------------------------------------------- /common/monadic.ml: -------------------------------------------------------------------------------- 1 | (** Identity function *) 2 | let id x = x 3 | 4 | (** Constant function *) 5 | let const x _ = x 6 | let seq _ x = x 7 | 8 | (** Flip takes its (first) two arguments in the reverse order of f *) 9 | let flip f x y = f y x 10 | let flip2 f y z x = f x y z 11 | let flip3 f x y z w = f w x y z 12 | 13 | module type Monad = sig 14 | type 'a t 15 | val map : 'a t -> f:('a -> 'b) -> 'b t 16 | val return : 'a -> 'a t 17 | val bind : 'a t -> f:('a -> 'b t) -> 'b t 18 | end 19 | 20 | module type S = sig 21 | include Monad 22 | 23 | (* Functorial things *) 24 | val fmap : ('a -> 'b) -> 'a t -> 'b t 25 | 26 | val (<$) : 'a -> 'b t -> 'a t 27 | val ($>) : 'a t -> 'b -> 'b t 28 | val (<$>) : ('a -> 'b) -> 'a t -> 'b t 29 | val (<$$>) : 'a t -> ('a -> 'b) -> 'b t 30 | 31 | val ($<<) : 'a -> 'b -> 'a t 32 | val ($<) : 'a t -> 'b -> 'a t 33 | val (>>$) : 'a -> 'b -> 'b t 34 | val (>$) : 'a -> 'b t -> 'b t 35 | val ($>=) : 'a -> ('a -> 'b t) -> 'b t 36 | 37 | (* Applicative things *) 38 | val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t 39 | val ( *> ) : 'a t -> 'b t -> 'b t 40 | val ( <* ) : 'a t -> 'b t -> 'a t 41 | 42 | val ( <**> ) : 'a t -> ('a -> 'b) t -> 'b t 43 | 44 | (* Monadic things *) 45 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 46 | val (=<<) : ('a -> 'b t) -> 'a t -> 'b t 47 | val (>>) : 'a t -> 'b t -> 'b t 48 | 49 | val fail : string -> 'a t 50 | val join : 'a t t -> 'a t 51 | val ignore : 'a -> unit t 52 | 53 | val sequence : 'a t list -> 'a list t 54 | val sequence_ : 'a t list -> unit t 55 | val mapM : ('a -> 'b t) -> 'a list -> 'b list t 56 | val mapM_ : ('a -> 'b t) -> 'a list -> unit t 57 | val filterM : ('a -> bool t) -> 'a list -> 'a list t 58 | val forM : 'a list -> ('a -> 'b t) -> 'b list t 59 | val forM_ : 'a list -> ('a -> 'b t) -> unit t 60 | val forever : 'a t -> 'b t 61 | val void : 'a t -> unit t 62 | val foldM : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t 63 | val foldM_ : ('a -> 'b -> 'a t) -> 'a -> 'b list -> unit t 64 | val replicate : int -> 'a -> 'a list 65 | val replicateM : int -> 'a t -> 'a list t 66 | val replicateM_ : int -> 'a t -> unit t 67 | val mwhen : bool -> unit t -> unit t 68 | val unless : bool -> unit t -> unit t 69 | val liftM : ('a -> 'b) -> 'a t -> 'b t 70 | val liftM2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t 71 | val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t 72 | val liftM4 : 73 | ('a -> 'b -> 'c -> 'd -> 'e) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t 74 | val ap : ('a -> 'b) t -> 'a t -> 'b t 75 | end 76 | 77 | module Make(M : Monad) : S with type 'a t = 'a M.t = struct 78 | include M 79 | 80 | let pure = return 81 | 82 | let (>>=) a f = bind a ~f 83 | let fmap f a = map ~f a 84 | 85 | let (<$) x = fmap (const x) 86 | let ($>) x y = y <$ x 87 | let (<$>) = fmap 88 | let (<$$>) x y = fmap y x 89 | 90 | let (>$) x = fmap (seq x) 91 | let ($<) x y = y >$ x 92 | let (>>$) x y = (return x) $> y 93 | let ($<<) x y = y >>$ x 94 | 95 | let ($>=) x y = (return x) >>= y 96 | 97 | let liftM f m = m >>= fun x -> return (f x) 98 | let liftM2 f m1 m2 = m1 >>= fun x1 -> m2 >>= fun x2 -> return (f x1 x2) 99 | 100 | let (<*>) fs xs = fs >>= fun f -> xs >>= fun x -> return (f x) 101 | 102 | (** Sequence actions, discarding the value of the first argument *) 103 | let ( *> ) a1 a2 = (id <$ a1) <*> a2 104 | 105 | (** Sequence actions, discarding the value of the second argument. *) 106 | let ( <* ) a b = liftM2 const a b 107 | 108 | (** A variant of '<*>' with the arguments reversed. *) 109 | let (<**>) a b = liftM2 (flip (@@)) a b 110 | 111 | (* Sequential composition of two actions, discarding any value produced 112 | * by the first. Similar to semicolon normally. *) 113 | let (>>) m k = m >>= fun _ -> k 114 | 115 | let fail s = failwith s 116 | let join x = x >>= id 117 | 118 | (* Jane Street's 'map' is really '<$$>' *) 119 | let (>>|) = (<$$>) 120 | (* let ($$>) x y = (return x) $>> y *) 121 | 122 | let ignore t = return () 123 | 124 | let (=<<) x y = y >>= x 125 | 126 | let sequence ms = 127 | let k m n = 128 | m >>= fun x -> 129 | n >>= fun xs -> 130 | return (x::xs) 131 | in 132 | List.fold_right k ms (return []) 133 | 134 | let sequence_ ms = 135 | List.fold_right (>>) ms (return ()) 136 | 137 | let mapM f a = sequence (List.map f a) 138 | let mapM_ f a = sequence_ (List.map f a) 139 | 140 | let rec filterM p = function 141 | | [] -> return [] 142 | | x::xs -> 143 | p x >>= fun flg -> 144 | filterM p xs >>= fun ys -> 145 | return (if flg then x::ys else ys) 146 | 147 | let forM x y = mapM y x 148 | let forM_ x y = mapM_ y x 149 | 150 | let forever a = let rec b () = a >> b () in b () 151 | let void m = fmap (const ()) m 152 | 153 | let rec foldM f a = function 154 | | [] -> return a 155 | | x::xs -> f a x >>= fun fax -> foldM f fax xs 156 | 157 | let foldM_ f a xs = foldM f a xs >> return () 158 | 159 | let rec replicate n i = 160 | match n with 161 | | 0 -> [] 162 | | _ -> i::(replicate (n - 1) i) 163 | 164 | let replicateM n x = sequence (replicate n x) 165 | let replicateM_ n x = sequence_ (replicate n x) 166 | 167 | let mwhen p s = if p then s else return () 168 | let unless p s = if p then return () else s 169 | 170 | let liftM3 f m1 m2 m3 = m1 >>= fun x1 -> m2 >>= fun x2 -> m3 >>= fun x3 -> return (f x1 x2 x3) 171 | let liftM4 f m1 m2 m3 m4 = m1 >>= fun x1 -> m2 >>= fun x2 -> m3 >>= fun x3 -> m4 >>= fun x4 -> return (f x1 x2 x3 x4) 172 | let ap m1 m2 = liftM2 id m1 m2 173 | end 174 | -------------------------------------------------------------------------------- /common/name.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Core.Poly 3 | open BasicClasses 4 | open Util 5 | 6 | (********************************* 7 | * Names 8 | *********************************) 9 | (** 10 | * Names defined by the user. 11 | * Uses a hash to speed up comparisons. The hash is constructed 12 | * such that they can be compared too. (h1 > h2 => name1 > name2) 13 | * The hash is case-insensitive, just like comparisons on names. 14 | * Use 'case_equal' for case-sensitive comparisons. 15 | *) 16 | type t = { 17 | name_module : string; 18 | hash_module : int; 19 | name_id : string; 20 | hash_id : int; 21 | } [@@deriving sexp] 22 | 23 | let case_equal name1 name2 = 24 | (name1.name_module = name2.name_module) && 25 | (name1.name_id = name2.name_id) 26 | 27 | (* Checks whether both names are in the same namespace *) 28 | let is_same_namespace name1 name2 = 29 | if (String.length name1.name_id > 0) && (String.length name2.name_id > 0) then 30 | (Char.is_uppercase name1.name_id.[0]) = (Char.is_uppercase name2.name_id.[0]) 31 | else true 32 | 33 | let case_overlap name1 name2 = 34 | (not @@ case_equal name1 name2) && (is_same_namespace name1 name2) 35 | 36 | let lower_compare n1 n2 = 37 | match String.compare (String.lowercase n1.name_module) (String.lowercase n2.name_module) with 38 | | 0 -> String.compare (String.lowercase n1.name_id) (String.lowercase n2.name_id) 39 | | lg -> lg 40 | 41 | let equal n1 n2 = 42 | (n1.hash_id = n2.hash_id) && 43 | (n1.hash_module = n2.hash_module) && 44 | (lower_compare n1 n2 = 0) 45 | 46 | let compare n1 n2 = 47 | let c1 = Int.compare n1.hash_module n2.hash_module in 48 | let c2 = Int.compare n1.hash_id n2.hash_id in 49 | if c1 <> 0 then c1 50 | else if c2 <> 0 then c2 51 | else lower_compare n1 n2 52 | 53 | let show { name_module = m; name_id = n; _ } = 54 | if String.is_empty m then 55 | n 56 | else 57 | m ^ "/" ^ (let c = String.get m 0 in (* We're guranteed non-zero length *) 58 | if not (Char.is_alpha c || c = '_' || c ='(') then 59 | "(" ^ n ^ ")" 60 | else n) 61 | 62 | (** Show quotes around the name *) 63 | let pp fmt name = Format.pp_print_string fmt ("\"" ^ (show name) ^ "\"") 64 | 65 | let new_qualified m n = 66 | let string_take i s = s |> String.to_list |> Util.flip (List.take) i |> String.of_char_list in 67 | let short s = string_take 4 (String.lowercase s) in 68 | let hash s = String.fold ~init:0 ~f:(fun h c -> h*256 + (Char.to_int c)) (short s) in 69 | { name_module = m; hash_module = (hash m); name_id = n; hash_id = (hash n)} 70 | 71 | let create s = new_qualified "" s 72 | 73 | let nil = create "" 74 | 75 | let is_nil { name_module = m; name_id = n; _ } = String.is_empty n 76 | 77 | let qualify 78 | ({ name_module = x; name_id = m; hash_id = hm; _} as n1) 79 | ({ name_module = y; name_id = n; hash_id = hn; _} as n2) = 80 | if (String.is_empty x && String.is_empty y) || 81 | (String.is_empty x && m = y) then 82 | { name_module = m; hash_module = hm; name_id = n; hash_id = hn } 83 | else 84 | failwithf "Common.Name.qualify: Cannot use qualify on qualified names: (%s, %s)" (show n1) (show n2) () 85 | 86 | let unqualify { name_id = n; hash_id = hn; _ } = 87 | { name_module = ""; hash_module = 0; name_id = n; hash_id = hn } 88 | 89 | let is_qualified { name_module = m; _ } = 90 | not @@ String.is_empty m 91 | 92 | let qualifier { name_module = m; hash_module = hm; _} = 93 | { name_module = ""; hash_module = 0; name_id = m; hash_id = hm } 94 | 95 | (************************************************** 96 | * Modules paths 97 | **************************************************) 98 | 99 | let rec split_module_name name = 100 | if (is_qualified name) then 101 | split_module_name (qualifier name) 102 | else List.map ~f:create @@ String.split ~on:'/' (show name) 103 | 104 | let unsplit_module_name xs = 105 | create @@ String.concat ?sep:(Some "/") (List.map ~f:show xs) 106 | 107 | 108 | (************************************************** 109 | * wildcards & constructors 110 | **************************************************) 111 | 112 | let is_wildcard name = 113 | (String.length name.name_id) > 0 && 114 | (String.get name.name_id 0) = '_' 115 | 116 | let is_constructor_name name = 117 | if (String.length name.name_id) > 0 then 118 | let c = (String.get name.name_id 0) in 119 | (Char.is_uppercase c) || (c = '(') 120 | else false 121 | 122 | 123 | let to_constructor_name name = 124 | new_qualified name.name_module @@ String.capitalize name.name_id 125 | 126 | 127 | (************************************************** 128 | * wildcards & constructors 129 | **************************************************) 130 | 131 | let new_hidden_name s = 132 | create ("." ^ s) 133 | 134 | let is_hidden_name name = 135 | (String.length name.name_id) > 0 && 136 | (String.get name.name_id 0) = '.' 137 | 138 | let new_field_name i = 139 | new_hidden_name ("field" ^ i) 140 | 141 | let is_field_name = is_hidden_name 142 | 143 | let new_implicit_type_var_name i = 144 | new_hidden_name ("t" ^ i) 145 | 146 | let is_implicit_type_var_name = is_hidden_name 147 | 148 | (* let new_hidden_external_name name = *) 149 | (* new_hidden_name ((show name) ^ "@extern") *) 150 | 151 | (** Create a constructor creator name from the constructor name. 152 | * Used if special creation functions are used for the constructor. 153 | * in particular for the case of optional arguments. *) 154 | let prepend s name = 155 | new_qualified name.name_module (s ^ name.name_id) 156 | 157 | let postpend s name = 158 | new_qualified name.name_module (name.name_id ^ s) 159 | 160 | let new_creator_name = 161 | prepend ".create" 162 | 163 | 164 | (************************************************** 165 | * camel-case to dash-case 166 | **************************************************) 167 | 168 | let split_camel s = 169 | let rec split_camel_list = function 170 | | [] -> [] 171 | | c::cs when c = '-' -> split_camel_list cs 172 | | c::cs -> 173 | let is_break c = (Char.is_uppercase c || c = '-') in 174 | let all_but_last l = List.take l @@ (List.length l) - 1 in 175 | let (pre, post) = List.split_while ~f:(fun c -> not @@ is_break c) cs in 176 | if List.is_empty pre then 177 | let (pre2,post2) = List.split_while ~f:Char.is_uppercase post in 178 | if List.is_empty pre2 || (not (List.is_empty post2) && is_break (List.hd_exn post2)) 179 | then (c::pre2) :: split_camel_list post2 180 | else (c::(all_but_last pre2)) :: split_camel_list ((List.last_exn pre2)::post2) 181 | else (c::pre) :: split_camel_list post 182 | in 183 | String.to_list s |> split_camel_list |> List.map ~f:String.of_char_list 184 | 185 | 186 | let camel_to_dash s = 187 | match List.map ~f:String.lowercase (split_camel s) with 188 | | x::xs -> List.fold_left ~init:x ~f: (fun y ys -> y ^ "-" ^ ys) xs 189 | | [] -> "" 190 | 191 | (************************************************** 192 | * name to file path 193 | **************************************************) 194 | 195 | let show_hex len i = 196 | let show_hex_char = function 197 | | d when d <= 9 -> Char.of_int_exn (d + Char.to_int '0') 198 | | d -> Char.of_int_exn (d - 10 + Char.to_int '0') 199 | in 200 | let rec hex_digits i = 201 | let d = i / 16 in 202 | let m = i % 16 in 203 | if d = 0 then [m] 204 | else m::(hex_digits d) 205 | in 206 | let hexs = List.map ~f:show_hex_char (List.rev @@ hex_digits i) in 207 | String.of_char_list @@ List.init (len - (List.length hexs)) ~f:(fun _ -> '0') @ hexs 208 | 209 | (************************************************** 210 | * Ascii encode a name 211 | * - on module names '/' becomes '_' 212 | * - on normal names '.' becomes '_' name to file path 213 | **************************************************) 214 | 215 | let ascii_encode is_module name = 216 | let encode_char c = 217 | if Char.is_alphanum c then [c] 218 | else String.to_list @@ match c with 219 | | '/' when is_module -> "_" 220 | | '.' when not is_module -> "_" 221 | | '_' -> "__" 222 | | '.' -> "_dot_" 223 | | '-' -> "_dash_" 224 | | '+' -> "_plus_" 225 | | '*' -> "_star_" 226 | | '&' -> "_amp_" 227 | | '~' -> "_tilde_" 228 | | '!' -> "_excl_" 229 | | '@' -> "_at_" 230 | | '#' -> "_hash_" 231 | | '$' -> "_dollar_" 232 | | '%' -> "_perc_" 233 | | '^' -> "_hat_" 234 | | '=' -> "_eq_" 235 | | ':' -> "_colon_" 236 | | '<' -> "_lt_" 237 | | '>' -> "_gt_" 238 | | '[' -> "_lb_" 239 | | ']' -> "_rb_" 240 | | '?' -> "_ques_" 241 | | '/' -> "_fs_" 242 | | '\\'-> "_bs_" 243 | | '(' -> "_lp_" 244 | | ')' -> "_rp_" 245 | | ',' -> "_comma_" 246 | | ' ' -> "_space_" 247 | | '\'' -> "_sq_" 248 | | '\"' -> "_dq_" 249 | | '`' -> "_bq_" 250 | | '{' -> "_lc_" 251 | | '}' -> "_rc_" 252 | | _ -> "_x" ^ show_hex 2 (Char.to_int c) ^ "_" 253 | in 254 | let encode_chars s = 255 | let (dots,rest) = List.split_while ~f:(fun c -> c = '.') (String.to_list s) in 256 | String.of_char_list @@ (List.map ~f:(fun _ -> '_') dots) @ (List.concat_map ~f:encode_char rest) 257 | in 258 | if String.length name > 0 && Char.is_alphanum (String.get name 0) then 259 | encode_chars name 260 | else match name with 261 | | "" -> "_null_" 262 | | ".<>" -> "_Total_" 263 | | ".<|>" -> "_Extend_" 264 | | ".()" -> "_Unit_" 265 | | ".(,)" -> "_Tuple2_" 266 | | ".(,,)" -> "_Tuple3_" 267 | | ".(,,,)"-> "_Tuple4_" 268 | | "()" -> "_unit_" 269 | | "(,)" -> "_tuple2_" 270 | | "(,,)" -> "_tuple3_" 271 | | "(,,,)" -> "_tuple4_" 272 | | "[]" -> "_index_" 273 | | _ -> 274 | (* I hate OCaml string matching so much *) 275 | match String.to_list name with 276 | | '.'::'c'::'o'::'n'::' '::cs -> "_con_" ^ encode_chars (String.of_char_list cs) 277 | | '.'::'t'::'y'::'p'::'e'::' '::cs -> "_type_" ^ encode_chars (String.of_char_list cs) 278 | | _ -> encode_chars name 279 | 280 | 281 | let module_name_to_path name = 282 | ascii_encode true (show name) 283 | 284 | module Map = struct 285 | module C = Comparator.Make(struct 286 | type nonrec t = t 287 | let compare = compare 288 | let sexp_of_t = sexp_of_t 289 | end) 290 | include Map.Make_using_comparator(struct 291 | include C 292 | type nonrec t = t 293 | let t_of_sexp = t_of_sexp 294 | let sexp_of_t = sexp_of_t 295 | end) 296 | 297 | (* left-biased union(s) *) 298 | let union m1 m2 = 299 | merge m1 m2 ~f:(fun ~key -> function `Both(l,r) -> Some l | `Left l -> Some l | `Right r -> Some r) 300 | 301 | let rec union_list = function 302 | | [] -> empty 303 | | x::[] -> x 304 | | x::ys -> union x (union_list ys) 305 | end 306 | 307 | 308 | (*************************************************** 309 | * Primitives (originally in NamePrim) 310 | ***************************************************) 311 | let system_core = create "std/core" 312 | let core = create "core" 313 | let prelude_name s = qualify system_core @@ create s 314 | 315 | (* Special *) 316 | let expr = create ".expr" 317 | let typ = create ".type" 318 | let interactive_module = create "interactive" 319 | let interactive = create "interactive" 320 | let main = create "main" 321 | let copy = create ".copy" 322 | let op_expr = create ".opexpr" 323 | 324 | (* Primitive operations *) 325 | let if_ = create "if" 326 | let case = create "case" 327 | let unit = create "()" 328 | let pred_heap_div = prelude_name "hdiv" 329 | let return = prelude_name ".return" 330 | let trace = prelude_name "trace" 331 | let log = prelude_name "log" 332 | let effect_open = create ".open" 333 | 334 | (* Primitive constructors *) 335 | let true_ = prelude_name "True" 336 | let false_ = prelude_name "False" 337 | 338 | let just = prelude_name "Just" 339 | let nothing = prelude_name "Nothing" 340 | 341 | let optional = prelude_name "Optional" 342 | let optional_none = prelude_name "None" 343 | let tp_optional = prelude_name "optional" 344 | 345 | (* Lists *) 346 | let null = prelude_name "Nil" 347 | let cons = prelude_name "Cons" 348 | let enum_from_to = prelude_name "enumFromTo" 349 | let enum_from_then_to = prelude_name "enumFromThenTo" 350 | let tp_list = prelude_name "list" 351 | 352 | (* Primitive type constructors *) 353 | let effect_empty = prelude_name "<>" 354 | let effect_extend = prelude_name "<|>" 355 | let effect_append = create ".<+>" 356 | 357 | let tp_bool = prelude_name "bool" 358 | let tp_int = prelude_name "int" 359 | let tp_float = prelude_name "double" 360 | let tp_char = prelude_name "char" 361 | let tp_string = prelude_name "string" 362 | let tp_any = prelude_name "any" 363 | 364 | let tp_io = prelude_name "io" 365 | let tp_unit = prelude_name "()" 366 | let tp_ref = prelude_name "ref" 367 | let ref_ = prelude_name "ref" 368 | 369 | let tp_total = prelude_name "total" 370 | let tp_partial = prelude_name "exn" 371 | let tp_div = prelude_name "div" 372 | let tp_pure = prelude_name "pure" 373 | 374 | let tp_alloc = prelude_name "alloc" 375 | let tp_read = prelude_name "read" 376 | let tp_write = prelude_name "write" 377 | let tp_st = prelude_name "st" 378 | 379 | let tp_void = prelude_name "void" 380 | 381 | let tp_async = prelude_name "async" 382 | let tp_exception = prelude_name "exception" 383 | 384 | 385 | let tuple n = prelude_name ("(" ^ String.make (n - 1) ',' ^ ")") 386 | (* let%test _ = String.equal "()" (tuple 1).name_id 387 | * let%test _ = String.equal "(,,,)" (tuple 4).name_id *) 388 | 389 | let is_tuple (name : t) = 390 | let s = String.to_list name.name_id in 391 | (name.name_module) = (system_core.name_id) && 392 | (List.length s) >= 2 && 393 | (List.hd_exn s) = '(' && (List.last_exn s) = ')' && 394 | List.for_all ~f:((=) ',') (List.tl_exn (List.rev @@ List.tl_exn @@ List.rev s)) 395 | 396 | (* let%test _ = is_tuple { name_module = system_core.name_id; 397 | * name_id = "(,,,,,,,)"; 398 | * hash_id = 0; hash_module = 0 } *) 399 | 400 | let to_short_module_name (name:t) : t = 401 | let short = List.hd_exn @@ List.rev @@ split_module_name name in 402 | if equal short core then system_core else short 403 | 404 | (* Primitive kind constructors *) 405 | let kind_star = create "V" 406 | let kind_label = create "X" 407 | let kind_fun = create "->" 408 | let kind_pred = create "P" 409 | let kind_effect = create "E" 410 | let kind_heap = create "H" 411 | -------------------------------------------------------------------------------- /common/qNameMap.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module M = Map.Make(Name) 4 | type 'a t = (Name.t *'a) list M.t 5 | type 'a lookup = 6 | | Found of Name.t * 'a 7 | | Ambiguous of Name.t list 8 | | NotFound 9 | 10 | let empty : 'a t = M.empty 11 | let is_empty : 'a t -> bool = M.is_empty 12 | 13 | let single name x :'a t = M.singleton (Name.unqualify name) [(name,x)] 14 | 15 | (** Lookup a fully qualified name *) 16 | let lookup_q (name:Name.t) (m:'a t) : 'a option = 17 | match M.find m (Name.unqualify name) with 18 | | None -> None 19 | | Some xs -> List.Assoc.find xs name ~equal:Name.equal 20 | 21 | (** Lookup a potentially unqualified name within a module context. 22 | * (The module context is ignored if a qualified name is looked up) *) 23 | let lookup (context:Name.t) (name:Name.t) (m:'a t) : 'a lookup = 24 | match M.find m (Name.unqualify name) with 25 | | None -> NotFound 26 | | Some [(qname,x)] when not (Name.is_qualified name) -> Found(qname,x) 27 | | Some xs -> 28 | let qname = if Name.is_qualified name then name else Name.qualify context name in 29 | match List.filter xs ~f:(fun p -> Name.equal (fst p) qname) with 30 | | [(realname,x)] -> Found(realname,x) 31 | | _ -> Ambiguous (List.map ~f:fst xs) 32 | 33 | let filter_names ~(f:Name.t -> bool) : 'a t -> 'a t = 34 | M.map ~f:(List.filter ~f:(fun (name,_) -> f name)) 35 | 36 | let safe_combine (caller:string) (xs:(Name.t * 'a) list) (ys:(Name.t * 'a) list) : (Name.t * 'a) list = 37 | let ynames = List.map ys fst in 38 | let xnames = List.map xs fst in 39 | if List.exists xnames ~f:(List.mem ynames ~equal:Name.equal) then 40 | failwithf "Common.QNameMap.%s: overlapping names: (%s, %s)" 41 | caller (List.to_string ~f:Name.show xnames) (List.to_string ~f:Name.show ynames) () 42 | else xs @ ys 43 | 44 | let insert ~(name:Name.t) ~(data:'a) (m:'a t) : 'a t = 45 | M.change m (Name.unqualify name) 46 | ~f:(function None -> Some [(name,data)] 47 | | Some ys -> Some (safe_combine "insert" [(name,data)] ys)) 48 | 49 | let of_list : (Name.t * 'a) list -> 'a t = 50 | List.fold ~init:empty ~f:(fun qm (name,data) -> insert qm ~name ~data) 51 | 52 | let union (m1:'a t) (m2:'a t) : 'a t = 53 | List.fold (M.to_alist m2) ~init:m1 ~f:(fun acc (key,data) -> 54 | M.change acc key ~f:(function None -> Some data 55 | | Some ys -> Some (safe_combine "union" data ys))) 56 | 57 | let union_list (qs:'a t list) : 'a t = List.fold ~init:empty ~f:union qs 58 | 59 | let to_alist (m:'a t) : (Name.t * 'a) list = List.concat_map ~f:snd (M.to_alist m) 60 | -------------------------------------------------------------------------------- /common/syntax.ml: -------------------------------------------------------------------------------- 1 | (* Common syntactical constructs *) 2 | 3 | 4 | (******************************* 5 | Backend targets 6 | ********************************) 7 | 8 | module Target = struct 9 | type t = CS | JS | Default 10 | [@@deriving eq, ord] 11 | 12 | let show = function 13 | | CS -> "cs" 14 | | JS -> "js" 15 | | Default -> "" 16 | end 17 | 18 | module Host = struct 19 | type t = Node | Browser 20 | 21 | let show = function 22 | | Node -> "node" 23 | | Browser -> "browser" 24 | end 25 | 26 | (********************************* 27 | Visibility 28 | *********************************) 29 | module Visibility = struct 30 | type t = Public | Private 31 | [@@deriving eq, ord, show] 32 | 33 | let is_public = function 34 | | Public -> true 35 | | _ -> false 36 | 37 | let is_private = function 38 | | Private -> true 39 | | _ -> false 40 | end 41 | 42 | (************************************ 43 | Data Kind 44 | ************************************) 45 | module DataKind = struct 46 | type t = Inductive | CoInductive | Retractive 47 | [@@deriving eq] 48 | 49 | let show = function 50 | | Inductive -> "type" 51 | | CoInductive -> "cotype" 52 | | Retractive -> "rectype" 53 | 54 | let pp fmt dk = Format.pp_print_string fmt (show dk) 55 | end 56 | 57 | module DataDef = struct 58 | type t = Normal | Rec | Open 59 | [@@deriving eq] 60 | 61 | let is_rec = function Normal -> false | _ -> true 62 | let is_open = function Open -> true | _ -> false 63 | end 64 | 65 | (************************************ 66 | Definition Kind 67 | ************************************) 68 | 69 | module DefSort = struct 70 | type t = Fun | Val | Var 71 | [@@deriving eq, ord] 72 | 73 | let show = function 74 | | Fun -> "fun" 75 | | Val -> "val" 76 | | Var -> "var" 77 | end 78 | 79 | (************************************* 80 | Fixities 81 | *************************************) 82 | (** Operator associativity *) 83 | module Assoc = struct 84 | type t = None | Right | Left 85 | [@@deriving eq, show] 86 | end 87 | 88 | (** Operator fixity *) 89 | module Fixity = struct 90 | type t = 91 | | Infix of int * Assoc.t (* precedence and associativity *) 92 | [@equal fun (i1,a1) (i2,a2) -> (i1 = i2) && (Assoc.equal a1 a2)] 93 | | Prefix 94 | | Postfix 95 | [@@deriving show, eq] 96 | end 97 | 98 | -------------------------------------------------------------------------------- /common/unique.ml: -------------------------------------------------------------------------------- 1 | (* Instead of using a monad, I'll be using OCaml's global state/ref system. Like a hack. *) 2 | let counter = 3 | let count = ref (-1) in 4 | fun () -> incr count; !count 5 | 6 | open Core 7 | 8 | let unique = counter 9 | let uniques n = List.init n ~f:Util.id |> List.map ~f:(fun _ -> unique ()) 10 | let unique_id basename = Id.generate basename (unique ()) 11 | let unique_ids basename n = List.map ~f:(Id.generate basename) (uniques n) 12 | let unique_name basename = Name.new_hidden_name (basename ^ "." ^ Int.to_string (unique ())) 13 | -------------------------------------------------------------------------------- /common/util.ml: -------------------------------------------------------------------------------- 1 | include Core.Fn 2 | 3 | let (<.>) (f:'b -> 'c) (g:'a -> 'b) (x:'a) = f @@ g x 4 | let (<.:>) f g x y = f @@ g x y 5 | let until p f = 6 | let rec go = function 7 | | x when p x -> x 8 | | x -> go @@ f x 9 | in go 10 | 11 | 12 | (* Implementation of arrows for functions *) 13 | let (<<<) f g x = f @@ g x 14 | let (>>>) f g x = g @@ f x 15 | let arr f = f 16 | let ( *** ) f g (x,y) = (f x, g y) 17 | let first f = f *** id 18 | let second f = id *** f 19 | let (&&&) f g = arr (fun b -> (b,b)) >>> f *** g 20 | let return = id 21 | let (<<^) a f = a <<< arr f 22 | let (^<<) a f = arr f <<< a 23 | let (^>>) a f = arr f >>> a 24 | let (>>^) a f = a >>> arr f 25 | 26 | module List = struct 27 | include Core.List 28 | let guard = function 29 | | true -> return () 30 | | false -> [] 31 | end 32 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name kekka) 3 | (public_name kekka) 4 | (libraries core kindEngine typeEngine)) 5 | (env 6 | (dev 7 | (flags (:standard -warn-error -A)))) 8 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name kekka) 3 | -------------------------------------------------------------------------------- /heart/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name heart) 3 | (public_name kekka.heart) 4 | (libraries core common) 5 | (preprocess 6 | (pps ppx_deriving.std ppx_sexp_conv))) 7 | -------------------------------------------------------------------------------- /heart/expr.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | 4 | type tname = Name.t * Type.typ 5 | let get_name tname = fst tname 6 | 7 | (************************************************ 8 | * Type definitions 9 | ************************************************) 10 | 11 | module TypeDef = struct 12 | type t = 13 | | Synonym of { syn_info : Type.syn_info; 14 | vis : Syntax.Visibility.t } 15 | 16 | | Data of { data_info : Type.data_info; 17 | vis : Syntax.Visibility.t; 18 | con_vis : Syntax.Visibility.t list; 19 | is_extend : bool } (* true if this is an extension of the datatype *) 20 | type group = t list 21 | type groups = group list 22 | let is_extension = function 23 | | Data{is_extend=true} -> true 24 | | _ -> false 25 | end 26 | 27 | (************************************************ 28 | * Data representation 29 | ************************************************) 30 | module ConRepr = struct 31 | type t = 32 | | Enum of {type_name : Name.t; tag : int} (* part of enumeration (none has fields) *) 33 | | Iso of {type_name : Name.t; tag : int} (* one constructor with one field *) 34 | | Singleton of {type_name : Name.t; tag : int} (* the only constructor without fields *) 35 | | Single of {type_name : Name.t; tag : int} (* there is only one constructor *) 36 | | Struct of {type_name : Name.t; tag : int} (* constructor as value type *) 37 | | AsCons of {type_name : Name.t; tag : int; (* constructor is the cons node of a list-like datatype (may have one or more fields) *) 38 | as_nil: Name.t } 39 | | Open of {type_name : Name.t} (* constructor of open data type *) 40 | | Normal of {type_name : Name.t; tag : int} (* a regular constructor *) 41 | end 42 | 43 | (**************************************************************************** 44 | * Expressions 45 | * 46 | * Since this is System-F, all binding sites are annotated with their type. 47 | ****************************************************************************) 48 | type expr = 49 | | Lam of tname list * Type.effect * expr 50 | 51 | (* typed name and possible type-arity/parameter-arity tuple for top-level functions *) 52 | | Var of { var_name : tname; var_info : var_info} 53 | | App of expr * (expr list) 54 | 55 | (* Type (universal) abstraction application *) 56 | | TypeLam of Type.TypeVar.t list * expr 57 | | TypeApp of expr * (Type.typ list) 58 | 59 | (* Literals, constants, and labels *) 60 | | Constructor of { con_name : tname; con_repr : ConRepr.t} 61 | | Literal of literal 62 | 63 | (* Let *) 64 | | Let of def_group list * expr 65 | 66 | (* Case expressions *) 67 | | Case of { case_exprs : expr list; case_branches : branch list} 68 | 69 | and var_info = 70 | | InfoNone 71 | | InfoArity of int * int (* type-parameters-arity, parameters-arity*) 72 | | InfoExternal of (Syntax.Target.t * string) list 73 | 74 | and branch = { 75 | branch_patterns : pattern list; 76 | branch_guards : guard list; 77 | } 78 | 79 | and guard = { 80 | guard_test : expr; 81 | guard_expr : expr; 82 | } 83 | 84 | and pattern = 85 | | PatConstructor of { pat_con_name : tname 86 | ; pat_con_patterns : pattern list 87 | ; pat_con_repr : ConRepr.t 88 | ; pat_type_args : Type.typ list 89 | ; pat_type_res : Type.typ 90 | (* ; pat_con_info : con_info *) 91 | } 92 | 93 | | PatVariable of { pat_name : tname; pat_pattern : pattern } 94 | | PatLiteral of { pat_lit : literal } 95 | | PatWild 96 | and literal = 97 | | Int of int 98 | | Float of float 99 | | Char of char 100 | | String of string 101 | 102 | and def = { 103 | def_name : Name.t; 104 | def_type : Type.scheme; 105 | def_expr : expr; 106 | def_vis : Syntax.Visibility.t; 107 | (* def_sort : def_sort; *) 108 | (* def_name_range : range; *) 109 | def_doc : string; 110 | } 111 | 112 | and def_group = 113 | | DefRec of def list 114 | | DefNonRec of def 115 | 116 | (* Create a phantom application that opens the effect type of a function *) 117 | let open_effect_expr 118 | (eff_from : Type.effect) (eff_to : Type.effect) 119 | (tp_from : Type.typ) (tp_to : Type.typ) 120 | (expr : expr) : expr = 121 | let open Type in 122 | let a = Type.TypeVar.{ id = -1; kind = Kind.Prim.effect; flavour = Bound } in 123 | let b = Type.TypeVar.{ id = -2; kind = Kind.Prim.effect; flavour = Bound } in 124 | (* forall a b. fun(x:tp_from)-> tp_to[total] *) 125 | let tp_open : typ = TForall([a;b], [], TFun([(Name.create "x", tp_from)], Type.type_total, tp_to)) in 126 | let var_open : expr = Var { var_name = (Name.effect_open, tp_open) 127 | ; var_info = (InfoExternal [(Default, "#1")])} 128 | in 129 | App ((TypeApp(var_open, [eff_from; eff_to])), [expr]) 130 | 131 | (*********************************************************** 132 | * Auxiliary functions to build Heart terms 133 | ***********************************************************) 134 | 135 | (** Add kind and type application *) 136 | let add_type_apps (ts: Type.TypeVar.t list) (e:expr) : expr = match (ts,e) with 137 | | ([], e) -> e 138 | | (ts, TypeApp(e, args)) -> TypeApp(e, args @ List.map ts ~f:(fun t -> Type.TVar t)) 139 | | (ts, e) -> TypeApp(e, List.map ts ~f:(fun t -> Type.TVar t)) 140 | 141 | let add_type_lambdas (pars: Type.TypeVar.t list) (e:expr) : expr = match (pars, e) with 142 | | ([], e) -> e 143 | | (pars, TypeLam(ps, e)) -> TypeLam(pars @ ps, e) 144 | | (pars, e) -> TypeLam(pars, e) 145 | 146 | 147 | (** Create a fresh variable name with a particular prefix *) 148 | let fresh_name (prefix:string) : Name.t = 149 | Name.create (prefix ^ "." ^ string_of_int (Unique.unique ())) 150 | -------------------------------------------------------------------------------- /heart/kind.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Definitions of kinds and helper functions 3 | * For more information, see Figure 1. of the paper. 4 | *) 5 | 6 | open Core 7 | open Common 8 | 9 | (** Kinds *) 10 | type t = 11 | | Constant of Name.t (* kind constants "*", "->","!", "H", "P" *) 12 | | App of t * t (* Application (only allowed for functions as yet) *) 13 | [@@deriving eq,show,sexp] 14 | 15 | (** 16 | * Kind and Type variables come in three flavours: 'Unifiable' 17 | * variables can be unified, 'Skolem' are non-unifiable (fresh) 18 | * variables, and 'Bound' variables are bound by a quantifier. *) 19 | module Flavour = struct 20 | type t = Meta | Skolem | Bound 21 | [@@deriving show,eq,ord,sexp] 22 | end 23 | 24 | module Prim = struct 25 | (* Kind @*@ *) 26 | let star = Constant Name.kind_star 27 | 28 | (* Kind @Label@ *) 29 | let label = Constant Name.kind_label 30 | 31 | (* Kind arrow @->@ *) 32 | let arrow = Constant Name.kind_fun 33 | 34 | let pred = Constant Name.kind_pred 35 | 36 | let effect = Constant Name.kind_effect 37 | 38 | let heap = Constant Name.kind_heap 39 | 40 | (** Create a (kind) function from a kind to another kind *) 41 | let fun_1 k1 k2 = App(App(arrow, k1), k2) 42 | 43 | let arrow_n (n:int) = 44 | List.fold_right ~f:fun_1 ~init:(fun_1 effect star) @@ 45 | List.init n ~f:(fun _ -> star) 46 | 47 | let extend = fun_1 label (fun_1 effect effect) (* label -> (effect -> effect) *) 48 | end 49 | 50 | let is_kind_fun : t -> bool = function 51 | | App(App(k0,k1),k2) -> phys_equal (k0) (Prim.arrow) 52 | | _ -> false 53 | 54 | let rec extract_kind_fun : t -> (t list * t) = function 55 | | App(App(k0,k1),k2) when 56 | phys_equal k0 (Prim.arrow) -> 57 | let (args,res) = extract_kind_fun k2 in 58 | ((k1::args), res) 59 | 60 | | k -> ([],k) 61 | 62 | let is_star (k:t) : bool = phys_equal k (Prim.star) 63 | let is_effect (k:t) : bool = phys_equal k (Prim.effect) 64 | 65 | let builtin_kinds : (Name.t * t) list = 66 | [ 67 | (Name.kind_star, Prim.star); (* Value *) 68 | (Name.kind_fun, Prim.arrow); (* Type constructor *) 69 | (Name.kind_pred, Prim.pred); (* Predicate *) 70 | (Name.kind_effect, Prim.effect); (* Effect constants *) 71 | (Name.kind_label, Prim.label); (* Labels *) 72 | (Name.kind_heap, Prim.heap) (* Heaps *) 73 | ] 74 | 75 | -------------------------------------------------------------------------------- /heart/type.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * type.ml 3 | * Ported from Daan Leijin's implementation, 4 | * which is licensed under the APLv2.0 5 | * Copyright 2012 Microsoft Corporation, Daan Leijen 6 | * Copyright 2015 Katherine Whitlock 7 | *) 8 | open Common 9 | 10 | (** This is the primary type-system, the heart of $\lambda^k$ *) 11 | 12 | 13 | (** 14 | * Type variables are variables in a type and contain an identifier and 15 | * kind. One can ask for the free type variables in a type, and substitute 16 | * them with '$\tau$' types. 17 | * Eg. $\alpha^K$ *) 18 | module TypeVar = struct 19 | type t = { 20 | id : Id.t; 21 | kind : Kind.t; 22 | flavour : Kind.Flavour.t; 23 | } [@@deriving show, sexp] 24 | 25 | let equal tv1 tv2 = Id.equal tv1.id tv2.id 26 | let compare tv1 tv2 = Id.compare tv1.id tv2.id 27 | end 28 | 29 | (** Type constants have a name and a kind. 30 | * Eg. $c^K$ *) 31 | module TypeCon = struct 32 | type t = { 33 | name : Name.t; 34 | kind : Kind.t; 35 | } [@@deriving show, sexp] 36 | 37 | let equal tc1 tc2 = Name.equal tc1.name tc2.name 38 | let compare tc1 tc2 = Name.compare tc1.name tc2.name 39 | end 40 | 41 | 42 | (** Types in the paper were presented as: 43 | * 44 | * $\tau^K ::= \alpha^K$ 45 | * $\qquad |\ c^K$ 46 | * $\qquad |\ c^{K_0}\langle \tau_1^{K_1}, \ldots,$$\tau_n^{K_n} \rangle$ 47 | * 48 | * where: 49 | * * $\alpha^k$ is a type variable, using $\mu$ for effects, $\xi$ for heaps 50 | * * $c^K$ is a type constant 51 | * * $K_0$ is C's type constructor kind, given by $K_0=(K_1,\ldots,K_n) \rightarrow K$ 52 | * $K$ is a type's kind. The kind system gurantees that types $\tau$ are 53 | * well-formed. The formal definitions of kinds are: 54 | * $K ::= * | e | k | h$ : values, effect rows, effect constants, and heaps, respectively 55 | * $\quad\ | (K_1,\ldots,K_n) \rightarrow K$ : type constructor 56 | **) 57 | type typ = 58 | 59 | (** 60 | * $\forall a b c. \phi, \psi \Rightarrow \rho$ 61 | * there is at least one variable 62 | * every variable occurs at least once in rho 63 | * variables and predicates are canonically ordered 64 | * each predicate refers to at least one of the variables. 65 | * Rho is really $\rho^\star$, where its kind is the set of all kinds (Kleene star) *) 66 | | TForall of TypeVar.t list * pred list * rho 67 | 68 | 69 | (** $(x:a, y:b, z:c) \rightarrow m\ d$ *) 70 | | TFun of ((Name.t * typ) list) * effect * typ 71 | 72 | (** a type constant (primitive, label, or newtype; not $\rightarrow$ or $\Rightarrow$) *) 73 | | TCon of TypeCon.t 74 | 75 | (** type variable (cannot instantiate to $\rightarrow$ or $\Rightarrow$) *) 76 | | TVar of TypeVar.t 77 | 78 | (** application of datatypes *) 79 | | TApp of typ * (typ list) 80 | 81 | (** 82 | * type synonym indirection 83 | * first (type list) is the actual arguments 84 | * final typ is the "real" type (expanded) (it always has kind '$\star$' (Kleene star)) *) 85 | | TSyn of type_syn * (typ list) * typ 86 | 87 | and pred = PredSub of typ * typ 88 | | PredIFace of Name.t * typ list 89 | 90 | (** Various synonyms of types *) 91 | and scheme = typ 92 | and sigma = typ (* polymorphic type *) 93 | and tau = typ (* monomorphic type *) 94 | and rho = typ (* unqualified type *) 95 | and effect = tau 96 | 97 | (** An inference type can contain type variables of flavour 'Meta' or 'Skolem' *) 98 | and infer_type = typ 99 | 100 | 101 | (** 102 | * The flavour of a type variable. Types in a 'Type.assumption' ($\Gamma$) and 103 | * inferred types in "Core.core" are always of the 'Bound' flavour. 104 | * 'Meta' and 'Skolem' type variables only ever occur during type inference. *) 105 | (* TODO: Figure out why this was redeclared from Kind.flavour? *) 106 | (* and flavour = Kind.Flavour.t *) 107 | 108 | 109 | (** Type synonyms have an identifier, kind, and rank (used for partial ordering among type synonyms) 110 | * Eg. $\alpha^K_r$ *) 111 | and type_syn = { 112 | type_syn_name : Name.t; 113 | type_syn_kind : Kind.t; 114 | type_syn_rank : synonym_rank; 115 | type_syn_info : syn_info option; 116 | } 117 | 118 | 119 | (** The rank of a type synonym gives a relative ordering among them. This is used 120 | * during unification to increase the chance of matching up type synonyms. *) 121 | and synonym_rank = int 122 | 123 | 124 | (***************************************************************** 125 | Information about types 126 | 127 | Defined here to avoid circular dependencies 128 | *****************************************************************) 129 | 130 | (** Data type information: name, kind, type arguments, and constructors *) 131 | and data_info = { 132 | data_info_sort : Syntax.DataKind.t; 133 | data_info_name : Name.t; 134 | data_info_kind : Kind.t; 135 | data_info_params : TypeVar.t list; (** arguments *) 136 | data_info_constrs : con_info list; 137 | (* data_info_range : range; *) (** location information *) 138 | data_info_def : Syntax.DataDef.t; 139 | data_info_doc : string 140 | } 141 | 142 | (** Constructor information: constructor name, name of the newtype, 143 | * field types, and the full type of the constructor *) 144 | and con_info = { 145 | con_info_name : Name.t; 146 | con_info_type_name : Name.t; 147 | con_info_foralls : TypeVar.t list; (** quantifiers *) 148 | con_info_exists : TypeVar.t list; (** existentials *) 149 | con_info_params : (Name.t * typ) list; (** field types *) 150 | con_info_type : scheme; 151 | con_info_type_sort : Syntax.DataKind.t; 152 | (* con_info_range : range; *) (** Source code position information *) 153 | (* con_info_param_ranges : range list; *) 154 | con_info_param_vis : Syntax.Visibility.t list; 155 | con_info_singleton : bool; (** is this the only constructor of this type? *) 156 | con_info_doc : string 157 | } 158 | 159 | (** A type synonym is quantified by type parameters *) 160 | and syn_info = { 161 | syn_info_name : Name.t; 162 | syn_info_kind : Kind.t; 163 | syn_info_params : TypeVar.t list; (** parameters *) 164 | syn_info_typ : typ; (** result type *) 165 | syn_info_rank : synonym_rank; 166 | (* syn_info_range : range; *) 167 | syn_info_doc : string; 168 | } 169 | 170 | open Core 171 | 172 | module rec Show_typ : BasicClasses.Show with type t = typ = struct 173 | type t = typ 174 | let show s = 175 | let rec show' = function 176 | | TForall (tvs, ps, r) -> "TForall" 177 | | TFun (nts,e,t) -> "TFun" 178 | | TCon tc -> "TCon" 179 | | TVar tv -> "TVar" (* " (" ^ Show ^")" *) 180 | | TApp (t,ts) -> Printf.sprintf "TApp (%s,%s)" (show' t) (List.to_string ts ~f:show') 181 | | TSyn (ts,tls,t) -> Printf.sprintf "TSyn (%s,%s,%s)" 182 | (Show_type_syn.show ts) (List.to_string tls ~f:show') (show' t) 183 | in show' s 184 | end 185 | 186 | and Show_pred : BasicClasses.Show with type t = pred = struct 187 | type t = pred 188 | let show = function 189 | | PredSub (t1,t2) -> Printf.sprintf "PredSub (%s,%s)" (Show_typ.show t1) (Show_typ.show t2) 190 | | PredIFace (n,ts) -> 191 | Printf.sprintf "PredIFace (%s,%s)" (Name.show n) (List.to_string ts ~f:Show_typ.show) 192 | end 193 | 194 | and Show_type_syn : BasicClasses.Show with type t = type_syn = struct 195 | type t = type_syn 196 | let show s = Printf.sprintf "{ type_syn_name : %s; type_syn_kind : %s; type_syn_rank : %s; type_syn_info : %s }" 197 | (Name.show s.type_syn_name) (Kind.show s.type_syn_kind) 198 | (string_of_int s.type_syn_rank) 199 | (match s.type_syn_info with None -> "None" 200 | | Some i -> "("^ Show_syn_info.show i ^")") 201 | end 202 | 203 | and Show_syn_info : BasicClasses.Show with type t = syn_info = struct 204 | type t = syn_info 205 | let show s = Printf.sprintf "{ name : %s; kind : %s; params : %s; typ : %s; rank : %s; doc : %s }" 206 | (Name.show s.syn_info_name) (Kind.show s.syn_info_kind) 207 | (List.to_string s.syn_info_params ~f:(fun e -> TypeVar.show e)) 208 | (Show_typ.show s.syn_info_typ) (string_of_int s.syn_info_rank) 209 | s.syn_info_doc 210 | end 211 | 212 | let show_con_info (info:con_info) = Name.show info.con_info_name 213 | 214 | let pp_con_info fmt info = Format.pp_print_string fmt @@ show_con_info info 215 | 216 | let rec max_synonym_rank (tp:typ) : synonym_rank = 217 | let max_synonym_ranks : typ list -> int = 218 | List.fold_right ~f:(fun a b -> max (max_synonym_rank a) b) ~init:0 219 | in 220 | match tp with 221 | | TForall(_,_,rho) -> max_synonym_rank rho 222 | | TFun(args,eff,tp) -> max_synonym_ranks (tp::eff::(List.map ~f:snd args)) 223 | | TCon _ -> 0 224 | | TVar _ -> 0 225 | | TApp(tp,tps) -> max_synonym_ranks (tp::tps) 226 | | TSyn(syn,args,tp) -> max syn.type_syn_rank (max_synonym_ranks @@ tp::args) (* TODO: replace nested destructure with proper accessor call *) 227 | 228 | (*************************************************** 229 | Predicates 230 | ***************************************************) 231 | 232 | (** Is a type variable 'Bound'? *) 233 | let is_bound tv = 234 | match tv.TypeVar.flavour with Bound -> true | _ -> false 235 | 236 | (** Is a type variable 'Meta' (and thus unifiable) ? *) 237 | let is_meta tv = 238 | match tv.TypeVar.flavour with Meta -> true | _ -> false 239 | 240 | (** Is a type variable 'Skolem' (and thus not unifiable) ? *) 241 | let is_skolem tv = 242 | match tv.TypeVar.flavour with Skolem -> true | _ -> false 243 | 244 | (***************************************************** 245 | Equality 246 | *****************************************************) 247 | 248 | let eq_type_syn ts1 ts2 = Name.equal ts1.type_syn_name ts2.type_syn_name 249 | let compare_type_syn ts1 ts2 = Name.compare ts1.type_syn_name ts2.type_syn_name 250 | 251 | (****************************************************** 252 | Split/add quantifiers 253 | ******************************************************) 254 | 255 | (** Split type into a list of universally quantified 256 | * type variables, a list of predicates, and a rho-type. 257 | * $\tau^K \rightarrow ([\forall \alpha \beta \gamma \ldots], [pred], \rho$) *) 258 | let rec split_pred_type (tp:typ) : (TypeVar.t list * pred list * rho) = 259 | (* We must split a synonym if its expansion 260 | * includes further quantifiers or predicates *) 261 | let rec must_split = function 262 | | TForall _ -> true 263 | | TSyn(_,_,tp) -> must_split tp 264 | | _ -> false 265 | in match tp with 266 | | TForall(vars,preds,rho) -> (vars, preds, rho) 267 | | TSyn(_,_,tp) when must_split tp -> split_pred_type tp 268 | | tp -> ([], [], tp) 269 | 270 | (** split a function type into its arguments, effect, and result type *) 271 | let rec split_fun_type = function 272 | | TFun(args,effect,result) -> Some (args,effect,result) 273 | | TSyn(_,_,t) -> split_fun_type t 274 | | _ -> None 275 | 276 | 277 | (* Find all quantified type variables, but do not expand synonyms *) 278 | let shallow_split_vars = function 279 | | TForall(vars,preds,rho) -> (vars,preds,rho) 280 | | tp -> ([], [], tp) 281 | 282 | 283 | (* Find all predicates *) 284 | let shallow_split_preds = function 285 | | TForall(_,preds,_) -> preds 286 | | _ -> [] 287 | 288 | 289 | let rec expand_syn = function 290 | | TSyn(syn,args,tp) -> expand_syn tp 291 | | tp -> tp 292 | 293 | 294 | let tForall (vars : TypeVar.t list) (preds : pred list) (rho : rho) : scheme = 295 | match (vars, preds) with 296 | | ([],[]) -> rho 297 | | _ -> TForall(vars,preds,rho) 298 | 299 | (** Create a type scheme from a list of quantifiers *) 300 | let make_scheme (vars : TypeVar.t list) (rho:rho) : scheme = 301 | let (vars0,preds,t) = split_pred_type rho in 302 | tForall (vars @ vars0) preds t 303 | 304 | let quantify (vars : TypeVar.t list) (tp : scheme) : scheme = 305 | let (vars0,preds,rho) = split_pred_type tp in 306 | tForall (vars @ vars0) preds rho 307 | 308 | let qualify (preds : pred list) (tp : scheme) : scheme = 309 | let (vars,preds0,rho) = split_pred_type tp in 310 | tForall vars (preds @ preds0) rho 311 | 312 | let rec apply tp1 tp2 = 313 | let rec must_split = function 314 | | TApp(_,_) -> true 315 | | TSyn(_,_,tp) -> must_split tp 316 | | _ -> false 317 | in match tp1 with 318 | | TApp(tp,tps) -> TApp(tp, tps @ [tp2]) 319 | | TSyn(_,_,tp) 320 | when must_split tp -> apply tp tp2 321 | | _ -> TApp(tp1,[tp2]) 322 | 323 | let get_con_arities tp = 324 | let (tvars,preds,rho) = split_pred_type tp in 325 | match split_fun_type rho with 326 | | Some((pars,eff,res)) -> (List.length tvars, List.length pars) 327 | | None -> (List.length tvars, 0) 328 | 329 | 330 | (**************************************************** 331 | Assertions 332 | ****************************************************) 333 | 334 | (** Is this a type variable? *) 335 | let rec is_TVar = function 336 | | TVar(tv) -> true 337 | | TSyn(_,_,t) -> is_TVar t 338 | | _ -> false 339 | 340 | (** Is this a type constant? *) 341 | let rec is_TCon = function 342 | | TCon(c) -> true 343 | | TSyn(_,_,t) -> is_TCon t 344 | | _ -> false 345 | 346 | (** Verify that a type is a $\rho$ type 347 | * i.e, no outermost quantifiers *) 348 | let rec is_Rho = function 349 | | TForall _ -> false 350 | | TSyn(_,_,t) -> is_Rho t 351 | | _ -> true 352 | 353 | (** Is this a type constant? *) 354 | let rec is_Tau = function 355 | | TForall _ -> false 356 | | TFun(xs,e,r) -> List.for_all ~f:(fun x -> is_Tau @@ snd x) xs && is_Tau e && is_Tau r (* TODO: e should always be tau *) 357 | | TCon _ -> true 358 | | TVar _ -> true 359 | | TApp(a,b) -> is_Tau a && List.for_all ~f:is_Tau b 360 | | TSyn(_,ts,t) -> is_TCon t 361 | 362 | 363 | (** Is this a function type? *) 364 | let rec is_Fun tp = 365 | match split_fun_type tp with 366 | | Some (args,effect,res) -> true 367 | | None -> false 368 | 369 | (**************************************************** 370 | Primitive types 371 | ****************************************************) 372 | 373 | let tcon_int = TypeCon.{name = Name.tp_int; kind = Kind.Prim.star } 374 | 375 | (** Type of integers (@Int@) *) 376 | let type_int : tau = TCon(tcon_int) 377 | 378 | let is_type_int = function 379 | | TCon(tc) -> TypeCon.equal tc tcon_int 380 | | _ -> false 381 | 382 | (** Type of floats *) 383 | let type_float : tau = TCon{ name = Name.tp_float; kind = Kind.Prim.star} 384 | 385 | let tcon_char : TypeCon.t = { name = Name.tp_char; kind = Kind.Prim.star} 386 | 387 | (** Type of characters *) 388 | let type_char : tau = TCon(tcon_char) 389 | 390 | let is_type_char = function 391 | | TCon(tc) -> TypeCon.equal tc tcon_char 392 | | _ -> false 393 | 394 | let tcon_string : TypeCon.t = {name=Name.tp_string; kind=Kind.Prim.star} 395 | 396 | (** Type of strings *) 397 | let type_string : tau = TCon(tcon_string) 398 | 399 | let label_name (tp : tau) : Name.t = 400 | match expand_syn tp with 401 | | TCon(tc) -> tc.TypeCon.name 402 | | TApp(TCon(tc),_) -> 403 | Failure.assertwith "non-expanded type synonym used as a label" (not @@ Name.equal tc.TypeCon.name Name.effect_extend) tc.TypeCon.name 404 | | _ -> failwith "Type.Unify.label_name: label is not a constant" 405 | 406 | let effect_empty : tau = 407 | TCon{name = Name.effect_empty; kind = Kind.Prim.effect } 408 | 409 | let is_effect_empty (tp : tau) : bool = 410 | match expand_syn tp with 411 | | TCon tc -> Name.equal tc.TypeCon.name Name.effect_empty 412 | | _ -> false 413 | 414 | let tcon_effect_extend : TypeCon.t = 415 | { name = Name.effect_extend; kind = (Kind.Prim.fun_1 Kind.Prim.label (Kind.Prim.fun_1 Kind.Prim.effect Kind.Prim.effect)) } 416 | 417 | let rec extract_effect_extend (t : tau) : tau list * tau = 418 | let extract_label (l : tau) : tau list = 419 | match expand_syn l with 420 | | TApp(TCon(tc),[_;e]) when (Name.equal tc.name Name.effect_extend) -> 421 | let (ls,tl) = extract_effect_extend l in 422 | Failure.assertwith "label was not a fixed effect type alias" (is_effect_fixed tl) ls 423 | | _ -> [l] 424 | in 425 | match expand_syn t with 426 | | TApp(TCon(tc),[l;e]) when (Name.equal tc.name Name.effect_extend) -> 427 | let (ls,tl) = extract_effect_extend e in 428 | let ls0 = extract_label l in 429 | (ls0 @ ls, tl) 430 | | _ -> ([],t) 431 | 432 | and is_effect_fixed (tp : tau) : bool = 433 | is_effect_empty (snd (extract_effect_extend tp)) 434 | 435 | 436 | let rec effect_extend (label : tau) (eff : tau) : tau = 437 | let (ls,tl) = extract_effect_extend label in 438 | if List.is_empty ls then 439 | TApp(TCon(tcon_effect_extend), [label;eff]) 440 | else effect_extends ls eff 441 | 442 | (* prevent over expansion of type synonyms here (see also: Core.Parse.teffect) *) 443 | and effect_extends (labels : tau list) (eff : tau) : tau = 444 | match labels with 445 | | [TSyn({type_syn_kind=kind;_},_,_) as lab] when 446 | (is_effect_empty eff) && 447 | (Kind.equal kind Kind.Prim.effect) -> lab 448 | | _ -> List.fold_right ~f:effect_extend ~init:eff labels 449 | 450 | let effect_fixed (labels : tau list) : tau = effect_extends labels effect_empty 451 | 452 | (* let rec effect_extend_no_dup (label : tau) (eff : tau) : tau = *) 453 | (* let (ls,_) = extract_effect_extend eff in *) 454 | (* if List.is_empty ls then *) 455 | (* let (els,_) = extract_effect_extend eff in *) 456 | (* if List.mem els label ~equal:Eq_typ.equal then *) 457 | (* eff *) 458 | (* else TApp(TCon tcon_effect_extend,[label;eff]) *) 459 | (* else effect_extend_no_dups ls eff *) 460 | 461 | (* and effect_extend_no_dups (labels : tau list) (eff : tau) : tau = *) 462 | (* List.fold_right ~f:effect_extend_no_dup ~init:eff labels *) 463 | 464 | let rec shallow_extract_effect_extend : tau -> tau list * tau = function 465 | | TApp(TCon(tc),[l;e]) when (Name.equal tc.name Name.effect_extend) -> 466 | let (ls,tl) = shallow_extract_effect_extend e in 467 | (l::ls, tl) 468 | | t -> ([],t) 469 | 470 | and shallow_effect_extend (label : tau) (eff : tau) : tau = 471 | (* We do not expand type synonyms in the label here by using the 'shallow' version of extract 472 | * this means that type synonyms of kind E (i.e. a fixed effect row) could stay around in 473 | * the label (which should have kind X). 474 | * We use this to keep type synonyms around longer -- but during unification we've got to be 475 | * careful to expand such synonyms*) 476 | let (ls,tl) = shallow_extract_effect_extend label in 477 | if List.is_empty ls 478 | then TApp(TCon(tcon_effect_extend),[label;eff]) 479 | else effect_extends ls eff 480 | 481 | 482 | 483 | let extract_ordered_effect (tp : tau) : (tau list * tau) = 484 | let expand l = 485 | let (ls,tl) = extract_effect_extend l in 486 | if is_effect_empty tl && not (List.is_empty ls) 487 | then ls 488 | else [l] 489 | in 490 | let (labs,tl) = extract_effect_extend tp in 491 | let labss = List.concat_map ~f:expand labs in 492 | let slabs = List.dedup_and_sort ~compare:(fun l1 l2 -> Name.compare (label_name l1) (label_name l2)) labss in 493 | (slabs,tl) 494 | 495 | 496 | let order_effect (tp : tau) : tau = 497 | let (ls,tl) = extract_ordered_effect tp in 498 | List.fold_right ~f:effect_extend ~init:tl ls 499 | 500 | (** A type in canonical form has no type synonyms and expanded effect types *) 501 | let rec canonical_form : typ -> typ = function 502 | | TSyn(syn,args,t) -> canonical_form t (* You can see how here, we abandon the synonym for the raw type *) 503 | | TForall(vars,preds,t) -> TForall(vars, preds, canonical_form t) 504 | | TApp(t,ts) -> TApp(canonical_form t, List.map ~f:canonical_form ts) 505 | | TFun(args,eff,res) -> TFun(List.map ~f:(fun (name,t) -> (name, canonical_form t)) args, 506 | (order_effect @@ canonical_form eff), 507 | (canonical_form res)) 508 | | tp -> tp 509 | 510 | 511 | (** A type in minimal form is canonical_form but also has no named function arguments *) 512 | let minimal_form : typ -> typ = function 513 | | TSyn(syn,args,t) -> canonical_form t 514 | | TForall(vars,preds,t) -> TForall(vars,preds,canonical_form t) 515 | | TApp(t,ts) -> TApp(canonical_form t, List.map ~f:canonical_form ts) 516 | | TFun(args,eff,res) -> TFun(List.map ~f:(fun (_,t) -> (Name.null, canonical_form t)) args, 517 | (order_effect @@ canonical_form eff), 518 | (canonical_form res)) 519 | | tp -> tp 520 | 521 | (*********************************************** 522 | Primitive Types Cont. 523 | ***********************************************) 524 | 525 | let single (name : Name.t) : effect = 526 | effect_extend (TCon { name; kind = Kind.Prim.effect }) effect_empty 527 | 528 | let type_divergent : tau = single Name.tp_div 529 | 530 | let tcon_total : TypeCon.t = {name=Name.effect_empty; kind=Kind.Prim.effect } 531 | 532 | let type_total : tau = TCon tcon_total 533 | 534 | let is_type_total : tau -> bool = function 535 | | TCon tc -> TypeCon.equal tc tcon_total 536 | | _ -> false 537 | 538 | let type_partial : tau = single Name.tp_partial 539 | 540 | let type_pure : tau = effect_fixed [type_partial; type_divergent] 541 | 542 | let tcon_bool : TypeCon.t = { name=Name.tp_bool; kind = Kind.Prim.star} 543 | let type_bool : tau = TCon tcon_bool 544 | 545 | let is_type_bool : tau -> bool = function 546 | | TCon tc -> TypeCon.equal tc tcon_bool 547 | | _ -> false 548 | 549 | let tcon_unit : TypeCon.t = { name = Name.tp_unit; kind = Kind.Prim.star } 550 | let type_unit : tau = TCon tcon_unit 551 | 552 | let is_type_unit : tau -> bool = function 553 | | TCon tc -> TypeCon.equal tc tcon_unit 554 | | _ -> false 555 | 556 | let tcon_list : TypeCon.t = { 557 | name = Name.tp_list; 558 | kind = (Kind.Prim.fun_1 Kind.Prim.star Kind.Prim.star) 559 | } 560 | 561 | (** Type of lists (@[]@) *) 562 | let type_list = TCon tcon_list 563 | 564 | let type_fun args effect result = 565 | TFun(args,effect,result) 566 | 567 | (** Create an application *) 568 | let type_app t ts = 569 | match (t,ts) with 570 | | (_,[]) -> t 571 | | (TApp(t1,ts0),_) -> TApp(t1,(ts0 @ ts)) 572 | | (_,_) -> TApp(t,ts) 573 | 574 | let type_void : tau = TCon { name = Name.tp_void; kind = Kind.Prim.star } 575 | 576 | let type_tuple (n : int) : tau = 577 | TCon { name = (Name.tuple n); kind = (Kind.Prim.arrow_n n)} 578 | 579 | let tcon_optional : TypeCon.t = { 580 | name = Name.tp_optional; 581 | kind = (Kind.Prim.fun_1 Kind.Prim.star Kind.Prim.star) 582 | } 583 | 584 | let type_optional : tau = TCon tcon_optional 585 | 586 | let is_optional (tp : typ) : bool = 587 | match expand_syn tp with 588 | | TApp(TCon tc,[t]) -> TypeCon.equal tc tcon_optional 589 | | _ -> false 590 | 591 | let make_optional (tp : typ) : typ = 592 | TApp(type_optional, [tp]) 593 | 594 | let unoptional (tp : typ) : typ = 595 | match expand_syn tp with 596 | | TApp((TCon tc),[t]) when (TypeCon.equal tc tcon_optional) -> t 597 | | _ -> tp 598 | 599 | (** Remove type synonym indirections *) 600 | let rec pruneSyn : rho -> rho = function 601 | | TSyn(_sin,_args,t) -> pruneSyn t 602 | | TApp(t1,ts) -> TApp((pruneSyn t1), (List.map ~f:pruneSyn ts)) 603 | | rho -> rho 604 | 605 | 606 | (***************************************************** 607 | Conversion between types 608 | *****************************************************) 609 | module type IsType = sig 610 | type t 611 | (* Trivial conversion to a kind quantified type scheme *) 612 | val to_type : t -> typ 613 | end 614 | 615 | (* let to_type {I:IsType} tp = I.to_type tp *) 616 | 617 | module IsType_typ : IsType with type t = typ = struct 618 | type t = typ 619 | let to_type tp = tp 620 | end 621 | 622 | module IsType_type_var : IsType with type t = TypeVar.t = struct 623 | type t = TypeVar.t 624 | let to_type v = TVar v 625 | end 626 | 627 | module IsType_type_con : IsType with type t = TypeCon.t = struct 628 | type t = TypeCon.t 629 | let to_type con = TCon con 630 | end 631 | 632 | (****************************************************** 633 | Equality between types 634 | ******************************************************) 635 | let rec match_type tp1 tp2 = 636 | match (expand_syn tp1, expand_syn tp2) with 637 | | (TForall(vs1,ps1,t1), TForall(vs2,ps2,t2)) -> ((List.equal TypeVar.equal vs1 vs2) && match_preds ps1 ps2 && match_type t1 t2) 638 | | (TFun(pars1,eff1,t1),TFun(pars2,eff2,t2)) -> (match_types (List.map pars1 ~f:snd) (List.map ~f:snd pars2) && match_effect eff1 eff2 && match_type t1 t2) 639 | | (TCon(c1),TCon(c2)) -> TypeCon.equal c1 c2 640 | | (TVar(v1),TVar(v2)) -> TypeVar.equal v1 v2 641 | | (TApp(t1,ts1),TApp(t2,ts2)) -> (match_type t1 t2 && match_types ts1 ts2) 642 | (* | (TSyn(syn1,ts1,t1),TSyn(syn2,ts2,t2)) -> (syn1 = syn2 && match_types ts1 ts2 && match_type t1 t2) *) 643 | | _ -> false 644 | 645 | and match_types ts1 ts2 = 646 | List.fold2_exn ts1 ts2 ~init:true ~f:(fun i l r -> i && (match_type l r)) 647 | 648 | and match_effect eff1 eff2 = 649 | match_type (order_effect eff1) (order_effect eff2) 650 | 651 | and match_pred p1 p2 = 652 | match (p1,p2) with 653 | | (PredSub(sub1,sup1), PredSub(sub2,sup2)) -> (match_type sub1 sub2 && match_type sup1 sup2) 654 | | (PredIFace(n1,ts1), PredIFace(n2,ts2)) -> (Name.equal n1 n2 && match_types ts1 ts2) 655 | | _ -> false 656 | 657 | and match_preds ps1 ps2 = 658 | List.fold2_exn ps1 ps2 ~init:true ~f:(fun i l r -> i && (match_pred l r)) 659 | 660 | (* implicit *) 661 | module Eq_typ : BasicClasses.Eq with type t = typ = struct 662 | type t = typ 663 | let equal = match_type 664 | end 665 | 666 | (* implicit *) 667 | module Eq_pred : BasicClasses.Eq with type t = pred = struct 668 | type t = pred 669 | let equal = match_pred 670 | end 671 | 672 | module Flavour = Kind.Flavour 673 | 674 | let pred_type = function 675 | | PredSub (t1,t2) -> type_fun [(Name.create "sub", t1)] type_total t2 676 | | PredIFace (name, tps) -> Failure.todo "Type.Operations.predType.PredIFace" 677 | -------------------------------------------------------------------------------- /heart/typeKind.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | (********************************* 4 | Get the kind of a type 5 | *********************************) 6 | 7 | (* Soooo, in the original source, this is done with a HasKind typeclass. 8 | * But I _really_ don't want to deal with OCaml's functors, since it'll just 9 | * introduce _more_ complexity to the already-weird module layout. So instead, 10 | * we're going to continue ppx_deriving's convention of prefixes and then types. 11 | * a la get_kind_kind. *) 12 | 13 | module type HasKind = sig 14 | type t 15 | val get_kind : t -> Kind.t 16 | end 17 | 18 | 19 | let get_kind_kind k = k 20 | let get_kind_type_var { Type.TypeVar.kind = k; _ } = k 21 | let get_kind_type_con { Type.TypeCon.kind = k; _ } = k 22 | let get_kind_type_syn { Type.type_syn_kind = k; _ } = k 23 | let rec get_kind_typ = 24 | let rec collect acc = function 25 | | Kind.App(Kind.App(arr,k1),k2) when arr = Kind.Prim.arrow -> collect (k1::acc) k2 26 | | k -> k :: acc 27 | in 28 | let rec kind_apply l k = 29 | match (l,k) with 30 | | [], _ -> k 31 | | (_::rest), Kind.App(Kind.App(arr,k1),k2) -> kind_apply rest k2 32 | | _,_ -> Core.failwithf "TypeKind.t_apply: illegal kind in application? %s" (Kind.show k) () 33 | in 34 | let open Type in function 35 | | TForall(_,_,tp) -> get_kind_typ tp 36 | | TFun _ -> Kind.Prim.star 37 | | TVar v -> get_kind_type_var v 38 | | TCon c -> get_kind_type_con c 39 | | TSyn(syn,xs,tp) -> (*getKind tp (* this is wrong for partially applied type synonym arguments, see "kind/alias3" test *)*) 40 | kind_apply xs (get_kind_type_syn syn) 41 | | TApp(tp,args) -> begin 42 | match collect [] (get_kind_typ tp) with 43 | | (kres::_) -> kres 44 | | _ -> Core.failwithf "TypeKind: illegal kind in type application? %s" (Kind.show @@ get_kind_typ tp) () 45 | end 46 | -------------------------------------------------------------------------------- /heart/typeVar.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | open Common.Util 4 | open Type.TypeVar 5 | 6 | module C = Comparator.Make(struct 7 | type nonrec t = Type.TypeVar.t 8 | let compare = Type.TypeVar.compare 9 | let sexp_of_t = Type.TypeVar.sexp_of_t 10 | end) 11 | 12 | module Set = Core.Set.Make_using_comparator(struct 13 | include C 14 | type nonrec t = Type.TypeVar.t 15 | let t_of_sexp = Type.TypeVar.t_of_sexp 16 | let sexp_of_t = Type.TypeVar.sexp_of_t 17 | end) 18 | 19 | module Map = struct 20 | include Core.Map.Make_using_comparator(struct 21 | include C 22 | type nonrec t = Type.TypeVar.t 23 | let t_of_sexp = Type.TypeVar.t_of_sexp 24 | let sexp_of_t = Type.TypeVar.sexp_of_t 25 | end) 26 | 27 | 28 | let inter_with ~f m1 m2 = 29 | fold m1 ~init:empty ~f:(fun ~key ~data acc -> 30 | match find m2 key with 31 | | Some data2 -> set acc ~key:key ~data:(f data data2) 32 | | None -> acc 33 | ) 34 | 35 | (* I've only seen inter_with used with lists, so this is a better 36 | * version that only cons and doesn't have to do Map.to_alist *) 37 | let inter_with_to_alist ~f m1 m2 = 38 | fold m1 ~init:[] ~f:(fun ~key ~data acc -> 39 | match find m2 key with 40 | | Some data2 -> (key, f data data2)::acc 41 | | None -> acc 42 | ) 43 | 44 | (* left-biased union(s) *) 45 | let union m1 m2 = 46 | merge m1 m2 ~f:(fun ~key -> function 47 | | `Both(l,r) -> Some l 48 | | `Left l -> Some l 49 | | `Right r -> Some r 50 | ) 51 | 52 | let rec union_list = function 53 | | [] -> empty 54 | | x::[] -> x 55 | | x::ys -> union x (union_list ys) 56 | end 57 | 58 | 59 | (******************************************************************** 60 | * Debugging 61 | ********************************************************************) 62 | let show_type_var Type.TypeVar.{id=name; kind; flavour} = 63 | Id.show name ^ " : " ^ Kind.show kind 64 | 65 | let rec show_tp = 66 | let open Type in function 67 | | Type.TVar tvar -> show_type_var tvar 68 | | Type.TCon tcon -> Name.show tcon.name ^ " : " ^ Kind.show tcon.kind 69 | | TApp(tp,args) -> show_tp tp ^ "<" ^ String.concat ~sep:"," (List.map ~f:show_tp args) ^ ">" 70 | | TSyn(syn,args,body) -> "(syn:" ^ Name.show syn.type_syn_name ^ " : " ^ Kind.show syn.type_syn_kind 71 | ^ "<" ^ String.concat ~sep:"," (List.map ~f:show_tp args) ^ ">" ^ "[" ^ show_tp body ^ "])" 72 | | _ -> "?" 73 | 74 | (********************************************************************** 75 | * Type variables 76 | **********************************************************************) 77 | 78 | let tvs_empty = Set.empty 79 | let tvs_is_empty = Set.is_empty 80 | let tvs_single = Set.singleton 81 | let tvs_insert = Fn.flip Set.add 82 | let tvs_insert_all vars s = List.fold ~init:s ~f:Set.add vars 83 | let tvs_new = Set.of_list 84 | let tvs_list = Set.to_list 85 | let tvs_remove tvs set = List.fold tvs ~init:set ~f:Set.remove 86 | let tvs_diff = Set.diff 87 | let tvs_union = Set.union 88 | let tvs_unions tvs = List.fold tvs ~init:tvs_empty ~f:Set.union 89 | let tvs_filter = Set.filter 90 | let tvs_member = Set.mem 91 | let tvs_interset = Set.inter 92 | let tvs_disjoint = Set.is_empty <.:> Set.inter 93 | let tvs_common t1 t2 = not @@ Set.is_empty @@ Set.inter t1 t2 94 | let tvs_is_subset_of t1 t2 = Set.is_subset t1 ~of_:t2 (* Is first argument a subset of second? *) 95 | 96 | 97 | (*************************************************************************** 98 | Substitution 99 | 100 | A substitution can be seen as a mapping from one domain to another, and 101 | is usually denoted by $\sigma :V \mapsto T$ for some given variable $V$ and term $T$. 102 | In type variables, this is no different, and can be noted as 103 | $\sigma : \alpha \mapsto \tau$, where $\alpha$ is a type variable, and $\tau$ is 104 | some type, which could be a type variable itself. 105 | 106 | Because of this mapping, substitutions can be composed much like functions. 107 | Given $s1 = \alpha \mapsto \beta$ and of $s2 = \beta \mapsto \gamma$ 108 | the composition $(s1 \circ s2) \mapsto x$ must be the same as $s1 \mapsto (s2 \mapsto x)$ 109 | 110 | Since there's no \circ operator in code, here we're going to use `@@@`. In 111 | the original Haskell, `@@` was used. But because `@@` is a primitive operator 112 | in OCaml, we won't use that. 113 | 114 | 115 | Daan's notes: 116 | For a substitution it should hold that: 117 | $(s1 \circ s2) \mapsto x \Leftrightarrow s1 \mapsto (s2 \mapsto x)$ 118 | 119 | 120 | We can implement this by: 121 | 1) upon encountering a composition we apply the first substitution 122 | to the other, and finding an identifier is a simple lookup. 123 | or, 124 | 2) we compose by simple union and perform a fixpoint at lookup. 125 | 126 | We have chosen (1) here, but it could be interesting to compare 127 | performance with strategy (2). 128 | ***************************************************************************) 129 | type tau = Type.tau (* $\tau$ *) 130 | type sub = tau Map.t (* \sigma:\alpha \mapsto \tau *) 131 | 132 | (********************************************************************** 133 | * Entities with type variables 134 | **********************************************************************) 135 | 136 | (* Entities that contain type variables *) 137 | module type HasTypeVar = sig 138 | type t 139 | (* Substitute type variables by $\tau$ types *) 140 | val substitute : sub -> t -> t 141 | (* Return free type variables *) 142 | val ftv : t -> Set.t 143 | (* Return bound type variables *) 144 | val btv : t -> Set.t 145 | end 146 | 147 | module type HasTypeVarEx = sig 148 | include HasTypeVar 149 | val (|->) : sub -> t -> t 150 | end 151 | 152 | (* Entities that contain type variables that can be put in a particular order *) 153 | module type HasOrderedTypeVar = sig 154 | type t 155 | (* Return free type variables in a particular order, may contain duplicates *) 156 | val odftv : t -> Type.TypeVar.t list 157 | end 158 | 159 | 160 | (* TODO: inline-replace all of these with their corresponding functions *) 161 | 162 | let sub_count : sub -> int = Map.length 163 | let sub_null : sub = Map.empty 164 | let sub_is_null : sub -> bool = Map.is_empty 165 | let sub_new (sub : (t * tau) list) : sub = 166 | Failure.assertwith (Printf.sprintf "TypeVar.sub_new.KindMisMatch: %i {%s}" (List.length sub) 167 | (String.concat @@ List.map ~f:(fun (x,t) -> Printf.sprintf "(%s |-> %s)" (show_type_var x) (show_tp t)) sub)) 168 | (List.for_all ~f:(fun (x,t) -> Kind.equal (TypeKind.get_kind_type_var x) (TypeKind.get_kind_typ t)) sub) 169 | Map.of_alist_exn sub (* TODO: Don't let this throw an exception *) 170 | 171 | (** This is the set of all types in our current environment. 172 | * In type theory, it is denoted by $\Gamma$ *) 173 | let sub_dom : sub -> Set.t = tvs_new <.> Map.keys 174 | let sub_range : sub -> tau list = Map.data 175 | let sub_list : sub -> (Type.TypeVar.t * tau) list = Map.to_alist 176 | let sub_common : sub -> sub -> (t*(tau*tau)) list = 177 | Map.inter_with_to_alist ~f:Tuple2.create 178 | 179 | let sub_lookup tvar sub : tau option = Map.find sub tvar 180 | let sub_remove tvars sub : sub = List.fold tvars ~f:Map.remove ~init:sub 181 | let sub_find tvar sub : tau = match sub_lookup tvar sub with 182 | | None -> Type.TVar tvar 183 | | Some tau -> 184 | Failure.assertwith ("Type.TypeVar.sub_find: incompatible kind: " 185 | ^ Type.TypeVar.show tvar ^ ":" 186 | ^ Kind.show (TypeKind.get_kind_type_var tvar) ^ "," 187 | ^ "?" ^ ":" ^ Kind.show (TypeKind.get_kind_typ tau)) 188 | (Kind.equal (TypeKind.get_kind_type_var tvar) (TypeKind.get_kind_typ tau)) @@ 189 | tau 190 | 191 | module HasTypeVar_list (H:HasTypeVar) : HasTypeVarEx with type t = H.t list = struct 192 | type t = H.t list 193 | let substitute sub xs = List.map xs ~f:(fun x -> H.substitute sub x) 194 | let ftv xs = tvs_unions (List.map xs ~f:H.ftv) 195 | let btv xs = tvs_unions (List.map xs ~f:H.btv) 196 | let (|->) sub x = if sub_is_null sub then x else substitute sub x 197 | end 198 | 199 | module HasOrderedTypeVar_list (H:HasOrderedTypeVar) : HasOrderedTypeVar with type t = H.t list = struct 200 | type t = H.t list 201 | let odftv xs = List.concat_map ~f:H.odftv xs 202 | end 203 | 204 | module rec HasTypeVar_pred : HasTypeVarEx with type t = Type.pred = struct 205 | open Type 206 | 207 | type t = pred 208 | 209 | let substitute subst pred = match pred with 210 | | PredSub (sub, super) -> PredSub (HasTypeVar_typ.substitute subst sub, 211 | HasTypeVar_typ.substitute subst super) 212 | | PredIFace (name, args) -> PredIFace (name, HasTypeVar_list_typ.substitute subst args) 213 | 214 | let ftv = function 215 | | PredSub (sub, super) -> tvs_union (HasTypeVar_typ.ftv sub) (HasTypeVar_typ.ftv super) 216 | | PredIFace (_, args) -> HasTypeVar_list_typ.ftv args 217 | let btv _ = tvs_empty 218 | let (|->) sub x = if sub_is_null sub then x else substitute sub x 219 | end 220 | 221 | and HasTypeVar_typ : HasTypeVarEx with type t = Type.typ = struct 222 | open Type 223 | type t = typ 224 | let substitute (sub:sub) (t:rho) = 225 | let rec substitute' sub t = 226 | match t with 227 | | TForall (vars,preds,tp) -> 228 | let sub' = sub_remove vars sub in 229 | let (|->) sub x = if sub_is_null sub then x else HasTypeVar_list_pred.substitute sub x in 230 | TForall (vars, (sub' |-> preds), (if sub_is_null sub' then tp else substitute' sub' tp)) 231 | 232 | | TFun (args,effect,result) -> 233 | let mapped_args = List.map ~f:(fun (name,tp) -> (name, substitute' sub tp)) args in 234 | Type.TFun (mapped_args, (substitute' sub effect), (substitute' sub result)) 235 | | TCon _ -> t 236 | | TVar tvar -> sub_find tvar sub 237 | | TApp (tp,arg) -> 238 | Type.TApp (substitute' sub tp, HasTypeVar_list_typ.substitute sub arg) 239 | | TSyn (syn,xs,tp) -> 240 | TSyn (syn, HasTypeVar_list_typ.substitute sub xs, substitute' sub tp) 241 | in substitute' sub t 242 | 243 | let ftv tp = 244 | let rec ftv' = function 245 | | TForall (vars, preds, tp) -> 246 | tvs_remove vars (tvs_union (HasTypeVar_list_pred.ftv preds) (ftv' tp)) 247 | | TFun (args, effect, result) -> 248 | tvs_unions (ftv' effect :: ftv' result :: List.map ~f:(ftv' <.> snd) args) 249 | | TCon _ -> tvs_empty 250 | | TVar tvar -> tvs_single tvar 251 | | TApp (tp, args) -> tvs_union (ftv' tp) (HasTypeVar_list_typ.ftv args) 252 | | TSyn (syn, xs, tp) -> tvs_union (HasTypeVar_list_typ.ftv xs) (ftv' tp) 253 | in ftv' tp 254 | 255 | let btv tp = 256 | let rec btv' = function 257 | | TForall (vars, preds, tp) -> tvs_remove vars (tvs_union (HasTypeVar_list_pred.ftv preds) (btv' tp)) 258 | | TFun (args, effect, result) -> tvs_unions (btv' effect :: btv' result :: List.map ~f:(btv' <.> snd) args) 259 | | TSyn (_,_,tp) -> btv' tp 260 | | TApp (tp, args) -> tvs_union (btv' tp) (HasTypeVar_list_typ.btv args) 261 | | _ -> tvs_empty 262 | in btv' tp 263 | 264 | let (|->) sub x = if sub_is_null sub then x else substitute sub x 265 | end 266 | 267 | and HasTypeVar_list_typ : HasTypeVarEx with type t = Type.typ list = HasTypeVar_list(HasTypeVar_typ) 268 | and HasTypeVar_list_pred : HasTypeVarEx with type t = Type.pred list = HasTypeVar_list(HasTypeVar_pred) 269 | 270 | module rec HasOrderedTypeVar_typ : HasOrderedTypeVar with type t = Type.typ = struct 271 | open Type 272 | type t = typ 273 | let odftv tp = 274 | let rec odftv' = function 275 | | TForall (vars, preds, tp) -> 276 | let module HOTV_list_pred = HasOrderedTypeVar_list(HasOrderedTypeVar_pred) in 277 | List.filter ~f:(fun tv -> not (List.mem vars tv ~equal:equal)) (odftv' tp @ HOTV_list_pred.odftv preds) 278 | | TFun (args, effect, result) -> 279 | List.concat_map ~f:odftv' ((List.map ~f:snd args) @ [effect; result]) 280 | | TCon _ -> [] 281 | | TVar tvar -> [tvar] 282 | | TApp (tp, args) -> 283 | let module HOTV_list_typ = HasOrderedTypeVar_list(HasOrderedTypeVar_typ) in 284 | (odftv' tp) @ (HOTV_list_typ.odftv args) 285 | | TSyn (_, xs, tp) -> (odftv' tp) @ (List.concat_map ~f:odftv' xs) 286 | in odftv' tp 287 | end 288 | and HasOrderedTypeVar_pred : HasOrderedTypeVar with type t = Type.pred = struct 289 | type t = Type.pred 290 | let odftv tp = assert false 291 | end 292 | 293 | module HasTypeVar_sub = struct 294 | type t = sub 295 | let substitute sub (s:sub) = Map.map s ~f:(fun (k:tau) -> HasTypeVar_typ.substitute sub k) 296 | let ftv sub = tvs_empty (* TODO: tvs_union (tvs_new (Map.keys sub)) (ftv (Map.elems sub)) *) 297 | let btv _ = tvs_empty 298 | let (|->) sub x = if sub_is_null sub then x else substitute sub x 299 | end 300 | 301 | 302 | module HasTypeVar_option(H:HasTypeVar) : HasTypeVar with type t = H.t option = struct 303 | type t = H.t option 304 | let substitute sub = function Some x -> Some (H.substitute sub x) 305 | | None -> None 306 | let ftv = function Some x -> H.ftv x 307 | | None -> tvs_empty 308 | 309 | let btv = function Some x -> H.btv x 310 | | None -> tvs_empty 311 | end 312 | 313 | let sub_single tvar (tau:tau) : sub = 314 | (** Top assertion is invalid; it can happen (and happens) in the CoreF typechecker when 315 | * typechecking $\forall \alpha. f \alpha$ with $f :: \forall \beta. \beta \rightarrow \beta$, that a bound variable ($\beta$) with 316 | * number ID must be substituted for another bound variable ($\alpha$), which *could* have the same 317 | * ID. If we want to avoid this, we must ensure that all IDs are distinct; in particular, 318 | * the IDs of built-in types such as .select must be distinct from further IDs generated 319 | * by the compiler. *) 320 | Map.singleton tvar tau 321 | |> Failure.assertwith "Type.TypeVar.sub_single.KindMismatch" (Kind.equal (TypeKind.get_kind_type_var tvar) (TypeKind.get_kind_typ tau)) 322 | |> Failure.assertwith ("Type.TypeVar.sub_single: recursive type: " ^ show_type_var tvar) (not (Set.mem (HasTypeVar_typ.ftv tau) tvar)) 323 | 324 | let sub_compose (sub1:sub) (sub2:sub) : sub = 325 | let open HasTypeVar_sub in 326 | Map.union sub1 (sub1 |-> sub2) 327 | 328 | let (@@@) sub1 sub2 = sub_compose sub1 sub2 329 | 330 | let sub_extend (tvar:Type.TypeVar.t) (tau:tau) (sub:sub) = 331 | (sub_single tvar tau) @@@ sub 332 | 333 | let fresh_type_var kind (flavour : Type.Flavour.t) = 334 | let open Kind in 335 | let id = Unique.unique_id (match flavour with Flavour.Meta -> "_v" | Flavour.Skolem -> "$v" | Flavour.Bound -> "v") in 336 | Type.TypeVar.{id; kind; flavour} 337 | 338 | 339 | (********************************************************************* 340 | * HasTypeVar Monad Stuff 341 | *********************************************************************) 342 | 343 | module HasTypeVar_tname = struct 344 | type t = Expr.tname 345 | let substitute sub (name, tp) = (name, HasTypeVar_typ.substitute sub tp) 346 | let ftv (name, tp) = HasTypeVar_typ.ftv tp 347 | let btv (name, tp) = HasTypeVar_typ.btv tp 348 | end 349 | 350 | module HasTypeVar_list_tname = HasTypeVar_list(HasTypeVar_tname) 351 | 352 | module rec HasTypeVar_def : HasTypeVar with type t = Expr.def = struct 353 | open Expr 354 | type t = def 355 | let substitute sub (def:def) = {def with def_type=HasTypeVar_typ.substitute sub def.def_type; 356 | def_expr=HasTypeVar_expr.substitute sub def.def_expr} 357 | let ftv def = tvs_union (HasTypeVar_typ.ftv def.def_type) (HasTypeVar_expr.ftv def.def_expr) 358 | let btv def = tvs_union (HasTypeVar_typ.btv def.def_type) (HasTypeVar_expr.btv def.def_expr) 359 | end 360 | 361 | and HasTypeVar_list_def : HasTypeVarEx with type t = Expr.def list 362 | = HasTypeVar_list(HasTypeVar_def) 363 | 364 | and HasTypeVar_defgroup : HasTypeVar = struct 365 | open Expr 366 | type t = def_group 367 | let substitute sub = function 368 | | DefRec(defs) -> DefRec(HasTypeVar_list_def.substitute sub defs) 369 | | DefNonRec(def) -> DefNonRec(HasTypeVar_def.substitute sub def) 370 | let ftv = function 371 | | DefRec(defs) -> HasTypeVar_list_def.ftv defs 372 | | DefNonRec(def) -> HasTypeVar_def.ftv def 373 | let btv = function 374 | | DefRec(defs) -> HasTypeVar_list_def.btv defs 375 | | DefNonRec(def) -> HasTypeVar_def.btv def 376 | end 377 | 378 | and HasTypeVar_list_defgroup : HasTypeVarEx with type t = Expr.def_group list 379 | = HasTypeVar_list(HasTypeVar_defgroup) 380 | 381 | and HasTypeVar_pattern : HasTypeVar with type t = Expr.pattern = struct 382 | open Expr 383 | type t = pattern 384 | let rec substitute sub = function 385 | | PatVariable pvar -> PatVariable{pat_name = HasTypeVar_tname.substitute sub pvar.pat_name; 386 | pat_pattern = substitute sub pvar.pat_pattern} 387 | | PatConstructor con -> PatConstructor{con with pat_con_name = HasTypeVar_tname.substitute sub con.pat_con_name; 388 | pat_con_patterns = HasTypeVar_list_pattern.substitute sub con.pat_con_patterns; 389 | pat_type_args = HasTypeVar_list_typ.substitute sub con.pat_type_args; 390 | pat_type_res = HasTypeVar_typ.substitute sub con.pat_type_res} 391 | | PatWild -> PatWild 392 | | PatLiteral lit -> PatLiteral lit 393 | 394 | let rec ftv = function 395 | | PatVariable pvar -> tvs_union (HasTypeVar_tname.ftv pvar.pat_name) (ftv pvar.pat_pattern) 396 | | PatConstructor con -> tvs_unions [HasTypeVar_tname.ftv con.pat_con_name; 397 | HasTypeVar_list_pattern.ftv con.pat_con_patterns; 398 | HasTypeVar_list_typ.ftv con.pat_type_args; 399 | HasTypeVar_typ.ftv con.pat_type_res] 400 | | PatWild -> tvs_empty 401 | | PatLiteral _ -> tvs_empty 402 | 403 | let rec btv = function 404 | | PatVariable pvar -> tvs_union (HasTypeVar_tname.btv pvar.pat_name) (btv pvar.pat_pattern) 405 | | PatConstructor con -> tvs_unions [HasTypeVar_tname.btv con.pat_con_name; 406 | HasTypeVar_list_pattern.btv con.pat_con_patterns; 407 | HasTypeVar_list_typ.btv con.pat_type_args; 408 | HasTypeVar_typ.btv con.pat_type_res] 409 | | PatWild -> tvs_empty 410 | | PatLiteral _ -> tvs_empty 411 | end 412 | 413 | and HasTypeVar_list_pattern : HasTypeVarEx with type t = Expr.pattern list 414 | = HasTypeVar_list(HasTypeVar_pattern) 415 | 416 | and HasTypeVar_guard : HasTypeVar with type t = Expr.guard = struct 417 | open Expr 418 | type t = guard 419 | let substitute sub {guard_test; guard_expr} = {guard_test=HasTypeVar_expr.substitute sub guard_test; 420 | guard_expr=HasTypeVar_expr.substitute sub guard_expr;} 421 | let ftv {guard_test; guard_expr} = tvs_union (HasTypeVar_expr.ftv guard_test) (HasTypeVar_expr.ftv guard_expr) 422 | let btv {guard_test; guard_expr} = tvs_union (HasTypeVar_expr.btv guard_test) (HasTypeVar_expr.btv guard_expr) 423 | end 424 | 425 | and HasTypeVar_list_guard : HasTypeVarEx with type t = Expr.guard list 426 | = HasTypeVar_list(HasTypeVar_guard) 427 | 428 | and HasTypeVar_branch : HasTypeVar with type t = Expr.branch = struct 429 | open Expr 430 | type t = branch 431 | let substitute sub {branch_patterns=patterns; branch_guards=guards} = 432 | let sub' = sub_remove (tvs_list @@ HasTypeVar_list_pattern.btv patterns) sub in 433 | { branch_patterns=List.map ~f:(HasTypeVar_pattern.substitute sub) patterns; 434 | branch_guards=List.map ~f:(HasTypeVar_guard.substitute sub') guards } 435 | 436 | let ftv {branch_patterns; branch_guards} = 437 | tvs_union 438 | (HasTypeVar_list_pattern.ftv branch_patterns) 439 | (tvs_diff 440 | (HasTypeVar_list_guard.ftv branch_guards) 441 | (HasTypeVar_list_pattern.btv branch_patterns)) 442 | 443 | let btv {branch_patterns; branch_guards} = 444 | tvs_union (HasTypeVar_list_pattern.btv branch_patterns) (HasTypeVar_list_guard.btv branch_guards) 445 | end 446 | 447 | and HasTypeVar_list_branch : HasTypeVarEx with type t = Expr.branch list 448 | = HasTypeVar_list(HasTypeVar_branch) 449 | 450 | and HasTypeVar_expr : HasTypeVarEx with type t = Expr.expr = struct 451 | open Expr 452 | type t = expr 453 | let rec substitute sub = function 454 | | Lam(tnames, eff, expr) -> Lam (HasTypeVar_list_tname.substitute sub tnames, 455 | HasTypeVar_typ.substitute sub eff, 456 | substitute sub expr) 457 | | Var{var_name=tname; var_info=info} -> Var{var_name=HasTypeVar_tname.substitute sub tname; var_info=info} 458 | | App(f, args) -> App(substitute sub f, HasTypeVar_list_expr.substitute sub args) 459 | | TypeLam(tvs, expr) -> 460 | let sub' = sub_remove tvs sub in 461 | TypeLam(tvs, HasTypeVar_expr.(sub' |-> expr)) 462 | | TypeApp(expr, tps) -> TypeApp(substitute sub expr, HasTypeVar_list_typ.substitute sub tps) 463 | | Constructor{con_name=tname; con_repr=repr} -> Constructor{con_name=HasTypeVar_tname.substitute sub tname; con_repr=repr} 464 | | Literal lit -> Literal lit 465 | | Let(defgroups, expr) -> Let(HasTypeVar_list_defgroup.substitute sub defgroups, substitute sub expr) 466 | | Case c -> Case{case_exprs = HasTypeVar_list_expr.substitute sub c.case_exprs; 467 | case_branches = HasTypeVar_list_branch.substitute sub c.case_branches} 468 | 469 | let rec ftv = function 470 | | Lam(tnames, eff, expr) -> tvs_unions [HasTypeVar_list_tname.ftv tnames; 471 | HasTypeVar_typ.ftv eff; 472 | ftv expr] 473 | | Var v -> HasTypeVar_tname.ftv v.var_name 474 | | App(f, args) -> tvs_union (ftv f) (HasTypeVar_list_expr.ftv args) 475 | | TypeLam(tvs, expr) -> tvs_remove tvs (ftv expr) 476 | | TypeApp(expr, tps) -> tvs_union (ftv expr) (HasTypeVar_list_typ.ftv tps) 477 | | Constructor c -> HasTypeVar_tname.ftv c.con_name 478 | | Literal _ -> tvs_empty 479 | | Let(defgroups, expr) -> tvs_union (HasTypeVar_list_defgroup.ftv defgroups) (ftv expr) 480 | | Case c -> tvs_union (HasTypeVar_list_expr.ftv c.case_exprs) (HasTypeVar_list_branch.ftv c.case_branches) 481 | 482 | let rec btv = function 483 | | Lam(tnames, eff, expr) -> tvs_unions [HasTypeVar_list_tname.btv tnames; 484 | HasTypeVar_typ.btv eff; 485 | btv expr] 486 | | Var v -> HasTypeVar_tname.btv v.var_name 487 | | App(f, args) -> tvs_union (btv f) (HasTypeVar_list_expr.btv args) 488 | | TypeLam(tvs, expr) -> tvs_insert_all tvs (btv expr) (* The magic *) 489 | | TypeApp(expr, tps) -> tvs_union (btv expr) (HasTypeVar_list_typ.btv tps) 490 | | Constructor c -> HasTypeVar_tname.btv c.con_name 491 | | Literal _ -> tvs_empty 492 | | Let(defgroups, expr) -> tvs_union (HasTypeVar_list_defgroup.btv defgroups) (btv expr) 493 | | Case c -> tvs_union (HasTypeVar_list_expr.btv c.case_exprs) (HasTypeVar_list_branch.btv c.case_branches) 494 | 495 | let (|->) sub x = if sub_is_null sub then x else substitute sub x 496 | end 497 | and HasTypeVar_list_expr : HasTypeVarEx with type t = Expr.expr list = HasTypeVar_list(HasTypeVar_expr) 498 | -------------------------------------------------------------------------------- /kekka.ml: -------------------------------------------------------------------------------- 1 | (* Dummy file to cause module generation *) 2 | let () = () 3 | -------------------------------------------------------------------------------- /kekka.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "kekka" 3 | version: "~unknown" 4 | maintainer: "Katherine Whitlock " 5 | authors: "Katherine Whitlock " 6 | homepage: "https://github.com/brick-lang/kekka" 7 | bug-reports: "https://github.com/brick-lang/kekka/issues" 8 | dev-repo: "https://github.com/brick-lang/kekka" 9 | license: "Apache-2.0" 10 | build: [ 11 | ["dune" "build" "-p" name "-j" jobs] 12 | ] 13 | depends: [ 14 | "core" 15 | "dune" {build & >= "1.0"} 16 | "ppx_deriving" 17 | "ppx_inline_test" 18 | "ppx_let" 19 | "ppx_sexp_conv" 20 | ] 21 | available: [ ocaml-version >= "4.04.1" ] 22 | descr: "Daan Leijen's lambda-k type system in OCaml" 23 | -------------------------------------------------------------------------------- /kindEngine/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name kindEngine) 3 | (public_name kekka.kindEngine) 4 | (libraries core common heart) 5 | (preprocess 6 | (pps ppx_let ppx_deriving.std))) 7 | -------------------------------------------------------------------------------- /kindEngine/importMap.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | open Common.Util 4 | 5 | (** 6 | * Maps short module aliases @core@ to full module paths @std/core@. 7 | * It is represented as a map from a reversed list of module path components to a full name 8 | * i.e. import my/core = std/core -> [(["core","my"], "std/core"); ...] *) 9 | type t = (Name.t list * Name.t) list 10 | 11 | let empty = [] 12 | 13 | let extend name fq_name (imp_map:t) = 14 | let rpath = List.rev @@ Name.split_module_name name in 15 | (* make sure it's not already there *) 16 | if List.Assoc.mem imp_map rpath ~equal:(List.equal Name.equal) then 17 | None 18 | else 19 | Some((rpath,fq_name)::imp_map) 20 | 21 | (** 22 | * `expand name map` takes a qualified name (`core/int`) and expands 23 | * it to its real fully qualified name (`std/core/int`). It also returns 24 | * the declared alias suffix (used to find case-errors). 25 | * On ambiguity, or if not found at all, it returns First with a list of candidates. *) 26 | let expand name (imp:t) : (Name.t list, (Name.t * Name.t)) Either.t = 27 | let rec is_prefix x y = match x,y with 28 | | x::xs, y::ys -> (Name.equal x y) && is_prefix xs ys 29 | | [], _ -> true 30 | | _ -> false 31 | in 32 | if Name.is_qualified name then 33 | let rpath = List.rev @@ Name.split_module_name (Name.qualifier name) in 34 | match List.filter imp ~f:(fun (ralias,_) -> is_prefix rpath ralias) with 35 | | [(ralias,full_name)] -> 36 | Either.Second (Name.qualify full_name (Name.unqualify name), 37 | Name.unsplit_module_name List.(rev @@ take ralias (length rpath))) 38 | | amb -> Either.First (List.map amb ~f:Util.(fst >>> List.rev >>> Name.unsplit_module_name)) 39 | else 40 | Either.Second (name, Name.nil) 41 | 42 | 43 | (* Given a fully qualified name, return the shorter aliased name. 44 | * For example, with `import System.Foo as F` a name `System.Foo.bar` is shortened to `F.bar`. *) 45 | let alias name imp : Name.t = 46 | let module_name = if Name.is_qualified name then Name.qualifier name else name in 47 | match List.filter imp ~f:(fun (_,fullname) -> Name.equal module_name fullname) with 48 | | [(ralias,_)] -> 49 | let alias = Name.unsplit_module_name (List.rev ralias) in 50 | if Name.is_qualified name then Name.qualify alias (Name.unqualify name) else alias 51 | | _ -> name 52 | 53 | 54 | let to_list : t -> (Name.t * Name.t) list = 55 | List.map ~f:(fun (ralias,fullname)-> (Name.unsplit_module_name (List.rev ralias), fullname)) 56 | -------------------------------------------------------------------------------- /kindEngine/infer.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | open Common.ConcreteSyntax 4 | open Heart 5 | open InferKind 6 | 7 | (* Responsibilities of the kind checker: 8 | * - Kindcheck all types in the program 9 | * - Translate user types to internal types 10 | * - Collect lists of data types, synonyms and constructors 11 | * - Expand all synonyms (i.e., replace `id(int)` by `id(int) == int`) 12 | * - Transate type definition groups and externals to Heart.Expr *) 13 | 14 | (************************************************************** 15 | * Resolve kinds: from InfKind to Kind and UserType to Type 16 | **************************************************************) 17 | let resolve_kind infkind = let open InferMonad in 18 | let rec resolve = function 19 | | InfKind.Var _ -> Kind.Prim.star 20 | | InfKind.Con k -> k 21 | | InfKind.App(k1,k2) -> Kind.App(resolve k1, resolve k2) 22 | in 23 | let%bind skind = subst infkind in 24 | return @@ resolve skind 25 | 26 | let resolve_type_binder_def TypeBinder.{name; kind=infkind} = let open InferMonad in 27 | let%bind kind = resolve_kind infkind in 28 | let%bind qname = qualify_def name in 29 | return TypeBinder.{name=qname; kind} 30 | 31 | let resolve_type_binder TypeBinder.{name; kind=infkind} = let open InferMonad in 32 | let%bind kind = resolve_kind infkind in 33 | return TypeBinder.{name; kind} 34 | 35 | (** 36 | * `resolve_type` takes: a map from locally quantified type name variables to types, 37 | * a boolean that is `true` if partially applied type synonyms are allowed (i.e. when 38 | * these are arguments to type synonyms themselves), a user type with inference kinds, 39 | * and it returns a fully resolved type. *) 40 | let rec resolve_type idmap partial_syn user_type = let open InferMonad in 41 | let open KindedUserType in 42 | let open UserQuantifier in 43 | let rec collect_args tp args = match tp with 44 | | App(tp', args') -> collect_args tp' (args' @ args) 45 | | Parens(tp') -> collect_args tp' args 46 | | Ann(tp',_) -> collect_args tp' args 47 | | _ -> (tp, args) 48 | in 49 | let resolve_param (name,tp) = 50 | let%bind tp' = resolve_type idmap false tp in 51 | return (name,tp') 52 | in 53 | match user_type with 54 | | Quan(Forall, tname, tp) -> 55 | let%bind tname' = resolve_type_binder tname in 56 | let%bind tvar = fresh_type_var tname' Kind.Flavour.Bound in 57 | let%bind tp' = resolve_type (Name.Map.set idmap ~key:tname.TypeBinder.name ~data:tvar) false tp in 58 | return @@ Type.quantify [tvar] tp' 59 | 60 | | Quan(Some, tname, tp) -> 61 | let%bind tname' = resolve_type_binder tname in 62 | let%bind tvar = fresh_type_var tname' Kind.Flavour.Meta in 63 | let%bind tp' = resolve_type (Name.Map.set idmap ~key:tname.TypeBinder.name ~data:tvar) false tp in 64 | return @@ Type.quantify [tvar] tp' 65 | 66 | | Quan(Exists, _tname, _tp) -> 67 | failwith "TODO: KindEngine.Infer.resolve_type: existentials are not supported yet" 68 | 69 | | Qual(preds,tp) -> 70 | let%bind preds' = mapM (resolve_predicate idmap) preds in 71 | let%bind tp' = resolve_type idmap false tp in 72 | return @@ Type.qualify preds' tp' 73 | 74 | | Fun(args, effect, tp) -> 75 | let%bind args' = mapM resolve_param args in 76 | let%bind effect' = resolve_type idmap false effect in 77 | let%bind tp' = resolve_type idmap false tp in 78 | return @@ Type.TFun(args', effect', tp') 79 | 80 | | App(tp,args) -> resolve_app idmap partial_syn (collect_args tp args) 81 | | Var(_name) -> resolve_app idmap partial_syn (user_type, []) 82 | | Con(_name) -> resolve_app idmap partial_syn (user_type, []) 83 | | Parens(tp) -> resolve_type idmap partial_syn tp 84 | | Ann(tp,_) -> resolve_type idmap partial_syn tp 85 | 86 | and resolve_predicate idmap tp = let open InferMonad in 87 | match%bind resolve_type idmap false tp with 88 | | Type.TCon(tc) -> return @@ Type.PredIFace(tc.name, []) 89 | | Type.TApp(Type.TCon(tc), targs) -> return @@ Type.PredIFace(tc.name, targs) 90 | | tp' -> failwithf "KindEngine.Infer.resolve_predicate: invalid predicate: %s" (Type.Show_typ.show tp') () 91 | 92 | (* Kind/Infer.hs:944 *) 93 | and resolve_app idmap partial_syn = let open InferMonad in 94 | function 95 | | KindedUserType.Var(name), args -> 96 | let%bind (tp', kind) = match Name.Map.find idmap name with 97 | | None -> failwithf "Type variable %s is undefined" (Name.show name) () 98 | (* let%bind id = Unique.id (Name.show name) in return (Type.TVar Type.{type_var_id=id; type_var_kind=Kind.Prim.star; type_var_flavour=Flavour.Bound}, Kind.Prim.star) *) 99 | | Some tvar -> return (Type.TVar(tvar), tvar.Type.TypeVar.kind) 100 | in 101 | let%bind args' = mapM (resolve_type idmap false) args in 102 | return @@ Type.type_app tp' args' 103 | 104 | | KindedUserType.Con(name), [fixed;ext] when (Name.equal name Name.effect_append) -> 105 | let%bind fixed' = resolve_type idmap false fixed in 106 | let%bind ext' = resolve_type idmap false ext in 107 | let (ls,tl) = Type.extract_ordered_effect fixed' in 108 | if not (Type.is_effect_empty tl) then 109 | failwith "Effects can only have one extension point"; 110 | return @@ Type.shallow_effect_extend fixed' ext' 111 | 112 | | KindedUserType.Con(name), args -> 113 | let%bind qname, ikind = find_inf_kind name in 114 | let%bind kind = resolve_kind ikind in begin 115 | match%bind lookup_syn_info name with 116 | | Some(Type.{syn_info_name; syn_info_kind; syn_info_params; syn_info_typ; syn_info_rank; syn_info_doc} as syn) -> 117 | (* check over/under application *) 118 | if not partial_syn && List.length args < List.length syn_info_params then 119 | failwithf "Type alias %s has too few arguments" (Name.show name) (); 120 | if List.length args > List.length syn_info_params then 121 | failwithf "Type alias %s has too many arguments" (Name.show name) (); 122 | let%bind args' = mapM (resolve_type idmap true) args in 123 | let tsyn = Type.TSyn({type_syn_name=syn_info_name; 124 | type_syn_kind=syn_info_kind; 125 | type_syn_rank=syn_info_rank; 126 | type_syn_info=Some(syn)}, 127 | args', 128 | TypeVar.HasTypeVar_typ.(TypeVar.sub_new (List.zip_exn syn_info_params args') |-> syn_info_typ)) 129 | in return tsyn 130 | (* NOTE: on partially applied type synonyms, we get a funky body type with free parameters but this 131 | * s only inside synonyms arguments so we are ok. *) 132 | | None -> 133 | let%bind args' = mapM (resolve_type idmap false) args in 134 | return (Type.type_app (Type.TCon{name; kind}) args') 135 | end 136 | 137 | | _ -> failwith "KindEngine.Infer.resolve_app: this case should never occur after kind checking" 138 | 139 | 140 | let resolve_con_param idmap (vis,vb) = let open InferMonad in 141 | let%bind typ = resolve_type idmap false vb.ValueBinder.typ in 142 | let%bind expr = match vb.ValueBinder.expr with 143 | | None -> return None 144 | | Some e -> (* return @@ Some *) 145 | failwith "KindEngine.Infer.resolve_con_param: option parameter expression in constructor" 146 | in 147 | return (vis, {vb with typ; expr}) 148 | 149 | 150 | let resolve_constructor type_name type_sort is_singleton type_result type_params idmap constr = let open InferMonad in 151 | let open UserCon in 152 | let%bind qname = qualify_def constr.name in 153 | let%bind exist' = mapM resolve_type_binder constr.exists in 154 | let%bind exist_vars = mapM (fun ename -> fresh_type_var ename Kind.Flavour.Bound) exist' in 155 | let idmap' = 156 | Name.Map.union 157 | (Name.Map.of_alist_exn @@ 158 | List.zip_exn (List.map ~f:(fun uc -> uc.name) constr.exists) exist_vars) 159 | idmap 160 | in 161 | let%bind params' = mapM (resolve_con_param idmap') constr.params in 162 | let result = Type.type_app type_result (List.map ~f:(fun t -> Type.TVar t) type_params) in 163 | let scheme = Type.quantify (type_params @ exist_vars) @@ 164 | if List.is_empty params' then 165 | result 166 | else 167 | Type.type_fun (List.map ~f:(fun (_,p) -> (p.name, p.typ)) params') Type.type_total result 168 | in 169 | return (UserCon.{name = qname; exists= exist'; params = params'; vis = constr.vis; doc = constr.doc}, 170 | Type.{con_info_name = qname; 171 | con_info_type_name = type_name; 172 | con_info_foralls = type_params; 173 | con_info_exists = exist_vars; 174 | con_info_params = 175 | List.mapi params' ~f:(fun i (_,b) -> 176 | let i = i+1 in (* 1-indexed *) 177 | (if Name.is_nil b.ValueBinder.name then 178 | Name.new_field_name (Int.to_string i) 179 | else b.ValueBinder.name), 180 | b.ValueBinder.typ); 181 | con_info_type = scheme; 182 | con_info_type_sort = type_sort; 183 | con_info_param_vis = List.map ~f:fst params'; 184 | con_info_singleton = is_singleton; 185 | con_info_doc = constr.doc}) 186 | 187 | let rec occurs names is_neg = function 188 | | Type.TForall(_,_,tp) -> occurs names is_neg tp 189 | | Type.TFun(args,effect,result) -> List.exists ~f:(occurs names (not is_neg)) (List.map ~f:snd args) || occurs names is_neg effect || occurs names is_neg result 190 | | Type.TCon(tcon) -> if List.mem names tcon.Type.TypeCon.name ~equal:Name.equal then is_neg else false 191 | | Type.TVar(tvar) -> false 192 | | Type.TApp(tp,args) -> List.exists ~f:(occurs names is_neg) (tp::args) 193 | | Type.TSyn(_,_,tp) -> occurs names is_neg tp 194 | 195 | let occurs_negative names tp = occurs names false tp 196 | 197 | let resolve_typedef is_rec rec_names = let open InferMonad in 198 | let rec kind_arity = function 199 | | Kind.App(Kind.App(kcon, k1), k2) when Kind.equal kcon Kind.Prim.arrow -> k1::(kind_arity k2) 200 | | _ -> [] 201 | in 202 | function 203 | | TypeDef.Synonym{binder=syn; params; synonym=tp; vis; doc} -> 204 | let%bind syn' = resolve_type_binder_def syn in 205 | let%bind params' = mapM resolve_type_binder params in 206 | let%bind type_vars = mapM (fun param -> fresh_type_var param Kind.Flavour.Bound) params' in 207 | let tvar_map = Name.Map.of_alist_exn @@ 208 | List.zip_exn (List.map ~f:(fun p -> p.TypeBinder.name) params') type_vars 209 | in 210 | let%bind tp' = resolve_type tvar_map true tp in 211 | (* eta-expand type synonyms *) 212 | let kind = syn'.kind in 213 | let arity = kind_arity kind in 214 | let eta_kinds = List.drop arity (List.length type_vars) in 215 | let eta_tp, eta_params = 216 | if List.is_empty eta_kinds then 217 | (tp', type_vars) 218 | else 219 | let eta_vars = List.map eta_kinds ~f:(fun kind -> Type.TypeVar.{id=Unique.unique_id "eta"; kind; flavour=Type.Flavour.Bound}) in 220 | (Type.type_app tp' (List.map ~f:(fun t -> Type.TVar t) eta_vars), type_vars @ eta_vars) 221 | in 222 | let syn_info = Type.{ 223 | syn_info_name = syn'.TypeBinder.name; 224 | syn_info_kind = syn'.TypeBinder.kind; 225 | syn_info_params = eta_params; 226 | syn_info_typ = eta_tp; 227 | syn_info_rank = Type.max_synonym_rank eta_tp; 228 | syn_info_doc = doc 229 | } 230 | in 231 | return @@ Expr.TypeDef.Synonym{syn_info; vis} 232 | 233 | | TypeDef.DataType{binder=newtp; params; constrs=constructors; sort; def=ddef; vis; is_extend; doc} -> 234 | let%bind newtp' = 235 | if is_extend then 236 | let%bind name, ikind = find_inf_kind newtp.name in 237 | let%bind kind = resolve_kind ikind in 238 | return TypeBinder.{name; kind} 239 | else 240 | resolve_type_binder_def newtp 241 | in 242 | let%bind params' = mapM resolve_type_binder params in 243 | let type_result = Type.TCon{name=newtp'.name; kind=newtp'.kind} in 244 | let%bind type_vars = 245 | let kargs, kres = Kind.extract_kind_fun newtp'.kind in 246 | if List.is_empty params' && not (List.is_empty kargs) then 247 | (* invent parameters if they are not given (and it has an arrow kind) *) 248 | forM kargs (fun karg -> return Type.TypeVar.{id=Unique.unique_id "k"; kind=karg; flavour=Kind.Flavour.Bound}) 249 | else 250 | forM params' (fun param -> fresh_type_var param Kind.Flavour.Bound) 251 | in 252 | let tvar_map = Name.Map.of_alist_exn @@ List.zip_exn (List.map params' ~f:(fun p -> p.name)) type_vars in 253 | let%bind consinfos = 254 | forM constructors 255 | (resolve_constructor newtp'.name sort 256 | ((not @@ Syntax.DataDef.is_open ddef) && List.length constructors = 1) 257 | type_result type_vars tvar_map) 258 | in 259 | let (constructors', infos) = List.unzip consinfos in begin 260 | match sort with 261 | | Retractive -> return () 262 | | _ -> if List.exists ~f:(occurs_negative rec_names) 263 | (List.concat_map infos ~f:(fun c -> List.map ~f:snd c.Type.con_info_params)) then 264 | failwithf "Type %s is declared is declared as being (co)inductive but it occurs\n recursively in a negative position.\n hint: declare it as a 'rectype' to allow negative occurances" (Name.show @@ Name.unqualify newtp.name) () 265 | else return () 266 | end >> 267 | let data_info = Type.{data_info_sort = sort; 268 | data_info_name = newtp'.name; 269 | data_info_kind = newtp'.kind; 270 | data_info_params = type_vars; 271 | data_info_constrs = infos; 272 | data_info_def = Syntax.(match ddef with Normal when is_rec -> Rec | _ -> ddef); 273 | data_info_doc = doc } 274 | in 275 | return @@ Expr.TypeDef.Data {data_info; vis; con_vis=List.map ~f:(fun uc -> uc.vis) constructors; is_extend} 276 | 277 | 278 | (************************************************************** 279 | * Setup type environment for recursive definitions 280 | **************************************************************) 281 | let rec user_kind_to_inf_kind = let open InferMonad in 282 | function 283 | | UserKind.Con(name) -> return @@ InfKind.Con(Kind.Constant name) 284 | | UserKind.Arrow(k1,k2) -> 285 | let%bind k1' = user_kind_to_inf_kind k1 in 286 | let%bind k2' = user_kind_to_inf_kind k2 in begin 287 | match (k1', k2') with 288 | | InfKind.Con(kk1), InfKind.Con(kk2) -> 289 | return @@ InfKind.Con(Kind.Prim.fun_1 kk1 kk2) 290 | | _ -> return @@ InfKind.App(k1',k2') 291 | end 292 | | UserKind.Parens(k) -> user_kind_to_inf_kind k 293 | | UserKind.None -> fresh_kind 294 | 295 | let bind_type_binder TypeBinder.{name; kind=user_kind} = let open InferMonad in 296 | let%bind kind = user_kind_to_inf_kind user_kind in 297 | return @@ TypeBinder.{name; kind} 298 | 299 | let bind_typedef tdef = let open InferMonad in (* extension *) 300 | let%bind TypeBinder.{name;kind} = bind_type_binder (TypeDef.binder tdef) in 301 | let is_extend = TypeDef.is_extend tdef in 302 | let%bind qname = if is_extend then return name else qualify_def name in 303 | return (TypeBinder.{name=qname;kind}, not is_extend) 304 | 305 | (************************************************************** 306 | * Infer kinds for the type definition groups 307 | **************************************************************) 308 | 309 | let unify_binder tbinder defbinder infgamma reskind = let open InferMonad in 310 | let kind = InfKind.fun_n (List.map ~f:(fun tb -> tb.TypeBinder.kind) infgamma) reskind in 311 | Unify.unify Unify.Infer tbinder.TypeBinder.kind kind >> 312 | return tbinder 313 | 314 | let inf_user_type expected context user_type = assert false 315 | 316 | let inf_con_value_binder (vis, (ValueBinder.{typ} as vb)) = let open InferMonad in 317 | let%bind tp' = inf_user_type InfKind.star (Unify.Check "Constructor parameters must be values") typ in 318 | return (vis, ValueBinder.{vb with typ=tp'}) 319 | 320 | let inf_constructor (UserCon.{exists; params} as constr) = let open InferMonad in 321 | let%bind infgamma = mapM bind_type_binder exists in 322 | let%bind params' = extend_inf_gamma infgamma (mapM inf_con_value_binder params) in 323 | return @@ UserCon.{constr with exists=infgamma; params=params'} 324 | 325 | let inf_typedef (tbinder,td) = let open InferMonad in 326 | match td with 327 | | TypeDef.Synonym({binder=syn; params=args; synonym=tp} as sr) -> 328 | let%bind infgamma = mapM bind_type_binder args in 329 | let%bind kind = fresh_kind in 330 | let%bind tp' = extend_inf_gamma infgamma (inf_user_type kind Unify.Infer tp) in 331 | let%bind tbinder' = unify_binder tbinder syn infgamma kind in 332 | return @@ TypeDef.Synonym{sr with binder = tbinder'; params = infgamma; synonym=tp' } 333 | 334 | | TypeDef.DataType({binder=newtp; params=args; constrs=constructors; def; is_extend} as dtr) -> 335 | let%bind infgamma = mapM bind_type_binder args in 336 | let%bind constructors' = extend_inf_gamma infgamma (mapM inf_constructor constructors) in 337 | (* TODO: unify extended datatype kind with original *) 338 | let%bind reskind = if Syntax.DataDef.is_open def then return InfKind.star else fresh_kind in 339 | let%bind tbinder' = unify_binder tbinder newtp infgamma reskind in begin 340 | if not is_extend then 341 | return () 342 | else 343 | let%bind (qname, kind) = find_inf_kind newtp.name in 344 | Unify.unify (Unify.Check "extended type must have the same kind as the open type") tbinder'.kind kind 345 | end >> 346 | return @@ TypeDef.DataType{dtr with binder = tbinder'; params = infgamma; constrs=constructors'} 347 | 348 | let check_recursion tdefs = 349 | if (List.length tdefs > 1) && (List.for_all tdefs ~f:TypeDef.is_synonym) then 350 | failwith "Type synonyms cannot be recursive"; 351 | InferMonad.return () 352 | 353 | let inf_type_defs is_rec tdefs : Heart.Expr.TypeDef.group InferMonad.t = let open InferMonad in 354 | let%bind xinfgamma = mapM bind_typedef tdefs in 355 | let infgamma = List.map ~f:fst @@ List.filter ~f:snd xinfgamma in 356 | let%bind ctdefs = extend_inf_gamma infgamma @@ begin (* extend inference gamma, also checks for duplicates *) 357 | let names = List.map ~f:(fun TypeBinder.{name} -> name) infgamma in 358 | let%bind tdefs1 = mapM inf_typedef (List.zip_exn (List.map ~f:fst xinfgamma) tdefs) in 359 | mapM (resolve_typedef is_rec names) tdefs1 360 | end in 361 | check_recursion tdefs >> (* check for recursive type synonym definitions rather late so we spot duplicate definitions first *) 362 | return @@ ctdefs 363 | 364 | let inf_type_def_group = let open TypeDefGroup in function 365 | | Rec tdefs -> inf_type_defs true tdefs 366 | | NonRec tdef -> inf_type_defs false [tdef] 367 | 368 | let rec inf_type_def_groups = let open InferMonad in function 369 | | tdgroup::tdgroups -> 370 | let%bind ctdgroup = inf_type_def_group tdgroup in 371 | let%bind (ctdgroups,kgamma,syns) = extend_kgamma ctdgroup (inf_type_def_groups tdgroups) in 372 | return (ctdgroup::ctdgroups, kgamma, syns) 373 | | [] -> 374 | let%bind kgamma = get_kgamma in 375 | let%bind syns = get_synonyms in 376 | return ([],kgamma,syns) 377 | 378 | 379 | (************************************************************** 380 | * Main function 381 | **************************************************************) 382 | let infer_kinds 383 | (max_struct_fields : int) (* max struct fields option *) 384 | (imports : ImportMap.t) (* import aliases *) 385 | (kgamma0 : KGamma.t) (* initial kind gamma *) 386 | (syns0 : Synonyms.t) (* initial list of synonyms *) 387 | program (* original program *) 388 | = 389 | let (cgroups, kgamma1, syns1) = InferMonad.run_kind_infer program.Program.name imports kgamma0 syns0 (inf_type_def_groups program.Program.typedefs) in 390 | assert false 391 | -------------------------------------------------------------------------------- /kindEngine/inferKind.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | 4 | (** Inference Kind: These kinds contain meta kind-variables *) 5 | module InfKind = struct 6 | type t = 7 | | Var of Common.Id.t (* variable *) 8 | | Con of Heart.Kind.t (* constant *) 9 | | App of t * t (* application *) 10 | [@@deriving show] 11 | 12 | let star = Con Heart.Kind.Prim.star 13 | (* let inf_kind_handled = KICon Kind.kind_handled *) 14 | let fun_1 k1 k2 = App(App(Con Heart.Kind.Prim.arrow, k1), k2) (* (->) k1 k2 *) 15 | let fun_n kinds k = List.fold_right ~init:k ~f:fun_1 kinds 16 | 17 | (* HasKindVar *) 18 | let rec (|=>) sub kind = match kind with 19 | | Var id -> (match Id.Map.find sub id with Some k -> k | None -> kind) 20 | | Con _ -> kind 21 | | App (k1,k2) -> App (sub |=> k1, sub |=> k2) 22 | let rec fkv = function 23 | | Var id -> Id.Set.singleton id 24 | | Con _ -> Id.Set.empty 25 | | App (k1,k2) -> Id.Set.union (fkv k1) (fkv k2) 26 | end 27 | 28 | module InfKGamma = struct 29 | type t = InfKind.t Common.Name.Map.t 30 | end 31 | 32 | 33 | (************************************************************** 34 | * Substitution 35 | **************************************************************) 36 | open Util 37 | 38 | (* module HasKindVar_list(H:HasKindVar) : HasKindVar with type t = H.t list = struct 39 | * type t = H.t list 40 | * let (|=>) sub = List.map ~f:(H.(|=>) sub) 41 | * let fkv = Id.Set.union_list <.> List.map ~f:H.fkv 42 | * end 43 | * 44 | * module HasKindVar_list_inf_kind = HasKindVar_list(InfKind) *) 45 | module KVs = struct 46 | type t = Id.Set.t 47 | let member = Util.flip Id.Set.mem 48 | let list = Id.Set.to_list 49 | end 50 | 51 | module KSub = struct 52 | type t = InfKind.t Id.Map.t 53 | 54 | let empty : t = Id.Map.empty 55 | let single id kind = Id.Map.singleton id kind 56 | 57 | (* Left-biased union *) 58 | let union m1 m2 = Id.Map.merge m1 m2 ~f:(fun ~key -> 59 | function `Both(l,r) -> Some l | `Left l -> Some l | `Right r -> Some r) 60 | 61 | (* HasKindVar *) 62 | let (|=>) sub ksub = Id.Map.map ~f:(InfKind.(|=>) sub) ksub 63 | let fkv (sub:t) : KVs.t = Id.Map.data sub |> List.map ~f:InfKind.fkv |> Id.Set.union_list 64 | 65 | (* Assumes a left-biased union (which it is) *) 66 | let (@@@) sub1 sub2 = union sub1 (sub1 |=> sub2) 67 | end 68 | 69 | module type HasKindVar = sig 70 | type t 71 | val (|=>) : KSub.t -> t -> t 72 | val fkv : t -> KVs.t 73 | end 74 | 75 | 76 | (************************************************************** 77 | * Precedence 78 | **************************************************************) 79 | module Prec = struct 80 | type t = Int.t 81 | let top = 0 82 | let arrow = 1 83 | let app = 2 84 | let atom = 3 85 | end 86 | (* let pparens ctxt prec doc = if ctxt >= prec then parens doc else doc *) 87 | -------------------------------------------------------------------------------- /kindEngine/inferMonad.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | open InferKind 4 | 5 | type kst = KSub.t 6 | type kenv = { 7 | current_module : Name.t; 8 | imports : ImportMap.t; 9 | kgamma : KGamma.t; 10 | infgamma : InfKGamma.t; 11 | synonyms : Synonyms.t 12 | } 13 | 14 | type 'a kresult = { 15 | result: 'a; 16 | (* errors: (range * doc) list; *) 17 | (* warnings: (range * doc) list; *) 18 | st: kst; 19 | } 20 | 21 | (* kinfer *) 22 | module Let_syntax = struct 23 | type 'a t = kenv -> kst -> 'a kresult 24 | let map (ki:'a t) ~(f:'a -> 'b) : 'b t = fun env st -> 25 | let r = ki env st in 26 | {r with result = f (r.result) } 27 | let return (x:'a) : 'a t = fun env st -> {result=x; st} 28 | let bind (ki:'a t) ~(f:'a -> 'b t) : 'b t = fun env st -> 29 | let {result=x; (* errs1; warns1; *) st=st1} = ki env st in 30 | let {result=y; (* errs2; warns2; *) st=st2} = (f x) env st1 in 31 | {result=y; (* errors=errs1^errs2; warnings=warns1^warns2; *) st=st2} 32 | end 33 | include Monadic.Make(Let_syntax) 34 | 35 | let run_kind_infer module_name imports kgamma synonyms (ki:'a t) = 36 | let imports' = Option.value ~default:imports @@ 37 | ImportMap.extend (Name.to_short_module_name module_name) module_name imports 38 | in 39 | (ki {current_module=module_name; imports=imports'; kgamma; infgamma=Name.Map.empty; synonyms} 40 | KSub.empty).result 41 | 42 | 43 | let get_kind_env : kenv t = fun env st -> {result=env; st} 44 | 45 | (* let add_error range doc : unit t = 46 | * add_range_info range Error(doc) >> 47 | * fun env st -> {result=(); errors=[(range,doc)]; warnings=[]; st} 48 | * 49 | * let add_warning range doc : unit t = 50 | * add_range_info range Warning(doc) >> 51 | * fun env st -> {result=(); errors=[]; warnings=[(range,doc)]; st} *) 52 | 53 | let get_ksub : KSub.t t = fun env st -> {result=st; st} 54 | 55 | let extend_ksub (sub:KSub.t) : unit t = 56 | fun env st -> {result=(); st=KSub.(sub @@@ st)} 57 | 58 | (********************************************************************** 59 | * Operations 60 | **********************************************************************) 61 | 62 | let fresh_kind = 63 | return @@ InfKind.Var(Unique.unique_id "k") 64 | 65 | let fresh_type_var tb flavour = 66 | let open ConcreteSyntax.TypeBinder in 67 | let id = Unique.unique_id (Name.show tb.name) in 68 | return Heart.Type.TypeVar.{id; kind=tb.kind; flavour} 69 | 70 | let subst x = 71 | let%bind sub = get_ksub in 72 | return InferKind.InfKind.(sub |=> x) 73 | 74 | let get_kgamma = 75 | let%bind env = get_kind_env in 76 | return env.kgamma 77 | 78 | let get_synonyms = 79 | let%bind env = get_kind_env in 80 | return env.synonyms 81 | 82 | (** Extend the inference kind assumption; checks for shadowed definitions *) 83 | let extend_inf_gamma tbinders (ki:'a t) : 'a t = 84 | let open Common.ConcreteSyntax.TypeBinder in 85 | let check (infgamma:InfKGamma.t) tb = 86 | if Name.Map.mem infgamma tb.name then 87 | (* add_error name_range @@ Printf.sprintf "Type %s is already defined" (Name.show tb.name) *) 88 | failwith (Printf.sprintf "Type %s is already defined" (Name.show tb.name)) 89 | (* return @@ Name.Map.set infgamma ~key:tb.name ~data:tb.kind (* replaces *) *) 90 | else 91 | return @@ Name.Map.set infgamma ~key:tb.name ~data:tb.kind 92 | in 93 | let extend_unsafe tbinders ki = 94 | let inf_gamma = Name.Map.of_alist_exn @@ List.map tbinders ~f:(fun {name; kind} -> (name,kind)) in 95 | (* assumes left-biased union *) 96 | fun env st -> ki {env with infgamma=Name.Map.union inf_gamma env.infgamma} st 97 | in 98 | let%bind env = get_kind_env in 99 | foldM check env.infgamma tbinders >> 100 | extend_unsafe tbinders ki 101 | 102 | (** Extend the kind assumption; checks for shadowed definitions *) 103 | let extend_kgamma (tdefs:Heart.Expr.TypeDef.group) (ki:'a t) : 'a t = 104 | (* NOTE: duplication check already happens in extendInfGamma but 105 | * there can still be a clash with a definition in another inference group *) 106 | let name_kind = let open Heart.Expr.TypeDef in function 107 | | Synonym{syn_info} -> Heart.Type.(syn_info.syn_info_name, syn_info.syn_info_kind) 108 | | Data{data_info} -> Heart.Type.(data_info.data_info_name, data_info.data_info_kind) 109 | in 110 | let check (kgamma, tdefs) tdef = 111 | if Heart.Expr.TypeDef.is_extension tdef then 112 | return (kgamma, tdefs) 113 | else 114 | let (name,kind) = name_kind tdef in 115 | match KGamma.lookup_q name kgamma with 116 | | None -> return (KGamma.extend ~name ~data:kind kgamma, tdef::tdefs) 117 | | Some _ -> 118 | failwith (Printf.sprintf "Type %s is already defined" (Name.show name)) 119 | (* return (kgamma, tdefs) *) 120 | in 121 | let extend_unsafe tdefs (ki:'a t) : 'a t = 122 | let new_kgamma = KGamma.new_dedup (List.map ~f:name_kind tdefs) in 123 | let ksyns = Synonyms.create (List.concat_map tdefs ~f:(function Heart.Expr.TypeDef.Synonym{syn_info} -> [syn_info] | _ -> [])) in 124 | fun env st -> ki {env with kgamma = KGamma.union env.kgamma new_kgamma; 125 | synonyms = Synonyms.compose env.synonyms ksyns} st 126 | in 127 | let%bind env = get_kind_env in 128 | let%bind (_, tdefs') = foldM check (env.kgamma, []) tdefs in 129 | extend_unsafe List.(rev tdefs') ki 130 | 131 | let inf_qualified_name (name:Name.t) : Name.t t = 132 | if not (Name.is_qualified name) then 133 | return name 134 | else 135 | let%bind env = get_kind_env in 136 | match ImportMap.expand name env.imports with 137 | | Second (name', alias) when Name.case_equal (Name.qualifier name) alias -> 138 | return name' 139 | | Second (_, alias) -> 140 | failwithf "module %s should be cased as %s" (Name.show name) (Name.show alias) () 141 | | First [] -> 142 | failwithf "module %s is undefined" (Name.show name) () 143 | | First aliases -> 144 | failwithf "module %s is ambiguous. It can refer to: %s" (Name.show name) (List.to_string aliases ~f:Name.show) () 145 | 146 | let find_inf_kind name0 = 147 | let%bind env = get_kind_env in 148 | let (name,mb_alias) = match ImportMap.expand name0 env.imports with 149 | | Second (name', alias) -> (name', Some alias) 150 | | _ -> (name0, None) 151 | in 152 | (* lookup locally 153 | * NOTE: also lookup qualified since it might be recursive definition 154 | * TODO: check for the locally inferred names for casing too. *) 155 | match Name.Map.find env.infgamma name with 156 | | Some infkind -> return (name, infkind) 157 | | None -> match KGamma.lookup env.current_module name env.kgamma with 158 | | Found(qname,kind) -> 159 | let name' = if Name.is_qualified name then qname else (Name.unqualify qname) in 160 | if not (Name.case_equal name' name) then 161 | failwithf "type %s should be cased as %s." (Name.show @@ Name.unqualify name0) (Name.show @@ Name.unqualify name') (); 162 | if (Option.is_some mb_alias) && not (String.equal name0.Name.name_module (Name.show @@ Option.value_exn mb_alias)) then 163 | failwithf "module %s should be cased as %s." name0.Name.name_module (Name.show @@ Option.value_exn mb_alias) (); 164 | return (qname, InfKind.Con(kind)) 165 | | NotFound -> 166 | failwithf "Type %s is not defined.\n hint: bind the variable using 'forall<%s>'?" (Name.show name) (Name.show name) () 167 | | Ambiguous names -> 168 | failwithf "Type %s is ambiguous. It can refer to: %s" (Name.show name) (List.to_string names ~f:Name.show) () 169 | 170 | let qualify_def name = 171 | let%bind env = get_kind_env in 172 | return (Name.qualify env.current_module name) 173 | 174 | let find_kind name = 175 | let%bind env = get_kind_env in 176 | match KGamma.lookup env.current_module name env.kgamma with 177 | | Found(qname,kind) -> return (qname, kind) 178 | | _ -> failwithf "KindEngine.InferMonad.find_kind: unknown type constructor: %s" (Name.show name) () 179 | 180 | let lookup_syn_info name = 181 | let%bind env = get_kind_env in 182 | return (Synonyms.lookup name env.synonyms) 183 | -------------------------------------------------------------------------------- /kindEngine/kGamma.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | open Common.Util 4 | 5 | (* Kind assumptions *) 6 | type t = Heart.Kind.t QNameMap.t 7 | 8 | let empty = QNameMap.empty 9 | let single = QNameMap.single 10 | let create = QNameMap.of_list 11 | let new_dedup xs = QNameMap.of_list @@ List.dedup_and_sort ~compare:(fun (n1,x) (n2,y) -> Name.compare n1 n2) xs 12 | 13 | let extend = QNameMap.insert 14 | let lookup = QNameMap.lookup 15 | let lookup_q = QNameMap.lookup_q (* Lookup a fq-name *) 16 | let find ctxt name kg = match lookup ctxt name kg with 17 | | QNameMap.Found(qname,scheme) -> (qname,scheme) 18 | | _ -> failwithf "Kind.Assumption.kgammaFind: unbound type '%s' in %s" (Name.show name) 19 | (List.to_string ~f:(fun (k,v) -> Printf.sprintf "(%s) => %s" (Name.show k) (Heart.Kind.show v)) @@ QNameMap.to_alist kg) () 20 | 21 | let to_list kg = List.sort ~compare:(fun (n1,_) (n2,_) -> Name.compare n1 n2) @@ QNameMap.to_alist kg 22 | let filter mod_name = QNameMap.filter_names ~f:(Name.equal mod_name <.> Name.qualifier) 23 | 24 | (** kind gamma union; error on duplicates *) 25 | let union = QNameMap.union 26 | let union_list = QNameMap.union_list 27 | 28 | 29 | (**************************************************** 30 | * Initial kind gamma 31 | ****************************************************) 32 | (** The initial kind gamma contains the 'builtinTypes'. *) 33 | let init = empty 34 | let is_empty = QNameMap.is_empty 35 | -------------------------------------------------------------------------------- /kindEngine/kGamma.mli: -------------------------------------------------------------------------------- 1 | open Common 2 | open Heart 3 | 4 | type t = Kind.t QNameMap.t 5 | val empty : t 6 | val single : Name.t -> Kind.t -> t 7 | val create : (Name.t * Kind.t) list -> t 8 | val new_dedup : (Name.t * Kind.t) Util.List.t -> t 9 | val extend : name:Name.t -> data:Kind.t -> t -> t 10 | val lookup : Name.t -> Name.t -> t -> Kind.t QNameMap.lookup 11 | val lookup_q : Name.t -> t -> Kind.t option 12 | val find : Name.t -> Name.t -> t -> Name.t * Kind.t 13 | val to_list :t -> (Name.t * Kind.t) Util.List.t 14 | val filter : Name.t -> t -> t 15 | val union : t -> t -> t 16 | val union_list : t list -> t 17 | val init : t 18 | val is_empty : t -> bool 19 | -------------------------------------------------------------------------------- /kindEngine/synonyms.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | open Common.Util 4 | open Heart 5 | (* Instantiate type synonyms *) 6 | 7 | (* Synonyms: a map from type synonym names to a tuple of a synonym 8 | * type scheme ('SynInfo'), an integer that gives the relative _rank_ of the type synonym *) 9 | type t = Type.syn_info Name.Map.t 10 | 11 | let empty : t = Name.Map.empty 12 | let is_empty : t -> bool = Name.Map.is_empty 13 | let create : Type.syn_info list -> t = 14 | Name.Map.of_alist_exn <.> List.map ~f:(fun syninfo -> syninfo.Type.syn_info_name, syninfo) 15 | 16 | let type_defs : t -> t = id 17 | let extend (syn_info:Type.syn_info) (m:t) : t = Name.Map.set m ~key:syn_info.Type.syn_info_name ~data:syn_info 18 | let lookup (name:Name.t) (map:t) : Type.syn_info option = Name.Map.find map name 19 | let compose (m1:t) (m2:t) : t = Name.Map.union m1 m2 20 | let find (name:Name.t) (syn:t) = 21 | match lookup name syn with 22 | | None -> failwithf "KindEngine.Synonyms.find: unknown type synonym:%s" (Name.show name) () 23 | | Some x -> x 24 | 25 | let filter (mod_name:Name.t) (s:t) = 26 | Name.Map.filter_keys s ~f:(fun name -> Name.equal (Name.qualifier name) mod_name) 27 | 28 | let to_list (syns:t) : Type.syn_info list = List.map ~f:snd (Name.Map.to_alist syns) 29 | (* let pretty (syns:t) = *) 30 | 31 | (** Extract synonym environment from core program *) 32 | let extract_synonyms core = assert false (* TODO: implement *) 33 | 34 | let extract_type_def : Expr.TypeDef.t -> t = function 35 | | Expr.TypeDef.Synonym { syn_info; vis=Syntax.Visibility.Public } -> 36 | Name.Map.singleton syn_info.Type.syn_info_name syn_info 37 | | _ -> Name.Map.empty 38 | 39 | let extract_type_def_group (tdefs:Expr.TypeDef.group) = 40 | List.map ~f:extract_type_def tdefs 41 | -------------------------------------------------------------------------------- /kindEngine/unify.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open InferKind 3 | 4 | type t = 5 | | Ok of KSub.t 6 | | InfiniteKind 7 | | NoMatch 8 | 9 | type context = 10 | | Check of string (* * range *) 11 | | Infer (* of range *) 12 | 13 | (* TODO: replace this with Kind.equal *) 14 | let rec match_kind k1 k2 = let open Heart.Kind in match k1,k2 with 15 | | Constant(c1), Constant(c2) -> Common.Name.equal c1 c2 16 | | App(k1, k2), App(l1, l2) -> match_kind k1 l1 && match_kind k2 l2 17 | | _ -> false 18 | 19 | let unify_var id kind = 20 | if KVs.member id (InfKind.fkv kind) then 21 | InfiniteKind 22 | else Ok (KSub.single id kind) 23 | 24 | 25 | (* TODO: What the heck does 'mgu' stand for? something something unify? *) 26 | let rec mgu ik1 ik2 = 27 | let open InfKind in 28 | match ik1,ik2 with 29 | | Var(id1), Var(id2) when id1 = id2 -> Ok KSub.empty 30 | | Con(k1), Con(k2) -> if match_kind k1 k2 then Ok KSub.empty else NoMatch 31 | | App(k1,k2), App(l1,l2) -> begin 32 | match mgu k1 l1 with 33 | | Ok(sub1) -> begin 34 | match mgu InfKind.(sub1 |=> k2) InfKind.(sub1 |=> l2) with 35 | | Ok(sub2) -> Ok KSub.(sub2 @@@ sub1) 36 | | err -> err 37 | end 38 | | err -> err 39 | end 40 | 41 | (* pull up Applications *) 42 | | Con(App(k1,k2)), App(l1,l2) -> mgu (App(Con k1, Con k2)) (App(l1, l2)) 43 | | App(k1,k2), Con(App(l1,l2)) -> mgu (App(k1, k2)) (App(Con l1, Con l2)) 44 | 45 | (* unify variables *) 46 | | Var(id), kind -> unify_var id kind 47 | | kind, Var(id) -> unify_var id kind 48 | 49 | (* no match *) 50 | | _ -> NoMatch 51 | 52 | let kind_error context err kind1 kind2 = 53 | let message = match err with 54 | | InfiniteKind -> "Invalid type (due to an infinite kind)\n" 55 | | _ -> "Invalid type\n" 56 | in 57 | let expected = match context with 58 | | Check msg -> Format.sprintf " because %s" msg 59 | | Infer -> "" 60 | in 61 | failwithf "%sinferred kind: %s\nexpected kind:%s%s" message expected (InfKind.show kind1) (InfKind.show kind2) () 62 | 63 | let unify (context:context) (kind1:InfKind.t) (kind2:InfKind.t) = let open InferMonad in 64 | let%bind skind1 = subst kind1 in 65 | let%bind skind2 = subst kind2 in 66 | match mgu skind1 skind2 with 67 | | Ok(sub') -> extend_ksub sub' 68 | | err -> kind_error context err skind1 skind2 69 | 70 | 71 | -------------------------------------------------------------------------------- /misc/expr.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Var of string (* x *) 3 | | Primitive of primitive (* p *) 4 | | Apply of t * t (* e1 e2 *) 5 | | Lambda of string * t (* λx.e *) 6 | | Let of string * t * t (* let x = e1 in e2 *) 7 | | Catch of t * t (* catch e1 e2 *) 8 | | Run of t (* run e *) 9 | 10 | and primitive = Unit | Fix | Throw | New | Bang | Assign 11 | 12 | let prim_to_string = function 13 | | Unit -> "()" 14 | | Fix -> "fix" 15 | | Throw -> "throw" 16 | | New -> "new" 17 | | Bang -> "(!)" 18 | | Assign -> "(:=)" 19 | 20 | let rec to_string = function 21 | | Var(v) -> v 22 | | Primitive(p) -> prim_to_string p 23 | | Apply(f,a) -> Printf.sprintf "(%s %s)" (to_string f) (to_string a) 24 | | Lambda(a,b) -> Printf.sprintf "(fun %s -> %s)" a (to_string b) 25 | | Let(v,e,b) -> Printf.sprintf "(let %s = %s in %s)" v (to_string e) (to_string b) 26 | | Catch(ex,b) -> Printf.sprintf "(catch %s %s)" (to_string ex) (to_string b) 27 | | Run(e) -> Printf.sprintf "(run %s)" (to_string e) 28 | 29 | 30 | -------------------------------------------------------------------------------- /misc/expr.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | Var of string 3 | | Primitive of primitive 4 | | Apply of t * t 5 | | Lambda of string * t 6 | | Let of string * t * t 7 | | Catch of t * t 8 | | Run of t 9 | and primitive = Unit | Fix | Throw | New | Bang | Assign 10 | val to_string : t -> string 11 | -------------------------------------------------------------------------------- /synonyms.ml: -------------------------------------------------------------------------------- 1 | (* Instantiate type synonyms *) 2 | 3 | (* Synonyms: a map from type synonym names to a tuple of a synonym 4 | * type scheme ('SynInfo'), an integer that gives the relative _rank_ of the type synonym *) 5 | type t = Heart.Type.syn_info Common.Name.Map.t 6 | -------------------------------------------------------------------------------- /test_runner.ml: -------------------------------------------------------------------------------- 1 | Ppx_inline_test_lib.Runtime.exit () 2 | -------------------------------------------------------------------------------- /typeEngine/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typeEngine) 3 | (public_name kekka.typeEngine) 4 | (libraries core common heart) 5 | (preprocess 6 | (pps ppx_let ppx_deriving.std ppx_sexp_conv))) 7 | -------------------------------------------------------------------------------- /typeEngine/typeOperations.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | open Common.Util 4 | open Heart 5 | open TypeVar 6 | 7 | (***************************************************** 8 | * Fresh type variables 9 | *****************************************************) 10 | let freshTVar (kind:Kind.t) (flavour:Type.Flavour.t) : Type.typ = 11 | TVar (fresh_type_var kind flavour) 12 | 13 | (***************************************************** 14 | Instantiation 15 | *****************************************************) 16 | module Evidence = struct 17 | type t = { 18 | name : Expr.tname; 19 | pred : Type.pred; 20 | (* range : Range.t; *) 21 | } 22 | 23 | let show {pred = ep; _} = Type.Show_pred.show ep 24 | 25 | (* HasTypeVar *) 26 | let substitute sub ({pred = ep; _} as ev) = 27 | { ev with pred = HasTypeVar_pred.substitute sub ep } 28 | let ftv {pred = ep; _} = HasTypeVar_pred.ftv ep 29 | let btv {pred = ep; _} = HasTypeVar_pred.btv ep 30 | let (|->) sub x = if sub_is_null sub then x else substitute sub x 31 | end 32 | 33 | module HasTypeVar_evidence_list = HasTypeVar_list(Evidence) 34 | 35 | (** Instantiate a Type.type *) 36 | let rec instantiate (tp:Type.typ) : Type.rho = 37 | let (_,_,rho,_) = instantiate_ex tp in rho 38 | 39 | (** Instantiate a type and return the instantiated quantifiers, name/predicate pairs for evidence, 40 | * the instantiated type, and a core transformer function (which applies type arguments and evidence) *) 41 | and instantiate_ex (tp:Type.typ) = 42 | let (ids, preds, rho, coref) = instantiate_ex_fl Type.Flavour.Meta tp in 43 | let (erho, coreg) = extend rho in 44 | (ids, preds, erho, coreg <.> coref) 45 | 46 | and instantiate_no_ex (tp:Type.typ) = 47 | let (ids, preds, rho, coref) = instantiate_ex_fl Meta tp in 48 | (ids, preds, rho, coref) 49 | 50 | (** Ensure the result of function always gets an extensible effect Type.type 51 | * This is necessary to do on instantiation since we simplify such effect variables 52 | * away during generalization. Effectively, the set of accepted programs does not 53 | * change but the Type.types look simpler to the user. *) 54 | and extend (tp:Type.rho) : Type.rho * (Expr.expr -> Expr.expr) = 55 | match Type.expand_syn tp with 56 | | TFun (args, eff, res) -> 57 | let (ls, tl) = Type.extract_ordered_effect eff in 58 | if Type.is_effect_empty tl then 59 | let tv = freshTVar Kind.Prim.effect Meta in 60 | let open_eff = Type.effect_extends ls tv in 61 | let open_tp = Type.TFun(args, open_eff, res) in 62 | (open_tp, fun core -> Expr.open_effect_expr eff open_eff tp open_tp core) 63 | else (tp, Util.id) 64 | | _ -> (tp, Util.id) 65 | 66 | (** General instantiation for skolemize and instantiate *) 67 | and instantiate_ex_fl (flavour:Type.Flavour.t) (tp:Type.typ) 68 | : (Type.TypeVar.t list * Evidence.t list * Type.rho * (Expr.expr -> Expr.expr)) = 69 | match Type.split_pred_type tp with 70 | | ([],[],rho) -> ([], [], rho, Util.id) 71 | | (vars, preds, rho) -> 72 | let (tvars, sub) = fresh_sub flavour vars in 73 | let srho : Type.rho = HasTypeVar_typ.(sub |-> rho) in 74 | let spreds : Type.pred list = HasTypeVar_list_pred.(sub |-> preds) in 75 | let pnames = List.map ~f:pred_name spreds in 76 | let corevars = List.map pnames ~f:(fun name -> Expr.Var {var_name = name; var_info = Expr.InfoNone}) in 77 | let evidence = List.zip_exn pnames spreds 78 | |> List.map ~f:(fun (name,pred) -> Evidence.{name = name; pred = pred}) in 79 | (tvars, evidence, srho, 80 | (match corevars with [] -> Util.id | _ -> Util.id (* add_apps corevars*)) <.> Expr.add_type_apps tvars) 81 | 82 | and pred_name (pred:Type.pred) : Expr.tname = 83 | let name = match pred with Type.PredSub _ -> Expr.fresh_name "sub" 84 | | Type.PredIFace (iname,_) -> Expr.fresh_name (Name.show iname) 85 | in (name, Type.pred_type pred) 86 | 87 | and fresh_sub_x (makeTVar:Type.TypeVar.t -> Type.typ) (flavour:Type.Flavour.t) (vars:Type.TypeVar.t list) : Type.TypeVar.t list * sub = 88 | let tvars = List.map ~f:(fun tv -> fresh_type_var tv.Type.TypeVar.kind flavour) vars in 89 | let sub = sub_new (List.zip_exn vars (List.map tvars ~f:makeTVar)) in 90 | (tvars, sub) 91 | 92 | and fresh_sub f v = fresh_sub_x (fun x -> TVar x) f v 93 | 94 | (* Skolemize a Type.type and return the instantiated quantifiers, name/predicate pairs for evidence, 95 | * the instantiated Type.type, and a core transformer function (which applies Type.type arguments and evidence) *) 96 | let skolemize_ex = instantiate_ex_fl Skolem 97 | 98 | (* Skolemize a Type.type *) 99 | let skolemize (tp:Type.typ) : Type.rho = let (_,_,rho,_) = skolemize_ex tp in rho 100 | -------------------------------------------------------------------------------- /typeEngine/unify.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Common 3 | open Common.Util 4 | open Heart 5 | open TypeOperations 6 | 7 | (******************************************** 8 | * Unify monad 9 | ********************************************) 10 | type unify_error = 11 | | NoMatch 12 | | NoMatchKind 13 | | NoMatchPred 14 | | NoSubsume 15 | | NoEntail 16 | | Infinite 17 | | NoArgMatch of int * int 18 | 19 | type st = TypeVar.sub (* global state *) 20 | type 'a res = 21 | | Ok of 'a * st 22 | | Err of unify_error * st 23 | 24 | (* The unification state-monad *) 25 | module UnifyM = struct 26 | module Let_syntax = struct 27 | type 'a t = (st -> 'a res) 28 | let return (x:'a) : 'a t = fun st -> Ok(x,st) 29 | let bind (u:'a t) ~(f: 'a -> 'b t) : 'b t = fun st1 -> 30 | match u st1 with 31 | | Ok(x,st2) -> (f x) st2 32 | | Err(err,st2) -> Err(err,st2) 33 | let map a ~f = bind a ~f:(return <.> f) 34 | end 35 | 36 | include Common.Monadic.Make(Let_syntax) 37 | 38 | let run f = 39 | match f TypeVar.sub_null with 40 | | Ok(x,sub) -> (Result.Ok x, sub) 41 | | Err(err,sub) -> (Result.Error err, sub) 42 | 43 | let error err = fun (st:'a) -> Err(err,st) 44 | let extend_sub tv tp = fun (st:'a) -> Ok((), TypeVar.sub_extend tv tp st) 45 | 46 | let get_subst = fun (st:'a) -> Ok(st, st) 47 | let subst (x:Type.typ) : Type.typ t = get_subst >>= fun (sub) -> return TypeVar.HasTypeVar_typ.(sub |-> x) 48 | let subst_list (x:Type.typ list) : Type.typ list t = get_subst >>= fun (sub) -> return TypeVar.HasTypeVar_list_typ.(sub |-> x) 49 | let subst_pred (x:Type.pred) : Type.pred t = get_subst >>= fun (sub) -> return TypeVar.HasTypeVar_pred.(sub |-> x) 50 | end 51 | 52 | (** Does a type have the given named arguments *) 53 | let match_named (tp:Type.typ) (n:int) (named : Name.t list) : unit UnifyM.t = 54 | let rho1 = instantiate tp in 55 | match Type.split_fun_type rho1 with 56 | | None -> UnifyM.error NoMatch 57 | | Some(pars,_,_) -> 58 | if (n + List.length named) > List.length pars then 59 | UnifyM.error NoMatch 60 | else 61 | let npars = List.drop pars n in 62 | let names = List.map ~f:fst npars in 63 | if List.for_all ~f:(List.mem names ~equal:Name.equal) named then 64 | (* [tp | (nm,tp) <- npars, not (nm `elem` named)] *) 65 | let rest = List.(npars >>= fun (nm,tp) -> 66 | guard (not @@ mem named nm ~equal:Name.equal) >>= fun _ -> 67 | return tp) 68 | in 69 | if (List.for_all ~f:Type.is_optional rest) then 70 | UnifyM.return () 71 | else UnifyM.error NoMatch 72 | else UnifyM.error NoMatch 73 | 74 | let rec match_kind kind1 kind2 : bool = match kind1, kind2 with 75 | | Kind.Constant(c1), Kind.Constant(c2) -> Name.equal c1 c2 76 | | Kind.App(a1,r1), Kind.App(a2,r2) -> (match_kind a1 a2) && (match_kind r1 r2) 77 | | _,_ -> false 78 | 79 | let match_kinds kinds1 kinds2 : unit UnifyM.t = 80 | let matches = List.map2_exn ~f:match_kind kinds1 kinds2 in 81 | let all_match = List.fold ~init:true ~f:(&&) matches in 82 | if all_match then 83 | UnifyM.return () 84 | else 85 | UnifyM.error NoMatchKind 86 | 87 | let extract_normalize_effect (tp:Type.typ) : (Type.typ list * Type.typ) UnifyM.t = let open UnifyM in 88 | let%bind tp' = subst tp in 89 | return @@ Type.extract_ordered_effect tp' 90 | 91 | (** Do two types overlap on the argument types? Used to check for overlapping 92 | * definitions of overloaded identifiers. *) 93 | let rec overlaps (_free:TypeVar.Set.t) (tp1:Type.typ) (tp2:Type.typ) : unit UnifyM.t = 94 | let rho1 = instantiate tp1 in 95 | let rho2 = instantiate tp2 in 96 | match (Type.split_fun_type rho1, Type.split_fun_type rho2) with 97 | (* values always overlap *) 98 | | (None,_) | (_,None) -> UnifyM.return () 99 | (* rest *) 100 | | (Some(targs1,_,_),Some(targs2,_,_)) -> 101 | let (fixed1,optional1) = List.split_while ~f:(not <.> Type.is_optional) (List.map ~f:snd targs1) in 102 | let (fixed2,optional2) = List.split_while ~f:(not <.> Type.is_optional) (List.map ~f:snd targs2) in 103 | let hi = Stdlib.max (List.length fixed1) (List.length fixed2) in 104 | let fo1 = (flip List.take) hi (fixed1 @ (List.map ~f:Type.unoptional optional1)) in 105 | let fo2 = (flip List.take) hi (fixed2 @ (List.map ~f:Type.unoptional optional2)) in 106 | if ((List.length fo1) <> (List.length fo2)) then 107 | UnifyM.error NoMatch (* one has more fixed arguments than the other can ever get *) 108 | else UnifyM.( 109 | unifies fo1 fo2 >> 110 | return () 111 | ) 112 | 113 | (** Unify two types. *) 114 | and unify (t1:Type.typ) (t2:Type.typ) : unit UnifyM.t = let open UnifyM in match (t1,t2) with 115 | (* Effects *) 116 | | TApp(TCon tc1, _), TApp(TCon tc2, _) 117 | when (Type.TypeCon.equal tc2 Type.tcon_effect_extend) && 118 | (Type.TypeCon.equal tc1 Type.tcon_effect_extend) -> 119 | unify_effect t1 t2 120 | 121 | | TApp(TCon tc1, _), TVar tv2 122 | when (Type.TypeCon.equal tc1 Type.tcon_effect_extend) && 123 | Type.is_meta tv2 -> 124 | unify_effect_var tv2 t1 125 | 126 | | TVar tv1, TApp(TCon tc2, _) 127 | when (Type.TypeCon.equal tc2 Type.tcon_effect_extend) && 128 | Type.is_meta tv1 -> 129 | unify_effect_var tv1 t2 130 | 131 | (* Type variables *) 132 | | (TVar v1, TVar v2) when Type.TypeVar.equal v1 v2 -> return () 133 | | (TVar tv, tp) when Type.is_meta tv -> unify_tvar tv tp 134 | | (tp, TVar tv) when Type.is_meta tv -> unify_tvar tv tp 135 | 136 | (* Constants *) 137 | | TCon tc1, TCon tc2 when Type.TypeCon.equal tc1 tc2 -> return () 138 | 139 | (* Applications *) 140 | | TApp(t, ts), TApp(u, us) when (List.length ts) = (List.length us) -> 141 | unify t u >> 142 | unifies ts us 143 | 144 | (* Functions *) 145 | | TFun(a1,e1,r1), TFun(a2,e2,r2) when (List.length a1) = (List.length a2) -> 146 | unify e1 e2 >> 147 | unifies (r1::(List.map ~f:snd a1)) (r2::(List.map ~f:snd a2)) 148 | 149 | (* quantified types *) 150 | | TForall(vars1, preds1, tp1), TForall(vars2, preds2, tp2) 151 | when (List.length vars1) = (List.length vars2) && 152 | (List.length preds1) = (List.length preds2) -> 153 | let kinds1 = List.map ~f:TypeKind.get_kind_type_var vars1 in 154 | let kinds2 = List.map ~f:TypeKind.get_kind_type_var vars2 in 155 | match_kinds kinds1 kinds2 >> 156 | (* replace with shared bound variables in both types 157 | * NOTE: assumes ordered quantifiers and ordered predicates 158 | * NOTE: we don't use Skolem as a Meta variable can unify with a Skolem but not with a Bound one *) 159 | let vars = List.map ~f:(fun kind -> freshTVar kind Type.Flavour.Bound) kinds1 in 160 | let sub1 = TypeVar.sub_new @@ List.zip_exn vars1 vars in 161 | let sub2 = TypeVar.sub_new @@ List.zip_exn vars2 vars in 162 | let stp1 = TypeVar.HasTypeVar_typ.(sub1 |-> tp1) in 163 | let stp2 = TypeVar.HasTypeVar_typ.(sub2 |-> tp2) in 164 | let _spreds1 = TypeVar.HasTypeVar_list_pred.(sub1 |-> preds1) in 165 | let _spreds2 = TypeVar.HasTypeVar_list_pred.(sub2 |-> preds2) in 166 | (* and unify the results *) 167 | unify stp1 stp2 >> 168 | unify_preds preds1 preds2 169 | (* no need to check for escaping skolems as we don't unify to bound variables *) 170 | 171 | (*TODO: orig_line:247 cps translation/continuations stuff*) 172 | 173 | (* synonyms *) 174 | | TSyn(syn1,_,tp1), TSyn(syn2,_,_) when syn1.type_syn_rank > syn2.type_syn_rank -> unify tp1 t2 175 | | TSyn(syn1,_,_), TSyn(syn2,_,tp2) when syn1.type_syn_rank <= syn2.type_syn_rank -> unify t1 tp2 176 | | TSyn(_,_,tp1), tp2 -> unify tp1 tp2 177 | | tp1, TSyn(_,_,tp2) -> unify tp1 tp2 178 | 179 | (* No match *) 180 | | _ -> error NoMatch 181 | 182 | and unifies (tl1:Type.typ list) (tl2:Type.typ list) : unit UnifyM.t = let open UnifyM in 183 | match (tl1,tl2) with 184 | | [], [] -> UnifyM.return () 185 | | t::ts, u::us -> 186 | let%bind st = subst t in 187 | let%bind su = subst u in 188 | unify st su >> 189 | unifies ts us 190 | 191 | | _ -> failwith "Type.Unify.unifies" 192 | 193 | and unify_effect (tp1:Type.typ) (tp2:Type.typ) = let open UnifyM in 194 | let%bind (ls1, tl1) = extract_normalize_effect tp1 in 195 | let%bind (ls2, tl2) = extract_normalize_effect tp2 in 196 | let%bind (ds1,ds2) = unify_labels ls1 ls2 in 197 | match (Type.expand_syn tl1, Type.expand_syn tl2) with 198 | | Type.TVar(Type.TypeVar.{id=id1; kind=kind1; flavour=Meta}), 199 | Type.TVar(Type.TypeVar.{id=id2; kind=kind2; flavour=Meta}) when 200 | id1 = id2 && not (List.is_empty ds1 && List.is_empty ds2) -> error Infinite 201 | | _ -> 202 | let%bind tail1 = (if List.is_empty ds1 then return tl1 else 203 | let tv1 = freshTVar Kind.Prim.effect Type.Flavour.Meta in 204 | unify tl1 (Type.effect_extends ds1 tv1) >> return tv1) in 205 | let%bind stl2 = subst tl2 in 206 | let%bind tail2 = (if List.is_empty ds2 then return stl2 else 207 | let tv2 = freshTVar Kind.Prim.effect Type.Flavour.Meta in 208 | unify stl2 (Type.effect_extends ds2 tv2) >> return tv2) in 209 | let%bind stail1 = subst tail1 in 210 | unify stail1 tail2 >> 211 | let%bind stp1 = subst tp1 in 212 | let%bind stp2 = subst tp2 in 213 | return () 214 | 215 | and unify_effect_var tv1 tp2 = let open UnifyM in 216 | let (ls2, tl2) = Type.extract_ordered_effect tp2 in (* ls2 must be non-empty *) 217 | match Type.expand_syn tl2 with 218 | | Type.TVar tv2 when Type.TypeVar.equal tv1 tv2 -> (* e ~ ~> e := *) 219 | error Infinite 220 | | _ -> 221 | (* let tv = freshTVar Kind.t_effect Flavour.Meta in *) 222 | unify_tvar tv1 (Type.effect_extends ls2 tl2) 223 | 224 | and unify_tvar (tv:Type.TypeVar.t) (tp:Type.typ) : unit UnifyM.t = 225 | if not (Type.is_meta tv) then 226 | failwith "Type.Unify.unify_tvar: called with skolem or bound variable"; 227 | 228 | let etp = Type.expand_syn tp in 229 | if TypeVar.tvs_member (TypeVar.tvs_filter ~f:Type.is_meta (TypeVar.HasTypeVar_typ.ftv etp)) tv then 230 | match Type.expand_syn tp with 231 | | Type.TVar tv2 when Type.TypeVar.equal tv tv2 -> UnifyM.return () (* i.e. a ~ id *) 232 | | _ -> UnifyM.error Infinite 233 | else 234 | match etp with 235 | | Type.TVar{flavour=Type.Flavour.Bound; _} -> UnifyM.error NoMatch (* can't unify with bound variables *) 236 | | Type.TVar({id=id2; flavour=Type.Flavour.Meta; _} as tv2) when tv.Type.TypeVar.id <= id2 -> 237 | if tv.Type.TypeVar.id < id2 then 238 | unify_tvar tv2 (TVar tv) 239 | else 240 | UnifyM.return () (* TODO: kind check? *) 241 | | _ -> 242 | if not (match_kind tv.Type.TypeVar.kind (TypeKind.get_kind_typ tp)) then 243 | UnifyM.error NoMatchKind 244 | else 245 | UnifyM.(extend_sub tv tp >> return ()) 246 | 247 | (* Unify lists of ordered labels; return the differences. *) 248 | and unify_labels (ls1:Type.tau list) (ls2:Type.tau list) : (Type.tau list * Type.tau list) UnifyM.t = let open UnifyM in 249 | match (ls1,ls2) with 250 | | [], [] -> return ([],[]) 251 | | (_::_, []) -> return ([],ls1) 252 | | ([], _::_) -> return (ls2,[]) 253 | | (l1::ll1, l2::ll2) -> 254 | let compared = Name.compare (Type.label_name l1) (Type.label_name l2) in 255 | if compared < 0 then 256 | let%bind (ds1,ds2) = unify_labels ll1 ls2 in 257 | return (ds1, l1::ds2) 258 | else if compared > 0 then 259 | let%bind (ds1,ds2) = unify_labels ls1 ll2 in 260 | return (l2::ds1, ds2) 261 | else 262 | unify l1 l2 >> 263 | let%bind _ll1' = (get_subst >>= fun (sub) -> return TypeVar.HasTypeVar_list_typ.(sub |-> ll1)) in 264 | let%bind _ll2' = (get_subst >>= fun (sub) -> return TypeVar.HasTypeVar_list_typ.(sub |-> ll2)) in 265 | unify_labels ll1 ll2 266 | 267 | and unify_pred (p1:Type.pred) (p2:Type.pred) : unit UnifyM.t = let open UnifyM in 268 | match p1, p2 with 269 | | Type.PredSub(t1,t2), PredSub(u1,u2) -> 270 | unify t1 u1 >> 271 | let%bind st2 = subst t2 in 272 | let%bind su2 = subst u2 in 273 | unify st2 su2 274 | | Type.PredIFace(name1,ts1), PredIFace(name2, ts2) 275 | when Name.equal name1 name2 -> 276 | unifies ts1 ts2 277 | | _,_ -> error NoMatchPred 278 | 279 | (* unify predicates (applies a substitution before each unification) *) 280 | and unify_preds ps1 ps2 = let open UnifyM in 281 | match ps1,ps2 with 282 | | [],[] -> return () 283 | | p1::ps1, p2::ps2 -> 284 | let%bind _sp1 = subst_pred p1 in 285 | let%bind _sp2 = subst_pred p2 in 286 | unify_pred p1 p2 >> 287 | unify_preds ps1 ps2 288 | | _,_ -> failwith "Type.Unify.unify_preds" 289 | 290 | (** 291 | * @entails skolems known preds@ returns both predicates that need to be proved 292 | * and a core transformer that applies the evidence for @preds@ and abstracts for 293 | * those in @known@. The @preds@ are entailed by 294 | * @known@ and predicates containing a type variable in @skolems@ must be entailed 295 | * completely by other predicates (not containing such skolems). *) 296 | let rec entails (skolems:TypeVar.Set.t) (known:Evidence.t list) (preds:Evidence.t list) = 297 | match preds with 298 | | [] -> UnifyM.return ([],id) 299 | (* TODO: possible failure point here 300 | * TODO: should construct evidence from known to preds (simple one-to-one name mapping)*) 301 | | evs when List.equal Type.Eq_pred.equal 302 | (List.map ~f:(fun e -> e.Evidence.pred) known) 303 | (List.map ~f:(fun e -> e.Evidence.pred) evs) -> 304 | UnifyM.return (evs,id) 305 | | ev::evs -> match ev.Evidence.pred with 306 | | PredIFace(name,[_;_;_]) when (Name.equal name Name.pred_heap_div) -> (* can always be solved *) 307 | entails skolems known evs 308 | | _ -> UnifyM.error NoEntail 309 | 310 | (** 311 | * `subsume free t_1 t_2` holds if $t_2$ can be instantiated to $t_1$ where 312 | * `free` are the free type variables in the assumptnio. Returns under 313 | * which predicates this holds and a core transformer that needs to be applied 314 | * to the expressions of type $t_2$. Also returns a new type for the expect type 315 | * $t_1$ where 'some' types have been properly substitude (and may be quantified) *) 316 | let subsume (free:TypeVar.Set.t) (tp1:Type.typ) (tp2:Type.typ) 317 | : (Type.typ * Evidence.t list * (Heart.Expr.expr -> Heart.Expr.expr)) UnifyM.t = let open UnifyM in 318 | (* skolemize, instantiate, and unify *) 319 | let (sks, evs1, rho1, core1) = skolemize_ex tp1 in 320 | let (tvs, evs2, rho2, core2) = instantiate_ex tp2 in 321 | unify rho2 rho1 >> 322 | 323 | (* Escape check: no skolems should escape into the environment 324 | * Entailment check: predicates should be entailed 325 | * TODO: we should check for skolems since predicates with skolems must be entailed directly *) 326 | let%bind subst = get_subst in begin 327 | let allfree = TypeVar.tvs_union free (TypeVar.HasTypeVar_typ.ftv tp1) in 328 | let escaped = (* fsv $ [tp | (tv,tp) <- subList sub, tvsMember tv allfree] *) 329 | TypeVar.tvs_filter ~f:Type.is_skolem @@ TypeVar.HasTypeVar_list_typ.ftv @@ 330 | List.(TypeVar.sub_list subst >>= fun (tv,tp) -> 331 | guard (TypeVar.tvs_member allfree tv) >>= fun _ -> 332 | return tp) 333 | in 334 | (if (TypeVar.tvs_disjoint (TypeVar.tvs_new sks) escaped) 335 | then return () else error NoSubsume) 336 | end >> 337 | let%bind (evs_ent, core_ent) = entails (TypeVar.tvs_new sks) HasTypeVar_evidence_list.(subst |-> evs1) HasTypeVar_evidence_list.(subst |-> evs2) in 338 | let (vars, ssub) = fresh_sub Bound sks in 339 | let subx = TypeVar.(ssub @@@ subst) in 340 | let tp = Type.quantify vars @@ 341 | Type.qualify 342 | (List.map evs1 ~f:(fun Evidence.{pred} -> TypeVar.HasTypeVar_pred.(subx |-> pred))) 343 | TypeVar.HasTypeVar_typ.(subx |-> rho1) 344 | in 345 | return (tp, HasTypeVar_evidence_list.(subx |-> evs_ent), 346 | fun expr -> 347 | Heart.Expr.add_type_lambdas vars @@ (* generalize *) 348 | TypeVar.HasTypeVar_expr.(subx |-> (core_ent @@ (* apply evidence evs2 & abstract evidence evs1 *) 349 | Heart.Expr.add_type_apps tvs expr))) (* instantiate *) 350 | 351 | 352 | (** Does a function type match the given arguments? If the first argument 'matchSome' is true, 353 | ** it is considered a match even if not all arguments to the function are supplied. *) 354 | let match_arguments (match_some:bool) (* (range:range) *) (free:TypeVar.Set.t) (tp:Type.typ) (fixed:Type.typ list) (named:(Name.t * Type.typ) list) : unit UnifyM.t = 355 | let open UnifyM in 356 | let rho1 = instantiate tp in 357 | match Type.split_fun_type rho1 with 358 | | None -> error NoMatch 359 | | Some(pars,_,_) -> 360 | if ((List.length fixed) + (List.length named)) > (List.length pars) then 361 | error NoMatch 362 | else (* subsume fixed parameters *) 363 | let (fpars, npars) = List.split_n pars (List.length fixed) in 364 | mapM_ (fun (tpar,targ) -> subsume free (Type.unoptional tpar) targ) (List.zip_exn (List.map ~f:snd fpars) fixed) >> 365 | (* subsume named parameters *) 366 | forM_ named (fun (name,targ) -> match List.Assoc.find npars name ~equal:Name.equal with 367 | | None -> error NoMatch 368 | | Some tpar -> subsume free tpar (Type.make_optional targ)) >> 369 | 370 | (* check the rest is optional *) 371 | let rest = 372 | let names = (List.map ~f:fst named) in 373 | lazy List.(npars >>= fun (nm,tpar) -> 374 | guard @@ not (List.mem names nm ~equal:Name.equal) >>= fun _ -> 375 | return tpar) 376 | in 377 | if match_some || List.for_all ~f:Type.is_optional (Lazy.force rest) then 378 | return () 379 | else 380 | error NoMatch 381 | --------------------------------------------------------------------------------