├── .gitignore ├── LICENSE ├── README.md ├── back ├── lib │ ├── Check.ml │ ├── Check.mli │ ├── Context.ml │ ├── Context.mli │ ├── Copy.ml │ ├── Copy.mli │ ├── Naming.ml │ ├── Naming.mli │ ├── Print.ml │ ├── Print.mli │ ├── Syntax.ml │ ├── Valid.ml │ ├── Valid.mli │ └── dune └── test │ ├── Tests.ml │ └── dune ├── bhrp.opam ├── dune ├── dune-project ├── dune-workspace ├── examples ├── apply.bhrp ├── id.bhrp ├── id_type.bhrp ├── product.bhrp └── unit.bhrp ├── front ├── lib │ ├── Interp.ml │ ├── Lexer.mll │ ├── Native.ml │ ├── Parser.mly │ ├── Value.ml │ └── dune └── test │ ├── Tests.ml │ └── dune ├── misc ├── profile.csv └── profile_extract.py ├── repl └── bin │ ├── Main.ml │ └── dune ├── shared └── lib │ ├── Expr.ml │ ├── Mono.ml │ ├── Poly.ml │ ├── Simple.ml │ └── dune └── util ├── lib ├── AVL.ml ├── Env.ml ├── Env.mli ├── Extra.ml ├── Infix.ml ├── Map.ml ├── Option.ml ├── Order.ml ├── Result.ml ├── Set.ml └── dune └── test ├── Tests.ml └── dune /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # Merlin configuring file for Vim and Emacs 23 | .merlin 24 | 25 | # Dune generated files 26 | *.install 27 | 28 | # Local OPAM switch 29 | _opam/ 30 | 31 | # Macos 32 | .DS_Store 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Søren Nørbæk 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # bidi-higher-rank-poly 2 | Didactic implementation of the type checker described in "Complete and Easy Bidirectional Typechecking for Higher-Rank Polymorphism" written in OCaml. 3 | 4 | # Notable detours from the paper 5 | Added the empty program and type explicitly in order to have a better handle on them during random program generation for testing. The reason is there are many different terms that represent the empty type in System F (e.g. ∀a.a), however in general it is undecidable whether a type term is inhabited or not. Therefore generating random polymorphic type terms is not very useful for testing, since some of them will represent the empty type and there is no way to tell. The chosen strategy for testing therefore became; generate random monomorphic type terms (these are always inhabited), generalise these type terms by randomly substituting their subterms with existential variables (the results are still inhabited, and should sometimes implicitly create polymorphic type terms); from these type terms generate random typed programs. 6 | 7 | # Testing strategy 8 | This project uses Property Based Testing through the QCheck module for OCaml. Code has been written that allows for the random generation of typed programs, and as well as type directed shrinking of said generated programs. This made it very easy to hone in on bugs in e.g. the type checker, type synthesis and interpreter. 9 | 10 | # Language feature additions 11 | Computing only with abstractions and units is a little inconvenient, as such additional language features will be added over time to this language playground. 12 | 13 | Added features so far: 14 | - Empty types and programs 15 | - Statements 16 | 17 | # Frontend syntax 18 | ```text 19 | // Types - t 20 | nothing (Empty type) 21 | unit (Singleton type) 22 | x (Type variable) 23 | s -> t (Arrow type) 24 | x => t (Universally quantified type) 25 | 26 | // Statements - s 27 | x : t. s (Variable declaration followed by statement) 28 | x = e. s (Variable definition followed by statement) 29 | e (Statement terminal) 30 | 31 | // Expressions - e 32 | undefined (Empty program) 33 | unit (Singleton value) 34 | x (Variables) 35 | x => s (Abstractions) 36 | f x (Applications) 37 | (e : t) (Type annotation) 38 | ``` 39 | 40 | # Building 41 | ```text 42 | cd bidi-higher-rank-poly/ 43 | dune build repl/bin (Build the REPL) 44 | dune build util/test (Build the util tests) 45 | dune build back/test (Build the backend tests) 46 | dune build front/test (Build the frontend tests) 47 | ``` 48 | 49 | Or build all artefacts at once with 50 | ```Text 51 | dune build 52 | ``` 53 | 54 | # Testing 55 | ```text 56 | _build/default/util/test/Tests.exe (Run the util tests) 57 | _build/default/back/test/Tests.exe (Run the backend tests) 58 | _build/default/front/test/Tests.exe (Run the frontend tests) 59 | ``` 60 | 61 | Or run all tests at once with 62 | ```Text 63 | dune runtest 64 | ``` 65 | 66 | # Using the REPL 67 | ```text 68 | rlwrap ./_build/default/repl/bin/Main.exe 69 | > exit;; (Exit the REPL) 70 | > context;; (Print the current context) 71 | > x => x;; (Evaluate an input term and print its result) 72 | ``` 73 | -------------------------------------------------------------------------------- /back/lib/Check.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Extra 3 | open Syntax 4 | open Context 5 | open Print 6 | open Typeset 7 | 8 | (* 9 | An implementation of: 10 | Complete and easy bidirectional typechecking for higher-rank polymorphism 11 | https://arxiv.org/pdf/1306.6032.pdf 12 | *) 13 | 14 | type 'r fail = Typeset.eDSL -> 'r 15 | type ('a, 'r) return = ('a -> 'r) -> 'r 16 | 17 | (* 18 | Implementation of figure 8. 19 | Applying a context, as a substitution, to a type. 20 | 21 | Note on deviation from paper: 22 | The context is an implementation detail; 23 | It is due to deferred substitution from the subtype relation. 24 | *) 25 | let rec norm_poly poly tctx return = 26 | match poly with 27 | | PNothing -> return poly_nothing 28 | | PUnit -> return poly_unit 29 | | PParam param -> 30 | lookup_t param tctx 31 | (fun _msg -> 32 | return (poly_param param)) 33 | (fun poly1 -> 34 | match poly1 with 35 | | PVar _ -> norm_poly poly1 tctx return 36 | | _ -> assert false (* Invariant *)) 37 | | PVar exist -> 38 | begin match !exist with 39 | | None -> return (poly_var exist) 40 | | Some mono -> 41 | norm_mono mono tctx @@ fun mono1 -> 42 | return (poly_mono mono1) 43 | end 44 | | PArrow (dom, codom) -> 45 | norm_poly dom tctx @@ fun dom1 -> 46 | norm_poly codom tctx @@ fun codom1 -> 47 | return (poly_arrow dom1 codom1) 48 | | PForall (param, poly1) -> 49 | norm_poly poly1 tctx @@ fun poly2 -> 50 | return (poly_forall param poly2) 51 | | PMono mono -> 52 | norm_mono mono tctx @@ fun mono1 -> 53 | return (poly_mono mono1) 54 | and norm_mono mono tctx return = 55 | match mono with 56 | | MNothing -> return mono_nothing 57 | | MUnit -> return mono_unit 58 | | MParam param -> 59 | lookup_t param tctx 60 | (fun _msg -> 61 | return (mono_param param)) 62 | (fun poly1 -> 63 | match poly1 with 64 | | PVar exist -> norm_mono (mono_var exist) tctx return 65 | | _ -> assert false (* Invariant *)) 66 | | MVar exist -> 67 | begin match !exist with 68 | | None -> return (mono_var exist) 69 | | Some mono -> 70 | norm_mono mono tctx return 71 | end 72 | | MArrow (dom, codom) -> 73 | norm_mono dom tctx @@ fun dom1 -> 74 | norm_mono codom tctx @@ fun codom1 -> 75 | return (mono_arrow dom1 codom1) 76 | 77 | let extend label tctx return = 78 | let var = poly_var (ref None) in 79 | bind_t label var tctx return 80 | 81 | (* 82 | Implementation of figure 10. 83 | Instantiate a existential variable, such that the instantiation is a 84 | subtype or supertype of a given type, depending on whether we are 85 | instantiating the left or right hand side of the subtype relation. 86 | *) 87 | let rec instantiate_l_poly l_exist poly tctx = 88 | match poly with 89 | | PNothing -> l_exist := Some mono_nothing 90 | | PUnit -> l_exist := Some mono_unit 91 | | PVar r_exist -> r_exist := Some (mono_var l_exist) 92 | | PParam name -> 93 | lookup_t name tctx 94 | (fun _msg -> 95 | l_exist := Some (mono_param name)) 96 | (fun poly1 -> 97 | instantiate_l_poly l_exist poly1 tctx) 98 | | PArrow (dom, codom) -> 99 | let dom_exist = ref None in 100 | let codom_exist = ref None in 101 | l_exist := Some (mono_arrow 102 | (mono_var dom_exist) 103 | (mono_var codom_exist)); 104 | instantiate_r_poly dom dom_exist tctx; 105 | norm_poly codom tctx @@ fun codom1 -> 106 | instantiate_l_poly codom_exist codom1 tctx 107 | | PForall (param, poly1) -> 108 | extend param tctx @@ fun tctx1 -> 109 | instantiate_l_poly l_exist poly1 tctx1 110 | | PMono mono -> 111 | instantiate_l_mono l_exist mono tctx 112 | and instantiate_l_mono l_exist mono tctx = 113 | match mono with 114 | | MNothing -> l_exist := Some mono_nothing 115 | | MUnit -> l_exist := Some mono_unit 116 | | MVar r_exist -> r_exist := Some (mono_var l_exist) 117 | | MParam name -> 118 | lookup_t name tctx 119 | (fun _msg -> 120 | l_exist := Some (mono_param name)) 121 | (fun poly1 -> 122 | instantiate_l_poly l_exist poly1 tctx) 123 | | MArrow (dom, codom) -> 124 | let dom_exist = ref None in 125 | let codom_exist = ref None in 126 | l_exist := Some (mono_arrow 127 | (mono_var dom_exist) 128 | (mono_var codom_exist)); 129 | instantiate_r_mono dom dom_exist tctx; 130 | norm_mono codom tctx @@ fun codom1 -> 131 | instantiate_l_mono codom_exist codom1 tctx 132 | and instantiate_r_poly poly r_exist tctx = 133 | match poly with 134 | | PNothing -> r_exist := Some mono_nothing 135 | | PUnit -> r_exist := Some mono_unit 136 | | PVar l_exist -> l_exist := Some (mono_var r_exist) 137 | | PParam name -> 138 | lookup_t name tctx 139 | (fun _msg -> 140 | r_exist := Some (mono_param name)) 141 | (fun poly1 -> 142 | instantiate_r_poly poly1 r_exist tctx) 143 | | PArrow (dom, codom) -> 144 | let dom_exist = ref None in 145 | let codom_exist = ref None in 146 | r_exist := Some (mono_arrow 147 | (mono_var dom_exist) 148 | (mono_var codom_exist)); 149 | instantiate_l_poly dom_exist dom tctx; 150 | norm_poly codom tctx @@ fun codom1 -> 151 | instantiate_r_poly codom1 codom_exist tctx 152 | | PForall (param, poly1) -> 153 | extend param tctx @@ fun tctx1 -> 154 | instantiate_r_poly poly1 r_exist tctx1 155 | | PMono mono -> 156 | instantiate_r_mono mono r_exist tctx 157 | and instantiate_r_mono mono r_exist tctx = 158 | match mono with 159 | | MNothing -> r_exist := Some mono_nothing 160 | | MUnit -> r_exist := Some mono_unit 161 | | MVar l_exist -> l_exist := Some (mono_var r_exist) 162 | | MParam name -> 163 | lookup_t name tctx 164 | (fun _msg -> 165 | r_exist := Some (mono_param name)) 166 | (fun poly1 -> 167 | instantiate_r_poly poly1 r_exist tctx) 168 | | MArrow (dom, codom) -> 169 | let dom_exist = ref None in 170 | let codom_exist = ref None in 171 | r_exist := Some (mono_arrow 172 | (mono_var dom_exist) 173 | (mono_var codom_exist)); 174 | instantiate_l_mono dom_exist dom tctx; 175 | norm_mono codom tctx @@ fun codom1 -> 176 | instantiate_r_mono codom1 codom_exist tctx 177 | 178 | let rec acyclic_poly l_exist r_poly fail return = 179 | let rec _visit poly return = 180 | match poly with 181 | | PVar r_exist -> 182 | if not (exist_equal l_exist r_exist) then return () else 183 | let ctx = Naming.make_ctx () in 184 | layout_poly ctx r_poly @@ fun r_poly1 -> 185 | fail (~$"type is cyclic" <+> grp r_poly1) 186 | | PArrow (dom, codom) -> 187 | _visit dom @@ fun () -> 188 | _visit codom return 189 | | PForall (_param, poly1) -> 190 | _visit poly1 return 191 | | PMono mono -> 192 | acyclic_mono l_exist mono fail return 193 | | PNothing | PUnit | PParam _ -> return () 194 | in 195 | _visit r_poly return 196 | and acyclic_mono l_exist r_mono fail return = 197 | let rec _visit mono return = 198 | match mono with 199 | | MVar r_exist -> 200 | if not (exist_equal l_exist r_exist) then return () else 201 | let ctx = Naming.make_ctx () in 202 | layout_mono ctx r_mono @@ fun r_mono1 -> 203 | fail (~$"type is cyclic" <+> grp r_mono1) 204 | | MArrow (dom, codom) -> 205 | _visit dom @@ fun () -> 206 | _visit codom return 207 | | MNothing | MUnit | MParam _ -> return () 208 | in 209 | _visit r_mono return 210 | 211 | let rec mono_2_poly mono return = 212 | match mono with 213 | | MNothing -> return poly_nothing 214 | | MUnit -> return poly_unit 215 | | MParam label -> return (poly_param label) 216 | | MVar exist -> return (poly_var exist) 217 | | MArrow (dom, codom) -> 218 | mono_2_poly dom @@ fun dom1 -> 219 | mono_2_poly codom @@ fun codom1 -> 220 | return (poly_arrow dom1 codom1) 221 | 222 | let subtype left right tctx fail return = 223 | let _msg left right tctx = 224 | let ctx = Naming.make_ctx () in 225 | norm_poly left tctx @@ fun left1 -> 226 | norm_poly right tctx @@ fun right1 -> 227 | layout_poly ctx left1 @@ fun left_s -> 228 | layout_poly ctx right1 @@ fun right_s -> 229 | seq (~$"Subtyping" <+> 230 | nest (seq ((grp left_s) <+> ~$"<:" (grp right_s))) <+> 231 | ~$"failed") 232 | in 233 | let _fail_end fail left right tctx () = 234 | fail (_msg left right tctx) 235 | in 236 | let _fail_cont fail left right tctx msg = 237 | fail ((_msg left right tctx) ~$"because" msg) 238 | in 239 | let rec _subtype left right tctx fail return = 240 | let _fail = _fail_end fail left right tctx in 241 | let __fail = _fail_cont fail left right tctx in 242 | match left, right with 243 | | PNothing, PNothing -> return () 244 | | PUnit, PUnit -> return () 245 | | PParam l_name, PParam r_name -> 246 | lookup_t l_name tctx 247 | (fun _msg -> 248 | if label_equal l_name r_name 249 | then return () 250 | else _fail ()) 251 | (fun left1 -> 252 | _subtype left1 right tctx fail return) 253 | | PParam param, _ -> 254 | lookup_t param tctx 255 | (fun _msg -> _fail ()) 256 | (fun left1 -> 257 | _subtype left1 right tctx fail return) 258 | | _, PParam param -> 259 | lookup_t param tctx 260 | (fun _msg -> _fail ()) 261 | (fun right1 -> 262 | _subtype left right1 tctx fail return) 263 | | PVar l_exist, PVar r_exist -> 264 | if exist_equal l_exist r_exist then return () else 265 | begin instantiate_l_poly l_exist right tctx; return () end 266 | | PArrow (l_dom, l_codom), PArrow (r_dom, r_codom) -> 267 | _subtype r_dom l_dom tctx __fail @@ fun () -> 268 | norm_poly l_codom tctx @@ fun l_codom1 -> 269 | norm_poly r_codom tctx @@ fun r_codom1 -> 270 | _subtype l_codom1 r_codom1 tctx __fail return 271 | | PMono l_mono, PMono r_mono -> 272 | mono_2_poly l_mono @@ fun left1 -> 273 | mono_2_poly r_mono @@ fun right1 -> 274 | _subtype left1 right1 tctx fail return 275 | | PMono l_mono, _ -> 276 | mono_2_poly l_mono @@ fun left1 -> 277 | _subtype left1 right tctx fail return 278 | | _, PMono r_mono -> 279 | mono_2_poly r_mono @@ fun right1 -> 280 | _subtype left right1 tctx fail return 281 | | PForall (param, left1), _ -> 282 | extend param tctx @@ fun tctx1 -> 283 | _subtype left1 right tctx1 __fail return 284 | | _, PForall (_param, right1) -> 285 | _subtype left right1 tctx __fail return 286 | | PVar l_exist, _ -> 287 | acyclic_poly l_exist right __fail @@ fun () -> 288 | begin instantiate_l_poly l_exist right tctx; return () end 289 | | _, PVar r_exist -> 290 | acyclic_poly r_exist left __fail @@ fun () -> 291 | begin instantiate_r_poly left r_exist tctx; return () end 292 | | _, _ -> 293 | _fail () 294 | in 295 | _subtype left right tctx fail return 296 | 297 | let _recursion_allowed tctx poly = 298 | let rec _visit_poly poly = 299 | match poly with 300 | | PNothing -> false 301 | | PUnit -> false 302 | | PParam name -> 303 | lookup_t name tctx 304 | (fun _msg -> false) 305 | (fun poly1 -> _visit_poly poly1) 306 | | PVar exist -> 307 | begin match !exist with 308 | | None -> false 309 | | Some mono -> _visit_mono mono 310 | end 311 | | PArrow _ -> true 312 | | PForall (_name, poly1) -> 313 | _visit_poly poly1 314 | | PMono mono -> 315 | _visit_mono mono 316 | and _visit_mono mono = 317 | match mono with 318 | | MNothing -> false 319 | | MUnit -> false 320 | | MParam name -> 321 | lookup_t name tctx 322 | (fun _msg -> false) 323 | (fun poly1 -> _visit_poly poly1) 324 | | MVar exist -> 325 | begin match !exist with 326 | | None -> false 327 | | Some mono -> _visit_mono mono 328 | end 329 | | MArrow _ -> true 330 | in 331 | _visit_poly poly 332 | 333 | let rec synth_expr expr tctx fail return = 334 | match expr with 335 | | EUndefined -> return poly_nothing 336 | | EUnit -> return poly_unit 337 | | EVar name -> lookup_v name tctx fail return 338 | | EAbs (param, body) -> 339 | let dom = poly_var (ref None) in 340 | let codom = poly_var (ref None) in 341 | bind_v param dom tctx @@ fun tctx1 -> 342 | check_stmt body codom tctx1 fail @@ fun () -> 343 | return (poly_arrow dom codom) 344 | | EApp (func, arg) -> 345 | synth_expr func tctx fail @@ fun func_t -> 346 | norm_poly func_t tctx @@ fun func_t1 -> 347 | synth_apply func_t1 arg tctx fail return 348 | | EAnno (expr1, poly) -> 349 | check_expr expr1 poly tctx fail @@ fun () -> 350 | return poly 351 | and synth_stmt stmt tctx fail return = 352 | match stmt with 353 | | SDecl (name, poly, stmt1) -> 354 | if not (_recursion_allowed tctx poly) 355 | then synth_stmt stmt1 tctx fail return else 356 | bind_v name poly tctx @@ fun tctx1 -> 357 | synth_stmt stmt1 tctx1 fail return 358 | | SDefn (name, expr, stmt1) -> 359 | synth_expr expr tctx fail @@ fun expr_t -> 360 | bind_v name expr_t tctx @@ fun tctx1 -> 361 | synth_stmt stmt1 tctx1 fail return 362 | | SExpr expr -> 363 | synth_expr expr tctx fail return 364 | and synth_apply poly expr tctx fail return = 365 | match poly with 366 | | PVar exist -> 367 | let dom_exist = ref None in 368 | let codom_exist = ref None in 369 | exist := Some (mono_arrow 370 | (mono_var dom_exist) 371 | (mono_var codom_exist)); 372 | check_expr expr (poly_var dom_exist) tctx fail @@ fun () -> 373 | return (poly_var codom_exist) 374 | | PArrow (dom, codom) -> 375 | check_expr expr dom tctx fail @@ fun () -> 376 | return codom 377 | | PForall (param, poly1) -> 378 | extend param tctx @@ fun tctx1 -> 379 | synth_apply poly1 expr tctx1 fail return 380 | | PMono MArrow (dom, codom) -> 381 | check_expr expr (poly_mono dom) tctx fail @@ fun () -> 382 | return (poly_mono codom) 383 | | _ -> 384 | assert false (* Invariant *) 385 | and check_expr expr poly tctx fail return = 386 | match expr, poly with 387 | | EUnit, PUnit -> return () 388 | | EAbs (param, body), PArrow (dom, codom) -> 389 | bind_v param dom tctx @@ fun tctx1 -> 390 | check_stmt body codom tctx1 fail return 391 | | _, PForall (_param, poly1) -> 392 | check_expr expr poly1 tctx fail return 393 | | _, _ -> 394 | synth_expr expr tctx fail @@ fun expr_t -> 395 | norm_poly expr_t tctx @@ fun expr_t1 -> 396 | norm_poly poly tctx @@ fun poly1 -> 397 | subtype expr_t1 poly1 tctx fail return 398 | and check_stmt stmt poly tctx fail return = 399 | match stmt with 400 | | SDecl (name, poly1, stmt1) -> 401 | if not (_recursion_allowed tctx poly1) 402 | then check_stmt stmt1 poly tctx fail return else 403 | bind_v name poly1 tctx @@ fun tctx1 -> 404 | check_stmt stmt1 poly tctx1 fail return 405 | | SDefn (name, expr, stmt1) -> 406 | synth_expr expr tctx fail @@ fun expr_t -> 407 | bind_v name expr_t tctx @@ fun tctx1 -> 408 | check_stmt stmt1 poly tctx1 fail return 409 | | SExpr expr -> 410 | check_expr expr poly tctx fail return 411 | 412 | let rec check_prog prog tctx fail return = 413 | match prog with 414 | | PEnd -> return tctx 415 | | PDecl (name, poly, prog1) -> 416 | bind_v name poly tctx @@ fun tctx1 -> 417 | check_prog prog1 tctx1 fail return 418 | | PDefn (name, expr, prog1) -> 419 | synth_expr expr tctx fail @@ fun expr_t -> 420 | bind_v name expr_t tctx @@ fun tctx1 -> 421 | check_prog prog1 tctx1 fail return 422 | 423 | let generalize poly return = 424 | let ctx = Naming.make_ctx () in 425 | let exists = ref Env.empty in 426 | let rec _visit_poly poly env return = 427 | match poly with 428 | | PParam from_label -> 429 | Env.lookup label_equal from_label env 430 | (fun () -> assert false (* Invariant *)) 431 | (fun to_label -> 432 | return (poly_param to_label)) 433 | | PVar exist -> 434 | begin match !exist with 435 | | Some mono -> 436 | _visit_mono mono env @@ fun mono1 -> 437 | return (poly_mono mono1) 438 | | None -> 439 | let _exists = !exists in 440 | Env.lookup exist_equal exist _exists 441 | (fun () -> 442 | Naming.sample_label ctx @@ fun label -> 443 | Env.bind exist label _exists @@ fun exists1 -> 444 | exists := exists1; 445 | return (poly_param label)) 446 | (fun label -> 447 | return (poly_param label)) 448 | end 449 | | PArrow (dom, codom) -> 450 | _visit_poly dom env @@ fun dom1 -> 451 | _visit_poly codom env @@ fun codom1 -> 452 | return (poly_arrow dom1 codom1) 453 | | PForall (from_label, poly1) -> 454 | Naming.sample_label ctx @@ fun to_label -> 455 | Env.bind from_label to_label env @@ fun env1 -> 456 | _visit_poly poly1 env1 @@ fun poly2 -> 457 | return (poly_forall to_label poly2) 458 | | PMono mono -> 459 | _visit_mono mono env @@ fun mono1 -> 460 | return (poly_mono mono1) 461 | | PNothing | PUnit -> return poly 462 | and _visit_mono mono env return = 463 | match mono with 464 | | MParam from_label -> 465 | Env.lookup label_equal from_label env 466 | (fun () -> assert false (* Invariant *)) 467 | (fun to_label -> 468 | return (mono_param to_label)) 469 | | MVar exist -> 470 | begin match !exist with 471 | | Some mono -> 472 | _visit_mono mono env return 473 | | None -> 474 | let _exists = !exists in 475 | Env.lookup exist_equal exist _exists 476 | (fun () -> 477 | Naming.sample_label ctx @@ fun label -> 478 | Env.bind exist label _exists @@ fun exists1 -> 479 | exists := exists1; 480 | return (mono_param label)) 481 | (fun label -> 482 | return (mono_param label)) 483 | end 484 | | MArrow (dom, codom) -> 485 | _visit_mono dom env @@ fun dom1 -> 486 | _visit_mono codom env @@ fun codom1 -> 487 | return (mono_arrow dom1 codom1) 488 | | MNothing | MUnit -> return mono 489 | in 490 | _visit_poly poly Env.empty @@ fun poly1 -> 491 | Env.values !exists @@ fun labels -> 492 | return (List.fold_rev poly1 poly_forall labels) 493 | -------------------------------------------------------------------------------- /back/lib/Check.mli: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Context 3 | type 'r fail = Typeset.eDSL -> 'r 4 | type ('a, 'r) return = ('a -> 'r) -> 'r 5 | val subtype : poly -> poly -> tctx -> 'a fail -> (unit, 'a) return 6 | val synth_expr : expr -> tctx -> 'a fail -> (poly, 'a) return 7 | val synth_stmt : stmt -> tctx -> 'a fail -> (poly, 'a) return 8 | val check_expr : expr -> poly -> tctx -> 'a fail -> (unit, 'a) return 9 | val check_stmt : stmt -> poly -> tctx -> 'a fail -> (unit, 'a) return 10 | val check_prog : prog -> tctx -> 'a fail -> (tctx, 'a) return 11 | val generalize : poly -> (poly, 'a) return 12 | -------------------------------------------------------------------------------- /back/lib/Context.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Syntax 3 | open Typeset 4 | 5 | type tctx = 6 | { venv : (label, poly) Env.env 7 | ; tenv : (label, poly) Env.env 8 | } 9 | 10 | let empty = 11 | { venv = Env.empty 12 | ; tenv = Env.empty 13 | } 14 | 15 | let make venv tenv = 16 | { venv = venv 17 | ; tenv = tenv 18 | } 19 | 20 | let get_venv ctx return = return ctx.venv 21 | let get_tenv ctx return = return ctx.tenv 22 | 23 | let bind_v label poly ctx return = 24 | Env.bind label poly ctx.venv @@ fun venv1 -> 25 | return { ctx with venv = venv1 } 26 | 27 | let bind_t label poly ctx return = 28 | Env.bind label poly ctx.tenv @@ fun tenv1 -> 29 | return { ctx with tenv = tenv1 } 30 | 31 | let lookup_v label ctx fail return = 32 | Env.lookup label_equal label ctx.venv 33 | (fun () -> 34 | fail (fix (~$"Unknown program parameter \"" <&> ~$label <&> ~$"\""))) 35 | return 36 | 37 | let lookup_t label ctx fail return = 38 | Env.lookup label_equal label ctx.tenv 39 | (fun () -> 40 | fail (fix (~$"Unknown type parameter \"" <&> ~$label <&> ~$"\""))) 41 | return 42 | 43 | let bound_v label ctx fail return = 44 | Env.bound label_equal label ctx.venv 45 | (fun () -> 46 | fail (fix (~$"Unknown program parameter \"" <&> ~$label <&> ~$"\""))) 47 | return 48 | 49 | let bound_t label ctx fail return = 50 | Env.bound label_equal label ctx.tenv 51 | (fun () -> 52 | fail (fix (~$"Unknown type parameter \"" <&> ~$label <&> ~$"\""))) 53 | return 54 | 55 | let print ctx tctx return = 56 | let open Printf in 57 | let _id x k = k x in 58 | Env.print _id (Print.print_poly ctx) tctx.venv @@ fun venv1 -> 59 | Env.print _id (Print.print_poly ctx) tctx.tenv @@ fun tenv1 -> 60 | return (sprintf "%s\n%s" venv1 tenv1) 61 | -------------------------------------------------------------------------------- /back/lib/Context.mli: -------------------------------------------------------------------------------- 1 | open Util 2 | open Syntax 3 | open Naming 4 | type tctx 5 | val empty : tctx 6 | val make : (label, poly) Env.env -> (label, poly) Env.env -> tctx 7 | val get_venv : tctx -> ((label, poly) Env.env -> 'a) -> 'a 8 | val get_tenv : tctx -> ((label, poly) Env.env -> 'a) -> 'a 9 | val bind_v : label -> poly -> tctx -> (tctx -> 'a) -> 'a 10 | val bind_t : label -> poly -> tctx -> (tctx -> 'a) -> 'a 11 | val lookup_v : label -> tctx -> (Typeset.eDSL -> 'a) -> (poly -> 'a) -> 'a 12 | val lookup_t : label -> tctx -> (Typeset.eDSL -> 'a) -> (poly -> 'a) -> 'a 13 | val bound_v : label -> tctx -> (Typeset.eDSL -> 'a) -> (unit -> 'a) -> 'a 14 | val bound_t : label -> tctx -> (Typeset.eDSL -> 'a) -> (unit -> 'a) -> 'a 15 | val print : ctx -> tctx -> (string -> 'a) -> 'a 16 | -------------------------------------------------------------------------------- /back/lib/Copy.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Syntax 3 | 4 | let rec _copy_mono mono env return = 5 | match mono with 6 | | MNothing -> return mono_nothing env 7 | | MUnit -> return mono_unit env 8 | | MParam name -> return (mono_param name) env 9 | | MVar from_exist -> 10 | Env.lookup exist_equal from_exist env 11 | (fun () -> 12 | let to_exist = ref None in 13 | Env.bind from_exist to_exist env @@ fun env1 -> 14 | match !from_exist with 15 | | None -> return (mono_var to_exist) env1 16 | | Some mono1 -> 17 | _copy_mono mono1 env1 @@ fun mono2 env2 -> 18 | to_exist := Some mono2; 19 | return (mono_var to_exist) env2) 20 | (fun to_exist -> 21 | return (mono_var to_exist) env) 22 | | MArrow (dom, codom) -> 23 | _copy_mono dom env @@ fun dom1 env1 -> 24 | _copy_mono codom env1 @@ fun codom1 env2 -> 25 | return (mono_arrow dom1 codom1) env2 26 | 27 | let copy_mono mono return = 28 | _copy_mono mono Env.empty @@ fun result _env1 -> 29 | return result 30 | 31 | let rec _copy_poly poly env return = 32 | match poly with 33 | | PNothing -> return poly_nothing env 34 | | PUnit -> return poly_unit env 35 | | PParam name -> return (poly_param name) env 36 | | PVar from_exist -> 37 | Env.lookup exist_equal from_exist env 38 | (fun () -> 39 | let to_exist = ref None in 40 | Env.bind from_exist to_exist env @@ fun env1 -> 41 | match !from_exist with 42 | | None -> return (poly_var to_exist) env1 43 | | Some mono1 -> 44 | _copy_mono mono1 env1 @@ fun mono2 env2 -> 45 | to_exist := Some mono2; 46 | return (poly_var to_exist) env2) 47 | (fun to_exist -> 48 | return (poly_var to_exist) env) 49 | | PArrow (dom, codom) -> 50 | _copy_poly dom env @@ fun dom1 env1 -> 51 | _copy_poly codom env1 @@ fun codom1 env2 -> 52 | return (poly_arrow dom1 codom1) env2 53 | | PForall (param, poly1) -> 54 | _copy_poly poly1 env @@ fun poly2 env1 -> 55 | return (poly_forall param poly2) env1 56 | | PMono mono -> 57 | _copy_mono mono env @@ fun mono1 env1 -> 58 | return (poly_mono mono1) env1 59 | 60 | let copy_poly poly return = 61 | _copy_poly poly Env.empty @@ fun result _env1 -> 62 | return result 63 | 64 | let rec copy_expr expr return = 65 | match expr with 66 | | EUndefined -> return expr_undefined 67 | | EUnit -> return expr_unit 68 | | EVar name -> return (expr_var name) 69 | | EAbs (param, body) -> 70 | copy_stmt body @@ fun body1 -> 71 | return (expr_abs param body1) 72 | | EApp (func, arg) -> 73 | copy_expr func @@ fun func1 -> 74 | copy_expr arg @@ fun arg1 -> 75 | return (expr_app func1 arg1) 76 | | EAnno (expr1, poly) -> 77 | copy_expr expr1 @@ fun expr2 -> 78 | copy_poly poly @@ fun poly1 -> 79 | return (expr_anno expr2 poly1) 80 | and copy_stmt stmt return = 81 | match stmt with 82 | | SDecl (name, poly, stmt1) -> 83 | copy_poly poly @@ fun poly1 -> 84 | copy_stmt stmt1 @@ fun stmt2 -> 85 | return (stmt_decl name poly1 stmt2) 86 | | SDefn (name, expr, stmt1) -> 87 | copy_expr expr @@ fun expr1 -> 88 | copy_stmt stmt1 @@ fun stmt2 -> 89 | return (stmt_defn name expr1 stmt2) 90 | | SExpr expr -> 91 | copy_expr expr @@ fun expr1 -> 92 | return (stmt_expr expr1) 93 | -------------------------------------------------------------------------------- /back/lib/Copy.mli: -------------------------------------------------------------------------------- 1 | open Syntax 2 | val copy_mono : mono -> (mono -> 'a) -> 'a 3 | val copy_poly : poly -> (poly -> 'a) -> 'a 4 | val copy_expr : expr -> (expr -> 'a) -> 'a 5 | val copy_stmt : stmt -> (stmt -> 'a) -> 'a 6 | -------------------------------------------------------------------------------- /back/lib/Naming.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | type gen = int ref 4 | let make_gen () = ref 0 5 | let sample gen = 6 | let result = !gen in 7 | gen := result + 1; 8 | abs result 9 | 10 | let suffix n = 11 | string_of_int (abs n) 12 | 13 | let alphabet = 14 | [| 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g' 15 | ; 'h'; 'i'; 'j'; 'k'; 'l'; 'm'; 'n' 16 | ; 'o'; 'p'; 'q'; 'r'; 's'; 't'; 'u' 17 | ; 'v'; 'w'; 'x'; 'y'; 'z' |] 18 | 19 | type ctx = 20 | { label : gen 21 | ; exist : gen 22 | } 23 | 24 | let make_ctx () = 25 | { label = make_gen () 26 | ; exist = make_gen () 27 | } 28 | 29 | let sample_label ctx return = 30 | let _n = sample ctx.label in 31 | let a = _n mod 26 in 32 | let i = _n / 26 in 33 | return (sprintf "%c%s" alphabet.(a) (suffix i)) 34 | 35 | let sample_exist ctx return = 36 | let n = sample ctx.exist in 37 | let a = n mod 26 in 38 | let i = n / 26 in 39 | return (sprintf "_%c%s" alphabet.(a) (suffix i)) 40 | -------------------------------------------------------------------------------- /back/lib/Naming.mli: -------------------------------------------------------------------------------- 1 | type gen 2 | val make_gen : unit -> gen 3 | val sample : gen -> int 4 | 5 | type ctx 6 | val make_ctx : unit -> ctx 7 | val sample_label : ctx -> (string -> 'a) -> 'a 8 | val sample_exist : ctx -> (string -> 'a) -> 'a 9 | -------------------------------------------------------------------------------- /back/lib/Print.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Typeset 3 | open Syntax 4 | 5 | let _pass layout = layout 6 | 7 | let _group layout = 8 | ~$"(" layout ~$")" 9 | 10 | let _wrap layout = 11 | grp (~$"(" layout ~$")") 12 | 13 | let _layout_mono ctx env mono wrap return = 14 | let rec _visit mono wrap return = 15 | match mono with 16 | | MNothing -> return ~$"nothing" 17 | | MUnit -> return ~$"unit" 18 | | MParam label -> return ~$label 19 | | MVar exist -> 20 | begin match !exist with 21 | | Some mono1 -> _visit mono1 wrap return 22 | | None -> 23 | let _env = !env in 24 | Env.lookup exist_equal exist _env 25 | (fun () -> 26 | Naming.sample_exist ctx @@ fun label -> 27 | Env.bind exist label _env @@ fun env1 -> 28 | env := env1; 29 | return ~$label) 30 | (fun label -> return ~$label) 31 | end 32 | | MArrow (dom, codom) -> 33 | _visit dom _wrap @@ fun dom1 -> 34 | _visit codom _pass @@ fun codom1 -> 35 | return (wrap (seq (dom1 <+> ~$"->" codom1))) 36 | in 37 | _visit mono wrap return 38 | 39 | let layout_mono ctx mono return = 40 | let env = ref Env.empty in 41 | _layout_mono ctx env mono _pass return 42 | 43 | let print_mono ctx mono return = 44 | layout_mono ctx mono @@ fun layout -> 45 | Typeset.compile layout @@ fun document -> 46 | Typeset.render document 2 80 return 47 | 48 | let _layout_poly ctx env poly wrap return = 49 | let rec _visit poly wrap return = 50 | match poly with 51 | | PNothing -> return ~$"nothing" 52 | | PUnit -> return ~$"unit" 53 | | PParam label -> return ~$label 54 | | PVar exist -> 55 | begin match !exist with 56 | | Some mono -> _layout_mono ctx env mono wrap return 57 | | None -> 58 | let _env = !env in 59 | Env.lookup exist_equal exist _env 60 | (fun () -> 61 | Naming.sample_exist ctx @@ fun label -> 62 | Env.bind exist label _env @@ fun env1 -> 63 | env := env1; 64 | return ~$label) 65 | (fun label -> return ~$label) 66 | end 67 | | PArrow (dom, codom) -> 68 | _visit dom _wrap @@ fun dom1 -> 69 | _visit codom _pass @@ fun codom1 -> 70 | return (wrap (seq (dom1 <+> ~$"->" codom1))) 71 | | PForall (param, poly1) -> 72 | _visit poly1 _pass @@ fun poly2 -> 73 | return (wrap (~$param ~$"=>" <+> nest (seq poly2))) 74 | | PMono mono -> 75 | _layout_mono ctx env mono wrap return 76 | in 77 | _visit poly wrap return 78 | 79 | let layout_poly ctx poly return = 80 | let env = ref Env.empty in 81 | _layout_poly ctx env poly _pass return 82 | 83 | let print_poly ctx poly return = 84 | layout_poly ctx poly @@ fun layout -> 85 | Typeset.compile layout @@ fun document -> 86 | Typeset.render document 2 80 return 87 | 88 | let rec _layout_expr ctx expr wrap return = 89 | match expr with 90 | | EUndefined -> return ~$"undefined" 91 | | EUnit -> return ~$"unit" 92 | | EVar label -> return ~$label 93 | | EAbs (param, body) -> 94 | _layout_stmt ctx body @@ fun body1 -> 95 | return (wrap (~$param seq (~$"=>" <+> nest body1))) 96 | | EApp (func, arg) -> 97 | _layout_expr ctx func _group @@ fun func1 -> 98 | _layout_expr ctx arg _group @@ fun arg1 -> 99 | return (wrap (func1 seq (null <+> nest arg1))) 100 | | EAnno (expr1, poly) -> 101 | _layout_expr ctx expr1 _group @@ fun expr2 -> 102 | let env = ref Env.empty in 103 | _layout_poly ctx env poly _pass @@ fun poly1 -> 104 | return (wrap (expr2 seq (~$":" <+> nest poly1))) 105 | and _layout_stmt ctx stmt return = 106 | match stmt with 107 | | SDecl (label, poly, stmt1) -> 108 | let env = ref Env.empty in 109 | _layout_poly ctx env poly _pass @@ fun poly1 -> 110 | _layout_stmt ctx stmt1 @@ fun stmt2 -> 111 | return ((seq (~$label ~$":" <+> nest poly1 ~$".")) 112 | stmt2) 113 | | SDefn (label, expr, stmt1) -> 114 | _layout_expr ctx expr _group @@ fun expr1 -> 115 | _layout_stmt ctx stmt1 @@ fun stmt2 -> 116 | return ((seq (~$label ~$"=" <+> nest expr1 ~$".")) 117 | stmt2) 118 | | SExpr expr -> 119 | _layout_expr ctx expr _pass @@ fun expr1 -> 120 | return (grp expr1) 121 | 122 | let layout_expr ctx expr return = 123 | _layout_expr ctx expr _pass return 124 | 125 | let print_expr ctx expr return = 126 | layout_expr ctx expr @@ fun layout -> 127 | Typeset.compile layout @@ fun document -> 128 | Typeset.render document 2 80 return 129 | 130 | let layout_stmt ctx stmt return = 131 | _layout_stmt ctx stmt return 132 | 133 | let print_stmt ctx stmt return = 134 | layout_stmt ctx stmt @@ fun layout -> 135 | Typeset.compile layout @@ fun document -> 136 | Typeset.render document 2 80 return 137 | 138 | let rec _layout_prog ctx prog return = 139 | match prog with 140 | | PDecl (name, poly, prog1) -> 141 | let env = ref Env.empty in 142 | _layout_poly ctx env poly _pass @@ fun poly1 -> 143 | _layout_prog ctx prog1 @@ fun prog1 -> 144 | return ((nest (~$name ~$":" <+> poly1) ~$".") prog1) 145 | | PDefn (name, expr, prog1) -> 146 | _layout_expr ctx expr _pass @@ fun expr1 -> 147 | _layout_prog ctx prog1 @@ fun prog1 -> 148 | return ((nest (~$name ~$"=" <+> expr1) ~$".") prog1) 149 | | PEnd -> return null 150 | 151 | let layout_prog ctx prog return = 152 | _layout_prog ctx prog return 153 | 154 | let print_prog ctx prog return = 155 | layout_prog ctx prog @@ fun layout -> 156 | Typeset.compile layout @@ fun document -> 157 | Typeset.render document 2 80 return 158 | -------------------------------------------------------------------------------- /back/lib/Print.mli: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Naming 3 | val layout_mono : ctx -> mono -> (Typeset.eDSL -> 'a) -> 'a 4 | val layout_poly : ctx -> poly -> (Typeset.eDSL -> 'a) -> 'a 5 | val layout_expr : ctx -> expr -> (Typeset.eDSL -> 'a) -> 'a 6 | val layout_stmt : ctx -> stmt -> (Typeset.eDSL -> 'a) -> 'a 7 | val layout_prog : ctx -> prog -> (Typeset.eDSL -> 'a) -> 'a 8 | val print_mono : ctx -> mono -> (string -> 'a) -> 'a 9 | val print_poly : ctx -> poly -> (string -> 'a) -> 'a 10 | val print_expr : ctx -> expr -> (string -> 'a) -> 'a 11 | val print_stmt : ctx -> stmt -> (string -> 'a) -> 'a 12 | val print_prog : ctx -> prog -> (string -> 'a) -> 'a 13 | -------------------------------------------------------------------------------- /back/lib/Syntax.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Order 3 | 4 | type label = string 5 | 6 | let label_equal l r = l = r 7 | let label_order l r = 8 | if l < r then LT else 9 | if l = r then EQ else 10 | GT 11 | 12 | type mono = 13 | | MNothing 14 | | MUnit 15 | | MParam of label 16 | | MVar of exist 17 | | MArrow of mono * mono 18 | and exist = mono option ref 19 | 20 | let exist_equal l r = l == r 21 | 22 | let mono_nothing = MNothing 23 | let mono_unit = MUnit 24 | let mono_param label = MParam label 25 | let mono_var exist = MVar exist 26 | let mono_arrow dom codom = MArrow (dom, codom) 27 | 28 | type poly = 29 | | PNothing 30 | | PUnit 31 | | PParam of label 32 | | PVar of exist 33 | | PArrow of poly * poly 34 | | PForall of label * poly 35 | | PMono of mono 36 | 37 | let poly_nothing = PNothing 38 | let poly_unit = PUnit 39 | let poly_param name = PParam name 40 | let poly_var exist = PVar exist 41 | let poly_arrow dom codom = PArrow (dom, codom) 42 | let poly_forall param poly = PForall (param, poly) 43 | let poly_mono mono = PMono mono 44 | 45 | type expr = 46 | | EUndefined 47 | | EUnit 48 | | EVar of label 49 | | EAbs of label * stmt 50 | | EApp of expr * expr 51 | | EAnno of expr * poly 52 | and stmt = 53 | | SDecl of label * poly * stmt 54 | | SDefn of label * expr * stmt 55 | | SExpr of expr 56 | 57 | let expr_undefined = EUndefined 58 | let expr_unit = EUnit 59 | let expr_var name = EVar name 60 | let expr_abs param body = EAbs (param, body) 61 | let expr_app func arg = EApp (func, arg) 62 | let expr_anno expr poly = EAnno (expr, poly) 63 | 64 | let stmt_decl name poly stmt = SDecl (name, poly, stmt) 65 | let stmt_defn name expr stmt = SDefn (name, expr, stmt) 66 | let stmt_expr expr = SExpr expr 67 | 68 | type prog = 69 | | PDecl of label * poly * prog 70 | | PDefn of label * expr * prog 71 | | PEnd 72 | 73 | let prog_decl name poly prog = PDecl (name, poly, prog) 74 | let prog_defn name expr prog = PDefn (name, expr, prog) 75 | let prog_end = PEnd 76 | 77 | let rec _equal_expr left right env fail return = 78 | match left, right with 79 | | EUndefined, EUndefined -> return () 80 | | EUnit, EUnit -> return () 81 | | EVar label, EVar r_label -> 82 | Env.lookup label_equal label env fail @@ fun l_label -> 83 | if label_equal l_label r_label then return () else fail () 84 | | EAbs (l_param, l_body), EAbs (r_param, r_body) -> 85 | Env.bind l_param r_param env @@ fun env1 -> 86 | _equal_stmt l_body r_body env1 fail return 87 | | EApp (l_func, l_arg), EApp (r_func, r_arg) -> 88 | _equal_expr l_func r_func env fail @@ fun () -> 89 | _equal_expr l_arg r_arg env fail return 90 | | EAnno (left1, _), _ -> _equal_expr left1 right env fail return 91 | | _, EAnno (right1, _) -> _equal_expr left right1 env fail return 92 | | _, _ -> fail () 93 | and _equal_stmt left right env fail return = 94 | match left, right with 95 | | SDecl (l_label, _, left1), SDecl (r_label, _, right1) -> 96 | Env.bind l_label r_label env @@ fun env1 -> 97 | _equal_stmt left1 right1 env1 fail return 98 | | SDefn (l_label, l_expr, left1), SDefn (r_label, r_expr, right1) -> 99 | _equal_expr l_expr r_expr env fail @@ fun () -> 100 | Env.bind l_label r_label env @@ fun env1 -> 101 | _equal_stmt left1 right1 env1 fail return 102 | | SExpr l_expr, SExpr r_expr -> 103 | _equal_expr l_expr r_expr env fail return 104 | | _, _ -> fail () 105 | 106 | let expr_equal left right = 107 | _equal_expr left right Env.empty 108 | (fun () -> false) 109 | (fun () -> true) 110 | 111 | let stmt_equal left right = 112 | _equal_stmt left right Env.empty 113 | (fun () -> false) 114 | (fun () -> true) 115 | 116 | let rec _equal_prog left right env fail return = 117 | match left, right with 118 | | PDecl (l_label, _, left1), PDecl (r_label, _, right1) -> 119 | Env.bind l_label r_label env @@ fun env1 -> 120 | _equal_prog left1 right1 env1 fail return 121 | | PDefn (l_label, l_expr, left1), PDefn (r_label, r_expr, right1) -> 122 | _equal_expr l_expr r_expr env fail @@ fun () -> 123 | Env.bind l_label r_label env @@ fun env1 -> 124 | _equal_prog left1 right1 env1 fail return 125 | | PEnd, PEnd -> return () 126 | | _, _ -> fail () 127 | 128 | let equal_prog left right = 129 | _equal_prog left right Env.empty 130 | (fun () -> false) 131 | (fun () -> true) 132 | -------------------------------------------------------------------------------- /back/lib/Valid.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Typeset 3 | open Syntax 4 | 5 | let _check_mono mono tenv fail return = 6 | let _fail name = 7 | fail (~$"Unknown type parameter" <+> ~$"\"" ~$name ~$"\"") 8 | in 9 | let rec _visit mono return = 10 | match mono with 11 | | MNothing -> return () 12 | | MUnit -> return () 13 | | MParam name -> 14 | if Set.is_member label_order name tenv 15 | then return () 16 | else _fail name 17 | | MVar exist -> 18 | begin match !exist with 19 | | None -> return () 20 | | Some mono1 -> _visit mono1 return 21 | end 22 | | MArrow (dom, codom) -> 23 | _visit dom @@ fun () -> 24 | _visit codom return 25 | in 26 | _visit mono return 27 | 28 | let check_mono mono ctx fail return = 29 | Context.get_tenv ctx @@ fun tenv -> 30 | Env.keys label_order tenv @@ fun tenv1 -> 31 | _check_mono mono tenv1 fail return 32 | 33 | let _check_poly poly tenv fail return = 34 | let _fail name = 35 | fail (~$"Unknown type parameter" <+> ~$"\"" ~$name ~$"\"") 36 | in 37 | let rec _visit poly tenv return = 38 | match poly with 39 | | PNothing -> return () 40 | | PUnit -> return () 41 | | PParam name -> 42 | if Set.is_member label_order name tenv 43 | then return () 44 | else _fail name 45 | | PVar exist -> 46 | begin match !exist with 47 | | None -> return () 48 | | Some mono -> _check_mono mono tenv fail return 49 | end 50 | | PArrow (dom, codom) -> 51 | _visit dom tenv @@ fun () -> 52 | _visit codom tenv return 53 | | PForall (param, poly1) -> 54 | let tenv1 = Set.add label_order param tenv in 55 | _visit poly1 tenv1 return 56 | | PMono mono -> 57 | _check_mono mono tenv fail return 58 | in 59 | _visit poly tenv return 60 | 61 | let check_poly poly ctx fail return = 62 | Context.get_tenv ctx @@ fun tenv -> 63 | Env.keys label_order tenv @@ fun tenv1 -> 64 | _check_poly poly tenv1 fail return 65 | 66 | let rec _check_expr expr tenv venv fail return = 67 | let _fail name = 68 | fail (~$"Unknown program parameter" <+> ~$"\"" ~$name ~$"\"") 69 | in 70 | match expr with 71 | | EUndefined | EUnit -> return () 72 | | EVar name -> 73 | if Set.is_member label_order name venv 74 | then return () 75 | else _fail name 76 | | EAbs (param, body) -> 77 | let venv1 = Set.add label_order param venv in 78 | _check_stmt body tenv venv1 Env.empty fail return 79 | | EApp (func, arg) -> 80 | _check_expr func tenv venv fail @@ fun () -> 81 | _check_expr arg tenv venv fail return 82 | | EAnno (expr1, poly) -> 83 | _check_expr expr1 tenv venv fail @@ fun () -> 84 | _check_poly poly tenv fail return 85 | and _check_stmt stmt tenv venv decls fail return = 86 | match stmt with 87 | | SDecl (name, poly, stmt1) -> 88 | if Set.is_member label_order name venv 89 | then fail (~$name <+> ~$"was redeclared") else 90 | _check_poly poly tenv fail @@ fun () -> 91 | let decl = ref false in 92 | Env.bind name decl decls @@ fun decls1 -> 93 | let venv1 = Set.add label_order name venv in 94 | _check_stmt stmt1 tenv venv1 decls1 fail @@ fun () -> 95 | if !decl then return () else 96 | fail (~$name <+> ~$"was declared but not defined") 97 | | SDefn (name, expr, stmt1) -> 98 | _check_expr expr tenv venv fail @@ fun () -> 99 | let venv1 = Set.add label_order name venv in 100 | Env.lookup label_equal name decls ignore (fun decl -> decl := true); 101 | _check_stmt stmt1 tenv venv1 decls fail return 102 | | SExpr expr -> 103 | _check_expr expr tenv venv fail return 104 | 105 | let check_expr expr tctx fail return = 106 | Context.get_tenv tctx @@ fun tenv -> 107 | Context.get_venv tctx @@ fun venv -> 108 | Env.keys label_order tenv @@ fun tenv1 -> 109 | Env.keys label_order venv @@ fun venv1 -> 110 | _check_expr expr tenv1 venv1 fail return 111 | 112 | let check_stmt stmt tctx fail return = 113 | Context.get_tenv tctx @@ fun tenv -> 114 | Context.get_venv tctx @@ fun venv -> 115 | Env.keys label_order tenv @@ fun tenv1 -> 116 | Env.keys label_order venv @@ fun venv1 -> 117 | _check_stmt stmt tenv1 venv1 Env.empty fail return 118 | 119 | let rec _check_prog prog tenv venv decls fail return = 120 | match prog with 121 | | PDecl (name, poly, prog1) -> 122 | if Set.is_member label_order name venv 123 | then fail (~$name <+> ~$"was redeclared") else 124 | _check_poly poly tenv fail @@ fun () -> 125 | let decl = ref false in 126 | Env.bind name decl decls @@ fun decls1 -> 127 | let venv1 = Set.add label_order name venv in 128 | _check_prog prog1 tenv venv1 decls1 fail @@ fun () -> 129 | if !decl then return () else 130 | fail (~$name <+> ~$"was declared but not defined") 131 | | PDefn (name, expr, prog1) -> 132 | _check_expr expr tenv venv fail @@ fun () -> 133 | let venv1 = Set.add label_order name venv in 134 | Env.lookup label_equal name decls ignore (fun decl -> decl := true); 135 | _check_prog prog1 tenv venv1 decls fail return 136 | | PEnd -> return () 137 | 138 | let check_prog prog tctx fail return = 139 | Context.get_tenv tctx @@ fun tenv -> 140 | Context.get_venv tctx @@ fun venv -> 141 | Env.keys label_order tenv @@ fun tenv1 -> 142 | Env.keys label_order venv @@ fun venv1 -> 143 | _check_prog prog tenv1 venv1 Env.empty fail return 144 | -------------------------------------------------------------------------------- /back/lib/Valid.mli: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Context 3 | val check_mono : mono -> tctx -> (Typeset.eDSL -> 'a) -> (unit -> 'a) -> 'a 4 | val check_poly : poly -> tctx -> (Typeset.eDSL -> 'a) -> (unit -> 'a) -> 'a 5 | val check_expr : expr -> tctx -> (Typeset.eDSL -> 'a) -> (unit -> 'a) -> 'a 6 | val check_stmt : stmt -> tctx -> (Typeset.eDSL -> 'a) -> (unit -> 'a) -> 'a 7 | val check_prog : prog -> tctx -> (Typeset.eDSL -> 'a) -> (unit -> 'a) -> 'a 8 | -------------------------------------------------------------------------------- /back/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name back) 3 | (public_name bhrp.back) 4 | (libraries 5 | landmarks 6 | typeset 7 | bhrp.util) 8 | (instrumentation (backend bhrp.landmarks))) 9 | -------------------------------------------------------------------------------- /back/test/Tests.ml: -------------------------------------------------------------------------------- 1 | open Bhrp_shared 2 | open Back 3 | open Front 4 | open Poly 5 | open Expr 6 | open Simple 7 | 8 | let parse input return = 9 | return (Parser.input Lexer.token (Lexing.from_string input)) 10 | 11 | let print layout = 12 | Typeset.compile layout @@ fun doc -> 13 | Typeset.render doc 2 80 @@ fun msg -> 14 | print_endline msg 15 | 16 | let (<:) left right = 17 | Check.subtype left right Native.tenv 18 | (fun msg -> print msg; false) 19 | (fun () -> true) 20 | 21 | let (==>) expr return = 22 | Check.synth_expr expr Native.tenv 23 | (fun msg -> print msg; assert false) 24 | return 25 | 26 | let (<==) expr poly = 27 | Check.check_expr expr poly Native.tenv 28 | (fun msg -> print msg; false) 29 | (fun () -> true) 30 | 31 | let purely_universally_quantified poly = 32 | let open Syntax in 33 | let rec _visit_poly poly = 34 | match poly with 35 | | PNothing -> true 36 | | PUnit -> true 37 | | PParam _label -> true 38 | | PVar _exist -> false 39 | | PArrow (dom, codom) -> 40 | _visit_poly dom && _visit_poly codom 41 | | PForall (_label, poly1) -> 42 | _visit_poly poly1 43 | | PMono mono -> 44 | _visit_mono mono 45 | and _visit_mono mono = 46 | match mono with 47 | | MNothing -> true 48 | | MUnit -> true 49 | | MParam _label -> true 50 | | MVar _exist -> false 51 | | MArrow (dom, codom) -> 52 | _visit_mono dom && _visit_mono codom 53 | in 54 | _visit_poly poly 55 | 56 | (* Define tests *) 57 | let print_parse_sound = 58 | let ctx = Naming.make_ctx () in 59 | QCheck.Test.make ~count:32 60 | ~name:"print_parse_sound" 61 | (arbitrary_typed_stmt ctx) 62 | (fun (stmt, _simple_mono) -> 63 | Print.print_stmt ctx stmt @@ fun stmt_s -> 64 | parse stmt_s @@ fun stmt1 -> 65 | Syntax.stmt_equal stmt stmt1) 66 | 67 | let subtype_sound = 68 | QCheck.Test.make ~count:64 69 | ~name:"subtype_sound" 70 | arbitrary_simple 71 | (fun simple -> 72 | Mono.simple_2_simple_mono simple @@ fun simple_mono -> 73 | Poly.simple_mono_2_simple_poly simple_mono @@ fun simple_poly_exist -> 74 | Poly.simple_2_simple_poly simple @@ fun simple_poly -> 75 | if not (simple_poly_exist <: simple_poly) then 76 | let ctx = Naming.make_ctx () in 77 | Print.print_poly ctx simple_poly print_endline; 78 | print_endline "-----------------------------------"; 79 | Print.print_poly ctx simple_poly_exist print_endline; 80 | print_endline "***********************************"; 81 | false 82 | else true) 83 | 84 | let synth_expr_sound = 85 | let ctx = Naming.make_ctx () in 86 | QCheck.Test.make ~count:128 87 | ~name:"synth_expr_sound" 88 | (arbitrary_typed_expr ctx) 89 | (fun (expr, simple_mono) -> 90 | Poly.simple_mono_2_simple_poly simple_mono @@ fun expr_t -> 91 | if not (expr <== expr_t) then 92 | let ctx = Naming.make_ctx () in 93 | Print.print_expr ctx expr print_endline; 94 | print_endline "-----------------------------------"; 95 | Print.print_poly ctx expr_t print_endline; 96 | print_endline "***********************************"; 97 | false 98 | else true) 99 | 100 | let synth_type_sound_l = 101 | let ctx = Naming.make_ctx () in 102 | QCheck.Test.make ~count:64 103 | ~name:"synth_type_sound_l" 104 | (arbitrary_typed_expr ctx) 105 | (fun (expr, simple_mono) -> 106 | Poly.simple_mono_2_simple_poly simple_mono @@ fun left -> 107 | expr ==> fun right -> 108 | left <: right) 109 | 110 | let synth_type_sound_r = 111 | let ctx = Naming.make_ctx () in 112 | QCheck.Test.make ~count:64 113 | ~name:"synth_type_sound_r" 114 | (arbitrary_typed_expr ctx) 115 | (fun (expr, simple_mono) -> 116 | Poly.simple_mono_2_simple_poly simple_mono @@ fun right -> 117 | expr ==> fun left -> 118 | left <: right) 119 | 120 | let check_type_sound = 121 | let ctx = Naming.make_ctx () in 122 | QCheck.Test.make ~count:64 123 | ~name:"check_type_sound" 124 | (arbitrary_typed_expr ctx) 125 | (fun (expr, _simple_mono) -> 126 | expr ==> fun expr_t -> 127 | expr <== expr_t) 128 | 129 | let generalize_sound = 130 | let ctx = Naming.make_ctx () in 131 | QCheck.Test.make ~count:64 132 | ~name:"generalize_sound" 133 | (arbitrary_poly ctx) 134 | (fun poly -> 135 | Check.generalize poly @@ fun poly1 -> 136 | purely_universally_quantified poly1) 137 | 138 | (* Run tests *) 139 | let _ = 140 | QCheck_runner.run_tests 141 | [ print_parse_sound 142 | (* ; subtype_sound *) 143 | ; synth_expr_sound 144 | (* ; synth_type_sound_l 145 | ; synth_type_sound_r 146 | ; check_type_sound 147 | ; generalize_sound *) 148 | ]; 149 | -------------------------------------------------------------------------------- /back/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name Tests) 3 | (libraries 4 | qcheck 5 | landmarks 6 | bhrp.back 7 | bhrp.front 8 | bhrp_shared) 9 | (instrumentation (backend bhrp.landmarks))) 10 | 11 | (rule 12 | (alias runtest) 13 | (action (run ./Tests.exe))) 14 | -------------------------------------------------------------------------------- /bhrp.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "bhrp" 3 | version: "1.0" 4 | synopsis: "Didactic OCaml implementation of the bidirectional higher-rank polymorphic type checker" 5 | maintainer: "sorennorbaek@gmail.com" 6 | authors: ["Soren Norbaek "] 7 | license: "MIT" 8 | homepage: "https://github.com/soren-n/bidi-higher-rank-poly" 9 | bug-reports: "https://github.com/soren-n/bidi-higher-rank-poly/issues" 10 | dev-repo: "git+https://github.com/soren-n/bidi-higher-rank-poly.git" 11 | build: [ 12 | "dune" "build" "-p" name "-j" jobs "@install" 13 | ] 14 | depends: [ 15 | "ocaml" {>= "4.08"} 16 | "dune" {>= "2.8"} 17 | "qcheck" {>= "0.17"} 18 | "typeset" {>= "0.2"} 19 | "landmarks" {>= "1.3"} 20 | ] 21 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name landmarks_backend) 3 | (public_name bhrp.landmarks) 4 | (instrumentation.backend 5 | (ppx landmarks.ppx))) 6 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (name bhrp) 3 | (using menhir 2.0) 4 | -------------------------------------------------------------------------------- /dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (context default) 3 | (context 4 | (default 5 | (name profilling) 6 | (instrument_with bhrp.landmarks) 7 | (env (_ (env-vars 8 | (OCAML_LANDMARKS "auto,format=json,output=profile.json")))))) 9 | -------------------------------------------------------------------------------- /examples/apply.bhrp: -------------------------------------------------------------------------------- 1 | ((x => x)(_x => unit))(x => x) 2 | -------------------------------------------------------------------------------- /examples/id.bhrp: -------------------------------------------------------------------------------- 1 | x => x 2 | -------------------------------------------------------------------------------- /examples/id_type.bhrp: -------------------------------------------------------------------------------- 1 | ((a => a) : a => a -> a) 2 | -------------------------------------------------------------------------------- /examples/product.bhrp: -------------------------------------------------------------------------------- 1 | cons : x => y => x -> y -> . 2 | cons = x => y => . 3 | 4 | head : -> x. 5 | head = => x. 6 | 7 | tail : -> y. 8 | tail = <_x y> => y. 9 | 10 | head (cons (cons unit unit) unit) 11 | -------------------------------------------------------------------------------- /examples/unit.bhrp: -------------------------------------------------------------------------------- 1 | unit 2 | -------------------------------------------------------------------------------- /front/lib/Interp.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Back 3 | open Syntax 4 | open Value 5 | 6 | let _fail () = assert false (* Syntax invariant *) 7 | 8 | let rec eval_expr expr env return = 9 | let _undefined = VUndefined in 10 | let _unit = VUnit in 11 | let _closure env param body = VClo (env, param, body) in 12 | match expr with 13 | | EUndefined -> return _undefined 14 | | EUnit -> return _unit 15 | | EVar name -> 16 | Env.lookup label_equal name env _fail return 17 | | EAbs (param, body) -> 18 | return (_closure env param body) 19 | | EApp (func, arg) -> 20 | eval_expr func env @@ fun func1 -> 21 | begin match func1 with 22 | | VClo (env1, param, body) -> 23 | eval_expr arg env @@ fun arg1 -> 24 | Env.bind param arg1 env1 @@ fun env2 -> 25 | eval_stmt body env2 return 26 | | VFix maybe_value -> 27 | begin match !maybe_value with 28 | | None -> assert false (* Runtime invariant *) 29 | | Some (VClo (env1, param, body)) -> 30 | eval_expr arg env @@ fun arg1 -> 31 | Env.bind param arg1 env1 @@ fun env2 -> 32 | eval_stmt body env2 return 33 | | _ -> assert false (* Typing invariant *) 34 | end 35 | | _ -> assert false (* Typing invariant *) 36 | end 37 | | EAnno (expr, _poly) -> 38 | eval_expr expr env return 39 | and eval_stmt stmt env return = 40 | let _closure env param body = VClo (env, param, body) in 41 | let _fix maybe_value = VFix maybe_value in 42 | match stmt with 43 | | SDecl (_, _, stmt1) -> eval_stmt stmt1 env return 44 | | SDefn (name, expr, stmt1) -> 45 | eval_expr expr env @@ fun expr1 -> 46 | begin match expr1 with 47 | | VClo (_env, param, body) -> 48 | let value = ref None in 49 | Env.bind name (_fix value) env @@ fun env1 -> 50 | value := Some (_closure env1 param body); 51 | eval_stmt stmt1 env1 return 52 | | _ -> 53 | Env.bind name expr1 env @@ fun env1 -> 54 | eval_stmt stmt1 env1 return 55 | end 56 | | SExpr expr -> 57 | eval_expr expr env return 58 | 59 | let rec _eval_prog prog env return = 60 | match prog with 61 | | PDecl (_, _, prog1) -> _eval_prog prog1 env return 62 | | PDefn (name, expr, prog1) -> 63 | eval_expr expr env @@ fun expr1 -> 64 | Env.bind name expr1 env @@ fun env1 -> 65 | _eval_prog prog1 env1 return 66 | | PEnd -> return env 67 | 68 | let eval_prog prog env return = 69 | _eval_prog prog env @@ fun env1 -> 70 | eval_expr (expr_app (expr_var "main") expr_unit) env1 @@ fun _result -> 71 | return () 72 | -------------------------------------------------------------------------------- /front/lib/Lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | exception Error of string 4 | } 5 | 6 | let label = ['a'-'z' 'A'-'Z' '_']['a'-'z' 'A'-'Z' '0'-'9' '_']* 7 | 8 | rule token = parse 9 | [' ' '\t' '\r'] { token lexbuf } 10 | | '\n' { Lexing.new_line lexbuf; token lexbuf } 11 | | "nothing" { NOTHING } 12 | | "undefined" { UNDEFINED } 13 | | "unit" { UNIT } 14 | | "->" { SINGLE_ARROW } 15 | | "=>" { DOUBLE_ARROW } 16 | | '(' { LPAREN } 17 | | ')' { RPAREN } 18 | | ':' { DECLARE } 19 | | '=' { DEFINE } 20 | | '.' { END } 21 | | label { LABEL (Lexing.lexeme lexbuf) } 22 | | eof { EOF } 23 | | _ { raise (Error "Syntax error") } 24 | -------------------------------------------------------------------------------- /front/lib/Native.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Back 3 | open Syntax 4 | 5 | let venv = 6 | Env.empty 7 | 8 | let tenv = 9 | Context.make 10 | (Env.from_list 11 | [ "main", poly_arrow poly_unit poly_unit 12 | ]) 13 | Env.empty 14 | -------------------------------------------------------------------------------- /front/lib/Parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Back 3 | open Syntax 4 | %} 5 | 6 | %token SINGLE_ARROW 7 | %token DOUBLE_ARROW 8 | %token NOTHING 9 | %token UNDEFINED 10 | %token UNIT 11 | %token LABEL 12 | %token LPAREN RPAREN 13 | %token DECLARE 14 | %token DEFINE 15 | %token END 16 | %token EOF 17 | 18 | %start file 19 | %type file 20 | 21 | %start input 22 | %type input 23 | 24 | %% 25 | 26 | file: 27 | | p = prog 28 | { p } 29 | 30 | input: 31 | | s = stmt EOF 32 | { s } 33 | 34 | expr: 35 | | e = expr_abs 36 | { e } 37 | | e = expr_redex 38 | { e } 39 | | e = expr_value 40 | { e } 41 | 42 | expr_abs: 43 | | x = LABEL DOUBLE_ARROW s = stmt 44 | { expr_abs x s } 45 | 46 | expr_redex: 47 | | f = expr_func a = expr_value 48 | { expr_app f a } 49 | 50 | expr_func: 51 | | x = LABEL 52 | { expr_var x } 53 | | LPAREN e = expr_group RPAREN 54 | { e } 55 | 56 | expr_value: 57 | | e = expr_simple 58 | { e } 59 | | LPAREN e = expr_group RPAREN 60 | { e } 61 | 62 | expr_simple: 63 | | UNDEFINED 64 | { expr_undefined } 65 | | UNIT 66 | { expr_unit } 67 | | x = LABEL 68 | { expr_var x } 69 | 70 | expr_group: 71 | | e = expr_value DECLARE p = poly 72 | { expr_anno e p } 73 | | e = expr_abs 74 | { e } 75 | | e = expr_redex 76 | { e } 77 | 78 | stmt: 79 | | x = LABEL DECLARE t = poly END s = stmt 80 | { stmt_decl x t s } 81 | | x = LABEL DEFINE e = expr END s = stmt 82 | { stmt_defn x e s } 83 | | e = expr 84 | { stmt_expr e } 85 | 86 | prog: 87 | | x = LABEL DECLARE t = poly END p = prog 88 | { prog_decl x t p } 89 | | x = LABEL DEFINE e = expr END p = prog 90 | { prog_defn x e p } 91 | | EOF 92 | { prog_end } 93 | 94 | poly: 95 | | s = poly_simple SINGLE_ARROW t = poly 96 | { poly_arrow s t } 97 | | x = LABEL DOUBLE_ARROW t = poly 98 | { poly_forall x t } 99 | | t = poly_simple 100 | { t } 101 | 102 | poly_simple: 103 | | NOTHING 104 | { poly_nothing } 105 | | UNIT 106 | { poly_unit } 107 | | x = LABEL 108 | { poly_param x } 109 | | LPAREN t = poly RPAREN 110 | { t } 111 | -------------------------------------------------------------------------------- /front/lib/Value.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Back 3 | open Syntax 4 | 5 | type value = 6 | | VUndefined 7 | | VUnit 8 | | VClo of (label, value) Env.env * label * stmt 9 | | VFix of value option ref 10 | 11 | let value_2_expr value return = 12 | let rec _eval value return = 13 | match value with 14 | | VUndefined -> return expr_undefined 15 | | VUnit -> return expr_unit 16 | | VClo (env, param, body) -> 17 | _normalize_stmt body env @@ fun body1 -> 18 | return (expr_abs param body1) 19 | | VFix maybe_value -> 20 | begin match !maybe_value with 21 | | None -> assert false (* Invariant *) 22 | | Some value -> _eval value return 23 | end 24 | and _normalize_expr expr env return = 25 | match expr with 26 | | EUndefined -> return expr_undefined 27 | | EUnit -> return expr_unit 28 | | EVar label -> 29 | Env.lookup label_equal label env 30 | (fun () -> return (expr_var label)) 31 | (fun value -> _eval value return) 32 | | EAbs (param, body) -> 33 | _normalize_stmt body env @@ fun body1 -> 34 | return (expr_abs param body1) 35 | | EApp (func, arg) -> 36 | _normalize_expr func env @@ fun func1 -> 37 | _normalize_expr arg env @@ fun arg1 -> 38 | return (expr_app func1 arg1) 39 | | EAnno (expr1, poly) -> 40 | _normalize_expr expr1 env @@ fun expr2 -> 41 | return (expr_anno expr2 poly) 42 | and _normalize_stmt stmt env return = 43 | match stmt with 44 | | SDecl (name, poly, stmt1) -> 45 | _normalize_stmt stmt1 env @@ fun stmt2 -> 46 | return (stmt_decl name poly stmt2) 47 | | SDefn (name, expr, stmt1) -> 48 | _normalize_expr expr env @@ fun expr1 -> 49 | _normalize_stmt stmt1 env @@ fun stmt2 -> 50 | return (stmt_defn name expr1 stmt2) 51 | | SExpr expr -> 52 | _normalize_expr expr env @@ fun expr1 -> 53 | return (stmt_expr expr1) 54 | in 55 | _eval value return 56 | 57 | let print_value value return = 58 | match value with 59 | | VUndefined -> return "undefined" 60 | | VUnit -> return "unit" 61 | | VClo _ -> return "" 62 | | VFix _ -> return "" 63 | 64 | let prepare env return = 65 | let _undefined = VUndefined in 66 | let _unit = VUnit in 67 | let _closure env param body = VClo (env, param, body) in 68 | let _convert expr return = 69 | match expr with 70 | | EUndefined -> return _undefined 71 | | EUnit -> return _unit 72 | | EAbs (param, body) -> return (_closure Env.empty param body) 73 | | _ -> assert false (* Typing invariant *) 74 | in 75 | Env.fold 76 | (fun return -> return Env.empty) 77 | (fun label expr visit_env return -> 78 | _convert expr @@ fun value -> 79 | visit_env @@ fun env1 -> 80 | Env.bind label value env1 return) 81 | env return 82 | -------------------------------------------------------------------------------- /front/lib/dune: -------------------------------------------------------------------------------- 1 | (ocamllex 2 | (modules Lexer)) 3 | 4 | (menhir 5 | (flags --explain) 6 | (modules Parser)) 7 | 8 | (library 9 | (name front) 10 | (public_name bhrp.front) 11 | (libraries 12 | landmarks 13 | bhrp.back 14 | bhrp.util) 15 | (instrumentation (backend bhrp.landmarks))) 16 | -------------------------------------------------------------------------------- /front/test/Tests.ml: -------------------------------------------------------------------------------- 1 | open Bhrp_shared 2 | open Expr 3 | open Back 4 | open Front 5 | 6 | let print layout = 7 | Typeset.compile layout @@ fun doc -> 8 | Typeset.render doc 2 80 @@ fun msg -> 9 | print_endline msg 10 | 11 | let (<:) left right = 12 | Check.subtype left right Native.tenv 13 | (fun msg -> print msg; false) 14 | (fun () -> true) 15 | 16 | let (==>) expr return = 17 | Check.synth_expr expr Native.tenv 18 | (fun msg -> print msg; assert false) 19 | return 20 | 21 | let (<==) expr poly = 22 | Check.check_expr expr poly Native.tenv 23 | (fun msg -> print msg; false) 24 | (fun () -> true) 25 | 26 | let interp expr return = 27 | Interp.eval_expr expr Native.venv @@ fun value -> 28 | Value.value_2_expr value return 29 | 30 | (* Define tests *) 31 | let interp_sound = 32 | let ctx = Naming.make_ctx () in 33 | QCheck.Test.make ~count:64 34 | ~name:"interp_sound" 35 | (arbitrary_typed_expr ctx) 36 | (fun (expr, simple_mono) -> 37 | Poly.simple_mono_2_simple_poly simple_mono @@ fun expr_t -> 38 | try 39 | interp expr @@ fun expr1 -> 40 | if not (expr1 <== expr_t) then 41 | let ctx = Naming.make_ctx () in 42 | Print.print_expr ctx expr print_endline; 43 | print_endline "-----------------------------------"; 44 | Print.print_expr ctx expr1 print_endline; 45 | print_endline "-----------------------------------"; 46 | Print.print_poly ctx expr_t print_endline; 47 | print_endline "***********************************"; 48 | false 49 | else true 50 | with Assert_failure (msg, line, index) -> 51 | let open Printf in 52 | print_endline (sprintf "%s: line %d, index %d" msg line index); 53 | let ctx = Naming.make_ctx () in 54 | Print.print_expr ctx expr print_endline; 55 | print_endline "-----------------------------------"; 56 | Print.print_poly ctx expr_t print_endline; 57 | print_endline "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@"; 58 | false 59 | ) 60 | 61 | (* Run tests *) 62 | let _ = 63 | QCheck_runner.run_tests 64 | [ interp_sound 65 | ]; 66 | -------------------------------------------------------------------------------- /front/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name Tests) 3 | (libraries 4 | qcheck 5 | landmarks 6 | bhrp.back 7 | bhrp.front 8 | bhrp_shared) 9 | (instrumentation (backend bhrp.landmarks))) 10 | 11 | (rule 12 | (alias runtest) 13 | (action (run ./Tests.exe))) 14 | -------------------------------------------------------------------------------- /misc/profile.csv: -------------------------------------------------------------------------------- 1 | 'Name'; 'Calls'; 'Time Per Call'; 'Time Total' 2 | 'Back/test/Mono._lookup'; 38096; 0,0013; 48,0278 3 | 'Back/test/Simple.proper_simple_equal'; 13372326; 0,0000; 31,7840 4 | 'Util/lib/Map.get_value_unsafe'; 6718; 0,0005; 3,2638 5 | 'Back/test/Mono._lookup'; 1720; 0,0017; 3,0080 6 | 'Back/test/Simple._gen_proper_simple'; 1268; 0,0016; 1,9775 7 | 'Back/test/Simple.proper_simple_equal'; 768050; 0,0000; 1,9524 8 | 'Util/lib/Typeset.newline'; 207; 0,0061; 1,2544 9 | 'Util/lib/Typeset._rescope'; 34; 0,0348; 1,1840 10 | 'Util/lib/Typeset._denull'; 34; 0,0167; 0,5692 11 | 'Util/lib/Typeset._linearize'; 34; 0,0163; 0,5525 12 | 'Back/lib/Naming.sample_label'; 3939; 0,0001; 0,4922 13 | 'Util/lib/Typeset._fixed'; 34; 0,0122; 0,4160 14 | 'Back/test/Simple._gen_simple'; 128; 0,0029; 0,3771 15 | 'Util/lib/Typeset._serialize'; 34; 0,0087; 0,2948 16 | 'Back/test/Mono._gen_proper_simple_mono'; 1268; 0,0002; 0,2542 17 | 'Util/lib/Extra.List.cons'; 93659; 0,0000; 0,2407 18 | 'Util/lib/Extra.List.cons'; 95249; 0,0000; 0,2361 19 | 'Back/test/Simple._gen_proper_simple'; 66; 0,0034; 0,2220 20 | 'Util/lib/AVL.fold'; 2691; 0,0001; 0,1966 21 | 'Util/lib/Env.bind'; 3829; 0,0000; 0,1895 22 | 'Util/lib/AVL.local_inbalance'; 16430; 0,0000; 0,1764 23 | 'Util/lib/Infix.<=='; 847651; 0,0000; 0,1700 24 | 'Front/lib/Lexer.token'; 12387; 0,0000; 0,1489 25 | 'Util/lib/Order.int_compare'; 38258; 0,0000; 0,1325 26 | 'Util/lib/AVL.local_rebalance'; 16430; 0,0000; 0,1256 27 | 'Util/lib/Extra.compose'; 13436; 0,0000; 0,1221 28 | 'Front/lib/Parser.input'; 17; 0,0070; 0,1191 29 | 'Util/lib/Typeset.get_break'; 3490; 0,0000; 0,1190 30 | 'Util/lib/Map.get_key'; 62302; 0,0000; 0,1152 31 | 'Util/lib/Extra.identity'; 24863; 0,0000; 0,0992 32 | 'Util/lib/Typeset._identities'; 34; 0,0025; 0,0842 33 | 'Util/lib/AVL.make_node'; 28117; 0,0000; 0,0830 34 | 'Back/test/Mono._proper_simple_convert'; 630; 0,0001; 0,0826 35 | 'Util/lib/AVL.get_height'; 32860; 0,0000; 0,0818 36 | 'Util/lib/Typeset.get_pos'; 17587; 0,0000; 0,0602 37 | 'Util/lib/Env.bind'; 1739; 0,0000; 0,0551 38 | 'Util/lib/Typeset.get_head'; 2504; 0,0000; 0,0523 39 | 'load(back/test/Main)'; 1; 0,0520; 0,0520 40 | 'Util/lib/Typeset.~$'; 11238; 0,0000; 0,0516 41 | 'Back/lib/Naming.suffix'; 1927; 0,0000; 0,0490 42 | 'Util/lib/Extra.List.fold'; 2691; 0,0000; 0,0422 43 | 'Back/lib/Syntax._equal_stmt'; 17; 0,0023; 0,0396 44 | 'Util/lib/Extra.identity'; 2727; 0,0000; 0,0363 45 | 'Back/test/Expr._synth_expr_bind'; 2362; 0,0000; 0,0360 46 | 'Util/lib/Typeset._reassociate'; 34; 0,0010; 0,0339 47 | 'Back/test/Simple.proper_simple_arrow'; 18414; 0,0000; 0,0337 48 | 'Util/lib/Typeset.'; 3866; 0,0000; 0,0335 49 | 'Back/test/Expr._synth_expr_lookup'; 909; 0,0000; 0,0330 50 | 'Util/lib/Extra.identity'; 16978; 0,0000; 0,0324 51 | 'Util/lib/AVL.get_height'; 9777; 0,0000; 0,0321 52 | 'Back/test/Mono.proper_simple_mono_arrow'; 15231; 0,0000; 0,0304 53 | 'Util/lib/Typeset._broken'; 34; 0,0009; 0,0295 54 | 'Back/test/Expr._synth_expr_lookup'; 758; 0,0000; 0,0286 55 | 'Back/test/Expr._synth_expr_lookup'; 778; 0,0000; 0,0276 56 | 'Util/lib/Typeset.<+>'; 4068; 0,0000; 0,0273 57 | 'Util/lib/Map.values'; 2691; 0,0000; 0,0261 58 | 'Util/lib/Map.make_bind'; 13371; 0,0000; 0,0254 59 | 'Back/lib/Syntax.label_equal'; 7022; 0,0000; 0,0253 60 | 'Back/test/Main.parse'; 89; 0,0003; 0,0243 61 | 'Util/lib/Typeset.text'; 13622; 0,0000; 0,0227 62 | 'Back/lib/Naming.suffix'; 751; 0,0000; 0,0223 63 | 'Util/lib/Typeset.comp'; 11299; 0,0000; 0,0205 64 | 'Util/lib/Typeset.text'; 11238; 0,0000; 0,0188 65 | 'Util/lib/AVL.to_list'; 2691; 0,0000; 0,0186 66 | 'Back/test/Poly._proper_simple_mono_poly'; 501; 0,0000; 0,0183 67 | 'Util/lib/AVL.get_height'; 6846; 0,0000; 0,0182 68 | 'ROOT'; 0; 0,0169; 0,0169 69 | 'Back/test/Mono.proper_simple_mono_equal'; 5208; 0,0000; 0,0164 70 | 'Util/lib/Typeset._structurize'; 92; 0,0002; 0,0162 71 | 'Back/test/Mono.proper_simple_mono_equal'; 4896; 0,0000; 0,0162 72 | 'Util/lib/Extra.swap'; 2580; 0,0000; 0,0158 73 | 'Back/test/Mono.proper_simple_mono_equal'; 3907; 0,0000; 0,0152 74 | 'Util/lib/Extra.List.map'; 2691; 0,0000; 0,0150 75 | 'Back/lib/Print._group'; 932; 0,0000; 0,0144 76 | 'Util/lib/Typeset.seq'; 3083; 0,0000; 0,0137 77 | 'Util/lib/Extra.List.cons'; 6718; 0,0000; 0,0132 78 | 'Back/test/Mono._gen_proper_simple_mono'; 66; 0,0002; 0,0131 79 | 'Util/lib/Typeset.make_node'; 5707; 0,0000; 0,0122 80 | 'Util/lib/Typeset.get_head'; 763; 0,0000; 0,0115 81 | 'Util/lib/Typeset.'; 1847; 0,0000; 0,0112 82 | 'Back/test/Simple._gen_simple_wrap'; 128; 0,0001; 0,0111 83 | 'Util/lib/AVL.insert_cont'; 13436; 0,0000; 0,0109 84 | 'Util/lib/Typeset.make_edge'; 5473; 0,0000; 0,0105 85 | 'Util/lib/Typeset.'; 1864; 0,0000; 0,0101 86 | 'Back/lib/Naming.suffix'; 652; 0,0000; 0,0094 87 | 'Util/lib/Infix.<=='; 2383; 0,0000; 0,0094 88 | 'Util/lib/Typeset.line'; 2693; 0,0000; 0,0094 89 | 'Back/test/Expr._synth_expr_lookup'; 280; 0,0000; 0,0091 90 | 'Util/lib/AVL.get_count'; 4564; 0,0000; 0,0091 91 | 'Util/lib/Typeset.~$'; 1864; 0,0000; 0,0091 92 | 'Back/lib/Naming.suffix'; 778; 0,0000; 0,0080 93 | 'Back/lib/Print._pass'; 1190; 0,0000; 0,0077 94 | 'Util/lib/Extra.identity'; 3969; 0,0000; 0,0075 95 | 'Util/lib/Typeset.'; 1645; 0,0000; 0,0074 96 | 'Util/lib/Map.get_value_unsafe'; 27; 0,0003; 0,0072 97 | 'Util/lib/Typeset.comp'; 4068; 0,0000; 0,0070 98 | 'Util/lib/Typeset.seq'; 4068; 0,0000; 0,0068 99 | 'Util/lib/Typeset.comp'; 3866; 0,0000; 0,0068 100 | 'Back/lib/Print._layout_stmt'; 128; 0,0001; 0,0067 101 | 'Util/lib/Typeset._structurize'; 34; 0,0002; 0,0066 102 | 'Util/lib/Typeset.get_pos'; 495; 0,0000; 0,0065 103 | 'Back/lib/Print._wrap'; 301; 0,0000; 0,0063 104 | 'Front/lib/Parser.input'; 6; 0,0010; 0,0062 105 | 'Back/test/Poly.proper_simple_mono_poly'; 501; 0,0000; 0,0059 106 | 'Util/lib/Typeset.nest'; 3182; 0,0000; 0,0059 107 | 'Front/lib/Lexer.token'; 662; 0,0000; 0,0054 108 | 'Util/lib/Typeset.nest'; 3226; 0,0000; 0,0054 109 | 'Back/test/Expr._synth_expr_bind'; 151; 0,0000; 0,0053 110 | 'Back/lib/Naming.sample'; 1927; 0,0000; 0,0052 111 | 'Util/lib/Extra.identity'; 2691; 0,0000; 0,0051 112 | 'Util/lib/Env.lookup'; 1758; 0,0000; 0,0050 113 | 'Util/lib/Typeset.newline'; 9; 0,0006; 0,0050 114 | 'Back/test/Mono.proper_simple_mono_arrow'; 2132; 0,0000; 0,0050 115 | 'Util/lib/AVL.make_null'; 2657; 0,0000; 0,0049 116 | 'Util/lib/AVL.make_node'; 2580; 0,0000; 0,0049 117 | 'Back/test/Mono._proper_simple_convert'; 43; 0,0001; 0,0048 118 | 'Back/lib/Print._layout_poly'; 556; 0,0000; 0,0047 119 | 'Back/test/Mono.proper_simple_mono_equal'; 1789; 0,0000; 0,0046 120 | 'Util/lib/Map.get_value_unsafe'; 16; 0,0003; 0,0046 121 | 'Util/lib/Env.lookup'; 610; 0,0000; 0,0044 122 | 'Back/test/Mono._lookup'; 115; 0,0000; 0,0042 123 | 'Util/lib/Env.lookup'; 573; 0,0000; 0,0041 124 | 'Util/lib/Typeset.get_offset'; 19686; 0,0000; 0,0041 125 | 'Back/lib/Syntax.expr_var'; 1235; 0,0000; 0,0040 126 | 'Util/lib/Typeset._linearize'; 92; 0,0000; 0,0038 127 | 'Back/lib/Naming.suffix'; 220; 0,0000; 0,0038 128 | 'Back/lib/Naming.suffix'; 35; 0,0001; 0,0038 129 | 'Util/lib/Typeset.comp'; 1847; 0,0000; 0,0038 130 | 'Util/lib/Typeset.~$'; 602; 0,0000; 0,0038 131 | 'Util/lib/Typeset.inc_pos'; 75995; 0,0000; 0,0037 132 | 'Util/lib/Env.bind'; 169; 0,0000; 0,0037 133 | 'Util/lib/Extra.identity'; 2151; 0,0000; 0,0037 134 | 'Back/lib/Syntax.stmt_expr'; 1375; 0,0000; 0,0035 135 | 'Back/lib/Syntax.expr_abs'; 1319; 0,0000; 0,0035 136 | 'Util/lib/Typeset.get_head'; 187; 0,0000; 0,0034 137 | 'Back/lib/Naming.sample_label'; 92; 0,0000; 0,0034 138 | 'Back/test/Mono.exist_equal'; 1306; 0,0000; 0,0032 139 | 'Util/lib/Typeset.'; 602; 0,0000; 0,0032 140 | 'Util/lib/Typeset.comp'; 1864; 0,0000; 0,0032 141 | 'Front/lib/Lexer.token'; 541; 0,0000; 0,0031 142 | 'Util/lib/Typeset.get_head'; 86; 0,0000; 0,0031 143 | 'Util/lib/Typeset.text'; 1864; 0,0000; 0,0031 144 | 'Back/test/Expr._synth_stmt'; 128; 0,0000; 0,0030 145 | 'Front/lib/Parser.input'; 2; 0,0015; 0,0030 146 | 'Util/lib/Typeset.grp'; 1692; 0,0000; 0,0029 147 | 'Back/lib/Syntax.stmt_defn'; 1065; 0,0000; 0,0028 148 | 'Front/lib/Lexer.token'; 178; 0,0000; 0,0028 149 | 'Util/lib/Typeset.line'; 1645; 0,0000; 0,0028 150 | 'Front/lib/Parser.input'; 2; 0,0014; 0,0027 151 | 'Util/lib/Typeset.get_break'; 234; 0,0000; 0,0027 152 | 'Back/lib/Naming.suffix'; 92; 0,0000; 0,0026 153 | 'Back/lib/Syntax.poly_var'; 751; 0,0000; 0,0026 154 | 'Back/test/Mono._bind'; 630; 0,0000; 0,0026 155 | 'Back/test/Main.parse'; 17; 0,0001; 0,0025 156 | 'Back/lib/Syntax.exist_equal'; 1395; 0,0000; 0,0025 157 | 'Util/lib/Typeset._broken'; 92; 0,0000; 0,0024 158 | 'Util/lib/Typeset.grp'; 1369; 0,0000; 0,0024 159 | 'Back/lib/Syntax.stmt_expr'; 1229; 0,0000; 0,0023 160 | 'Back/lib/Naming.sample_label'; 48; 0,0000; 0,0023 161 | 'Back/test/Mono.proper_simple_mono_var'; 630; 0,0000; 0,0023 162 | 'Back/lib/Naming.suffix'; 86; 0,0000; 0,0023 163 | 'Back/lib/Syntax.expr_abs'; 1212; 0,0000; 0,0022 164 | 'Util/lib/Typeset._serialize'; 92; 0,0000; 0,0022 165 | 'Front/lib/Parser.input'; 89; 0,0000; 0,0021 166 | 'Back/lib/Syntax.stmt_defn'; 991; 0,0000; 0,0020 167 | 'Util/lib/Typeset.~$'; 205; 0,0000; 0,0019 168 | 'Back/lib/Syntax.poly_param'; 727; 0,0000; 0,0019 169 | 'Util/lib/Map.lookup_unsafe_cont'; 6718; 0,0000; 0,0019 170 | 'Back/lib/Naming.sample'; 652; 0,0000; 0,0018 171 | 'Back/lib/Syntax.expr_var'; 940; 0,0000; 0,0018 172 | 'Back/lib/Naming.sample'; 751; 0,0000; 0,0018 173 | 'Back/test/Mono._gen_simple_mono'; 128; 0,0000; 0,0017 174 | 'Back/lib/Naming.sample_exist'; 812; 0,0000; 0,0017 175 | 'Back/test/Simple.proper_simple_arrow'; 827; 0,0000; 0,0017 176 | 'Back/test/Simple.proper_simple_equal'; 574; 0,0000; 0,0017 177 | 'Util/lib/Map.values'; 89; 0,0000; 0,0017 178 | 'Back/lib/Syntax._equal_stmt'; 6; 0,0003; 0,0017 179 | 'Util/lib/Typeset._fixed'; 92; 0,0000; 0,0017 180 | 'Front/lib/Parser.input'; 3; 0,0006; 0,0017 181 | 'Util/lib/Typeset._rescope'; 89; 0,0000; 0,0016 182 | 'Back/lib/Syntax.poly_arrow'; 771; 0,0000; 0,0016 183 | 'Util/lib/AVL.insert_cont'; 54; 0,0000; 0,0016 184 | 'Util/lib/AVL.local_inbalance'; 119; 0,0000; 0,0015 185 | 'Util/lib/Typeset._rescope'; 2; 0,0008; 0,0015 186 | 'Util/lib/Env.bind'; 610; 0,0000; 0,0015 187 | 'Back/lib/Syntax.poly_arrow'; 789; 0,0000; 0,0015 188 | 'Util/lib/Extra.identity'; 712; 0,0000; 0,0015 189 | 'Util/lib/AVL.local_rebalance'; 119; 0,0000; 0,0015 190 | 'Back/lib/Naming.sample'; 778; 0,0000; 0,0015 191 | 'Util/lib/Env.bind'; 573; 0,0000; 0,0014 192 | 'Back/lib/Syntax.stmt_decl'; 501; 0,0000; 0,0014 193 | 'Util/lib/Typeset.get_pos'; 38; 0,0000; 0,0014 194 | 'Util/lib/Typeset.set_pos'; 6039; 0,0000; 0,0014 195 | 'Util/lib/Typeset._rescope'; 3; 0,0005; 0,0014 196 | 'Back/test/Expr._synth_expr_lookup'; 62; 0,0000; 0,0014 197 | 'Util/lib/Typeset._denull'; 89; 0,0000; 0,0014 198 | 'Back/lib/Naming.suffix'; 135; 0,0000; 0,0013 199 | 'Back/test/Mono.proper_simple_mono_arrow'; 691; 0,0000; 0,0013 200 | 'Back/test/Poly._proper_simple_mono_poly'; 55; 0,0000; 0,0013 201 | 'Back/lib/Print.layout_stmt'; 128; 0,0000; 0,0013 202 | 'Util/lib/Map.insert_cont'; 13436; 0,0000; 0,0013 203 | 'Util/lib/Typeset._reassociate'; 89; 0,0000; 0,0013 204 | 'Back/lib/Syntax.expr_var'; 573; 0,0000; 0,0013 205 | 'Util/lib/Typeset.render'; 89; 0,0000; 0,0013 206 | 'Back/lib/Syntax.expr_var'; 348; 0,0000; 0,0013 207 | 'Front/lib/Lexer.token'; 165; 0,0000; 0,0012 208 | 'Util/lib/Typeset.inc_pos'; 89; 0,0000; 0,0012 209 | 'Util/lib/Env.lookup'; 1880; 0,0000; 0,0012 210 | 'Back/test/Mono.proper_simple_mono_var'; 378; 0,0000; 0,0012 211 | 'Back/test/Expr._synth_expr_bind'; 126; 0,0000; 0,0012 212 | 'Back/test/Expr._synth_expr_lookup'; 36; 0,0000; 0,0012 213 | 'Back/test/Mono.proper_simple_mono_var'; 433; 0,0000; 0,0012 214 | 'Util/lib/AVL.to_list'; 89; 0,0000; 0,0012 215 | 'Util/lib/AVL.make_node'; 119; 0,0000; 0,0012 216 | 'Util/lib/Typeset._identities'; 89; 0,0000; 0,0011 217 | 'Util/lib/Typeset.comp'; 602; 0,0000; 0,0011 218 | 'Back/lib/Naming.suffix'; 61; 0,0000; 0,0011 219 | 'Util/lib/Typeset.text'; 602; 0,0000; 0,0011 220 | 'Util/lib/Extra.identity'; 540; 0,0000; 0,0011 221 | 'Back/lib/Print.print_stmt'; 128; 0,0000; 0,0010 222 | 'Util/lib/Typeset.render'; 34; 0,0000; 0,0010 223 | 'Back/lib/Naming.suffix'; 34; 0,0000; 0,0010 224 | 'Util/lib/Infix.<=='; 1544; 0,0000; 0,0010 225 | 'Util/lib/Typeset.get_break'; 23; 0,0000; 0,0010 226 | 'Back/lib/Naming.sample'; 82; 0,0000; 0,0010 227 | 'Back/lib/Naming.suffix'; 82; 0,0000; 0,0010 228 | 'Back/test/Mono.proper_simple_mono_equal'; 356; 0,0000; 0,0010 229 | 'Back/lib/Syntax.label_equal'; 250; 0,0000; 0,0009 230 | 'Util/lib/AVL.fold'; 89; 0,0000; 0,0009 231 | 'Back/lib/Syntax.stmt_decl'; 487; 0,0000; 0,0009 232 | 'Back/lib/Syntax.expr_app'; 203; 0,0000; 0,0009 233 | 'Back/test/Mono.proper_simple_mono_equal'; 192; 0,0000; 0,0009 234 | 'Back/lib/Syntax._equal_stmt'; 2; 0,0004; 0,0009 235 | 'Util/lib/Typeset.compile'; 92; 0,0000; 0,0009 236 | 'Util/lib/Typeset.~$'; 129; 0,0000; 0,0009 237 | 'Util/lib/Env.lookup'; 100; 0,0000; 0,0009 238 | 'Util/lib/Typeset.get_head'; 69; 0,0000; 0,0008 239 | 'Util/lib/Typeset.make_node'; 89; 0,0000; 0,0008 240 | 'Util/lib/Extra.List.fold'; 89; 0,0000; 0,0008 241 | 'Util/lib/Typeset.set_pos'; 89; 0,0000; 0,0008 242 | 'Util/lib/Extra.List.cons'; 359; 0,0000; 0,0008 243 | 'Front/lib/Parser.input'; 3; 0,0003; 0,0008 244 | 'Front/lib/Parser.input'; 1; 0,0008; 0,0008 245 | 'Front/lib/Parser.input'; 3; 0,0002; 0,0007 246 | 'Util/lib/Extra.List.cons'; 393; 0,0000; 0,0007 247 | 'Util/lib/Typeset.set_break'; 89; 0,0000; 0,0007 248 | 'Util/lib/AVL.fold'; 4; 0,0002; 0,0007 249 | 'Back/lib/Naming.sample'; 220; 0,0000; 0,0007 250 | 'Front/lib/Parser.input'; 2; 0,0004; 0,0007 251 | 'Util/lib/Map.values'; 36; 0,0000; 0,0007 252 | 'Back/test/Mono.proper_simple_mono_var'; 270; 0,0000; 0,0007 253 | 'Util/lib/Typeset.set_head'; 89; 0,0000; 0,0007 254 | 'Util/lib/Typeset.compile'; 34; 0,0000; 0,0007 255 | 'Util/lib/Typeset.reset'; 89; 0,0000; 0,0007 256 | 'Front/lib/Lexer.token'; 98; 0,0000; 0,0006 257 | 'Back/lib/Print._group'; 24; 0,0000; 0,0006 258 | 'Util/lib/Typeset.get_offset'; 10; 0,0001; 0,0006 259 | 'Back/test/Mono.proper_simple_mono_equal'; 182; 0,0000; 0,0006 260 | 'Util/lib/Extra.List.cons'; 297; 0,0000; 0,0006 261 | 'Util/lib/Typeset.set_break'; 6740; 0,0000; 0,0006 262 | 'Util/lib/Typeset.text'; 273; 0,0000; 0,0006 263 | 'Front/lib/Lexer.token'; 77; 0,0000; 0,0006 264 | 'Util/lib/Typeset._linearize'; 2; 0,0003; 0,0006 265 | 'Util/lib/Typeset._denull'; 2; 0,0003; 0,0006 266 | 'Back/test/Expr._synth_expr_lookup'; 13; 0,0000; 0,0006 267 | 'Util/lib/Typeset._denull'; 3; 0,0002; 0,0006 268 | 'Back/test/Poly.proper_simple_mono_poly'; 55; 0,0000; 0,0006 269 | 'Util/lib/Extra.List.map'; 89; 0,0000; 0,0006 270 | 'Back/lib/Syntax.stmt_equal'; 89; 0,0000; 0,0006 271 | 'Util/lib/AVL.get_height'; 238; 0,0000; 0,0006 272 | 'Back/lib/Syntax.label_equal'; 178; 0,0000; 0,0006 273 | 'Util/lib/Typeset.get_offset'; 19; 0,0000; 0,0006 274 | 'Util/lib/Typeset._serialize'; 2; 0,0003; 0,0006 275 | 'Back/lib/Naming.sample_label'; 21; 0,0000; 0,0006 276 | 'Util/lib/AVL.local_inbalance'; 51; 0,0000; 0,0006 277 | 'Back/test/Expr._synth_expr_bind'; 15; 0,0000; 0,0006 278 | 'Util/lib/AVL.local_rebalance'; 51; 0,0000; 0,0005 279 | 'Util/lib/Typeset.grp'; 301; 0,0000; 0,0005 280 | 'Back/lib/Naming.suffix'; 6; 0,0001; 0,0005 281 | 'Util/lib/Typeset.text'; 205; 0,0000; 0,0005 282 | 'Back/test/Expr._synth_expr_lookup'; 41; 0,0000; 0,0005 283 | 'Util/lib/Env.lookup'; 171; 0,0000; 0,0005 284 | 'Util/lib/Map.get_key'; 250; 0,0000; 0,0005 285 | 'Util/lib/Typeset.indent'; 19470; 0,0000; 0,0005 286 | 'Util/lib/Typeset._fixed'; 2; 0,0002; 0,0005 287 | 'Util/lib/Order.int_compare'; 153; 0,0000; 0,0005 288 | 'Back/test/Expr.synth_stmt'; 128; 0,0000; 0,0005 289 | 'Util/lib/Typeset.get_lvl'; 53153; 0,0000; 0,0005 290 | 'Util/lib/Typeset.get_offset'; 46; 0,0000; 0,0005 291 | 'Util/lib/AVL.to_list'; 36; 0,0000; 0,0005 292 | 'Front/lib/Lexer.token'; 64; 0,0000; 0,0004 293 | 'Util/lib/Extra.List.cons'; 224; 0,0000; 0,0004 294 | 'Util/lib/Typeset._structurize'; 2; 0,0002; 0,0004 295 | 'Util/lib/Typeset._broken'; 2; 0,0002; 0,0004 296 | 'Back/lib/Naming.sample_label'; 10; 0,0000; 0,0004 297 | 'Util/lib/Typeset.reset'; 5420; 0,0000; 0,0004 298 | 'Util/lib/Typeset.get_head'; 13; 0,0000; 0,0004 299 | 'Util/lib/Typeset.set_lvl'; 38940; 0,0000; 0,0004 300 | 'Back/lib/Naming.sample'; 135; 0,0000; 0,0004 301 | 'Util/lib/Typeset.get_break'; 19; 0,0000; 0,0004 302 | 'Util/lib/AVL.local_rebalance'; 23; 0,0000; 0,0004 303 | 'Back/lib/Syntax._equal_stmt'; 3; 0,0001; 0,0004 304 | 'Back/test/Main.parse'; 6; 0,0001; 0,0004 305 | 'Util/lib/Typeset.set_head'; 15269; 0,0000; 0,0004 306 | 'Back/lib/Syntax._equal_stmt'; 89; 0,0000; 0,0004 307 | 'Util/lib/AVL.make_null'; 70; 0,0000; 0,0004 308 | 'Back/lib/Naming.sample'; 92; 0,0000; 0,0004 309 | 'Back/lib/Syntax.expr_app'; 185; 0,0000; 0,0004 310 | 'Util/lib/Typeset.'; 48; 0,0000; 0,0004 311 | 'Front/lib/Lexer.token'; 40; 0,0000; 0,0004 312 | 'Back/lib/Naming.suffix'; 9; 0,0000; 0,0004 313 | 'Back/lib/Naming.sample_label'; 9; 0,0000; 0,0004 314 | 'Back/lib/Print._group'; 15; 0,0000; 0,0004 315 | 'Util/lib/Typeset.<+>'; 45; 0,0000; 0,0003 316 | 'Util/lib/Typeset.grp'; 120; 0,0000; 0,0003 317 | 'Back/test/Mono.proper_simple_mono_arrow'; 116; 0,0000; 0,0003 318 | 'Back/test/Expr._synth_expr_lookup'; 15; 0,0000; 0,0003 319 | 'Util/lib/AVL.fold'; 36; 0,0000; 0,0003 320 | 'Util/lib/Typeset.<+>'; 40; 0,0000; 0,0003 321 | 'Util/lib/Typeset.get_head'; 17; 0,0000; 0,0003 322 | 'Util/lib/AVL.make_null'; 92; 0,0000; 0,0003 323 | 'Util/lib/Extra.List.fold'; 36; 0,0000; 0,0003 324 | 'Back/lib/Syntax.expr_var'; 66; 0,0000; 0,0003 325 | 'Back/test/Expr._synth_expr_lookup'; 11; 0,0000; 0,0003 326 | 'Util/lib/Typeset.'; 38; 0,0000; 0,0003 327 | 'Util/lib/Typeset.~$'; 48; 0,0000; 0,0003 328 | 'Util/lib/Extra.compose'; 54; 0,0000; 0,0003 329 | 'Util/lib/AVL.insert_cont'; 32; 0,0000; 0,0003 330 | 'Util/lib/Typeset.inc_pos'; 402; 0,0000; 0,0003 331 | 'Util/lib/Typeset.'; 35; 0,0000; 0,0003 332 | 'Util/lib/Typeset.set_lvl'; 38; 0,0000; 0,0003 333 | 'Util/lib/Typeset._identities'; 3; 0,0001; 0,0003 334 | 'Util/lib/Extra.identity'; 154; 0,0000; 0,0003 335 | 'Front/lib/Lexer.token'; 36; 0,0000; 0,0003 336 | 'Util/lib/Typeset.text'; 129; 0,0000; 0,0003 337 | 'Back/lib/Syntax.expr_var'; 66; 0,0000; 0,0003 338 | 'Util/lib/Typeset._reassociate'; 3; 0,0001; 0,0003 339 | 'Back/test/Expr._synth_expr_bind'; 4; 0,0001; 0,0003 340 | 'Back/lib/Naming.suffix'; 19; 0,0000; 0,0003 341 | 'Back/lib/Syntax.expr_var'; 85; 0,0000; 0,0003 342 | 'Back/lib/Syntax.expr_var'; 103; 0,0000; 0,0003 343 | 'Util/lib/AVL.local_inbalance'; 23; 0,0000; 0,0003 344 | 'Util/lib/Typeset.text'; 110; 0,0000; 0,0003 345 | 'Util/lib/Typeset.indent'; 19; 0,0000; 0,0003 346 | 'Back/lib/Syntax.poly_var'; 82; 0,0000; 0,0003 347 | 'Util/lib/Typeset.make_state'; 89; 0,0000; 0,0003 348 | 'Util/lib/Typeset.grp'; 105; 0,0000; 0,0003 349 | 'Back/lib/Syntax.expr_abs'; 56; 0,0000; 0,0003 350 | 'Util/lib/Typeset.get_lvl'; 38; 0,0000; 0,0003 351 | 'Util/lib/Extra.List.map'; 36; 0,0000; 0,0003 352 | 'Back/lib/Syntax.stmt_equal'; 17; 0,0000; 0,0003 353 | 'Util/lib/Typeset.get_break'; 14; 0,0000; 0,0003 354 | 'Util/lib/Extra.identity'; 96; 0,0000; 0,0003 355 | 'Util/lib/Extra.List.cons'; 128; 0,0000; 0,0002 356 | 'Util/lib/Env.bind'; 100; 0,0000; 0,0002 357 | 'Back/lib/Naming.suffix'; 2; 0,0001; 0,0002 358 | 'Util/lib/Extra.compose'; 32; 0,0000; 0,0002 359 | 'Back/lib/Naming.suffix'; 19; 0,0000; 0,0002 360 | 'Back/lib/Syntax.poly_arrow'; 75; 0,0000; 0,0002 361 | 'Back/test/Expr._synth_expr_lookup'; 7; 0,0000; 0,0002 362 | 'Util/lib/Extra.identity'; 89; 0,0000; 0,0002 363 | 'Util/lib/Typeset.get_offset'; 7; 0,0000; 0,0002 364 | 'Back/lib/Naming.sample'; 86; 0,0000; 0,0002 365 | 'Back/test/Simple.proper_simple_arrow'; 74; 0,0000; 0,0002 366 | 'Util/lib/AVL.local_inbalance'; 22; 0,0000; 0,0002 367 | 'Util/lib/Typeset.get_head'; 15; 0,0000; 0,0002 368 | 'Back/test/Mono.proper_simple_mono_var'; 51; 0,0000; 0,0002 369 | 'Util/lib/Extra.identity'; 89; 0,0000; 0,0002 370 | 'Util/lib/Typeset.get_head'; 33; 0,0000; 0,0002 371 | 'Util/lib/AVL.local_rebalance'; 22; 0,0000; 0,0002 372 | 'Util/lib/Extra.List.cons'; 110; 0,0000; 0,0002 373 | 'Back/test/Expr._synth_expr_bind'; 4; 0,0001; 0,0002 374 | 'Util/lib/Typeset._reassociate'; 2; 0,0001; 0,0002 375 | 'Back/test/Mono.exist_equal'; 89; 0,0000; 0,0002 376 | 'Util/lib/Extra.List.fold'; 7; 0,0000; 0,0002 377 | 'Util/lib/AVL.get_height'; 102; 0,0000; 0,0002 378 | 'Util/lib/Typeset.comp'; 45; 0,0000; 0,0002 379 | 'Util/lib/Order.int_compare'; 54; 0,0000; 0,0002 380 | 'Util/lib/Typeset._identities'; 2; 0,0001; 0,0002 381 | 'Util/lib/Extra.List.cons'; 70; 0,0000; 0,0002 382 | 'Util/lib/Typeset.set_lvl'; 20; 0,0000; 0,0002 383 | 'Util/lib/AVL.make_node'; 100; 0,0000; 0,0002 384 | 'Back/lib/Syntax.stmt_defn'; 55; 0,0000; 0,0002 385 | 'Util/lib/Typeset.~$'; 30; 0,0000; 0,0002 386 | 'Back/lib/Syntax.stmt_expr'; 85; 0,0000; 0,0002 387 | 'Util/lib/Typeset.'; 26; 0,0000; 0,0002 388 | 'Util/lib/Env.from_list'; 1; 0,0002; 0,0002 389 | 'Back/lib/Syntax.stmt_expr'; 89; 0,0000; 0,0002 390 | 'Util/lib/Map.get_key'; 108; 0,0000; 0,0002 391 | 'Util/lib/Extra.List.fold'; 14; 0,0000; 0,0002 392 | 'Util/lib/Order.int_compare'; 53; 0,0000; 0,0002 393 | 'Util/lib/Typeset.'; 30; 0,0000; 0,0002 394 | 'Back/lib/Naming.sample'; 61; 0,0000; 0,0002 395 | 'Back/lib/Syntax._equal_stmt'; 2; 0,0001; 0,0002 396 | 'Back/test/Expr._synth_expr_lookup'; 4; 0,0000; 0,0002 397 | 'Util/lib/Typeset.comp'; 78; 0,0000; 0,0002 398 | 'Back/lib/Syntax.poly_arrow'; 40; 0,0000; 0,0002 399 | 'Util/lib/Extra.identity'; 89; 0,0000; 0,0002 400 | 'Back/test/Main.parse'; 3; 0,0001; 0,0002 401 | 'Back/lib/Syntax._equal_stmt'; 3; 0,0001; 0,0002 402 | 'Util/lib/Typeset.make_node'; 67; 0,0000; 0,0002 403 | 'Back/lib/Syntax.stmt_decl'; 55; 0,0000; 0,0002 404 | 'Back/lib/Syntax.label_equal'; 44; 0,0000; 0,0002 405 | 'Util/lib/AVL.fold'; 7; 0,0000; 0,0002 406 | 'Back/lib/Syntax.expr_abs'; 73; 0,0000; 0,0002 407 | 'Util/lib/Map.get_key'; 86; 0,0000; 0,0002 408 | 'Util/lib/Order.int_compare'; 54; 0,0000; 0,0002 409 | 'Util/lib/Typeset.indent'; 10; 0,0000; 0,0002 410 | 'Back/test/Simple.simple_proper'; 43; 0,0000; 0,0002 411 | 'load(front/lib/Native)'; 1; 0,0002; 0,0002 412 | 'Back/test/Mono._bind'; 43; 0,0000; 0,0002 413 | 'Util/lib/Typeset.make_state'; 34; 0,0000; 0,0002 414 | 'Back/lib/Syntax.stmt_expr'; 79; 0,0000; 0,0002 415 | 'Back/lib/Naming.sample_label'; 6; 0,0000; 0,0002 416 | 'Util/lib/Extra.identity'; 89; 0,0000; 0,0002 417 | 'Util/lib/Extra.identity'; 89; 0,0000; 0,0002 418 | 'Util/lib/Map.lookup_unsafe_cont'; 27; 0,0000; 0,0002 419 | 'Back/lib/Naming.sample'; 35; 0,0000; 0,0002 420 | 'Util/lib/Typeset.'; 17; 0,0000; 0,0002 421 | 'Back/lib/Naming.suffix'; 2; 0,0001; 0,0002 422 | 'Util/lib/Extra.identity'; 80; 0,0000; 0,0002 423 | 'Back/lib/Syntax.stmt_expr'; 43; 0,0000; 0,0002 424 | 'Util/lib/Map.values'; 7; 0,0000; 0,0002 425 | 'Util/lib/Typeset.get_lvl'; 20; 0,0000; 0,0002 426 | 'Util/lib/AVL.fold'; 14; 0,0000; 0,0002 427 | 'Util/lib/Extra.identity'; 75; 0,0000; 0,0002 428 | 'Util/lib/Map.values'; 14; 0,0000; 0,0002 429 | 'Util/lib/Typeset.get_head'; 7; 0,0000; 0,0002 430 | 'Util/lib/Typeset.'; 21; 0,0000; 0,0001 431 | 'Back/test/Main.parse'; 3; 0,0000; 0,0001 432 | 'Back/lib/Syntax.expr_var'; 50; 0,0000; 0,0001 433 | 'Util/lib/Typeset.make_node'; 36; 0,0000; 0,0001 434 | 'Back/lib/Syntax.expr_var'; 53; 0,0000; 0,0001 435 | 'Util/lib/Map.get_key'; 53; 0,0000; 0,0001 436 | 'Util/lib/Typeset.get_head'; 8; 0,0000; 0,0001 437 | 'Back/test/Expr.arbitrary_typed_expr'; 5; 0,0000; 0,0001 438 | 'Back/test/Mono.simple_mono_proper'; 43; 0,0000; 0,0001 439 | 'Back/test/Mono.proper_simple_mono_equal'; 46; 0,0000; 0,0001 440 | 'Util/lib/Extra.List.cons'; 61; 0,0000; 0,0001 441 | 'Back/lib/Naming.sample_label'; 2; 0,0001; 0,0001 442 | 'Util/lib/Typeset.inc_pos'; 282; 0,0000; 0,0001 443 | 'Util/lib/Extra.swap'; 14; 0,0000; 0,0001 444 | 'Back/test/Main.parse'; 2; 0,0001; 0,0001 445 | 'Back/test/Mono.proper_simple_mono_equal'; 21; 0,0000; 0,0001 446 | 'Back/test/Main.parse'; 3; 0,0000; 0,0001 447 | 'Back/test/Mono.proper_simple_mono_var'; 43; 0,0000; 0,0001 448 | 'Util/lib/Env.lookup'; 5; 0,0000; 0,0001 449 | 'Util/lib/Typeset.comp'; 54; 0,0000; 0,0001 450 | 'Util/lib/Map.make_bind'; 34; 0,0000; 0,0001 451 | 'Back/lib/Naming.make_gen'; 14; 0,0000; 0,0001 452 | 'Back/test/Mono.proper_simple_mono_equal'; 16; 0,0000; 0,0001 453 | 'Util/lib/AVL.get_height'; 54; 0,0000; 0,0001 454 | 'Back/lib/Syntax.stmt_equal'; 6; 0,0000; 0,0001 455 | 'Back/lib/Syntax._equal_stmt'; 1; 0,0001; 0,0001 456 | 'Util/lib/Typeset.comp'; 56; 0,0000; 0,0001 457 | 'Util/lib/Typeset.get_offset'; 5; 0,0000; 0,0001 458 | 'Back/test/Mono.proper_simple_mono_equal'; 41; 0,0000; 0,0001 459 | 'Util/lib/Typeset.text'; 58; 0,0000; 0,0001 460 | 'Util/lib/Map.insert_cont'; 54; 0,0000; 0,0001 461 | 'Back/lib/Print._wrap'; 2; 0,0001; 0,0001 462 | 'Back/lib/Syntax.poly_param'; 44; 0,0000; 0,0001 463 | 'Util/lib/AVL.to_list'; 7; 0,0000; 0,0001 464 | 'Util/lib/AVL.get_height'; 46; 0,0000; 0,0001 465 | 'Util/lib/AVL.to_list'; 14; 0,0000; 0,0001 466 | 'Util/lib/Typeset.get_head'; 4; 0,0000; 0,0001 467 | 'Util/lib/Typeset.nest'; 45; 0,0000; 0,0001 468 | 'Back/lib/Syntax.stmt_defn'; 52; 0,0000; 0,0001 469 | 'Util/lib/AVL.get_height'; 44; 0,0000; 0,0001 470 | 'Back/test/Expr.arbitrary_typed_stmt'; 1; 0,0001; 0,0001 471 | 'Back/lib/Naming.sample'; 34; 0,0000; 0,0001 472 | 'Util/lib/Typeset.seq'; 45; 0,0000; 0,0001 473 | 'Back/lib/Syntax.stmt_defn'; 3; 0,0000; 0,0001 474 | 'Util/lib/Typeset.comp'; 48; 0,0000; 0,0001 475 | 'Util/lib/Typeset.seq'; 40; 0,0000; 0,0001 476 | 'Back/lib/Syntax.expr_var'; 40; 0,0000; 0,0001 477 | 'Back/lib/Naming.suffix'; 7; 0,0000; 0,0001 478 | 'Back/lib/Syntax.expr_var'; 45; 0,0000; 0,0001 479 | 'Util/lib/AVL.get_count'; 22; 0,0000; 0,0001 480 | 'Back/test/Mono.proper_simple_mono_var'; 40; 0,0000; 0,0001 481 | 'Util/lib/Map.values'; 4; 0,0000; 0,0001 482 | 'Util/lib/Map.lookup_unsafe_cont'; 16; 0,0000; 0,0001 483 | 'Util/lib/Typeset.'; 10; 0,0000; 0,0001 484 | 'Util/lib/Typeset.text'; 48; 0,0000; 0,0001 485 | 'Back/test/Main.parse'; 2; 0,0000; 0,0001 486 | 'Util/lib/Typeset.set_pos'; 18; 0,0000; 0,0001 487 | 'Back/lib/Naming.suffix'; 6; 0,0000; 0,0001 488 | 'Back/test/Mono.proper_simple_mono_equal'; 13; 0,0000; 0,0001 489 | 'Util/lib/Map.make_bind'; 44; 0,0000; 0,0001 490 | 'Util/lib/Extra.identity'; 36; 0,0000; 0,0001 491 | 'Util/lib/AVL.make_node'; 44; 0,0000; 0,0001 492 | 'Util/lib/Typeset.comp'; 40; 0,0000; 0,0001 493 | 'Util/lib/Typeset.render'; 3; 0,0000; 0,0001 494 | 'Back/lib/Syntax.poly_arrow'; 37; 0,0000; 0,0001 495 | 'Util/lib/Env.bind'; 17; 0,0000; 0,0001 496 | 'Util/lib/Typeset.get_head'; 3; 0,0000; 0,0001 497 | 'Util/lib/AVL.get_height'; 33; 0,0000; 0,0001 498 | 'Util/lib/Extra.List.map'; 14; 0,0000; 0,0001 499 | 'Util/lib/Typeset.comp'; 35; 0,0000; 0,0001 500 | 'Back/lib/Naming.sample'; 19; 0,0000; 0,0001 501 | 'Util/lib/Typeset.comp'; 38; 0,0000; 0,0001 502 | 'Back/lib/Syntax.expr_app'; 11; 0,0000; 0,0001 503 | 'Util/lib/Typeset.nest'; 38; 0,0000; 0,0001 504 | 'Back/lib/Syntax.poly_arrow'; 46; 0,0000; 0,0001 505 | 'Back/lib/Syntax._equal_stmt'; 3; 0,0000; 0,0001 506 | 'Util/lib/Typeset.text'; 40; 0,0000; 0,0001 507 | 'Util/lib/Extra.identity'; 36; 0,0000; 0,0001 508 | 'Back/test/Main.parse'; 2; 0,0000; 0,0001 509 | 'Util/lib/Map.make_bind'; 30; 0,0000; 0,0001 510 | 'Back/lib/Syntax.poly_param'; 42; 0,0000; 0,0001 511 | 'Util/lib/Extra.identity'; 36; 0,0000; 0,0001 512 | 'Util/lib/Typeset.get_pos'; 16; 0,0000; 0,0001 513 | 'Back/lib/Syntax.label_equal'; 15; 0,0000; 0,0001 514 | 'Back/lib/Naming.make_ctx'; 7; 0,0000; 0,0001 515 | 'Util/lib/Typeset.comp'; 30; 0,0000; 0,0001 516 | 'Back/lib/Syntax.label_equal'; 10; 0,0000; 0,0001 517 | 'Back/lib/Syntax.expr_var'; 13; 0,0000; 0,0001 518 | 'Back/lib/Syntax.expr_abs'; 44; 0,0000; 0,0001 519 | 'Util/lib/AVL.get_height'; 34; 0,0000; 0,0001 520 | 'Back/lib/Syntax.stmt_expr'; 46; 0,0000; 0,0001 521 | 'Back/lib/Syntax.stmt_decl'; 28; 0,0000; 0,0001 522 | 'Util/lib/Extra.List.map'; 7; 0,0000; 0,0001 523 | 'Util/lib/Env.lookup'; 2; 0,0000; 0,0001 524 | 'Back/lib/Syntax.expr_var'; 9; 0,0000; 0,0001 525 | 'Util/lib/Map.make_bind'; 31; 0,0000; 0,0001 526 | 'Util/lib/Typeset.get_pos'; 13; 0,0000; 0,0001 527 | 'Util/lib/Typeset.text'; 30; 0,0000; 0,0001 528 | 'Back/lib/Naming.sample'; 19; 0,0000; 0,0001 529 | 'Util/lib/Typeset.render'; 2; 0,0000; 0,0001 530 | 'Util/lib/Env.bind'; 17; 0,0000; 0,0001 531 | 'Util/lib/Map.insert_cont'; 32; 0,0000; 0,0001 532 | 'Util/lib/Extra.List.cons'; 27; 0,0000; 0,0001 533 | 'Util/lib/Typeset.make_edge'; 27; 0,0000; 0,0001 534 | 'Util/lib/Typeset.get_pos'; 9; 0,0000; 0,0001 535 | 'Back/lib/Syntax.expr_var'; 38; 0,0000; 0,0001 536 | 'Back/lib/Syntax.label_equal'; 13; 0,0000; 0,0001 537 | 'Util/lib/AVL.make_node'; 23; 0,0000; 0,0001 538 | 'Util/lib/AVL.get_height'; 27; 0,0000; 0,0001 539 | 'Back/lib/Syntax.stmt_defn'; 37; 0,0000; 0,0001 540 | 'Back/test/Main.parse'; 1; 0,0001; 0,0001 541 | 'Util/lib/Map.get_key'; 26; 0,0000; 0,0001 542 | 'Util/lib/Typeset.comp'; 26; 0,0000; 0,0001 543 | 'Back/lib/Naming.suffix'; 6; 0,0000; 0,0001 544 | 'Util/lib/Typeset.get_lvl'; 92; 0,0000; 0,0001 545 | 'Util/lib/Typeset.get_break'; 3; 0,0000; 0,0001 546 | 'Util/lib/Typeset.set_break'; 25; 0,0000; 0,0001 547 | 'Util/lib/Typeset.compile'; 2; 0,0000; 0,0001 548 | 'Util/lib/AVL.to_list'; 4; 0,0000; 0,0000 549 | 'Util/lib/Extra.List.fold'; 4; 0,0000; 0,0000 550 | 'Back/lib/Print._pass'; 11; 0,0000; 0,0000 551 | 'Util/lib/Typeset.set_lvl'; 10; 0,0000; 0,0000 552 | 'Util/lib/Order.int_compare'; 13; 0,0000; 0,0000 553 | 'Back/lib/Syntax.stmt_equal'; 3; 0,0000; 0,0000 554 | 'Util/lib/Typeset.get_head'; 9; 0,0000; 0,0000 555 | 'Back/lib/Syntax._equal_stmt'; 2; 0,0000; 0,0000 556 | 'Back/lib/Syntax.stmt_equal'; 3; 0,0000; 0,0000 557 | 'Util/lib/Typeset.make_node'; 24; 0,0000; 0,0000 558 | 'Util/lib/Typeset.get_pos'; 13; 0,0000; 0,0000 559 | 'Util/lib/Typeset.line'; 21; 0,0000; 0,0000 560 | 'Util/lib/Typeset.indent'; 46; 0,0000; 0,0000 561 | 'Util/lib/Extra.List.cons'; 16; 0,0000; 0,0000 562 | 'Util/lib/Typeset.make_node'; 18; 0,0000; 0,0000 563 | 'Util/lib/Extra.identity'; 18; 0,0000; 0,0000 564 | 'Util/lib/Extra.List.map'; 4; 0,0000; 0,0000 565 | 'Util/lib/Extra.List.fold'; 1; 0,0000; 0,0000 566 | 'Back/test/Mono.proper_simple_mono_var'; 7; 0,0000; 0,0000 567 | 'Back/lib/Naming.suffix'; 4; 0,0000; 0,0000 568 | 'Util/lib/Typeset.nest'; 19; 0,0000; 0,0000 569 | 'Util/lib/Typeset.indent'; 5; 0,0000; 0,0000 570 | 'Util/lib/Typeset.indent'; 7; 0,0000; 0,0000 571 | 'Back/lib/Syntax.label_equal'; 7; 0,0000; 0,0000 572 | 'Util/lib/Typeset.nest'; 20; 0,0000; 0,0000 573 | 'Util/lib/Typeset.get_lvl'; 10; 0,0000; 0,0000 574 | 'Back/test/Mono.proper_simple_mono_var'; 17; 0,0000; 0,0000 575 | 'Back/lib/Naming.suffix'; 4; 0,0000; 0,0000 576 | 'Util/lib/Typeset.get_pos'; 10; 0,0000; 0,0000 577 | 'Util/lib/Extra.identity'; 21; 0,0000; 0,0000 578 | 'Util/lib/AVL.get_count'; 18; 0,0000; 0,0000 579 | 'Util/lib/Typeset.seq'; 19; 0,0000; 0,0000 580 | 'Util/lib/Extra.identity'; 18; 0,0000; 0,0000 581 | 'Util/lib/Typeset.set_pos'; 34; 0,0000; 0,0000 582 | 'Util/lib/Typeset.comp'; 17; 0,0000; 0,0000 583 | 'Util/lib/Typeset.set_head'; 82; 0,0000; 0,0000 584 | 'Back/lib/Naming.sample'; 7; 0,0000; 0,0000 585 | 'Back/lib/Syntax.stmt_equal'; 2; 0,0000; 0,0000 586 | 'Back/lib/Syntax.stmt_equal'; 3; 0,0000; 0,0000 587 | 'Util/lib/Extra.swap'; 2; 0,0000; 0,0000 588 | 'Util/lib/Env.lookup'; 4; 0,0000; 0,0000 589 | 'Util/lib/AVL.local_inbalance'; 2; 0,0000; 0,0000 590 | 'Back/lib/Syntax.stmt_expr'; 16; 0,0000; 0,0000 591 | 'Util/lib/Typeset.set_lvl'; 92; 0,0000; 0,0000 592 | 'Back/lib/Syntax.stmt_decl'; 23; 0,0000; 0,0000 593 | 'Util/lib/Typeset.reset'; 11; 0,0000; 0,0000 594 | 'Util/lib/Typeset.~$'; 4; 0,0000; 0,0000 595 | 'Back/lib/Naming.sample'; 9; 0,0000; 0,0000 596 | 'Util/lib/Typeset.text'; 17; 0,0000; 0,0000 597 | 'Util/lib/Typeset.set_lvl'; 14; 0,0000; 0,0000 598 | 'Util/lib/Typeset.line'; 16; 0,0000; 0,0000 599 | 'Util/lib/Typeset.reset'; 34; 0,0000; 0,0000 600 | 'Back/lib/Syntax.label_equal'; 6; 0,0000; 0,0000 601 | 'Util/lib/Typeset.make_edge'; 16; 0,0000; 0,0000 602 | 'Util/lib/Typeset.grp'; 14; 0,0000; 0,0000 603 | 'Util/lib/Typeset.indent'; 47; 0,0000; 0,0000 604 | 'Util/lib/Typeset.get_pos'; 5; 0,0000; 0,0000 605 | 'Util/lib/AVL.make_node'; 14; 0,0000; 0,0000 606 | 'Back/lib/Syntax.expr_app'; 8; 0,0000; 0,0000 607 | 'Back/lib/Syntax.poly_param'; 12; 0,0000; 0,0000 608 | 'Back/lib/Syntax.stmt_expr'; 15; 0,0000; 0,0000 609 | 'Util/lib/Typeset.get_pos'; 6; 0,0000; 0,0000 610 | 'Back/lib/Syntax.stmt_defn'; 13; 0,0000; 0,0000 611 | 'Util/lib/Typeset.'; 4; 0,0000; 0,0000 612 | 'Util/lib/Typeset.get_offset'; 47; 0,0000; 0,0000 613 | 'Util/lib/Typeset.get_lvl'; 14; 0,0000; 0,0000 614 | 'Back/lib/Syntax.expr_abs'; 13; 0,0000; 0,0000 615 | 'Util/lib/Env.lookup'; 1; 0,0000; 0,0000 616 | 'Util/lib/Typeset.seq'; 14; 0,0000; 0,0000 617 | 'Util/lib/AVL.local_rebalance'; 2; 0,0000; 0,0000 618 | 'Util/lib/Typeset.set_lvl'; 94; 0,0000; 0,0000 619 | 'Util/lib/AVL.make_null'; 12; 0,0000; 0,0000 620 | 'Back/lib/Syntax.poly_arrow'; 13; 0,0000; 0,0000 621 | 'Util/lib/AVL.get_height'; 13; 0,0000; 0,0000 622 | 'Util/lib/Typeset.line'; 10; 0,0000; 0,0000 623 | 'Util/lib/Extra.identity'; 14; 0,0000; 0,0000 624 | 'Util/lib/Env.lookup'; 1; 0,0000; 0,0000 625 | 'Util/lib/Typeset.set_head'; 62; 0,0000; 0,0000 626 | 'Back/lib/Syntax.stmt_equal'; 2; 0,0000; 0,0000 627 | 'Util/lib/Typeset.set_break'; 34; 0,0000; 0,0000 628 | 'Back/lib/Syntax.stmt_equal'; 2; 0,0000; 0,0000 629 | 'load(back/test/Mono)'; 1; 0,0000; 0,0000 630 | 'Util/lib/Typeset.get_lvl'; 115; 0,0000; 0,0000 631 | 'Util/lib/Order.int_compare'; 7; 0,0000; 0,0000 632 | 'Back/lib/Syntax.expr_abs'; 12; 0,0000; 0,0000 633 | 'Back/lib/Naming.sample'; 6; 0,0000; 0,0000 634 | 'Back/lib/Syntax.stmt_expr'; 12; 0,0000; 0,0000 635 | 'Util/lib/Extra.identity'; 10; 0,0000; 0,0000 636 | 'Back/test/Poly.arbitrary_poly'; 1; 0,0000; 0,0000 637 | 'Back/lib/Syntax.expr_var'; 10; 0,0000; 0,0000 638 | 'Back/lib/Naming.sample'; 6; 0,0000; 0,0000 639 | 'Back/lib/Naming.make_ctx'; 1; 0,0000; 0,0000 640 | 'Back/lib/Syntax.stmt_expr'; 4; 0,0000; 0,0000 641 | 'Util/lib/AVL.get_height'; 9; 0,0000; 0,0000 642 | 'Back/test/Mono.proper_simple_mono_var'; 4; 0,0000; 0,0000 643 | 'Back/lib/Syntax.stmt_expr'; 9; 0,0000; 0,0000 644 | 'Back/lib/Naming.suffix'; 2; 0,0000; 0,0000 645 | 'Back/lib/Syntax.stmt_defn'; 5; 0,0000; 0,0000 646 | 'Back/lib/Syntax.stmt_equal'; 1; 0,0000; 0,0000 647 | 'Back/lib/Syntax.expr_abs'; 10; 0,0000; 0,0000 648 | 'Util/lib/Extra.compose'; 1; 0,0000; 0,0000 649 | 'Back/lib/Print._pass'; 2; 0,0000; 0,0000 650 | 'Back/lib/Syntax.expr_var'; 4; 0,0000; 0,0000 651 | 'Back/lib/Syntax.stmt_decl'; 3; 0,0000; 0,0000 652 | 'Back/test/Mono.proper_simple_mono_equal'; 6; 0,0000; 0,0000 653 | 'Util/lib/Typeset.make_node'; 8; 0,0000; 0,0000 654 | 'Util/lib/Typeset.grp'; 9; 0,0000; 0,0000 655 | 'Back/lib/Syntax.expr_app'; 11; 0,0000; 0,0000 656 | 'Util/lib/Extra.List.cons'; 6; 0,0000; 0,0000 657 | 'Util/lib/Extra.List.cons'; 8; 0,0000; 0,0000 658 | 'Back/lib/Syntax.expr_abs'; 7; 0,0000; 0,0000 659 | 'Back/lib/Naming.sample'; 6; 0,0000; 0,0000 660 | 'Util/lib/Map.make_bind'; 7; 0,0000; 0,0000 661 | 'Util/lib/AVL.make_null'; 6; 0,0000; 0,0000 662 | 'Back/lib/Syntax.poly_param'; 3; 0,0000; 0,0000 663 | 'Util/lib/AVL.get_height'; 8; 0,0000; 0,0000 664 | 'Back/lib/Syntax.stmt_decl'; 7; 0,0000; 0,0000 665 | 'Back/lib/Syntax.expr_var'; 5; 0,0000; 0,0000 666 | 'Util/lib/Extra.identity'; 7; 0,0000; 0,0000 667 | 'Back/lib/Syntax.stmt_defn'; 8; 0,0000; 0,0000 668 | 'Back/lib/Syntax.expr_var'; 6; 0,0000; 0,0000 669 | 'Back/lib/Syntax.stmt_defn'; 7; 0,0000; 0,0000 670 | 'Back/test/Mono.proper_simple_mono_equal'; 4; 0,0000; 0,0000 671 | 'Util/lib/Map.get_key'; 7; 0,0000; 0,0000 672 | 'Util/lib/Extra.identity'; 4; 0,0000; 0,0000 673 | 'Back/lib/Syntax.poly_arrow'; 2; 0,0000; 0,0000 674 | 'Util/lib/Typeset.comp'; 4; 0,0000; 0,0000 675 | 'Back/lib/Naming.sample'; 2; 0,0000; 0,0000 676 | 'Util/lib/Typeset.get_pos'; 2; 0,0000; 0,0000 677 | 'Back/test/Mono.proper_simple_mono_var'; 5; 0,0000; 0,0000 678 | 'Back/lib/Syntax.expr_var'; 3; 0,0000; 0,0000 679 | 'Util/lib/Typeset.make_node'; 4; 0,0000; 0,0000 680 | 'Util/lib/AVL.get_count'; 6; 0,0000; 0,0000 681 | 'Util/lib/Extra.identity'; 4; 0,0000; 0,0000 682 | 'Util/lib/AVL.get_height'; 6; 0,0000; 0,0000 683 | 'Util/lib/AVL.get_height'; 4; 0,0000; 0,0000 684 | 'Util/lib/Map.make_bind'; 3; 0,0000; 0,0000 685 | 'load(back/lib/Naming)'; 1; 0,0000; 0,0000 686 | 'Back/test/Mono.proper_simple_mono_var'; 2; 0,0000; 0,0000 687 | 'Back/lib/Naming.sample'; 4; 0,0000; 0,0000 688 | 'Back/lib/Syntax.expr_var'; 2; 0,0000; 0,0000 689 | 'Back/lib/Syntax.expr_var'; 5; 0,0000; 0,0000 690 | 'Util/lib/AVL.get_count'; 4; 0,0000; 0,0000 691 | 'Util/lib/Typeset.comp'; 4; 0,0000; 0,0000 692 | 'Back/lib/Syntax.stmt_defn'; 4; 0,0000; 0,0000 693 | 'Util/lib/Extra.identity'; 5; 0,0000; 0,0000 694 | 'Back/test/Expr.gen_typed_expr'; 5; 0,0000; 0,0000 695 | 'Util/lib/Typeset.comp'; 2; 0,0000; 0,0000 696 | 'Util/lib/AVL.make_node'; 2; 0,0000; 0,0000 697 | 'Back/lib/Naming.sample'; 4; 0,0000; 0,0000 698 | 'Util/lib/AVL.make_null'; 4; 0,0000; 0,0000 699 | 'Back/lib/Syntax.expr_app'; 4; 0,0000; 0,0000 700 | 'Util/lib/Env.bind'; 4; 0,0000; 0,0000 701 | 'Util/lib/Typeset.make_state'; 3; 0,0000; 0,0000 702 | 'Back/lib/Naming.sample'; 2; 0,0000; 0,0000 703 | 'Back/lib/Syntax.stmt_expr'; 4; 0,0000; 0,0000 704 | 'Util/lib/Extra.identity'; 4; 0,0000; 0,0000 705 | 'Util/lib/Typeset.get_pos'; 2; 0,0000; 0,0000 706 | 'Util/lib/Typeset.line'; 4; 0,0000; 0,0000 707 | 'load(util/lib/Extra)'; 1; 0,0000; 0,0000 708 | 'Util/lib/Typeset.make_node'; 4; 0,0000; 0,0000 709 | 'Util/lib/Map.get_key'; 2; 0,0000; 0,0000 710 | 'Util/lib/Order.int_compare'; 2; 0,0000; 0,0000 711 | 'Back/lib/Syntax.expr_var'; 2; 0,0000; 0,0000 712 | 'Util/lib/Typeset.get_pos'; 2; 0,0000; 0,0000 713 | 'Util/lib/Extra.identity'; 4; 0,0000; 0,0000 714 | 'Back/lib/Syntax.expr_app'; 3; 0,0000; 0,0000 715 | 'Back/lib/Syntax.poly_param'; 3; 0,0000; 0,0000 716 | 'Back/lib/Syntax.stmt_decl'; 3; 0,0000; 0,0000 717 | 'Back/lib/Syntax.expr_var'; 3; 0,0000; 0,0000 718 | 'Back/lib/Syntax.expr_var'; 3; 0,0000; 0,0000 719 | 'Back/lib/Syntax.expr_app'; 2; 0,0000; 0,0000 720 | 'Util/lib/Typeset.text'; 4; 0,0000; 0,0000 721 | 'Back/lib/Syntax.stmt_decl'; 3; 0,0000; 0,0000 722 | 'Back/lib/Syntax.expr_var'; 2; 0,0000; 0,0000 723 | 'Util/lib/Map.make_bind'; 2; 0,0000; 0,0000 724 | 'Util/lib/Typeset.make_state'; 2; 0,0000; 0,0000 725 | 'Back/lib/Syntax.expr_abs'; 3; 0,0000; 0,0000 726 | 'Back/lib/Syntax.expr_var'; 2; 0,0000; 0,0000 727 | 'Back/lib/Syntax.expr_var'; 2; 0,0000; 0,0000 728 | 'Back/lib/Syntax.expr_var'; 2; 0,0000; 0,0000 729 | 'load(back/test/Simple)'; 1; 0,0000; 0,0000 730 | 'Util/lib/Extra.identity'; 2; 0,0000; 0,0000 731 | 'Util/lib/Env.bind'; 1; 0,0000; 0,0000 732 | 'Back/lib/Naming.make_gen'; 2; 0,0000; 0,0000 733 | 'Util/lib/Typeset.get_pos'; 1; 0,0000; 0,0000 734 | 'Back/lib/Syntax.stmt_decl'; 2; 0,0000; 0,0000 735 | 'load(front/lib/Parser)'; 1; 0,0000; 0,0000 736 | 'Util/lib/AVL.make_node'; 2; 0,0000; 0,0000 737 | 'Back/lib/Syntax.poly_param'; 2; 0,0000; 0,0000 738 | 'load(util/lib/Option)'; 1; 0,0000; 0,0000 739 | 'Back/lib/Syntax.poly_arrow'; 2; 0,0000; 0,0000 740 | 'Back/lib/Syntax.expr_abs'; 1; 0,0000; 0,0000 741 | 'Back/lib/Naming.sample'; 2; 0,0000; 0,0000 742 | 'Back/lib/Syntax.poly_arrow'; 1; 0,0000; 0,0000 743 | 'Util/lib/Typeset.grp'; 2; 0,0000; 0,0000 744 | 'Back/lib/Syntax.expr_app'; 1; 0,0000; 0,0000 745 | 'Util/lib/Extra.identity'; 1; 0,0000; 0,0000 746 | 'load(util/lib/Set)'; 1; 0,0000; 0,0000 747 | 'load(front/lib/Lexer)'; 1; 0,0000; 0,0000 748 | 'load(front/lib/Interp)'; 1; 0,0000; 0,0000 749 | 'Util/lib/Env.bind'; 1; 0,0000; 0,0000 750 | 'load(util/lib/Env)'; 1; 0,0000; 0,0000 751 | 'Back/test/Expr.gen_typed_stmt'; 1; 0,0000; 0,0000 752 | 'load(back/test/Expr)'; 1; 0,0000; 0,0000 753 | 'load(util/lib/Map)'; 1; 0,0000; 0,0000 754 | 'load(util/lib/AVL)'; 1; 0,0000; 0,0000 755 | 'load(back/lib/Context)'; 1; 0,0000; 0,0000 756 | 'load(back/lib/Check)'; 1; 0,0000; 0,0000 757 | 'load(back/lib/Syntax)'; 1; 0,0000; 0,0000 758 | 'load(util/lib/Typeset)'; 1; 0,0000; 0,0000 759 | 'load(back/test/Poly)'; 1; 0,0000; 0,0000 760 | 'load(back/lib/Print)'; 1; 0,0000; 0,0000 761 | 'load(util/lib/Infix)'; 1; 0,0000; 0,0000 762 | 'Back/lib/Context.make'; 1; 0,0000; 0,0000 763 | 'Back/lib/Syntax.poly_arrow'; 1; 0,0000; 0,0000 764 | 'Back/test/Poly.gen_poly'; 1; 0,0000; 0,0000 765 | 'load(util/lib/Order)'; 1; 0,0000; 0,0000 766 | 'load(util/lib/Result)'; 1; 0,0000; 0,0000 767 | 'Back/lib/Syntax.expr_var'; 1; 0,0000; 0,0000 768 | 769 | -------------------------------------------------------------------------------- /misc/profile_extract.py: -------------------------------------------------------------------------------- 1 | import os 2 | import json 3 | 4 | def load_json(path): 5 | with open(path, "r") as file: 6 | return json.load(file) 7 | 8 | def error(cli, msg): 9 | print(cli) 10 | print("Error: %s" % msg) 11 | return 1 12 | 13 | def validate(data): 14 | if not isinstance(data, dict): return False 15 | if len(data) != 2: return False 16 | if "nodes" not in data: return False 17 | nodes = data["nodes"] 18 | if not isinstance(nodes, list): return False 19 | if len(nodes) == 0: return True 20 | node = nodes[0] 21 | if not isinstance(node, dict): return False 22 | if len(node) != 11: return False 23 | if "id" not in node: return False 24 | if "kind" not in node: return False 25 | if "landmark_id" not in node: return False 26 | if "name" not in node: return False 27 | if "location" not in node: return False 28 | if "calls" not in node: return False 29 | if "time" not in node: return False 30 | if "sons" not in node: return False 31 | if "sys_time" not in node: return False 32 | if "allocated_bytes" not in node: return False 33 | if "distrib" not in node: return False 34 | return True 35 | 36 | def process(data): 37 | nodes = data["nodes"] 38 | node_count = len(nodes) 39 | times = [node["time"] for node in nodes] 40 | result = times.copy() 41 | for node in nodes: 42 | node_id = node["id"] 43 | for child_id in node["sons"]: 44 | result[node_id] -= times[child_id] 45 | return nodes[0]["time"], [ { 46 | "name": node["name"], 47 | "calls": node["calls"], 48 | "time": result[node["id"]] 49 | } for node in nodes] 50 | 51 | def report(total_time, result): 52 | def _time(item): return item["time"] 53 | def _row(node): 54 | name = node["name"] 55 | calls = node["calls"] 56 | time_total = node["time"] 57 | time_per_call = ((time_total / max(calls, 1.0)) / total_time) * 100.0 58 | time_total_percent = (time_total / total_time) * 100.0 59 | return ( 60 | name, 61 | str(calls), 62 | ("%.4f" % time_per_call).replace('.', ','), 63 | ("%.4f" % time_total_percent).replace('.', ',') 64 | ) 65 | result.sort(key=_time, reverse=True) 66 | csv = "'Name'; 'Calls'; 'Time Per Call'; 'Time Total'\n" 67 | for node in result: 68 | csv += "'%s'; %s; %s; %s\n" % _row(node) 69 | print(csv) 70 | 71 | def main(args): 72 | cli = args[0] 73 | if len(args) != 2: 74 | return error(cli, "Expected an argument!") 75 | 76 | # Parse file path argument 77 | path = args[1] 78 | if not os.path.exists(path): 79 | return error(cli, "Argument is not a file path!") 80 | 81 | # Load profile data 82 | data = load_json(path) 83 | if not validate(data): 84 | return error(cli, "File is not a valid Landmarks profile!") 85 | 86 | # Process profile data 87 | total_time, result = process(data) 88 | 89 | # Print results 90 | report(total_time, result) 91 | 92 | # Done 93 | return 0 94 | 95 | if __name__ == '__main__': 96 | import sys 97 | sys.exit(main(sys.argv)) 98 | -------------------------------------------------------------------------------- /repl/bin/Main.ml: -------------------------------------------------------------------------------- 1 | open Typeset 2 | open Util 3 | open Extra 4 | open Back 5 | open Front 6 | 7 | let print layout = 8 | Typeset.compile layout @@ fun doc -> 9 | Typeset.render doc 2 80 @@ fun msg -> 10 | print_endline msg 11 | 12 | let error msg = 13 | print (seq (~$"🔥 Error:" <+> grp msg) null) 14 | 15 | let success value poly = 16 | let ctx = Naming.make_ctx () in 17 | Check.generalize poly @@ fun poly1 -> 18 | Value.print_value value @@ fun value1 -> 19 | Print.layout_poly ctx poly1 @@ fun poly2 -> 20 | print (~$value1 <+> ~$":" <+> poly2 null) 21 | 22 | let report_context tctx = 23 | let ctx = Naming.make_ctx () in 24 | Context.get_venv tctx @@ fun venv -> 25 | Env.fold 26 | (fun return -> return ~$"") 27 | (fun name poly visit_env return -> 28 | Print.layout_poly ctx poly @@ fun poly1 -> 29 | visit_env @@ fun binds -> 30 | return (~$name <+> ~$":" <+> poly1 binds)) 31 | venv print 32 | 33 | let parse parser tokens = 34 | try 35 | let result = parser Lexer.token tokens in 36 | Result.make_value result 37 | with 38 | | Lexer.Error msg -> 39 | Result.make_error (~$"Lexing error:" <+> ~$msg) 40 | | Parser.Error -> 41 | Result.make_error ~$"Parsing error" 42 | 43 | let parse_file path = 44 | try 45 | let file_in = open_in path in 46 | let tokens = Lexing.from_channel file_in in 47 | let result = parse Parser.file tokens in 48 | close_in file_in; 49 | result 50 | with Sys_error msg -> 51 | Result.make_error ~$msg 52 | 53 | let parse_input input = 54 | parse Parser.input (Lexing.from_string input) 55 | 56 | let options = [] 57 | 58 | let files = ref [] 59 | let anonymous path = 60 | files := path :: !files 61 | 62 | let interp_input tctx env input = 63 | match parse_input input with 64 | | Result.Error msg -> error msg 65 | | Result.Value stmt -> 66 | Valid.check_stmt stmt tctx error @@ fun () -> 67 | Check.synth_stmt stmt tctx error @@ fun result_t -> 68 | Interp.eval_stmt stmt env @@ fun result_v -> 69 | success result_v result_t 70 | 71 | let interp_file tctx env path = 72 | match parse_file path with 73 | | Result.Error msg -> error msg; exit 1 74 | | Result.Value prog -> 75 | Valid.check_prog prog tctx error @@ fun () -> 76 | Check.check_prog prog tctx error @@ fun tctx1 -> 77 | Interp.eval_prog prog env @@ fun () -> 78 | report_context tctx1 79 | 80 | let interp_files tctx env paths = 81 | List.iter (interp_file tctx env) paths; 82 | exit 0 83 | 84 | let read_input () = 85 | let _complete input = 86 | let length = String.length input in 87 | if length < 2 then false else 88 | if input.[length - 1] <> ';' then false else 89 | if input.[length - 2] <> ';' then false else 90 | true 91 | in 92 | let prompt = "▶ " in 93 | let prompt_more = "⋮ " in 94 | print_string prompt; 95 | let input = ref (read_line ()) in 96 | while not (_complete !input) do 97 | print_string prompt_more; 98 | input := !input ^ (read_line ()) 99 | done; 100 | let result = !input in 101 | String.sub result 0 (String.length result - 2) 102 | 103 | let repl tctx env = 104 | while true do 105 | let input = read_input () in 106 | if input = "exit" then exit 0 else 107 | if input = "context" then report_context tctx else 108 | interp_input tctx env input 109 | done 110 | 111 | let usage = 112 | "Usage: BHRP [file] ..." 113 | 114 | let () = 115 | Sys.catch_break true; 116 | Arg.parse options anonymous usage; 117 | let _files = !files in 118 | if (List.length _files) <> 0 119 | then interp_files Native.tenv Native.venv !files 120 | else repl Native.tenv Native.venv 121 | -------------------------------------------------------------------------------- /repl/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name Main) 3 | (libraries 4 | typeset 5 | bhrp.back 6 | bhrp.front)) 7 | 8 | (install 9 | (section bin) 10 | (files (Main.exe as bhrp.repl))) 11 | -------------------------------------------------------------------------------- /shared/lib/Expr.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Extra 3 | open Back 4 | open Syntax 5 | open Mono 6 | open Poly 7 | 8 | (* Typed Expr *) 9 | let _synth_expr_empty = [] 10 | 11 | let _synth_expr_bind simple expr env return = 12 | return ((simple, expr) :: env) 13 | 14 | let _synth_expr_lookup simple env fail return = 15 | let rec _visit env result = 16 | match env with 17 | | [] -> 18 | if (List.length result) <= 0 19 | then fail () 20 | else return result 21 | | (key, expr) :: env1 -> 22 | if proper_simple_mono_equal simple key 23 | then _visit env1 (expr :: result) 24 | else _visit env1 result 25 | in 26 | _visit env [] 27 | 28 | let rec _synth_expr n ctx env simple_mono = 29 | let open QCheck.Gen in 30 | match simple_mono with 31 | | SMNothing -> return expr_undefined 32 | | SMProper proper_simple_mono -> 33 | _synth_expr_proper n ctx env proper_simple_mono 34 | and _synth_expr_proper n ctx env proper_simple_mono = 35 | match proper_simple_mono with 36 | | SMUnit -> _synth_expr_unit n ctx env 37 | | SMVar exist -> _synth_expr_var n ctx env exist 38 | | SMArrow (dom, codom) -> _synth_expr_arrow n ctx env dom codom 39 | and _synth_expr_unit n ctx env = 40 | let open QCheck.Gen in 41 | if n = 0 then _synth_expr_unit_term env else 42 | frequency 43 | [ 1, _synth_expr_unit_term env 44 | ; 2, _synth_expr_redex (n / 2) ctx env proper_simple_mono_unit 45 | ] 46 | and _synth_expr_var n ctx env exist = 47 | let open QCheck.Gen in 48 | _synth_expr_lookup (proper_simple_mono_var exist) env 49 | (fun () -> 50 | match !exist with 51 | | None -> assert false (* Invariant *) 52 | | Some proper_simple_mono -> 53 | _synth_expr_proper n ctx env proper_simple_mono) 54 | (fun instances -> 55 | match instances with 56 | | [] -> assert false (* Invariant *) 57 | | var :: _ -> 58 | return var) 59 | and _synth_expr_unit_term env = 60 | let open QCheck.Gen in 61 | _synth_expr_lookup proper_simple_mono_unit env 62 | (fun () -> return expr_unit) 63 | (fun instances -> 64 | let m = List.length instances in 65 | frequency 66 | [ 1, return expr_unit 67 | ; m, oneofl instances 68 | ]) 69 | and _synth_expr_arrow n ctx env dom codom = 70 | let open QCheck.Gen in 71 | Naming.sample_label ctx @@ fun param -> 72 | _synth_expr_bind dom (expr_var param) env @@ fun env1 -> 73 | _synth_stmt_proper n ctx env1 codom >>= fun body -> 74 | return (expr_abs param body) 75 | and _synth_expr_redex n ctx env codom = 76 | let open QCheck.Gen in 77 | Naming.sample_label ctx @@ fun param -> 78 | gen_proper_simple_mono >>= fun dom -> 79 | _synth_expr_proper n ctx env dom >>= fun arg -> 80 | _synth_expr_bind dom (expr_var param) env @@ fun env1 -> 81 | _synth_stmt_proper n ctx env1 codom >>= fun body -> 82 | return (expr_app (expr_abs param body) arg) 83 | and _synth_stmt n ctx env simple_mono = 84 | let open QCheck.Gen in 85 | match simple_mono with 86 | | SMNothing -> 87 | return (stmt_expr expr_undefined) 88 | | SMProper proper_simple_mono -> 89 | _synth_stmt_proper n ctx env proper_simple_mono 90 | and _synth_stmt_proper n ctx env proper_simple_mono = 91 | let open QCheck.Gen in 92 | if n = 0 then _synth_stmt_expr n ctx env proper_simple_mono else 93 | frequency 94 | [ 1, _synth_stmt_expr n ctx env proper_simple_mono 95 | ; 2, _synth_stmt_decl n ctx env proper_simple_mono 96 | ; 2, _synth_stmt_defn n ctx env proper_simple_mono 97 | ] 98 | and _synth_stmt_expr n ctx env proper_simple_mono = 99 | let open QCheck.Gen in 100 | _synth_expr_proper n ctx env proper_simple_mono >>= fun expr -> 101 | return (stmt_expr expr) 102 | and _synth_stmt_decl n ctx env proper_simple_mono st = 103 | let open QCheck.Gen in 104 | (Naming.sample_label ctx @@ fun name -> 105 | gen_proper_simple_mono >>= fun proto -> 106 | let env2 = 107 | match proto with 108 | | SMArrow _ -> 109 | _synth_expr_bind proto (expr_var name) env @@ fun env1 -> 110 | env1 111 | | _ -> env 112 | in 113 | proper_simple_mono_2_proper_simple_poly proto @@ fun poly -> 114 | map (stmt_decl name poly) 115 | (_synth_stmt_defn_name name proto n ctx env2 proper_simple_mono)) 116 | st 117 | and _synth_stmt_defn n ctx env proper_simple_mono st = 118 | let open QCheck.Gen in 119 | Naming.sample_label ctx @@ fun name -> 120 | (gen_proper_simple_mono >>= fun proto -> 121 | _synth_stmt_defn_name name proto n ctx env proper_simple_mono) st 122 | and _synth_stmt_defn_name name proto n ctx env proper_simple_mono = 123 | let open QCheck.Gen in 124 | map2 (stmt_defn name) 125 | (_synth_expr_proper (n / 2) ctx env proto) 126 | (_synth_stmt_proper (n / 2) ctx env proper_simple_mono) 127 | 128 | let synth_expr ctx simple_mono = 129 | let open QCheck.Gen in 130 | nat >>= fun n -> 131 | _synth_expr n ctx _synth_expr_empty simple_mono 132 | 133 | let synth_stmt ctx simple_mono = 134 | let open QCheck.Gen in 135 | nat >>= fun n -> 136 | _synth_stmt n ctx _synth_expr_empty simple_mono 137 | 138 | let gen_typed_expr ctx = 139 | let open QCheck.Gen in 140 | gen_simple_mono >>= fun simple_mono -> 141 | synth_expr ctx simple_mono >>= fun expr -> 142 | return (expr, simple_mono) 143 | 144 | let gen_typed_stmt ctx = 145 | let open QCheck.Gen in 146 | gen_simple_mono >>= fun simple_mono -> 147 | synth_stmt ctx simple_mono >>= fun stmt -> 148 | return (stmt, simple_mono) 149 | 150 | let print_expr ctx expr = 151 | Print.print_expr ctx expr (fun x -> x) 152 | 153 | let print_stmt ctx stmt = 154 | Print.print_stmt ctx stmt (fun x -> x) 155 | 156 | let print_typed_expr ctx (expr, simple_mono) = 157 | let open Printf in 158 | sprintf "%s : %s" 159 | (print_expr ctx expr) 160 | (print_simple_mono ctx simple_mono) 161 | 162 | let print_typed_stmt ctx (stmt, simple_mono) = 163 | let open Printf in 164 | sprintf "%s : %s" 165 | (print_stmt ctx stmt) 166 | (print_simple_mono ctx simple_mono) 167 | 168 | let stmt_2_expr env stmt return = 169 | let rec _visit_stmt_drop env stmt return = 170 | match stmt with 171 | | SDecl (_name, _poly, stmt1) -> 172 | _visit_stmt_drop env stmt1 return 173 | | SDefn (name, expr, stmt1) -> 174 | _visit_expr env expr @@ fun expr1 -> 175 | Env.bind name expr1 env @@ fun env1 -> 176 | _visit_stmt_drop env1 stmt1 return 177 | | SExpr expr -> 178 | _visit_expr env expr return 179 | and _visit_stmt_remain env stmt return = 180 | match stmt with 181 | | SDecl (name, poly, stmt1) -> 182 | _visit_stmt_remain env stmt1 @@ fun stmt2 -> 183 | return (stmt_decl name poly stmt2) 184 | | SDefn (name, expr, stmt1) -> 185 | _visit_expr env expr @@ fun expr1 -> 186 | _visit_stmt_remain env stmt1 @@ fun stmt2 -> 187 | return (stmt_defn name expr1 stmt2) 188 | | SExpr expr -> 189 | _visit_expr env expr @@ fun expr1 -> 190 | return (stmt_expr expr1) 191 | and _visit_expr env expr return = 192 | match expr with 193 | | EUndefined -> return expr_undefined 194 | | EUnit -> return expr_unit 195 | | EVar name -> 196 | Env.lookup label_equal name env 197 | (fun () -> return (expr_var name)) 198 | (fun expr -> return expr) 199 | | EAbs (param, body) -> 200 | _visit_stmt_remain env body @@ fun body1 -> 201 | return (expr_abs param body1) 202 | | EApp (func, arg) -> 203 | _visit_expr env func @@ fun func1 -> 204 | _visit_expr env arg @@ fun arg1 -> 205 | return (expr_app func1 arg1) 206 | | EAnno (expr1, poly) -> 207 | _visit_expr env expr1 @@ fun expr2 -> 208 | return (expr_anno expr2 poly) 209 | in 210 | _visit_stmt_drop env stmt return 211 | 212 | let rec label_ref_count_stmt label stmt return = 213 | match stmt with 214 | | SDecl (name, _poly, stmt1) -> 215 | if label_equal label name then return 0 else 216 | label_ref_count_stmt label stmt1 return 217 | | SDefn (name, expr, stmt1) -> 218 | label_ref_count_expr label expr @@ fun expr_count -> 219 | if label_equal label name then return expr_count else 220 | label_ref_count_stmt label stmt1 @@ fun stmt1_count -> 221 | return (expr_count + stmt1_count) 222 | | SExpr expr -> 223 | label_ref_count_expr label expr return 224 | and label_ref_count_expr label expr return = 225 | match expr with 226 | | EUndefined -> return 0 227 | | EUnit -> return 0 228 | | EVar name -> 229 | if label_equal label name 230 | then return 1 231 | else return 0 232 | | EAbs (param, body) -> 233 | if label_equal label param then return 0 else 234 | label_ref_count_stmt label body return 235 | | EApp (func, arg) -> 236 | label_ref_count_expr label func @@ fun func_count -> 237 | label_ref_count_expr label arg @@ fun arg_count -> 238 | return (func_count + arg_count) 239 | | EAnno (expr1, _poly) -> 240 | label_ref_count_expr label expr1 return 241 | 242 | let rec subst_stmt label subst stmt return = 243 | match stmt with 244 | | SDecl (name, poly, stmt1) -> 245 | if label_equal label name then return stmt else 246 | subst_stmt label subst stmt1 @@ fun stmt2 -> 247 | return (stmt_decl name poly stmt2) 248 | | SDefn (name, expr, stmt1) -> 249 | if label_equal label name then return stmt else 250 | subst_expr label subst expr @@ fun expr1 -> 251 | subst_stmt label subst stmt1 @@ fun stmt2 -> 252 | return (stmt_defn name expr1 stmt2) 253 | | SExpr expr -> 254 | subst_expr label subst expr @@ fun expr1 -> 255 | return (stmt_expr expr1) 256 | and subst_expr label subst expr return = 257 | match expr with 258 | | EUndefined | EUnit -> return expr 259 | | EVar name -> 260 | if label_equal label name 261 | then return subst 262 | else return expr 263 | | EAbs (param, body) -> 264 | if label_equal label param then return expr else 265 | subst_stmt label subst body @@ fun body1 -> 266 | return (expr_abs param body1) 267 | | EApp (func, arg) -> 268 | subst_expr label subst func @@ fun func1 -> 269 | subst_expr label subst arg @@ fun arg1 -> 270 | return (expr_app func1 arg1) 271 | | EAnno (expr1, poly) -> 272 | subst_expr label subst expr1 @@ fun expr2 -> 273 | return (expr_anno expr2 poly) 274 | 275 | let rec type_directed_shrink_stmt env stmt yield = 276 | match stmt with 277 | | SDecl (name, poly, stmt1) -> 278 | type_directed_shrink_stmt env stmt1 279 | (fun stmt2 -> yield (stmt_decl name poly stmt2)); 280 | label_ref_count_stmt name stmt1 @@ fun stmt_count -> 281 | begin match stmt_count with 282 | | 0 -> yield stmt1 283 | | _ -> () 284 | end 285 | | SDefn (name, expr, stmt1) -> 286 | let scope = Env.empty in 287 | Env.bind name () scope @@ fun scope1 -> 288 | type_directed_shrink_expr env scope1 expr 289 | (fun expr1 -> yield (stmt_defn name expr1 stmt1)); 290 | type_directed_shrink_stmt env stmt1 291 | (fun stmt2 -> yield (stmt_defn name expr stmt2)); 292 | label_ref_count_expr name expr @@ fun expr_count -> 293 | label_ref_count_stmt name stmt1 @@ fun stmt_count -> 294 | begin match expr_count, stmt_count with 295 | | 0, 1 -> subst_stmt name expr stmt1 yield 296 | | _, 0 -> yield stmt1 297 | | _, _ -> () 298 | end 299 | | SExpr expr -> 300 | let scope = Env.empty in 301 | type_directed_shrink_expr env scope expr @@ fun expr1 -> 302 | yield (stmt_expr expr1) 303 | and type_directed_shrink_expr env scope expr yield = 304 | match expr with 305 | | EUndefined -> () 306 | | EUnit -> () 307 | | EVar name -> 308 | Env.lookup label_equal name scope 309 | (fun () -> 310 | Env.lookup label_equal name env identity @@ fun expr1 -> 311 | Env.bind name () scope @@ fun scope1 -> 312 | type_directed_shrink_expr env scope1 expr1 yield) 313 | (fun () -> ()) 314 | | EAbs (param, body) -> 315 | type_directed_shrink_stmt env body 316 | (fun body1 -> yield (expr_abs param body1)) 317 | | EApp (func, arg) -> 318 | type_directed_shrink_expr env scope func 319 | (fun func1 -> yield (expr_app func1 arg)); 320 | type_directed_shrink_expr env scope arg 321 | (fun arg1 -> yield (expr_app func arg1)); 322 | begin match func, arg with 323 | | EAbs (param, SExpr (EVar arg)), _ -> 324 | if label_equal param arg then () else 325 | yield (expr_var arg) 326 | | EAbs (_param, SExpr EUndefined), _ -> yield expr_undefined 327 | | EAbs (_param, SExpr EUnit), _ -> yield expr_unit 328 | | EAbs _, EUndefined -> yield expr_undefined 329 | | EAbs (param, body), EUnit 330 | | EAbs (param, body), EAbs _ -> 331 | Env.bind param arg env @@ fun env1 -> 332 | type_directed_shrink_stmt env1 body 333 | (fun body1 -> stmt_2_expr env1 body1 yield) 334 | | _, _ -> () 335 | end 336 | | EAnno (expr1, poly) -> 337 | type_directed_shrink_expr env scope expr1 338 | (fun expr2 -> yield (expr_anno expr2 poly)); 339 | yield expr1 340 | 341 | let shrink_typed_expr (expr, simple_mono) = 342 | let open QCheck.Iter in 343 | let env = Env.empty in 344 | let scope = Env.empty in 345 | type_directed_shrink_expr env scope expr >>= fun expr1 -> 346 | return (expr1, simple_mono) 347 | 348 | let shrink_typed_stmt (stmt, simple_mono) = 349 | let open QCheck.Iter in 350 | let env = Env.empty in 351 | type_directed_shrink_stmt env stmt >>= fun stmt1 -> 352 | return (stmt1, simple_mono) 353 | 354 | let arbitrary_typed_expr ctx = 355 | QCheck.make (gen_typed_expr ctx) 356 | ~print: (print_typed_expr ctx) 357 | ~shrink: shrink_typed_expr 358 | 359 | let arbitrary_typed_stmt ctx = 360 | QCheck.make (gen_typed_stmt ctx) 361 | ~print: (print_typed_stmt ctx) 362 | ~shrink: shrink_typed_stmt 363 | -------------------------------------------------------------------------------- /shared/lib/Mono.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Back 3 | open Syntax 4 | open Simple 5 | 6 | (* Mono *) 7 | let rec _gen_mono n ps vs = 8 | let open QCheck.Gen in 9 | let _gen_mono_var_fresh _st = 10 | let exist = ref None in 11 | vs := exist :: !vs; 12 | mono_var exist 13 | in 14 | let _gen_mono_var = 15 | let _vs = !vs in 16 | let m = List.length _vs in 17 | if m <= 0 then _gen_mono_var_fresh else 18 | frequency 19 | [ 1, _gen_mono_var_fresh 20 | ; m, map mono_var (oneofl _vs) 21 | ] 22 | in 23 | let _gen_mono_term = 24 | if (List.length ps) <= 0 then 25 | frequency 26 | [ 1, return mono_unit 27 | ; 1, _gen_mono_var 28 | ] 29 | else 30 | frequency 31 | [ 1, return mono_unit 32 | ; 1, map mono_param (oneofl ps) 33 | ; 1, _gen_mono_var 34 | ] 35 | in 36 | if n = 0 then _gen_mono_term else 37 | frequency 38 | [ 1, _gen_mono_term 39 | ; 2, map2 mono_arrow 40 | (_gen_mono (n / 2) ps vs) 41 | (_gen_mono (n / 2) ps vs) 42 | ] 43 | 44 | let gen_mono = 45 | let open QCheck.Gen in 46 | let ps = [] in 47 | let vs = ref [] in 48 | nat >>= fun n -> 49 | _gen_mono n ps vs 50 | 51 | let print_mono ctx mono = 52 | Print.print_mono ctx mono (fun x -> x) 53 | 54 | let rec shrink_mono mono = 55 | let open QCheck.Iter in 56 | match mono with 57 | | MNothing -> empty 58 | | MUnit -> empty 59 | | MParam _name -> empty 60 | | MVar exist -> 61 | begin match !exist with 62 | | None -> empty 63 | | Some mono -> shrink_mono mono >|= fun mono1 -> mono1 64 | end 65 | | MArrow (dom, codom) -> 66 | of_list [dom; codom] 67 | <+> (shrink_mono dom >|= fun dom1 -> mono_arrow dom1 codom) 68 | <+> (shrink_mono codom >|= fun codom1 -> mono_arrow dom codom1) 69 | 70 | let arbitrary_mono ctx = 71 | QCheck.make gen_mono 72 | ~print: (print_mono ctx) 73 | ~shrink: shrink_mono 74 | 75 | (* Simple mono *) 76 | type simple_mono = 77 | | SMNothing 78 | | SMProper of proper_simple_mono 79 | and proper_simple_mono = 80 | | SMUnit 81 | | SMVar of exist 82 | | SMArrow of proper_simple_mono * proper_simple_mono 83 | and exist = 84 | proper_simple_mono option ref 85 | 86 | let simple_mono_nothing = SMNothing 87 | let simple_mono_proper proper_simple_mono = SMProper proper_simple_mono 88 | let proper_simple_mono_unit = SMUnit 89 | let proper_simple_mono_var exist = SMVar exist 90 | let proper_simple_mono_arrow dom codom = SMArrow (dom, codom) 91 | 92 | let exist_equal left right = left == right 93 | 94 | let proper_simple_mono_equal left right = 95 | let rec _equal left right env fail return = 96 | match left, right with 97 | | SMUnit, SMUnit -> return env 98 | | SMVar left1, SMVar right1 -> 99 | Env.lookup exist_equal left1 env 100 | (fun () -> 101 | Env.bind left1 right1 env return) 102 | (fun left2 -> 103 | if exist_equal left2 right1 104 | then return env 105 | else fail ()) 106 | | SMArrow (l_dom, l_codom), SMArrow (r_dom, r_codom) -> 107 | _equal l_dom r_dom env fail @@ fun env1 -> 108 | _equal l_codom r_codom env1 fail return 109 | | _, _ -> fail () 110 | in 111 | _equal left right Env.empty 112 | (fun () -> false) 113 | (fun _env -> true) 114 | 115 | let simple_mono_equal left right = 116 | match left, right with 117 | | SMNothing, SMNothing -> true 118 | | SMProper left1, SMProper right1 -> 119 | proper_simple_mono_equal left1 right1 120 | | _, _ -> false 121 | 122 | let _bind proper_simple exist vs = 123 | vs := (proper_simple, exist) :: !vs 124 | 125 | let _lookup proper_simple vs return = 126 | let rec _visit vs exists = 127 | match vs with 128 | | [] -> return exists 129 | | (proper_simple1, exist) :: vs1 -> 130 | if proper_simple_equal proper_simple proper_simple1 131 | then _visit vs1 (exist :: exists) 132 | else _visit vs1 exists 133 | in 134 | _visit !vs [] 135 | 136 | let _proper_simple_convert proper_simple return = 137 | let rec _convert proper_simple return = 138 | match proper_simple with 139 | | SUnit -> return proper_simple_mono_unit 140 | | SArrow (dom, codom) -> 141 | _convert dom @@ fun dom1 -> 142 | _convert codom @@ fun codom1 -> 143 | return (proper_simple_mono_arrow dom1 codom1) 144 | in 145 | _convert proper_simple return 146 | 147 | let rec _gen_simple_mono simple vs = 148 | let open QCheck.Gen in 149 | match simple with 150 | | SNothing -> return simple_mono_nothing 151 | | SProper proper_simple -> 152 | _gen_proper_simple_mono proper_simple vs >|= fun proper_simple_mono -> 153 | simple_mono_proper proper_simple_mono 154 | and _gen_proper_simple_mono proper_simple vs = 155 | let open QCheck.Gen in 156 | match proper_simple with 157 | | SUnit -> 158 | frequency 159 | [ 1, _gen_proper_simple_mono_exist proper_simple vs 160 | ; 10, return proper_simple_mono_unit 161 | ] 162 | | SArrow (dom, codom) -> 163 | frequency 164 | [ 1, _gen_proper_simple_mono_exist proper_simple vs 165 | ; 10, map2 proper_simple_mono_arrow 166 | (_gen_proper_simple_mono dom vs) 167 | (_gen_proper_simple_mono codom vs) 168 | ] 169 | and _gen_proper_simple_mono_exist proper_simple vs = 170 | let open QCheck.Gen in 171 | _lookup proper_simple vs @@ fun vars -> 172 | let m = List.length vars in 173 | if m = 0 then _gen_proper_simple_mono_exist_fresh proper_simple vs else 174 | frequency 175 | [ 1, _gen_proper_simple_mono_exist_fresh proper_simple vs 176 | ; m, oneofl vars 177 | ] 178 | and _gen_proper_simple_mono_exist_fresh proper_simple vs _st = 179 | _proper_simple_convert proper_simple @@ fun proper_simple_mono -> 180 | let exist = ref (Some proper_simple_mono) in 181 | let var = proper_simple_mono_var exist in 182 | _bind proper_simple var vs; 183 | var 184 | 185 | let gen_proper_simple_mono = 186 | let open QCheck.Gen in 187 | let vs = ref [] in 188 | gen_proper_simple >>= fun proper_simple -> 189 | _gen_proper_simple_mono proper_simple vs 190 | 191 | let gen_simple_mono = 192 | let open QCheck.Gen in 193 | let vs = ref [] in 194 | gen_simple >>= fun simple -> 195 | _gen_simple_mono simple vs 196 | 197 | let rec _print_simple_mono ctx env simple_mono return = 198 | match simple_mono with 199 | | SMNothing -> return "⊥" 200 | | SMProper proper_simple_mono -> 201 | _print_proper_simple_mono ctx env proper_simple_mono false return 202 | and _print_proper_simple_mono ctx env proper_simple_mono group return = 203 | let open Printf in 204 | match proper_simple_mono with 205 | | SMUnit -> return "unit" 206 | | SMVar exist -> 207 | let _env = !env in 208 | Env.lookup exist_equal exist _env 209 | (fun () -> 210 | Naming.sample_exist ctx @@ fun label -> 211 | Env.bind exist label _env @@ fun env1 -> 212 | env := env1; 213 | return label) 214 | (fun label -> return label) 215 | | SMArrow (dom, codom) -> 216 | _print_proper_simple_mono ctx env dom true @@ fun dom1 -> 217 | _print_proper_simple_mono ctx env codom false @@ fun codom1 -> 218 | if group 219 | then return (sprintf "(%s -> %s)" dom1 codom1) 220 | else return (sprintf "%s -> %s" dom1 codom1) 221 | 222 | let print_simple_mono ctx simple_mono = 223 | let env = ref Env.empty in 224 | _print_simple_mono ctx env simple_mono (fun x -> x) 225 | 226 | let print_proper_simple_mono ctx proper_simple_mono = 227 | let env = ref Env.empty in 228 | _print_proper_simple_mono ctx env 229 | proper_simple_mono false (fun x -> x) 230 | 231 | let rec shrink_simple_mono simple_mono = 232 | let open QCheck.Iter in 233 | match simple_mono with 234 | | SMNothing -> empty 235 | | SMProper proper_simple_mono -> 236 | shrink_proper_simple_mono proper_simple_mono >|= simple_mono_proper 237 | and shrink_proper_simple_mono proper_simple_mono = 238 | let open QCheck.Iter in 239 | match proper_simple_mono with 240 | | SMUnit -> empty 241 | | SMVar _exist -> empty 242 | | SMArrow (dom, codom) -> 243 | of_list [dom; codom] 244 | <+> (shrink_proper_simple_mono dom >|= fun dom1 -> 245 | proper_simple_mono_arrow dom1 codom) 246 | <+> (shrink_proper_simple_mono codom >|= fun codom1 -> 247 | proper_simple_mono_arrow dom codom1) 248 | 249 | let arbitrary_simple_mono = 250 | let ctx = Naming.make_ctx () in 251 | QCheck.make gen_simple_mono 252 | ~print: (print_simple_mono ctx) 253 | ~shrink: shrink_simple_mono 254 | 255 | (* Convert *) 256 | let simple_2_simple_mono simple return = 257 | let vs = ref [] in 258 | return (QCheck.Gen.generate1 (_gen_simple_mono simple vs)) 259 | -------------------------------------------------------------------------------- /shared/lib/Poly.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Back 3 | open Syntax 4 | open Mono 5 | open Simple 6 | 7 | (* Poly *) 8 | let rec _gen_poly n ctx ps vs = 9 | let open QCheck.Gen in 10 | let _gen_poly_var_fresh _st = 11 | let exist = ref None in 12 | vs := exist :: !vs; 13 | poly_var exist 14 | in 15 | let _gen_poly_var = 16 | let _vs = !vs in 17 | let m = List.length _vs in 18 | if m <= 0 then _gen_poly_var_fresh else 19 | frequency 20 | [ 1, _gen_poly_var_fresh 21 | ; m, map poly_var (oneofl _vs) 22 | ] 23 | in 24 | let _gen_poly_term = 25 | if (List.length ps) <= 0 then 26 | frequency 27 | [ 1, return poly_unit 28 | ; 1, _gen_poly_var 29 | ] 30 | else 31 | frequency 32 | [ 1, return poly_unit 33 | ; 1, map poly_param (oneofl ps) 34 | ; 1, _gen_poly_var 35 | ] 36 | in 37 | let _gen_poly_forall st = 38 | Naming.sample_label ctx @@ fun param -> 39 | map (poly_forall param) 40 | (_gen_poly (n / 2) ctx (param :: ps) vs) st 41 | in 42 | if n = 0 then _gen_poly_term else 43 | frequency 44 | [ 1, _gen_poly_term 45 | ; 1, _gen_poly_forall 46 | ; 1, map poly_mono (_gen_mono n ps vs) 47 | ; 2, map2 poly_arrow 48 | (_gen_poly (n / 2) ctx ps vs) 49 | (_gen_poly (n / 2) ctx ps vs) 50 | ] 51 | 52 | let gen_poly ctx = 53 | let open QCheck.Gen in 54 | let ps = [] in 55 | let vs = ref [] in 56 | nat >>= fun n -> 57 | _gen_poly n ctx ps vs 58 | 59 | let print_poly ctx poly = 60 | Print.print_poly ctx poly (fun x -> x) 61 | 62 | let rec shrink_poly poly = 63 | let open QCheck.Iter in 64 | match poly with 65 | | PNothing -> empty 66 | | PUnit -> empty 67 | | PParam _name -> empty 68 | | PVar exist -> 69 | begin match !exist with 70 | | None -> empty 71 | | Some mono -> shrink_mono mono >|= fun mono1 -> poly_mono mono1 72 | end 73 | | PArrow (dom, codom) -> 74 | of_list [dom; codom] 75 | <+> (shrink_poly dom >|= fun dom1 -> poly_arrow dom1 codom) 76 | <+> (shrink_poly codom >|= fun codom1 -> poly_arrow dom codom1) 77 | | PForall (param, poly1) -> 78 | shrink_poly poly1 >|= fun poly2 -> poly_forall param poly2 79 | | PMono mono -> 80 | shrink_mono mono >|= fun mono1 -> poly_mono mono1 81 | 82 | let arbitrary_poly ctx = 83 | QCheck.make (gen_poly ctx) 84 | ~print: (print_poly ctx) 85 | ~shrink: shrink_poly 86 | 87 | (* Convert *) 88 | let rec simple_2_simple_poly simple return = 89 | match simple with 90 | | SNothing -> return poly_nothing 91 | | SProper proper_simple -> 92 | _proper_simple_2_simple_poly proper_simple return 93 | and _proper_simple_2_simple_poly proper_simple return = 94 | match proper_simple with 95 | | SUnit -> return poly_unit 96 | | SArrow (dom, codom) -> 97 | _proper_simple_2_simple_poly dom @@ fun dom1 -> 98 | _proper_simple_2_simple_poly codom @@ fun codom1 -> 99 | return (poly_arrow dom1 codom1) 100 | 101 | let rec simple_mono_2_simple_poly simple_mono return = 102 | match simple_mono with 103 | | SMNothing -> return poly_nothing 104 | | SMProper proper_simple_mono -> 105 | let env = ref Env.empty in 106 | _proper_simple_mono_2_simple_poly env proper_simple_mono return 107 | and _proper_simple_mono_2_simple_poly env proper_simple_mono return = 108 | match proper_simple_mono with 109 | | SMUnit -> return poly_unit 110 | | SMVar from_exist -> 111 | let _env = !env in 112 | Env.lookup exist_equal from_exist _env 113 | (fun () -> 114 | let to_exist = ref None in 115 | Env.bind from_exist to_exist _env @@ fun env1 -> 116 | env := env1; 117 | return (poly_var to_exist)) 118 | (fun to_exist -> 119 | return (poly_var to_exist)) 120 | | SMArrow (dom, codom) -> 121 | _proper_simple_mono_2_simple_poly env dom @@ fun dom1 -> 122 | _proper_simple_mono_2_simple_poly env codom @@ fun codom1 -> 123 | return (poly_arrow dom1 codom1) 124 | 125 | let proper_simple_mono_2_proper_simple_poly proper_simple_mono return = 126 | let env = ref Env.empty in 127 | _proper_simple_mono_2_simple_poly env proper_simple_mono return 128 | -------------------------------------------------------------------------------- /shared/lib/Simple.ml: -------------------------------------------------------------------------------- 1 | type simple = 2 | | SNothing 3 | | SProper of proper_simple 4 | and proper_simple = 5 | | SUnit 6 | | SArrow of proper_simple * proper_simple 7 | 8 | let simple_nothing = SNothing 9 | let simple_proper simple = SProper simple 10 | let proper_simple_unit = SUnit 11 | let proper_simple_arrow dom codom = SArrow (dom, codom) 12 | 13 | let proper_simple_equal left right = 14 | let rec _equal left right = 15 | match left, right with 16 | | SUnit, SUnit -> true 17 | | SArrow (l_dom, l_codom), SArrow (r_dom, r_codom) -> 18 | if not (_equal l_dom r_dom) then false else 19 | if not (_equal l_codom r_codom) then false else 20 | true 21 | | _, _ -> false 22 | in 23 | _equal left right 24 | 25 | let simple_equal left right = 26 | match left, right with 27 | | SNothing, SNothing -> true 28 | | SProper left1, SProper right1 -> 29 | proper_simple_equal left1 right1 30 | | _, _ -> false 31 | 32 | let rec _gen_proper_simple n = 33 | let open QCheck.Gen in 34 | match n with 35 | | 0 -> return proper_simple_unit 36 | | _ -> 37 | frequency 38 | [ 1, return proper_simple_unit 39 | ; 2, map2 proper_simple_arrow 40 | (_gen_proper_simple (n / 2)) 41 | (_gen_proper_simple (n / 2)) 42 | ] 43 | 44 | let gen_proper_simple = 45 | let open QCheck.Gen in 46 | nat >>= fun n -> 47 | _gen_proper_simple n 48 | 49 | exception Nothing 50 | 51 | let rec _gen_simple n = 52 | let open QCheck.Gen in 53 | let _gen_simple_nothing _st = raise Nothing in 54 | let _gen_simple_term = 55 | frequency 56 | [ 1, _gen_simple_nothing 57 | ; 100, return proper_simple_unit 58 | ] 59 | in 60 | match n with 61 | | 0 -> _gen_simple_term 62 | | _ -> 63 | frequency 64 | [ 1, _gen_simple_term 65 | ; 2, map2 proper_simple_arrow 66 | (_gen_simple (n / 2)) 67 | (_gen_simple (n / 2)) 68 | ] 69 | 70 | let _gen_simple_wrap n st = 71 | try simple_proper (_gen_simple n st) 72 | with Nothing -> simple_nothing 73 | 74 | let gen_simple = 75 | let open QCheck.Gen in 76 | nat >>= fun n -> 77 | _gen_simple_wrap n 78 | 79 | let rec _print_simple simple return = 80 | match simple with 81 | | SNothing -> return "⊥" 82 | | SProper proper_simple -> 83 | _print_proper_simple proper_simple false return 84 | and _print_proper_simple proper_simple group return = 85 | let open Printf in 86 | match proper_simple with 87 | | SUnit -> return "unit" 88 | | SArrow (dom, codom) -> 89 | _print_proper_simple dom true @@ fun dom1 -> 90 | _print_proper_simple codom false @@ fun codom1 -> 91 | if group 92 | then return (sprintf "(%s -> %s)" dom1 codom1) 93 | else return (sprintf "%s -> %s" dom1 codom1) 94 | 95 | let print_simple simple = 96 | _print_simple simple (fun x -> x) 97 | 98 | let print_proper_simple proper_simple = 99 | _print_proper_simple proper_simple false (fun x -> x) 100 | 101 | let rec shrink_simple simple = 102 | let open QCheck.Iter in 103 | match simple with 104 | | SNothing -> empty 105 | | SProper proper_simple -> 106 | shrink_proper_simple proper_simple >|= simple_proper 107 | and shrink_proper_simple proper_simple = 108 | let open QCheck.Iter in 109 | match proper_simple with 110 | | SUnit -> empty 111 | | SArrow (dom, codom) -> 112 | of_list [dom; codom] 113 | <+> (shrink_proper_simple dom >|= fun dom1 -> 114 | proper_simple_arrow dom1 codom) 115 | <+> (shrink_proper_simple codom >|= fun codom1 -> 116 | proper_simple_arrow dom codom1) 117 | 118 | let arbitrary_simple = 119 | QCheck.make gen_simple 120 | ~print: print_simple 121 | ~shrink: shrink_simple 122 | 123 | let arbitrary_proper_simple = 124 | QCheck.make gen_proper_simple 125 | ~print: print_proper_simple 126 | ~shrink: shrink_proper_simple 127 | -------------------------------------------------------------------------------- /shared/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bhrp_shared) 3 | (package bhrp) 4 | (libraries 5 | qcheck 6 | landmarks 7 | bhrp.back) 8 | (instrumentation (backend bhrp.landmarks))) 9 | -------------------------------------------------------------------------------- /util/lib/AVL.ml: -------------------------------------------------------------------------------- 1 | open Infix 2 | open Order 3 | open Extra 4 | 5 | type 'a tree = 6 | | Null 7 | | Node of int * int * 'a * 'a tree * 'a tree 8 | 9 | let make_null () = Null 10 | 11 | let make_node count height data left right = 12 | Node (count, height, data, left, right) 13 | 14 | let fold null_case node_case tree = 15 | let rec _visit tree return = 16 | match tree with 17 | | Null -> return null_case 18 | | Node (count, height, data, left, right) -> 19 | _visit left (fun left' -> 20 | _visit right (fun right' -> 21 | return (node_case count height data left' right'))) 22 | in 23 | _visit tree identity 24 | 25 | let map f tree = 26 | fold Null 27 | (fun c h x l r -> 28 | make_node c h (f x) l r) 29 | tree 30 | 31 | let get_count tree = 32 | match tree with 33 | | Null -> 0 34 | | Node (count, _, _, _, _) -> count 35 | 36 | let get_height tree = 37 | match tree with 38 | | Null -> 0 39 | | Node (_, height, _, _, _) -> height 40 | 41 | let local_inbalance pos tree = 42 | match tree with 43 | | Null -> EQ 44 | | Node (_, _, _, l, r) -> 45 | let h_l = get_height l in 46 | let h_r = get_height r in 47 | let h_diff = h_l - h_r in 48 | match pos with 49 | | EQ -> 50 | if h_diff > 1 then LT else 51 | if h_diff < -1 then GT else 52 | EQ 53 | | LT -> 54 | if h_diff > 1 then LT else 55 | if h_diff < 0 then GT else 56 | EQ 57 | | GT -> 58 | if h_diff > 0 then LT else 59 | if h_diff < -1 then GT else 60 | EQ 61 | 62 | let local_rebalance pos tree = 63 | let _rotate_left p = 64 | match p with 65 | | Null -> assert false 66 | | Node (c_p, _, u, a, q) -> 67 | let c_a = get_count a in 68 | let h_a = get_height a in 69 | match q with 70 | | Null -> assert false 71 | | Node (_, _, v, b, c) -> 72 | let c_b = get_count b in 73 | let h_b = get_height b in 74 | let c_l = c_a + c_b + 1 in 75 | let h_l = (max h_a h_b) + 1 in 76 | let h_r = get_height c in 77 | Node (c_p, (max h_l h_r) + 1, v, Node (c_l, h_l, u, a, b), c) 78 | in 79 | let _rotate_right q = 80 | match q with 81 | | Null -> assert false 82 | | Node (c_q, _, v, p, c) -> 83 | let c_c = get_count c in 84 | let h_c = get_height c in 85 | match p with 86 | | Null -> assert false 87 | | Node (_, _, u, a, b) -> 88 | let c_b = get_count b in 89 | let h_b = get_height b in 90 | let c_r = c_b + c_c + 1 in 91 | let h_l = get_height a in 92 | let h_r = (max h_b h_c) + 1 in 93 | Node (c_q, (max h_l h_r) + 1, u, a, Node (c_r, h_r, v, b, c)) 94 | in 95 | match local_inbalance pos tree with 96 | | EQ -> tree 97 | | LT -> _rotate_right tree 98 | | GT -> _rotate_left tree 99 | 100 | let insert_cont order data tree return = 101 | let rec _visit tree pos updated inserted = 102 | match tree with 103 | | Null -> inserted (make_node 1 1 data Null Null) 104 | | Node (count, height, data', left, right) -> 105 | match order data data' with 106 | | EQ -> updated (make_node count height data left right) 107 | | LT -> 108 | _visit left LT 109 | (updated <== (swap (make_node count height data') right)) 110 | (inserted <== (local_rebalance pos) <== (fun left' -> 111 | let height' = max ((get_height left') + 1) height in 112 | make_node (count + 1) height' data' left' right)) 113 | | GT -> 114 | _visit right GT 115 | (updated <== (make_node count height data' left)) 116 | (inserted <== (local_rebalance pos) <== (fun right' -> 117 | let height' = max ((get_height right') + 1) height in 118 | make_node (count + 1) height' data' left right')) 119 | in 120 | _visit tree EQ return (return <== (local_rebalance EQ)) 121 | 122 | let insert order data tree = 123 | insert_cont order data tree identity 124 | 125 | let remove_cont order data tree return = 126 | let rec _leftmost tree = 127 | match tree with 128 | | Null -> assert false 129 | | Node (_, _, data, Null, _) -> data 130 | | Node (_, _, _, left, _) -> _leftmost left 131 | in 132 | let rec _rightmost tree = 133 | match tree with 134 | | Null -> assert false 135 | | Node (_, _, data, _, Null) -> data 136 | | Node (_, _, _, _, right) -> _rightmost right 137 | in 138 | let rec _visit tree pos data return = 139 | match tree with 140 | | Null -> tree 141 | | Node (count, height, data', left, right) -> 142 | begin match order data data' with 143 | | EQ -> 144 | begin match left, right with 145 | | Null, Null -> return (make_null ()) 146 | | Null, _ -> 147 | let data' = _leftmost right in 148 | _visit right GT data' 149 | (return <== (local_rebalance pos) <== (fun right' -> 150 | let height' = max ((get_height right') + 1) height in 151 | make_node (count - 1) height' data' left right')) 152 | | _, Null -> 153 | let data' = _rightmost left in 154 | _visit left LT data' 155 | (return <== (local_rebalance pos) <== (fun left' -> 156 | let height' = max ((get_height left') + 1) height in 157 | make_node (count - 1) height' data' left' right)) 158 | | _, _ -> 159 | let left_count = get_count left in 160 | let right_count = get_count right in 161 | begin match int_compare left_count right_count with 162 | | LT -> 163 | let data' = _leftmost right in 164 | _visit right GT data' 165 | (return <== (local_rebalance pos) <== (fun right' -> 166 | let height' = max ((get_height right') + 1) height in 167 | make_node (count - 1) height' data' left right')) 168 | | GT | EQ -> 169 | let data' = _rightmost left in 170 | _visit left LT data' 171 | (return <== (local_rebalance pos) <== (fun left' -> 172 | let height' = max ((get_height left') + 1) height in 173 | make_node (count - 1) height' data' left' right)) 174 | end 175 | end 176 | | LT -> 177 | _visit left LT data 178 | (return <== (local_rebalance pos) <== (fun left' -> 179 | let height' = max ((get_height left') + 1) height in 180 | make_node (count - 1) height' data' left' right)) 181 | | GT -> 182 | _visit right GT data 183 | (return <== (local_rebalance pos) <== (fun right' -> 184 | let height' = max ((get_height right') + 1) height in 185 | make_node (count - 1) height' data' left right')) 186 | end 187 | in 188 | _visit tree EQ data (return <== (local_rebalance EQ)) 189 | 190 | let remove order data tree = 191 | remove_cont order data tree identity 192 | 193 | let is_member order item tree = 194 | let rec _visit tree = 195 | match tree with 196 | | Null -> false 197 | | Node (_, _, data, left, right) -> 198 | match order item data with 199 | | EQ -> true 200 | | LT -> _visit left 201 | | GT -> _visit right 202 | in 203 | _visit tree 204 | 205 | let rec get_member index tree = 206 | match tree with 207 | | Null -> None 208 | | Node (_, _, data, left, right) -> 209 | if index = 0 then Some data else 210 | let left_count = get_count left in 211 | if left_count <= index 212 | then get_member (index - left_count) right 213 | else get_member index left 214 | 215 | let rec get_leftmost tree = 216 | match tree with 217 | | Null -> None 218 | | Node (_, _, data, left, _) -> 219 | if left = Null then Some data else 220 | get_leftmost left 221 | 222 | let rec get_rightmost tree = 223 | match tree with 224 | | Null -> None 225 | | Node (_, _, data, _, right) -> 226 | if right = Null then Some data else 227 | get_rightmost right 228 | 229 | let to_list tree = 230 | fold 231 | (fun result -> result) 232 | (fun _ _ data visit_left visit_right result -> 233 | visit_left (data :: (visit_right result))) 234 | tree [] 235 | 236 | let from_list items = 237 | let _pop items f = 238 | match items with 239 | | item :: items' -> f item items' 240 | | [] -> assert false 241 | in 242 | let rec _build pos count items return = 243 | match count with 244 | | 0 -> return items 0 (make_null ()) 245 | | 1 -> 246 | _pop items (fun data items1 -> 247 | return items1 1 (make_node 1 1 data (make_null ()) (make_null ()))) 248 | | _ -> 249 | let n = count - 1 in 250 | let m = n / 2 in 251 | let _left () = 252 | let sm = m + 1 in 253 | _build LT sm items (fun items1 l_h left -> 254 | _pop items1 (fun data items2 -> 255 | _build GT m items2 (fun items3 r_h right -> 256 | let height = (max l_h r_h) + 1 in 257 | return items3 height (make_node count height data left right)))) 258 | in 259 | let _right () = 260 | let sm = m + 1 in 261 | _build LT m items (fun items1 l_h left -> 262 | _pop items1 (fun data items2 -> 263 | _build GT sm items2 (fun items3 r_h right -> 264 | let height = (max l_h r_h) + 1 in 265 | return items3 height (make_node count height data left right)))) 266 | in 267 | begin match pos, n mod 2 with 268 | | _, 0 -> 269 | _build LT m items (fun items1 l_h left -> 270 | _pop items1 (fun data items2 -> 271 | _build GT m items2 (fun items3 r_h right -> 272 | let height = (max l_h r_h) + 1 in 273 | return items3 height (make_node count height data left right)))) 274 | | EQ, _ | LT, _ -> _left () 275 | | GT, _ -> _right () 276 | end 277 | in 278 | let count = List.length items in 279 | _build EQ count items (fun _ _ x -> x) 280 | -------------------------------------------------------------------------------- /util/lib/Env.ml: -------------------------------------------------------------------------------- 1 | open Extra 2 | 3 | type ('key, 'value) env = 4 | ('key * 'value) list 5 | 6 | let empty = [] 7 | 8 | let from_list binds = 9 | List.fold empty 10 | (fun (key, value) env -> 11 | (key, value) :: env) 12 | binds 13 | 14 | let fold empty_case bind_case env = 15 | let rec _visit env return = 16 | match env with 17 | | [] -> return empty_case 18 | | (key, value) :: env1 -> 19 | _visit env1 @@ fun result -> 20 | return (bind_case key value result) 21 | in 22 | _visit env identity 23 | 24 | let bind key value env return = 25 | return ((key, value) :: env) 26 | 27 | let lookup equal key env fail return = 28 | let rec _visit env = 29 | match env with 30 | | [] -> fail () 31 | | (key1, value) :: env1 -> 32 | if equal key key1 33 | then return value 34 | else _visit env1 35 | in 36 | _visit env 37 | 38 | let bound equal key env fail return = 39 | let rec _visit env = 40 | match env with 41 | | [] -> fail () 42 | | (key1, _value) :: env1 -> 43 | if equal key key1 44 | then return () 45 | else _visit env1 46 | in 47 | _visit env 48 | 49 | let keys order env return = 50 | fold 51 | (fun return -> return (Set.make ())) 52 | (fun key _value visit_env return -> 53 | visit_env @@ fun keys -> 54 | return (Set.add order key keys)) 55 | env return 56 | 57 | let values env return = 58 | fold 59 | (fun return -> return []) 60 | (fun _key value visit_env return -> 61 | visit_env @@ fun values -> 62 | return (value :: values)) 63 | env return 64 | 65 | let print print_key print_value env return = 66 | let open Printf in 67 | let _cont k x y xys = k ((sprintf "%s = %s" x y) :: xys) in 68 | let rec _visit env return = 69 | match env with 70 | | [] -> return [] 71 | | (key, value) :: env1 -> 72 | print_key key @@ fun key1 -> 73 | print_value value @@ fun value1 -> 74 | _visit env1 (_cont return key1 value1) 75 | in 76 | _visit env @@ fun binds -> 77 | return (String.join_with "\n" binds) 78 | -------------------------------------------------------------------------------- /util/lib/Env.mli: -------------------------------------------------------------------------------- 1 | type ('key, 'value) env 2 | val empty : ('key, 'value) env 3 | val from_list : ('key * 'value) list -> ('key, 'value) env 4 | val fold : 'a -> ('key -> 'value -> 'a -> 'a) -> ('key, 'value) env -> 'a 5 | 6 | val bind : 7 | 'key -> 'value -> 8 | ('key, 'value) env -> 9 | (('key, 'value) env -> 'result) -> 10 | 'result 11 | 12 | val lookup : 13 | ('key -> 'key -> bool) -> 14 | 'key -> ('key, 'value) env -> 15 | (unit -> 'result) -> 16 | ('value -> 'result) -> 17 | 'result 18 | 19 | val bound : 20 | ('key -> 'key -> bool) -> 21 | 'key -> ('key, 'value) env -> 22 | (unit -> 'result) -> 23 | (unit -> 'result) -> 24 | 'result 25 | 26 | val keys : 27 | ('key -> 'key -> Order.total) -> 28 | ('key, 'value) env -> 29 | ('key Set.set -> 'result) -> 30 | 'result 31 | 32 | val values : 33 | ('key, 'value) env -> 34 | ('value list -> 'result) -> 35 | 'result 36 | 37 | val print : 38 | ('key -> (string -> 'a) -> 'a) -> 39 | ('value -> (string -> 'a) -> 'a) -> 40 | ('key, 'value) env -> 41 | (string -> 'a) -> 'a 42 | -------------------------------------------------------------------------------- /util/lib/Extra.ml: -------------------------------------------------------------------------------- 1 | let identity x = x 2 | let app f x = f x 3 | let swap f x y = f y x 4 | let compose f g x = f (g x) 5 | let pipe f g x = g (f x) 6 | let tap f g x = begin f x; g x end 7 | 8 | module List = struct 9 | let nil = [] 10 | let cons x xs = x :: xs 11 | 12 | let length = List.length 13 | 14 | let fold null_case list_case term = 15 | let rec _visit xs return = 16 | match xs with 17 | | [] -> return null_case 18 | | x :: xs' -> 19 | _visit xs' (compose return (list_case x)) 20 | in 21 | _visit term identity 22 | 23 | let fold_rev null_case list_case term = 24 | let rec _visit xs result = 25 | match xs with 26 | | [] -> result 27 | | x :: xs' -> 28 | _visit xs' (list_case x result) 29 | in 30 | _visit term null_case 31 | 32 | let iter f term = 33 | fold () (fun item () -> f item) term 34 | 35 | let init count item = 36 | if count <= 0 then [] else 37 | let rec _visit index result = 38 | if index = count then result else 39 | _visit (index + 1) (item :: result) 40 | in 41 | _visit 0 [] 42 | 43 | let map f term = 44 | fold [] (compose cons f) term 45 | 46 | let conc xs ys = 47 | fold ys cons xs 48 | 49 | let flatten xs = 50 | fold [] conc xs 51 | 52 | let rec zip xs ys = 53 | match xs, ys with 54 | | [], _ -> [] 55 | | _, [] -> [] 56 | | x :: xs1, y :: ys1 -> 57 | (x, y) :: (zip xs1 ys1) 58 | 59 | let print print_x xs = 60 | let open Printf in 61 | let join_with sep terms = 62 | let _conc a b = a ^ b in 63 | let _sep = _conc sep in 64 | fold 65 | (fun _sep return -> return "") 66 | (fun term visit_terms sep return -> 67 | visit_terms _sep @@ fun terms1 -> 68 | return (sep (_conc term terms1))) 69 | terms identity identity 70 | in 71 | sprintf "[%s]" 72 | (join_with "; " 73 | (map print_x xs)) 74 | end 75 | 76 | module String = struct 77 | let epsi = "" 78 | let conc a b = a ^ b 79 | 80 | let make = String.make 81 | let get = String.get 82 | let sub = String.sub 83 | let length = String.length 84 | 85 | let fold null_case char_case term = 86 | let length = String.length term in 87 | let rec _visit index return = 88 | if length <= index then return null_case else 89 | _visit (index + 1) (compose return (char_case (String.get term index))) 90 | in 91 | _visit 0 identity 92 | 93 | let join terms = 94 | List.fold "" conc terms 95 | 96 | let join_with sep terms = 97 | let _sep = conc sep in 98 | List.fold 99 | (fun _sep return -> return "") 100 | (fun term visit_terms sep return -> 101 | visit_terms _sep @@ fun terms1 -> 102 | return (sep (conc term terms1))) 103 | terms identity identity 104 | 105 | let contain y xs = 106 | fold false 107 | (fun x result -> 108 | if result 109 | then result 110 | else x = y) 111 | xs 112 | 113 | let count y xs = 114 | fold 0 115 | (fun x result -> 116 | if x = y 117 | then result + 1 118 | else result) 119 | xs 120 | end 121 | -------------------------------------------------------------------------------- /util/lib/Infix.ml: -------------------------------------------------------------------------------- 1 | let (<==) f g x = f (g x) 2 | let (==>) f g x = g (f x) 3 | 4 | let (<<=) f g x y = f (g x y) 5 | let (=>>) f g x y = g (f x y) 6 | 7 | let () f g x = Option.map g (f x) 9 | 10 | let () f g x = Result.map g (f x) 12 | -------------------------------------------------------------------------------- /util/lib/Map.ml: -------------------------------------------------------------------------------- 1 | open Extra 2 | 3 | type ('key, 'value) map = (('key, 'value) data) AVL.tree 4 | and ('key, 'value) data = 5 | | Peek of 'key 6 | | Bind of 'key * 'value 7 | 8 | let make_peek key = Peek key 9 | let make_bind key value = Bind (key, value) 10 | 11 | let size = AVL.get_count 12 | 13 | let get_key data = 14 | match data with 15 | | Peek key -> key 16 | | Bind (key, _) -> key 17 | 18 | let get_value data fail return = 19 | match data with 20 | | Peek _ -> fail () 21 | | Bind (_, value) -> return value 22 | 23 | let get_value_unsafe data return = 24 | match data with 25 | | Peek _ -> assert false 26 | | Bind (_, value) -> return value 27 | 28 | let make = AVL.make_null 29 | 30 | let fold empty_case bind_case binds = 31 | List.fold empty_case 32 | (fun bind result -> 33 | match bind with 34 | | Peek _ -> assert false 35 | | Bind (key, value) -> 36 | bind_case key value result) 37 | (AVL.to_list binds) 38 | 39 | let map f binds = 40 | (AVL.from_list 41 | (List.map 42 | (fun bind -> 43 | match bind with 44 | | Peek _ -> assert false 45 | | Bind (key, value) -> 46 | Bind (key, f value)) 47 | (AVL.to_list binds))) 48 | 49 | let contains key_order = 50 | let _bind_order a b = key_order a (get_key b) in 51 | AVL.is_member _bind_order 52 | 53 | let insert_cont order key value binds return = 54 | let _data_order left right = order (get_key left) (get_key right) in 55 | AVL.insert_cont _data_order (make_bind key value) binds return 56 | 57 | let insert order key value binds = 58 | insert_cont order key value binds identity 59 | 60 | let remove_cont order key binds return = 61 | let _data_order left right = order (get_key left) (get_key right) in 62 | AVL.remove_cont _data_order (make_peek key) binds return 63 | 64 | let remove order key binds = 65 | remove_cont order key binds identity 66 | 67 | let lookup_cont order key binds fail return = 68 | let open AVL in 69 | let open Order in 70 | let rec _visit tree = 71 | match tree with 72 | | Null -> fail () 73 | | Node (_, _, data, left, right) -> 74 | begin match order key (get_key data) with 75 | | EQ -> get_value data fail return 76 | | LT -> _visit left 77 | | GT -> _visit right 78 | end 79 | in 80 | _visit binds 81 | 82 | let lookup order key binds = 83 | lookup_cont order key binds Option.make_none Option.make_some 84 | 85 | let lookup_unsafe_cont order key binds return = 86 | let open AVL in 87 | let open Order in 88 | let rec _visit tree = 89 | match tree with 90 | | Null -> assert false 91 | | Node (_, _, data, left, right) -> 92 | match order key (get_key data) with 93 | | EQ -> get_value_unsafe data return 94 | | LT -> _visit left 95 | | GT -> _visit right 96 | in 97 | _visit binds 98 | 99 | let lookup_unsafe order key binds = 100 | lookup_unsafe_cont order key binds identity 101 | 102 | let entries binds = 103 | List.map 104 | (fun bind -> 105 | match bind with 106 | | Peek _ -> assert false 107 | | Bind (key, value) -> key, value) 108 | (AVL.to_list binds) 109 | 110 | let keys binds = 111 | List.map 112 | (fun bind -> 113 | match bind with 114 | | Peek _ -> assert false 115 | | Bind (key, _) -> key) 116 | (AVL.to_list binds) 117 | 118 | let values binds = 119 | List.map 120 | (fun bind -> 121 | match bind with 122 | | Peek _ -> assert false 123 | | Bind (_, value) -> value) 124 | (AVL.to_list binds) 125 | 126 | let from_entries entries = 127 | AVL.from_list 128 | (List.map (fun (key, value) -> Bind (key, value)) 129 | entries) 130 | -------------------------------------------------------------------------------- /util/lib/Option.ml: -------------------------------------------------------------------------------- 1 | let make_none () = None 2 | let make_some x = Some x 3 | 4 | let is_none x = 5 | match x with 6 | | Some _ -> false 7 | | None -> true 8 | 9 | let is_some x = 10 | match x with 11 | | Some _ -> true 12 | | None -> false 13 | 14 | let map f x = 15 | match x with 16 | | Some x' -> Some (f x') 17 | | _ -> None 18 | 19 | let map2 f x y = 20 | match x, y with 21 | | Some x', Some y' -> Some (f x' y') 22 | | _, _ -> None 23 | 24 | let case none_case some_case x = 25 | match x with 26 | | None -> none_case 27 | | Some y -> some_case y 28 | -------------------------------------------------------------------------------- /util/lib/Order.ml: -------------------------------------------------------------------------------- 1 | type total = 2 | | EQ 3 | | LT 4 | | GT 5 | 6 | let total_order left right = 7 | if left = right then EQ else 8 | if left < right then LT else 9 | GT 10 | 11 | let int_compare a b = 12 | if a = b then EQ else 13 | if a < b then LT else 14 | GT 15 | -------------------------------------------------------------------------------- /util/lib/Result.ml: -------------------------------------------------------------------------------- 1 | type ('error, 'value) result = 2 | | Error of 'error 3 | | Value of 'value 4 | 5 | let make_error msg = Error msg 6 | let make_value value = Value value 7 | 8 | let map f result = 9 | match result with 10 | | Error error -> Error error 11 | | Value value -> Value (f value) 12 | -------------------------------------------------------------------------------- /util/lib/Set.ml: -------------------------------------------------------------------------------- 1 | open Extra 2 | 3 | type 'a set = 'a AVL.tree 4 | 5 | let make = AVL.make_null 6 | let is_empty set = (AVL.get_count set) = 0 7 | let is_member = AVL.is_member 8 | let get_member = AVL.get_member 9 | let size = AVL.get_count 10 | let add = AVL.insert 11 | let remove = AVL.remove 12 | let to_list = AVL.to_list 13 | let from_list = AVL.from_list 14 | 15 | let fold empty_case item_case set = 16 | List.fold empty_case item_case (to_list set) 17 | 18 | let union order xs ys = 19 | let open AVL in 20 | let open Order in 21 | let _cont k x xs = k (x :: xs) in 22 | let rec _visit xs ys return = 23 | match xs, ys with 24 | | [], _ -> return ys 25 | | _, [] -> return xs 26 | | x :: xs', y :: ys' -> 27 | match order x y with 28 | | EQ -> _visit xs' ys' (_cont return x) 29 | | LT -> _visit xs' ys (_cont return x) 30 | | GT -> _visit xs ys' (_cont return y) 31 | in 32 | from_list (_visit (to_list xs) (to_list ys) identity) 33 | 34 | let difference order xs ys = 35 | let open AVL in 36 | let open Order in 37 | let _cont k x xs = k (x :: xs) in 38 | let rec _visit xs ys return = 39 | match xs, ys with 40 | | [], _ | _, [] -> return xs 41 | | x :: xs', y :: ys' -> 42 | match order x y with 43 | | EQ -> _visit xs' ys' return 44 | | LT -> _visit xs' ys (_cont return x) 45 | | GT -> _visit xs' ys' (_cont return x) 46 | in 47 | from_list (_visit (to_list xs) (to_list ys) identity) 48 | 49 | let intersection order xs ys = 50 | let open AVL in 51 | let open Order in 52 | let _cont k x xs = k (x :: xs) in 53 | let rec _visit xs ys return = 54 | match xs, ys with 55 | | [], _ | _, [] -> return [] 56 | | x :: xs', y :: ys' -> 57 | match order x y with 58 | | EQ -> _visit xs' ys' (_cont return x) 59 | | LT -> _visit xs' ys return 60 | | GT -> _visit xs ys' return 61 | in 62 | from_list (_visit (to_list xs) (to_list ys) identity) 63 | 64 | let first values = AVL.get_leftmost values 65 | let first_unsafe values = 66 | match AVL.get_leftmost values with 67 | | None -> assert false 68 | | Some value -> value 69 | 70 | let last values = AVL.get_rightmost values 71 | let last_unsafe values = 72 | match AVL.get_rightmost values with 73 | | None -> assert false 74 | | Some value -> value 75 | -------------------------------------------------------------------------------- /util/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name util) 3 | (public_name bhrp.util) 4 | (libraries landmarks) 5 | (instrumentation (backend bhrp.landmarks))) 6 | -------------------------------------------------------------------------------- /util/test/Tests.ml: -------------------------------------------------------------------------------- 1 | (* Run tests *) 2 | let _ = 3 | QCheck_runner.run_tests [] 4 | -------------------------------------------------------------------------------- /util/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name Tests) 3 | (libraries 4 | qcheck 5 | landmarks 6 | bhrp.util) 7 | (instrumentation (backend bhrp.landmarks))) 8 | 9 | (rule 10 | (alias runtest) 11 | (action (run ./Tests.exe))) 12 | --------------------------------------------------------------------------------