[ { "path": ".github/workflows/ci.yml", "content": "name: CI\n\non:\n - pull_request\n - push\n\njobs:\n build:\n name: Build\n\n strategy:\n fail-fast: false\n matrix:\n os:\n - macos-latest\n - ubuntu-latest\n ocaml-compiler:\n - 4.11.x\n - 4.12.x\n - 4.13.x\n\n runs-on: ${{ matrix.os }}\n\n steps:\n - name: Checkout code\n uses: actions/checkout@v2\n\n - name: Setup OCaml ${{ matrix.ocaml-compiler }}\n uses: ocaml/setup-ocaml@v2\n with:\n ocaml-compiler: ${{ matrix.ocaml-compiler }}\n dune-cache: ${{ matrix.os != 'macos-latest' }}\n opam-depext-flags: --with-test\n\n - name: Setup Erlang\n if: ${{ matrix.os == 'macos-latest' }}\n run: brew install erlang\n\n - name: Install opam packages\n run: opam install . --deps-only --with-test\n\n - name: Build Sesterl\n run: opam exec -- make all\n\n - name: Run unit tests\n run: opam exec -- make test-unit\n\n - name: Run positive blackbox tests\n run: opam exec -- make test-blackbox-positive\n\n - name: Run negative blackbox tests\n run: opam exec -- make test-blackbox-negative\n\n - name: Upload compiler artifact\n if: ${{ matrix.ocaml-compiler == '4.13.x' }}\n uses: actions/upload-artifact@v2\n with:\n name: sesterl-${{ matrix.os }}\n path: sesterl\n" }, { "path": ".gitignore", "content": "_opam/\n_build/\n*~\n.merlin\n.DS_Store\nsesterl\n_generated/\n*.install\n_generated_test/\n" }, { "path": ".gitmodules", "content": "[submodule \"external/stdlib\"]\n\tpath = external/stdlib\n\turl = https://github.com/gfngfn/sesterl_stdlib\n[submodule \"external/testing\"]\n\tpath = external/testing\n\turl = https://github.com/gfngfn/sesterl_testing\n" }, { "path": "CHANGELOG.md", "content": "# Changelog\n\nAll notable changes to this project will be documented in this file.\n\nThe format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html).\n\n## [Unreleased]\n\n## [0.2.1] - 2021-12-12\n### Fixed\n- **Fix the precedence of arithmetic operators** ([PR\\#57](https://github.com/gfngfn/Sesterl/pull/57), which was encouraged by [Issue\\#56](https://github.com/gfngfn/Sesterl/issues/56) by @michallepicki).\n- **Fix the associativity of arithmetic operators** ([PR\\#68](https://github.com/gfngfn/Sesterl/pull/68), which was encouraged by [Issue\\#67](https://github.com/gfngfn/Sesterl/issues/67) by @michallepicki).\n\n### Added\n- Support OCaml 4.13 ([PR\\#50](https://github.com/gfngfn/Sesterl/pull/50) by @smorimoto).\n\n## [0.2.0] - 2021-10-03\n### Fixed\n- Allow test modules to be dependent on the main module ([PR\\#47](https://github.com/gfngfn/Sesterl/pull/47), which was encouraged by [Issue\\#19](https://github.com/gfngfn/Sesterl/issues/19) by @michallepicki).\n\n### Added\n- Add a new field `language` to the config file format ([PR\\#36](https://github.com/gfngfn/Sesterl/pull/36)).\n- Add the attribute `#[doc(...)]` for doc comments on declarations and equip the mechanism of the document generation ([PR\\#42](https://github.com/gfngfn/Sesterl/pull/42)).\n- Allow patterns for function parameters ([PR\\#45](https://github.com/gfngfn/Sesterl/pull/45)).\n- Allow `receive`-expressions to have `after`-branches ([PR\\#46](https://github.com/gfngfn/Sesterl/pull/46); **breaking change** due to a new keyword `after`).\n\n### Changed\n- Change the typing rules for records from a record polymorphism similar to that of SML\\# to a kind of row polymorphism ([PR\\#39](https://github.com/gfngfn/Sesterl/pull/39); **breaking change**).\n- Change the type for the hole `~s` in patterns from `list` to `binary` ([PR\\#33](https://github.com/gfngfn/Sesterl/pull/33); **breaking change**).\n- Omit the fallback mechanism for the old config file name `package.yaml` ([PR\\#40](https://github.com/gfngfn/Sesterl/pull/40); **breaking change**).\n- Change how to compile messages so that `GenServer` can provide `handle_timeout` ([\\PR#44](https://github.com/gfngfn/Sesterl/pull/44); **breaking change for FFIs**).\n- Reject `do`-expressions without binders ([PR\\#45](https://github.com/gfngfn/Sesterl/pull/45); **breaking change**).\n- Remove floating-point-number-related primitives ([PR\\#48](https://github.com/gfngfn/Sesterl/pull/48); **breaking change**).\n\n## [0.1.5] - 2021-08-14\n### Fixed\n- Fix an unsound type-checking behavior about record kinds ([PR\\#35](https://github.com/gfngfn/Sesterl/pull/35)).\n\n## [0.1.4] - 2021-07-15\n### Changed\n- Rename configuration files from `package.yaml` to `sesterl.yaml` while providing a fallback mechanism ([PR\\#32](https://github.com/gfngfn/Sesterl/pull/32) by @michallepicki).\n\n## [0.1.3] - 2021-07-11\n### Fixed\n- Fix how to load test dependencies.\n- Fix how to output string/binary literals about non-ASCII characters ([PR\\#22](https://github.com/gfngfn/Sesterl/pull/22) by @michallepicki).\n- Update GitHub Actions workflow ([PR\\#12](https://github.com/gfngfn/Sesterl/pull/12) by @smorimoto).\n- Fix how to check type definitions ([PR\\#30](https://github.com/gfngfn/Sesterl/pull/30)).\n- Fix how to perform the universal quantification ([PR\\#31](https://github.com/gfngfn/Sesterl/pull/31)).\n\n### Added\n- Add binary literal patterns ([PR\\#28](https://github.com/gfngfn/Sesterl/pull/28)).\n- Support fully-annotated polymorphic recursion ([PR\\#31](https://github.com/gfngfn/Sesterl/pull/31)).\n\n## [0.1.2] - 2021-05-29\n### Added\n- Introduce the notion of attributes of the form `#[foo(…)]`.\n- Introduce attributes `#[test]`, `#[behavior(…)]`, and `#[atom(…)]`.\n- Add the syntax `assert e` for tracking code positions in unit tests.\n- Separate test dependencies from dependencies.\n- Collaborate with EUnit.\n- Add the syntax `open M`.\n\n### Changed\n- Change how to compile `None` and `Some` (**breaking change for FFIs**).\n\n### Fixed\n- Largely fix the type-checking algorithm (mainly about how to track type synonyms).\n- Fix how to treat relative paths given via command lines.\n\n## [0.1.1] - 2021-05-16\n### Added\n- Add the syntax sugar of list patterns.\n- Add patterns of the form `Module.Constructor`.\n- Add the variant type `result`.\n- Add first-class modules based on the formalization of F-ing modules.\n- Add option `-p` for specifying paths of external packages, which will be used mainly for the collaboration with Rebar3.\n\n### Changed\n- Change output module names from `foo_bar_baz.erl` to `Foo.Bar.Baz.erl` (**breaking change for FFIs**).\n\n### Fixed\n- Fix the parser about unit patterns and Boolean patterns.\n- Quote global names in order to avoid clashes with keywords.\n\n## [0.1.0] - 2021-05-02\n### Added\n- Develop the collabration with Rebar3.\n- Add the command line `sesterl config ` for generating `rebar.config`.\n\n### Changed\n- Change the command line spec from `sesterl -o ` to `sesterl build -o `.\n- Change the syntax of effect types from `[τ]τ` to `fun(τ, …, τ) -> [τ]τ` (**breaking change**).\n- Separate the syntax of expressions and that of computations by using the newly introduced keyword `act` (**breaking change**).\n\n## 0.0.1 - 2020-10-29\n\nThe initial release\n\n\n [Unreleased]: https://github.com/gfngfn/Sesterl/compare/v0.2.1...HEAD\n [0.2.1]: https://github.com/gfngfn/Sesterl/compare/v0.2.0...v0.2.1\n [0.2.0]: https://github.com/gfngfn/Sesterl/compare/v0.1.5...v0.2.0\n [0.1.5]: https://github.com/gfngfn/Sesterl/compare/v0.1.4...v0.1.5\n [0.1.4]: https://github.com/gfngfn/Sesterl/compare/v0.1.3...v0.1.4\n [0.1.3]: https://github.com/gfngfn/Sesterl/compare/v0.1.2...v0.1.3\n [0.1.2]: https://github.com/gfngfn/Sesterl/compare/v0.1.1...v0.1.2\n [0.1.1]: https://github.com/gfngfn/Sesterl/compare/v0.1.0...v0.1.1\n [0.1.0]: https://github.com/gfngfn/Sesterl/compare/v0.0.1...v0.1.0\n" }, { "path": "Makefile", "content": ".PHONY: all\nall:\n\tdune build -p sesterl\n\tcp _build/default/src/main.exe ./sesterl\n\n.PHONY: test\ntest: test-blackbox-positive test-blackbox-negative test-unit\n\n.PHONY: test-unit\ntest-unit:\n\tdune exec test/testRange.exe\n\tdune exec test/testLanguageVersion.exe\n\tdune exec test/testIdentifierScheme.exe\n\n.PHONY: test-blackbox-positive\ntest-blackbox-positive: submodule\n\t./run-positive-blackbox-tests.sh\n\n.PHONY: test-blackbox-negative\ntest-blackbox-negative: submodule\n\t./run-negative-blackbox-tests.sh\n\n.PHONY: submodule\nsubmodule:\n\tgit submodule update --init --recursive\n\n.PHONY: clean\nclean:\n\tdune clean\n\n.PHONY: clean-test\nclean-test:\n\trm -f test/_generated/*\n" }, { "path": "README.md", "content": "# Sesterl: A Session-Typed Erlang\n\n## Summary\n\n*Sesterl* (pronounced as /səsˈtɚːl/) is an ML-like statically-typed functional language that is intended to compile to Erlang. Contrary to its name, Sesterl has not supported session types yet; it only checks the type of messages every process can receive. As mentioned in the section “[Features](#features)” below, however, many features as a typed functional language have already been furnished. Among them are the following:\n\n* First-class higher-order functions\n* ADTs and pattern matching\n* The standard *Damas–Milner polymorphism* (i.e. so-called the *let-polymorphism*) and *Hindley–Milner type inference* \\[Hindley 1969\\]\\[Milner 1978\\]\n* Type-level distinction between pure calculations and concurrent computations by a kind of monads \\[Fowler 2019\\]\n* A module system equipped with functors and first-class modules based on *F-ing modules* \\[Rossberg, Russo & Dreyer 2014\\]\n\n\n## Table of contents\n\n- [How to install](#how-to-install)\n- [How to build source files for development](#how-to-build-source-files-for-development)\n- [How to use](#how-to-use)\n- [Example code](#example-code)\n- [Libraries](#libraries)\n- [Features](#features)\n - [Function definition](#function-definition)\n - [Polymorphism](#polymorphism)\n - [ADTs](#adts)\n - [Pattern matching](#pattern-matching)\n - [Concurrency](#concurrency)\n - [Module system](#module-system)\n - [OTP as functors](#otp-as-functors)\n - [FFI](#ffi)\n - [Labeled optional parameters](#labeled-optional-parameters)\n - [Labeled mandatory parameters](#labeled-mandatory-parameters)\n - [Records](#records)\n - [Doc comments](#doc-comments)\n - [Writing tests](#writing-tests)\n- [Major differences from similar projects](#major-differences-from-similar-projects)\n- [Future work](#future-work)\n - [TODO list](#todo-list)\n- [Configuration file format](#configuration-file-format)\n- [Overall syntax](#overall-syntax)\n- [References](#references)\n\n\n## How to install\n\nUnder the condition that Dune (≥ 2.5) and OPAM are installed, invoke:\n\n```console\n$ git clone https://github.com/gfngfn/Sesterl.git\n$ cd Sesterl\n$ opam pin add sesterl .\n # Probably this command asks you whether to install the package (and its dependencies).\n # You may answer Y to do so.\n$ sesterl --version\n```\n\n\n## How to build source files for development\n\nUnder the condition that Dune (≥ 2.5) and Make are installed, invoke:\n\n```\n$ opam install . --deps-only --with-test\n$ make\n```\n\n\n## How to use\n\n### Building a single source file\n\nInvoke:\n\n```console\n$ sesterl build -o \n```\n\nwhere `` is the path to the source file you want to build (e.g. `trial/hello_world.sest`), and `` is the directory where Erlang source files will be generated (e.g. `trial/_generated`).\n\n\n### Building with Rebar3\n\n[*Rebar3*](https://github.com/erlang/rebar3) is a popular build system for Erlang programs. Sesterl can collaborate with Rebar3.\n\nBased on a configuration file (i.e., `sesterl.yaml`), the following command will generate `rebar.config`:\n\n```console\n$ sesterl config ./\n```\n\nThen you can invoke the following command to compile Sesterl programs before Rebar3 compiles Erlang code:\n\n```console\n$ rebar3 sesterl compile\n```\n\nHere, `sesterl` is a name space of Rebar3 commands for compiling Sesterl programs, and is introduced by plugin [`rebar_sesterl`](https://github.com/gfngfn/rebar_sesterl_plugin).\n\nRunning unit tests (by using [*EUnit*](http://erlang.org/doc/apps/eunit/chapter.html)) can be done by the following:\n\n```console\n$ rebar3 sesterl test\n```\n\n\n## Example code\n\nExample usages can be seen in the following:\n\n* [`examples/` in this repository](https://github.com/gfngfn/Sesterl/tree/master/examples)\n* [`test/pass/` in this repository](https://github.com/gfngfn/Sesterl/tree/master/test/pass)\n* [`game_tianjiupai`](https://github.com/gfngfn/game_tianjiupai)\n\n\n## Libraries\n\n* [`sesterl_stdlib`](https://github.com/gfngfn/sesterl_stdlib)\n - The standard library for Sesterl.\n - Contains modules for manipulating basic values and collections (e.g. `Binary`, `List`).\n - Contains modules for constructing OTP-compliant processes (e.g. `GenServer`, `Supervisor`).\n* [`sesterl_testing`](https://github.com/gfngfn/sesterl_testing)\n - A testing library for Sesterl.\n - Uses [*EUnit*](http://erlang.org/doc/apps/eunit/chapter.html).\n - Tests written by this module can be run by `rebar3 sesterl test`.\n* [`sesterl_json`](https://github.com/gfngfn/sesterl_json)\n - A JSON-handling library.\n - Has APIs similar to those of Elm’s [`elm/json`](https://package.elm-lang.org/packages/elm/json/latest/).\n - Uses [*jsone*](https://github.com/sile/jsone) internally.\n* [`sesterl_cowboy`](https://github.com/gfngfn/sesterl_cowboy)\n - A small wrapper for [*Cowboy*](https://github.com/ninenines/cowboy).\n\n\n## Features\n\nSesterl provides many ML-inspired features (i.e. basically resembles OCaml, Standard ML, F\\#, ReScript, etc.).\n\n\n### Function definition\n\nTop-level (resp. local) functions are defined by `val`-bindings (resp. `let`-expressions):\n\n```\nval add(x, y) = x + y\n\nval add_partial(x) =\n let f(y) = x + y in f\n```\n\nUnlike ML family, however, in order to realize seemless compilation to top-level function definitions in Erlang, functions have their own arity (i.e. not curried by nature) and thereby have types of the form `fun(τ_1, …, τ_n) -> τ`. The function `add` defined above, for instance, has type `fun(int, int) -> int`, which is **NOT** equivalent to the type of `add_partial`, i.e., `fun(int) -> (fun(int) -> int)`.\n\nBy using `fun`-expressions (i.e. *lambda abstractions*), `add_partial` can also be defined as follows:\n\n```\nval add_partial(x) =\n fun(y) -> x + y end\n```\n\nIncidentally, you do not have to annotate types of arguments or return values; they will be reconstructed by standard *Hindley–Milner type inference*. you can nonetheless add type annotations like the following:\n\n```\nval add(x : int, y : int) : int = x + y\n```\n\nYou can define higher-order functions, of course:\n\n```\nval apply(f, x) = f(x)\n```\n\nAs is the case in ML, `apply` has a polymorphic type. Features related to type polymorphism is explained later.\n\nRecursive or mutually recursive functions can be defined by using `rec`/`and` keywords, not only globally but also in a local scope:\n\n```\nval rec fact(n) =\n if n <= 0 then 1 else n * fact(n - 1)\n\nval is_even_nat(n) =\n let rec odd(n) =\n if n == 0 then false else even(n - 1)\n\n and even(n) =\n if n == 0 then true else odd(n - 1)\n in\n if n < 0 then false else even(n)\n```\n\nNote that, unlike Erlang, function names are all lowercased regardless of whether they are defined in the global scope or in a local one. You can also write, for example, `apply(fact, 6)`; each name of globally-defined functions can be used for the function value the name is bound to, just as locally defined function names can be. This is different from the situation in Erlang, where a globally-defined function name by itself will be interpreted as an atom of the same text.\n\n\n### Polymorphism\n\nValues defined by `val`, `val rec`, `let`, or `let rec` can be polymorphic. For instance, the function `proj1` defined as follows has type `<$a, $b> fun($a, $b) -> $a` (where `<$a, $b>` stands for universal quantification):\n\n```\nval proj1(x, y) = x\n```\n\nInstead of relying upon type inference, you can also annotate polymorphic types and check that the defined function is indeed polymorphic:\n\n```\nval proj1<$a, $b>(x : $a, y : $b) : $a = x\n```\n\n\n### ADTs\n\nYou can define (non-generalized) algebraic data types and type synonyms in a standard way like the following:\n\n```\ntype name = binary\n\ntype with_number<$a> = {$a, int}\n\ntype bintree<$b> =\n | Node($b, bintree<$b>, bintree<$b>)\n | Empty\n```\n\nHere, `{$a, int}` is an example use of standard product types.\n\nAs can be seen from the example above, type names start with a lowercase letter, constructors do with an uppercase one, and type variables are denoted by using a preceding `$`.\n\nEach application of a constructor `Ctor(e_1, …, e_n)` will be compiled to a tuple `{ctor, e_1, …, e_n}` in Erlang where `ctor` is basically a lowercased atom corresponding to `Ctor`. You can, however, change what atoms are generated for constructors by using `#[atom(...)]` attribute:\n\n```\ntype bintree<$b>\n | #[atom(\"branch\")] Node($b, bintree<$b>, bintree<$b>)\n | #[atom(\"leaf\")] Empty\n```\n\nList-generating constructors, `[]` (nil) and `::` (cons), are also supported by default. Optionals are also provided by default as follows:\n\n```\ntype option<$a> =\n | #[atom(\"error\")] None\n | #[atom(\"ok\")] Some($a)\n```\n\n\n### Pattern matching\n\nYou can decompose values of ADTs by using `case`-expressions in an ordinary way like the following:\n\n```\nval reverse<$a>(xs : list<$a>) : list<$a> =\n let rec aux(acc, xs) =\n case xs of\n | [] -> acc\n | x :: tail -> aux(x :: acc, tail)\n end\n in\n aux([], xs)\n\nval rec tree_size<$a>(t : bintree<$a>) =\n case t of\n | Empty -> 0\n | Node(_, t1, t2) -> 1 + tree_size(t1) + tree_size(t2)\n end\n```\n\n\n### Concurrency\n\nAs in Erlang, you can use primitives `self`, `send`, and `spawn` for message-passing concurrency. They are given types by using a kind of monadic function types `fun(τ_1, …, τ_n) -> [τ]τ'` and types `pid<τ>` for PIDs (i.e. process identifiers) as follows:\n\n* `self<$p> : fun() -> [$p]pid<$p>`\n* `send<$p, $q> : fun(pid<$q>, $q) -> [$p]unit`\n* `spawn<$p, $q> : fun(fun() -> [$q]unit) -> [$p]pid<$q>`\n\nIntuitively, `[τ]τ'` in `fun(τ_1, …, τ_n) -> [τ]τ'` stands for concurrent computations that will be run on processes capable of receiving messages of type `τ` and that finally produce a value of type `τ'`. The composition of such computations can be done by `do`-notation. Messages can be received by using `receive`-expressions. See a small example below:\n\n```\nmodule Example = struct\n\n /* dummy */\n val some_heavy_calculation(n) =\n n\n\n val rec wait_all(msgacc, n) = act\n if n <= 0 then\n return(msgacc)\n else\n receive\n | {pid, msg} ->\n let _ = print_debug(format(f'message ~p received from: ~p~n', {msg, pid})) in\n wait_all(msg :: msgacc, n - 1)\n end\n\n val rec spawn_all(pidacc, n) = act\n if n <= 0 then\n return(pidacc)\n else\n do parent <- self() in\n do pid <-\n spawn(fun() -> act\n do me <- self() in\n let msg = some_heavy_calculation(n) in\n send(parent, {me, msg})\n end)\n in\n spawn_all(pid :: pidacc, n - 1)\n\n val main(arg) = act\n let n = 10 in\n do pids <- spawn_all([], n) in\n let _ = print_debug(format(f'spawned: ~p~n', {pids})) in\n do msgs <- wait_all([], n) in\n let _ = print_debug(msgs) in\n return({})\n\nend\n```\n\nHere, the primitive `return<$p, $a> : fun($a) -> [$p]$a` lifts a pure value to the computation that has no effect and simply returns the value.\n\nThe function `spawn_all` takes an integer `n`, spawns `n` processes that perform some heavy calculation in parallel, and returns their PIDs. `wait_all`, on the other hand, waits all the messages sent from the processes spawned by `spawn_all` and makes a list of the received messages. These functions are typed as follows, supposing `some_heavy_calculation` is of type `fun(int) -> answer`:\n\n* `spawn_all<$p, $q> : fun(list>, int) -> [$p]list>`\n* `wait_all<$q> : fun(list, list>) -> [{pid<$q>, answer}]list`\n\nAs mentioned earlier, supporting session types is an important future work. One possible way of supporting session types would be adopting types of the form `[S]τ` where `S` is a session type by using theories like \\[Orchard & Yoshida 2016\\].\n\n\n### Module system\n\nOne of the Sesterl’s largest features is the support for a subset of *F-ing modules* \\[Rossberg, Russo & Dreyer 2014\\], where kinds and functors are restricted to first-order (i.e., type constructors cannot take type constructors as arguments and functors cannot take functors as arguments). For example, Sesterl can type-check the following definition of modules and functors:\n\n```\n/* mod.sest */\n\nmodule Mod = struct\n\n signature Ord = sig\n type s :: o\n val compare : fun(s, s) -> int\n end\n\n module Map = fun(Elem : Ord) ->\n struct\n type elem = Elem.s\n type t<$a> = list<{elem, $a}>\n val rec find<$b>(x : elem, assoc : t<$b>) : option<$b> =\n case assoc of\n | [] ->\n None\n\n | {k, v} :: tail ->\n if Elem.compare(k, x) == 0 then\n Some(v)\n else\n find(x, tail)\n end\n end\n\n module Int = struct\n type s = int\n val compare(x : int, y : int) = y - x\n end\n\n module IntMap = Map(Int)\n\nend\n```\n\nThe program above is compiled to the following Erlang modules (where line breaks and indentation are manually added for clarity):\n\n```erlang\n-module('Mod.Int').\n-export([compare/2]).\n\ncompare(S13X, S14Y) -> (S14Y - S13X).\n```\n\n```erlang\n-module('Mod.IntMap').\n-export([find/2]).\n\nfind(S17X, S18Assoc) ->\n case S18Assoc of\n [] ->\n error;\n\n [{S19K, S20V} | S21Tail] ->\n case ('Mod.Int':compare(S19K, S17X) == 0) of\n true -> {ok, S20V};\n false -> 'Mod.IntMap':find(S17X, S21Tail)\n end\n end.\n```\n\nNote that nested modules are flattened and given names of the form `'.. ... .'` where each `` is a module identifier.\n\nWhat is more important here is that functors are eliminated *at compilation time*. This is realized by the technique of so-called the *static interpretation* \\[Elsman, Henriksen, Annenkov & Oancea 2018\\].\n\n\n### OTP as functors\n\nOne of the interesting use cases of the module system is to represent OTP libraries by using functors; for example, `gen_server` can be represented by a functor that takes the callback functions (such as `init/1` or `handle_cast/3`) and related types and that returns modules that contains the specialized version of functions provided by `gen_server` (such as `cast/2`, `call/3`, `start_link/1`, etc.). The functor `GenServer.Make` defined in `sesterl_stdlib` as follows represents principal functionalities of `gen_server`:\n\n```\nmodule GenServer : sig\n\n type initialized :: (o) -> o\n val init_ok<$msg, $state> : fun($state) -> [$msg]initialized<$state>\n val init_stop<$msg, $state> : fun(StopReason.t) -> [$msg]initialized<$state>\n type reply :: (o, o, o) -> o\n val reply<$msg, $response, $state> :\n fun($response, $state, ?timeout int) -> [$msg]reply<$msg, $response, $state>\n val reply_and_stop<$msg, $response, $state> :\n fun(StopReason.t, $response, $state) -> [$msg]reply<$msg, $response, $state>\n type no_reply :: (o) -> o\n val no_reply<$msg, $state> : fun($state, ?timeout int) -> [$msg]no_reply<$state>\n val no_reply_and_stop<$msg, $state> : fun(StopReason.t, $state) -> [$msg]no_reply<$state>\n type start_link_error = RawValue.t\n type call_error = RawValue.t\n\n signature Behaviour = sig\n type init_arg :: o\n type request :: o\n type response :: o\n type cast_message :: o\n type info :: o\n type state :: o\n type global :: o\n val init : fun(init_arg) -> [info]initialized\n val handle_call<$a> : fun(request, pid<$a>, state) -> [info]reply\n val handle_cast : fun(cast_message, state) -> [info]no_reply\n val handle_info : fun(info, state) -> [info]no_reply\n val handle_timeout : fun(state) -> [info]no_reply\n val handle_down<$a> : fun(MonitorRef.t, pid<$a>, StopReason.t, state) -> [info]no_reply\n val terminate : fun(StopReason.t, state) -> [info]unit\n end\n\n module Make : fun(Callback : Behaviour) -> sig\n type proc :: o\n val as_pid : fun(proc) -> pid\n val from_pid : fun(pid) -> proc\n val call<$a> : fun(proc, Callback.request, ?timeout int) -> [$a]result\n val cast<$a> : fun(proc, Callback.cast_message) -> [$a]unit\n val send_info<$a> : fun(proc, Callback.info) -> [$a]unit\n val start_link<$a> : fun(Callback.init_arg) -> [$a]result\n val start_link_name<$a> : fun(Callback.init_arg, -name name) -> [$a]result\n val where_is_local<$a> : fun(binary) -> [$a]option\n val where_is_global<$a> : fun(Callback.global) -> [$a]option\n val stop<$a> : fun(proc) -> [$a]unit\n end\nend\n```\n\n\n### FFI\n\nFunctions written in Erlang can be called from Sesterl via FFI (foreign function interface) as follows:\n\n````\nmodule FfiExample = struct\n\n val assoc<$a> : fun(int, list<(int, $a)>) -> option<($a, list<(int, $a)>)> = external 2 ```\nassoc(Key, Xs) ->\n case lists:keytake(Key, 1, Xs) of\n false -> error;\n {value, {_, V}, Rest} -> {ok, {V, Rest}}\n end.\n ```\n\n val main() =\n assoc(1, [\n (3, \"Komaba\"),\n (1, \"Hongo\"),\n (4, \"Yayoi\"),\n (1, \"Asano\"),\n (5, \"Kashiwa\")\n ])\n\nend\n````\n\nThis program compiles to the following implementation:\n\n```erlang\n-module('FfiExample').\n-export([assoc/2, main/0]).\n\nassoc(Key, Xs) ->\n case lists:keytake(Key, 1, Xs) of\n false -> error;\n {value, {_, V}, Rest} -> {ok, {V, Rest}}\n end.\n\nmain() ->\n 'FfiExample':assoc(1, [\n {3, <<\"Komaba\">>},\n {1, <<\"Hongo\">>},\n {4, <<\"Yayoi\">>},\n {1, <<\"Asano\">>},\n {5, <<\"Kashiwa\">>}]).\n```\n\n\n### Labeled optional parameters\n\nFunctions can have labeled optional parameters:\n\n```\nval succ(n : int, ?diff dopt : option) =\n case dopt of\n | None -> n + 1\n | Some(d) -> n + d\n end\n\nval f(g) =\n {g(36), g(36, ?diff 64)}\n\nval main() =\n {succ(42), succ(42, ?diff 15), f(succ)}\n /* This evaluates to {43, 57, {37, 100}} in Erlang. */\n```\n\nIn this example, `?diff` is a label for an optional parameter. By not giving a `?diff`-labeled argument you can use `succ` as the standard successor function, while by giving one you can use `succ` as the integer addition function.\n\nThe functions `succ` and `f` defined above are given types as follows:\n\n```\nval succ : fun(int, ?diff int) -> int\nval f<$a, ?$r :: (diff)> : fun(fun(int, ?diff int, ?$r) -> $a) -> ($a, $a)\n```\n\nHere, `?diff int` signifies that `succ` can take a `?diff`-labeled optional argument of type `int`, and the absense of other labels in the same domain means that `succ` cannot take optional arguments with labels other than `?diff`.\n\n`?$r :: (diff)` is a *row variable* with its kind; it can be instantiated with any rows that do NOT contain the label `diff`; kinds for row variables stand for the prohibited set of labels. This is based on an original type system that resembles record polymorphism \\[Gaster & Jones 1996\\] (The type system is currently not documented anywhere).\n\n\n### Labeled mandatory parameters\n\nYou can also use labeled mandatory parameters/arguments:\n\n```\nval rec foldl(-f f, -init init, -list xs) =\n case xs of\n | [] -> init\n | y :: ys -> foldl(-init f(init, y), -list ys, -f f)\n end\n```\n\nHere, `-f`, `-init`, and `-list` are labels for mandatory parameters. Note the order in which labeled arguments are applied is not necessarily the same as that in which labeled parameters are defined. The function `foldl` defined above is typed as follows:\n\n```\nval fold<$a, $b> :\n fun(\n -f fun($a, $b) -> $a,\n -init $a,\n -list list<$b>,\n ) -> $a\n```\n\nYou can use non-labeled parameters (resp. arguments) and labeled ones for the same function. At least currently, however, their order must be:\n\n1. (possibly empty) non-labeled parameters (resp. arguments),\n2. (possibly empty) labeled mandatory ones, and\n3. (possibly empty) labeled optional ones.\n\nIn other words, abstractions (resp. applications) must be of the following form:\n\n```\nfun(param1, …, paramL, -m1 mparam1, … -mM mparamM, ?o1 oparam1, … ?oN oparamN) -> …\n\nf(arg1, …, argL, -m1 marg1, … -mM margM, ?o1 oarg1, … ?oN oargN)\n```\n\n\n### Records\n\nA *record* is a labeled tuple that has the following syntax:\n\n```\n{foo = 42, bar = true}\n```\n\nLabels should be distinct from each other in one record value. The expression above has the following type:\n\n```\n{foo : int, bar : bool}\n```\n\nYou can also extract values from records as follows:\n\n```\nlet r = {foo = 42, bar = true} in\nr.foo /* => 42 */\n```\n\nIn Sesterl, operations for records are made polymorphic by using the type system for extensible rows \\[Gaster & Jones 1996\\]. For example, consider the function definition below:\n\n```\nval get_foo(x) = x.foo\n```\n\nThe function `get_foo` is typed like the following:\n\n```\nval get_foo<$a, ?$r :: (foo)> : fun({foo : $a, ?$r}) -> $a\n```\n\nHere, `(foo)` is the kind for row variables that does NOT contain the label `foo`, similar to ones used for optional parameters. Thanks to the constraint expressed by the kind, `{foo : $a, ?$r}` can be instantiated by `{foo : int, bar : bool}`, `{foo : int, baz : binary}`, and so on, but not by `{bar : bool}` etc. Then, for instance, the following program is well-typed:\n\n```\nval main() =\n get_foo({foo = 42, bar = true})\n```\n\nand the following is ill-typed on the other hand:\n\n```\nval main() =\n get_foo({bar = true})\n```\n\nNote: Prior to Sesterl 0.2.0, polymorphic typing for records was based on the one used in *SML\\#* \\[Ohori 1995\\].\n\n\n### Doc comments\n\nYou can add doc comments to members in signatures by using `#[doc(String)]` attribute where `String` is an arbitrary string literal containing a text in Markdown:\n\n````\nmodule List :> sig\n ...\n\n #[doc(```\n `map f [v_1, …, v_n]` applies function `f` to each `v_i` in the given order,\n and builds the list [f v_1, …, f v_n] with the results produced by `f`.\n ```)]\n val map<$a, $b> : fun(fun($a) -> $b, list<$a>) -> list<$b>\n\n ...\nend = struct\n ...\nend\n````\n\n(Note: The outermost triple back ticks in the example above are NOT included in Markdown contents; they just start/terminate the string literal as double quotes do. If you want to use triple back ticks in Markdown contents to display code blocks, you can use quadruple back ticks for enclosing string literals.)\n\nYou can, for example, generate documents `./_docs/your_package.html` by specifying the following description in your configuration file:\n\n```yaml\ndocument_outputs:\n - format:\n type: \"html\"\n output_directory: \"./_doc\"\n```\n\n\n## Writing tests\n\nYou can write test modules like the following:\n\n```\n./\n├── README.md\n├── sesterl.yaml\n├── rebar.config\n├── rebar.lock\n├── src/\n│   └── Adder.sest\n└── test/\n └── AdderTests.sest\n```\n\n`sesterl.yaml`:\n\n```\npackage: \"adder\"\nlanguage: \"v0.2.0\"\nsource_directories:\n - \"./src\"\nmain_module: \"Adder\"\ntest_directories:\n - \"./test\"\n```\n\n`src/Adder.sest`:\n\n```\nmodule Adder = struct\n\n val add(m, n) = m + n\n\nend\n```\n\n`test/AdderTests.sest`:\n\n```\nimport Adder\n\nmodule AdderTests = #[test] struct\n\n #[test]\n val adder_test() =\n Testing.it(\"42 plus 57 equals 99\", fun() ->\n assert Testing.equal(\n -expect 99,\n -got Adder.add(42, 57),\n )\n end)\n\nend\n```\n\nThe following makes the test run:\n\n```\n$ sesterl config ./\n$ rebar3 sesterl test\n```\n\n\n## Major differences from similar projects\n\nThere have been brilliant functional languages that compile to Erlang or BEAM (i.e. bytecode for Erlang VM). Some of them are the following:\n\n* [*Elixir*](https://elixir-lang.org/) \\[Valim et al. 2011–2021\\]\n - Definitely the most well-known AltErlang language, and well-used in productions.\n - Compiles to Erlang AST.\n - Untyped (i.e. dynamically typed).\n - Has Ruby-like syntax.\n - Supports Lisp-like meta-programming features by quoting/unquoting.\n* [*Alpaca*](https://github.com/alpaca-lang/alpaca) \\[Pierre et al. 2016–2019\\]\n - Statically typed.\n - Compiles to Core Erlang compiler IR.\n - Has static guarantee about types of messages sent or received between processes.\n - Has OCaml- or Elm-like syntax.\n - Implemented in Erlang.\n* [*Gleam*](https://github.com/gleam-lang/gleam) \\[Pilfold et al. 2018–2021\\]\n - Statically typed.\n - Compiles to sources in Erlang.\n - Has Rust-like syntax.\n - Implemented in Rust.\n\nMajor differences between the features of Sesterl and those of the languages above are:\n\n* an ML-like module system that supports:\n - abstraction by using signatures, and\n - functors and their elimination at compilation time (called the *static interpretation* \\[Elsman, Henriksen, Annenkov & Oancea 2018\\]);\n* a kind of monadic types for distinguishing pure calculations from concurrent computations.\n\nAlso, though not supporting them currently, we want to add features like the following (see “[Future work](#future-work)” for detail):\n\n* GADTs for typing synchronous message-passing operations more strictly.\n* Session types in a gradually-typed manner.\n\n\n## Future work\n\n* Support recursive modules.\n* Support GADTs.\n - This is mainly for typing `gen_server` callbacks as to synchronous messages.\n - The formalization of such a type system and a type inference algorithm will probably be based on *choice types* \\[Chen & Erwig 2016\\].\n* Support (multiparty) session types.\n - Type checking based on session types may well be optional or something like gradual types. This is because message passing is quite frequent in typical uses of Erlang-style concurrency and thereby strict assertion for sessions may rather complicate in the short term how to program concurrent computations.\n\n\n### TODO list\n\n* [ ] Message-passing primitives\n * [x] `spawn`\n * [x] `receive`-expressions\n * [x] `send`\n * [x] `self`\n * [x] `MonitorRef.monitor<$a, $b> : fun(pid<$b>) -> [$a]MonitorRef.t`\n * [x] `MonitorRef.demonitor<$a> : fun(MonitorRef.t) -> [$a]unit`\n * [ ] Special message `down(MonitorRef.t, StopReason.t)` representing `{'DOWN', MRef, process, Pid, Reason}`\n * [ ] `link<$a, $b> : fun(pid<$b>) -> [$a]unit`\n * [ ] `unlink<$a, $b> : fun(pid<$b>) -> [$a]unit`\n* [x] Principal type inference\n* [x] Type annotation\n* [x] Output Erlang code\n* [x] FFI\n* [ ] Data types\n * [x] Strings (as lists of code points)\n * [x] Binaries\n * [x] Monitoring references `MonitorRef.t`\n * [ ] Unique references\n * [x] Product types\n * [x] Lists\n * [x] User-defined ADTs\n * [x] Type synonyms\n * [x] Records\n * [x] Functions with labeled optional parameters\n * [x] Functions with labeled mandatory parameters\n * [ ] GADTs (especially for typing synchronous messages)\n* [x] Mutual recursion by generalized `val rec`-expressions\n* [ ] Pattern matching\n * [x] `case`-expressions\n * [x] Generalized `let`-expressions\n * [ ] Exhaustiveness check\n* [x] Module system\n * [x] Support for F-ing modules\n * [x] Compilation using the static interpretation\n * [x] First-class modules\n* [x] Configuration\n * [x] Loading external modules by `import`\n * [x] Package system\n * [x] Embedding external modules as submodules\n * [x] Connection with Rebar3\n* [ ] (Multiparty) session types\n\n\n## Configuration file format\n\nConfiguration files must be of the following form. Although configuration files are in the YAML format, their specification is described here by using JSON-like expressions for clarity of the structure:\n\n```\nConfig := {\n package: String\n # The name of the package. Example: \"sesterl_json\"\n\n language: String\n # The minimum version of Sesterl required by the package.\n # Example: \"v0.2.0\"\n # The Sesterl compiler refers to this field for checking that\n # the compiler is backward-compatible with the required version.\n # This field is optional. No check will be performed if omitted.\n\n source_directories: Array\n # The list of directories where source files are placed.\n # All the source files (i.e. files that have\n # \".sest\", \".erl\", or \".app.src\" as their extension)\n # that are exactly at one of the specified directories will be used for compilation.\n # Specified directories must be relative to the configuration file.\n # Example: [ \"./src\", \"./src/generated\" ]\n\n main_module: String\n # The name of the main module of the package.\n # The *main module* of a package is defined to be\n # the sole module visible from the outside of the package.\n\n test_directories: Array\n # The list of directories where test files are placed.\n # Specified directories must be relative to the configuration file.\n # This field is optional. Default: []\n # Example: [ \"./test\" ]\n\n dependencies: Array\n # This field is optional. Default: []\n\n test_dependencies: Array\n # This field is optional. Default: []\n\n erlang: ErlangConfig\n # This field is optional. Default: {}\n\n document_outputs: Array\n # Settings for the document generation.\n # This field is optional. Default: []\n}\n\nDependency := {\n name: String\n # The name of the dependency.\n\n source: (GitSource | LocalSource)\n # Describes how to get the dependency.\n}\n\nGitSource := {\n type: \"git\"\n\n repository: String\n # The URI of the Git repository.\n\n spec: (TagSpec | RefSpec | BranchSpec)\n # Describes which commit to use.\n}\n\nTagSpec := {\n type: \"tag\"\n value: String # Example: \"v1.3.0\"\n}\n\nRefSpec := {\n type: \"ref\"\n value: String # A commit hash.\n}\n\nBranchSpec := {\n type: \"branch\"\n value: String # Example: \"master\"\n}\n\nLocalSource := {\n type: \"local\"\n\n directory: String\n # The directory where the dependency is placed.\n}\n\nHexSource := {\n type: \"hex\"\n\n version: String\n # The version number.\n}\n\nErlangConfig := {\n output_directory: String\n # The directory at which Erlang modules are generated.\n # Must be relative to the configuration file.\n # This field is Optional. Default: \"./_generated\"\n\n test_output_directory: String\n # The directory at which Erlang test modules for EUnit are generated.\n # Must be relative to the configuration file.\n # This field is Optional. Default: \"./_generated_test\"\n\n erlang_dependencies: Array\n # The Erlang libraries on which the package depends.\n # This field is optional. Default: []\n\n relx: Relx\n # This field is optional.\n # No `relx` stanza will be written on `rebar.config` if omitted.\n}\n\nErlangDependency := {\n name: String\n # The name of the package. Example: \"cowboy\"\n\n source: (HexSource | GitSource)\n # Describes how to get the Erlang library.\n}\n\nRelx := {\n release: RelxRelease\n dev_mode: Boolean # This field is optional. Default: false\n}\n\nRelxRelease := {\n name: String\n version: String\n applications: Array\n}\n\nDocumentOutput := {\n format: { type: \"html\" }\n # The format of output documents.\n # Only HTML is supported so far.\n\n output_directory: String\n # The directory at which documents are generated.\n # Must be relative to the configuration file.\n # Example: [ \"./_doc\" ]\n}\n```\n\n\n## Overall syntax\n\nHow to read:\n\n* a word enclosed by single quotation marks (e.g. `'let'` or `'('`):\n - a keyword token or a symbol token\n* a word without quotations (e.g. `E` or `val-args`):\n - a metavariable of the (extended) BNF\n* `(empty)`\n - the empty sequence of tokens\n* `( DESCR )*`\n - a possibly empty finite repetition of `DESCR`\n* `( DESCR )+`\n - equals `DESCR ( DESCR )*`\n* `(empty)`\n - no token (i.e. a token sequence of length zero)\n* `(DESCR1 | DESCR2)`\n - either `DESCR1` or `DESCR2`\n* `( DESCR )?`\n - equals `((empty) | DESCR)`\n\n```\nn ::= (decimal or hexadecimal integer literals)\nfloat-lit ::= (floating-point number literals)\nbin-lit ::= (string literals enclosed by double quotation marks)\nX, C ::= (capitalized identifiers)\nx, t, k, l ::= (lowercased identifiers other than keywords)\n$a ::= (lowercased identifiers preceded by a dollar sign)\n?$a ::= (lowercased identifiers preceded by a question mark and a dollar sign)\n-l ::= (lowercased identifiers preceded by a hyphen)\n?l ::= (lowercased identifiers preceded by a question mark)\n\n# source files:\nsource-file ::=\n | ('import' X)* 'module' X (':>' S) '=' 'struct' (open-spec)* (bind)* 'end'\n\n# value expressions:\nE ::=\n | '(' E ')'\n | E binary-operator E\n | (X '.')* x\n | (X '.')* C # variant constructors\n | E '(' val-args ')' # function applications\n | 'let' bind-val-local 'in' E # local bindings\n | 'let' pattern '=' E 'in' E # local bindings by the pattern matching\n | 'fun' '(' val-params ')' '->' E 'end' # pure abstractions\n | 'fun' '(' val-params ')' '->' 'act' P 'end' # effectful abstractions\n | 'if' E 'then' E 'else' E # conditionals\n | 'case' E 'of' (pure-case)+ 'end' # pattern-matching expressions\n | '{' '}' # the unit value\n | '{' E (',' E)* (',')? '}' # tuples\n | '{' l '=' E (',' l '=' E)* (',')? '}' # records\n | E '.' l # record access\n | '{' E '|' l '=' E (',' l '=' E)* (',')? '}' # record update\n | 'freeze' (X '.')* x '(' freeze-args ')' # so-called (possibly partial) mfargs() in Erlang\n | 'freeze' '(' E ')' 'with' '(' freeze-args ')' # addition of arguments to partial mfargs()\n | 'pack' M ':' S # packed first-class modules\n | 'assert' E # assertion for tests\n | E '::' E # cons\n | '[' ']' # nil\n | n\n | float-lit\n | bin-lit\n | 'true'\n | 'false'\n | ...\n\npure-case ::=\n | '|' pattern '->' E\n\n# effectful computations:\nP ::=\n | 'do' pattern '<-' P 'in' P # sequential compositions (i.e. so-called monadic binds)\n | 'receive' (effectful-case)+ after-branch 'end' # selective receive\n | E '(' val-args ')' # function applications\n | 'if' E 'then' P 'else' P # conditionals\n | 'case' E 'of' (effectful-case)+ 'end' # pattern-matching expressions\n\neffectful-case ::=\n | '|' pattern '->' P\n\nafter-branch ::=\n | (empty)\n | 'after' E '->' P\n\n# sequences of arguments for function applications:\nval-args ::=\n | E (',' val-args)?\n | val-labeled-args\n\nval-labeled-args ::=\n | -l E (',' val-labeled-args)?\n | val-optional-args\n\nval-optional-args ::=\n | ?l E (',' val-optional-args)?\n | (empty)\n\n# patterns for the pattern matching:\npattern ::=\n | '_' # wildcard\n | x # variable binding\n | C # constructors with no argument\n | C '(' pattern (',' pattern)* (',')? ')' # constructors with arguments\n | '{' '}' # the unit pattern\n | '{' pattern (',' pattern)* (',')? '}' # tuples\n | pattern '::' pattern # cons\n | '[' ']' # nil\n | n\n | bin\n | 'true'\n | 'false'\n | ...\n\n# types:\nT ::=\n | $a # type variables\n | (X '.')* t ty-args # applications of type constructors\n | 'fun' '(' ty-doms ')' '->' T # function types\n | 'fun' '(' ty-doms ')' '->' '[' T ']' T # action types\n | '{' T (',' T)* (',')? '}' # product types\n | '{' l '=' T (',' l '=' T)* (',')? '}' # record types\n | 'pack' S # types for first-class modules\n\n# sequences of type arguments:\nty-args ::=\n | ('<' ty-args-sub '>')?\n\nty-args-sub ::=\n | T (',' ty-args-sub)?\n | (empty)\n\n# sequences of domain types:\nty-doms ::=\n | T (',' ty-doms)?\n | ty-labeled-doms\n\nty-labeled-doms ::=\n | -l T (',' ty-labeled-doms)?\n | ty-optional-doms\n | ?$a\n\nty-optinal-doms ::=\n | ?l T (',' ty-optional-doms)?\n | (empty)\n\n# a kind:\nK ::=\n | kd-base # base kinds (i.e. order-0 kinds)\n | '(' kd-base (',' kd-base)* (',')? ')' '->' kd-base # order-1 kinds\n\nkd-base ::=\n | k # named base kinds (currently only 'o' is provided)\n | kd-row # row kinds\n\nkd-row ::=\n | '(' labels ')'\n\nlabels ::=\n | l ',' labels\n | l\n | (empty)\n\nopen-spec ::=\n | 'open' (X '.')* X\n\n# module expressions:\nM ::=\n | '(' M ')'\n | (X '.')* X\n | 'struct' (open-spec)* (bind)* 'end' # structures\n | 'fun' '(' X ':' S ')' '->' M # functor abstractions\n | (X '.')* X '( M )' # functor applications\n | X ':>' S # coercion\n\n# bindings (i.e. members of structures):\nbind ::=\n | 'val' (bind-val-local | bind-val-ffi)\n | 'type' bind-ty\n | 'module' X (':>' S)? '=' M\n | 'signature' X '=' S\n | 'include' M\n\n# signature expressions:\nS ::=\n | '(' S ')'\n | (X '.')* X\n | 'sig' (open-spec)* (decl)* 'end' # structure signatures\n | 'fun' '(' X ':' S ')' '->' S # functor signatures\n | S 'with' 'type' bind-ty\n\n# declarations (i.e. members of structure signatures):\ndecl ::=\n | 'val' x ty-quant ':' T\n | 'type' t ('::' K)?\n | 'type' t '=' bind-ty\n | 'module' X ':' S\n | 'signature' X '=' S\n\nbind-val-local ::=\n | bind-val-single # non-recursive definitions\n | 'rec' bind-val-single ('and' bind-val-single)* # (mutually) recursive definitions\n\nbind-val-single ::=\n | x ty-quant '(' val-params ')' (':' T)? '=' E # function definitions\n | x ty-quant '(' val-params ')' (':' '[' T ']' T)? '=' 'act' P # action definitions\n\nbind-val-ffi ::=\n | x ty-quant ':' T '=' 'external' n ('+')? string-block # FFI\n\nbind-ty ::=\n | bind-ty-single ('and' bind-ty-single)*\n\nbind-ty-single ::=\n | t ty-quant '=' ('|')? ctor-branch ('|' ctor-branch)* # variant type definitions\n | t ty-quant '=' T # type synonym definitions\n\nctor-branch ::=\n | C ('(' T (',' T)* ')')? # a definition of a constructor and its parameter types\n\n# comma-separated sequences of value parameters (for function definitions):\nval-params ::=\n | pattern (':' T)? (',' val-params)?\n | val-labeled-params\n\n# comma-separated labeled parameters:\nval-labeled-params ::=\n | -l pattern (':' T)? (',' val-labeled-params)?\n | val-optional-params\n\n# comma-separated labeled optional parameters (possibly with default expressions):\nval-optional-params ::=\n | ?l pattern (':' T)? ('=' E)? (',' val-optional-params)?\n | (empty)\n\n# sequences of universal quantifiers for type parameters and row parameters\nty-quant ::=\n | ('<' ty-params '>')?\n\nty-params ::=\n | $a ',' ty-params\n | $a\n | row-params\n\nrow-params ::=\n | ?$a '::' kd-row (',' row-params)?\n | (empty)\n```\n\n\n## References\n\n* Sheng Chen and Martin Erwig. [Principal type inference for GADTs](https://doi.org/10.1145/2837614.2837665). In *Proceedings of the 43rd Annual ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages (POPL ’16)*, pp. 416–428, 2016.\n* Martin Elsman, Troels Henriksen, Danil Annenkov, and Cosmin E. Oancea. [Static interpretation of higher-order modules in Futhark: functional GPU programming in the large](https://dl.acm.org/doi/10.1145/3236792). *Proceedings of the ACM on Programming Languages* 2, ICFP, Article 97, 2018.\n* Simon Fowler. [*Typed Concurrent Functional Programming with Channels, Actors, and Sessions*](https://era.ed.ac.uk/handle/1842/35873). PhD thesis, University of Edinburgh, 2019.\n* Benedict R. Gaster and Mark P. Jones. [A polymorphic type system for extensible records and variants](https://web.cecs.pdx.edu/~mpj/pubs/96-3.pdf). Technical Report NOTTCS-TR-96-3, 1996.\n* Roger Hindley. The principal type-scheme of an object in combinatory logic. *Transactions of the American Mathematical Society*, **146**, pp. 29–60, 1969.\n* Robin Milner. A theory of type polymorphism in programming. *Journal of Computer and System Sciences*, **17**, pp. 348–375, 1978.\n* Atsushi Ohori. [A polymorphic record calculus and its compilation](https://dl.acm.org/doi/10.1145/218570.218572). *ACM Transactions on Programming Languages and Systems*, **17**(6), pp. 844–895, 1995.\n* Dominic Orchard and Nobuko Yoshida. [Effects as sessions, sessions as effects](https://dl.acm.org/doi/10.1145/2837614.2837634). In *Proceedings of the 43rd Annual ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages (POPL ’16)*, pp. 568–581, 2016.\n* Andreas Rossberg, Claudio Russo, and Derek Dreyer. [F-ing modules](https://people.mpi-sws.org/~rossberg/f-ing/). *Journal of Functional Programming*, **24**(5), pp. 529–607, 2014.\n" }, { "path": "dune-project", "content": "(lang dune 2.5)\n(name sesterl)\n(version 0.2.1)\n\n(using menhir 2.0)\n(generate_opam_files true)\n\n(source (github gfngfn/Sesterl))\n(license MIT)\n(authors \"T. Suwa\")\n(maintainers \"bd[dot]gfngfn[at]gmail[dot]com\")\n\n(package\n (name sesterl)\n (synopsis \"Sesterl: A Session-Typed Erlang\")\n (description \"Sesterl: A Session-Typed Erlang\")\n (depends\n (alcotest :with-test)\n (dune (>= 2.5))\n (menhir (>= 20200211))\n (menhirLib (>= 20200211))\n (cmdliner (>= 1.0.4))\n (ocamlgraph (>= 1.8.8))\n (semver2 (>= 1.2.0))\n (core (>= 0.13.0))\n (uutf (>= 1.0.2))\n (yaml (>= 2.1.0))\n (omd (>= 1.3.1))\n (ppx_deriving (>= 4.4.1))))\n" }, { "path": "examples/echo_server/README.md", "content": "\n## How to Compile and Run\n\n```console\n# Generate `rebar.config`\n$ sesterl config ./\n\n# Compile sources\n$ rebar3 sesterl compile\n\n# Run (after compiling sources)\n$ rebar3 shell\n\n# Test (after compiling sources)\n$ rebar3 eunit\n```\n\nThen you can see `http://localhost:8080` on your browser or some CLI tool:\n\n```\n$ curl \"http://localhost:8080\"\nHello, Sesterl! (no text was given, 2)\n$ curl \"http://localhost:8080/?text\"\nHello, Sesterl! (no text was given, 1)\n$ curl \"http://localhost:8080/?text=foo\"\nfoo\n$ curl \"http://localhost:8080/?text=Hello%20World\"\nHello World\n$ curl \"http://localhost:8080/users/taro\"\ntaro\n```\n" }, { "path": "examples/echo_server/rebar.config", "content": "{plugins, [{rebar_sesterl, {git, \"https://github.com/gfngfn/rebar_sesterl_plugin.git\", {branch, \"master\"}}}]}.\n{src_dirs, [\"./_generated\", \"./src\"]}.\n{deps, [{sesterl_stdlib, {git, \"https://github.com/gfngfn/sesterl_stdlib\", {tag, \"v0.4.0\"}}},{sesterl_cowboy, {git, \"https://github.com/gfngfn/sesterl_cowboy\", {branch, \"master\"}}},{cowboy, \"2.8.0\"}]}.\n{profiles, [{test, [{deps, [{sesterl_testing, {git, \"https://github.com/gfngfn/sesterl_testing\", {tag, \"v0.0.2\"}}}]}]}]}.\n{eunit_tests, [{dir, \"./_generated_test\"}, {dir, \"./test\"}]}.\n{relx, [{release, {echo_server, \"0.1.0\"}, [cowboy, echo_server]}, {dev_mode, true}]}.\n{sesterl_opts, [{output_dir, \"./_generated\"},{test_output_dir, \"./_generated_test\"}]}.\n" }, { "path": "examples/echo_server/sesterl.yaml", "content": "package: \"echo_server\"\nlanguage: \"v0.2.0\"\n\nsource_directories:\n - \"./src\"\n\ntest_directories:\n - \"./test\"\n\nmain_module: \"App\"\n\ndependencies:\n - name: \"sesterl_stdlib\"\n source:\n type: \"git\"\n repository: \"https://github.com/gfngfn/sesterl_stdlib\"\n spec:\n type: \"tag\"\n value: \"v0.4.0\"\n\n - name: \"sesterl_cowboy\"\n source:\n type: \"git\"\n repository: \"https://github.com/gfngfn/sesterl_cowboy\"\n spec:\n type: \"tag\"\n value: \"v0.1.0\"\n\ntest_dependencies:\n - name: \"sesterl_testing\"\n source:\n type: \"git\"\n repository: \"https://github.com/gfngfn/sesterl_testing\"\n spec:\n type: \"tag\"\n value: \"v0.0.2\"\n\nerlang:\n output_directory: \"./_generated\"\n test_output_directory: \"./_generated_test\"\n erlang_dependencies:\n - name: \"cowboy\"\n source:\n type: \"hex\"\n version: \"2.8.0\"\n relx:\n release:\n name: \"echo_server\"\n version: \"0.1.0\"\n applications:\n - \"cowboy\"\n - \"echo_server\"\n dev_mode: true\n" }, { "path": "examples/echo_server/src/echo_server.app.src", "content": "{application, echo_server, [\n {description, \"An example echo server written in Sesterl\"},\n {vsn, \"0.1.0\"},\n {registered, []},\n {mod, {'EchoServer.App', []}},\n {applications, [\n kernel,\n stdlib,\n cowboy\n ]},\n {env, []},\n {modules, []},\n\n {licenses, [\"MIT\"]},\n {links, []}\n]}.\n" }, { "path": "examples/echo_server/src/echo_server.sest", "content": "import Sup\nimport Handler\n\nmodule App = struct\n\n val start(start_type, start_args) = act\n let error = fun(x) -> Error(Stdlib.RawValue.forget(x)) end in\n let dispatch_res =\n Cowboy.make_dispatch_table(pack Handler : Cowboy.Handler, [\n {\"/\", {}},\n {\"/users/:user_name\", {}},\n ]) in\n case dispatch_res of\n | Error(e) ->\n return(error(e))\n | Ok(dispatch) ->\n do res <- Cowboy.start_clear(-name \"echo_server\", -port 8080, -dispatch dispatch) in\n case res of\n | Error(e) -> return(error(e))\n | Ok(_) -> Sup.start_link({})\n end\n end\n\n val stop(state) = act\n Cowboy.stop_listener(\"echo_server\")\n\nend\n" }, { "path": "examples/echo_server/src/handler.sest", "content": "module Handler = struct\n open Stdlib\n\n val status_code() =\n 200\n\n val init(req, state) = act\n let bs = Cowboy.bindings(req) in\n let body =\n case RawMap.find(\"user_name\", bs) of\n | Some(user_name) ->\n user_name\n | None ->\n let qs = Cowboy.parse_qs(req) in\n case RawMap.find(\"text\", qs) of\n | Some(Some(text)) -> text\n | Some(None) -> \"Hello, Sesterl! ('text' was given but no content)\"\n | None -> \"Hello, Sesterl! ('text' was not given)\"\n end\n end\n in\n let header = RawMap.put(\"content-type\", \"text/plain\", RawMap.new()) in\n do req <-\n Cowboy.reply(\n status_code(),\n header,\n body,\n req,\n )\n in\n Cowboy.init_ok(req, state)\n\nend\n" }, { "path": "examples/echo_server/src/sup.sest", "content": "module Sup = struct\n open Stdlib\n\n module S = Supervisor.Static\n\n module Callback = struct\n type child_id = unit\n\n type init_arg = unit\n\n type info = unit\n\n type global = unit\n\n val init(args) = act\n let sup_flags = S.make_sup_flags() in\n let child_specs = [] in\n S.init_ok(sup_flags, child_specs)\n end\n\n include S.Make(Callback)\n\nend\n" }, { "path": "examples/echo_server/test/handler_tests.sest", "content": "import Handler\n\nmodule HandlerTests = #[test] struct\n\n #[test]\n val status_code_test() =\n Testing.it(\"status code test\", fun() ->\n assert Testing.equal(\n -expect 200,\n -got Handler.status_code())\n end)\n\nend\n" }, { "path": "examples/hello_world/README.md", "content": "\n```console\n# Generate/update `rebar.config`\n$ sesterl config ./\n output written on '/path/to/repo/examples/hello_world/rebar.config'.\n\n# Build\n$ rebar3 sesterl compile\n===> Verifying dependencies...\n===> Compiling Sesterl programs (command: \"sesterl build ./\") ...\n parsing '/path/to/repo/examples/hello_world/src/Main.sest' ...\n type checking '/path/to/repo/examples/hello_world/src/Main.sest' ...\n output written on '/path/to/repo/examples/hello_world/_generated/HelloWorld.Main.erl'.\n output written on '/path/to/repo/examples/hello_world/_generated/sesterl_internal_prim.erl'.\n===> Analyzing applications...\n===> Compiling hello_world\n\n# Run\n$ rebar3 shell\n===> Verifying dependencies...\n===> Analyzing applications...\n===> Compiling hello_world\nErlang/OTP 24 [erts-12.0.1] [source] [64-bit] [smp:4:4] [ds:4:4:10] [async-threads:1] [jit] [dtrace]\n\nEshell V12.0.1 (abort with ^G)\n1> 'HelloWorld.Main':show().\n<<\"Hello World!\">>\nok\n2>\n```\n" }, { "path": "examples/hello_world/rebar.config", "content": "{plugins, [{rebar_sesterl, {git, \"https://github.com/gfngfn/rebar_sesterl_plugin.git\", {branch, \"master\"}}}]}.\n{src_dirs, [\"_generated\", \"./src\"]}.\n{deps, []}.\n{profiles, [{test, [{deps, []}]}]}.\n{eunit_tests, [{dir, \"_generated_test\"}]}.\n{sesterl_opts, [{output_dir, \"_generated\"},{test_output_dir, \"_generated_test\"}]}.\n" }, { "path": "examples/hello_world/sesterl.yaml", "content": "package: \"hello_world\"\nlanguage: \"v0.2.0\"\nmain_module: \"Main\"\nsource_directories:\n - \"./src\"\n" }, { "path": "examples/hello_world/src/Main.sest", "content": "module Main = struct\n\n val show() =\n print_debug(\"Hello World!\")\n\nend\n" }, { "path": "examples/hello_world/src/hello_world.app.src", "content": "{application, hello_world, [\n {description, \"A Hello World Program\"},\n {vsn, \"0.0.1\"},\n {registered, []},\n {modules, []},\n {applications, [kernel, stdlib]},\n {env, []},\n {modules, []},\n {licenses, [\"MIT\"]},\n {links, []}\n]}.\n" }, { "path": "run-negative-blackbox-tests.sh", "content": "#!/bin/bash\n\nBIN=\"./sesterl\"\nSOURCE_DIR=\"test/fail\"\nTARGET_DIR=\"test/_generated\"\n\nmkdir -p \"$TARGET_DIR\"\n\nNO_ERRORS=()\n\nfor PKG_DIR in \"$SOURCE_DIR\"/*/; do\n echo \"Compiling package '$PKG_DIR' ...\"\n \"$BIN\" build \"$PKG_DIR\" -o \"$TARGET_DIR\"\n STATUS=$?\n if [ $STATUS -eq 0 ]; then\n NO_ERRORS+=(\"$PKG_DIR\")\n fi\ndone\n\nfor SOURCE in \"$SOURCE_DIR\"/*.sest; do\n echo \"Compiling standalone file '$SOURCE' ...\"\n \"$BIN\" build \"$SOURCE\" -o \"$TARGET_DIR\"\n STATUS=$?\n if [ $STATUS -eq 0 ]; then\n NO_ERRORS+=(\"$SOURCE\")\n fi\ndone\n\nRET=0\nfor X in \"${NO_ERRORS[@]}\"; do\n RET=1\n echo \"[FAIL] $X\"\ndone\nif [ $RET -eq 0 ]; then\n echo \"All tests have passed.\"\nfi\n\nexit $RET\n" }, { "path": "run-positive-blackbox-tests.sh", "content": "#!/bin/bash\n\nCURDIR=$(pwd)\n\ncommand -v gsed\nSTATUS=$?\nif [ $STATUS -eq 0 ]; then\n GNU_SED=\"gsed\"\nelse\n command -v sed\n STATUS=$?\n if [ $STATUS -eq 0 ]; then\n GNU_SED=\"sed\"\n else\n echo \"GNU sed is not installed. Stop.\"\n exit 1\n fi\nfi\n\nBIN=\"./sesterl\"\nSOURCE_DIR=\"test/pass\"\nTARGET_DIR=\"test/_generated\"\n\nmkdir -p \"$TARGET_DIR\"\n\nERRORS=()\n\n# Compiles all the packages.\nfor PKG_DIR in \"$SOURCE_DIR\"/*/; do\n echo \"Compiling package '$PKG_DIR' ...\"\n \"$BIN\" build \"$PKG_DIR\" -p sesterl_stdlib:external/stdlib -p sesterl_testing:external/testing\n STATUS=$?\n if [ $STATUS -ne 0 ]; then\n ERRORS+=(\"$PKG_DIR\")\n fi\ndone\n\n# Compiles all the single source files.\nfor SOURCE in \"$SOURCE_DIR\"/*.sest; do\n echo \"Compiling standalone file '$SOURCE' by sesterl ...\"\n \"$BIN\" build \"$SOURCE\" -o \"$TARGET_DIR\"\n STATUS=$?\n if [ $STATUS -ne 0 ]; then\n ERRORS+=(\"$SOURCE\")\n fi\ndone\n\n# Checks whether every generated Erlang code successfully compiles.\nfor TARGET in \"$TARGET_DIR\"/*.erl; do\n echo \"Compiling '$TARGET' by erlc ...\"\n erlc -o \"$TARGET_DIR\" \"$TARGET\"\n STATUS=$?\n if [ $STATUS -ne 0 ]; then\n ERRORS+=(\"$TARGET\")\n fi\ndone\n\n# Runs every generated Erlang code that has `main/1`.\ncd \"$TARGET_DIR\" || exit\nfor TARGET in *.erl; do\n NUM=\"$(grep -c \"'main'/1\" \"$TARGET\")\"\n if [ \"$NUM\" -eq 0 ]; then\n echo \"Skip '$TARGET' due to the absence of main/1.\"\n else\n echo \"Executing '$TARGET' by escript ...\"\n $GNU_SED '1s|^|#!/usr/local/bin/escript\\n|' -i \"$TARGET\"\n escript \"$TARGET\"\n STATUS=$?\n if [ $STATUS -ne 0 ]; then\n ERRORS+=(\"$TARGET\")\n fi\n fi\ndone\ncd \"$CURDIR\" || exit\n\nRET=0\nfor X in \"${ERRORS[@]}\"; do\n RET=1\n echo \"[FAIL] $X\"\ndone\nif [ $RET -eq 0 ]; then\n echo \"All tests have passed.\"\nfi\n\nexit $RET\n" }, { "path": "sesterl.opam", "content": "# This file is generated by dune, edit dune-project instead\nopam-version: \"2.0\"\nversion: \"0.2.1\"\nsynopsis: \"Sesterl: A Session-Typed Erlang\"\ndescription: \"Sesterl: A Session-Typed Erlang\"\nmaintainer: [\"bd[dot]gfngfn[at]gmail[dot]com\"]\nauthors: [\"T. Suwa\"]\nlicense: \"MIT\"\nhomepage: \"https://github.com/gfngfn/Sesterl\"\nbug-reports: \"https://github.com/gfngfn/Sesterl/issues\"\ndepends: [\n \"alcotest\" {with-test}\n \"dune\" {>= \"2.5\"}\n \"menhir\" {>= \"20200211\"}\n \"menhirLib\" {>= \"20200211\"}\n \"cmdliner\" {>= \"1.0.4\"}\n \"ocamlgraph\" {>= \"1.8.8\"}\n \"semver2\" {>= \"1.2.0\"}\n \"core\" {>= \"0.13.0\"}\n \"uutf\" {>= \"1.0.2\"}\n \"yaml\" {>= \"2.1.0\"}\n \"omd\" {>= \"1.3.1\"}\n \"ppx_deriving\" {>= \"4.4.1\"}\n]\nbuild: [\n [\"dune\" \"subst\"] {pinned}\n [\n \"dune\"\n \"build\"\n \"-p\"\n name\n \"-j\"\n jobs\n \"@install\"\n \"@runtest\" {with-test}\n \"@doc\" {with-doc}\n ]\n]\ndev-repo: \"git+https://github.com/gfngfn/Sesterl.git\"\n" }, { "path": "src/address.ml", "content": "\nopen MyUtil\n\n\ntype element =\n | Member of string\n | FunctorBody of { arg : string }\n[@@deriving show { with_path = false }]\n\ntype t = element Alist.t\n\n\nlet root =\n Alist.empty\n\n\nlet append_member (modnm : string) (address : t) =\n Alist.extend address (Member(modnm))\n\n\nlet append_functor_body ~arg:(modnm : string) (address : t) =\n Alist.extend address (FunctorBody{ arg = modnm })\n\n\nlet to_list (address : t) =\n Alist.to_list address\n\n\nlet subtract ~(long : t) ~(short : t) : t =\n let elems_long = Alist.to_list long in\n let elems_short = Alist.to_list short in\n let rec aux (elems_long : element list) (elems_short : element list) =\n match (elems_long, elems_short) with\n | ([], _) ->\n Alist.empty\n\n | (_ :: _, []) ->\n Alist.from_list elems_long\n\n | (elem1 :: tail1, elem2 :: tail2) ->\n begin\n match (elem1, elem2) with\n | (Member(modnm1), Member(modnm2)) ->\n if String.equal modnm1 modnm2 then\n aux tail1 tail2\n else\n Alist.from_list elems_long\n\n | (FunctorBody(_), FunctorBody(_)) ->\n aux tail1 tail2\n\n | _ ->\n Alist.from_list elems_long\n end\n in\n aux elems_long elems_short\n\n\nlet show (address : t) : string =\n let adelems = to_list address in\n let ss =\n adelems |> List.mapi (fun index adelem ->\n match adelem with\n | Member(modnm) -> if index = 0 then modnm else Printf.sprintf \".%s\" modnm\n | FunctorBody(r) -> Printf.sprintf \"(%s = ...)\" r.arg\n )\n in\n let s_last = if adelems = [] then \"\" else \".\" in\n (List.append ss [ s_last ]) |> String.concat \"\"\n\n\nlet pp (ppf : Format.formatter) (address : t) =\n let pp_sep ppf () = Format.fprintf ppf \":\" in\n Format.fprintf ppf \"%a\" (Format.pp_print_list ~pp_sep pp_element) (to_list address)\n" }, { "path": "src/address.mli", "content": "\ntype element =\n | Member of string\n | FunctorBody of { arg : string }\n\ntype t\n\nval root : t\n\nval append_member : string -> t -> t\n\nval append_functor_body : arg:string -> t -> t\n\nval to_list : t -> element list\n\nval subtract : long:t -> short:t -> t\n\nval show : t -> string\n\nval pp : Format.formatter -> t -> unit\n" }, { "path": "src/assocList.ml", "content": "\n\nmodule type EQ = sig\n type t\n val equal : t -> t -> bool\nend\n\n\nmodule Make(Key : EQ) : sig\n type elem\n type 'v t\n val empty : 'v t\n val add_last : elem -> 'v -> 'v t -> ('v t) option\n val find_opt : elem -> 'v t -> 'v option\n val fold_left : ('a -> elem -> 'v -> 'a) -> 'a -> 'v t -> 'a\n val values : 'v t -> 'v list\n val length : 'v t -> int\nend\n with type elem = Key.t\n= struct\n\n type elem = Key.t\n\n type 'v t = (elem * 'v) list\n\n\n let empty = []\n\n\n let add_last k v assoc =\n let rec aux acc xs =\n match xs with\n | [] ->\n Some(List.rev ((k, v) :: acc))\n\n | ((kx, _) as x) :: tail ->\n if Key.equal k kx then\n None\n else\n aux (x :: acc) tail\n in\n aux [] assoc\n\n\n let rec find_opt k assoc =\n match assoc with\n | [] ->\n None\n\n | (kx, vx) :: tail ->\n if Key.equal k kx then\n Some(vx)\n else\n find_opt k tail\n\n\n let fold_left f init assoc =\n List.fold_left (fun acc (k, v) -> f acc k v) init assoc\n\n\n let values assoc =\n assoc |> List.map snd\n\n\n let length =\n List.length\n\nend\n" }, { "path": "src/boundID.ml", "content": "\ntype t = {\n id : int;\n}\n\n\nlet equal bid1 bid2 =\n bid1.id = bid2.id\n\n\nlet hash bid =\n bid.id\n\n\nlet compare bid1 bid2 =\n bid2.id - bid1.id\n\n\nlet current_max = ref 0\n\n\nlet initialize () =\n current_max := 0\n\n\nlet fresh () =\n incr current_max;\n { id = !current_max; }\n\n\nlet pp ppf bid =\n Format.fprintf ppf \"'#%d\" bid.id\n" }, { "path": "src/boundID.mli", "content": "\ntype t\n\nval initialize : unit -> unit\n\nval fresh : unit -> t\n\nval equal : t -> t -> bool\n\nval hash : t -> int\n\nval compare : t -> t -> int\n\nval pp : Format.formatter -> t -> unit\n" }, { "path": "src/configLoader.ml", "content": "\nopen MyUtil\nopen Errors\nopen Syntax\n\n\ntype git_spec =\n | Tag of string\n | Ref of string\n | Branch of string\n\ntype erlang_library_source =\n | ErlangLibFromHex of { version : string }\n | ErlangLibFromGit of { repository : string; git_spec : git_spec }\n\ntype erlang_library = {\n erlang_library_name : string;\n erlang_library_source : erlang_library_source;\n}\n\ntype relx_release = {\n relx_name : string;\n relx_version : string;\n relx_applications : string list;\n}\n\ntype relx = {\n relx_release : relx_release;\n relx_dev_mode : bool;\n}\n\ntype erlang_config = {\n output_directory : relative_dir;\n test_output_directory : relative_dir;\n erlang_dependencies : erlang_library list;\n relx : relx option;\n}\n\ntype document_output_format =\n | Html\n\ntype document_output_config = {\n document_output_format : document_output_format;\n document_output_directory : relative_dir;\n}\n\ntype dependency_source =\n | Local of absolute_path\n | Git of { repository : string; git_spec : git_spec }\n\ntype dependency = {\n dependency_name : package_name;\n dependency_source : dependency_source;\n}\n\n\nlet default_erlang_config : erlang_config =\n {\n output_directory = RelativeDir(Constants.default_output_directory);\n test_output_directory = RelativeDir(Constants.default_test_output_directory);\n erlang_dependencies = [];\n relx = None;\n }\n\n\ntype config = {\n language_version : string option;\n config_directory : absolute_dir;\n package_name : package_name;\n main_module_name : module_name;\n source_directories : relative_dir list;\n test_directories : relative_dir list;\n document_outputs : document_output_config list;\n dependencies : dependency list;\n test_dependencies : dependency list;\n erlang_config : erlang_config;\n}\n\n\nlet git_spec_decoder : git_spec YamlDecoder.t =\n let open YamlDecoder in\n branch \"type\" [\n \"tag\" ==> begin\n get \"value\" string >>= fun tag ->\n succeed (Tag(tag))\n end;\n\n \"ref\" ==> begin\n get \"value\" string >>= fun hash ->\n succeed (Ref(hash))\n end;\n\n \"branch\" ==> begin\n get \"value\" string >>= fun branch ->\n succeed (Branch(branch))\n end;\n ]\n ~on_error:(fun other ->\n Printf.sprintf \"unsupported type '%s' for specifying sources from Git\" other\n )\n\n\nlet erlang_library_decoder : erlang_library_source YamlDecoder.t =\n let open YamlDecoder in\n branch \"type\" [\n \"hex\" ==> begin\n get \"version\" string >>= fun version ->\n succeed (ErlangLibFromHex{ version = version })\n end;\n\n \"git\" ==> begin\n get \"repository\" string >>= fun repository ->\n get \"spec\" git_spec_decoder >>= fun git_spec ->\n succeed (ErlangLibFromGit{ repository = repository; git_spec = git_spec })\n end;\n ]\n ~on_error:(fun other ->\n Printf.sprintf \"unsupported type '%s' for specifying dependency sources\" other\n )\n\n\nlet erlang_dependency_decoder : erlang_library YamlDecoder.t =\n let open YamlDecoder in\n get \"name\" string >>= fun name ->\n get \"source\" erlang_library_decoder >>= fun erlsrc ->\n succeed {\n erlang_library_name = name;\n erlang_library_source = erlsrc;\n }\n\n\nlet relx_release_decoder : relx_release YamlDecoder.t =\n let open YamlDecoder in\n get \"name\" string >>= fun name ->\n get \"version\" string >>= fun version ->\n get \"applications\" (list string) >>= fun applications ->\n succeed {\n relx_name = name;\n relx_version = version;\n relx_applications = applications;\n }\n\n\nlet relx_decoder : relx YamlDecoder.t =\n let open YamlDecoder in\n get \"release\" relx_release_decoder >>= fun release ->\n get_or_else \"dev_mode\" bool false >>= fun dev_mode ->\n succeed {\n relx_release = release;\n relx_dev_mode = dev_mode;\n }\n\n\nlet erlang_config_decoder : erlang_config YamlDecoder.t =\n let open YamlDecoder in\n get_or_else \"output_directory\" string Constants.default_output_directory >>= fun reldir_out ->\n get_or_else \"test_output_directory\" string Constants.default_test_output_directory >>= fun reldir_test_out ->\n get_or_else \"erlang_dependencies\" (list erlang_dependency_decoder) [] >>= fun erldeps ->\n get_opt \"relx\" relx_decoder >>= fun relx_opt ->\n succeed {\n output_directory = RelativeDir(reldir_out);\n test_output_directory = RelativeDir(reldir_test_out);\n erlang_dependencies = erldeps;\n relx = relx_opt;\n }\n\n\nlet source_decoder (confdir : absolute_dir) : dependency_source YamlDecoder.t =\n let open YamlDecoder in\n branch \"type\" [\n \"local\" ==> begin\n get \"directory\" string >>= fun dirstr ->\n succeed (Local(make_absolute_path confdir dirstr))\n end;\n \"git\" ==> begin\n get \"repository\" string >>= fun repository ->\n get \"spec\" git_spec_decoder >>= fun git_spec ->\n succeed (Git{ repository = repository; git_spec = git_spec })\n end;\n ]\n ~on_error:(fun other ->\n Printf.sprintf \"unsupported type '%s' for specifying dependency sources\" other\n )\n\n\nlet dependency_decoder (confdir : absolute_dir) : dependency YamlDecoder.t =\n let open YamlDecoder in\n get \"name\" string >>= fun name ->\n get \"source\" (source_decoder confdir) >>= fun source ->\n succeed {\n dependency_name = name;\n dependency_source = source;\n }\n\n\nlet document_output_format_decoder : document_output_format YamlDecoder.t =\n let open YamlDecoder in\n branch \"type\" [\n \"html\" ==> succeed Html\n ]\n ~on_error:(fun other ->\n Printf.sprintf \"unsupported type '%s' for specifying document output format\" other\n )\n\n\nlet document_output_decoder : document_output_config YamlDecoder.t =\n let open YamlDecoder in\n get \"output_directory\" string >>= fun reldir_out ->\n get \"format\" document_output_format_decoder >>= fun format ->\n succeed {\n document_output_format = format;\n document_output_directory = RelativeDir(reldir_out);\n }\n\n\nlet config_decoder (confdir : absolute_dir) : config YamlDecoder.t =\n let open YamlDecoder in\n get_opt \"language\" string >>= fun language_opt ->\n get \"package\" string >>= fun package_name ->\n get \"source_directories\" (list string) >>= fun srcdirs ->\n get \"main_module\" string >>= fun main_module_name ->\n get_or_else \"test_directories\" (list string) [] >>= fun testdirs ->\n get_or_else \"dependencies\" (list (dependency_decoder confdir)) [] >>= fun dependencies ->\n get_or_else \"test_dependencies\" (list (dependency_decoder confdir)) [] >>= fun test_dependencies ->\n get_or_else \"document_outputs\" (list document_output_decoder) [] >>= fun document_outputs ->\n get_or_else \"erlang\" erlang_config_decoder default_erlang_config >>= fun erlang_config ->\n let config =\n {\n language_version = language_opt;\n config_directory = confdir;\n package_name = package_name;\n main_module_name = main_module_name;\n source_directories = srcdirs |> List.map (fun srcdir -> RelativeDir(srcdir));\n test_directories = testdirs |> List.map (fun testdir -> RelativeDir(testdir));\n document_outputs = document_outputs;\n dependencies = dependencies;\n test_dependencies = test_dependencies;\n erlang_config = erlang_config;\n }\n in\n succeed config\n\n\nlet load (confpath : absolute_path) : (config, config_error) result =\n let open ResultMonad in\n begin\n try return (open_in confpath) with\n | Sys_error(_) -> err (ConfigFileNotFound(confpath))\n end >>= fun fin ->\n let confdir = Filename.dirname confpath in\n let s = Core.In_channel.input_all fin in\n close_in fin;\n YamlDecoder.run (config_decoder confdir) s |> map_err (fun e -> ConfigFileError(e))\n" }, { "path": "src/constants.ml", "content": "\n\nlet semantic_version =\n \"v0.2.1\"\n\n\nlet config_file_name =\n \"sesterl.yaml\"\n\n\nlet default_output_directory =\n \"_generated\"\n\n\nlet default_test_output_directory =\n \"_generated_test\"\n\n\nlet plugin_name =\n \"rebar_sesterl\"\n\n\nlet plugin_url =\n \"https://github.com/gfngfn/rebar_sesterl_plugin.git\"\n\n\nlet message_tag_atom =\n \"'$sesterl'\"\n" }, { "path": "src/constructorAttribute.ml", "content": "\nopen MyUtil\nopen Syntax\n\n\ntype t = {\n target_atom : (string ranged) option;\n}\n\n\nlet default =\n { target_atom = None }\n\n\nlet decode (attrs : attribute list) : t * attribute_warning list =\n let (acc, warn_acc) =\n attrs |> List.fold_left (fun (acc, warn_acc) attr ->\n let Attribute((rng, attr_main)) = attr in\n match attr_main with\n | (\"atom\", utast_opt) ->\n begin\n match utast_opt with\n | Some((rngs, BaseConst(BinaryByString(s)))) ->\n ({ target_atom = Some((rngs, s)) }, warn_acc)\n\n | _ ->\n let warn =\n {\n position = rng;\n tag = \"atom\";\n message = \"argument should be a string literal\"\n }\n in\n (acc, Alist.extend warn_acc warn)\n end\n\n | (tag, _) ->\n let warn =\n {\n position = rng;\n tag = tag;\n message = \"unsupported attribute\";\n }\n in\n (acc, Alist.extend warn_acc warn)\n ) (default, Alist.empty)\n in\n (acc, Alist.to_list warn_acc)\n" }, { "path": "src/constructorID.ml", "content": "\ntype t = IdentifierScheme.t\n\n\nlet from_upper_camel_case : string -> t option =\n IdentifierScheme.from_upper_camel_case\n\n\nlet from_snake_case : string -> t option =\n IdentifierScheme.from_snake_case\n\n\nlet pp ppf ctorid =\n Format.fprintf ppf \"C\\\"%a\\\"\" IdentifierScheme.pp ctorid\n\n\nlet output (ctorid : t) : string =\n Printf.sprintf \"'%s'\" (IdentifierScheme.to_snake_case ctorid)\n" }, { "path": "src/constructorID.mli", "content": "\ntype t\n\nval from_upper_camel_case : string -> t option\n\nval from_snake_case : string -> t option\n\nval pp : Format.formatter -> t -> unit\n\nval output : t -> string\n" }, { "path": "src/declarationAttribute.ml", "content": "\nopen MyUtil\nopen Syntax\n\n\ntype t = {\n doc : string option;\n}\n\n\nlet default =\n {\n doc = None;\n }\n\n\nlet decode (attrs : attribute list) : t * attribute_warning list =\n let (r, warn_acc) =\n attrs |> List.fold_left (fun (r, warn_acc) attr ->\n let Attribute((rng, attr_main)) = attr in\n match attr_main with\n | (\"doc\", utast_opt) ->\n begin\n match utast_opt with\n | Some((_, BaseConst(BinaryByString(s)))) ->\n ({ doc = Some(s) }, warn_acc)\n\n | Some((_, BaseConst(BinaryByInts(chs)))) ->\n let s = chs |> List.map Char.chr |> List.to_seq |> String.of_seq in\n ({ doc = Some(s) }, warn_acc)\n\n | _ ->\n let warn =\n {\n position = rng;\n tag = \"doc\";\n message = \"invalid argument\";\n }\n in\n (r, Alist.extend warn_acc warn)\n end\n\n | (tag, _) ->\n let warn =\n {\n position = rng;\n tag = tag;\n message = \"unsupported attribute\";\n }\n in\n (r, Alist.extend warn_acc warn)\n\n ) (default, Alist.empty)\n in\n (r, Alist.to_list warn_acc)\n" }, { "path": "src/dependencyGraph.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Env\n\nmodule IDMap = Map.Make(String)\n\nmodule GraphImpl = Graph.Persistent.Digraph.Abstract(String)\n\nmodule ComponentImpl = Graph.Components.Make(GraphImpl)\n\nmodule TopologicalImpl = Graph.Topological.Make(GraphImpl)\n\ntype data = {\n position : Range.t;\n type_variables : type_variable_binder list;\n definition_body : manual_type;\n kind : kind;\n}\n\ntype t = {\n labels : (data * GraphImpl.V.t) IDMap.t;\n main : GraphImpl.t;\n}\n\n\nlet empty : t =\n {\n labels = IDMap.empty;\n main = GraphImpl.empty;\n }\n\n\nlet add_vertex (tynm : type_name) (data : data) (graph : t) : t =\n let vertex = GraphImpl.V.create tynm in\n {\n labels = graph.labels |> IDMap.add tynm (data, vertex);\n main = GraphImpl.add_vertex graph.main vertex;\n }\n\n\nlet get_vertex_token (map : (data * GraphImpl.V.t) IDMap.t) (tynm : type_name) : GraphImpl.V.t =\n match map |> IDMap.find_opt tynm with\n | None -> assert false\n | Some(_, vertex) -> vertex\n\n\nlet add_edge ~depended:(tynm1 : type_name) ~depending:(tynm2 : type_name) (graph : t) : t =\n let map = graph.labels in\n let vertex1 = get_vertex_token map tynm1 in\n let vertex2 = get_vertex_token map tynm2 in\n { graph with main = GraphImpl.add_edge graph.main vertex1 vertex2 }\n\n\nlet extract_vertex_info graph v =\n let tynm = GraphImpl.V.label v in\n match graph.labels |> IDMap.find_opt tynm with\n | None -> assert false\n | Some((data, _)) -> (tynm, data)\n\n\nlet extract_vertex_error_info graph v =\n let (tynm, data) = extract_vertex_info graph v in\n (data.position, tynm)\n\n\nlet find_loop g =\n GraphImpl.fold_vertex (fun v acc ->\n match acc with\n | Some(_) -> acc\n | None -> if GraphImpl.mem_edge g v v then Some(v) else None\n ) g None\n\n\nlet topological_sort (graph : t) : ((type_name * data) list, (type_name ranged) cycle) result =\n match find_loop graph.main with\n | Some(v) ->\n Error(Loop(extract_vertex_error_info graph v))\n\n | None ->\n let sccs = ComponentImpl.scc_list graph.main in\n begin\n match\n sccs |> List.find_map (fun scc ->\n match scc with\n | [] ->\n assert false\n\n | [_] ->\n None\n\n | v1 :: v2 :: vrest ->\n let vs = List2.make v1 v2 vrest in\n Some(Cycle(vs |> List2.map (extract_vertex_error_info graph)))\n )\n with\n | Some(cycle) ->\n Error(cycle)\n\n | None ->\n let acc =\n TopologicalImpl.fold (fun v acc ->\n let info = extract_vertex_info graph v in\n Alist.extend acc info\n ) graph.main Alist.empty\n in\n Ok(Alist.to_list acc)\n end\n" }, { "path": "src/dependencyGraph.mli", "content": "\nopen Syntax\nopen Env\n\ntype t\n\ntype data = {\n position : Range.t;\n type_variables : type_variable_binder list;\n definition_body : manual_type;\n kind : kind;\n}\n\nval empty : t\n\nval add_vertex : type_name -> data -> t -> t\n\nval add_edge : depended:type_name -> depending:type_name -> t -> t\n\nval topological_sort : t -> ((type_name * data) list, (type_name ranged) cycle) result\n" }, { "path": "src/displayMap.ml", "content": "\nopen Syntax\n\n\nmodule FreeIDMap = Map.Make(FreeID)\nmodule FreeRowIDMap = Map.Make(FreeRowID)\nmodule BoundIDMap = Map.Make(BoundID)\nmodule BoundRowIDMap = Map.Make(BoundRowID)\n\n\ntype t = {\n current_max : int;\n free_ids : string FreeIDMap.t;\n free_row_ids : (string * LabelSet.t) FreeRowIDMap.t;\n bound_ids : string BoundIDMap.t;\n bound_row_ids : (string * LabelSet.t) BoundRowIDMap.t;\n}\n\n\nlet empty =\n {\n current_max = 0;\n free_ids = FreeIDMap.empty;\n free_row_ids = FreeRowIDMap.empty;\n bound_ids = BoundIDMap.empty;\n bound_row_ids = BoundRowIDMap.empty;\n }\n\n\nlet make_value (prefix : string) (i : int) =\n let rec aux chs i =\n let q = i / 26 in\n let r = i mod 26 in\n let ch = Char.chr (Char.code 'a' + r) in\n if q <= 0 then\n ch :: chs\n else\n aux (ch :: chs) r\n in\n let chs = aux [] i in\n prefix ^ (Core_kernel.String.of_char_list chs)\n\n\nlet add_free_id fid dispmap =\n let fids = dispmap.free_ids in\n if fids |> FreeIDMap.mem fid then\n dispmap\n else\n let i = dispmap.current_max in\n let s = make_value \"'\" i in\n { dispmap with\n current_max = i + 1;\n free_ids = fids |> FreeIDMap.add fid s;\n }\n\n\nlet add_free_row_id frid labset dispmap =\n let frids = dispmap.free_row_ids in\n if frids |> FreeRowIDMap.mem frid then\n dispmap\n else\n let i = dispmap.current_max in\n let s = make_value \"?'\" i in\n { dispmap with\n current_max = i + 1;\n free_row_ids = dispmap.free_row_ids |> FreeRowIDMap.add frid (s, labset);\n }\n\n\nlet add_bound_id bid dispmap =\n let bids = dispmap.bound_ids in\n if bids |> BoundIDMap.mem bid then\n dispmap\n else\n let i = dispmap.current_max in\n let s = make_value \"#\" i in\n { dispmap with\n current_max = i + 1;\n bound_ids = bids |> BoundIDMap.add bid s;\n }\n\n\nlet add_bound_row_id brid labset dispmap =\n let brids = dispmap.bound_row_ids in\n if brids |> BoundRowIDMap.mem brid then\n dispmap\n else\n let i = dispmap.current_max in\n let s = make_value \"?#\" i in\n { dispmap with\n current_max = i + 1;\n bound_row_ids = brids |> BoundRowIDMap.add brid (s, labset);\n }\n\n\nlet find_free_id fid dispmap =\n match dispmap.free_ids |> FreeIDMap.find_opt fid with\n | Some(s) -> s\n | None -> Format.asprintf \"!!%a!!\" FreeID.pp fid\n\n\nlet find_free_row_id frid dispmap =\n match dispmap.free_row_ids |> FreeRowIDMap.find_opt frid with\n | Some((s, _)) -> s\n | None -> Format.asprintf \"!!%a!!\" FreeRowID.pp frid\n\n\nlet find_bound_id bid dispmap =\n match dispmap.bound_ids |> BoundIDMap.find_opt bid with\n | Some(s) -> s\n | None -> Format.asprintf \"!!%a!!\" BoundID.pp bid\n\n\nlet find_bound_row_id brid dispmap =\n match dispmap.bound_row_ids |> BoundRowIDMap.find_opt brid with\n | Some((s, _)) -> s\n | None -> Format.asprintf \"!!%a!!\" BoundRowID.pp brid\n\n\nlet make_free_id_hash_set dispmap =\n let fidht = FreeIDHashTable.create 32 in\n dispmap.free_ids |> FreeIDMap.iter (fun fid _ ->\n FreeIDHashTable.add fidht fid ()\n );\n fidht\n\n\nlet make_free_row_id_hash_set dispmap =\n let fridht = FreeRowIDHashTable.create 32 in\n dispmap.free_row_ids |> FreeRowIDMap.iter (fun frid (_, labset) ->\n FreeRowIDHashTable.add fridht frid labset\n );\n fridht\n\n\nlet make_bound_id_hash_set dispmap =\n let bidht = BoundIDHashTable.create 32 in\n dispmap.bound_ids |> BoundIDMap.iter (fun bid _ ->\n BoundIDHashTable.add bidht bid ()\n );\n bidht\n\n\nlet make_bound_row_id_hash_set dispmap =\n let bridht = BoundRowIDHashTable.create 32 in\n dispmap.bound_row_ids |> BoundRowIDMap.iter (fun brid (_, labset) ->\n BoundRowIDHashTable.add bridht brid labset\n );\n bridht\n\n\nlet fold_free_id f acc dispmap =\n FreeIDMap.fold f dispmap.free_ids acc\n\n\nlet fold_free_row_id f acc dispmap =\n FreeRowIDMap.fold f dispmap.free_row_ids acc\n\n\nlet fold_bound_id f acc dispmap =\n BoundIDMap.fold f dispmap.bound_ids acc\n\n\nlet fold_bound_row_id f acc dispmap =\n BoundRowIDMap.fold f dispmap.bound_row_ids acc\n" }, { "path": "src/displayMap.mli", "content": "\nopen Syntax\n\ntype t\n\nval empty : t\n\nval add_free_id : FreeID.t -> t -> t\n\nval add_free_row_id : FreeRowID.t -> LabelSet.t -> t -> t\n\nval add_bound_id : BoundID.t -> t -> t\n\nval add_bound_row_id : BoundRowID.t -> LabelSet.t -> t -> t\n\nval find_free_id : FreeID.t -> t -> string\n\nval find_free_row_id : FreeRowID.t -> t -> string\n\nval find_bound_id : BoundID.t -> t -> string\n\nval find_bound_row_id : BoundRowID.t -> t -> string\n\nval make_free_id_hash_set : t -> unit FreeIDHashTable.t\n\nval make_free_row_id_hash_set : t -> LabelSet.t FreeRowIDHashTable.t\n\nval make_bound_id_hash_set : t -> unit BoundIDHashTable.t\n\nval make_bound_row_id_hash_set : t -> LabelSet.t BoundRowIDHashTable.t\n\nval fold_free_id : (FreeID.t -> string -> 'a -> 'a) -> 'a -> t -> 'a\n\nval fold_free_row_id : (FreeRowID.t -> string * LabelSet.t -> 'a -> 'a) -> 'a -> t -> 'a\n\nval fold_bound_id : (BoundID.t -> string -> 'a -> 'a) -> 'a -> t -> 'a\n\nval fold_bound_row_id : (BoundRowID.t -> string * LabelSet.t -> 'a -> 'a) -> 'a -> t -> 'a\n" }, { "path": "src/documentGenerator.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Env\nopen IntermediateSyntax\n\n\ntype document_tree_element_main =\n | DocVal of identifier * poly_type\n | DocType of type_name * type_scheme_with_entity\n | DocModule of module_name * document_tree_signature\n | DocSig of signature_name * document_tree_signature\n\nand document_tree_element =\n document_tree_element_main * string option\n\nand document_tree_signature =\n | DocSigVar of Address.t * signature_name\n | DocSigFunctor of module_name * document_tree_signature * document_tree_signature\n | DocSigWith of document_tree_signature * (type_name * type_scheme_with_entity) list\n | DocSigDecls of document_tree_element list\n\n\nlet trim_indentation (s : string) : string =\n let lines = Core.String.split_lines s in\n let acc =\n lines |> List.fold_left (fun acc line ->\n (* `res` will be:\n - `Error(n)` if the indentation depth of `line` is `n`.\n - `Ok(_)` if `line` consists only of spaces. *)\n let res =\n Core.String.fold_result s ~init:0 ~f:(fun n ch ->\n if Char.equal ch ' ' then Ok(n + 1) else Error(n)\n )\n in\n match (acc, res) with\n | (Some(min_indent), Ok(_)) -> Some(min_indent)\n | (Some(min_indent), Error(indent)) -> Some(Stdlib.min min_indent indent)\n | (None, Ok(_)) -> None\n | (None, Error(indent)) -> Some(indent)\n ) None\n in\n match acc with\n | None ->\n (* If `s` consists only of space lines. *)\n \"\"\n\n | Some(min_indent) ->\n lines |> List.map (fun line -> Core.String.drop_prefix line min_indent) |> String.concat \"\\n\"\n\n\nlet rec traverse_signature (modsig : module_signature) : document_tree_signature =\n let (isig, _) = modsig in\n traverse_signature_source isig\n\n\nand traverse_signature_source (isig : signature_source) : document_tree_signature =\n match isig with\n | ISigVar(address, signm) ->\n DocSigVar(address, signm)\n\n | ISigWith(isig0, tydefs) ->\n let withs = tydefs |> List.map (fun (tynm, tentry) -> (tynm, tentry.type_scheme)) in\n DocSigWith(traverse_signature_source isig0, withs)\n\n | ISigFunctor(m, isigdom, isigcod) ->\n let docsigdom = traverse_signature_source isigdom in\n let docsigcod = traverse_signature_source isigcod in\n DocSigFunctor(m, docsigdom, docsigcod)\n\n | ISigDecls(sigr) ->\n DocSigDecls(traverse_structure sigr)\n\n\nand traverse_structure (sigr : SigRecord.t) : document_tree_element list =\n let acc =\n sigr |> SigRecord.fold\n ~v:(fun x ventry acc ->\n Alist.extend acc (DocVal(x, ventry.val_type), ventry.val_doc)\n )\n ~c:(fun _ _ acc -> acc)\n ~f:(fun _ _ acc -> acc)\n ~t:(fun tynm tentry acc ->\n Alist.extend acc (DocType(tynm, tentry.type_scheme), tentry.type_doc)\n )\n ~m:(fun modnm mentry acc ->\n let docelems = traverse_signature mentry.mod_signature in\n Alist.extend acc (DocModule(modnm, docelems), mentry.mod_doc)\n )\n ~s:(fun signm sentry acc ->\n let (_, modsig) = sentry.sig_signature in\n let docsig = traverse_signature modsig in\n Alist.extend acc (DocSig(signm, docsig), sentry.sig_doc)\n )\n Alist.empty\n in\n acc |> Alist.to_list\n\n\nlet stringify_type ~token:(s_token : string) ~doc:(s_doc : string) ~(seen_from : Address.t) (tynm : type_name) (tyscheme : type_scheme_with_entity) : string list =\n let spec = TypeConv.display_spec_html in\n let (bids, tybody, tyentity) = tyscheme in\n let dispmap =\n bids |> List.fold_left (fun dispmap bid ->\n dispmap |> DisplayMap.add_bound_id bid\n ) DisplayMap.empty\n in\n let s_typarams =\n let ss = bids |> List.map (fun bid -> dispmap |> DisplayMap.find_bound_id bid) in\n match ss with\n | [] -> \"\"\n | _ :: _ -> Printf.sprintf \"<%s>\" (String.concat \", \" ss)\n in\n let ss_body =\n match tyentity with\n | Opaque(_tyid) ->\n [ Printf.sprintf \"%s\" s_typarams ]\n\n | Synonym ->\n [ Format.asprintf \"%s = %a\" s_typarams (TypeConv.pp_poly_type ~spec ~seen_from dispmap) tybody ]\n\n | Variant(ctormap) ->\n let ss_elems =\n ConstructorMap.bindings ctormap |> List.map (fun (ctornm, (_, ptys)) ->\n let s_param =\n match ptys with\n | [] ->\n \"\"\n\n | _ :: _ ->\n let pp_sep = (fun ppf () -> Format.fprintf ppf \", \") in\n Format.asprintf \"(%a)\"\n (Format.pp_print_list ~pp_sep:pp_sep (TypeConv.pp_poly_type ~spec ~seen_from dispmap)) ptys\n in\n Printf.sprintf \"
  • | %s%s
    • \" ctornm s_param\n )\n in\n List.concat [\n [ Printf.sprintf \"%s =
      \" s_typarams ];\n ss_elems;\n [ \"
    \" ];\n ]\n in\n [ Printf.sprintf \"
  • %s %s%s%s
    • \"\n (spec.token s_token) tynm (String.concat \"\" ss_body) s_doc;\n ]\n\n\nlet rec stringify_document_element ~(seen_from : Address.t) ((docelem, doc_opt) : document_tree_element) : string list =\n let spec = TypeConv.display_spec_html in\n let s_doc =\n match doc_opt with\n | None ->\n \"\"\n\n | Some(doc_md_raw) ->\n let doc_md = trim_indentation doc_md_raw in\n let doc_html = Omd.to_html (Omd.of_string doc_md) in\n Printf.sprintf \"
    %s
    \" doc_html\n in\n match docelem with\n | DocVal(x, pty) ->\n let dispmap = DisplayMap.empty |> TypeConv.collect_ids_poly pty in\n let sty = Format.asprintf \"%a\" (TypeConv.pp_poly_type ~spec ~seen_from dispmap) pty in\n let sq =\n let acc =\n dispmap |> DisplayMap.fold_bound_id (fun bid name acc ->\n Alist.extend acc name\n ) Alist.empty\n in\n let acc =\n dispmap |> DisplayMap.fold_bound_row_id (fun brid (name, labset) acc ->\n let s_labs = labset |> LabelSet.elements |> String.concat \", \" in\n Alist.extend acc (Printf.sprintf \"%s :: (%s)\" name s_labs)\n ) acc\n in\n match Alist.to_list acc with\n | [] -> \"\"\n | ss -> Printf.sprintf \"<%s>\" (String.concat \", \" ss)\n in\n [ Printf.sprintf \"
  • %s %s%s : %s%s
    • \" (spec.token \"val\") x sq sty s_doc ]\n\n | DocType(tynm, tyscheme) ->\n stringify_type ~token:\"type\" ~doc:s_doc ~seen_from tynm tyscheme\n\n | DocModule(modnm, docsig) ->\n let ss = docsig |> (stringify_document_signature ~seen_from:(seen_from |> Address.append_member modnm)) in\n List.concat [\n [ Printf.sprintf \"
  • %s %s%s : \" (spec.token \"module\") modnm s_doc ];\n ss;\n [ \"
    • \" ];\n ]\n\n | DocSig(signm, docsig) ->\n let ss = docsig |> (stringify_document_signature ~seen_from) in\n List.concat [\n [ Printf.sprintf \"
  • %s %s%s = \" (spec.token \"signature\") signm s_doc ];\n ss;\n [ \"
    • \" ];\n ]\n\n\nand stringify_document_signature ~(seen_from : Address.t) (docsig : document_tree_signature) : string list =\n let spec = TypeConv.display_spec_html in\n match docsig with\n | DocSigVar(address, signm) ->\n let diff_address = Address.subtract ~long:address ~short:seen_from in\n [ Printf.sprintf \"%s%s\" (Address.show diff_address) signm ]\n\n | DocSigWith(docsig0, withs) ->\n let ss1 = stringify_document_signature ~seen_from docsig0 in\n let ss2 =\n withs |> List.mapi (fun index (tynm, tyscheme) ->\n let token = if index = 0 then \"type\" else \"and\" in\n stringify_type ~token ~doc:\"\" ~seen_from tynm tyscheme\n ) |> List.concat\n in\n List.concat [\n [ Printf.sprintf \"(\" ];\n ss1;\n [ Printf.sprintf \"%s\" (spec.token \"with\") ];\n ss2;\n [ Printf.sprintf \")\" ];\n ]\n\n\n | DocSigDecls(docelems) ->\n List.concat [\n [\n Printf.sprintf \"%s\" (spec.token \"sig\");\n \"
      \";\n ];\n docelems |> List.map (stringify_document_element ~seen_from) |> List.concat;\n [\n \"
    \";\n Printf.sprintf \"%s\" (spec.token \"end\");\n ];\n ]\n\n | DocSigFunctor(m, docsig1, docsig2) ->\n List.concat [\n [ Printf.sprintf \"%s(%s : \" (spec.token \"fun\") m ];\n stringify_document_signature ~seen_from docsig1;\n [ Printf.sprintf \") -> \" ];\n stringify_document_signature ~seen_from:(seen_from |> Address.append_functor_body ~arg:m) docsig2;\n ]\n\n\nlet main (abspath_doc_out : absolute_path) (out : PackageChecker.single_output) : unit =\n let (_, (isig, _sigr)) = out.signature in\n let docelem =\n (DocModule(out.module_name, traverse_signature_source isig), None)\n in\n let lines =\n List.concat [\n [\n \"\";\n \"\";\n \"\";\n Printf.sprintf \"%s\" out.module_name;\n \"\";\n \"\";\n \"
      \";\n ];\n stringify_document_element ~seen_from:Address.root docelem;\n [\n \"
    \";\n \"\";\n ];\n ]\n in\n let fout = open_out abspath_doc_out in\n lines |> List.iter (fun line ->\n output_string fout line\n );\n close_out fout;\n Logging.output_written abspath_doc_out\n" }, { "path": "src/dune", "content": "(executable\n (public_name sesterl)\n (package sesterl)\n (name main)\n (flags (-w -3 -bin-annot -thread))\n (libraries\n menhirLib\n cmdliner\n ocamlgraph\n semver2\n core\n uutf\n yaml\n omd)\n (preprocess\n (pps\n ppx_deriving.show)))\n\n(ocamllex\n (modules lexer))\n\n(menhir\n (modules parser)\n (flags (--table --explain)))\n" }, { "path": "src/env.ml", "content": "\nopen MyUtil\nopen Syntax\n\ntype ('a, 'b) typ =\n (('a, 'b) typ_main) ranged\n\nand ('a, 'b) typ_main =\n | BaseType of base_type\n | FuncType of ('a, 'b) domain_type * ('a, 'b) typ\n | PidType of ('a, 'b) pid_type\n | EffType of ('a, 'b) domain_type * ('a, 'b) effect * ('a, 'b) typ\n | TypeVar of 'a\n | ProductType of (('a, 'b) typ) TupleList.t\n | TypeApp of TypeID.t * (('a, 'b) typ) list\n | RecordType of ('a, 'b) row\n | PackType of module_signature abstracted\n [@printer (fun ppf (qt, modsig) -> Format.fprintf ppf \"PackType(%a, _)\" pp_opaque_id_quantifier qt)]\n\nand ('a, 'b) domain_type = {\n ordered : (('a, 'b) typ) list;\n mandatory : (('a, 'b) typ) LabelAssoc.t;\n optional : ('a, 'b) row;\n}\n\nand ('a, 'b) effect =\n | Effect of ('a, 'b) typ\n\nand ('a, 'b) pid_type =\n | Pid of ('a, 'b) typ\n\nand ('a, 'b) row =\n | RowCons of label ranged * (('a, 'b) typ) * ('a, 'b) row\n | RowVar of 'b\n | RowEmpty\n\nand base_kind =\n | TypeKind\n | RowKind of LabelSet.t\n\nand module_signature_main =\n | ConcStructure of record_signature\n | ConcFunctor of functor_signature\n\nand module_signature =\n signature_source * module_signature_main\n\nand signature_source =\n | ISigVar of Address.t * signature_name\n | ISigWith of signature_source * (type_name * type_entry) list\n | ISigFunctor of signature_name * signature_source * signature_source\n | ISigDecls of record_signature\n\nand functor_signature = {\n opaques : quantifier;\n [@printer pp_opaque_id_quantifier]\n domain : functor_domain;\n codomain : module_signature abstracted;\n [@printer (fun ppf (qt, modsig) -> Format.fprintf ppf \"(%a, _)\" pp_opaque_id_quantifier qt)]\n closure : (module_name ranged * untyped_module * environment) option;\n}\n\nand functor_domain =\n | Domain of signature_source * record_signature\n\nand env_value_entry = {\n typ : poly_type;\n name : name;\n mutable is_used : bool;\n}\n\nand value_entry = {\n val_type : poly_type;\n val_global : global_name;\n val_doc : string option;\n}\n\nand type_scheme = BoundID.t list * poly_type\n\nand constructor_map = (ConstructorID.t * poly_type list) ConstructorMap.t\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n\nand type_entity =\n | Opaque of TypeID.t\n | Synonym\n | Variant of constructor_map\n\nand type_scheme_with_entity = BoundID.t list * poly_type * type_entity\n\nand type_entry = {\n type_scheme : type_scheme_with_entity;\n type_kind : kind;\n type_doc : string option;\n}\n\nand module_entry = {\n mod_signature : module_signature;\n mod_name : space_name;\n mod_doc : string option;\n}\n\nand signature_entry = {\n sig_signature : module_signature abstracted;\n sig_doc : string option;\n sig_address : Address.t;\n}\n\nand constructor_entry = {\n belongs : TypeID.t;\n constructor_id : ConstructorID.t;\n type_variables : BoundID.t list;\n parameter_types : poly_type list;\n}\n\nand opaque_entry = {\n opaque_kind : kind;\n}\n\nand environment = {\n values : env_value_entry ValNameMap.t;\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n constructors : constructor_entry ConstructorMap.t;\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n types : type_entry TypeNameMap.t;\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n opaques : kind OpaqueIDMap.t;\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n modules : module_entry ModuleNameMap.t;\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n signatures : signature_entry SignatureNameMap.t;\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n}\n\nand record_signature =\n record_signature_entry Alist.t\n[@printer (fun ppf acc ->\n Format.fprintf ppf \"%a\" (Format.pp_print_list pp_record_signature_entry) (Alist.to_list acc)\n)]\n\nand record_signature_entry =\n | SRVal of identifier * value_entry\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n | SRCtor of constructor_name * constructor_entry\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n | SRFold of type_name * poly_type\n | SRType of type_name * type_entry\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n | SRModule of module_name * module_entry\n | SRSig of signature_name * signature_entry\n [@printer (fun ppf _ -> Format.fprintf ppf \"\")]\n[@@deriving show { with_path = false }]\n\nand kind =\n | Kind of (base_kind) list * base_kind\n (* Handles order-0 or order-1 kind only. *)\n\nand mono_type_var_updatable =\n | Free of FreeID.t\n | Link of mono_type\n\nand mono_type_var =\n | Updatable of mono_type_var_updatable ref\n | MustBeBound of MustBeBoundID.t\n\nand mono_row_var_updatable =\n | FreeRow of FreeRowID.t\n | LinkRow of mono_row\n\nand mono_row_var =\n | UpdatableRow of mono_row_var_updatable ref\n | MustBeBoundRow of MustBeBoundRowID.t\n\nand mono_type = (mono_type_var, mono_row_var) typ\n\nand mono_row = (mono_type_var, mono_row_var) row\n\nand mono_effect = (mono_type_var, mono_row_var) effect\n\nand mono_domain_type = (mono_type_var, mono_row_var) domain_type\n\nand poly_type_var =\n | Mono of mono_type_var\n | Bound of BoundID.t\n\nand poly_row_var =\n | MonoRow of mono_row_var\n | BoundRow of BoundRowID.t\n\nand poly_type = (poly_type_var, poly_row_var) typ\n\nand poly_row = (poly_type_var, poly_row_var) row\n\nand poly_domain_type = (poly_type_var, poly_row_var) domain_type\n\nand quantifier = kind OpaqueIDMap.t\n [@printer pp_opaque_id_quantifier]\n\nand 'a abstracted = quantifier * 'a\n\ntype ('a, 'b) normalized_row =\n | NormalizedRow of (('a, 'b) typ) LabelAssoc.t * 'b option\n\ntype normalized_mono_row = (mono_type_var, mono_row_var) normalized_row\n\ntype normalized_poly_row = (poly_type_var, poly_row_var) normalized_row\n\ntype local_row_parameter_map = (MustBeBoundRowID.t * LabelSet.t) RowParameterMap.t\n\n\nmodule Typeenv = struct\n\n type t = environment\n\n\n let empty = {\n values = ValNameMap.empty;\n types = TypeNameMap.empty;\n opaques = OpaqueIDMap.empty;\n constructors = ConstructorMap.empty;\n modules = ModuleNameMap.empty;\n signatures = SignatureNameMap.empty;\n }\n\n\n let map\n ~v:(fv : poly_type * name -> poly_type * name)\n ~m:(fm : module_signature * space_name -> module_signature * space_name)\n (tyenv : t) : t =\n let values =\n tyenv.values |> ValNameMap.map (fun ventry ->\n let (typ, name) = fv (ventry.typ, ventry.name) in\n { ventry with typ = typ; name = name }\n )\n in\n let modules =\n tyenv.modules |> ModuleNameMap.map (fun mentry ->\n let (modsig, sname) = fm (mentry.mod_signature, mentry.mod_name) in\n { mentry with mod_signature = modsig; mod_name = sname }\n )\n in\n { tyenv with values = values; modules = modules }\n\n\n let add_value (x : identifier) (pty : poly_type) (name : name) (tyenv : t) : t =\n let entry =\n {\n typ = pty;\n name = name;\n\n is_used = false;\n }\n in\n let values = tyenv.values |> ValNameMap.add x entry in\n { tyenv with values = values; }\n\n\n let find_value (x : identifier) (tyenv : t) =\n tyenv.values |> ValNameMap.find_opt x |> Option.map (fun entry ->\n entry.is_used <- true;\n (entry.typ, entry.name)\n )\n\n\n let is_val_properly_used (x : identifier) (tyenv : t) : bool option =\n tyenv.values |> ValNameMap.find_opt x |> Option.map (fun entry ->\n entry.is_used\n )\n\n\n let fold_value f tyenv acc =\n ValNameMap.fold (fun x entry acc -> f x entry.typ acc) tyenv.values acc\n\n\n let add_constructor (ctornm : constructor_name) (ctorentry : constructor_entry) (tyenv : t) : t =\n { tyenv with\n constructors = tyenv.constructors |> ConstructorMap.add ctornm ctorentry;\n }\n\n\n let find_constructor (ctornm : constructor_name) (tyenv : t) =\n tyenv.constructors |> ConstructorMap.find_opt ctornm\n\n\n let add_type (tynm : type_name) (tentry : type_entry) (tyenv : t) : t =\n { tyenv with\n types = tyenv.types |> TypeNameMap.add tynm tentry;\n }\n\n\n let add_opaque_id (tynm : type_name) (oid : TypeID.t) (kd : kind) (tyenv : t) : t =\n { tyenv with\n opaques = tyenv.opaques |> OpaqueIDMap.add oid kd;\n }\n\n\n let find_type (tynm : type_name) (tyenv : t) : type_entry option =\n tyenv.types |> TypeNameMap.find_opt tynm\n\n\n let add_module (modnm : module_name) (mentry : module_entry) (tyenv : t) : t =\n { tyenv with\n modules = tyenv.modules |> ModuleNameMap.add modnm mentry;\n }\n\n\n let find_module (modnm : module_name) (tyenv : t) : module_entry option =\n tyenv.modules |> ModuleNameMap.find_opt modnm\n\n\n let add_signature (signm : signature_name) (sentry : signature_entry) (tyenv : t) : t =\n { tyenv with\n signatures = tyenv.signatures |> SignatureNameMap.add signm sentry;\n }\n\n\n let find_signature (signm : signature_name) (tyenv : t) : signature_entry option =\n tyenv.signatures |> SignatureNameMap.find_opt signm\n\nend\n\n\nmodule SigRecord = struct\n\n type t = record_signature\n\n let empty : t =\n Alist.empty\n\n\n let add_value (x : identifier) (ventry : value_entry) (sigr : t) : t =\n Alist.extend sigr (SRVal(x, ventry))\n\n\n let find_value (x0 : identifier) (sigr : t) : value_entry option =\n sigr |> Alist.to_rev_list |> List.find_map (function\n | SRVal(x, ventry) -> if String.equal x x0 then Some(ventry) else None\n | _ -> None\n )\n\n\n let add_type (tynm : type_name) (tentry : type_entry) (sigr : t) : t =\n Alist.extend sigr (SRType(tynm, tentry))\n\n\n let find_type (tynm0 : type_name) (sigr : t) : type_entry option =\n sigr |> Alist.to_rev_list |> List.find_map (function\n | SRType(tynm, tentry) -> if String.equal tynm tynm0 then Some(tentry) else None\n | _ -> None\n )\n\n\n let add_constructor (ctornm : constructor_name) (centry : constructor_entry) (sigr : t) : t =\n Alist.extend sigr (SRCtor(ctornm, centry))\n\n\n let find_constructor (ctornm0 : constructor_name) (sigr : t) : constructor_entry option =\n sigr |> Alist.to_rev_list |> List.find_map (function\n | SRCtor(ctornm, centry) -> if String.equal ctornm ctornm0 then Some(centry) else None\n | _ -> None\n )\n\n\n let add_dummy_fold (tynm : type_name) (pty : poly_type) (sigr : t) : t =\n Alist.extend sigr (SRFold(tynm, pty))\n\n\n let find_dummy_fold (tynm0 : type_name) (sigr : t) : poly_type option =\n sigr |> Alist.to_rev_list |> List.find_map (function\n | SRFold(tynm, pty) -> if String.equal tynm tynm0 then Some(pty) else None\n | _ -> None\n )\n\n\n let add_module (modnm : module_name) (mentry : module_entry) (sigr : t) : t =\n Alist.extend sigr (SRModule(modnm, mentry))\n\n\n let find_module (modnm0 : module_name) (sigr : t) : module_entry option =\n sigr |> Alist.to_list |> List.find_map (function\n | SRModule(modnm, mentry) -> if String.equal modnm modnm0 then Some(mentry) else None\n | _ -> None\n )\n\n\n let add_signature (signm : signature_name) (sentry : signature_entry) (sigr : t) : t =\n Alist.extend sigr (SRSig(signm, sentry))\n\n\n let find_signature (signm0 : signature_name) (sigr : t) : signature_entry option =\n sigr |> Alist.to_list |> List.find_map (function\n | SRSig(signm, sentry) -> if String.equal signm signm0 then Some(sentry) else None\n | _ -> None\n )\n\n\n let fold (type a)\n ~v:(fv : identifier -> value_entry -> a -> a)\n ~c:(fc : constructor_name -> constructor_entry -> a -> a)\n ~f:(ff : type_name -> poly_type -> a -> a)\n ~t:(ft : type_name -> type_entry -> a -> a)\n ~m:(fm : module_name -> module_entry -> a -> a)\n ~s:(fs : signature_name -> signature_entry -> a -> a)\n (init : a) (sigr : t) : a =\n sigr |> Alist.to_list |> List.fold_left (fun acc entry ->\n match entry with\n | SRVal(x, ventry) -> fv x ventry acc\n | SRCtor(ctornm, centry) -> fc ctornm centry acc\n | SRFold(tynm, pty) -> ff tynm pty acc\n | SRType(tynm, tentry) -> ft tynm tentry acc\n | SRModule(modnm, mentry) -> fm modnm mentry acc\n | SRSig(signm, sentry) -> fs signm sentry acc\n ) init\n\n\n let map_and_fold (type a)\n ~v:(fv : identifier -> value_entry -> a -> value_entry * a)\n ~c:(fc : constructor_name -> constructor_entry -> a -> constructor_entry * a)\n ~f:(ff : type_name -> poly_type -> a -> poly_type * a)\n ~t:(ft : type_name -> type_entry -> a -> type_entry * a)\n ~m:(fm : module_name -> module_entry -> a -> module_entry * a)\n ~s:(fs : signature_name -> signature_entry -> a -> signature_entry * a)\n (init : a) (sigr : t) : t * a =\n sigr |> Alist.to_list |> List.fold_left (fun (sigracc, acc) entry ->\n match entry with\n | SRVal(x, ventry) ->\n let (ventry, acc) = fv x ventry acc in\n (Alist.extend sigracc (SRVal(x, ventry)), acc)\n\n | SRCtor(ctornm, centry) ->\n let (centry, acc) = fc ctornm centry acc in\n (Alist.extend sigracc (SRCtor(ctornm, centry)), acc)\n\n | SRFold(tynm, pty) ->\n let (pty, acc) = ff tynm pty acc in\n (Alist.extend sigracc (SRFold(tynm, pty)), acc)\n\n | SRType(tynm, tentry) ->\n let (tentry, acc) = ft tynm tentry acc in\n (Alist.extend sigracc (SRType(tynm, tentry)), acc)\n\n | SRModule(modnm, mentry) ->\n let (mentry, acc) = fm modnm mentry acc in\n (Alist.extend sigracc (SRModule(modnm, mentry)), acc)\n\n | SRSig(signm, sentry) ->\n let (sentry, acc) = fs signm sentry acc in\n (Alist.extend sigracc (SRSig(signm, sentry)), acc)\n\n ) (Alist.empty, init)\n\n\n let map (type a)\n ~v:(fv : identifier -> value_entry -> value_entry)\n ~c:(fc : constructor_name -> constructor_entry -> constructor_entry)\n ~f:(ff : type_name -> poly_type -> poly_type)\n ~t:(ft : type_name -> type_entry -> type_entry)\n ~m:(fm : module_name -> module_entry -> module_entry)\n ~s:(fs : signature_name -> signature_entry -> signature_entry)\n (sigr : t) : t =\n let (sigr, ()) =\n sigr |> map_and_fold\n ~v:(fun x ventry () -> (fv x ventry, ()))\n ~c:(fun ctornm centry () -> (fc ctornm centry, ()))\n ~f:(fun tynm pty () -> (ff tynm pty, ()))\n ~t:(fun tynm tentry () -> (ft tynm tentry, ()))\n ~m:(fun modnm mentry () -> (fm modnm mentry, ()))\n ~s:(fun signm sentry () -> (fs signm sentry, ()))\n ()\n in\n sigr\n\n(*\n let overwrite (superior : t) (inferior : t) : t =\n let left _ x _ = Some(x) in\n let sr_vals = ValNameMap.union left superior.sr_vals inferior.sr_vals in\n let sr_types = TypeNameMap.union left superior.sr_types inferior.sr_types in\n let sr_modules = ModuleNameMap.union left superior.sr_modules inferior.sr_modules in\n let sr_sigs = SignatureNameMap.union left superior.sr_sigs inferior.sr_sigs in\n let sr_ctors = ConstructorMap.union left superior.sr_ctors inferior.sr_ctors in\n { sr_vals; sr_types; sr_modules; sr_sigs; sr_ctors }\n*)\n\n exception Conflict of string\n\n\n let disjoint_union (sigr1 : t) (sigr2 : t) : (t, string) result =\n let check_none s opt =\n match opt with\n | None -> ()\n | Some(_) -> raise (Conflict(s))\n in\n try\n let sigr =\n sigr2 |> Alist.to_list |> List.fold_left (fun sigracc entry ->\n let () =\n match entry with\n | SRVal(x, _) -> check_none x (find_value x sigr1)\n | SRCtor(ctornm, _) -> check_none ctornm (find_constructor ctornm sigr1)\n | SRFold(_, _) -> ()\n | SRType(tynm, _) -> check_none tynm (find_type tynm sigr1)\n | SRModule(modnm, _) -> check_none modnm (find_module modnm sigr1)\n | SRSig(signm, _) -> check_none signm (find_signature signm sigr1)\n in\n Alist.extend sigracc entry\n ) sigr1\n in\n Ok(sigr)\n with\n | Conflict(s) -> Error(s)\nend\n\n(*\nlet pp_comma ppf () =\n Format.fprintf ppf \", \"\n\n\nlet pp_bound_type_id ppf bid =\n let pkd = KindStore.get_bound_id bid in\n match pkd with\n | UniversalKind ->\n Format.fprintf ppf \"%a\" BoundID.pp bid\n\n | _ ->\n let (_, _, skd) = TypeConv.show_poly_base_kind pkd in\n Format.fprintf ppf \"%a :: %s\" BoundID.pp bid skd\n\n\nlet pp_type_parameters ppf typarams =\n match typarams with\n | [] ->\n ()\n\n | _ :: _ ->\n Format.fprintf ppf \"<%a>\"\n (Format.pp_print_list ~pp_sep:pp_comma pp_bound_type_id) typarams\n\n\nlet display_poly_type pty =\n let (sbids, sbrids, sty) = TypeConv.show_poly_type pty in\n let ssub =\n let ss = List.append sbids sbrids in\n if ss = [] then\n \"\"\n else\n \"<\" ^ (String.concat \", \" ss) ^ \">\"\n in\n (ssub, sty)\n\n\nlet display_poly_type_params (ptys : poly_type list) =\n match ptys with\n | [] ->\n \"\"\n\n | _ :: _ ->\n let ss = ptys |> List.map display_poly_type |> List.map (fun (_, sty) -> sty) in\n Printf.sprintf \"(%s)\" (String.concat \", \" ss)\n\n\nlet rec display_signature (depth : int) (modsig : module_signature) : unit =\n let indent = String.make (depth * 2) ' ' in\n match modsig with\n | ConcStructure(sigr) ->\n Format.printf \"%ssig\\n\" indent;\n display_structure (depth + 1) sigr;\n Format.printf \"%send\\n\" indent\n\n | ConcFunctor(sigftor) ->\n let (oidset1, Domain(sigr1), (oidset2, modsigcod)) = (sigftor.opaques, sigftor.domain, sigftor.codomain) in\n let modsigdom = ConcStructure(sigr1) in\n let sx1 = stringify_opaque_id_set oidset1 in\n let sx2 = stringify_opaque_id_set oidset2 in\n Format.printf \"%s(forall%s) fun(\\n\" indent sx1;\n display_signature (depth + 1) modsigdom;\n Format.printf \"%s) -> (exists%s)\\n\" indent sx2;\n display_signature (depth + 1) modsigcod\n\n\nand display_structure (depth : int) (sigr : SigRecord.t) : unit =\n let indent = String.make (depth * 2) ' ' in\n sigr |> SigRecord.fold\n ~v:(fun x (pty, _) () ->\n let (ssub, sty) = display_poly_type pty in\n Format.printf \"%sval %s%s : %s\\n\" indent x ssub sty\n )\n ~t:(fun tydefs () ->\n tydefs |> List.iter (fun (tynm, tyopac) ->\n let (tyid, pkd) = tyopac in\n match tyid with\n | TypeID.Synonym(sid) ->\n let (typarams, ptyreal) = TypeDefinitionStore.find_synonym_type sid in\n let (_, sty) = display_poly_type ptyreal in\n Format.printf \"%stype %a%a = %s\\n\"\n indent\n TypeID.Synonym.pp sid\n pp_type_parameters typarams\n sty\n\n | TypeID.Variant(vid) ->\n let (typarams, ctorbrs) = TypeDefinitionStore.find_variant_type vid in\n Format.printf \"%stype %a%a =\\n\"\n indent\n TypeID.Variant.pp vid\n pp_type_parameters typarams;\n ctorbrs |> ConstructorMap.iter (fun ctor (ctorid, ptyparams) ->\n let sparam = display_poly_type_params ptyparams in\n Format.printf \"%s | %s%s\\n\"\n indent\n ctor\n sparam\n )\n\n | TypeID.Opaque(oid) ->\n let (_, _, skd) = TypeConv.show_poly_kind pkd in\n Format.printf \"%stype %a :: %s\\n\"\n indent\n TypeID.Opaque.pp oid\n skd\n )\n )\n ~m:(fun modnm (modsig, _) () ->\n Format.printf \"%smodule %s :\\n\" indent modnm;\n display_signature (depth + 1) modsig\n )\n ~s:(fun signm (oidset, modsig) () ->\n let sx = stringify_opaque_id_set oidset in\n Format.printf \"%ssignature %s =\\n\" indent signm;\n Format.printf \"%s (exists%s)\\n\" indent sx;\n display_signature (depth + 2) modsig\n )\n ()\n\n\nlet display_top_structure ((_, modnm) : module_name ranged) (sigr : SigRecord.t) =\n Format.printf \" --------------------------------\\n\";\n Format.printf \" module %s =\\n\" modnm;\n display_structure 2 sigr;\n Format.printf \" --------------------------------\\n\"\n*)\n" }, { "path": "src/env.mli", "content": "\nopen Syntax\n\ntype environment\n\ntype record_signature\n\ntype ('a, 'b) typ =\n (('a, 'b) typ_main) ranged\n\nand ('a, 'b) typ_main =\n | BaseType of base_type\n | FuncType of ('a, 'b) domain_type * ('a, 'b) typ\n | PidType of ('a, 'b) pid_type\n | EffType of ('a, 'b) domain_type * ('a, 'b) effect * ('a, 'b) typ\n | TypeVar of 'a\n | ProductType of (('a, 'b) typ) TupleList.t\n | TypeApp of TypeID.t * (('a, 'b) typ) list\n | RecordType of ('a, 'b) row\n | PackType of module_signature abstracted\n\nand ('a, 'b) domain_type = {\n ordered : (('a, 'b) typ) list;\n mandatory : (('a, 'b) typ) LabelAssoc.t;\n optional : ('a, 'b) row;\n}\n\nand ('a, 'b) effect =\n | Effect of ('a, 'b) typ\n\nand ('a, 'b) pid_type =\n | Pid of ('a, 'b) typ\n\nand ('a, 'b) row =\n | RowCons of label ranged * (('a, 'b) typ) * ('a, 'b) row\n | RowVar of 'b\n | RowEmpty\n\nand base_kind =\n | TypeKind\n | RowKind of LabelSet.t\n\nand module_signature_main =\n | ConcStructure of record_signature\n | ConcFunctor of functor_signature\n\nand module_signature =\n signature_source * module_signature_main\n\nand signature_source =\n | ISigVar of Address.t * signature_name\n | ISigWith of signature_source * (type_name * type_entry) list\n | ISigFunctor of signature_name * signature_source * signature_source\n | ISigDecls of record_signature\n\nand functor_signature = {\n opaques : quantifier;\n domain : functor_domain;\n codomain : module_signature abstracted;\n closure : (module_name ranged * untyped_module * environment) option;\n}\n\nand functor_domain =\n | Domain of signature_source * record_signature\n\nand kind =\n | Kind of (base_kind) list * base_kind\n (* Handles order-0 or order-1 kind only. *)\n\nand mono_type_var_updatable =\n | Free of FreeID.t\n | Link of mono_type\n\nand mono_type_var =\n | Updatable of mono_type_var_updatable ref\n | MustBeBound of MustBeBoundID.t\n\nand mono_row_var_updatable =\n | FreeRow of FreeRowID.t\n | LinkRow of mono_row\n\nand mono_row_var =\n | UpdatableRow of mono_row_var_updatable ref\n | MustBeBoundRow of MustBeBoundRowID.t\n\nand mono_type = (mono_type_var, mono_row_var) typ\n\nand mono_row = (mono_type_var, mono_row_var) row\n\nand mono_effect = (mono_type_var, mono_row_var) effect\n\nand mono_domain_type = (mono_type_var, mono_row_var) domain_type\n\nand poly_type_var =\n | Mono of mono_type_var\n | Bound of BoundID.t\n\nand poly_row_var =\n | MonoRow of mono_row_var\n | BoundRow of BoundRowID.t\n\nand poly_type = (poly_type_var, poly_row_var) typ\n\nand poly_row = (poly_type_var, poly_row_var) row\n\nand poly_domain_type = (poly_type_var, poly_row_var) domain_type\n\nand quantifier = kind OpaqueIDMap.t\n\nand 'a abstracted = quantifier * 'a\n\nand type_entry = {\n type_scheme : type_scheme_with_entity;\n type_kind : kind;\n type_doc : string option;\n}\n[@@deriving show { with_path = false }]\n\nand type_scheme_with_entity = BoundID.t list * poly_type * type_entity\n\nand type_entity =\n | Opaque of TypeID.t\n | Synonym\n | Variant of constructor_map\n\nand constructor_map = (ConstructorID.t * poly_type list) ConstructorMap.t\n\nval pp_module_signature : Format.formatter -> module_signature -> unit\n\ntype ('a, 'b) normalized_row =\n | NormalizedRow of (('a, 'b) typ) LabelAssoc.t * 'b option\n\ntype normalized_mono_row = (mono_type_var, mono_row_var) normalized_row\n\ntype normalized_poly_row = (poly_type_var, poly_row_var) normalized_row\n\ntype value_entry = {\n val_type : poly_type;\n val_global : global_name;\n val_doc : string option;\n}\n\ntype type_scheme = BoundID.t list * poly_type\n\ntype module_entry = {\n mod_signature : module_signature;\n mod_name : space_name;\n mod_doc : string option;\n}\n\ntype signature_entry = {\n sig_signature : module_signature abstracted;\n sig_doc : string option;\n sig_address : Address.t;\n}\n\ntype constructor_entry = {\n belongs : TypeID.t;\n constructor_id : ConstructorID.t;\n type_variables : BoundID.t list;\n parameter_types : poly_type list;\n}\n\ntype local_row_parameter_map = (MustBeBoundRowID.t * LabelSet.t) RowParameterMap.t\n\nmodule Typeenv : sig\n\n type t = environment\n\n val empty : t\n\n val map :\n v:(poly_type * name -> poly_type * name) ->\n m:(module_signature * space_name -> module_signature * space_name) ->\n t -> t\n\n val add_value : identifier -> poly_type -> name -> t -> t\n\n val find_value : identifier -> t -> (poly_type * name) option\n\n val is_val_properly_used : identifier -> t -> bool option\n\n val fold_value : (identifier -> poly_type -> 'a -> 'a) -> t -> 'a -> 'a\n\n val add_constructor : constructor_name -> constructor_entry -> t -> t\n\n val find_constructor : constructor_name -> t -> constructor_entry option\n\n val add_type : type_name -> type_entry -> t -> t\n\n val add_opaque_id : type_name -> TypeID.t -> kind -> t -> t\n\n val find_type : type_name -> t -> type_entry option\n\n val add_module : module_name -> module_entry -> t -> t\n\n val find_module : module_name -> t -> module_entry option\n\n val add_signature : signature_name -> signature_entry -> t -> t\n\n val find_signature : signature_name -> t -> signature_entry option\n\nend\n\nmodule SigRecord : sig\n\n type t = record_signature\n\n val empty : t\n\n val add_value : identifier -> value_entry -> t -> t\n\n val find_value : identifier -> t -> value_entry option\n\n val add_constructor : constructor_name -> constructor_entry -> t -> t\n\n val find_constructor : constructor_name -> t -> constructor_entry option\n\n val add_dummy_fold : type_name -> poly_type -> t -> t\n\n val find_dummy_fold : type_name -> t -> poly_type option\n\n val add_type : type_name -> type_entry -> t -> t\n\n val find_type : type_name -> t -> type_entry option\n\n val add_module : module_name -> module_entry -> t -> t\n\n val find_module : module_name -> t -> module_entry option\n\n val add_signature : signature_name -> signature_entry -> t -> t\n\n val find_signature : signature_name -> t -> signature_entry option\n\n val fold :\n v:(identifier -> value_entry -> 'a -> 'a) ->\n c:(constructor_name -> constructor_entry -> 'a -> 'a) ->\n f:(type_name -> poly_type -> 'a -> 'a) ->\n t:(type_name -> type_entry -> 'a -> 'a) ->\n m:(module_name -> module_entry -> 'a -> 'a) ->\n s:(signature_name -> signature_entry -> 'a -> 'a) ->\n 'a -> t -> 'a\n\n val map_and_fold :\n v:(identifier -> value_entry -> 'a -> value_entry * 'a) ->\n c:(constructor_name -> constructor_entry -> 'a -> constructor_entry * 'a) ->\n f:(type_name -> poly_type -> 'a -> poly_type * 'a) ->\n t:(type_name -> type_entry -> 'a -> type_entry * 'a) ->\n m:(module_name -> module_entry -> 'a -> module_entry * 'a) ->\n s:(signature_name -> signature_entry -> 'a -> signature_entry * 'a) ->\n 'a -> t -> t * 'a\n\n val map :\n v:(identifier -> value_entry -> value_entry) ->\n c:(constructor_name -> constructor_entry -> constructor_entry) ->\n f:(type_name -> poly_type -> poly_type) ->\n t:(type_name -> type_entry -> type_entry) ->\n m:(module_name -> module_entry -> module_entry) ->\n s:(signature_name -> signature_entry -> signature_entry) ->\n t -> t\n\n val disjoint_union : t -> t -> (t, string) result\n\nend\n(*\nval display_signature : int -> module_signature -> unit\n\nval display_structure : int -> SigRecord.t -> unit\n\nval display_top_structure : module_name ranged -> SigRecord.t -> unit\n*)\n" }, { "path": "src/errors.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Env\n\ntype config_error =\n | CyclicFileDependencyFound of absolute_path cycle\n | ConfigFileError of YamlDecoder.error\n | MultipleModuleOfTheSameName of module_name * absolute_path * absolute_path\n | ModuleNotFound of Range.t * module_name\n | InvalidPackageName of string\n | CannotSpecifyDependency\n | MainModuleNotFound of package_name * module_name\n | UnrecognizableExtension of string\n | ConfigFileNotFound of absolute_dir\n | SourceFileDependsOnTestFile of module_name * module_name\n | NoOutputSpecForSingleSource\n | UnsupportedLanguageVersion of string\n\nexception ConfigError of config_error\n\ntype package_error =\n | DuplicatedPackageName of package_name * absolute_path * absolute_path\n | PackageDirNotFound of absolute_dir\n | NotFoundInExternalMap of package_name * external_map\n\ntype lexer_error =\n | UnidentifiedToken of Range.t * string\n | SeeEndOfFileInComment of Range.t\n | SeeEndOfFileInStringLiteral of Range.t\n | BlockClosedWithTooManyBackQuotes of Range.t\n | SeeBreakInStringLiteral of Range.t\n | NotASingleCodePoint of Range.t\n | UnknownEscapeSequence of Range.t\n\ntype syntax_error =\n | LexerError of lexer_error\n | ParseError of Range.t\n\ntype unification_error =\n | Contradiction\n | Inclusion of FreeID.t\n | InclusionRow of FreeRowID.t\n | InsufficientRowConstraint of { id : MustBeBoundRowID.t; given : LabelSet.t; required : LabelSet.t; }\n\ntype type_error =\n | UnboundVariable of Range.t * identifier\n | UnificationError of { actual : mono_type; expected : mono_type; detail : unification_error; }\n | BadArityOfOrderedArguments of { range : Range.t; got : int; expected : int; }\n | BoundMoreThanOnceInPattern of Range.t * identifier\n | UnboundTypeParameter of Range.t * type_variable_name\n | UnboundRowParameter of Range.t * row_variable_name\n | UndefinedConstructor of Range.t * constructor_name\n | InvalidNumberOfConstructorArguments of Range.t * constructor_name * int * int\n | UndefinedTypeName of Range.t * type_name\n | UndefinedKindName of Range.t * kind_name\n | InvalidNumberOfTypeArguments of Range.t * type_name * int * int\n | KindContradiction of Range.t * type_name * kind * kind\n | TypeParameterBoundMoreThanOnce of Range.t * type_variable_name\n | RowParameterBoundMoreThanOnce of Range.t * row_variable_name\n | InvalidByte of Range.t\n | CyclicSynonymTypeDefinition of (type_name ranged) cycle\n | UnboundModuleName of Range.t * module_name\n | NotOfStructureType of Range.t * module_signature\n | NotOfFunctorType of Range.t * module_signature\n | NotAFunctorSignature of Range.t * module_signature\n | NotAStructureSignature of Range.t * module_signature\n | UnboundSignatureName of Range.t * signature_name\n | CannotRestrictTransparentType of Range.t * type_name * type_entry\n | PolymorphicContradiction of Range.t * identifier * poly_type * poly_type\n | PolymorphicInclusion of Range.t * FreeID.t * poly_type * poly_type\n | MissingRequiredValName of Range.t * identifier * poly_type\n | MissingRequiredConstructorName of Range.t * constructor_name * constructor_entry\n | MissingRequiredTypeName of Range.t * type_name * type_entry\n | MissingRequiredModuleName of Range.t * module_name * module_signature\n | MissingRequiredSignatureName of Range.t * signature_name * module_signature abstracted\n | NotASubtype of Range.t * module_signature * module_signature\n | NotASubtypeTypeDefinition of Range.t * type_name * type_entry * type_entry\n | NotASubtypeConstructorDefinition of Range.t * constructor_name * constructor_entry * constructor_entry\n | NotASubtypeVariant of Range.t * TypeID.t * TypeID.t * constructor_name\n | OpaqueIDExtrudesScopeViaValue of Range.t * poly_type\n | OpaqueIDExtrudesScopeViaType of Range.t * type_entry\n | OpaqueIDExtrudesScopeViaSignature of Range.t * module_signature abstracted\n | SupportOnlyFirstOrderFunctor of Range.t\n | RootModuleMustBeStructure of Range.t\n | InvalidIdentifier of Range.t * string\n | ConflictInSignature of Range.t * string\n | DuplicatedLabel of Range.t * label\n | UnexpectedMandatoryLabel of { range : Range.t; label : label; }\n | MissingMandatoryLabel of { range : Range.t; label : label; typ : mono_type; }\n | UnexpectedOptionalLabel of { range : Range.t; label : label; }\n | NullaryFormatString of Range.t\n | CannotFreezeNonGlobalName of Range.t * identifier\n" }, { "path": "src/fileDependencyGraph.ml", "content": "\nopen MyUtil\nopen Syntax\n\nmodule GraphImpl = Graph.Persistent.Digraph.Abstract(String)\n\nmodule ComponentImpl = Graph.Components.Make(GraphImpl)\n\nmodule TopologicalImpl = Graph.Topological.Make(GraphImpl)\n\nmodule PathMap = Map.Make(String)\n\ntype vertex = GraphImpl.V.t\n\ntype entry = {\n vertex : vertex;\n}\n\ntype t = {\n paths : entry PathMap.t;\n main : GraphImpl.t;\n}\n\n\nlet empty : t = {\n paths = PathMap.empty;\n main = GraphImpl.empty;\n}\n\n\nlet find_vertex (fpath : absolute_path) (graph : t) : vertex option =\n graph.paths |> PathMap.find_opt fpath |> Option.map (fun entry -> entry.vertex)\n\n\nlet add_vertex (abspath : absolute_path) (graph : t) : t * vertex =\n let vertex = GraphImpl.V.create abspath in\n let entry = { vertex = vertex; } in\n let graph =\n {\n paths = graph.paths |> PathMap.add abspath entry;\n main = GraphImpl.add_vertex graph.main vertex;\n }\n in\n (graph, vertex)\n\n\nlet add_edge ~depending:(vertex2 : vertex) ~depended:(vertex1 : vertex) (graph : t) : t =\n { graph with main = GraphImpl.add_edge graph.main vertex1 vertex2 }\n\n\nlet find_loop g =\n GraphImpl.fold_vertex (fun v acc ->\n match acc with\n | Some(_) -> acc\n | None -> if GraphImpl.mem_edge g v v then Some(v) else None\n ) g None\n\n\nlet topological_sort (graph : t) : (absolute_path list, absolute_path cycle) result =\n match find_loop graph.main with\n | Some(v) ->\n Error(Loop(GraphImpl.V.label v))\n\n | None ->\n let sccs = ComponentImpl.scc_list graph.main in\n match\n sccs |> List.find_map (fun vertices ->\n match vertices with\n | [] -> assert false\n | [ _ ] -> None\n | v1 :: v2 :: vrest -> Some(Cycle(List2.make v1 v2 vrest |> List2.map GraphImpl.V.label))\n )\n with\n | Some(cycle) ->\n Error(cycle)\n\n | None ->\n let acc =\n TopologicalImpl.fold (fun vertex acc ->\n let abspath = GraphImpl.V.label vertex in\n Alist.extend acc abspath\n ) graph.main Alist.empty\n in\n Ok(Alist.to_list acc)\n" }, { "path": "src/fileDependencyGraph.mli", "content": "\nopen MyUtil\nopen Syntax\n\ntype vertex\n\ntype t\n\nval empty : t\n\nval find_vertex : absolute_path -> t -> vertex option\n\nval add_vertex : absolute_path -> t -> t * vertex\n\nval add_edge : depending:vertex -> depended:vertex -> t -> t\n\nval topological_sort : t -> (absolute_path list, absolute_path cycle) result\n(** [topological_sort g] returns either:\n {ul\n {- [Ok(paths)] where [paths] is the sorted list of absolute paths of source files, or}\n {- [Error(cycle)] where [cycle] is a list of mutually dependent source files.}\n } *)\n" }, { "path": "src/freeID.ml", "content": "\ntype level = int\n\ntype t = {\n id : int;\n mutable level : level;\n}\n\n\nlet pp ppf fid =\n Format.fprintf ppf \"'%d\" fid.id\n\n\nlet equal fid1 fid2 =\n fid1.id = fid2.id\n\n\nlet compare fid1 fid2 =\n fid2.id - fid1.id\n\n\nlet hash fid =\n fid.id\n\n\nlet current_max = ref 0\n\n\nlet initialize () =\n current_max := 0\n\n\nlet fresh ~message:_msg lev =\n incr current_max;\n let ret = { id = !current_max; level = lev; } in\n(*\n print_endline (Format.asprintf \"generate %a (%s)\" pp ret msg); (* for debug *)\n*)\n ret\n\n\nlet get_level fid =\n fid.level\n\n\nlet update_level fid lev =\n fid.level <- min fid.level lev\n" }, { "path": "src/freeID.mli", "content": "\ntype level = int\n\ntype t\n\nval equal : t -> t -> bool\n\nval compare : t -> t -> int\n\nval hash : t -> int\n\nval initialize : unit -> unit\n\nval fresh : message:string -> level -> t\n\nval get_level : t -> level\n\nval update_level : t -> level -> unit\n\nval pp : Format.formatter -> t -> unit\n" }, { "path": "src/identifierScheme.ml", "content": "(**\n Every fragment should be a non-empty string consisting only of lowercase letters and digits.\n\n `to_upper_camel_case name` outputs `name` in upper camel case\n (with inserting underscores before every fragment that begins with a digit):\n\n*)\n\ntype t = {\n fragments : string list;\n original : string;\n}\n\nlet is_digit ch =\n '0' <= ch && ch <= '9'\n\n\nlet is_lowercase ch =\n 'a' <= ch && ch <= 'z'\n\nlet is_uppercase ch =\n 'A' <= ch && ch <= 'Z'\n\nlet to_lowercase ch =\n Char.chr (Char.code ch + 0x20)\n\n\nlet string_of_chars (chs : char list) : string =\n let len = List.length chs in\n let buf = Buffer.create len in\n chs |> List.iter (Buffer.add_char buf);\n Buffer.contents buf\n\n\nlet is_valid_fragment s =\n String.length s > 0 && String.equal s (String.lowercase_ascii s)\n\n\nlet is_valid =\n List.for_all is_valid_fragment\n\n\nlet from_snake_case (original : string) : t option =\n let fragments = String.split_on_char '_' original in\n if is_valid fragments then Some({ fragments; original; }) else None\n\n\nlet from_upper_camel_case (original : string) : t option =\n let len = String.length original in\n let rec aux (fragacc : string list) (chacc : char list) (index : int) =\n if index >= len then\n let fragment = string_of_chars (List.rev chacc) in\n let fragments = List.rev (fragment :: fragacc) in\n Some{ fragments; original }\n else\n let ch = String.get original index in\n if is_uppercase ch then\n let fragment = string_of_chars (List.rev chacc) in\n aux (fragment :: fragacc) [ to_lowercase ch ] (index + 1)\n else if is_lowercase ch || is_digit ch then\n aux fragacc (ch :: chacc) (index + 1)\n else if ch = '_' then\n let ch2 = String.get original (index + 1) in\n if is_digit ch2 then\n let fragment = string_of_chars (List.rev chacc) in\n aux (fragment :: fragacc) [ ch2 ] (index + 2)\n else\n None\n else\n None\n in\n try\n let ch0 = String.get original 0 in\n if is_uppercase ch0 then\n aux [] [ to_lowercase ch0 ] 1\n else\n None\n with\n | Invalid_argument(_) -> None\n\n\nlet original (name : t) : string =\n name.original\n\n\nlet to_snake_case (name : t) : string =\n name.fragments |> String.concat \"_\"\n\n\nlet capitalize (is_lower_first : bool) (fragment : string) =\n if is_lower_first then\n fragment\n else\n String.capitalize_ascii fragment\n\n\nlet camel_case (is_lower : bool) (name : t) : string =\n let rec aux is_lower_first acc = function\n | [] ->\n List.rev acc\n\n | x :: [] ->\n List.rev (capitalize is_lower_first x :: acc)\n\n | x :: ((y :: _) as rest) ->\n let xcap = capitalize is_lower_first x in\n if is_digit (String.get y 0) then\n aux false ((xcap ^ \"_\") :: acc) rest\n else\n aux false (xcap :: acc) rest\n in\n aux is_lower [] name.fragments |> String.concat \"\"\n\n\nlet to_lower_camel_case = camel_case true\n\nlet to_upper_camel_case = camel_case false\n\n\nlet pp ppf name =\n Format.fprintf ppf \"<\\\"%s\\\">\" (to_snake_case name)\n\n\nlet compare name1 name2 =\n String.compare name1.original name2.original\n" }, { "path": "src/identifierScheme.mli", "content": "(** `IdentifierScheme` is a module that abstracts identifiers\n for equating the snake case and the upper camel case.\n*)\n\ntype t\n\nval from_snake_case : string -> t option\n(** [from_snake_case s] converts the original identifier string [s] into its corresponding list of word fragments.\n Here, [s] should match [ * ('_' +)*].\n\n {[\n from_snake_case \"foo_bar\" (* ==> Some{ fragments = [\"foo\"; \"bar\"]; ... } *)\n from_snake_case \"foo_Bar\" (* ==> None *)\n from_snake_case \"foo__bar\" (* ==> None *)\n from_snake_case \"foo_bar_\" (* ==> None *)\n from_snake_case \"x86_64\" (* ==> Some{ fragments = [\"x86\"; \"64\"]; ... } *)\n ]}\n*)\n\nval from_upper_camel_case : string -> t option\n\nval original : t -> string\n\nval to_snake_case : t -> string\n\nval to_lower_camel_case : t -> string\n\nval to_upper_camel_case : t -> string\n(** {[\n to_upper_camel_case { fragments = [\"foo\"; \"bar\"]; ... } (* ==> \"FooBar\" *)\n to_upper_camel_case { fragments = [\"x86\"; \"64\"]; ... } (* ==> \"X86_64\" *)\n ]}\n*)\n\nval pp : Format.formatter -> t -> unit\n\nval compare : t -> t -> int\n" }, { "path": "src/intermediateSyntax.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Env\n\n\ntype pattern =\n | IPUnit\n | IPBool of bool\n | IPInt of int\n | IPBinary of string\n | IPChar of Uchar.t\n [@printer (fun ppf uchar -> Format.fprintf ppf \"IPChar(%a)\" pp_uchar uchar)]\n | IPVar of local_name\n | IPWildCard\n | IPListNil\n | IPListCons of pattern * pattern\n | IPTuple of pattern TupleList.t\n | IPConstructor of ConstructorID.t * pattern list\n[@@deriving show { with_path = false; } ]\n\ntype val_binding =\n | INonRec of (identifier * global_name * poly_type * ast)\n | IRec of (identifier * global_name * poly_type * ast) list\n | IExternal of global_name * string\n\nand binding =\n | IBindVal of val_binding\n | IBindModule of space_name * ModuleAttribute.t * binding list\n\nand ast =\n | IBaseConst of base_constant\n | IVar of name\n | ILambda of local_name option * pattern list * pattern LabelAssoc.t * (pattern * ast option) LabelAssoc.t * ast\n | IApply of name * mono_row * ast list * ast LabelAssoc.t * ast LabelAssoc.t\n | ILetIn of local_name * ast * ast\n | ICase of ast * branch list\n | IReceive of branch list * (ast * ast) option\n | ITuple of ast TupleList.t\n | IListNil\n | IListCons of ast * ast\n | IConstructor of ConstructorID.t * ast list\n | IRecord of ast LabelAssoc.t\n | IRecordAccess of ast * label\n | IRecordUpdate of ast * label * ast\n | IFreeze of global_name * ast list\n | IFreezeUpdate of ast * ast list\n | IPack of space_name\n | IAssert of Range.t * ast\n\nand branch =\n | IBranch of pattern * ast\n\n\nlet pp_sep_comma ppf () =\n Format.fprintf ppf \",@ \"\n\n\nlet rec pp_val_binding_sub ppf (gname, e) =\n Format.fprintf ppf \"%a =@[@ %a@]@,\"\n OutputIdentifier.pp_global gname\n pp_ast e\n\n\nand pp_val_binding ppf = function\n | INonRec(_, gname, _, e) ->\n Format.fprintf ppf \"val %a\"\n pp_val_binding_sub (gname, e)\n\n | IRec(recbinds) ->\n let pairs = recbinds |> List.map (fun (_, gname, _, e) -> (gname, e)) in\n Format.fprintf ppf \"val %a\"\n (Format.pp_print_list ~pp_sep:pp_sep_comma pp_val_binding_sub) pairs\n\n | IExternal(gname, code) ->\n Format.fprintf ppf \"val %a = external@ \\\"%s\\\"@,\"\n OutputIdentifier.pp_global gname\n code\n\n\nand pp_binding ppf = function\n | IBindVal(valbind) ->\n pp_val_binding ppf valbind\n\n | IBindModule(sname, _modattr, ibinds) ->\n Format.fprintf ppf \"module %a = @[{%a}@]@,\"\n OutputIdentifier.pp_space sname\n (Format.pp_print_list pp_binding) ibinds\n\n\nand pp_ast ppf = function\n | IBaseConst(bc) ->\n pp_base_constant ppf bc\n\n | IVar(name) ->\n OutputIdentifier.pp ppf name\n\n | ILambda(lnamerecopt, ordipats, mndipatmap, optipatmap, e) ->\n let snamerec =\n match lnamerecopt with\n | Some(lnamerec) -> Format.asprintf \"%a\" OutputIdentifier.pp_local lnamerec\n | None -> \"\"\n in\n Format.fprintf ppf \"\\\\%s(%a -{%a} ?{%a}) ->@[@ %a@]\"\n snamerec\n (Format.pp_print_list ~pp_sep:pp_sep_comma pp_pattern) ordipats\n (LabelAssoc.pp pp_pattern) mndipatmap\n (LabelAssoc.pp (fun ppf (ipat, astopt) ->\n match astopt with\n | None ->\n Format.fprintf ppf \"%a\"\n pp_pattern ipat\n\n | Some(ast) ->\n Format.fprintf ppf \"%a = %a\"\n pp_pattern ipat\n pp_ast ast\n )) optipatmap\n pp_ast e\n\n | IApply(name, _, eargs, mndargmap, optargmap) ->\n Format.fprintf ppf \"%a@[(%a -{%a} ?{%a})@]\"\n OutputIdentifier.pp name\n (Format.pp_print_list ~pp_sep:pp_sep_comma pp_ast) eargs\n (LabelAssoc.pp pp_ast) mndargmap\n (LabelAssoc.pp pp_ast) optargmap\n\n | ILetIn(lname, e1, e2) ->\n Format.fprintf ppf \"(let %a =@[@ %a@]@ in@ %a)\"\n OutputIdentifier.pp_local lname\n pp_ast e1\n pp_ast e2\n\n | ICase(e0, ibrs) ->\n Format.fprintf ppf \"(case@[@ %a@]@ of@[@ %a@]@ end)\"\n pp_ast e0\n (Format.pp_print_list pp_branch) ibrs\n\n | ITuple(es) ->\n Format.fprintf ppf \"{%a}\"\n (Format.pp_print_list ~pp_sep:pp_sep_comma pp_ast) (es |> TupleList.to_list)\n\n | _ ->\n Format.fprintf ppf \"...\"\n\n\nand pp_branch ppf = function\n | IBranch(ipat, e) ->\n Format.fprintf ppf \"%a ->@[@ %a@];@ \"\n pp_pattern ipat\n pp_ast e\n\n\nmodule GlobalNameMap = Map.Make(OutputIdentifier.Global)\n\nmodule SpaceNameMap = Map.Make(OutputIdentifier.Space)\n\ntype name_map = string GlobalNameMap.t * string SpaceNameMap.t\n(* The type for maps tracking which module every global name belongs to.\n This is used by 'Primitives' and 'OutputErlangCode'. *)\n" }, { "path": "src/kindStore.ml", "content": "\nopen Syntax\nopen Env\n\n\nmodule FreeRowHashTable = Hashtbl.Make(FreeRowID)\n\nmodule BoundRowHashTable = Hashtbl.Make(BoundRowID)\n\n\nlet free_row_hash_table =\n FreeRowHashTable.create 1024\n\n\nlet bound_row_hash_table =\n BoundRowHashTable.create 1024\n\n\nlet register_free_row (frid : FreeRowID.t) (labset : LabelSet.t) : unit =\n FreeRowHashTable.add free_row_hash_table frid labset\n\n\nlet get_free_row (frid : FreeRowID.t) : LabelSet.t =\n match FreeRowHashTable.find_opt free_row_hash_table frid with\n | None -> assert false\n | Some(labset) -> labset\n\n\nlet register_bound_row (brid : BoundRowID.t) (labset : LabelSet.t) : unit =\n BoundRowHashTable.add bound_row_hash_table brid labset\n\n\nlet get_bound_row (brid : BoundRowID.t) : LabelSet.t =\n match BoundRowHashTable.find_opt bound_row_hash_table brid with\n | None -> assert false\n | Some(labset) -> labset\n" }, { "path": "src/kindStore.mli", "content": "\nopen Syntax\nopen Env\n\nval register_free_row : FreeRowID.t -> LabelSet.t -> unit\n\nval get_free_row : FreeRowID.t -> LabelSet.t\n\nval register_bound_row : BoundRowID.t -> LabelSet.t -> unit\n\nval get_bound_row : BoundRowID.t -> LabelSet.t\n" }, { "path": "src/languageVersion.ml", "content": "\ntype t = Semver.t\n\n\nlet parse (s : string) : t option =\n Option.bind (Core.String.chop_prefix s ~prefix:\"v\") Semver.of_string\n\n\nlet is_compatible ~(before : t) ~(after : t) =\n let open Semver in\n match (before.major, after.major) with\n | (0, 0) ->\n before.minor = after.minor && before.patch <= after.patch\n\n | _ ->\n before.major = after.major &&\n ((before.minor < after.minor) ||\n (before.minor == after.minor && before.patch <= after.patch))\n\n\nlet is_supported (specified_language_version : string) : bool =\n match (parse specified_language_version, parse Constants.semantic_version) with\n | (_, None) -> assert false\n | (None, _) -> false\n | (Some(specified), Some(required)) -> is_compatible ~before:specified ~after:required\n" }, { "path": "src/lexer.mll", "content": "{\n open MyUtil\n open Syntax\n open Parser\n open Errors\n\n\n exception Error of lexer_error\n\n\n let raise_error e =\n raise (Error(e))\n\n\n let hole_of_char = function\n | 'c' -> HoleC\n | 'f' -> HoleF\n | 'e' -> HoleE\n | 'g' -> HoleG\n | 's' -> HoleS\n | 'p' -> HoleP\n | 'w' -> HoleW\n | _ -> assert false\n\n\n let int_of_string_or_empty = function\n | \"\" -> None\n | s -> Some(int_of_string s)\n\n\n let flush_buffer strbuf =\n let s = Buffer.contents strbuf in\n Buffer.clear strbuf;\n FormatConst(s)\n\n\n let escape_sequence c rngL = match c with\n | 'n' -> '\\n'\n | 'r' -> '\\r'\n | 't' -> '\\t'\n | '\\\\' | '\"' | '\\'' -> c\n | _ -> raise_error (UnknownEscapeSequence(rngL))\n\n}\n\nlet space = [' ' '\\t']\nlet break = ['\\n' '\\r']\nlet nzdigit = ['1'-'9']\nlet digit = (nzdigit | \"0\")\nlet hex = (digit | ['A'-'F'])\nlet capital = ['A'-'Z']\nlet small = ['a'-'z']\nlet latin = (small | capital)\nlet identifier = (small (digit | latin | \"_\")*)\nlet constructor = (capital (digit | latin | \"_\")*)\nlet nssymbol = ['&' '|' '=' '/' '+' '-' '.']\nlet fmtdigits = ((\"-\" digit+) | (digit*))\nlet hole = ['c' 'f' 'e' 'g' 's' 'p' 'w']\n\nrule token = parse\n | space { token lexbuf }\n | break { Lexing.new_line lexbuf; token lexbuf }\n | eof { EOI }\n\n | identifier {\n let s = Lexing.lexeme lexbuf in\n let pos = Range.from_lexbuf lexbuf in\n match s with\n | \"let\" -> LET(pos)\n | \"rec\" -> REC(pos)\n | \"and\" -> AND(pos)\n | \"in\" -> IN(pos)\n | \"fun\" -> LAMBDA(pos)\n | \"if\" -> IF(pos)\n | \"then\" -> THEN(pos)\n | \"else\" -> ELSE(pos)\n | \"true\" -> TRUE(pos)\n | \"false\" -> FALSE(pos)\n | \"act\" -> ACT(pos)\n | \"do\" -> DO(pos)\n | \"receive\" -> RECEIVE(pos)\n | \"after\" -> AFTER(pos)\n | \"end\" -> END(pos)\n | \"case\" -> CASE(pos)\n | \"of\" -> OF(pos)\n | \"val\" -> VAL(pos)\n | \"type\" -> TYPE(pos)\n | \"module\" -> MODULE(pos)\n | \"struct\" -> STRUCT(pos)\n | \"signature\" -> SIGNATURE(pos)\n | \"sig\" -> SIG(pos)\n | \"with\" -> WITH(pos)\n | \"external\" -> EXTERNAL(pos)\n | \"include\" -> INCLUDE(pos)\n | \"import\" -> IMPORT(pos)\n | \"freeze\" -> FREEZE(pos)\n | \"pack\" -> PACK(pos)\n | \"assert\" -> ASSERT(pos)\n | \"open\" -> OPEN(pos)\n | _ -> LOWER(pos, s)\n }\n\n | \"f\\'\" {\n let posL = Range.from_lexbuf lexbuf in\n let strbuf = Buffer.create 128 in\n let (rng, fmtelemacc) = format_literal posL strbuf Alist.empty lexbuf in\n FORMAT(rng, Alist.to_list fmtelemacc)\n }\n\n | constructor {\n let s = Lexing.lexeme lexbuf in\n let pos = Range.from_lexbuf lexbuf in\n UPPER(pos, s)\n }\n\n | (\"0\" | nzdigit (digit*) | (\"0x\" | \"0X\") hex+) {\n let s = Lexing.lexeme lexbuf in\n let pos = Range.from_lexbuf lexbuf in\n INT(pos, int_of_string s)\n }\n | ((\"0\" | nzdigit (digit*)) \".\" (digit*)) {\n let s = Lexing.lexeme lexbuf in\n let pos = Range.from_lexbuf lexbuf in\n FLOAT(pos, float_of_string s)\n }\n\n | (\".\" (constructor as s)) {\n let pos = Range.from_lexbuf lexbuf in\n DOTUPPER(pos, s)\n }\n | (\".\" (identifier as s)) {\n let pos = Range.from_lexbuf lexbuf in\n DOTLOWER(pos, s)\n }\n\n | (\"?\" (identifier as s)) {\n let pos = Range.from_lexbuf lexbuf in\n OPTLABEL(pos, s)\n }\n | (\"?$\" (identifier as s)) {\n let pos = Range.from_lexbuf lexbuf in\n ROWPARAM(pos, s)\n }\n\n | (\"$\" (identifier as s)) {\n let pos = Range.from_lexbuf lexbuf in\n TYPARAM(pos, s)\n }\n | \"$\\'\" {\n let posL = Range.from_lexbuf lexbuf in\n let strbuf = Buffer.create 16 in\n let (rng, s) = string_literal posL strbuf lexbuf in\n match MyUtil.Utf.uchar_of_utf8 s with\n | [ uchar ] -> CHAR(rng, uchar)\n | _ -> raise_error (NotASingleCodePoint(rng))\n }\n\n | \"_\" { UNDERSCORE(Range.from_lexbuf lexbuf) }\n | \",\" { COMMA(Range.from_lexbuf lexbuf) }\n | \"(\" { LPAREN(Range.from_lexbuf lexbuf) }\n | \")\" { RPAREN(Range.from_lexbuf lexbuf) }\n | \"[\" { LSQUARE(Range.from_lexbuf lexbuf) }\n | \"]\" { RSQUARE(Range.from_lexbuf lexbuf) }\n | \"{\" { LBRACE(Range.from_lexbuf lexbuf) }\n | \"}\" { RBRACE(Range.from_lexbuf lexbuf) }\n\n | \"#[\" { ATTRIBUTE(Range.from_lexbuf lexbuf) }\n\n | \"::\" { CONS(Range.from_lexbuf lexbuf) }\n | \":\" { COLON(Range.from_lexbuf lexbuf) }\n | \":>\" { COERCE(Range.from_lexbuf lexbuf) }\n\n | (\"&\" (nssymbol*)) { BINOP_AMP(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n\n | \"|\" { BAR(Range.from_lexbuf lexbuf) }\n | (\"|\" (nssymbol+)) { BINOP_BAR(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n\n | \"=\" { DEFEQ(Range.from_lexbuf lexbuf) }\n | (\"=\" (nssymbol+)) { BINOP_EQ(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n\n | \"<-\" { REVARROW(Range.from_lexbuf lexbuf) }\n | \"<<\" { LTLT(Range.from_lexbuf lexbuf) }\n | \"<\" { LT_EXACT(Range.from_lexbuf lexbuf) }\n | (\"<\" (nssymbol+)) { BINOP_LT(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n\n | (\">\" space) { GT_SPACES(Range.from_lexbuf lexbuf) }\n | (\">\" break) { Lexing.new_line lexbuf; GT_SPACES(Range.from_lexbuf lexbuf) }\n | \">\" { GT_NOSPACE(Range.from_lexbuf lexbuf) }\n | (\">\" (nssymbol+)) { BINOP_GT(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n\n | (\"*\" (nssymbol*)) { BINOP_TIMES(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n\n | \"/*\" { comment (Range.from_lexbuf lexbuf) lexbuf; token lexbuf }\n | (\"/\" (nssymbol*)) { BINOP_DIVIDES(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n\n | (\"+\" (nssymbol*)) { BINOP_PLUS(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n\n | \"->\" { ARROW(Range.from_lexbuf lexbuf) }\n | (\"-\" (nssymbol*)) { BINOP_MINUS(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) }\n | (\"-\" (identifier as s)) {\n let pos = Range.from_lexbuf lexbuf in\n MNDLABEL(pos, s)\n }\n\n | \"\\\"\" {\n let posL = Range.from_lexbuf lexbuf in\n let strbuf = Buffer.create 128 in\n let (rng, s) = binary_literal posL strbuf lexbuf in\n BINARY(rng, s)\n }\n\n | \"\\'\" {\n let posL = Range.from_lexbuf lexbuf in\n let strbuf = Buffer.create 128 in\n let (rng, s) = string_literal posL strbuf lexbuf in\n STRING(rng, s)\n }\n\n | (\"`\"+ break) {\n (* When first character in a string block is a line break,\n ignore this line break *)\n Lexing.new_line lexbuf;\n let posL = Range.from_lexbuf lexbuf in\n let num_start = String.length (String.trim (Lexing.lexeme lexbuf)) in\n let strbuf = Buffer.create 128 in\n string_block num_start posL strbuf lexbuf\n }\n\n | (\"`\"+) {\n let posL = Range.from_lexbuf lexbuf in\n let num_start = String.length (Lexing.lexeme lexbuf) in\n let strbuf = Buffer.create 128 in\n string_block num_start posL strbuf lexbuf\n }\n\n | _ as c { raise_error (UnidentifiedToken(Range.from_lexbuf lexbuf, String.make 1 c)) }\n\nand binary_literal posL strbuf = parse\n | break { raise_error (SeeBreakInStringLiteral(posL)) }\n | eof { raise_error (SeeEndOfFileInStringLiteral(posL)) }\n | (\"\\\\\" (_ as c)) {\n Buffer.add_char strbuf (escape_sequence c posL); binary_literal posL strbuf lexbuf\n }\n | \"\\\"\" { let posR = Range.from_lexbuf lexbuf in (Range.unite posL posR, Buffer.contents strbuf) }\n | _ as c { Buffer.add_char strbuf c; binary_literal posL strbuf lexbuf }\n\nand string_literal posL strbuf = parse\n | break { raise_error (SeeBreakInStringLiteral(posL)) }\n | eof { raise_error (SeeEndOfFileInStringLiteral(posL)) }\n | (\"\\\\\" (_ as c)) {\n Buffer.add_char strbuf (escape_sequence c posL); string_literal posL strbuf lexbuf\n }\n | \"\\'\" { let posR = Range.from_lexbuf lexbuf in (Range.unite posL posR, Buffer.contents strbuf) }\n | _ as c { Buffer.add_char strbuf c; string_literal posL strbuf lexbuf }\n\nand format_literal posL strbuf acc = parse\n | break { raise_error (SeeBreakInStringLiteral(posL)) }\n | eof { raise_error (SeeEndOfFileInStringLiteral(posL)) }\n\n | \"\\'\" {\n let posR = Range.from_lexbuf lexbuf in\n let elem = flush_buffer strbuf in\n (Range.unite posL posR, Alist.extend acc elem)\n }\n\n | \"\\\\\\'\" { Buffer.add_char strbuf '\\''; format_literal posL strbuf acc lexbuf }\n\n | \"~~\" {\n let elem = flush_buffer strbuf in\n format_literal posL strbuf (Alist.append acc [elem; FormatTilde]) lexbuf\n }\n\n | \"~n\" {\n let elem = flush_buffer strbuf in\n format_literal posL strbuf (Alist.append acc [elem; FormatBreak]) lexbuf\n }\n | (\"~\" (fmtdigits as s1) (hole as c)) {\n let elem = flush_buffer strbuf in\n let hole = hole_of_char c in\n let control =\n {\n field_width = int_of_string_or_empty s1;\n precision = None;\n padding = None;\n }\n in\n format_literal posL strbuf (Alist.append acc [elem; FormatHole(hole, control)]) lexbuf\n }\n\n | (\"~\" (fmtdigits as s1) \".\" (fmtdigits as s2) (hole as c)) {\n let elem = flush_buffer strbuf in\n let hole = hole_of_char c in\n let control =\n {\n field_width = int_of_string_or_empty s1;\n precision = int_of_string_or_empty s2;\n padding = None;\n }\n in\n format_literal posL strbuf (Alist.append acc [elem; FormatHole(hole, control)]) lexbuf\n }\n\n | \"\\\\\\\"\" {\n let elem = flush_buffer strbuf in\n format_literal posL strbuf (Alist.append acc [elem; FormatDQuote]) lexbuf\n }\n\n | _ as c { Buffer.add_char strbuf c; format_literal posL strbuf acc lexbuf }\n\nand string_block num_start posL strbuf = parse\n | (\"`\" +) {\n let posR = Range.from_lexbuf lexbuf in\n let s = Lexing.lexeme lexbuf in\n let num_end = String.length s in\n if num_end > num_start then\n raise_error (BlockClosedWithTooManyBackQuotes(posR))\n else if num_end = num_start then\n STRING_BLOCK(Range.unite posL posR, Buffer.contents strbuf)\n else begin\n Buffer.add_string strbuf s;\n string_block num_start posL strbuf lexbuf\n end\n }\n | break {\n let s = Lexing.lexeme lexbuf in\n Lexing.new_line lexbuf;\n Buffer.add_string strbuf s;\n string_block num_start posL strbuf lexbuf\n }\n | eof { raise_error (SeeEndOfFileInStringLiteral(posL)) }\n | _ as c { Buffer.add_char strbuf c; string_block num_start posL strbuf lexbuf }\n\nand comment rng = parse\n | \"/*\" { comment (Range.from_lexbuf lexbuf) lexbuf; comment rng lexbuf }\n | \"*/\" { () }\n | break { Lexing.new_line lexbuf; comment rng lexbuf }\n | eof { raise_error (SeeEndOfFileInComment(rng)) }\n | _ { comment rng lexbuf }\n" }, { "path": "src/list1.ml", "content": "\nopen MyUtil\n\n\ntype 'a t = 'a * 'a list\n\n\nlet make x1 xs =\n (x1, xs)\n\n\nlet map f (x1, xs) =\n let y1 = f x1 in\n (y1, xs |> List.map f)\n\n\nlet map_and_fold : 'a 'b 'c. ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t =\nfun f acc0 (x1, xs) ->\n let (acc1, y1) = f acc0 x1 in\n let (acc, yacc) =\n xs |> List.fold_left (fun (acc, yacc) x ->\n let (acc, y) = f acc x in\n (acc, Alist.extend yacc y)\n ) (acc1, Alist.empty)\n in\n (acc, (y1, Alist.to_list yacc))\n\n\nlet to_list (x1, xs) =\n x1 :: xs\n\n\nlet pp (type a) (ppa : Format.formatter -> a -> unit) (ppf : Format.formatter) ((x1, xs) : a t) =\n Format.fprintf ppf \"%a@ %a\"\n ppa x1\n (Format.pp_print_list ppa) xs\n" }, { "path": "src/list1.mli", "content": "\ntype 'a t\n(** ['a t] is the type for lists (of values of type ['a]) the length of which is more than or equal to 1. *)\n\nval make : 'a -> 'a list -> 'a t\n(** [make e1 es] corresponds to [e1 :: es]. *)\n\nval map : ('a -> 'b) -> 'a t -> 'b t\n\nval map_and_fold : ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t\n\nval to_list : 'a t -> 'a list\n(** [to_list] forgets the constraint of the length. *)\n\nval pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit\n" }, { "path": "src/list2.ml", "content": "\nopen MyUtil\n\n\ntype 'a t = 'a * 'a * 'a list\n\n\nlet make x1 x2 xs =\n (x1, x2, xs)\n\n\nlet map f (x1, x2, xs) =\n let y1 = f x1 in\n let y2 = f x2 in\n (y1, y2, xs |> List.map f)\n\n\nlet map_and_fold : 'a 'b 'c. ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t =\nfun f acc0 (x1, x2, xs) ->\n let (acc1, y1) = f acc0 x1 in\n let (acc2, y2) = f acc1 x2 in\n let (acc, yacc) =\n xs |> List.fold_left (fun (acc, yacc) x ->\n let (acc, y) = f acc x in\n (acc, Alist.extend yacc y)\n ) (acc2, Alist.empty)\n in\n (acc, (y1, y2, Alist.to_list yacc))\n\n\nlet to_list (x1, x2, xs) =\n x1 :: x2 :: xs\n\nlet decompose (v : 'a t) = v\n\nlet pp (type a) (ppa : Format.formatter -> a -> unit) (ppf : Format.formatter) ((x1, x2, xs) : a t) =\n Format.fprintf ppf \"%a@ %a@ %a\"\n ppa x1\n ppa x2\n (Format.pp_print_list ppa) xs\n" }, { "path": "src/list2.mli", "content": "\ntype 'a t\n(** ['a t] is the type for lists (of values of type ['a]) the length of which is more than or equal to 2. *)\n\nval make : 'a -> 'a -> 'a list -> 'a t\n(** [make e1 e2 es] corresponds to [e1 :: e2 :: es]. *)\n\nval map : ('a -> 'b) -> 'a t -> 'b t\n\nval map_and_fold : ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t\n\nval to_list : 'a t -> 'a list\n(** [to_list] forgets the constraint of the length. *)\n\nval decompose : 'a t -> 'a * 'a * 'a list\n\nval pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit\n" }, { "path": "src/logging.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Env\nopen Errors\n\n\nlet warn_val_not_used (rng : Range.t) (x : identifier) =\n Format.printf \"* [Warning] %a: variable '%s' is unused\\n\"\n Range.pp rng\n x\n\n\nlet warn_invalid_attribute (warning : attribute_warning) =\n Format.printf \"* [Warning] %a: tag '%s': %s\\n\"\n Range.pp warning.position\n warning.tag\n warning.message\n\n\nlet output_written (fpath : string) =\n Format.printf \" output written on '%s'.\\n\"\n fpath\n\n\nlet begin_to_parse (abspath : absolute_path) =\n Format.printf \" parsing '%s' ...\\n\"\n abspath\n\n\nlet begin_to_typecheck (abspath : absolute_path) =\n Format.printf \" type checking '%s' ...\\n\"\n abspath\n\n\nlet report_unsupported_feature (msg : string) =\n Format.printf \"! [Unsupported] \\\"%s\\\"\\n\" msg\n\n\nlet report_invalid_external_spec (s : string) =\n Format.printf \"! [Error] invalid external spec: \\\"%s\\\"\\n\" s\n\n\nlet report_system_error (msg : string) =\n Format.printf \"! [Error] system error: %s\\n\" msg\n\n\nlet report_parser_error (rng : Range.t) =\n Format.printf \"%a: syntax error\\n\" Range.pp rng\n\n\nlet report_lexer_error (e : lexer_error) : unit =\n Format.printf \"! [Syntax error] \";\n match e with\n | UnidentifiedToken(rng, s) ->\n Format.printf \"%a: unidentified token '%s'\\n\"\n Range.pp rng\n s\n\n | SeeEndOfFileInComment(rngL) ->\n Format.printf \"%a: an unclosed comment begins here\\n\"\n Range.pp rngL\n\n | SeeEndOfFileInStringLiteral(rngL) ->\n Format.printf \"%a: an unclosed string literal begins here\\n\"\n Range.pp rngL\n\n | SeeBreakInStringLiteral(rngL) ->\n Format.printf \"%a: a string literal that contains a break begins here\\n\"\n Range.pp rngL\n\n | BlockClosedWithTooManyBackQuotes(rngR) ->\n Format.printf \"%a: a string block ends with too many back quotes\\n\"\n Range.pp rngR\n\n | NotASingleCodePoint(rng) ->\n Format.printf \"%a: not a single code point\\n\"\n Range.pp rng\n\n | UnknownEscapeSequence(rngL) ->\n Format.printf \"%a: unknown escape sequence \\n\"\n Range.pp rngL\n\n\nlet report_config_error (e : config_error) : unit =\n Format.printf \"! [Build error] \";\n match e with\n | ConfigFileError(e) ->\n Format.printf \"malformed config file; %a\\n\"\n YamlDecoder.pp_error e\n\n | CyclicFileDependencyFound(cycle) ->\n begin\n match cycle with\n | Loop(abspath) ->\n Format.printf \"file '%s' is dependent on itself.\\n\"\n abspath\n\n | Cycle(abspaths) ->\n Format.printf \"cyclic file dependency found among:\\n\";\n abspaths |> List2.to_list |> List.iter (fun abspath ->\n Format.printf \" - '%s'\\n\" abspath\n )\n end\n\n | MultipleModuleOfTheSameName(modnm, abspath1, abspath2) ->\n Format.printf \"multiple module bound with the same name '%s':\\n - %s\\n - %s\\n\"\n modnm abspath1 abspath2\n\n | ModuleNotFound(rng, modnm) ->\n Format.printf \"%a: module '%s' not found\\n\"\n Range.pp rng\n modnm\n\n | InvalidPackageName(s) ->\n Format.printf \"invalid package name '%s'\\n\"\n s\n\n | CannotSpecifyDependency ->\n Format.printf \"cannot specify dependency at standalone file\\n\"\n\n | MainModuleNotFound(pkgname, modnm) ->\n Format.printf \"main module '%s' not found in package '%s'\\n\"\n modnm pkgname\n\n | UnrecognizableExtension(ext) ->\n Format.printf \"unrecognizable extension '%s' for a source file\\n\"\n ext\n\n | ConfigFileNotFound(abspath) ->\n Format.printf \"config file '%s' not found\\n\"\n abspath\n\n | SourceFileDependsOnTestFile(mod_src, mod_test) ->\n Format.printf \"source module '%s' depends on test module '%s'\\n\"\n mod_src\n mod_test\n\n | NoOutputSpecForSingleSource ->\n Format.printf \"no output spec ('--output' or '-o') for single source file\\n\"\n\n | UnsupportedLanguageVersion(language_version) ->\n Format.printf \"unsupported language version '%s' (the version of this compiler is '%s')\\n\"\n language_version\n Constants.semantic_version\n\n\nlet report_package_error (e : package_error) : unit =\n Format.printf \"! [Build error] \";\n match e with\n | DuplicatedPackageName(pkgname, abspath1, abspath2) ->\n Format.printf \"multiple package have the same name '%s':\\n - %s\\n - %s\\n\"\n pkgname abspath1 abspath2\n\n | PackageDirNotFound(absdir) ->\n Format.printf \"package directory '%s' not found\\n\"\n absdir\n\n | NotFoundInExternalMap(pkgname, external_map) ->\n let knowns = external_map |> ExternalMap.bindings in\n Format.printf \"package '%s' not found in:\\n\" pkgname;\n knowns |> List.iter (fun (name, path) ->\n Format.printf \" - %s (%s)\\n\" name path\n )\n\n\nlet pp_type_parameter_list dispmap ppf bids =\n match bids with\n | [] ->\n ()\n\n | _ :: _ ->\n let pp_bound_id ppf bid = Format.fprintf ppf \"%s\" (dispmap |> DisplayMap.find_bound_id bid) in\n let pp_sep ppf () = Format.fprintf ppf \", \" in\n Format.fprintf ppf \"<%a>\" (Format.pp_print_list ~pp_sep pp_bound_id) bids\n\n\nlet make_display_map_from_mono_types =\n DisplayMap.empty |> List.fold_left (fun dispmap ty -> dispmap |> TypeConv.collect_ids_mono ty)\n\n\nlet make_display_map_from_poly_types =\n DisplayMap.empty |> List.fold_left (fun dispmap pty -> dispmap |> TypeConv.collect_ids_poly pty)\n\n\nlet print_free_rows_and_base_kinds (dispmap : DisplayMap.t) =\n let row_names =\n dispmap |> DisplayMap.fold_free_row_id (fun frid (row_name, labset) acc ->\n let s = labset |> LabelSet.elements |> String.concat \", \" in\n Alist.extend acc (row_name, s)\n ) Alist.empty |> Alist.to_rev_list\n in\n match row_names with\n | [] ->\n ()\n\n | _ :: _ ->\n Format.printf \" where\\n\";\n row_names |> List.iter (fun (row_name, skd) ->\n Format.printf \" - %s :: (%s)\\n\" row_name skd\n )\n\n\nlet print_bound_ids (ss : string list) =\n match ss with\n | [] ->\n ()\n\n | _ :: _ ->\n Format.printf \" where\\n\";\n ss |> List.iter (fun s ->\n Format.printf \" - %s\\n\" s\n )\n\n\nlet report_unification_error ~actual:(ty1 : mono_type) ~expected:(ty2 : mono_type) (e : unification_error) : unit =\n match e with\n | Contradiction ->\n let dispmap = make_display_map_from_mono_types [ty1; ty2] in\n let (rng1, _) = ty1 in\n Format.printf \"%a:\\n\"\n Range.pp rng1;\n Format.printf \" this expression has type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty1;\n Format.printf \" but is expected of type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty2;\n print_free_rows_and_base_kinds dispmap\n\n | Inclusion(fid) ->\n let dispmap = make_display_map_from_mono_types [ty1; ty2] in\n let (rng1, _) = ty1 in\n Format.printf \"%a:\"\n Range.pp rng1;\n Format.printf \" this expression has type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty1;\n Format.printf \" and type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty2;\n Format.printf \" at the same time, but these types are inconsistent as to the occurrence of type variable %s\\n\"\n (dispmap |> DisplayMap.find_free_id fid);\n print_free_rows_and_base_kinds dispmap\n\n | InclusionRow(frid) ->\n let dispmap = make_display_map_from_mono_types [ty1; ty2] in\n let (rng1, _) = ty1 in\n Format.printf \"%a:\\n\"\n Range.pp rng1;\n Format.printf \" this expression has type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty1;\n Format.printf \" and type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty2;\n Format.printf \" at the same time, but these types are inconsistent as to the occurrence of row variable %s\\n\"\n (dispmap |> DisplayMap.find_free_row_id frid);\n print_free_rows_and_base_kinds dispmap\n\n | InsufficientRowConstraint(r) ->\n let dispmap = make_display_map_from_mono_types [ty1; ty2] in\n let (rng1, _) = ty1 in\n Format.printf \"%a:\\n\"\n Range.pp rng1;\n Format.printf \" this expression has type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty1;\n Format.printf \" but is expected of type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty2;\n print_free_rows_and_base_kinds dispmap;\n Format.printf \" The row parameter %a is specified so that it does not contain the following label(s):\\n\"\n MustBeBoundRowID.pp_rich r.id;\n Format.printf \" %s\\n\"\n (r.given |> LabelSet.elements |> String.concat \", \");\n Format.printf \" but the following label(s) should also be specified:\\n\";\n Format.printf \" %s\\n\"\n (r.required |> LabelSet.elements |> String.concat \", \")\n\n\nlet report_type_error (e : type_error) : unit =\n Format.printf \"! [Type error] \";\n match e with\n | UnboundVariable(rng, x) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" unbound variable '%s'\\n\"\n x\n\n | UnificationError(r) ->\n report_unification_error ~actual:r.actual ~expected:r.expected r.detail\n\n | BoundMoreThanOnceInPattern(rng, x) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" this pattern binds '%s' more than once.\\n\"\n x\n\n | UnboundTypeParameter(rng, tyvar) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" unbound type variable '$%s'\\n\"\n tyvar\n\n | UnboundRowParameter(rng, rowvar) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" unbound row variable '?$%s'\\n\"\n rowvar\n\n | UndefinedConstructor(rng, ctor) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" undefined constructor '%s'\\n\"\n ctor\n\n | InvalidNumberOfConstructorArguments(rng, ctor, len_expected, len_actual) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" constructor '%s' expects %d argument(s), but is here applied to %d argument(s)\\n\"\n ctor\n len_expected\n len_actual\n\n | UndefinedTypeName(rng, tynm) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" undefined type or type constructor '%s'\\n\"\n tynm\n\n | UndefinedKindName(rng, kdnm) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" undefined kind '%s'\\n\"\n kdnm\n\n | InvalidNumberOfTypeArguments(rng, tynm, len_expected, len_actual) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" type constructor '%s' expects %d argument(s), but is here applied to %d argument(s)\\n\"\n tynm\n len_expected\n len_actual\n\n | KindContradiction(rng, tynm, kd_expected, kd_actual) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" type constructor '%s' has kind %s, but is expected of kind %s\\n\"\n tynm\n (TypeConv.show_kind kd_actual)\n (TypeConv.show_kind kd_expected)\n\n | TypeParameterBoundMoreThanOnce(rng, tyvar) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" type variable '%s' is bound more than once\\n\"\n tyvar\n\n | RowParameterBoundMoreThanOnce(rng, rowvar) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" row variable '%s' is bound more than once\\n\"\n rowvar\n\n | InvalidByte(rng) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" invalid byte\\n\"\n\n | CyclicSynonymTypeDefinition(cycle) ->\n let tyidents =\n match cycle with\n | Loop(tyident) -> [ tyident ]\n | Cycle(tyidents) -> tyidents |> List2.to_list\n in\n Format.printf \"cyclic type definitions:\\n\";\n tyidents |> List.iter (fun (rng, tynm) ->\n Format.printf \" - %s (%a)\\n\" tynm Range.pp rng\n )\n\n | UnboundModuleName(rng, modnm) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" unbound module name '%s'\\n\"\n modnm\n\n | NotOfStructureType(rng, modsig) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" this module expression is not of a structure signature\\n\"\n\n | NotOfFunctorType(rng, modsig) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" this module expression is not of a functor signature\\n\"\n\n | NotAStructureSignature(rng, modsig) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" this signature expression is not a structure\\n\"\n\n | NotAFunctorSignature(rng, modsig) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" this signature expression is not a functor\\n\"\n\n | UnboundSignatureName(rng, signm) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" unbound signature name '%s'\\n\"\n signm\n\n | CannotRestrictTransparentType(rng, tynm, _) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" the specified type '%s' is already transparent\\n\"\n tynm\n\n | PolymorphicContradiction(rng, x, pty1, pty2) ->\n let dispmap = make_display_map_from_poly_types [pty1; pty2] in\n let sbids = TypeConv.show_bound_type_ids dispmap in\n let sbrids = TypeConv.show_bound_row_ids dispmap in\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" as to value '%s', type\\n\"\n x;\n Format.printf \" %a\\n\"\n (TypeConv.pp_poly_type dispmap) pty1;\n Format.printf \" is not a subtype of\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_poly_type dispmap) pty2;\n print_bound_ids (List.append sbids sbrids)\n\n | PolymorphicInclusion(rng, fid, pty1, pty2) ->\n let dispmap = make_display_map_from_poly_types [pty1; pty2] in\n let sbids = TypeConv.show_bound_type_ids dispmap in\n let sbrids = TypeConv.show_bound_row_ids dispmap in\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_poly_type dispmap) pty1;\n Format.printf \" is inconsistent with type\\n\";\n Format.printf \" %a\\n\"\n (TypeConv.pp_poly_type dispmap) pty2;\n Format.printf \" as to type variable %s\\n\"\n (dispmap |> DisplayMap.find_free_id fid);\n print_bound_ids (List.append sbids sbrids)\n\n | MissingRequiredValName(rng, x, pty) ->\n let dispmap = make_display_map_from_poly_types [pty] in\n let sbids = TypeConv.show_bound_type_ids dispmap in\n let sbrids = TypeConv.show_bound_row_ids dispmap in\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" missing required value '%s' of type\\n\"\n x;\n Format.printf \" %a\\n\"\n (TypeConv.pp_poly_type dispmap) pty;\n print_bound_ids (List.concat [sbids; sbrids])\n\n | MissingRequiredConstructorName(rng, ctornm, _centry) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" missing required constructor '%s'\\n\"\n ctornm\n\n | MissingRequiredTypeName(rng, tynm, tentry) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" missing required type name '%s' of arity %d\\n\"\n tynm\n (TypeConv.arity_of_kind tentry.type_kind)\n\n | MissingRequiredModuleName(rng, modnm, _modsign) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" missing required module name '%s'\\n\"\n modnm\n\n | MissingRequiredSignatureName(rng, signm, _absmodsig) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" missing required module name '%s'\\n\"\n signm\n\n | NotASubtype(rng, modsig1, modsig2) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" not a subtype (TODO: detailed explanation)\\n\"\n\n | NotASubtypeTypeDefinition(rng, tynm, _tentry1, _tentry2) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" not a subtype; type '%s' cannot be encapsulated (TODO: detailed explanation)\\n\"\n tynm\n\n | NotASubtypeConstructorDefinition(rng, ctornm, _centry1, _centry2) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" not a subtype; constructor '%s' cannot be encapsulated (TODO: detailed explanation)\\n\"\n ctornm\n\n | NotASubtypeVariant(rng, _vid1, _vid2, ctor) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" not a subtype about constructor '%s' (TODO: detailed explanation)\\n\"\n ctor\n\n | OpaqueIDExtrudesScopeViaValue(rng, _pty) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" an abstract type extrudes its scope via value (TODO: detailed explanation)\\n\"\n\n | OpaqueIDExtrudesScopeViaType(rng, _tyopac) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" an abstract type extrudes its scope via type (TODO: detailed explanation)\\n\"\n\n | OpaqueIDExtrudesScopeViaSignature(rng, _absmodsig) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" an abstract type extrudes its scope via signature (TODO: detailed explanation)\\n\"\n\n | SupportOnlyFirstOrderFunctor(rng) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" only first-order functors are supported\\n\"\n\n | RootModuleMustBeStructure(rng) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" root modules must be structures\\n\"\n\n | InvalidIdentifier(rng, s) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" invalid identifier '%s'\\n\"\n s\n\n | ConflictInSignature(rng, x) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" '%s' is already defined in the signature\\n\"\n x\n\n | DuplicatedLabel(rng, label) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" label '%s' is used more than once in a binding\\n\"\n label\n\n | BadArityOfOrderedArguments(info) ->\n Format.printf \"%a:\\n\"\n Range.pp info.range;\n Format.printf \" the function expects %d ordered argument(s), but is applied to %d ordered argument(s) here\\n\"\n info.expected\n info.got\n\n | MissingMandatoryLabel(info) ->\n let ty = info.typ in\n let dispmap = make_display_map_from_mono_types [ty] in\n Format.printf \"%a:\\n\"\n Range.pp info.range;\n Format.printf \" missing mandatory label '-%s' with an argument of type\\n\"\n info.label;\n Format.printf \" %a\\n\"\n (TypeConv.pp_mono_type dispmap) ty;\n print_free_rows_and_base_kinds dispmap\n\n | UnexpectedMandatoryLabel(info) ->\n Format.printf \"%a:\\n\"\n Range.pp info.range;\n Format.printf \" unexpected mandatory label '-%s'\\n\"\n info.label\n\n | UnexpectedOptionalLabel(info) ->\n Format.printf \"%a:\\n\"\n Range.pp info.range;\n Format.printf \" unexpected optional label '?%s'\\n\"\n info.label\n\n | NullaryFormatString(rng) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" nullary format string\\n\"\n\n | CannotFreezeNonGlobalName(rng, x) ->\n Format.printf \"%a:\\n\"\n Range.pp rng;\n Format.printf \" cannot freeze non-top-level identifier '%s'\\n\"\n x\n" }, { "path": "src/main.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Errors\nopen Env\n\n\nexception InvalidExternalSpec of string\n\n\nlet catch_error (k : unit -> unit) =\n try\n k ()\n with\n | Sys_error(msg) ->\n Logging.report_system_error msg;\n exit 1\n\n | Failure(msg) ->\n Logging.report_unsupported_feature msg;\n exit 1\n\n | InvalidExternalSpec(s) ->\n Logging.report_invalid_external_spec s;\n exit 1\n\n | PackageLoader.PackageError(e) ->\n Logging.report_package_error e;\n exit 1\n\n | SourceLoader.SyntaxError(LexerError(e)) ->\n Logging.report_lexer_error e;\n exit 1\n\n | SourceLoader.SyntaxError(ParseError(rng)) ->\n Logging.report_parser_error rng;\n exit 1\n\n | ConfigError(e) ->\n Logging.report_config_error e;\n exit 1\n\n | Typechecker.TypeError(e) ->\n Logging.report_type_error e;\n exit 1\n\n\nlet build (fpath_in : string) (dir_out_spec : string option) (is_verbose : bool) (externals : string list) =\n catch_error (fun () ->\n let current_directory = Sys.getcwd () in\n let abspath_in =\n make_absolute_path current_directory fpath_in\n in\n let external_map =\n externals |> List.fold_left (fun map s ->\n match String.split_on_char ':' s with\n | [pkgname; path_in] ->\n let absdir = make_absolute_path current_directory path_in in\n map |> ExternalMap.add pkgname absdir\n\n | _ ->\n raise (InvalidExternalSpec(s))\n\n ) ExternalMap.empty\n in\n let (pkgs, absdir_out, absdir_test_out, doc_configs_opt) =\n let (_, extopt) = Core.Filename.split_extension abspath_in in\n match extopt with\n | Some(\"sest\") ->\n let source = SourceLoader.single abspath_in in\n let pkgs = [ (None, [], source, []) ] in\n let absdir_out =\n match dir_out_spec with\n | None -> raise (ConfigError(NoOutputSpecForSingleSource))\n | Some(dir_out) -> append_dir current_directory (RelativeDir(dir_out))\n in\n (pkgs, absdir_out, absdir_out, None)\n\n | Some(ext) ->\n raise (ConfigError(UnrecognizableExtension(ext)))\n\n | _ ->\n assert (is_existing_directory abspath_in);\n (* The existence of given directories has been checked by 'cmdliner'. *)\n let absdir_in = abspath_in in\n let (pkgconfigs, main_config) = PackageLoader.main external_map absdir_in in\n let pkgs =\n pkgconfigs |> List.map (fun (_, config) ->\n let requires_tests =\n String.equal config.ConfigLoader.package_name main_config.ConfigLoader.package_name\n in\n let pkg = SourceLoader.main ~requires_tests config in\n (Some(pkg.SourceLoader.space_name),\n pkg.SourceLoader.aux_modules,\n pkg.SourceLoader.main_module,\n pkg.SourceLoader.test_modules)\n )\n in\n (pkgs,\n append_dir absdir_in main_config.erlang_config.output_directory,\n append_dir absdir_in main_config.erlang_config.test_output_directory,\n Some((absdir_in, main_config.document_outputs)))\n in\n\n (* Typecheck each package. *)\n let (tyenv, _) = Primitives.initial_environment in\n let (_, pkgoutsacc) =\n pkgs |> List.fold_left (fun (tyenv, outsacc) pkg ->\n let (pkgnameopt, auxmods, mainmod, testmods) = pkg in\n let (tyenv, auxouts, mainout, testouts) = PackageChecker.main ~is_verbose tyenv ~aux:auxmods ~main:mainmod ~test:testmods in\n (tyenv, Alist.extend outsacc (pkgnameopt, auxouts, mainout, testouts))\n ) (tyenv, Alist.empty)\n in\n\n let spec =\n {\n module_name_output_spec = DottedCamels;\n }\n in\n\n (* Generate and output code corresponding to each package. *)\n Core.Unix.mkdir_p absdir_out;\n Core.Unix.mkdir_p absdir_test_out;\n let (_, gmap) = Primitives.initial_environment in\n pkgoutsacc |> Alist.to_list |> List.fold_left (fun gmap (pkgnameopt, auxouts, mainout, testouts) ->\n doc_configs_opt |> Option.map (fun (absdir_in, doc_configs) ->\n doc_configs |> List.iter (fun doc_config ->\n let ConfigLoader.Html = doc_config.ConfigLoader.document_output_format in\n let absdir_doc_out = append_dir absdir_in doc_config.ConfigLoader.document_output_directory in\n Core.Unix.mkdir_p absdir_doc_out;\n let abspath_doc_out =\n match pkgnameopt with\n | None ->\n append_path absdir_doc_out (RelativePath(\"doc.html\"))\n\n | Some(pkgname) ->\n let relpath = Printf.sprintf \"%s.html\" (OutputIdentifier.output_space_to_snake pkgname) in\n append_path absdir_doc_out (RelativePath(relpath))\n in\n DocumentGenerator.main abspath_doc_out mainout\n )\n ) |> Option.value ~default:();\n let outs =\n List.concat [\n auxouts |> List.map (fun out -> (out, false));\n [ (mainout, false) ];\n testouts |> List.map (fun out -> (out, true));\n ]\n in\n outs |> List.fold_left (fun gmap (out, is_for_test) ->\n let sname = out.PackageChecker.space_name in\n let imod = (out.PackageChecker.attribute, out.PackageChecker.bindings) in\n let absdir = if is_for_test then absdir_test_out else absdir_out in\n OutputErlangCode.main spec absdir gmap ~package_name:pkgnameopt ~module_name:sname imod\n ) gmap\n ) gmap |> ignore;\n OutputErlangCode.write_primitive_module absdir_out\n )\n\n\nlet config (fpath_in : string) =\n catch_error (fun () ->\n let absdir_in =\n let dir = Sys.getcwd () in\n make_absolute_path dir fpath_in\n in\n let absdir_out = absdir_in in\n let config = PackageLoader.load_config absdir_in in\n OutputRebarConfig.main absdir_out config\n )\n\n\nlet flag_output : (string option) Cmdliner.Term.t =\n let open Cmdliner in\n let doc = \"Specify output path.\" in\n Arg.(value (opt (some string) None (info [ \"o\"; \"output\" ] ~docv:\"OUTPUT\" ~doc)))\n\n\nlet flag_verbose : bool Cmdliner.Term.t =\n let open Cmdliner in\n let doc = \"Makes reports more detailed.\" in\n Arg.(value (flag (info [ \"verbose\" ] ~doc)))\n\n\nlet flag_packages : (string list) Cmdliner.Term.t =\n let open Cmdliner in\n let doc = \"Specify paths of external packages.\" in\n Arg.(value (opt_all string [] (info [ \"p\"; \"package\" ] ~docv:\"PACKAGE\" ~doc)))\n\n\nlet arg_in : string Cmdliner.Term.t =\n let open Cmdliner in\n Arg.(required (pos 0 (some file) None (info [])))\n\n\nlet command_build =\n let open Cmdliner in\n let term : unit Term.t =\n Term.(const build $ arg_in $ flag_output $ flag_verbose $ flag_packages)\n in\n let info : Term.info =\n Term.info \"build\"\n in\n (term, info)\n\n\nlet command_config =\n let open Cmdliner in\n let term : unit Term.t =\n Term.(const config $ arg_in)\n in\n let info : Term.info =\n Term.info \"config\"\n in\n (term, info)\n\n\nlet command_main =\n let open Cmdliner in\n let term : unit Term.t =\n Term.(ret (const (`Error(true, \"No subcommand specified.\"))))\n in\n let info : Term.info =\n Term.info ~version:Constants.semantic_version \"sesterl\"\n in\n (term, info)\n\n\nlet () =\n let open Cmdliner in\n let subcommands =\n [\n command_build;\n command_config;\n ]\n in\n Term.(exit (eval_choice command_main subcommands))\n" }, { "path": "src/moduleAttribute.ml", "content": "\nopen MyUtil\nopen Syntax\n\n\ntype accumulator = {\n acc_behaviours : StringSet.t;\n acc_for_test : bool;\n}\n\ntype t = {\n behaviours : StringSet.t;\n for_test : bool;\n}\n\n\nlet empty : t =\n {\n behaviours = StringSet.empty;\n for_test = false;\n }\n\n\nlet merge (modattr1 : t) (modattr2 : t) : t =\n {\n behaviours = StringSet.union modattr1.behaviours modattr2.behaviours;\n for_test = modattr1.for_test || modattr2.for_test;\n }\n\n\nlet decode (attrs : attribute list) : t * attribute_warning list =\n let r =\n {\n acc_behaviours = StringSet.empty;\n acc_for_test = false;\n }\n in\n let (r, warn_acc) =\n attrs |> List.fold_left (fun (r, warn_acc) attr ->\n let Attribute((rng, attr_main)) = attr in\n match attr_main with\n | (((\"behaviour\" | \"behavior\") as tag), utast_opt) ->\n begin\n match utast_opt with\n | Some((_, BaseConst(BinaryByString(s)))) ->\n let r = { r with acc_behaviours = r.acc_behaviours |> StringSet.add s } in\n (r, warn_acc)\n\n | _ ->\n let warn =\n {\n position = rng;\n tag = tag;\n message = \"argument should be a string literal\";\n }\n in\n (r, Alist.extend warn_acc warn)\n end\n\n | (\"test\", utast_opt) ->\n let warn_acc =\n match utast_opt with\n | None ->\n warn_acc\n\n | Some(_) ->\n let warn =\n {\n position = rng;\n tag = \"test\";\n message = \"argument is ignored\";\n }\n in\n Alist.extend warn_acc warn\n in\n let r = { r with acc_for_test = true } in\n (r, warn_acc)\n\n | (tag, _) ->\n let warn =\n {\n position = rng;\n tag = tag;\n message = \"unsupported attribute\";\n }\n in\n (r, Alist.extend warn_acc warn)\n ) (r, Alist.empty)\n in\n let t =\n {\n behaviours = r.acc_behaviours;\n for_test = r.acc_for_test;\n }\n in\n (t, Alist.to_list warn_acc)\n" }, { "path": "src/mustBeBoundID.ml", "content": "\ntype t = {\n main : BoundID.t;\n name : string;\n level : int;\n}\n\n\nlet fresh (name : string) (lev : int) : t =\n let bid = BoundID.fresh () in\n { main = bid; name = name; level = lev; }\n\n\nlet equal (mbbid1 : t) (mbbid2 : t) : bool =\n BoundID.equal mbbid1.main mbbid2.main\n\n\nlet get_level (mbbid : t) : int =\n mbbid.level\n\n\nlet to_bound (mbbid : t) : BoundID.t =\n mbbid.main\n\n\nlet pp_rich (ppf : Format.formatter) (mbbid : t) : unit =\n Format.fprintf ppf \"%s\" mbbid.name\n\n\nlet pp (ppf : Format.formatter) (mbbid : t) : unit =\n Format.fprintf ppf \"_%aL%d\" BoundID.pp mbbid.main mbbid.level\n" }, { "path": "src/myUtil.ml", "content": "\nmodule StringSet = Set.Make(String)\n\n\nmodule Alist : sig\n type 'a t\n val empty : 'a t\n val extend : 'a t -> 'a -> 'a t\n val append : 'a t -> 'a list -> 'a t\n val length : 'a t -> int\n val to_list : 'a t -> 'a list\n val to_rev_list : 'a t -> 'a list\n val from_list : 'a list -> 'a t\n val is_empty : 'a t -> bool\nend = struct\n\n type 'a t = 'a list\n\n let empty = []\n\n let extend acc x = x :: acc\n\n let append acc xs = List.rev_append xs acc\n\n let length acc = List.length acc\n\n let to_list = List.rev\n\n let to_rev_list acc = acc\n\n let from_list = List.rev\n\n let is_empty acc =\n match acc with\n | [] -> true\n | _ :: _ -> false\n\nend\n\n\nmodule ResultMonad : sig\n val return : 'a -> ('a, 'e) result\n val err : 'e -> ('a, 'e) result\n val map_err : ('e1 -> 'e2) -> ('a, 'e1) result -> ('a, 'e2) result\n val ( >>= ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result\nend = struct\n\n let return v =\n Ok(v)\n\n let err e =\n Error(e)\n\n let ( >>= ) v f =\n match v with\n | Ok(x) -> f x\n | Error(e) -> Error(e)\n\n let map_err f v =\n match v with\n | Ok(x) -> Ok(x)\n | Error(e) -> Error(f e)\n\nend\n\n\nmodule OptionMonad : sig\n val return : 'a -> 'a option\n val none : 'a option\n val ( >>= ) : 'a option -> ('a -> 'b option) -> 'b option\nend = struct\n\n let return x = Some(x)\n\n let none = None\n\n let ( >>= ) = Option.bind\n\nend\n\n\ntype absolute_path = string\n\ntype absolute_dir = string\n\ntype relative_path = RelativePath of string\n\ntype relative_dir = RelativeDir of string\n\n\nlet make_absolute_path ?canonicalize:(canonicalize = false) (absdir : absolute_dir) (fpath : string) : absolute_path =\n let f = if canonicalize then Core.Filename.realpath else (fun s -> s) in\n if Filename.is_relative fpath then\n f (Filename.concat absdir fpath)\n else\n f fpath\n\n\nlet append_dir (absdir : absolute_dir) (RelativeDir(reldir) : relative_dir) : absolute_dir =\n Filename.concat absdir reldir\n\n\nlet append_path (absdir : absolute_dir) (RelativePath(relpath) : relative_path) : absolute_path =\n Filename.concat absdir relpath\n\n\nlet canonicalize_path (abspath : absolute_path) : absolute_path option =\n try\n Some(Core.Filename.realpath abspath)\n with\n | Unix.Unix_error(_) -> None\n\n\nlet is_existing_directory (abspath : absolute_path) : bool =\n let abspath0 = Core.Filename.concat abspath Filename.current_dir_name in\n try\n Option.equal String.equal (canonicalize_path abspath) (canonicalize_path abspath0)\n with\n | _ -> false\n\n\nmodule Utf : sig\n val uchar_of_utf8 : string -> Uchar.t list\nend = struct\n\n let uchar_of_utf8 (s : string) =\n let decoder = Uutf.decoder ~encoding:`UTF_8 (`String(s)) in\n let rec iter acc =\n match Uutf.decode decoder with\n | `End -> Alist.to_list acc\n | `Uchar(u) -> iter (Alist.extend acc u)\n | `Await -> iter acc\n | `Malformed(_) -> iter (Alist.extend acc Uutf.u_rep)\n (* Silently replaces malformed sequences with `Uutf.u_rep`. *)\n in\n iter Alist.empty\n\nend\n" }, { "path": "src/outputErlangCode.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Env\nopen IntermediateSyntax\n\n\nlet fresh_local_symbol () =\n OutputIdentifier.output_local (OutputIdentifier.fresh ())\n\n\ntype val_binding_output =\n | OBindVal of global_name * pattern list * pattern LabelAssoc.t * (pattern * ast option) LabelAssoc.t * name_map * ast\n | OBindValExternal of global_name * string\n\ntype module_binding_output =\n | OBindModule of {\n basename : string;\n atom : string;\n attributes : ModuleAttribute.t;\n bindings : val_binding_output list;\n }\n\n\nlet traverse_val_single (nmap : name_map) (_, gnamefun, _, ast) : val_binding_output =\n match ast with\n | ILambda(None, ipats, mndipatmap, optipatmap, ast0) ->\n OBindVal(gnamefun, ipats, mndipatmap, optipatmap, nmap, ast0)\n\n | _ ->\n assert false\n\n\nlet make_module_string ~(suffix : string) (spec : output_spec) (spacepath : space_name Alist.t) : string * string =\n let spaces = spacepath |> Alist.to_list in\n match spec.module_name_output_spec with\n | SingleSnake ->\n let s = spaces |> List.map OutputIdentifier.output_space_to_snake |> String.concat \"_\" in\n (s, s)\n\n | DottedCamels ->\n let s = spaces |> List.map OutputIdentifier.output_space_to_camel |> String.concat \".\" in\n let s = s ^ suffix in\n (s, Printf.sprintf \"'%s'\" s)\n\n\nlet rec traverse_binding_list (spec : output_spec) (sname : space_name) ((gmap, smap) : name_map) (spacepath : space_name Alist.t) (modattr : ModuleAttribute.t) (ibinds : binding list) : module_binding_output list * name_map =\n\n let suffix = if modattr.for_test then \"_tests\" else \"\" in\n let (smod_basename, smod_atom) = make_module_string ~suffix spec spacepath in\n\n let smap = smap |> SpaceNameMap.add sname smod_atom in\n\n (* Associates value identifiers in the current space with `spacepath` beforehand. *)\n let gmap =\n ibinds |> List.fold_left (fun gmap ibind ->\n match ibind with\n | IBindVal(INonRec(valbind)) ->\n let (_, gnamefun, _, _) = valbind in\n gmap |> GlobalNameMap.add gnamefun smod_atom\n\n | IBindVal(IRec(valbinds)) ->\n valbinds |> List.fold_left (fun gmap valbind ->\n let (_, gnamefun, _, _) = valbind in\n gmap |> GlobalNameMap.add gnamefun smod_atom\n ) gmap\n\n | IBindVal(IExternal(gnamefun, _)) ->\n gmap |> GlobalNameMap.add gnamefun smod_atom\n\n | IBindModule(_) ->\n gmap\n ) gmap\n in\n\n let nmap = (gmap, smap) in\n\n (* Traverses all the submodules. *)\n let (omodbindacc, nmap) =\n ibinds |> List.fold_left (fun ((omodbindacc, nmap) as original) ibind ->\n match ibind with\n | IBindVal(_) ->\n original\n\n | IBindModule(snamesub, attrssub, ibindssub) ->\n let (omodbindssub, nmap) =\n let spacepathsub = Alist.extend spacepath snamesub in\n traverse_binding_list spec snamesub nmap spacepathsub attrssub ibindssub\n in\n (Alist.append omodbindacc omodbindssub, nmap)\n\n ) (Alist.empty, nmap)\n in\n\n (* Constructs the output module corresponding to the current space (if not empty). *)\n let omodbindacc =\n let ovalbinds =\n ibinds |> List.map (fun ibind ->\n match ibind with\n | IBindVal(INonRec(valbind)) -> [ traverse_val_single nmap valbind ]\n | IBindVal(IRec(valbinds)) -> valbinds |> List.map (traverse_val_single nmap)\n | IBindVal(IExternal(gname, code)) -> [ OBindValExternal(gname, code) ]\n | IBindModule(_) -> []\n ) |> List.concat\n in\n match ovalbinds with\n | [] ->\n omodbindacc\n\n | _ :: _ ->\n let omodbind =\n OBindModule{\n basename = smod_basename;\n atom = smod_atom;\n attributes = modattr;\n bindings = ovalbinds;\n }\n in\n Alist.extend omodbindacc omodbind\n in\n\n (Alist.to_list omodbindacc, nmap)\n\n\nlet unit_atom = \"ok\"\n\n\nlet stringify_hole = function\n | HoleC -> \"c\"\n | HoleF -> \"f\"\n | HoleE -> \"e\"\n | HoleG -> \"g\"\n | HoleS -> \"s\"\n | HoleP -> \"p\"\n | HoleW -> \"w\"\n\n\nlet stringify_format_element = function\n | FormatBreak -> (0, \"~n\")\n | FormatTilde -> (0, \"~~\")\n | FormatDQuote -> (0, \"\\\\\\\"\")\n | FormatConst(s) -> (0, s)\n\n | FormatHole(hole, control) ->\n let ch = stringify_hole hole in\n let s =\n match (control.field_width, control.precision) with\n | (Some(n1), Some(n2)) -> Printf.sprintf \"%d.%d\" n1 n2\n | (Some(n1), None) -> Printf.sprintf \"%d\" n1\n | (None, Some(n2)) -> Printf.sprintf \".%d\" n2\n | (None, None) -> \"\"\n in\n (1, Printf.sprintf \"~%s%s\" s ch)\n\nlet escape_character c =\n match Uchar.to_int c with\n | 10 -> [ Uchar.of_char '\\\\'; Uchar.of_char 'n' ]\n | 13 -> [ Uchar.of_char '\\\\'; Uchar.of_char 'r' ]\n | 9 -> [ Uchar.of_char '\\\\'; Uchar.of_char 't' ]\n | 92 -> [ Uchar.of_char '\\\\'; Uchar.of_char '\\\\' ]\n | 34 -> [ Uchar.of_char '\\\\'; Uchar.of_char '\"' ]\n | 39 -> [ Uchar.of_char '\\\\'; Uchar.of_char '\\'' ]\n | _ -> [c]\n\nlet escape_string s =\n let buffer = Buffer.create 0 in\n s |> MyUtil.Utf.uchar_of_utf8 |> List.map escape_character |> List.flatten |> List.iter (Buffer.add_utf_8_uchar buffer);\n Buffer.contents buffer\n\nlet stringify_base_constant (bc : base_constant) =\n match bc with\n | Unit -> unit_atom\n | Bool(true) -> \"true\"\n | Bool(false) -> \"false\"\n | Int(n) -> string_of_int n\n\n | Float(r) ->\n if Float.is_finite r then\n string_of_float r ^ \"0\"\n (* DOUBTFUL; are all of the string representations made in this way\n valid as constants in Erlang source? *)\n else\n assert false\n\n | BinaryByString(s) -> Printf.sprintf \"<<\\\"%s\\\"/utf8>>\" (escape_string s)\n | BinaryByInts(ns) -> Printf.sprintf \"<<%s>>\" (ns |> List.map string_of_int |> String.concat \", \")\n | String(s) -> Printf.sprintf \"\\\"%s\\\"\" (escape_string s)\n | Char(uchar) -> Printf.sprintf \"%d\" (Uchar.to_int uchar)\n\n | FormatString(fmtelems) ->\n let pairs = fmtelems |> List.map stringify_format_element in\n let s = pairs |> List.map (fun (_, s) -> s) |> String.concat \"\" in\n let arity = pairs |> List.fold_left (fun arity (n, _) -> arity + n) 0 in\n Printf.sprintf \"{\\\"%s\\\", %d}\" s arity\n\n\nlet get_module_string ((gmap, _) : name_map) (gname : global_name) : string =\n match gmap |> GlobalNameMap.find_opt gname with\n | None -> assert false\n | Some(smod) -> smod\n\n\nlet stringify_single (nmap : name_map) = function\n | OutputIdentifier.Local(lname) ->\n OutputIdentifier.output_local lname\n\n | OutputIdentifier.Global(gname) ->\n let r = OutputIdentifier.output_global gname in\n let smod = get_module_string nmap gname in\n let arity = if r.has_option then r.arity + 1 else r.arity in\n Printf.sprintf \"(fun %s:%s/%d)\"\n smod\n r.function_name\n arity\n (* Use syntax `fun M:F/Arity` for global function names\n in order to avoid being confused with atoms.\n Here, arities are incremented in order to conform to labeled optional parameters. *)\n\n | OutputIdentifier.Operator(oname) ->\n let sop = OutputIdentifier.output_operator oname in\n let s1 = fresh_local_symbol () in\n let s2 = fresh_local_symbol () in\n Printf.sprintf \"(fun(%s, %s) -> %s %s %s end)\" s1 s2 s1 sop s2\n\n\nlet make_mandatory_parameters (ordipats : pattern list) (mndipatmap : pattern LabelAssoc.t) : pattern list =\n let mndipats =\n mndipatmap |> LabelAssoc.bindings |> List.map (fun (_, ipat) -> ipat)\n (* Labeled mandatory parameters are placed in alphabetical order. *)\n in\n List.append ordipats mndipats\n\n\nlet rec stringify_option_decoding_operation (nmap : name_map) (sname_map : string) (optipatmap : (pattern * ast option) LabelAssoc.t) : string =\n LabelAssoc.fold (fun label (ipat, default) acc ->\n let spat = stringify_pattern ipat in\n let s =\n match default with\n | None ->\n Printf.sprintf \"%s = %s:%s(%s, %s), \"\n spat\n Primitives.primitive_module_name\n Primitives.decode_option_function\n sname_map\n label\n\n | Some(ast) ->\n Printf.sprintf \"%s = %s:%s(%s, %s, fun() -> %s end), \"\n spat\n Primitives.primitive_module_name\n Primitives.decode_option_function_with_default\n sname_map\n label\n (stringify_ast nmap ast)\n in\n Alist.extend acc s\n ) optipatmap Alist.empty |> Alist.to_list |> String.concat \"\"\n\n\nand stringify_arguments (nmap : name_map) (mrow : mono_row) (ordastargs : ast list) (mndargmap : ast LabelAssoc.t) (optargmap : ast LabelAssoc.t) =\n let iter = stringify_ast nmap in\n let astargs =\n let mndastargs =\n mndargmap |> LabelAssoc.bindings |> List.map (fun (_, ast) -> ast)\n (* Labeled mandatory arguments are placed in alphabetical order. *)\n in\n List.append ordastargs mndastargs\n in\n let sargs = astargs |> List.map iter in\n let soptmap = mapify_label_assoc nmap optargmap in\n let can_take_optional = TypeConv.can_row_take_optional mrow in\n let no_mandatory_argument = (List.length astargs = 0) in\n (sargs, soptmap, can_take_optional, no_mandatory_argument)\n\n\nand stringify_ast (nmap : name_map) (ast : ast) =\n let iter = stringify_ast nmap in\n match ast with\n | IVar(name) ->\n stringify_single nmap name\n\n | IBaseConst(bc) ->\n stringify_base_constant bc\n\n | ILambda(recopt, ordipats, mndipatmap, optipatmap, ast0) ->\n let snames =\n let ipats = make_mandatory_parameters ordipats mndipatmap in\n ipats |> List.map stringify_pattern\n in\n let s0 = iter ast0 in\n let srec =\n match recopt with\n | None -> \"\"\n | Some(namerec) -> \" \" ^ OutputIdentifier.output_local namerec\n in\n if LabelAssoc.cardinal optipatmap = 0 then\n let sparamscat = snames |> String.concat \", \" in\n Printf.sprintf \"fun%s(%s) -> %s end\"\n srec\n sparamscat\n s0\n else\n let sparamscatcomma = snames |> List.map (fun s -> s ^ \", \") |> String.concat \"\" in\n let sname_map = fresh_local_symbol () in\n let sgetopts = stringify_option_decoding_operation nmap sname_map optipatmap in\n Printf.sprintf \"fun%s(%s%s) -> %s%s end\"\n srec\n sparamscatcomma\n sname_map\n sgetopts\n s0\n\n | IApply(name, mrow, ordastargs, mndargmap, optargmap) ->\n let (sargs, soptmap, can_take_optional, no_mandatory_argument) =\n stringify_arguments nmap mrow ordastargs mndargmap optargmap\n in\n begin\n match (name, sargs) with\n | (OutputIdentifier.Local(lname), _) ->\n let sname = OutputIdentifier.output_local lname in\n let sargscat = String.concat \", \" sargs in\n if can_take_optional then\n if no_mandatory_argument then\n Printf.sprintf \"%s(#{%s})\"\n sname\n soptmap\n else\n Printf.sprintf \"%s(%s, #{%s})\"\n sname\n sargscat\n soptmap\n else\n Printf.sprintf \"%s(%s)\"\n sname\n sargscat\n\n | (OutputIdentifier.Global(gname), _) ->\n let r = OutputIdentifier.output_global gname in\n let smod = get_module_string nmap gname in\n let sfun = r.function_name in\n let sopts =\n if LabelAssoc.cardinal optargmap = 0 then\n \"\"\n (* When no optional argument is given, we do not output the empty map for it.\n In response to this, functions defined with optional parameters are\n compiled into two variants; one has its innate arity,\n and the other can receive a map for optional arguments via an additional argument.\n *)\n else if no_mandatory_argument then\n Printf.sprintf \"#{%s}\" soptmap\n else\n Printf.sprintf \", #{%s}\" soptmap\n in\n Printf.sprintf \"%s:%s(%s%s)\"\n smod\n sfun\n (String.concat \", \" sargs)\n sopts\n\n | (OutputIdentifier.Operator(op), [sarg1; sarg2]) ->\n let sop = OutputIdentifier.output_operator op in\n Printf.sprintf \"(%s %s %s)\" sarg1 sop sarg2\n\n | _ ->\n assert false\n end\n\n | IFreeze(gname, astargs) ->\n let sargs = List.map iter astargs in\n let r = OutputIdentifier.output_global gname in\n let smod = get_module_string nmap gname in\n let sfun = r.function_name in\n Printf.sprintf \"{%s, %s, [%s]}\"\n smod\n sfun\n (String.concat \", \" sargs)\n\n | IFreezeUpdate(ast0, astargs) ->\n let s0 = iter ast0 in\n let sargs = List.map iter astargs in\n let varM = fresh_local_symbol () in\n let varF = fresh_local_symbol () in\n let varArgs = fresh_local_symbol () in\n Printf.sprintf \"begin {%s, %s, %s} = %s, {%s, %s, %s ++ [%s]} end\"\n varM\n varF\n varArgs\n s0\n varM\n varF\n varArgs\n (String.concat \", \" sargs)\n\n | IRecord(emap) ->\n let s = mapify_label_assoc nmap emap in\n Printf.sprintf \"#{%s}\" s\n\n | IRecordAccess(ast1, label) ->\n let s1 = iter ast1 in\n Printf.sprintf \"maps:get(%s, %s)\" label s1\n\n | IRecordUpdate(ast1, label, ast2) ->\n let s1 = iter ast1 in\n let s2 = iter ast2 in\n Printf.sprintf \"maps:put(%s, %s, %s)\" label s2 s1\n\n | ILetIn(lname, ast1, ast2) ->\n let s0 = OutputIdentifier.output_local lname in\n let s1 = iter ast1 in\n let s2 = iter ast2 in\n Printf.sprintf \"begin %s = %s, %s end\" s0 s1 s2\n\n | ICase(ast1, [ IBranch(ipat, ast2) ]) ->\n (* -- slight optimization of case-expressions into pattern-matching let-expressions -- *)\n let spat = stringify_pattern ipat in\n let s1 = iter ast1 in\n let s2 = iter ast2 in\n Printf.sprintf \"begin %s = %s, %s end\" spat s1 s2\n\n | ICase(ast0, branches) ->\n let s0 = iter ast0 in\n let sbrs = branches |> List.map (stringify_case_branch nmap) in\n Printf.sprintf \"case %s of %s end\" s0 (String.concat \"; \" sbrs)\n\n | IReceive(branches, iafter_opt) ->\n let sbrs = branches |> List.map (stringify_receive_branch nmap) |> String.concat \"; \" in\n begin\n match iafter_opt with\n | None ->\n Printf.sprintf \"receive %s end\" sbrs\n\n | Some((ast1, ast2)) ->\n let sv = fresh_local_symbol () in\n let s1 = iter ast1 in\n let s2 = iter ast2 in\n Printf.sprintf \"begin %s = %s, receive %s after %s -> %s end end\"\n sv s1 sbrs sv s2\n end\n\n | ITuple(es) ->\n let ss = es |> TupleList.to_list |> List.map iter in\n Printf.sprintf \"{%s}\" (String.concat \", \" ss)\n\n | IListNil ->\n \"[]\"\n\n | IListCons(e1, e2) ->\n let s1 = iter e1 in\n let s2 = iter e2 in\n Printf.sprintf \"[%s | %s]\" s1 s2\n\n | IConstructor(ctorid, es) ->\n let sctor = ConstructorID.output ctorid in\n begin\n match es with\n | [] ->\n sctor\n\n | _ :: _ ->\n let ss = es |> List.map iter in\n Printf.sprintf \"{%s, %s}\" sctor (String.concat \", \" ss)\n end\n\n | IPack(sname) ->\n let (_, smap) = nmap in\n begin\n match smap |> SpaceNameMap.find_opt sname with\n | None -> assert false\n | Some(smod) -> smod\n end\n\n | IAssert(rng, e0) ->\n let s0 = iter e0 in\n let var = fresh_local_symbol () in\n Printf.sprintf \"begin %s = %s, %s(<<\\\"%s\\\">>, %d) end\"\n var\n s0\n var\n (Range.get_file_name rng)\n (Range.get_start_line rng)\n\n\nand mapify_label_assoc (nmap : name_map) (emap : ast LabelAssoc.t) =\n LabelAssoc.fold (fun label ast acc ->\n let sarg = stringify_ast nmap ast in\n let s = Printf.sprintf \"%s => %s\" label sarg in\n Alist.extend acc s\n ) emap Alist.empty |> Alist.to_list |> String.concat \", \"\n\n\nand stringify_case_branch (nmap : name_map) (br : branch) =\n match br with\n | IBranch(pat, ast1) ->\n let spat = stringify_pattern pat in\n let s1 = stringify_ast nmap ast1 in\n Printf.sprintf \"%s -> %s\" spat s1\n\n\nand stringify_receive_branch (nmap : name_map) (br : branch) =\n match br with\n | IBranch(pat, ast1) ->\n let spat = stringify_pattern pat in\n let s1 = stringify_ast nmap ast1 in\n Printf.sprintf \"{%s, %s} -> %s\" Constants.message_tag_atom spat s1\n\n\nand stringify_pattern (ipat : pattern) =\n match ipat with\n | IPUnit -> unit_atom\n | IPBool(true) -> \"true\"\n | IPBool(false) -> \"false\"\n | IPInt(n) -> string_of_int n\n | IPBinary(s) -> Printf.sprintf \"<<\\\"%s\\\"/utf8>>\" (escape_string s)\n | IPChar(uchar) -> string_of_int (Uchar.to_int uchar)\n | IPVar(lname) -> OutputIdentifier.output_local lname\n | IPWildCard -> \"_\"\n | IPListNil -> \"[]\"\n\n | IPListCons(ipat1, ipat2) ->\n let s1 = stringify_pattern ipat1 in\n let s2 = stringify_pattern ipat2 in\n Printf.sprintf \"[%s | %s]\" s1 s2\n\n | IPTuple(ipats) ->\n let ss = ipats |> TupleList.to_list |> List.map stringify_pattern in\n Printf.sprintf \"{%s}\" (String.concat \", \" ss)\n\n | IPConstructor(ctorid, ipats) ->\n let atom = ConstructorID.output ctorid in\n begin\n match ipats with\n | [] ->\n atom\n\n | _ :: _ ->\n let ss = ipats |> List.map stringify_pattern in\n Printf.sprintf \"{%s, %s}\" atom (String.concat \", \" ss)\n end\n\n\nlet stringify_val_binding_output : val_binding_output -> string list = function\n | OBindVal(gnamefun, ordlnames, mndnamemap, optnamemap, gmap, ast0) ->\n let r = OutputIdentifier.output_global gnamefun in\n let sparams =\n let ipats = make_mandatory_parameters ordlnames mndnamemap in\n ipats |> List.map stringify_pattern\n in\n let sparamscat = String.concat \", \" sparams in\n let sparamscatcomma = sparams |> List.map (fun s -> s ^ \", \") |> String.concat \"\" in\n let sname_map = fresh_local_symbol () in\n let sgetopts = stringify_option_decoding_operation gmap sname_map optnamemap in\n let s0 = stringify_ast gmap ast0 in\n if r.has_option then\n let s_without_option =\n Printf.sprintf \"%s(%s) -> ?MODULE:%s(%s#{}).\"\n r.function_name\n sparamscat\n r.function_name\n sparamscatcomma\n in\n let s_with_option =\n Printf.sprintf \"%s(%s%s) -> %s%s.\"\n r.function_name\n sparamscatcomma\n sname_map\n sgetopts\n s0\n in\n [ s_without_option; s_with_option ]\n else\n let s =\n Printf.sprintf \"%s(%s) -> %s.\"\n r.function_name\n sparamscat\n s0\n in\n [ s ]\n\n | OBindValExternal(_, code) ->\n [code]\n\n\nlet stringify_module_binding_output (omodbind : module_binding_output) : string * string list =\n match omodbind with\n | OBindModule{\n basename = smod_basename;\n atom = smod_atom;\n attributes = modattr;\n bindings = ovalbinds;\n } ->\n let exports =\n ovalbinds |> List.map (function\n | OBindVal(gnamefun, _, _, _, _, _)\n | OBindValExternal(gnamefun, _) ->\n let r = OutputIdentifier.output_global gnamefun in\n if r.has_option then\n [\n Printf.sprintf \"%s/%d\" r.function_name r.arity;\n Printf.sprintf \"%s/%d\" r.function_name (r.arity + 1);\n ]\n else\n [\n Printf.sprintf \"%s/%d\" r.function_name r.arity;\n ]\n ) |> List.concat\n in\n let ss = ovalbinds |> List.map stringify_val_binding_output |> List.concat in\n let lines =\n List.concat [\n [ Printf.sprintf \"-module(%s).\" smod_atom ];\n modattr.behaviours |> StringSet.elements |> List.map (fun s -> Printf.sprintf \"-behaviour(%s).\" s);\n [ Printf.sprintf \"-export([%s]).\" (String.concat \", \" exports) ];\n ss;\n ]\n in\n (smod_basename, lines)\n\n\nlet write_file (absdir_out : absolute_dir) (smod_basename : string) (lines : string list) : unit =\n let abspath_out = Core.Filename.concat absdir_out (Printf.sprintf \"%s.erl\" smod_basename) in\n let fout = open_out abspath_out in\n lines |> List.iter (fun line ->\n output_string fout line;\n output_string fout \"\\n\"\n );\n close_out fout;\n Logging.output_written abspath_out\n\n\nlet write_module_to_file (absdir_out : absolute_dir) (omodbind : module_binding_output) : unit =\n let (smod_basename, lines) = stringify_module_binding_output omodbind in\n write_file absdir_out smod_basename lines\n\n\nlet write_primitive_module (dir_out : string) : unit =\n let smod = Primitives.primitive_module_name in\n let primdefs = Primitives.primitive_definitions in\n let exports =\n primdefs |> List.map (fun primdef ->\n let open Primitives in\n let targetdef = primdef.target in\n let arity = List.length targetdef.parameters in\n Printf.sprintf \"%s/%d\" targetdef.target_name arity\n )\n in\n let lines =\n List.concat [\n [\n Printf.sprintf \"-module(%s).\" smod;\n Printf.sprintf \"-export([%s]).\" (String.concat \", \" exports);\n ];\n primdefs |> List.map (fun primdef ->\n let open Primitives in\n let targetdef = primdef.target in\n Printf.sprintf \"%s(%s) -> %s.\"\n targetdef.target_name\n (String.concat \", \" targetdef.parameters)\n targetdef.code\n );\n ]\n in\n write_file dir_out smod lines\n\n\nlet main (spec : output_spec) (absdir_out : absolute_dir) (nmap : name_map) ~package_name:(pkgnameopt : space_name option) ~module_name:(sname : space_name) ((modattr, ibinds) : ModuleAttribute.t * binding list) : name_map =\n(*\n Format.printf \"OutputErlangCode | package: %a, module: %a\\n\"\n OutputIdentifier.pp_space pkgname\n OutputIdentifier.pp_space sname; (* for debug *)\n*)\n let (omodbinds, nmap_after) =\n let spacepath =\n match pkgnameopt with\n | Some(pkgname) -> Alist.extend (Alist.extend Alist.empty pkgname) sname\n | None -> Alist.extend Alist.empty sname\n in\n traverse_binding_list spec sname nmap spacepath modattr ibinds\n in\n omodbinds |> List.iter (fun omodbind ->\n write_module_to_file absdir_out omodbind\n );\n nmap_after\n" }, { "path": "src/outputErlangCode.mli", "content": "\nopen MyUtil\nopen Syntax\nopen IntermediateSyntax\n\n\nval main : output_spec -> string -> name_map -> package_name:(space_name option) -> module_name:space_name -> ModuleAttribute.t * binding list -> name_map\n(** [main spec dir_out nmap ~package_name:pkgopt ~module_name:sname binds]\n produces Erlang source files corresponding to [binds] in the directory [dir_out].\n The name of the resulting module is determined by [pkgopt] and [sname].\n The path [dir_out] can be either relative or absolute,\n and the directory specified by the path must be guaranteed existent beforehand. *)\n\nval write_primitive_module : absolute_dir -> unit\n" }, { "path": "src/outputIdentifier.ml", "content": "\ntype space =\n | ReprSpace of {\n number : int;\n main : IdentifierScheme.t;\n }\n\ntype local =\n | ReprLocal of {\n number : int;\n hint : IdentifierScheme.t option;\n }\n | ReprUnused\n\ntype global =\n | ReprGlobal of {\n number : int;\n function_name : IdentifierScheme.t;\n suffix : string;\n arity : int;\n has_option : bool;\n }\n | ReprDummy of {\n number : int;\n }\n\ntype operator =\n | ReprOperator of string\n\ntype t =\n | Local of local\n | Global of global\n | Operator of operator\n\ntype global_answer = {\n function_name : string;\n arity : int;\n has_option : bool;\n}\n\n\nlet fresh_number : unit -> int =\n let current_max = ref 0 in\n (fun () ->\n incr current_max;\n !current_max\n )\n\n\nlet space_of_module_name (s : string) : space option =\n let n = fresh_number () in\n IdentifierScheme.from_upper_camel_case s |> Option.map (fun space ->\n ReprSpace{\n number = n;\n main = space;\n }\n )\n\n\nlet space_of_package_name (s : string) : space option =\n let n = fresh_number () in\n IdentifierScheme.from_snake_case s |> Option.map (fun space ->\n ReprSpace{\n number = n;\n main = space;\n }\n )\n\n\nlet fresh () : local =\n let n = fresh_number () in\n ReprLocal{ hint = None; number = n }\n\n\nlet fresh_global_dummy () : global =\n let n = fresh_number () in\n ReprDummy{\n number = n;\n }\n\nlet generate_local (s : string) : local option =\n IdentifierScheme.from_snake_case s |> Option.map (fun ident ->\n let n = fresh_number () in\n ReprLocal{ hint = Some(ident); number = n }\n )\n\n\nlet generate_global (s : string) ~(suffix : string) ~(arity : int) ~(has_option : bool) : global option =\n IdentifierScheme.from_snake_case s |> Option.map (fun ident ->\n let n = fresh_number () in\n ReprGlobal{\n number = n;\n function_name = ident;\n suffix = suffix;\n arity = arity;\n has_option = has_option;\n }\n )\n\n\nlet operator (s : string) : operator =\n ReprOperator(s)\n\n\nlet unused : local =\n ReprUnused\n\n\nmodule Space = struct\n\n type t = space\n\n\n let compare (ReprSpace(sname1)) (ReprSpace(sname2)) =\n Int.compare sname2.number sname1.number\n\nend\n\n\nmodule Local = struct\n\n type t = local\n\n\n let compare lname1 lname2 =\n match (lname1, lname2) with\n | (ReprUnused, ReprUnused) -> 0\n | (ReprUnused, _) -> -1\n | (_, ReprUnused) -> 1\n | (ReprLocal(r1), ReprLocal(r2)) -> r2.number - r1.number\n\nend\n\n\nmodule Global = struct\n\n type t = global\n\n\n let compare gname1 gname2 =\n let extract_number = function\n | ReprDummy(r) -> r.number\n | ReprGlobal(r) -> r.number\n in\n extract_number gname2 - extract_number gname1\n\nend\n\n\nlet output_space_to_snake (ReprSpace(sname) : space) =\n IdentifierScheme.to_snake_case sname.main\n\n\nlet output_space_to_camel (ReprSpace(sname) : space) =\n IdentifierScheme.to_upper_camel_case sname.main\n\n\nlet output_local = function\n | ReprLocal(r) ->\n let hint =\n match r.hint with\n | None -> \"\"\n | Some(ident) -> IdentifierScheme.to_upper_camel_case ident\n in\n Printf.sprintf \"S%d%s\" r.number hint\n\n | ReprUnused ->\n \"_\"\n\n\nlet output_global = function\n | ReprGlobal(r) ->\n {\n function_name = Printf.sprintf \"'%s%s'\" (r.function_name |> IdentifierScheme.to_snake_case) r.suffix;\n arity = r.arity;\n has_option = r.has_option;\n }\n | ReprDummy(r) ->\n(*\n Format.printf \"attempted to output G%d(dummy)\\n\" r.number; (* for debug *)\n*)\n assert false\n\n\nlet output_operator = function\n | ReprOperator(s) ->\n s\n\n\nlet pp_space ppf (ReprSpace(sname) : space) =\n Format.fprintf ppf \"%a\" IdentifierScheme.pp sname.main\n\n\nlet pp_local ppf = function\n | ReprLocal(r) ->\n begin\n match r.hint with\n | None -> Format.fprintf ppf \"L%d\" r.number\n | Some(ident) -> Format.fprintf ppf \"L%d%a\" r.number IdentifierScheme.pp ident\n end\n\n | ReprUnused ->\n Format.fprintf ppf \"UNUSED\"\n\n\nlet pp_global ppf = function\n | ReprGlobal(r) ->\n Format.fprintf ppf \"G%d%a/%d\"\n r.number\n IdentifierScheme.pp r.function_name\n r.arity\n\n | ReprDummy(r) ->\n Format.fprintf ppf \"G%d(dummy)\"\n r.number\n\n\nlet pp_operator ppf = function\n | ReprOperator(s) ->\n Format.fprintf ppf \"O\\\"%s\\\"\" s\n\n\nlet pp ppf = function\n | Local(l) -> pp_local ppf l\n | Global(g) -> pp_global ppf g\n | Operator(o) -> pp_operator ppf o\n" }, { "path": "src/outputIdentifier.mli", "content": "\ntype space\n(** The type for abstracting module names in outputs. *)\n\ntype local\n\ntype global\n\ntype operator\n\ntype t =\n | Local of local\n | Global of global\n | Operator of operator\n\ntype global_answer = {\n function_name : string;\n arity : int;\n has_option : bool;\n}\n\nval space_of_module_name : string -> space option\n\nval space_of_package_name : string -> space option\n\nval fresh : unit -> local\n\nval fresh_global_dummy : unit -> global\n\nval generate_local : string -> local option\n\nval generate_global : string -> suffix:string -> arity:int -> has_option:bool -> global option\n\nval operator : string -> operator\n\nval unused : local\n\nmodule Space : sig\n\n type t = space\n\n val compare : t -> t -> int\n\nend\n\nmodule Local : sig\n\n type t = local\n\n val compare : t -> t -> int\n\nend\n\nmodule Global : sig\n\n type t = global\n\n val compare : t -> t -> int\n\nend\n\nval output_space_to_snake : space -> string\n\nval output_space_to_camel : space -> string\n\nval output_local : local -> string\n\nval output_global : global -> global_answer\n\nval output_operator : operator -> string\n\nval pp_space : Format.formatter -> space -> unit\n\nval pp_local : Format.formatter -> local -> unit\n\nval pp_global : Format.formatter -> global -> unit\n\nval pp_operator : Format.formatter -> operator -> unit\n\nval pp : Format.formatter -> t -> unit\n" }, { "path": "src/outputRebarConfig.ml", "content": "\nopen MyUtil\n\n\ntype value =\n | Int of int\n | String of string\n | Atom of string\n | Bool of bool\n | List of value list\n | Keyed of string * value list\n | Assoc of assoc\n\nand assoc =\n (string * value) list\n\n\nlet rec stringify_value = function\n | Int(n) -> string_of_int n\n | String(s) -> Printf.sprintf \"\\\"%s\\\"\" (String.escaped s)\n | Atom(s) -> s\n\n | Bool(true) -> \"true\"\n | Bool(false) -> \"false\"\n\n\n | List(vs) ->\n let s = vs |> List.map stringify_value |> String.concat \", \" in\n Printf.sprintf \"[%s]\" s\n\n | Keyed(key, vs) ->\n let ss = vs |> List.map stringify_value in\n Printf.sprintf \"{%s}\" (String.concat \", \" (key :: ss))\n\n | Assoc(assoc) ->\n let ss =\n assoc |> List.map (fun (key, v) ->\n Printf.sprintf \"{%s, %s}\" key (stringify_value v)\n )\n in\n Printf.sprintf \"[%s]\" (String.concat \",\" ss)\n\n\nlet ( ==> ) (key : string) (v : value) =\n (key, v)\n\n\nlet keyed (key : string) (vs : value list) =\n Keyed(key, vs)\n\n\nlet relative_dir_to_string (RelativeDir(s) : relative_dir) : value =\n String(s)\n\n\nlet make_git_spec (git_spec : ConfigLoader.git_spec) =\n match git_spec with\n | Tag(s) -> keyed \"tag\" [ String(s) ]\n | Ref(s) -> keyed \"ref\" [ String(s) ]\n | Branch(s) -> keyed \"branch\" [ String(s) ]\n\n\nlet make (config : ConfigLoader.config) : assoc =\n let entry_plugins =\n let v_git_spec = keyed \"branch\" [ String \"master\" ] in\n \"plugins\" ==> Assoc[\n Constants.plugin_name ==> keyed \"git\" [ String(Constants.plugin_url); v_git_spec ]\n ]\n in\n let reldir_out = config.erlang_config.output_directory in\n let reldir_test_out = config.erlang_config.test_output_directory in\n let entry_src_dirs =\n let reldirs = (reldir_out :: config.source_directories) in\n \"src_dirs\" ==> List(reldirs |> List.map relative_dir_to_string)\n in\n let entry_eunit_tests =\n let reldirs = (reldir_test_out :: config.test_directories) in\n \"eunit_tests\" ==> List(reldirs |> List.map (fun reldir -> Keyed(\"dir\", [ relative_dir_to_string reldir ])))\n in\n let entry_deps =\n let deps_sesterl =\n config.dependencies |> List.fold_left (fun acc dep ->\n let name = dep.ConfigLoader.dependency_name in\n match dep.ConfigLoader.dependency_source with\n | Local(_) ->\n acc\n\n | Git{ repository = uri; git_spec = git_spec } ->\n let v_git_spec = make_git_spec git_spec in\n let v_dep = keyed \"git\" [ String(uri); v_git_spec ] in\n Alist.extend acc (name, v_dep)\n ) Alist.empty |> Alist.to_list\n in\n let deps_erlang =\n config.erlang_config.erlang_dependencies |> List.map (fun erldep ->\n let name = erldep.ConfigLoader.erlang_library_name in\n let v_dep =\n match erldep.ConfigLoader.erlang_library_source with\n | ErlangLibFromHex{ version = version } ->\n String(version)\n\n | ErlangLibFromGit{ repository = uri; git_spec = git_spec } ->\n let v_git_spec = make_git_spec git_spec in\n keyed \"git\" [ String(uri); v_git_spec ]\n in\n (name, v_dep)\n )\n in\n \"deps\" ==> Assoc(List.append deps_sesterl deps_erlang)\n in\n let entry_profile =\n let test_deps_sesterl =\n config.ConfigLoader.test_dependencies |> List.fold_left (fun acc dep ->\n let name = dep.ConfigLoader.dependency_name in\n match dep.ConfigLoader.dependency_source with\n | Local(_) ->\n acc\n\n | Git{ repository = uri; git_spec = git_spec } ->\n let v_git_spec = make_git_spec git_spec in\n let v_dep = keyed \"git\" [ String(uri); v_git_spec ] in\n Alist.extend acc (name, v_dep)\n ) Alist.empty |> Alist.to_list\n in\n \"profiles\" ==> Assoc[\n \"test\" ==> Assoc[\n \"deps\" ==> Assoc(test_deps_sesterl)\n ]\n ]\n in\n let entries_relx =\n let open ConfigLoader in\n match config.erlang_config.relx with\n | None ->\n []\n\n | Some(relx) ->\n let release = relx.relx_release in\n let entry =\n \"relx\" ==> List[\n Keyed(\"release\", [\n Keyed(release.relx_name, [ String(release.relx_version) ]);\n List(\n release.relx_applications |> List.map (fun app -> Atom(app))\n );\n ]);\n Keyed(\"dev_mode\", [ Bool(relx.relx_dev_mode) ])\n ]\n in\n [ entry ]\n in\n let entry_sesterl_opts =\n \"sesterl_opts\" ==> Assoc[\n \"output_dir\" ==> relative_dir_to_string reldir_out;\n \"test_output_dir\" ==> relative_dir_to_string reldir_test_out;\n ]\n in\n List.concat [\n [\n entry_plugins;\n entry_src_dirs;\n entry_deps;\n entry_profile;\n entry_eunit_tests;\n ];\n entries_relx;\n [\n entry_sesterl_opts;\n ];\n ]\n\n\nlet main (absdir_out : absolute_dir) (config : ConfigLoader.config) =\n let top_assoc = make config in\n let s =\n top_assoc |> List.map (fun (key, v) ->\n Printf.sprintf \"{%s, %s}.\\n\" key (stringify_value v)\n ) |> String.concat \"\"\n in\n let fpath_out = Filename.concat absdir_out \"rebar.config\" in\n let fout = open_out fpath_out in\n output_string fout s;\n close_out fout;\n Logging.output_written fpath_out\n" }, { "path": "src/packageChecker.ml", "content": "\nopen MyUtil\nopen Syntax\nopen IntermediateSyntax\nopen Env\nopen Errors\n\n\nmodule SigRecordMap = Map.Make(String)\n\ntype sig_record_map = ((signature_source * SigRecord.t) abstracted * space_name) SigRecordMap.t\n\ntype single_output = {\n module_name : module_name;\n signature : (signature_source * SigRecord.t) abstracted;\n space_name : space_name;\n attribute : ModuleAttribute.t;\n bindings : binding list;\n}\n\n\nlet check_single ~(is_verbose : bool) ~(is_main_module : bool) (sigrmap : sig_record_map) (tyenv_before : Typeenv.t) (source : SourceLoader.loaded_module) : (signature_source * SigRecord.t) abstracted * single_output =\n let abspath = source.SourceLoader.source_path in\n let modident = source.SourceLoader.module_identifier in\n let utsigopt = source.SourceLoader.signature in\n let utmod = source.SourceLoader.module_content in\n let deps = source.SourceLoader.dependencies in\n Logging.begin_to_typecheck abspath;\n\n let tyenv_for_mod =\n deps |> List.fold_left (fun tyenv (rng, depmodnm) ->\n match sigrmap |> SigRecordMap.find_opt depmodnm with\n | None ->\n assert false\n\n | Some(((_, (isig, sigr)), sname)) ->\n let mentry =\n {\n mod_signature = (isig, ConcStructure(sigr));\n mod_name = sname;\n mod_doc = None;\n }\n in\n tyenv |> Typeenv.add_module depmodnm mentry\n ) tyenv_before\n in\n let (_, modnm) = modident in\n let absmodsigopt =\n let tyenv_for_sig = if is_main_module then tyenv_before else tyenv_for_mod in\n let address = Address.root |> Address.append_member modnm in\n utsigopt |> Option.map (Typechecker.typecheck_signature ~address tyenv_for_sig)\n in\n let (_, abssigr, sname, (modattr, ibinds)) = Typechecker.main tyenv_for_mod modident absmodsigopt utmod in\n let out =\n {\n module_name = modnm;\n signature = abssigr;\n space_name = sname;\n attribute = modattr;\n bindings = ibinds;\n }\n in\n (abssigr, out)\n\n\nlet main ~(is_verbose : bool) (tyenv_before : Typeenv.t) ~aux:(auxmods : SourceLoader.loaded_module list) ~main:(mainmod : SourceLoader.loaded_module) ~test:(testmods : SourceLoader.loaded_module list) : Typeenv.t * single_output list * single_output * single_output list =\n let (sigrmap, auxoutacc) =\n auxmods |> List.fold_left (fun (sigrmap, auxoutacc) auxmod ->\n let (abssigr, auxout) =\n check_single ~is_verbose ~is_main_module:false sigrmap tyenv_before auxmod\n in\n let sigrmap =\n let (_, modnm) = auxmod.SourceLoader.module_identifier in\n let sname = auxout.space_name in\n sigrmap |> SigRecordMap.add modnm (abssigr, sname)\n in\n let auxoutacc = Alist.extend auxoutacc auxout in\n (sigrmap, auxoutacc)\n ) (SigRecordMap.empty, Alist.empty)\n in\n\n let (abssigr_main, mainout) =\n check_single ~is_verbose ~is_main_module:true sigrmap tyenv_before mainmod\n in\n let sigrmap =\n let (_, modnm_main) = mainmod.SourceLoader.module_identifier in\n let sname_main = mainout.space_name in\n sigrmap |> SigRecordMap.add modnm_main (abssigr_main, sname_main)\n in\n\n let (_sigrmap, testoutacc) =\n testmods |> List.fold_left (fun (sigrmap, testoutacc) testmod ->\n let (abssigr, testout) =\n check_single ~is_verbose ~is_main_module:false sigrmap tyenv_before testmod\n in\n let sname = testout.space_name in\n let sigrmap =\n let (_, modnm) = testmod.SourceLoader.module_identifier in\n sigrmap |> SigRecordMap.add modnm (abssigr, sname)\n in\n let testoutacc = Alist.extend testoutacc testout in\n (sigrmap, testoutacc)\n ) (sigrmap, Alist.empty)\n in\n\n let tyenv =\n let (_, mainmod) = mainmod.SourceLoader.module_identifier in\n let mainsname = mainout.space_name in\n let (_, (mainisig, mainsigr)) = abssigr_main in\n let mentry =\n {\n mod_signature = (mainisig, ConcStructure(mainsigr));\n mod_name = mainsname;\n mod_doc = None;\n }\n in\n tyenv_before |> Typeenv.add_module mainmod mentry\n in\n let auxouts = Alist.to_list auxoutacc in\n let testouts = Alist.to_list testoutacc in\n (tyenv, auxouts, mainout, testouts)\n" }, { "path": "src/packageLoader.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Errors\n\n\nexception PackageError of package_error\n\n\nlet load_config absdir_in =\n let abspath_in = Core.Filename.concat absdir_in Constants.config_file_name in\n let config =\n match ConfigLoader.load abspath_in with\n | Ok(config) -> config\n | Error(e) -> raise (ConfigError(e))\n in\n match config.ConfigLoader.language_version with\n | None ->\n config\n\n | Some(language_version) ->\n if LanguageVersion.is_supported language_version then\n config\n else\n raise (ConfigError(UnsupportedLanguageVersion(language_version)))\n\n\n\nmodule PackageDirMap = Map.Make(String)\nmodule PackageNameMap = Map.Make(String)\n\ntype reading_state = {\n loaded_dirs : ConfigLoader.config PackageDirMap.t;\n loaded_names : absolute_dir PackageNameMap.t;\n graph : FileDependencyGraph.t;\n}\n\n\nlet main (external_map : external_map) (absdir : absolute_dir) : ((absolute_dir * ConfigLoader.config) list * ConfigLoader.config) =\n let rec aux ~(requires_test_deps : bool) (state : reading_state) (vertex : FileDependencyGraph.vertex) (absdir : absolute_dir) : ConfigLoader.config * reading_state =\n let config = load_config absdir in\n let pkgname = config.ConfigLoader.package_name in\n match state.loaded_names |> PackageNameMap.find_opt pkgname with\n | Some(absdir0) ->\n raise (PackageError(DuplicatedPackageName(pkgname, absdir0, absdir)))\n\n | None ->\n let loaded_dirs = state.loaded_dirs |> PackageDirMap.add absdir config in\n let loaded_names = state.loaded_names |> PackageNameMap.add pkgname absdir in\n let state = { state with loaded_dirs = loaded_dirs; loaded_names = loaded_names } in\n let state =\n let deps =\n if requires_test_deps then\n List.append\n config.ConfigLoader.dependencies\n config.ConfigLoader.test_dependencies\n else\n config.ConfigLoader.dependencies\n in\n deps |> List.fold_left (fun state dependency ->\n let graph = state.graph in\n let pkgname_sub = dependency.ConfigLoader.dependency_name in\n let absdir_sub =\n match dependency.ConfigLoader.dependency_source with\n | ConfigLoader.Local(absdir_sub) ->\n absdir_sub\n\n | ConfigLoader.Git(_git_spec) ->\n begin\n match external_map |> ExternalMap.find_opt pkgname_sub with\n | None -> raise (PackageError(NotFoundInExternalMap(pkgname_sub, external_map)))\n | Some(absdir_sub) -> absdir_sub\n end\n in\n let absdir_sub =\n match canonicalize_path absdir_sub with\n | None -> raise (PackageError(PackageDirNotFound(absdir_sub)))\n | Some(absdir) -> absdir\n in\n match graph |> FileDependencyGraph.find_vertex absdir_sub with\n | Some(vertex_sub) ->\n (* If the depended source file has already been parsed *)\n let graph = graph |> FileDependencyGraph.add_edge ~depending:vertex ~depended:vertex_sub in\n { state with graph = graph }\n\n | None ->\n (* If the depended source file has not been parsed yet *)\n let (graph, vertex_sub) = graph |> FileDependencyGraph.add_vertex absdir_sub in\n let graph = graph |> FileDependencyGraph.add_edge ~depending:vertex ~depended:vertex_sub in\n let (_, state) = aux ~requires_test_deps:false { state with graph = graph } vertex_sub absdir_sub in\n state\n ) state\n in\n (config, state)\n in\n let (config, state) =\n let (graph, vertex) = FileDependencyGraph.empty |> FileDependencyGraph.add_vertex absdir in\n let state =\n {\n graph = graph;\n loaded_dirs = PackageDirMap.empty;\n loaded_names = PackageNameMap.empty;\n }\n in\n aux ~requires_test_deps:true state vertex absdir\n in\n match FileDependencyGraph.topological_sort state.graph with\n | Error(cycle) ->\n raise (ConfigError(CyclicFileDependencyFound(cycle)))\n\n | Ok(absdirs) ->\n let pkgconfigs =\n absdirs |> List.map (fun absdir ->\n match state.loaded_dirs |> PackageDirMap.find_opt absdir with\n | None -> assert false\n | Some(config) -> (absdir, config)\n )\n in\n (pkgconfigs, config)\n" }, { "path": "src/packageLoader.mli", "content": "\nopen MyUtil\nopen Syntax\nopen Errors\n\nexception PackageError of package_error\n\nval load_config : absolute_dir -> ConfigLoader.config\n(** [load_config absdir] loads the configuration file placed in [absdir].\n May raise [ConfigError(_)] for invalid data.\n Note that paths contained in return values of this function have not been guaranteed existent. *)\n\nval main : external_map -> absolute_dir -> (absolute_dir * ConfigLoader.config) list * ConfigLoader.config\n(** [main absdir] lists up the package placed in [absdir] and all the packages\n on which the package depends either directly or indirectly,\n and sorts them in a topological order according to the dependency among them.\n May raise [ConfigError(_)] or [PackageError(_)]. *)\n" }, { "path": "src/parser.mly", "content": "%{\n open Syntax\n open MyUtil\n\n type 'a range_spec =\n | Token of Range.t\n | Ranged of (Range.t * 'a)\n\n let make_range rs1 rs2 =\n let aux = function\n | Token(rng) -> rng\n | Ranged((rng, _)) -> rng\n in\n let rng1 = aux rs1 in\n let rng2 = aux rs2 in\n Range.unite rng1 rng2\n\n\n let chop_last modchain =\n let (uident, uidents) = modchain in\n let (tokL, _) = uident in\n let (modidents, ctor) =\n match List.rev (uident :: uidents) with\n | [] -> assert false\n | ctor :: revmodidents -> (List.rev revmodidents, ctor)\n in\n (tokL, modidents, ctor)\n\n\n let fold_module_chain modchainraw =\n let (modident, projs) = modchainraw in\n let utmod =\n let (rng, modnm) = modident in\n (rng, ModVar(modnm))\n in\n projs |> List.fold_left (fun utmod proj ->\n let rng = make_range (Ranged(utmod)) (Ranged(proj)) in\n (rng, ModProjMod(utmod, proj))\n ) utmod\n\n\n let make_list_pattern pats =\n List.fold_right\n (fun pat patacc -> (Range.dummy \"pattern-cons\", PListCons(pat, patacc)))\n pats\n (Range.dummy \"pattern-nil\", PListNil)\n\n\n let binary e1 op e2 =\n let rng = make_range (Ranged(e1)) (Ranged(e2)) in\n let (rngop, _) = op in\n (rng, Apply((rngop, Var([], op)), ([e1; e2], [], [])))\n\n(*\n let syntax_sugar_module_application : Range.t -> untyped_module -> untyped_module -> untyped_module =\n let fresh =\n let r = ref 0 in\n (fun () -> incr r; Printf.sprintf \"SesterlInternalModule%d\" !r)\n in\n (* TODO: sophisticate how to generate dummy module identifiers *)\n fun rng utmod1 utmod2 ->\n let modident1 = (Range.dummy \"appident1\", fresh ()) in\n let modident2 = (Range.dummy \"appident2\", fresh ()) in\n let modidentA = (Range.dummy \"appidentA\", fresh ()) in\n let utbinds =\n [\n (Range.dummy \"appbind1\", BindModule(modident1, utmod1));\n (Range.dummy \"appbind2\", BindModule(modident2, utmod2));\n (Range.dummy \"appbindA\", BindModule(modidentA, (Range.dummy \"appA\", ModApply(modident1, modident2))));\n ]\n in\n (rng, ModProjMod((Range.dummy \"appB\", ModBinds(utbinds)), modidentA))\n*)\n\n let base_kind_o =\n (Range.dummy \"base_kind_o\", MKindName(\"o\"))\n (* TODO: fix such an ad-hoc insertion of kinds *)\n\n\n let decl_type_transparent (attrs : attribute list) (tokL : Range.t) (tybinds : type_binding list) : untyped_declaration =\n let rng = Range.dummy \"decl_type_transparent\" in (* TODO: give appropriate code ranges *)\n let dr = Range.dummy \"decl_type_transparent\" in\n let decls : untyped_declaration list =\n tybinds |> List.map (fun (tyident, tyvars, syn_or_vnt) ->\n let mnbkddoms =\n tyvars |> List.map (function\n | (_, None) -> base_kind_o\n | (_, Some(mnbkd)) -> mnbkd\n )\n in\n let mnkd = (dr, MKind(mnbkddoms, base_kind_o)) in\n (dr, DeclTypeOpaque(tyident, Some(mnkd), attrs))\n )\n in\n (rng, DeclInclude((dr, SigWith((dr, SigDecls([], decls)), [], tybinds))))\n%}\n\n%token LET REC AND IN LAMBDA IF THEN ELSE TRUE FALSE DO RECEIVE AFTER ACT END CASE OF TYPE VAL MODULE STRUCT SIGNATURE SIG WITH EXTERNAL INCLUDE IMPORT FREEZE PACK ASSERT OPEN\n%token LPAREN RPAREN LSQUARE RSQUARE LBRACE RBRACE ATTRIBUTE\n%token DEFEQ COMMA ARROW REVARROW BAR UNDERSCORE CONS COLON COERCE\n%token GT_SPACES GT_NOSPACE LTLT LT_EXACT\n%token LOWER DOTLOWER UPPER DOTUPPER TYPARAM ROWPARAM MNDLABEL OPTLABEL\n%token BINOP_TIMES BINOP_DIVIDES BINOP_PLUS BINOP_MINUS BINOP_AMP BINOP_BAR BINOP_EQ BINOP_LT BINOP_GT\n%token INT\n%token FLOAT\n%token BINARY STRING STRING_BLOCK\n%token FORMAT\n%token CHAR\n%token EOI\n\n%start main\n%type bindtop\n%type<(Syntax.module_name Syntax.ranged) list * Syntax.module_name Syntax.ranged * Syntax.untyped_signature option * Syntax.untyped_module> main\n%type ty\n%type params\n%type labparams\n%type optparams\n%type args\n%type labargs\n%type optargs\n%type tydoms\n%type labtydoms\n%type opttydoms\n%type<(Range.t * Syntax.label) list> labels\n%type typarams\n%type<((Range.t * Syntax.row_variable_name) * (Range.t * Syntax.label) list) list> rowparams\n%type bindvalsingle\n%type bindvaltop\n%type bindvallocal\n%type bindtypesingle\n%type modexprbot\n%type decl\n\n%%\nmain:\n | deps=list(dep); bindmod=bindmod; EOI {\n let (_, modident, utsigopt, utmod) = bindmod in\n (deps, modident, utsigopt, utmod)\n }\n;\ndep:\n | IMPORT; modident=UPPER { modident }\n;\nident:\n | ident=LOWER { ident }\n;\nbindtop:\n | TYPE; tybind=bindtypesingle; tybinds=list(bindtypesub) {\n let rng = Range.dummy \"bindtop-1\" in (* TODO: give appropriate code range *)\n (rng, BindType(tybind :: tybinds))\n }\n | attrs=list(attr); bindval=bindvaltop {\n let rng = Range.dummy \"bindtop-1\" in (* TODO: give appropriate code range *)\n let (_, valbinding) = bindval in\n (rng, BindVal(attrs, valbinding))\n }\n | bindmod=bindmod {\n let (rng, modident, utsigopt, utmod) = bindmod in\n (rng, BindModule(modident, utsigopt, utmod))\n }\n | tokL=SIGNATURE; sigident=UPPER; DEFEQ; utsig=sigexpr {\n let rng = make_range (Token(tokL)) (Ranged(utsig)) in\n (rng, BindSig(sigident, utsig))\n }\n | tokL=INCLUDE; utmod=modexpr {\n let rng = make_range (Token(tokL)) (Ranged(utmod)) in\n (rng, BindInclude(utmod))\n }\n;\nbindmod:\n | tokL=MODULE; modident=UPPER; utsigopt=option(coercion); DEFEQ; utmod=modexpr {\n let rng = make_range (Token(tokL)) (Ranged(utmod)) in\n (rng, modident, utsigopt, utmod)\n }\n;\ncoercion:\n | COERCE; utsig=sigexpr { utsig }\n;\nbindtypesingle:\n | ident=LOWER; tyrowparams=typarams; DEFEQ; ctorbrs=ctorbranches {\n let (typarams, _) = tyrowparams in\n (* TODO: restrict that the second entry is `[]` *)\n (ident, typarams, BindVariant(ctorbrs))\n }\n | ident=LOWER; tyrowparams=typarams; DEFEQ; mty=ty {\n let (typarams, _) = tyrowparams in\n (* TODO: restrict that the second entry is `[]` *)\n (ident, typarams, BindSynonym(mty))\n }\n;\nbindtypesub:\n | AND; tybind=bindtypesingle { tybind }\n;\ntyparams:\n | { ([], []) }\n | tylparen; typarams=typaramssub tyrparen { typarams }\n;\ntyparamssub:\n | rowparams=rowparams {\n ([], rowparams)\n }\n | typaram=TYPARAM {\n ([ (typaram, None) ], [])\n }\n | typaram=TYPARAM; CONS; mnbkd=bkd {\n ([ (typaram, Some(mnbkd)) ], [])\n }\n | typaram=TYPARAM; COMMA; tail=typaramssub {\n let (typarams, rowparams) = tail in\n ((typaram, None) :: typarams, rowparams)\n }\n | typaram=TYPARAM; CONS; mnbkd=bkd COMMA; tail=typaramssub {\n let (typarams, rowparams) = tail in\n ((typaram, Some(mnbkd)) :: typarams, rowparams)\n }\n;\nrowparams:\n | { [] }\n | rowparam=ROWPARAM; CONS; LPAREN; labels=labels; RPAREN { [ (rowparam, labels) ] }\n | rowparam=ROWPARAM; CONS; LPAREN; labels=labels; RPAREN; COMMA; tail=rowparams { (rowparam, labels) :: tail }\n;\nlabels:\n | { [] }\n | tok=LOWER { [ tok ] }\n | tok=LOWER; COMMA; tail=labels { tok :: tail }\n;\nbindvallocal:\n | valbinding=bindvalsingle { NonRec(valbinding) }\n | REC; valbinding=bindvalsingle; tail=list(recbinds) { Rec(valbinding :: tail) }\n;\nbindvaltop:\n | tokL=VAL; rec_or_nonrec=bindvallocal {\n (tokL, Internal(rec_or_nonrec))\n (* TODO: give appropriate range *)\n }\n | tokL=VAL; ident=LOWER; tyrowparams=typarams; COLON; mty=ty; DEFEQ; EXTERNAL; inttok=INT; has_option=has_option; strblock=STRING_BLOCK {\n let (typarams, rowparams) = tyrowparams in\n let (tokR, erlang_bind) = strblock in\n let (_, arity) = inttok in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n let extbind =\n {\n ext_identifier = ident;\n ext_type_params = typarams;\n ext_row_params = rowparams;\n ext_type_annot = mty;\n ext_arity = arity;\n ext_has_option = has_option;\n ext_code = erlang_bind;\n }\n in\n (rng, External(extbind))\n }\n;\nhas_option:\n | { false }\n | BINOP_PLUS { true } (* TODO: fix this ad-hoc implementation *)\n;\nrecbinds:\n | AND; valbinding=bindvalsingle { valbinding }\n;\nbindvalsingle:\n | ident=LOWER; tyrowparams=typarams; LPAREN; params=params; RPAREN; ret=bindvalret {\n let (typarams, rowparams) = tyrowparams in\n let (ordparams, (mndparams, optparams)) = params in\n {\n vb_identifier = ident;\n vb_forall = typarams;\n vb_forall_row = rowparams;\n vb_parameters = ordparams;\n vb_mandatories = mndparams;\n vb_optionals = optparams;\n vb_return = ret;\n }\n }\n;\nbindvalret:\n | DEFEQ; e=exprlet {\n Pure(None, e)\n }\n | COLON; mty=ty DEFEQ; e=exprlet {\n Pure(Some(mty), e)\n }\n | DEFEQ; ACT; c=comp {\n Effectful(None, c)\n }\n | COLON; LSQUARE; mty1=ty; RSQUARE; mty2=ty DEFEQ; ACT; c=comp {\n Effectful(Some(mty1, mty2), c)\n }\n;\nctorbranches:\n | ctorbrs=nonempty_list(ctorbranch) { ctorbrs }\n;\nctorbranch:\n | BAR; attrs=list(attr); ctor=UPPER { ConstructorBranch(attrs, ctor, []) }\n | BAR; attrs=list(attr); ctor=UPPER; LPAREN; paramtys=tys; RPAREN { ConstructorBranch(attrs, ctor, paramtys) }\n;\nparams:\n | labparams=labparams {\n ([], labparams)\n }\n | pat=patcons; tyannot=tyannot {\n ([ (pat, tyannot) ], ([], []))\n }\n | pat=patcons; tyannot=tyannot; COMMA; tail=params {\n let (ordparams, labparams) = tail in\n ((pat, tyannot) :: ordparams, labparams)\n }\n;\nlabparams:\n | optparams=optparams {\n ([], optparams)\n }\n | rlabel=MNDLABEL; pat=patcons; tyannot=tyannot {\n ([ (rlabel, (pat, tyannot)) ], [])\n }\n | rlabel=MNDLABEL; pat=patcons; tyannot=tyannot; COMMA; tail=labparams {\n let (mndparams, optparams) = tail in\n ((rlabel, (pat, tyannot)) :: mndparams, optparams)\n }\n;\noptparams:\n | { [] }\n | optparam=optparam { [ optparam ] }\n | optparam=optparam; COMMA; tail=optparams { optparam :: tail }\n;\noptparam:\n | rlabel=OPTLABEL; pat=patcons; tyannot=tyannot {\n ((rlabel, (pat, tyannot)), None)\n }\n | rlabel=OPTLABEL; pat=patcons; tyannot=tyannot; DEFEQ; utast=exprlet {\n ((rlabel, (pat, tyannot)), Some(utast))\n }\n;\ntyannot:\n | { None }\n | COLON; mty=ty { Some(mty) }\n;\ndecl:\n | attrs=list(attr); tokL=VAL; ident=LOWER; tyrowparams=typarams; COLON; mty=ty {\n let (typarams, rowparams) = tyrowparams in\n let rng = make_range (Token(tokL)) (Ranged(mty)) in\n (rng, DeclVal(ident, typarams, rowparams, mty, attrs))\n }\n | attrs=list(attr); tokL=TYPE; tyident=LOWER; CONS; kd=kd {\n let rng = make_range (Token(tokL)) (Ranged(kd)) in\n (rng, DeclTypeOpaque(tyident, Some(kd), attrs))\n }\n | attrs=list(attr); tokL=TYPE; tyident=LOWER {\n let rng = make_range (Token(tokL)) (Ranged(tyident)) in\n (rng, DeclTypeOpaque(tyident, None, attrs))\n }\n | attrs=list(attr); tokL=TYPE; tybind=bindtypesingle; tybinds=list(bindtypesub) {\n decl_type_transparent attrs tokL (tybind :: tybinds)\n }\n | attrs=list(attr); tokL=MODULE; modident=UPPER; COLON; utsig=sigexpr {\n let rng = make_range (Token(tokL)) (Ranged(utsig)) in\n (rng, DeclModule(modident, utsig, attrs))\n }\n | attrs=list(attr); tokL=SIGNATURE; sigident=UPPER; DEFEQ; utsig=sigexpr {\n let rng = make_range (Token(tokL)) (Ranged(utsig)) in\n (rng, DeclSig(sigident, utsig, attrs))\n }\n;\nmodexpr:\n | tokL=LAMBDA; LPAREN; modident=UPPER; COLON; utsig=sigexpr; RPAREN; ARROW; utmod=modexpr {\n let rng = make_range (Token(tokL)) (Ranged(utmod)) in\n (rng, ModFunctor(modident, utsig, utmod))\n }\n | modident=UPPER; COERCE; utsig=sigexprbot {\n let rng = make_range (Ranged(modident)) (Ranged(utsig)) in\n (rng, ModCoerce(modident, utsig))\n }\n | utmod=modapp { utmod }\n;\nmodapp:\n | modchain1=modchainraw; LPAREN; modchain2=modchainraw; tokR=RPAREN {\n let (modident1, _) = modchain1 in\n let rng = make_range (Ranged(modident1)) (Token(tokR)) in\n (rng, ModApply(modchain1, modchain2))\n }\n | utmod=modexprbot { utmod }\n;\nmodexprbot:\n | utmod=modexprunit { utmod }\n | utmod=modchain { utmod }\n;\nmodexprunit:\n | attrs=list(attr); tokL=STRUCT; openspecs=list(openspec) utbinds=list(bindtop); tokR=END {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, ModBinds(attrs, openspecs, utbinds))\n }\n | tokL=LPAREN; utmod=modexpr; tokR=RPAREN {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n let (_, utmodmain) = utmod in\n (rng, utmodmain)\n }\n;\nmodchain:\n | modchainraw=modchainraw { fold_module_chain modchainraw }\n;\nmodchainraw:\n | modident=UPPER; projs=list(DOTUPPER) { (modident, projs) }\n;\nopenspec:\n | OPEN; modchain=modchainraw { modchain }\n;\nattr:\n | tokL=ATTRIBUTE; ident=LOWER; LPAREN; utast=exprlet; RPAREN; tokR=RSQUARE {\n let (_, attr_name) = ident in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n Attribute((rng, (attr_name, Some(utast))))\n }\n | tokL=ATTRIBUTE; ident=LOWER; tokR=RSQUARE {\n let (_, attr_name) = ident in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n Attribute((rng, (attr_name, None)))\n }\n;\nsigexpr:\n | tokL=LAMBDA; LPAREN; sigident=UPPER; COLON; utsig1=sigexpr; RPAREN; ARROW; utsig2=sigexpr {\n let rng = make_range (Token(tokL)) (Ranged(utsig2)) in\n (rng, SigFunctor(sigident, utsig1, utsig2))\n }\n | utsig=sigexprwith { utsig }\n;\nsigexprwith:\n | utsig=sigexprbot; WITH; modidents=withproj; TYPE; tybind=bindtypesingle; tybinds=list(bindtypesub) {\n let rng = Range.dummy \"sigexpr\" in (* TODO: give appropriate code ranges *)\n (rng, SigWith(utsig, modidents, tybind :: tybinds))\n }\n | utsig=sigexprbot { utsig }\n;\nwithproj:\n | { [] }\n | modident=UPPER; modidents=list(DOTUPPER) { modident :: modidents }\n;\nsigexprbot:\n | utmod=modexprunit; sigident=DOTUPPER {\n let rng = make_range (Ranged(utmod)) (Ranged(sigident)) in\n (rng, SigPath(utmod, sigident))\n }\n | modchain=modchainraw {\n let (tokL, modidents, sigident) = chop_last modchain in\n let rng = make_range (Token(tokL)) (Ranged(sigident)) in\n match modidents with\n | [] ->\n let (_, signm) = sigident in\n (rng, SigVar(signm))\n\n | modident :: projs ->\n let utmod = fold_module_chain (modident, projs) in\n (rng, SigPath(utmod, sigident))\n }\n | tokL=SIG; openspecs=list(openspec); utdecls=list(decl); tokR=END {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, SigDecls(openspecs, utdecls))\n }\n | tokL=LPAREN; utsig=sigexpr; tokR=RPAREN {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n let (_, utsigmain) = utsig in\n (rng, utsigmain)\n }\n;\ncomp:\n | tokL=DO; pat=patcons; tyannot=tyannot; REVARROW; c1=comp; IN; c2=comp {\n let rng = make_range (Token(tokL)) (Ranged(c2)) in\n (rng, CompDo((pat, tyannot), c1, c2))\n }\n | tokL=RECEIVE; branches=nonempty_list(receive_branch); after=option(after); tokR=END {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, CompReceive(branches, after))\n }\n | tokL=LET; rec_or_nonrec=bindvallocal; IN; c2=comp {\n let rng = make_range (Token(tokL)) (Ranged(c2)) in\n (rng, CompLetIn(rec_or_nonrec, c2))\n }\n | tokL=LET; pat=patcons; DEFEQ; e1=exprlet; IN; c2=comp {\n let rng = make_range (Token(tokL)) (Ranged(c2)) in\n (rng, CompLetPatIn(pat, e1, c2))\n }\n | tokL=IF; e0=exprlet; THEN; c1=comp; ELSE c2=comp {\n let rng = make_range (Token(tokL)) (Ranged(c2)) in\n (rng, CompIf(e0, c1, c2))\n }\n | tokL=CASE; e=exprlet; OF; branches=nonempty_list(comp_case_branch); tokR=END {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, CompCase(e, branches))\n }\n | efun=exprapp; LPAREN; args=args; tokR=RPAREN {\n let (ordargs, (mndargs, optargs)) = args in\n let rng = make_range (Ranged(efun)) (Token(tokR)) in\n (rng, CompApply(efun, (ordargs, mndargs, optargs)))\n }\n;\nafter:\n | AFTER; e=exprapp; ARROW; c=comp { (e, c) }\n;\nexprlet:\n | tokL=LET; rec_or_nonrec=bindvallocal; IN; e2=exprlet {\n let rng = make_range (Token(tokL)) (Ranged(e2)) in\n (rng, LetIn(rec_or_nonrec, e2))\n }\n | tokL=LET; pat=patcons; DEFEQ; e1=exprlet; IN; e2=exprlet {\n let rng = make_range (Token(tokL)) (Ranged(e2)) in\n (rng, LetPatIn(pat, e1, e2))\n }\n | tokL=IF; e0=exprlet; THEN; e1=exprlet; ELSE; e2=exprlet {\n let rng = make_range (Token(tokL)) (Ranged(e2)) in\n (rng, If(e0, e1, e2))\n }\n | tokL=ASSERT; e0=exprlet {\n let rng = make_range (Token(tokL)) (Ranged(e0)) in\n (rng, Assert(e0))\n }\n | e=exprfun { e }\n;\nexprfun:\n | tokL=LAMBDA; LPAREN; params=params; RPAREN; ARROW; cod=exprcod; tokR=END {\n let (ordparams, (mndparams, optparams)) = params in\n let lamparams = (ordparams, mndparams, optparams) in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n match cod with\n | Pure(e) -> (rng, Lambda(lamparams, e))\n | Effectful(c) -> (rng, LambdaEff(lamparams, c))\n }\n | tokL=CASE; e=exprlet; OF; branches=nonempty_list(case_branch); tokR=END {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, Case(e, branches))\n }\n | e=exprland { e }\n;\nexprcod:\n | e=exprlet { Pure(e) }\n | ACT; c=comp { Effectful(c) }\n;\nexprland:\n | e1=exprlor; op=BINOP_AMP; e2=exprland { binary e1 op e2 }\n | e=exprlor { e }\n;\nexprlor:\n | e1=exprcomp; op=BINOP_BAR; e2=exprlor { binary e1 op e2 }\n | e=exprcomp { e }\n;\nexprcomp:\n | e1=exprcons; op=BINOP_EQ; e2=exprcomp { binary e1 op e2 }\n | e1=exprcons; op=oplt; e2=exprcomp { binary e1 op e2 }\n | e1=exprcons; op=opgt; e2=exprcomp { binary e1 op e2 }\n | e=exprcons { e }\n;\noplt:\n | op=BINOP_LT { op }\n | rng=LT_EXACT { (rng, \"<\") }\n;\nopgt:\n | op=BINOP_GT { op }\n | rng=GT_SPACES { (rng, \">\") }\n | rng=GT_NOSPACE { (rng, \">\") }\n;\nexprcons:\n | e1=exprtimes; CONS; e2=exprcons {\n let rng = make_range (Ranged(e1)) (Ranged(e2)) in\n (rng, ListCons(e1, e2))\n }\n | e=exprplus { e }\n;\nexprplus:\n | e1=exprplus; op=BINOP_PLUS; e2=exprtimes { binary e1 op e2 }\n | e1=exprplus; op=BINOP_MINUS; e2=exprtimes { binary e1 op e2 }\n | e=exprtimes { e }\n;\nexprtimes:\n | e1=exprtimes; op=BINOP_TIMES; e2=exprapp { binary e1 op e2 }\n | e1=exprtimes; op=BINOP_DIVIDES; e2=exprapp { binary e1 op e2 }\n | e=exprapp { e }\n;\nexprapp:\n | efun=exprapp; LPAREN; args=args; tokR=RPAREN {\n let (ordargs, (mndargs, optargs)) = args in\n let rng = make_range (Ranged(efun)) (Token(tokR)) in\n (rng, Apply(efun, (ordargs, mndargs, optargs)))\n }\n | tokL=PACK; modchain=modchainraw; COLON; utsig=sigexprbot {\n let rng = make_range (Token(tokL)) (Ranged(utsig)) in\n (rng, Pack(modchain, utsig))\n }\n | tokL=FREEZE; modchain=modchainraw; ident=DOTLOWER; LPAREN; args=freezeargs; tokR=RPAREN {\n let (ordargs, rngs) = args in\n let ((rng1, _), _) = modchain in\n let rngapp = make_range (Token(rng1)) (Token(tokR)) in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, Freeze(rngapp, FrozenModFun(modchain, ident), ordargs, rngs))\n }\n | tokL=FREEZE; ident=LOWER; LPAREN; args=freezeargs; tokR=RPAREN {\n let (ordargs, rngs) = args in\n let rngapp = make_range (Ranged(ident)) (Token(tokR)) in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, Freeze(rngapp, FrozenFun(ident), ordargs, rngs))\n }\n | tokL=FREEZE; LPAREN; e=exprlet; RPAREN; WITH; LPAREN; args=freezeargs; tokR=RPAREN {\n let (ordargs, rngs) = args in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, FreezeUpdate(e, ordargs, rngs))\n }\n | modchain=modchainraw; LPAREN; args=args; tokR=RPAREN {\n let (tokL, modidents, ctor) = chop_last modchain in\n let (ordargs, optargs) = args in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n let (_, ctornm) = ctor in\n (rng, Constructor(modidents, ctornm, ordargs))\n (* TODO: emit errors when `optargs` is not nil *)\n }\n | modchain=modchainraw {\n let (tokL, modidents, ctor) = chop_last modchain in\n let rng = make_range (Token(tokL)) (Ranged(ctor)) in\n let (_, ctornm) = ctor in\n (rng, Constructor(modidents, ctornm, []))\n }\n | modchain=modchainraw; ident=DOTLOWER {\n let (modident, modidents) = modchain in\n let rng = make_range (Ranged(modident)) (Ranged(ident)) in\n (rng, Var(modident :: modidents, ident))\n }\n | e=exprbot { e }\n;\nargs:\n | labargs=labargs { ([], labargs) }\n | e=exprlet { ([ e ], ([], [])) }\n | e=exprlet; COMMA; tail=args { let (ordargs, labargs) = tail in (e :: ordargs, labargs) }\n;\nlabargs:\n | optargs=optargs { ([], optargs) }\n | rlabel=MNDLABEL; e=exprlet { ([ (rlabel, e) ], []) }\n | rlabel=MNDLABEL; e=exprlet; COMMA; tail=labargs { let (mndargs, optargs) = tail in ((rlabel, e) :: mndargs, optargs) }\n;\noptargs:\n | { [] }\n | rlabel=OPTLABEL; e=exprlet { [ (rlabel, e) ] }\n | rlabel=OPTLABEL; e=exprlet; COMMA; tail=optargs { (rlabel, e) :: tail }\n;\nfreezeargs:\n | rngs=holeargs { ([], rngs) }\n | e=exprlet { ([ e ], []) }\n | e=exprlet; COMMA; tail=freezeargs { let (ordargs, rngs) = tail in (e :: ordargs, rngs) }\n;\nholeargs:\n | { [] }\n | tok=UNDERSCORE { [ tok ] }\n | tok=UNDERSCORE; COMMA; tail=holeargs { tok :: tail }\n;\nrecord:\n | { [] }\n | rlabel=LOWER; DEFEQ; e=exprlet { [ (rlabel, e) ] }\n | rlabel=LOWER; DEFEQ; e=exprlet; COMMA; tail=record { (rlabel, e) :: tail }\n;\nexprs:\n | { [] }\n | e=exprlet { [ e ] }\n | e=exprlet; COMMA; tail=exprs { e :: tail }\n;\nexprbot:\n | rng=TRUE { (rng, BaseConst(Bool(true))) }\n | rng=FALSE { (rng, BaseConst(Bool(false))) }\n | tokL=LBRACE; tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, BaseConst(Unit)) }\n | c=INT { let (rng, n) = c in (rng, BaseConst(Int(n))) }\n | c=FLOAT { let (rng, r) = c in (rng, BaseConst(Float(r))) }\n | ident=ident { let (rng, _) = ident in (rng, Var([], ident)) }\n | LPAREN; e=exprlet; RPAREN { e }\n\n | tokL=LBRACE; e1=exprlet; es=list(tuplesub); tokR=RBRACE {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, Tuple(TupleList.make e1 es))\n }\n | tokL=LSQUARE; es=exprs; tokR=RSQUARE {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n let dr = Range.dummy \"list\" in\n let (_, emain) =\n List.fold_right (fun e tail -> (dr, ListCons(e, tail))) es (dr, ListNil)\n in\n (rng, emain)\n }\n | tokL=LTLT; ns=bytes tokR=gtgt {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, BinaryByList(ns))\n }\n | binlit=BINARY {\n let (rng, s) = binlit in\n (rng, BaseConst(BinaryByString(s)))\n }\n | strblock=STRING_BLOCK {\n let (rng, s) = strblock in\n (rng, BaseConst(BinaryByInts(s |> String.to_seq |> List.of_seq |> List.map Char.code)))\n }\n | strlit=STRING {\n let (rng, s) = strlit in\n (rng, BaseConst(String(s)))\n }\n | fmtlit=FORMAT {\n let (rng, fmtelems) = fmtlit in\n (rng, BaseConst(FormatString(fmtelems)))\n }\n | charlit=CHAR {\n let (rng, uchar) = charlit in\n (rng, BaseConst(Char(uchar)))\n }\n | tokL=LBRACE; les=record; tokR=RBRACE {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, Record(les))\n }\n | tokL=LBRACE; e1=exprbot; BAR; les=record; tokR=RBRACE {\n let (_, eaccmain) =\n List.fold_left (fun eacc (rlabel, e2) ->\n let rng = make_range (Token(tokL)) (Ranged(e2)) in\n (rng, RecordUpdate(eacc, rlabel, e2))\n ) e1 les\n in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, eaccmain)\n }\n | e=exprbot; rlabel=DOTLOWER {\n let rng = make_range (Ranged(e)) (Ranged(rlabel)) in\n (rng, RecordAccess(e, rlabel))\n }\n;\nbytes:\n | { [] }\n | tok=INT { tok :: [] }\n | tok=INT; COMMA; tail=bytes { tok :: tail }\n;\ngtgt:\n | GT_NOSPACE; tokR=GT_NOSPACE { tokR }\n | GT_NOSPACE; tokR=GT_SPACES { tokR }\n;\ntuplesub:\n COMMA; e=exprlet { e }\n;\nreceive_branch:\n | BAR; pat=patcons; ARROW; c=comp { ReceiveBranch(pat, c) }\n;\ncase_branch:\n | BAR; pat=patcons; ARROW; e=exprlet { CaseBranch(pat, e) }\n;\ncomp_case_branch:\n | BAR; pat=patcons; ARROW; c=comp { CompCaseBranch(pat, c) }\n;\npatcons:\n | p1=patbot; CONS; p2=patcons { let rng = make_range (Ranged(p1)) (Ranged(p2)) in (rng, PListCons(p1, p2)) }\n | p=patbot { p }\n;\npatbot:\n | rng=TRUE { (rng, PBool(true)) }\n | rng=FALSE { (rng, PBool(false)) }\n | tokL=LBRACE; tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, PUnit) }\n | c=INT { let (rng, n) = c in (rng, PInt(n)) }\n | charlit=CHAR { let (rng, uchar) = charlit in (rng, PChar(uchar)) }\n | binlit=BINARY { let (rng, s) = binlit in (rng, PBinary(s)) }\n | ident=ident { let (rng, x) = ident in (rng, PVar(x)) }\n | rng=UNDERSCORE { (rng, PWildCard) }\n\n | tokL=LSQUARE; tokR=RSQUARE {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, PListNil)\n }\n | tokL=LSQUARE; p1=patcons; pats=list(pattuplesub); tokR=RSQUARE {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n let (_, pmain) = make_list_pattern (p1 :: pats) in\n (rng, pmain)\n }\n\n | tokL=LBRACE; p1=patcons; pats=list(pattuplesub); tokR=RBRACE {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, PTuple(TupleList.make p1 pats))\n }\n | modchain=modchainraw {\n let (tokL, modidents, ctor) = chop_last modchain in\n let rng = make_range (Token(tokL)) (Ranged(ctor)) in\n let (_, ctornm) = ctor in\n (rng, PConstructor(modidents, ctornm, []))\n }\n | modchain=modchainraw; LPAREN; pats=pats; tokR=RPAREN {\n let (tokL, modidents, ctor) = chop_last modchain in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n let (_, ctornm) = ctor in\n (rng, PConstructor(modidents, ctornm, pats))\n }\n;\npats:\n | { [] }\n | pat=patcons { pat :: [] }\n | pat=patcons; COMMA; tail=pats { pat :: tail }\n;\npattuplesub:\n | COMMA; p=patcons { p }\n;\ntys:\n | { [] }\n | mty=ty { mty :: [] }\n | mty=ty; COMMA; tail=tys { mty :: tail }\n;\ntydoms:\n | labmtydoms=labtydoms { ([], labmtydoms) }\n | mty=ty { ([ mty ], ([], MRow([], None))) }\n | mty=ty; COMMA; tail=tydoms { let (ordmtydoms, labmtydoms) = tail in (mty :: ordmtydoms, labmtydoms) }\n;\nlabtydoms:\n | optmtydoms=opttydoms {\n ([], optmtydoms)\n }\n | rlabel=MNDLABEL; mty=ty {\n ([ (rlabel, mty) ], MRow([], None))\n }\n | rlabel=MNDLABEL; mty=ty; COMMA; tail=labtydoms {\n let (mndmtydoms, optmtydoms) = tail in\n ((rlabel, mty) :: mndmtydoms, optmtydoms)\n }\n;\nopttydoms:\n | sub=opttydomssub { let (pairs, rowvaropt) = sub in MRow(pairs, rowvaropt) }\n;\nopttydomssub:\n | {\n ([], None)\n }\n | rlabel=OPTLABEL; mty=ty {\n ([ (rlabel, mty) ], None)\n }\n | tok=ROWPARAM {\n ([], Some(tok))\n }\n | rlabel=OPTLABEL; mty=ty; COMMA; tail=opttydomssub {\n let (pairs, rowvaropt) = tail in\n ((rlabel, mty) :: pairs, rowvaropt)\n }\n;\nkd:\n | tokL=LPAREN; bkddoms=bkds; RPAREN; ARROW; bkdcod=bkd {\n let rng = make_range (Token(tokL)) (Ranged(bkdcod)) in\n (rng, MKind(bkddoms, bkdcod))\n }\n | bkd=bkd {\n let (rng, _) = bkd in\n (rng, MKind([], bkd))\n }\n;\nbkds:\n | bkd=bkd { [ bkd ] }\n | bkd=bkd; COMMA { [ bkd ] }\n | bkd=bkd; COMMA; tail=bkds { bkd :: tail }\n;\nbkd:\n | ident=LOWER {\n let (rng, kdnm) = ident in\n (rng, MKindName(kdnm))\n }\nty:\n | utmod=modchain; tyident=DOTLOWER {\n let rng = make_range (Ranged(utmod)) (Ranged(tyident)) in\n (rng, MModProjType(utmod, tyident, []))\n }\n | utmod=modchain; tyident=DOTLOWER; tylparen; mtyargs=tys; tokR=tyrparen {\n let rng = make_range (Ranged(utmod)) (Token(tokR)) in\n (rng, MModProjType(utmod, tyident, mtyargs))\n }\n | mty=tybot { mty }\n;\ntybot:\n | tok=TYPARAM {\n let (rng, typaram) = tok in\n (rng, MTypeVar(typaram))\n }\n | ident=LOWER {\n let (rng, tynm) = ident in\n (rng, MTypeName(tynm, []))\n }\n | ident=LOWER; tylparen; mtyargs=tys; tokR=tyrparen {\n let (tokL, tynm) = ident in\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, MTypeName(tynm, mtyargs))\n }\n | tokL=LAMBDA; LPAREN; tydoms=tydoms; RPAREN; ARROW; cod=tycod {\n let (ordmtydoms, (mndmtydoms, optmtydoms)) = tydoms in\n match cod with\n | Pure(mtycod) ->\n let rng = make_range (Token(tokL)) (Ranged(mtycod)) in\n (rng, MFuncType((ordmtydoms, mndmtydoms, optmtydoms), mtycod))\n\n | Effectful(rngL, mty1, mty2) ->\n let rng = make_range (Token(tokL)) (Token(rngL)) in\n (rng, MEffType((ordmtydoms, mndmtydoms, optmtydoms), mty1, mty2))\n }\n | tokL=LBRACE; mty1=ty; mtys=list(tytuplesub) tokR=RBRACE {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n (rng, MProductType(TupleList.make mty1 mtys))\n }\n | tokL=LBRACE; tyrecord=tyrecord; tokR=RBRACE {\n let rng = make_range (Token(tokL)) (Token(tokR)) in\n let (pairs, rowvaropt) = tyrecord in\n (rng, MRecordType(MRow(pairs, rowvaropt)))\n }\n | tokL=PACK; utsig=sigexprbot {\n let rng = make_range (Token(tokL)) (Ranged(utsig)) in\n (rng, MPackType(utsig))\n }\n;\ntycod:\n | mtycod=ty {\n Pure(mtycod)\n }\n | tokL=LSQUARE; mty1=ty; RSQUARE; mty2=ty {\n let rng = make_range (Token(tokL)) (Ranged(mty2)) in\n Effectful(rng, mty1, mty2)\n }\n;\ntyrecord:\n | {\n ([], None)\n }\n | rlabel=LOWER; COLON; mty=ty {\n ([ (rlabel, mty) ], None)\n }\n | tok=ROWPARAM {\n ([], Some(tok))\n }\n | rlabel=LOWER; COLON; mty=ty; COMMA; tail=tyrecord {\n let (pairs, rowvaropt) = tail in\n ((rlabel, mty) :: pairs, rowvaropt)\n }\n;\ntytuplesub:\n | COMMA; mty=ty { mty }\n;\ntylparen:\n | tok=LT_EXACT { tok }\n;\ntyrparen:\n | tok=GT_NOSPACE { tok }\n | tok=GT_SPACES { tok }\n;\n" }, { "path": "src/parserInterface.ml", "content": "\nopen Syntax\nopen Errors\n\nmodule I = Parser.MenhirInterpreter\n\n\nlet k_success x =\n Ok(x)\n\n\nlet k_fail chkpt =\n match chkpt with\n | I.HandlingError(penv) ->\n let rng = Range.from_positions (I.positions penv) in\n Error(ParseError(rng))\n\n | _ ->\n assert false\n\n\nlet process ~fname:(fname : string) (lexbuf : Lexing.lexbuf) : ((module_name ranged) list * module_name ranged * untyped_signature option * untyped_module, syntax_error) result =\n try\n lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = fname };\n let supplier = I.lexer_lexbuf_to_supplier Lexer.token lexbuf in\n I.loop_handle k_success k_fail supplier (Parser.Incremental.main lexbuf.Lexing.lex_curr_p)\n with\n | Lexer.Error(e) ->\n Error(LexerError(e))\n" }, { "path": "src/parserInterface.mli", "content": "\nopen Syntax\nopen Errors\n\nval process : fname:string -> Lexing.lexbuf -> ((module_name ranged) list * module_name ranged * untyped_signature option * untyped_module, syntax_error) result\n" }, { "path": "src/primitives.ml", "content": "\nopen MyUtil\nopen Syntax\nopen IntermediateSyntax\nopen Env\n\n\nlet primitive_module_name =\n \"sesterl_internal_prim\"\n\n\nlet decode_option_function =\n \"decode_option\"\n\n\nlet decode_option_function_with_default =\n \"decode_option_with_default\"\n\n\nlet vid_option = TypeID.fresh Address.root \"option\"\n\n\nlet vid_result = TypeID.fresh Address.root \"result\"\n\n\nlet vid_list = TypeID.fresh Address.root \"list\"\n\n\nlet vid_format = TypeID.fresh Address.root \"format\"\n\n\nlet vid_frozen = TypeID.fresh Address.root \"frozen\"\n\n\nlet option_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ =\n (rng, TypeApp(vid_option, [ty]))\n\n\nlet list_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ =\n (rng, TypeApp(vid_list, [ty]))\n\n\nlet format_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ =\n (rng, TypeApp(vid_format, [ty]))\n\n\nlet frozen_type (rng : Range.t)\n ~rest:(tyrest : ('a, 'b) typ)\n ~receive:(tyrecv : ('a, 'b) typ)\n ~return:(tycod : ('a, 'b) typ) : ('a, 'b) typ =\n (rng, TypeApp(vid_frozen, [tyrest; tyrecv; tycod]))\n\n\nlet assertion_function_type : mono_type =\n let dr = Range.dummy \"assertion_function_type\" in\n let domty =\n {\n ordered = [(dr, BaseType(BinaryType)); (dr, BaseType(IntType))];\n mandatory = LabelAssoc.empty;\n optional = RowEmpty;\n }\n in\n (dr, FuncType(domty, (dr, BaseType(UnitType))))\n\n\nlet fresh_bound () =\n let bid = BoundID.fresh () in\n (Range.dummy \"primitives-bound\", TypeVar(Bound(bid)))\n\n\nlet dr = Range.dummy \"primitives\"\nlet u = (dr, BaseType(UnitType))\nlet b = (dr, BaseType(BoolType))\nlet i = (dr, BaseType(IntType))\nlet f = (dr, BaseType(FloatType))\nlet c = (dr, BaseType(CharType))\n\nlet ( @-> ) tydoms tycod =\n let domain =\n {\n ordered = tydoms;\n mandatory = LabelAssoc.empty;\n optional = RowEmpty;\n }\n in\n (dr, FuncType(domain, tycod))\n\nlet eff tydoms tyrcv ty0 =\n let domain =\n {\n ordered = tydoms;\n mandatory = LabelAssoc.empty;\n optional = RowEmpty;\n }\n in\n (dr, EffType(domain, Effect(tyrcv), ty0))\n\nlet pid tyrcv = (dr, PidType(Pid(tyrcv)))\n\nlet tylogic : poly_type = [b; b] @-> b\nlet tycomp : poly_type = [i; i] @-> b\nlet tyarith : poly_type = [i; i] @-> i\nlet tyarith_float : poly_type = [f; f] @-> f\n\nlet tyspawn : poly_type =\n let tyrecv = fresh_bound () in\n let tyrecvnew = fresh_bound () in\n eff [eff [] tyrecvnew u] tyrecv (pid tyrecvnew)\n\nlet tysend : poly_type =\n let tyrecv = fresh_bound () in\n let tyrecvremote = fresh_bound () in\n eff [pid tyrecvremote; tyrecvremote] tyrecv u\n\nlet tyreturn : poly_type =\n let tyrecv = fresh_bound () in\n let tyres = fresh_bound () in\n eff [tyres] tyrecv tyres\n\nlet tyself : poly_type =\n let tyrecv = fresh_bound () in\n eff [] tyrecv (pid tyrecv)\n\nlet typrintdebug : poly_type =\n let typaram = fresh_bound () in\n [typaram] @-> u\n\n\nlet tyformat : poly_type =\n let typaram = fresh_bound () in\n [format_type dr typaram; typaram] @-> list_type dr c\n\n\ntype source_definition = {\n identifier : string;\n typ : poly_type;\n}\n\ntype target_definition = {\n target_name : string;\n parameters : string list;\n code : string;\n}\n\ntype primitive_definition = {\n source : source_definition option;\n target : target_definition;\n}\n\n\nlet primitive_definitions = [\n {\n source = Some{\n identifier = \"spawn\";\n typ = tyspawn;\n };\n target = {\n target_name = \"spawn\";\n parameters = [\"F\"];\n code = \"erlang:spawn(F)\";\n };\n };\n {\n source = Some{\n identifier = \"send\";\n typ = tysend;\n };\n target = {\n target_name = \"send\";\n parameters = [\"Pid\"; \"Msg\"];\n code = Printf.sprintf \"Pid ! {%s, Msg}, ok\" Constants.message_tag_atom;\n };\n };\n {\n source = Some{\n identifier = \"return\";\n typ = tyreturn;\n };\n target = {\n target_name = \"return\";\n parameters = [\"X\"];\n code = \"X\";\n }\n };\n {\n source = Some{\n identifier = \"self\";\n typ = tyself;\n };\n target = {\n target_name = \"self\";\n parameters = [];\n code = \"erlang:self()\";\n };\n };\n {\n source = Some{\n identifier = \"print_debug\";\n typ = typrintdebug;\n };\n target = {\n target_name = \"print_debug\";\n parameters = [\"X\"];\n code = \"io:format(\\\"~p~n\\\", [X]), ok\";\n };\n };\n {\n source = Some{\n identifier = \"format\";\n typ = tyformat;\n };\n target = {\n target_name = \"format\";\n parameters = [\"{Fmt, _Arity}\"; \"Arg\"];\n code = \"Args = case Arg of ok -> []; _ -> tuple_to_list(Arg) end, lists:flatten(io_lib:format(Fmt, Args))\"\n };\n };\n {\n source = None;\n target = {\n target_name = decode_option_function;\n parameters = [\"Options\"; \"Key\"];\n code = \"maps:find(Key, Options)\";\n };\n };\n {\n source = None;\n target = {\n target_name = decode_option_function_with_default;\n parameters = [\"Options\"; \"Key\"; \"Thunk\"];\n code = \"case maps:find(Key, Options) of error -> Thunk(); {ok, Value} -> Value end\";\n };\n };\n]\n\n\nlet make_constructor_id (ctor : string) (atom_opt : string option) =\n match atom_opt with\n | None ->\n begin\n match ConstructorID.from_upper_camel_case ctor with\n | None -> assert false\n | Some(ctorid) -> ctorid\n end\n\n | Some(atom) ->\n begin\n match ConstructorID.from_snake_case atom with\n | None -> assert false\n | Some(ctorid) -> ctorid\n end\n\n\ntype constructor_definition = constructor_name * string option * poly_type list\n\n\nlet add_variant_types (vntdefs : (type_name * TypeID.t * BoundID.t list * constructor_definition list) list) (tyenv, gmap) =\n let tyenv : Typeenv.t =\n vntdefs |> List.fold_left (fun tyenv vntdef ->\n let (tynm, vid, bids, ctordefs) = vntdef in\n let pkd = TypeConv.kind_of_arity (List.length bids) in\n let (centryacc, ctormap) =\n ctordefs |> List.fold_left (fun (centryacc, ctormap) ctordef ->\n let (ctornm, atom_opt, paramtys) = ctordef in\n let ctorid = make_constructor_id ctornm atom_opt in\n let centry =\n {\n belongs = vid;\n constructor_id = ctorid;\n type_variables = bids;\n parameter_types = paramtys;\n }\n in\n let centryacc = Alist.extend centryacc (ctornm, centry) in\n let ctormap = ctormap |> ConstructorMap.add ctornm (ctorid, paramtys) in\n (centryacc, ctormap)\n ) (Alist.empty, ConstructorMap.empty)\n in\n let tentry =\n let (bids, tybody) = TypeConv.make_opaque_type_scheme bids vid in\n {\n type_scheme = (bids, tybody, Variant(ctormap));\n type_kind = pkd;\n type_doc = None;\n }\n in\n let tyenv = tyenv |> Typeenv.add_type tynm tentry in\n let tyenv =\n centryacc |> Alist.to_list |> List.fold_left (fun tyenv (ctornm, centry) ->\n tyenv |> Typeenv.add_constructor ctornm centry\n ) tyenv\n in\n tyenv\n ) tyenv\n in\n (tyenv, gmap)\n\n\nlet add_operators (ops : (string * poly_type * string) list) ((tyenv, nmap) : Typeenv.t * name_map) : Typeenv.t * name_map =\n let tyenv =\n ops |> List.fold_left (fun tyenv (x, pty, target) ->\n let name = OutputIdentifier.Operator(OutputIdentifier.operator target) in\n tyenv |> Typeenv.add_value x pty name\n ) tyenv\n in\n (tyenv, nmap)\n\n\nlet add_primitives (prims : primitive_definition list) ((tyenv, nmap) : Typeenv.t * name_map) : Typeenv.t * name_map =\n prims |> List.fold_left (fun (tyenv, nmap) primdef ->\n let (gmap, smap) = nmap in\n match primdef.source with\n | None ->\n (tyenv, nmap)\n\n | Some(srcdef) ->\n let targetdef = primdef.target in\n let gname =\n let arity = List.length targetdef.parameters in\n match\n OutputIdentifier.generate_global\n targetdef.target_name\n ~suffix:\"\"\n ~arity:arity\n ~has_option:false\n with\n | None -> assert false\n | Some(gname) -> gname\n in\n let tyenv = tyenv |> Typeenv.add_value srcdef.identifier srcdef.typ (OutputIdentifier.Global(gname)) in\n let gmap = gmap |> GlobalNameMap.add gname primitive_module_name in\n (tyenv, (gmap, smap))\n ) (tyenv, nmap)\n\n\nlet initial_environment =\n (Typeenv.empty, (GlobalNameMap.empty, SpaceNameMap.empty))\n |> add_variant_types [\n begin\n let bid = BoundID.fresh () in\n (\"option\", vid_option, [bid], [\n (\"None\", Some(\"error\"), []);\n (\"Some\", Some(\"ok\"), [(dr, TypeVar(Bound(bid)))]);\n ])\n end;\n begin\n let bid_ok = BoundID.fresh () in\n let bid_error = BoundID.fresh () in\n (\"result\", vid_result, [bid_ok; bid_error], [\n (\"Ok\", None, [(dr, TypeVar(Bound(bid_ok)))]);\n (\"Error\", None, [(dr, TypeVar(Bound(bid_error)))]);\n ])\n end;\n begin\n let bid = BoundID.fresh () in\n (\"list\", vid_list, [bid], [\n (* Here is no constructor definition\n because `ListNil` and `ListCons` are provided for type `untyped_ast`. *)\n ])\n end;\n begin\n let bid = BoundID.fresh () in\n (\"format\", vid_format, [bid], [\n ])\n end;\n begin\n let bid1 = BoundID.fresh () in\n let bid2 = BoundID.fresh () in\n let bid3 = BoundID.fresh () in\n (\"frozen\", vid_frozen, [bid1; bid2; bid3], [\n ])\n end;\n ]\n |> add_operators [\n (\"&&\", tylogic, \"and\");\n (\"||\", tylogic, \"or\" );\n (\"==\", tycomp , \"==\" );\n (\"<=\", tycomp , \"=<\" );\n (\">=\", tycomp , \">=\" );\n (\"<\" , tycomp , \"<\" );\n (\">\" , tycomp , \">\" );\n (\"*\" , tyarith, \"*\" );\n (\"/\" , tyarith, \"div\");\n (\"+\" , tyarith, \"+\" );\n (\"-\" , tyarith, \"-\" );\n (\"+.\", tyarith_float, \"+\");\n (\"-.\", tyarith_float, \"-\");\n (\"*.\", tyarith_float, \"*\");\n (\"/.\", tyarith_float, \"/\");\n ]\n |> add_primitives primitive_definitions\n" }, { "path": "src/primitives.mli", "content": "\nopen Syntax\nopen IntermediateSyntax\nopen Env\n\nval primitive_module_name : string\n\nval decode_option_function : string\n\nval decode_option_function_with_default : string\n\ntype source_definition = {\n identifier : string;\n typ : poly_type;\n}\n\ntype target_definition = {\n target_name : string;\n parameters : string list;\n code : string;\n}\n\ntype primitive_definition = {\n source : source_definition option;\n target : target_definition;\n}\n\nval primitive_definitions : primitive_definition list\n\nval option_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ\n\nval list_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ\n\nval format_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ\n\nval frozen_type : Range.t -> rest:('a, 'b) typ -> receive:('a, 'b) typ -> return:('a, 'b) typ -> ('a, 'b) typ\n\nval assertion_function_type : mono_type\n\nval initial_environment : Typeenv.t * name_map\n" }, { "path": "src/range.ml", "content": "\ntype real = {\n file_name : string;\n start_line : int;\n start_column : int;\n last_line : int;\n last_column : int;\n}\n\ntype t =\n | Dummy of string\n | Real of real\n\n\nlet pp ppf rng =\n match rng with\n | Dummy(s) ->\n Format.fprintf ppf \"(%s)\" s\n\n | Real(r) ->\n if r.start_line = r.last_line then\n Format.fprintf ppf \"file '%s', line %d, characters %d-%d\"\n r.file_name r.start_line r.start_column r.last_column\n else\n Format.fprintf ppf \"file '%s', line %d, character %d to line %d, character %d\"\n r.file_name r.start_line r.start_column r.last_line r.last_column\n\n\nlet from_positions (posS, posE) =\n let fname = posS.Lexing.pos_fname in\n let lnum = posS.Lexing.pos_lnum in\n let cnumS = posS.Lexing.pos_cnum - posS.Lexing.pos_bol in\n let cnumE = posE.Lexing.pos_cnum - posE.Lexing.pos_bol in\n Real{\n file_name = fname;\n start_line = lnum;\n start_column = cnumS;\n last_line = lnum;\n last_column = cnumE;\n }\n\n\nlet from_lexbuf lexbuf =\n let posS = Lexing.lexeme_start_p lexbuf in\n let posE = Lexing.lexeme_end_p lexbuf in\n from_positions (posS, posE)\n\n\nlet dummy s = Dummy(s)\n\n\nlet unite r1 r2 =\n match (r1, r2) with\n | (Real(_), Dummy(_)) -> r1\n | (Dummy(_), Real(_)) -> r2\n | (Dummy(s1), Dummy(s2)) -> Dummy(s1 ^ \"/\" ^ s2)\n\n | (Real(x1), Real(x2)) ->\n Real{\n file_name = x1.file_name;\n start_line = x1.start_line;\n start_column = x1.start_column;\n last_line = x2.last_line;\n last_column = x2.last_column;\n }\n\n\nlet get_file_name (rng : t) =\n match rng with\n | Dummy(s) -> Printf.sprintf \"(%s)\" s\n | Real(r) -> r.file_name\n\n\nlet get_start_line (rng : t) =\n match rng with\n | Dummy(_) -> 0\n | Real(r) -> r.start_line\n" }, { "path": "src/range.mli", "content": "\ntype t\n\nval pp : Format.formatter -> t -> unit\n\nval from_lexbuf : Lexing.lexbuf -> t\n\nval from_positions : Lexing.position * Lexing.position -> t\n\nval dummy : string -> t\n\nval unite : t -> t -> t\n\nval get_file_name : t -> string\n\nval get_start_line : t -> int\n" }, { "path": "src/sourceLoader.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Errors\n\nexception SyntaxError of syntax_error\n\n\ntype loaded_module = {\n source_path : absolute_path;\n module_identifier : module_name ranged;\n signature : untyped_signature option;\n module_content : untyped_module;\n dependencies : (module_name ranged) list;\n}\n\ntype loaded_package = {\n space_name : space_name;\n aux_modules : loaded_module list;\n main_module : loaded_module;\n test_modules : loaded_module list;\n}\n\n\nlet listup_sources_in_directory (dir : absolute_dir) : absolute_path list =\n let filenames = Core.Sys.ls_dir dir in\n filenames |> List.filter_map (fun filename ->\n if Core.String.is_suffix filename ~suffix:\".sest\" then\n Some(Core.Filename.concat dir filename)\n else\n None\n )\n\n\nlet read_source (abspath_in : absolute_path) : loaded_module =\n Logging.begin_to_parse abspath_in;\n let inc = open_in abspath_in in\n let lexbuf = Lexing.from_channel inc in\n let fname = Filename.basename abspath_in in\n let res =\n let open ResultMonad in\n ParserInterface.process ~fname:fname lexbuf >>= fun (deps, modident, utsigopt, utmod) ->\n return {\n source_path = abspath_in;\n module_identifier = modident;\n signature = utsigopt;\n module_content = utmod;\n dependencies = deps;\n }\n in\n close_in inc;\n match res with\n | Ok(baremod) -> baremod\n | Error(err) -> raise (SyntaxError(err))\n\n\nlet resolve_dependency_scheme (nmmap_known : absolute_path ModuleNameMap.t) (baremods : loaded_module list) : loaded_module list * absolute_path ModuleNameMap.t =\n (* First, adds the vertices to the graph for solving dependency. *)\n let (graph, nmmap) =\n baremods |> List.fold_left (fun (graph, nmmap) baremod ->\n let (_, modnm) = baremod.module_identifier in\n let abspath = baremod.source_path in\n begin\n match nmmap |> ModuleNameMap.find_opt modnm with\n | Some((_, baremod0)) ->\n let abspath0 = baremod0.source_path in\n raise (ConfigError(MultipleModuleOfTheSameName(modnm, abspath0, abspath)))\n\n | None ->\n begin\n match nmmap_known |> ModuleNameMap.find_opt modnm with\n | Some(abspath0) ->\n raise (ConfigError(MultipleModuleOfTheSameName(modnm, abspath0, abspath)))\n\n | None ->\n let (graph, vertex) = graph |> FileDependencyGraph.add_vertex modnm in\n let nmmap = nmmap |> ModuleNameMap.add modnm (vertex, baremod) in\n (graph, nmmap)\n end\n end\n ) (FileDependencyGraph.empty, ModuleNameMap.empty)\n in\n\n (* Second, adds the dependency edges to the graph. *)\n let graph =\n ModuleNameMap.fold (fun modnm (vertex, baremod) graph ->\n let deps = baremod.dependencies in\n deps |> List.fold_left (fun graph (rng, modnm_dep) ->\n match nmmap |> ModuleNameMap.find_opt modnm_dep with\n | None ->\n if nmmap_known |> ModuleNameMap.mem modnm_dep then\n (* If the depended one has already been resolved\n (i.e. if the dependency is on a source file from a test file) *)\n graph\n else\n raise (ConfigError(ModuleNotFound(rng, modnm_dep)))\n\n | Some((vertex_dep, baremod_dep)) ->\n graph |> FileDependencyGraph.add_edge ~depending:vertex ~depended:vertex_dep\n ) graph\n ) nmmap graph\n in\n\n (* Finally, resolves dependency among Auxs. *)\n let resolved_auxs =\n match FileDependencyGraph.topological_sort graph with\n | Error(cycle) ->\n raise (ConfigError(CyclicFileDependencyFound(cycle)))\n\n | Ok(sorted_paths) ->\n sorted_paths |> List.map (fun modnm ->\n match nmmap |> ModuleNameMap.find_opt modnm with\n | None -> assert false\n | Some((_, baremod)) -> baremod\n )\n in\n let nmmap_added =\n ModuleNameMap.fold (fun modnm (_, baremod) nmmap_added ->\n nmmap_added |> ModuleNameMap.add modnm baremod.source_path\n ) nmmap ModuleNameMap.empty\n in\n (resolved_auxs, nmmap_added)\n\n\nlet resolve_dependency_among_auxiliary ~aux:(bareauxs : loaded_module list) : loaded_module list * absolute_path ModuleNameMap.t =\n resolve_dependency_scheme ModuleNameMap.empty bareauxs\n\n\nlet check_dependency_of_main_on_auxiliary (nmmap_aux : absolute_path ModuleNameMap.t) ~main:(baremain : loaded_module) : unit =\n baremain.dependencies |> List.iter (fun (rng, modnm_dep) ->\n if nmmap_aux |> ModuleNameMap.mem modnm_dep then\n ()\n else\n raise (ConfigError(ModuleNotFound(rng, modnm_dep)))\n )\n\n\nlet resolve_dependency_among_test (nmmap_src : absolute_path ModuleNameMap.t) ~test:(baretests : loaded_module list) : loaded_module list =\n let (resolved_tests, _) = resolve_dependency_scheme nmmap_src baretests in\n resolved_tests\n\n\nlet resolve_dependency ~aux:(bareauxs : loaded_module list) ~main:(baremain : loaded_module) ~test:(baretests : loaded_module list) : loaded_module list * loaded_module list =\n let (resolved_auxs, nmmap_aux) = resolve_dependency_among_auxiliary ~aux:bareauxs in\n check_dependency_of_main_on_auxiliary nmmap_aux ~main:baremain;\n let nmmap_src =\n let (_, modnm_main) = baremain.module_identifier in\n let abspath_main = baremain.source_path in\n nmmap_aux |> ModuleNameMap.add modnm_main abspath_main\n in\n let resolved_tests = resolve_dependency_among_test nmmap_src ~test:baretests in\n (resolved_auxs, resolved_tests)\n\n\nlet single (abspath_in : absolute_path) : loaded_module =\n let baremod = read_source abspath_in in\n let deps = baremod.dependencies in\n if List.length deps > 0 then\n raise (ConfigError(CannotSpecifyDependency))\n else\n baremod\n\n\nlet separate_main_module (config : ConfigLoader.config) (baresrcs : loaded_module list) : loaded_module * loaded_module list =\n let main_module_name = config.ConfigLoader.main_module_name in\n let (baremains, baresubs) =\n baresrcs |> List.partition (fun baremod ->\n let (_, modnm) = baremod.module_identifier in\n String.equal modnm main_module_name\n )\n in\n match baremains with\n | [] ->\n let pkgname = config.ConfigLoader.package_name in\n raise (ConfigError(MainModuleNotFound(pkgname, main_module_name)))\n\n | baremain1 :: baremain2 :: _ ->\n let abspath1 = baremain1.source_path in\n let abspath2 = baremain2.source_path in\n raise (ConfigError(MultipleModuleOfTheSameName(main_module_name, abspath1, abspath2)))\n\n | [ baremain ] ->\n (baremain, baresubs)\n\n\nlet main ~(requires_tests : bool) (config : ConfigLoader.config) : loaded_package =\n let srcdirs =\n let srcreldirs = config.ConfigLoader.source_directories in\n let confdir = config.ConfigLoader.config_directory in\n srcreldirs |> List.map (function RelativeDir(reldir) -> Core.Filename.concat confdir reldir)\n in\n let testdirs =\n let testreldirs = config.ConfigLoader.test_directories in\n let confdir = config.ConfigLoader.config_directory in\n testreldirs |> List.map (function RelativeDir(reldir) -> Core.Filename.concat confdir reldir)\n in\n let abspaths_src = srcdirs |> List.map listup_sources_in_directory |> List.concat in\n let abspaths_test = testdirs |> List.map listup_sources_in_directory |> List.concat in\n let baresrcs = abspaths_src |> List.map read_source in\n let baretests = if requires_tests then abspaths_test |> List.map read_source else [] in\n let (baremain, bareauxs) = separate_main_module config baresrcs in\n let (resolved_auxs, resolved_tests) = resolve_dependency ~aux:bareauxs ~main:baremain ~test:baretests in\n let spkgname =\n let pkgname = config.package_name in\n match OutputIdentifier.space_of_package_name pkgname with\n | Some(spkgname) -> spkgname\n | None -> raise (ConfigError(InvalidPackageName(pkgname)))\n in\n {\n space_name = spkgname;\n aux_modules = resolved_auxs;\n main_module = baremain;\n test_modules = resolved_tests;\n }\n" }, { "path": "src/sourceLoader.mli", "content": "\nopen MyUtil\nopen Syntax\nopen Errors\n\nexception SyntaxError of syntax_error\n\ntype loaded_module = {\n source_path : absolute_path;\n module_identifier : module_name ranged;\n signature : untyped_signature option;\n module_content : untyped_module;\n dependencies : (module_name ranged) list;\n}\n\ntype loaded_package = {\n space_name : space_name;\n aux_modules : loaded_module list;\n main_module : loaded_module;\n test_modules : loaded_module list;\n}\n\nval single : absolute_path -> loaded_module\n(** Receiving an absolute path [p] to a single source file,\n [single p] loads the source file.\n May raise [ConfigError(_)] or [SyntaxError(_)].\n*)\n\nval main : requires_tests:bool -> ConfigLoader.config -> loaded_package\n(** Receiving a package configuration value [config],\n [main config] loads all the source files constituting the package into modules,\n and returns [pkg] where:\n {ul\n {- [pkg.space_name] is the space name corresponding to the name of the package;}\n {- [pkg.submodules] is the list of loaded submodules\n sorted by a topological order that reflects the dependency between modules; and}\n {- [pkg.main_module] is the main module of the package.}}\n May raise [ConfigError(_)] or [SyntaxError(_)]. *)\n" }, { "path": "src/syntax.ml", "content": "\nopen MyUtil\n\nmodule TupleList = List1\n\ntype module_name_output_spec =\n | SingleSnake\n | DottedCamels\n\ntype output_spec = {\n module_name_output_spec : module_name_output_spec;\n}\n\ntype package_name = string\n\nmodule ExternalMap = Map.Make(String)\n\ntype external_map = absolute_dir ExternalMap.t\n\ntype ('a, 'b) pure_or_effectful =\n | Pure of 'a\n | Effectful of 'b\n[@@deriving show { with_path = false; } ]\n\ntype 'a cycle =\n | Loop of 'a\n | Cycle of 'a List2.t\n\ntype 'a ranged = Range.t * 'a\n\nlet pp_ranged ppsub ppf (_, x) =\n Format.fprintf ppf \"%a\" ppsub x\n\ntype identifier = string\n\ntype type_name = string\n[@@deriving show { with_path = false; } ]\n\ntype kind_name = string\n[@@deriving show { with_path = false; } ]\n\ntype constructor_name = string\n[@@deriving show { with_path = false; } ]\n\ntype type_variable_name = string\n[@@deriving show { with_path = false; } ]\n\ntype row_variable_name = string\n[@@deriving show { with_path = false; } ]\n\ntype module_name = string\n[@@deriving show { with_path = false; } ]\n\ntype signature_name = string\n[@@deriving show { with_path = false; } ]\n\ntype label = string\n[@@deriving show { with_path = false; } ]\n\nmodule LabelAssoc : (sig\n include Map.S\n val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit\nend with type key = string) = struct\n module Impl = Map.Make(String)\n include Impl\n\n let pp ppsub ppf labmap =\n labmap |> Impl.iter (fun label v ->\n Format.fprintf ppf \"%s -> %a; \" label ppsub v\n )\nend\n\nmodule LabelSet : (sig\n include Set.S\n val pp : Format.formatter -> t -> unit\nend with type elt = label) = struct\n module Impl = Set.Make(String)\n include Impl\n\n let pp ppf labset =\n labset |> Impl.iter (fun label ->\n Format.fprintf ppf \"%s,@ \" label\n )\nend\n\n\nlet pp_identifier ppf s =\n Format.fprintf ppf \"\\\"%s\\\"\" s\n\n\nlet pp_uchar ppf uchar =\n Format.fprintf ppf \"U+%X\" (Uchar.to_int uchar)\n\n\ntype module_name_chain =\n module_name ranged * (module_name ranged) list\n[@@deriving show { with_path = false; } ]\n\ntype base_type =\n | IntType\n | FloatType\n | BoolType\n | UnitType\n | BinaryType\n | CharType\n[@@deriving show { with_path = false; } ]\n\n(* `format_*` are the types for representing format string literals.\n For the detail of format strings, see:\n http://erlang.org/doc/man/io.html *)\ntype format_hole =\n | HoleC (* Characters. *)\n | HoleF (* `[-]ddd.ddd` for floating-point numbers. *)\n | HoleE (* `[-]d.ddde+-ddd` for floating-point numbers. *)\n | HoleG (* Same as `HoleF` for `[0.1, 10000)` and same as `HoleE` otherwise. *)\n | HoleS (* Strings. *)\n | HoleP\n | HoleW\n[@@deriving show {with_path = false; } ]\n\ntype format_control = {\n field_width : int option;\n precision : int option;\n padding : char option;\n}\n[@@deriving show {with_path = false; } ]\n\ntype format_element =\n | FormatTilde\n | FormatBreak\n | FormatDQuote\n | FormatConst of string\n | FormatHole of format_hole * format_control\n[@@deriving show {with_path = false; } ]\n\ntype base_constant =\n | Unit\n | Bool of bool\n | Int of int\n | Float of float\n | BinaryByString of string\n | BinaryByInts of int list\n | String of string\n | Char of Uchar.t\n [@printer (fun ppf uchar -> Format.fprintf ppf \"Char(%a)\" pp_uchar uchar)]\n | FormatString of format_element list\n[@@deriving show { with_path = false; } ]\n\ntype manual_kind =\n manual_kind_main ranged\n\nand manual_kind_main =\n | MKind of manual_base_kind list * manual_base_kind\n\nand manual_base_kind =\n manual_base_kind_main ranged\n\nand manual_base_kind_main =\n | MKindName of kind_name\n\nand manual_type = manual_type_main ranged\n\nand manual_type_main =\n | MTypeName of type_name * manual_type list\n | MFuncType of manual_domain_type * manual_type\n | MProductType of manual_type TupleList.t\n | MRecordType of manual_row\n | MEffType of manual_domain_type * manual_type * manual_type\n | MTypeVar of type_variable_name\n | MModProjType of untyped_module * type_name ranged * manual_type list\n | MPackType of untyped_signature\n\nand manual_domain_type =\n manual_type list * labeled_manual_type list * manual_row\n\nand manual_row =\n | MRow of (label ranged * manual_type) list * (Range.t * row_variable_name) option\n\nand binder = untyped_pattern * manual_type option\n\nand constructor_branch =\n | ConstructorBranch of attribute list * constructor_name ranged * manual_type list\n\nand synonym_or_variant =\n | BindSynonym of manual_type\n | BindVariant of constructor_branch list\n\nand untyped_ast =\n untyped_ast_main ranged\n\nand untyped_ast_main =\n | BaseConst of base_constant\n | Var of (module_name ranged) list * identifier ranged\n | Lambda of untyped_parameters * untyped_ast\n | LambdaEff of untyped_parameters * untyped_computation_ast\n | Apply of untyped_ast * untyped_arguments\n | If of untyped_ast * untyped_ast * untyped_ast\n | LetIn of rec_or_nonrec * untyped_ast\n | LetPatIn of untyped_pattern * untyped_ast * untyped_ast\n | Tuple of untyped_ast TupleList.t\n | ListNil\n | ListCons of untyped_ast * untyped_ast\n | Case of untyped_ast * untyped_case_branch list\n | Constructor of (module_name ranged) list * constructor_name * untyped_ast list\n | BinaryByList of (int ranged) list\n | Record of labeled_untyped_ast list\n | RecordAccess of untyped_ast * label ranged\n | RecordUpdate of untyped_ast * label ranged * untyped_ast\n | Freeze of Range.t * frozen_fun * untyped_ast list * Range.t list\n | FreezeUpdate of untyped_ast * untyped_ast list * Range.t list\n | Pack of module_name_chain * untyped_signature\n | Assert of untyped_ast\n\nand untyped_parameters =\n binder list * labeled_binder list * labeled_optional_binder list\n\nand untyped_computation_ast =\n untyped_computation_ast_main ranged\n\nand untyped_computation_ast_main =\n | CompDo of binder * untyped_computation_ast * untyped_computation_ast\n | CompReceive of untyped_receive_branch list * (untyped_ast * untyped_computation_ast) option\n | CompLetIn of rec_or_nonrec * untyped_computation_ast\n | CompLetPatIn of untyped_pattern * untyped_ast * untyped_computation_ast\n | CompIf of untyped_ast * untyped_computation_ast * untyped_computation_ast\n | CompCase of untyped_ast * untyped_computation_case_branch list\n | CompApply of untyped_ast * untyped_arguments\n\nand untyped_arguments =\n untyped_ast list * labeled_untyped_ast list * labeled_untyped_ast list\n\nand frozen_fun =\n | FrozenModFun of module_name_chain * identifier ranged\n | FrozenFun of identifier ranged\n\nand internal_or_external =\n | Internal of rec_or_nonrec\n | External of external_binding\n\nand rec_or_nonrec =\n | NonRec of untyped_let_binding\n | Rec of untyped_let_binding list\n\nand type_variable_binder =\n type_variable_name ranged * manual_base_kind option\n\nand external_binding = {\n ext_identifier : identifier ranged;\n ext_type_params : type_variable_binder list;\n ext_row_params : ((row_variable_name ranged) * (label ranged) list) list;\n ext_type_annot : manual_type;\n ext_arity : int;\n ext_has_option : bool;\n ext_code : string;\n}\n\nand untyped_let_binding = {\n vb_identifier : identifier ranged;\n vb_forall : type_variable_binder list;\n vb_forall_row : (row_variable_name ranged * (label ranged) list) list;\n vb_parameters : binder list;\n vb_mandatories : labeled_binder list;\n vb_optionals : labeled_optional_binder list;\n vb_return : (pure_return, effectful_return) pure_or_effectful;\n}\n\nand pure_return =\n manual_type option * untyped_ast\n\nand effectful_return =\n (manual_type * manual_type) option * untyped_computation_ast\n\nand untyped_receive_branch =\n | ReceiveBranch of untyped_pattern * untyped_computation_ast\n\nand untyped_case_branch =\n | CaseBranch of untyped_pattern * untyped_ast\n\nand untyped_computation_case_branch =\n | CompCaseBranch of untyped_pattern * untyped_computation_ast\n\nand untyped_pattern =\n untyped_pattern_main ranged\n[@printer (fun ppf (_, utpatmain) -> pp_untyped_pattern_main ppf utpatmain)]\n\nand untyped_pattern_main =\n | PUnit\n | PBool of bool\n | PInt of int\n | PBinary of string\n | PChar of Uchar.t\n [@printer (fun ppf uchar -> Format.fprintf ppf \"PChar(%a)\" pp_uchar uchar) ]\n | PVar of identifier\n | PWildCard\n | PListNil\n | PListCons of untyped_pattern * untyped_pattern\n | PTuple of untyped_pattern TupleList.t\n | PConstructor of (module_name ranged) list * constructor_name * untyped_pattern list\n[@@deriving show { with_path = false; } ]\n\nand untyped_module =\n untyped_module_main ranged\n\nand untyped_module_main =\n | ModVar of module_name\n | ModBinds of attribute list * module_name_chain list * untyped_binding list\n | ModProjMod of untyped_module * module_name ranged\n | ModFunctor of module_name ranged * untyped_signature * untyped_module\n | ModApply of module_name_chain * module_name_chain\n | ModCoerce of module_name ranged * untyped_signature\n\nand untyped_binding =\n untyped_binding_main ranged\n\nand untyped_binding_main =\n | BindVal of attribute list * internal_or_external\n | BindType of type_binding list\n | BindModule of module_name ranged * untyped_signature option * untyped_module\n | BindSig of signature_name ranged * untyped_signature\n | BindInclude of untyped_module\n\nand type_binding =\n type_name ranged * type_variable_binder list * synonym_or_variant\n\nand untyped_signature =\n untyped_signature_main ranged\n\nand untyped_signature_main =\n | SigVar of signature_name\n | SigPath of untyped_module * signature_name ranged\n | SigDecls of module_name_chain list * untyped_declaration list\n | SigFunctor of module_name ranged * untyped_signature * untyped_signature\n | SigWith of untyped_signature * (module_name ranged) list * type_binding list\n\nand untyped_declaration =\n untyped_declaration_main ranged\n\nand untyped_declaration_main =\n | DeclVal of identifier ranged * type_variable_binder list * (row_variable_name ranged * (label ranged) list) list * manual_type * attribute list\n | DeclTypeOpaque of type_name ranged * manual_kind option * attribute list\n | DeclModule of module_name ranged * untyped_signature * attribute list\n | DeclSig of signature_name ranged * untyped_signature * attribute list\n | DeclInclude of untyped_signature\n\nand labeled_binder =\n label ranged * binder\n\nand labeled_optional_binder =\n labeled_binder * untyped_ast option\n\nand labeled_untyped_ast =\n label ranged * untyped_ast\n\nand labeled_manual_type =\n label ranged * manual_type\n[@@deriving show { with_path = false; } ]\n\nand attribute =\n Attribute of (string * untyped_ast option) ranged\n\ntype attribute_warning = {\n position : Range.t;\n tag : string;\n message : string;\n}\n\nmodule FreeRowID = struct\n include FreeID\nend\n\nmodule BoundRowID = struct\n include BoundID\nend\n\nmodule MustBeBoundRowID = struct\n include MustBeBoundID\nend\n\n\nmodule BoundBothID = struct\n\n type t =\n | Type of BoundID.t\n | Row of BoundRowID.t\n\n let hash = function\n | Type(bid) -> BoundID.hash bid\n | Row(brid) -> BoundRowID.hash brid\n\n let compare x1 x2 =\n match (x1, x2) with\n | (Type(bid1), Type(bid2)) -> BoundID.compare bid1 bid2\n | (Row(brid1), Row(brid2)) -> BoundRowID.compare brid1 brid2\n | (Type(_), Row(_)) -> 1\n | (Row(_), Type(_)) -> -1\n\n let equal x1 x2 =\n compare x1 x2 = 0\n(*\n let pp ppf = function\n | Type(bid) -> BoundID.pp_raw ppf bid\n | Row(brid) -> BoundRowID.pp_raw ppf brid\n*)\nend\n\n\nmodule FreeIDHashTable = Hashtbl.Make(FreeID)\n\nmodule FreeRowIDHashTable = Hashtbl.Make(FreeRowID)\n\nmodule BoundIDHashTable = Hashtbl.Make(BoundID)\n\nmodule BoundRowIDHashTable = Hashtbl.Make(BoundRowID)\n\nmodule BoundIDMap = Map.Make(BoundID)\n\ntype space_name = OutputIdentifier.space\n[@@deriving show { with_path = false; } ]\n\ntype local_name = OutputIdentifier.local\n[@@deriving show { with_path = false; } ]\n\ntype global_name = OutputIdentifier.global\n[@@deriving show { with_path = false; } ]\n\ntype operator_name = OutputIdentifier.operator\n[@@deriving show { with_path = false; } ]\n\ntype name = OutputIdentifier.t\n[@@deriving show { with_path = false; } ]\n\nmodule ConstructorMap = Map.Make(String)\n\nmodule TypeParameterAssoc = AssocList.Make(String)\n\ntype type_parameter_assoc = MustBeBoundID.t TypeParameterAssoc.t\n\nmodule TypeParameterMap = Map.Make(String)\n\ntype local_type_parameter_map = MustBeBoundID.t TypeParameterMap.t\n\nmodule RowParameterMap = Map.Make(String)\n\n\nmodule OpaqueIDMap = Map.Make(TypeID)\n\n\nlet stringify_opaque_id_quantifier qt =\n OpaqueIDMap.fold (fun oid pkd acc ->\n Alist.extend acc (Format.asprintf \"%a\" (TypeID.pp ~seen_from:Address.root) oid)\n ) qt Alist.empty |> Alist.to_list |> List.map (fun s -> \" \" ^ s) |> String.concat \",\"\n\n\nlet pp_opaque_id_quantifier ppf qt =\n Format.fprintf ppf \"%s\" (stringify_opaque_id_quantifier qt)\n\n\nmodule OpaqueIDHashTable = Hashtbl.Make(TypeID)\n\nmodule ValNameMap = Map.Make(String)\n\nmodule TypeNameMap = Map.Make(String)\n\nmodule ModuleNameMap = Map.Make(String)\n\nmodule SignatureNameMap = Map.Make(String)\n" }, { "path": "src/typeConv.ml", "content": "\nopen MyUtil\nopen Syntax\nopen Env\n\n\nlet collect_ids_scheme (fidht : unit FreeIDHashTable.t) (fridht : LabelSet.t FreeRowIDHashTable.t) (bidht : unit BoundIDHashTable.t) (bridht : LabelSet.t BoundRowIDHashTable.t) =\n let aux_free_id (fid : FreeID.t) =\n if FreeIDHashTable.mem fidht fid then\n ()\n else\n FreeIDHashTable.add fidht fid ()\n in\n let aux_free_row_id (frid : FreeRowID.t) =\n if FreeRowIDHashTable.mem fridht frid then\n ()\n else\n let labset = KindStore.get_free_row frid in\n FreeRowIDHashTable.add fridht frid labset\n in\n let aux_bound_id (bid : BoundID.t) =\n if BoundIDHashTable.mem bidht bid then\n ()\n else\n BoundIDHashTable.add bidht bid ()\n in\n let aux_bound_row_id (brid : BoundRowID.t) =\n if BoundRowIDHashTable.mem bridht brid then\n ()\n else\n let labset = KindStore.get_bound_row brid in\n BoundRowIDHashTable.add bridht brid labset\n in\n let rec aux_mono ((_, tymain) : mono_type) : unit =\n match tymain with\n | BaseType(_) ->\n ()\n\n | TypeVar(Updatable{contents = Link(ty)}) ->\n aux_mono ty\n\n | TypeVar(Updatable{contents = Free(fid)}) ->\n aux_free_id fid\n\n | TypeVar(MustBeBound(mbbid)) ->\n ()\n\n | FuncType(domain, tycod) ->\n aux_mono_domain domain;\n aux_mono tycod\n\n | EffType(domain, eff, ty0) ->\n aux_mono_domain domain;\n aux_mono_effect eff;\n aux_mono ty0\n\n | PidType(pidty) ->\n aux_mono_pid_type pidty\n\n | ProductType(tys) ->\n tys |> TupleList.to_list |> List.iter aux_mono\n\n | RecordType(row) ->\n aux_mono_row row\n\n | TypeApp(tyid, tyargs) ->\n tyargs |> List.iter aux_mono\n\n | PackType(_absmodsig) ->\n () (* TODO: traverse signatures *)\n\n and aux_poly ((_, ptymain) : poly_type) : unit =\n match ptymain with\n | BaseType(_) ->\n ()\n\n | TypeVar(ptv) ->\n begin\n match ptv with\n | Mono(Updatable{contents = Link(ty)}) -> aux_mono ty\n | Mono(Updatable{contents = Free(fid)}) -> aux_free_id fid\n | Mono(MustBeBound(_)) -> ()\n | Bound(bid) -> aux_bound_id bid\n end\n\n | FuncType(pdomain, ptycod) ->\n aux_poly_domain pdomain;\n aux_poly ptycod\n\n | EffType(pdomain, peff, pty0) ->\n aux_poly_domain pdomain;\n aux_poly_effect peff;\n aux_poly pty0\n\n | PidType(ppidty) ->\n aux_poly_pid_type ppidty\n\n | ProductType(ptys) ->\n ptys |> TupleList.to_list |> List.iter aux_poly\n\n | RecordType(prow) ->\n aux_poly_row prow\n\n | TypeApp(tyid, ptyargs) ->\n ptyargs |> List.iter aux_poly\n\n | PackType(_absmodsig) ->\n () (* TODO: traverse signatures *)\n\n and aux_mono_label_assoc (labmap : mono_type LabelAssoc.t) : unit =\n LabelAssoc.iter (fun _ ty -> aux_mono ty) labmap\n\n and aux_poly_label_assoc (plabmap : poly_type LabelAssoc.t) : unit =\n LabelAssoc.iter (fun _ pty -> aux_poly pty) plabmap\n\n and aux_mono_domain (domain : mono_domain_type) : unit =\n domain.ordered |> List.iter aux_mono;\n aux_mono_label_assoc domain.mandatory;\n aux_mono_row domain.optional\n\n and aux_poly_domain (pdomain : poly_domain_type) : unit =\n pdomain.ordered |> List.iter aux_poly;\n aux_poly_label_assoc pdomain.mandatory;\n aux_poly_row pdomain.optional\n\n and aux_mono_effect (Effect(ty)) =\n aux_mono ty\n\n and aux_poly_effect (Effect(pty)) =\n aux_poly pty\n\n and aux_mono_pid_type (Pid(ty)) =\n aux_mono ty\n\n and aux_poly_pid_type (Pid(pty)) =\n aux_poly pty\n\n and aux_mono_row : mono_row -> unit = function\n | RowCons(_rlabel, ty, row) -> aux_mono ty; aux_mono_row row\n | RowVar(UpdatableRow{contents = LinkRow(row)}) -> aux_mono_row row\n | RowVar(UpdatableRow{contents = FreeRow(frid)}) -> aux_free_row_id frid\n | RowVar(MustBeBoundRow(mbbrid)) -> ()\n | RowEmpty -> ()\n\n and aux_poly_row : poly_row -> unit = function\n | RowCons(_rlabel, pty, prow) ->\n aux_poly pty;\n aux_poly_row prow\n\n | RowVar(MonoRow(prv)) ->\n begin\n match prv with\n | UpdatableRow{contents = LinkRow(row)} -> aux_mono_row row\n | UpdatableRow{contents = FreeRow(frid)} -> aux_free_row_id frid\n | MustBeBoundRow(_) -> ()\n end\n\n | RowVar(BoundRow(brid)) ->\n aux_bound_row_id brid\n\n | RowEmpty ->\n ()\n in\n (aux_mono, aux_poly)\n\n\nlet collect_ids_mono (ty : mono_type) (dispmap : DisplayMap.t) : DisplayMap.t =\n let fidht = DisplayMap.make_free_id_hash_set dispmap in\n let fridht = DisplayMap.make_free_row_id_hash_set dispmap in\n let bidht = DisplayMap.make_bound_id_hash_set dispmap in\n let bridht = DisplayMap.make_bound_row_id_hash_set dispmap in\n let (aux_mono, _) = collect_ids_scheme fidht fridht bidht bridht in\n aux_mono ty;\n let dispmap =\n FreeIDHashTable.fold (fun fid () dispmap ->\n dispmap |> DisplayMap.add_free_id fid\n ) fidht dispmap\n in\n let dispmap =\n FreeRowIDHashTable.fold (fun frid labset dispmap ->\n dispmap |> DisplayMap.add_free_row_id frid labset\n ) fridht dispmap\n in\n dispmap\n\n\nlet collect_ids_poly (pty : poly_type) (dispmap : DisplayMap.t) : DisplayMap.t =\n let fidht = DisplayMap.make_free_id_hash_set dispmap in\n let fridht = DisplayMap.make_free_row_id_hash_set dispmap in\n let bidht = DisplayMap.make_bound_id_hash_set dispmap in\n let bridht = DisplayMap.make_bound_row_id_hash_set dispmap in\n let (_, aux_poly) = collect_ids_scheme fidht fridht bidht bridht in\n aux_poly pty;\n let dispmap =\n FreeIDHashTable.fold (fun fid () dispmap ->\n dispmap |> DisplayMap.add_free_id fid\n ) fidht dispmap\n in\n let dispmap =\n FreeRowIDHashTable.fold (fun frid labset dispmap ->\n dispmap |> DisplayMap.add_free_row_id frid labset\n ) fridht dispmap\n in\n let dispmap =\n BoundIDHashTable.fold (fun bid () dispmap ->\n dispmap |> DisplayMap.add_bound_id bid\n ) bidht dispmap\n in\n let dispmap =\n BoundRowIDHashTable.fold (fun brid labset dispmap ->\n dispmap |> DisplayMap.add_bound_row_id brid labset\n ) bridht dispmap\n in\n dispmap\n\n\nlet normalize_row_general : ('a, 'b) row -> ('a, 'b) normalized_row =\nfun prow ->\n let rec aux plabmap = function\n | RowCons((_, label), pty, prow) -> aux (plabmap |> LabelAssoc.add label pty) prow\n | RowVar(prv) -> NormalizedRow(plabmap, Some(prv))\n | RowEmpty -> NormalizedRow(plabmap, None)\n in\n aux LabelAssoc.empty prow\n\n\n(* Normalizes the polymorphic row `prow`. Here, `MonoRow` is not supposed to occur in `prow`. *)\nlet normalize_poly_row (prow : poly_row) : normalized_poly_row =\n normalize_row_general prow\n\n\nlet normalize_mono_row (row : mono_row) : normalized_mono_row =\n let rec aux labmap = function\n | RowCons((_, label), ty, row) -> aux (labmap |> LabelAssoc.add label ty) row\n | RowVar(UpdatableRow{contents = LinkRow(row)}) -> aux labmap row\n | RowVar(rv) -> NormalizedRow(labmap, Some(rv))\n | RowEmpty -> NormalizedRow(labmap, None)\n in\n aux LabelAssoc.empty row\n\n\n(* Arguments:\n - `levpred`:\n Given a level of free/must-be-bound ID,\n this predicate returns whether it should be bound or not. *)\nlet lift_scheme (rngf : Range.t -> Range.t) (levpred : int -> bool) (ty : mono_type) : poly_type =\n\n let fidht = FreeIDHashTable.create 32 in\n let fridht = FreeRowIDHashTable.create 32 in\n\n let rec intern (fid : FreeID.t) : BoundID.t =\n match FreeIDHashTable.find_opt fidht fid with\n | Some(bid) ->\n bid\n\n | None ->\n let bid = BoundID.fresh () in\n FreeIDHashTable.add fidht fid bid;\n bid\n\n and intern_row (frid : FreeRowID.t) : BoundRowID.t =\n match FreeRowIDHashTable.find_opt fridht frid with\n | Some(brid) ->\n brid\n\n | None ->\n let brid = BoundRowID.fresh () in\n FreeRowIDHashTable.add fridht frid brid;\n let labset = KindStore.get_free_row frid in\n KindStore.register_bound_row brid labset;\n brid\n\n and aux_label_assoc (labmap : mono_type LabelAssoc.t) : poly_type LabelAssoc.t =\n LabelAssoc.fold (fun label ty plabmap ->\n let pty = aux ty in\n plabmap |> LabelAssoc.add label pty\n ) labmap LabelAssoc.empty\n\n and aux_domain (domain : mono_domain_type) : poly_domain_type =\n let {ordered = tydoms; mandatory = mndlabmap; optional = optrow} = domain in\n let ptydoms = tydoms |> List.map aux in\n let pmndlabmap = aux_label_assoc mndlabmap in\n let poptrow = aux_row optrow in\n {ordered = ptydoms; mandatory = pmndlabmap; optional = poptrow}\n\n and aux ((rng, tymain) : mono_type) : poly_type =\n match tymain with\n | BaseType(bty) ->\n let pty = (rngf rng, BaseType(bty)) in\n pty\n\n | TypeVar(Updatable{contents = Link(ty)}) ->\n aux ty\n\n | TypeVar(Updatable{contents = Free(fid)} as mtv) ->\n let ptv =\n if levpred (FreeID.get_level fid) then\n let bid = intern fid in\n Bound(bid)\n else\n Mono(mtv)\n in\n (rngf rng, TypeVar(ptv))\n\n | TypeVar(MustBeBound(mbbid) as mtv) ->\n let ptv =\n if levpred (MustBeBoundID.get_level mbbid) then\n let bid = MustBeBoundID.to_bound mbbid in\n Bound(bid)\n else\n Mono(mtv)\n in\n (rngf rng, TypeVar(ptv))\n\n | FuncType(domain, tycod) ->\n let pdomain = aux_domain domain in\n let ptycod = aux tycod in\n (rngf rng, FuncType(pdomain, ptycod))\n\n | EffType(domain, eff, ty0) ->\n let pdomain = aux_domain domain in\n let peff = aux_effect eff in\n let pty0 = aux ty0 in\n (rngf rng, EffType(pdomain, peff, pty0))\n\n | PidType(pidty) ->\n let ppidty = aux_pid_type pidty in\n (rngf rng, PidType(ppidty))\n\n | ProductType(tys) ->\n let ptys = tys |> TupleList.map aux in\n (rngf rng, ProductType(ptys))\n\n | RecordType(row) ->\n let prow = aux_row row in\n (rngf rng, RecordType(prow))\n\n | TypeApp(tyid, tyargs) ->\n let ptyargs = tyargs |> List.map aux in\n (rngf rng, TypeApp(tyid, ptyargs))\n\n | PackType(absmodsig) ->\n (rngf rng, PackType(absmodsig))\n\n and aux_effect (Effect(ty)) =\n let pty = aux ty in\n Effect(pty)\n\n and aux_pid_type (Pid(ty)) =\n let pty = aux ty in\n Pid(pty)\n\n and aux_row : mono_row -> poly_row = function\n | RowCons(rlabel, ty, row) ->\n let pty = aux ty in\n let prow = aux_row row in\n RowCons(rlabel, pty, prow)\n\n | RowVar(UpdatableRow{contents = LinkRow(row)}) ->\n aux_row row\n\n | RowVar((UpdatableRow{contents = FreeRow(frid)}) as mrv) ->\n if levpred (FreeRowID.get_level frid) then\n let brid = intern_row frid in\n RowVar(BoundRow(brid))\n else\n RowVar(MonoRow(mrv))\n\n | RowVar(MustBeBoundRow(mbbrid)) ->\n if levpred (MustBeBoundRowID.get_level mbbrid) then\n let brid = MustBeBoundRowID.to_bound mbbrid in\n RowVar(BoundRow(brid))\n (* We do not need to register a kind to `KindStore`,\n since it has been done when `mbbrid` was created. *)\n else\n RowVar(MonoRow(MustBeBoundRow(mbbrid)))\n\n | RowEmpty ->\n RowEmpty\n\n in\n aux ty\n\n\n(* `generalize lev ty` transforms a monotype `ty` into a polytype\n by binding type variables the level of which is higher than `lev`. *)\nlet generalize (lev : int) (ty : mono_type) : poly_type =\n lift_scheme\n (fun _ -> Range.dummy \"erased\")\n (fun levx -> lev < levx)\n ty\n\n\n(* `lift` projects monotypes into polytypes without binding any type variables. *)\nlet lift (ty : mono_type) : poly_type =\n lift_scheme (fun rng -> rng) (fun _ -> false) ty\n\n\nlet instantiate_scheme : 'a 'b. (Range.t -> poly_type_var -> ('a, 'b) typ) -> (poly_row_var -> 'b) -> poly_type -> ('a, 'b) typ =\nfun intern intern_row pty ->\n let rec aux (rng, ptymain) =\n match ptymain with\n | BaseType(bty) ->\n (rng, BaseType(bty))\n\n | TypeVar(ptv) ->\n intern rng ptv\n\n | FuncType(pdomain, ptycod) ->\n let domain = aux_domain pdomain in\n let tycod = aux ptycod in\n (rng, FuncType(domain, tycod))\n\n | EffType(pdomain, peff, pty0) ->\n let domain = aux_domain pdomain in\n let eff = aux_effect peff in\n let ty0 = aux pty0 in\n (rng, EffType(domain, eff, ty0))\n\n | PidType(ppidty) ->\n let pidty = aux_pid_type ppidty in\n (rng, PidType(pidty))\n\n | ProductType(ptys) ->\n let tys = ptys |> TupleList.map aux in\n (rng, ProductType(tys))\n\n | RecordType(prow) ->\n let row = aux_row prow in\n (rng, RecordType(row))\n\n | TypeApp(tyid, ptyargs) ->\n (rng, TypeApp(tyid, ptyargs |> List.map aux))\n\n | PackType(absmodsig) ->\n (rng, PackType(absmodsig))\n\n and aux_row = function\n | RowCons(rlabel, pty, prow) ->\n let ty = aux pty in\n let row = aux_row prow in\n RowCons(rlabel, ty, row)\n\n | RowVar(prv) ->\n RowVar(intern_row prv)\n\n | RowEmpty ->\n RowEmpty\n\n and aux_domain pdomain =\n let {ordered = ptydoms; mandatory = pmndlabmap; optional = poptrow} = pdomain in\n let tydoms = ptydoms |> List.map aux in\n let mndlabmap = pmndlabmap |> LabelAssoc.map aux in\n let optrow = aux_row poptrow in\n {ordered = tydoms; mandatory = mndlabmap; optional = optrow}\n\n and aux_effect (Effect(pty)) =\n let ty = aux pty in\n Effect(ty)\n\n and aux_pid_type (Pid(pty)) =\n let ty = aux pty in\n Pid(ty)\n in\n aux pty\n\n\nlet instantiate_by_hash_table bidht bridht (lev : int) (pty : poly_type) : mono_type =\n\n let rec intern (rng : Range.t) (ptv : poly_type_var) : mono_type =\n match ptv with\n | Mono(mtv) ->\n (rng, TypeVar(mtv))\n\n | Bound(bid) ->\n let mtv =\n match BoundIDHashTable.find_opt bidht bid with\n | Some(mtvu) ->\n Updatable(mtvu)\n\n | None ->\n let fid = FreeID.fresh ~message:\"instantiate, intern\" lev in\n let mtvu = ref (Free(fid)) in\n BoundIDHashTable.add bidht bid mtvu;\n Updatable(mtvu)\n in\n (rng, TypeVar(mtv))\n\n and intern_row (prv : poly_row_var) : mono_row_var =\n match prv with\n | MonoRow(mrv) ->\n mrv\n\n | BoundRow(brid) ->\n begin\n match BoundRowIDHashTable.find_opt bridht brid with\n | Some(mrvu) ->\n UpdatableRow(mrvu)\n\n | None ->\n let labset = KindStore.get_bound_row brid in\n let frid = FreeRowID.fresh ~message:\"instantiate, intern_row\" lev in\n KindStore.register_free_row frid labset;\n let mrvu = ref (FreeRow(frid)) in\n UpdatableRow(mrvu)\n end\n\n and aux pty =\n instantiate_scheme intern intern_row pty\n in\n aux pty\n\n\nlet instantiate (lev : int) (pty : poly_type) =\n let bidht = BoundIDHashTable.create 32 in\n let bridht = BoundRowIDHashTable.create 32 in\n (* Hash tables are created at every (non-partial) call of `instantiate`. *)\n instantiate_by_hash_table bidht bridht lev pty\n\n\nlet make_bound_to_free_hash_table bidht bridht (lev : int) (typarams : BoundID.t list) : mono_type list =\n let tyargacc =\n typarams |> List.fold_left (fun tyargacc bid ->\n let mtv =\n match BoundIDHashTable.find_opt bidht bid with\n | Some(mtvu) ->\n Updatable(mtvu)\n\n | None ->\n let fid = FreeID.fresh ~message:\"make_bound_to_free_hash_table\" lev in\n let mtvu = ref (Free(fid)) in\n BoundIDHashTable.add bidht bid mtvu;\n Updatable(mtvu)\n in\n let ty = (Range.dummy \"constructor-arg\", TypeVar(mtv)) in\n(*\n Format.printf \"BTOF L%d %a\\n\" lev pp_mono_type ty; (* for debug *)\n*)\n Alist.extend tyargacc ty\n ) Alist.empty\n in\n Alist.to_list tyargacc\n\n\nlet instantiate_type_arguments (lev : int) (typarams : BoundID.t list) (ptys : poly_type list) : mono_type list * mono_type list =\n let bidht = BoundIDHashTable.create 32 in\n let bridht = BoundRowIDHashTable.create 32 in\n let tyargs = make_bound_to_free_hash_table bidht bridht lev typarams in\n let tys_expected = ptys |> List.map (instantiate_by_hash_table bidht bridht lev) in\n (tyargs, tys_expected)\n\n\nlet substitute_mono_type (substmap : mono_type BoundIDMap.t) : poly_type -> mono_type =\n let intern (rng : Range.t) (ptv : poly_type_var) : mono_type =\n match ptv with\n | Mono(mtv) ->\n (rng, TypeVar(mtv))\n\n | Bound(bid) ->\n begin\n match substmap |> BoundIDMap.find_opt bid with\n | None -> assert false\n | Some(ty) -> ty\n end\n in\n let intern_row (prv : poly_row_var) =\n failwith \"TODO: substitute_mono_type, intern_row\"\n in\n instantiate_scheme intern intern_row\n\n\nlet substitute_poly_type (substmap : poly_type BoundIDMap.t) : poly_type -> poly_type =\n let intern (rng : Range.t) (ptv : poly_type_var) : poly_type =\n match ptv with\n | Mono(_) ->\n (rng, TypeVar(ptv))\n\n | Bound(bid) ->\n begin\n match substmap |> BoundIDMap.find_opt bid with\n | None -> assert false\n | Some(pty) -> pty\n end\n in\n let intern_row (prv : poly_row_var) =\n failwith \"TODO: substitute_poly_type, intern_row\"\n in\n instantiate_scheme intern intern_row\n\n\nlet apply_type_scheme_mono ((bids, pty_body) : type_scheme) (tyargs : mono_type list) : mono_type option =\n try\n let substmap =\n List.fold_left2 (fun substmap bid tyarg ->\n substmap |> BoundIDMap.add bid tyarg\n ) BoundIDMap.empty bids tyargs\n in\n Some(substitute_mono_type substmap pty_body)\n with\n | Invalid_argument(_) -> None\n\n\nlet apply_type_scheme_poly ((bids, pty_body) : type_scheme) (ptyargs : poly_type list) : poly_type option =\n try\n let substmap =\n List.fold_left2 (fun substmap bid ptyarg ->\n substmap |> BoundIDMap.add bid ptyarg\n ) BoundIDMap.empty bids ptyargs\n in\n Some(substitute_poly_type substmap pty_body)\n with\n | Invalid_argument(_) -> None\n\nlet make_opaque_type_scheme (bids : BoundID.t list) (tyid : TypeID.t) : type_scheme =\n let dr = Range.dummy \"make_opaque_type_scheme\" in\n let ptyargs = bids |> List.map (fun bid -> (dr, TypeVar(Bound(bid)))) in\n (bids, (dr, TypeApp(tyid, ptyargs)))\n\n\nlet make_opaque_type_scheme_from_base_kinds (bkds : base_kind list) (tyid : TypeID.t) : type_scheme =\n let bids = bkds |> List.map (fun _bkd -> BoundID.fresh ()) in\n make_opaque_type_scheme bids tyid\n\n\nlet get_opaque_type ((bids, pty_body, _) : type_scheme_with_entity) : TypeID.t option =\n match pty_body with\n | (_, TypeApp(tyid, ptyargs)) ->\n begin\n match List.combine bids ptyargs with\n | exception Invalid_argument(_) ->\n None\n\n | zipped ->\n if\n zipped |> List.for_all (fun (bid, ptyarg) ->\n match ptyarg with\n | (_, TypeVar(Bound(bid0))) -> BoundID.equal bid bid0\n | _ -> false\n )\n then\n Some(tyid)\n else\n None\n end\n\n | _ ->\n None\n\n\nlet overwrite_range_of_type (rng : Range.t) (_, tymain) =\n (rng, tymain)\n\n\nlet rec can_row_take_optional : mono_row -> bool = function\n | RowCons(_, _, _) -> true\n | RowVar(UpdatableRow{contents = FreeRow(frid)}) -> false\n | RowVar(UpdatableRow{contents = LinkRow(row)}) -> can_row_take_optional row\n | RowVar(MustBeBoundRow(mbbrid)) -> false\n | RowEmpty -> false\n\n\nlet rec kind_of_arity n =\n let bkddoms = List.init n (fun _ -> TypeKind) in\n Kind(bkddoms, TypeKind)\n\n\nlet rec arity_of_kind = function\n Kind(bkddoms, _) -> List.length bkddoms\n\n\n(* Omit redundant structures of the given type. *)\nlet rec canonicalize_root = function\n | (_, TypeVar(Updatable({contents = Link(ty)}))) ->\n canonicalize_root ty\n\n | ty ->\n ty\n\n\ntype display_spec = {\n token : string -> string;\n arrow : string;\n paren : string -> string;\n bracket : string -> string;\n angle : string -> string;\n}\n\n\nlet display_spec_tty = {\n token = (fun s -> s);\n arrow = \"->\";\n paren = (fun s -> Printf.sprintf \"(%s)\" s);\n bracket = (fun s -> Printf.sprintf \"[%s]\" s);\n angle = (fun s -> Printf.sprintf \"<%s>\" s);\n}\n\n\nlet display_spec_html = {\n token = (fun s -> Printf.sprintf \"%s\" s);\n arrow = \"->\";\n paren = (fun s -> Printf.sprintf \"(%s)\" s);\n bracket = (fun s -> Printf.sprintf \"[%s]\" s);\n angle = (fun s -> Printf.sprintf \"<%s>\" s);\n}\n\n\nlet show_base_type = function\n | UnitType -> \"unit\"\n | BoolType -> \"bool\"\n | IntType -> \"int\"\n | FloatType -> \"float\"\n | BinaryType -> \"binary\"\n | CharType -> \"char\"\n\n\nlet rec show_label_assoc : 'a 'b. prefix:string -> suffix:string -> display_spec -> Address.t -> ('a -> string) -> ('b -> string option) -> (('a, 'b) typ) LabelAssoc.t -> string option =\nfun ~prefix:prefix ~suffix:suffix spec seen_from showtv showrv labmap ->\n if LabelAssoc.cardinal labmap = 0 then\n None\n else\n let s =\n LabelAssoc.fold (fun label ty acc ->\n let sty = show_type spec seen_from showtv showrv ty in\n Alist.extend acc (prefix ^ label ^ suffix ^ \" \" ^ sty)\n ) labmap Alist.empty |> Alist.to_list |> String.concat \", \"\n in\n Some(s)\n\n\nand show_domain : 'a 'b. display_spec -> Address.t -> ('a -> string) -> ('b -> string option) -> ('a, 'b) domain_type -> string =\nfun spec seen_from showtv showrv domain ->\n let sdoms = domain.ordered |> List.map (show_type spec seen_from showtv showrv) in\n let sdomscat = String.concat \", \" sdoms in\n let is_ord_empty = (sdoms = []) in\n let (is_mnds_empty, smnds) =\n match show_label_assoc ~prefix:\"-\" ~suffix:\"\" spec seen_from showtv showrv domain.mandatory with\n | None -> (true, \"\")\n | Some(s) -> (false, s)\n in\n let (is_opts_empty, sopts) =\n match show_row ~prefix:\"?\" ~suffix:\"\" spec seen_from showtv showrv domain.optional with\n | None -> (true, \"\")\n | Some(s) -> (false, s)\n in\n let smid1 =\n if is_ord_empty then\n \"\"\n else\n if is_mnds_empty && is_opts_empty then \"\" else \", \"\n in\n let smid2 =\n if is_mnds_empty || is_opts_empty then\n \"\"\n else\n if is_ord_empty then \"\" else \", \"\n in\n Printf.sprintf \"%s%s%s%s%s\"\n sdomscat smid1 smnds smid2 sopts\n\n\nand show_type : 'a 'b. display_spec -> Address.t -> ('a -> string) -> ('b -> string option) -> ('a, 'b) typ -> string =\nfun spec seen_from showtv showrv ty ->\n let rec aux (_, tymain) =\n match tymain with\n | BaseType(bty) ->\n show_base_type bty\n\n | FuncType(domain, tycod) ->\n let sdom = show_domain spec seen_from showtv showrv domain in\n let scod = aux tycod in\n Printf.sprintf \"%s%s %s %s\"\n (spec.token \"fun\") (spec.paren sdom) spec.arrow scod\n\n | EffType(domain, eff, ty0) ->\n let sdom = show_domain spec seen_from showtv showrv domain in\n let seff = aux_effect eff in\n let s0 = aux ty0 in\n Printf.sprintf \"%s%s %s %s%s\"\n (spec.token \"fun\") (spec.paren sdom) spec.arrow seff s0\n\n | PidType(pidty) ->\n let spid = aux_pid_type pidty in\n Printf.sprintf \"pid%s\" (spec.angle spid)\n\n | TypeVar(tv) ->\n showtv tv\n\n | ProductType(tys) ->\n let ss = tys |> TupleList.to_list |> List.map aux in\n Printf.sprintf \"{%s}\" (String.concat \", \" ss)\n\n | RecordType(row) ->\n begin\n match show_row ~prefix:\"\" ~suffix:\" :\" spec seen_from showtv showrv row with\n | None -> \"{}\"\n | Some(s) -> Printf.sprintf \"{%s}\" s\n end\n\n | TypeApp(tyid, tyargs) ->\n begin\n match tyargs with\n | [] ->\n Format.asprintf \"%a\" (TypeID.pp ~seen_from) tyid\n\n | _ :: _ ->\n let ss = tyargs |> List.map aux in\n Format.asprintf \"%a%s\" (TypeID.pp ~seen_from) tyid (spec.angle (String.concat \", \" ss))\n end\n\n | PackType(_absmodsig) ->\n \"(signature)\" (* TODO: show signatures *)\n\n and aux_effect (Effect(ty)) =\n let s = aux ty in\n spec.bracket s\n\n and aux_pid_type (Pid(ty)) =\n aux ty\n in\n aux ty\n\n\nand show_row : 'a 'b. prefix:string -> suffix:string -> display_spec -> Address.t -> ('a -> string) -> ('b -> string option) -> ('a, 'b) row -> string option =\nfun ~prefix ~suffix spec seen_from showtv showrv row ->\n let NormalizedRow(labmap, rowvar_opt) = normalize_row_general row in\n let smain_opt = labmap |> show_label_assoc ~prefix ~suffix spec seen_from showtv showrv in\n let svar_opt =\n match rowvar_opt with\n | Some(rv) -> showrv rv\n | None -> None\n in\n match (smain_opt, svar_opt) with\n | (Some(smain), Some(svar)) -> Some(Printf.sprintf \"%s, %s\" smain svar)\n | (Some(smain), None) -> Some(smain)\n | (None, Some(svar)) -> Some(svar)\n | (None, None) -> None\n\n\nand show_mono_type_var (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) (mtv : mono_type_var) : string =\n match mtv with\n | MustBeBound(mbbid) -> Format.asprintf \"%a\" MustBeBoundID.pp_rich mbbid\n | Updatable(mtvu) -> show_mono_type_var_updatable spec seen_from dispmap !mtvu\n\n\nand show_mono_type_var_updatable (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) (mtvu : mono_type_var_updatable) : string =\n match mtvu with\n | Link(ty) -> show_type spec seen_from (show_mono_type_var spec seen_from dispmap) (show_mono_row_var spec seen_from dispmap) ty\n | Free(fid) -> dispmap |> DisplayMap.find_free_id fid\n\n\nand show_mono_row_var (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) (mrv : mono_row_var) : string option =\n match mrv with\n | UpdatableRow(mrvu) -> show_mono_row_var_updatable spec seen_from dispmap !mrvu\n | MustBeBoundRow(mbbrid) -> Some(Format.asprintf \"%a\" MustBeBoundRowID.pp_rich mbbrid)\n\n\nand show_mono_row_var_updatable (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) (mrvu : mono_row_var_updatable) : string option =\n match mrvu with\n | LinkRow(row) ->\n show_row ~prefix:\"?\" ~suffix:\"\" spec seen_from (show_mono_type_var spec seen_from dispmap) (show_mono_row_var spec seen_from dispmap) row\n\n | FreeRow(frid) ->\n let s = dispmap |> DisplayMap.find_free_row_id frid in\n Some(s)\n\n\nlet show_mono_type ?(spec : display_spec = display_spec_tty) ?(seen_from : Address.t = Address.root) (dispmap : DisplayMap.t) : mono_type -> string =\n show_type spec seen_from (show_mono_type_var spec seen_from dispmap) (show_mono_row_var spec seen_from dispmap)\n\n\nlet show_mono_row ~(prefix : string) ~(suffix : string) ?(spec : display_spec = display_spec_tty) ?(seen_from : Address.t = Address.root) (dispmap : DisplayMap.t) : mono_row -> string option =\n show_row ~prefix ~suffix spec seen_from (show_mono_type_var spec seen_from dispmap) (show_mono_row_var spec seen_from dispmap)\n\n\nlet pp_mono_type ?(spec : display_spec = display_spec_tty) dispmap ppf ty =\n Format.fprintf ppf \"%s\" (show_mono_type ~spec dispmap ty)\n\n\nlet pp_mono_row ?(spec : display_spec = display_spec_tty) dispmap ppf row =\n Format.fprintf ppf \"%s\" (Option.value ~default:\"(empty)\" (show_mono_row ~prefix:\"\" ~suffix:\"\" ~spec dispmap row))\n\n\nlet rec show_poly_type_var (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) = function\n | Bound(bid) -> dispmap |> DisplayMap.find_bound_id bid\n | Mono(mtv) -> show_mono_type_var spec seen_from dispmap mtv\n\n\nand show_poly_row_var (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) = function\n | BoundRow(brid) -> Some(dispmap |> DisplayMap.find_bound_row_id brid)\n | MonoRow(mrv) -> show_mono_row_var spec seen_from dispmap mrv\n\n\nand show_poly_type ?(spec : display_spec = display_spec_tty) ?(seen_from : Address.t = Address.root) (dispmap : DisplayMap.t) : poly_type -> string =\n show_type spec seen_from (show_poly_type_var spec seen_from dispmap) (show_poly_row_var spec seen_from dispmap)\n\n\nlet show_poly_row ?(spec : display_spec = display_spec_tty) ?(seen_from : Address.t = Address.root) (dispmap : DisplayMap.t) : poly_row -> string option =\n show_row ~prefix:\"\" ~suffix:\"\" spec seen_from (show_poly_type_var spec seen_from dispmap) (show_poly_row_var spec seen_from dispmap)\n\n\nlet pp_poly_type ?(spec : display_spec = display_spec_tty) ?(seen_from : Address.t = Address.root) (dispmap : DisplayMap.t) (ppf : Format.formatter) (pty : poly_type) : unit =\n Format.fprintf ppf \"%s\" (show_poly_type ~spec ~seen_from dispmap pty)\n\n\nlet show_bound_type_ids (dispmap : DisplayMap.t) =\n dispmap |> DisplayMap.fold_bound_id (fun bid sb acc ->\n Alist.extend acc (Printf.sprintf \"%s :: o\" sb)\n ) Alist.empty |> Alist.to_rev_list\n\n\nlet show_bound_row_ids (dispmap : DisplayMap.t) =\n dispmap |> DisplayMap.fold_bound_row_id (fun brid (sb, labset) acc ->\n let skd = labset |> LabelSet.elements |> String.concat \", \" in\n Alist.extend acc (Printf.sprintf \"%s :: (%s)\" sb skd)\n ) Alist.empty |> Alist.to_rev_list\n\n\nlet show_base_kind (bkd : base_kind) : string =\n match bkd with\n | TypeKind -> \"o\"\n | RowKind(labset) -> Printf.sprintf \"(%s)\" (labset |> LabelSet.elements |> String.concat \", \")\n\n\nlet show_kind (kd : kind) : string =\n let Kind(bkddoms, bkdcod) = kd in\n let sdoms = bkddoms |> List.map show_base_kind in\n let scod = show_base_kind bkdcod in\n match sdoms with\n | [] -> scod\n | _ :: _ -> Printf.sprintf \"(%s) -> %s\" (String.concat \", \" sdoms) scod\n\n\nlet pp_debug_poly_type ~(raw : bool) (ppf : Format.formatter) (pty : poly_type) : unit =\n let dispmap = if raw then DisplayMap.empty else DisplayMap.empty |> collect_ids_poly pty in\n let ss1 = show_bound_type_ids dispmap in\n let ss2 = show_bound_row_ids dispmap in\n let s3 = show_poly_type dispmap pty in\n Format.fprintf ppf \"<%s> <%s> %s\" (String.concat \", \" ss1) (String.concat \", \" ss2) s3\n\n\nlet pp_debug_mono_type ~(raw : bool) (ppf : Format.formatter) (ty : mono_type) : unit =\n let dispmap = if raw then DisplayMap.empty else DisplayMap.empty |> collect_ids_mono ty in\n let s = show_mono_type dispmap ty in\n Format.printf \"%s\" s\n" }, { "path": "src/typeID.ml", "content": "\ntype t = {\n number : int;\n address : Address.t;\n name : string;\n}\n\n\nlet fresh =\n let current_max = ref 0 in\n (fun (address : Address.t) (name : string) ->\n incr current_max;\n {\n number = !current_max;\n address = address;\n name = name;\n }\n )\n\n\nlet hash tyid =\n tyid.number\n\n\nlet compare tyid1 tyid2 =\n tyid2.number - tyid1.number\n\n\nlet equal tyid1 tyid2 =\n tyid1.number = tyid2.number\n\n\nlet name tyid =\n tyid.name\n\n\nlet address tyid =\n tyid.address\n\n\nlet pp (ppf : Format.formatter) ?(seen_from : Address.t = Address.root) (tyid : t) =\n let address = Address.subtract ~long:tyid.address ~short:seen_from in\n Format.fprintf ppf \"%s%s\" (Address.show address) tyid.name\n\n\nlet pp_raw (ppf : Format.formatter) (tyid : t) =\n Format.fprintf ppf \"%s/%d\" tyid.name tyid.number\n" }, { "path": "src/typeID.mli", "content": "\ntype t\n\nval fresh : Address.t -> string -> t\n\nval hash : t -> int\n\nval compare : t -> t -> int\n\nval equal : t -> t -> bool\n\nval name : t -> string\n\nval address : t -> Address.t\n\nval pp : Format.formatter -> ?seen_from:Address.t -> t -> unit\n\nval pp_raw : Format.formatter -> t -> unit\n" }, { "path": "src/typechecker.ml", "content": "\nopen MyUtil\nopen Syntax\nopen IntermediateSyntax\nopen Env\nopen Errors\n\n\nexception TypeError of type_error\n\n\nmodule BindingMap = Map.Make(String)\n\nmodule SubstMap = Map.Make(TypeID)\n\ntype substitution = type_scheme_with_entity SubstMap.t\n\ntype type_intern = BoundID.t -> poly_type -> bool\n\ntype row_intern = BoundRowID.t -> normalized_poly_row -> bool\n\ntype subtyping_error = unit\n\ntype binding_map = (mono_type * local_name * Range.t) BindingMap.t\n\ntype variant_definition = type_name * TypeID.t * BoundID.t list * constructor_map\n\ntype rec_morph =\n | MonoRec of mono_type\n | PolyRec of poly_type\n\ntype pre = {\n level : int;\n tyenv : Typeenv.t;\n local_type_parameters : local_type_parameter_map;\n local_row_parameters : local_row_parameter_map;\n}\n\n\nmodule GlobalNameMap = Map.Make(OutputIdentifier.Global)\n\nmodule SynonymNameSet = Set.Make(String)\n\nmodule SynonymNameHashSet =\n Hashtbl.Make(\n struct\n type t = type_name\n let equal = String.equal\n let hash = Hashtbl.hash\n end)\n\n\nlet raise_error e =\n raise (TypeError(e))\n\n\nlet merge_quantifier (quant1 : quantifier) (quant2 : quantifier) : quantifier =\n OpaqueIDMap.union (fun _ pkd1 _pkd2 -> Some(pkd1)) quant1 quant2\n\n\nlet internbidf (bidmap : BoundID.t BoundIDMap.t) (bid1 : BoundID.t) (pty2 : poly_type) : bool =\n match pty2 with\n | (_, TypeVar(Bound(bid2))) ->\n begin\n match bidmap |> BoundIDMap.find_opt bid1 with\n | None -> false\n | Some(bid) -> BoundID.equal bid bid2\n end\n\n | _ ->\n false\n\n\nlet internbridf (_bidmap : BoundID.t BoundIDMap.t) (_brid1 : BoundRowID.t) (_nomrow2 : normalized_poly_row) : bool =\n (* TODO: implement this when type definitions become able to take row parameters *)\n false\n\n\nlet add_dummy_fold (tynm : type_name) (tyid : TypeID.t) (bids : BoundID.t list) (ctormap : constructor_map) (sigr : SigRecord.t) : SigRecord.t =\n let bid = BoundID.fresh () in\n let dr = Range.dummy \"add_dummy_fold\" in\n let plabmap =\n ConstructorMap.fold (fun ctornm (_ctorid, ptyargs) plabmap ->\n let domty =\n {\n ordered = ptyargs;\n mandatory = LabelAssoc.empty;\n optional = RowEmpty;\n }\n in\n plabmap |> LabelAssoc.add ctornm (dr, FuncType(domty, (dr, TypeVar(Bound(bid)))))\n ) ctormap LabelAssoc.empty\n in\n let domty =\n {\n ordered = [(dr, TypeApp(tyid, bids |> List.map (fun bid -> (dr, TypeVar(Bound(bid))))))];\n mandatory = plabmap;\n optional = RowEmpty;\n }\n in\n let pty = (dr, FuncType(domty, (dr, TypeVar(Bound(bid))))) in\n sigr |> SigRecord.add_dummy_fold tynm pty\n\n\nlet add_constructor_definitions (ctordefs : variant_definition list) (sigr : SigRecord.t) : SigRecord.t =\n ctordefs |> List.fold_left (fun sigr ctordef ->\n let (tynm, tyid, bids, ctorbrmap) = ctordef in\n let sigr =\n ConstructorMap.fold (fun ctornm (ctorid, ptyargs) sigr ->\n let centry =\n {\n belongs = tyid;\n constructor_id = ctorid;\n type_variables = bids;\n parameter_types = ptyargs;\n }\n in\n sigr |> SigRecord.add_constructor ctornm centry\n ) ctorbrmap sigr\n in\n sigr |> add_dummy_fold tynm tyid bids ctorbrmap\n ) sigr\n\n\nlet make_type_scheme_from_constructor_entry (centry : constructor_entry) : type_scheme =\n let\n {\n belongs = tyid;\n type_variables = bids;\n parameter_types = ptys;\n _\n } = centry\n in\n let dr = Range.dummy \"make_type_scheme_from_constructor_entry\" in\n let domty =\n {\n ordered = ptys;\n mandatory = LabelAssoc.empty;\n optional = RowEmpty;\n }\n in\n let ty_cod = (dr, TypeApp(tyid, bids |> List.map (fun bid -> (dr, TypeVar(Bound(bid)))))) in\n (bids, (dr, FuncType(domty, ty_cod)))\n\n\nlet make_address_module_list (address : Address.t) : module_name list =\n address |> Address.to_list |> List.fold_left (fun opt adelem ->\n match (opt, adelem) with\n | (Some(acc), Address.Member(modnm)) -> Some(Alist.extend acc modnm)\n | _ -> None\n ) (Some(Alist.empty)) |> Option.value ~default:Alist.empty |> Alist.to_list\n\n\nlet get_module_name_chain_position (modchain : module_name_chain) : Range.t =\n let ((rngL, _), projs) = modchain in\n match List.rev projs with\n | [] -> rngL\n | (rngR, _) :: _ -> Range.unite rngL rngR\n\n\nlet binding_map_union rng =\n BindingMap.union (fun x _ _ ->\n raise_error (BoundMoreThanOnceInPattern(rng, x))\n )\n\n\nlet get_dependency_on_synonym_types (vertices : SynonymNameSet.t) (pre : pre) (mty : manual_type) : SynonymNameSet.t =\n let hashset = SynonymNameHashSet.create 32 in\n (* A hash set is created on every (non-partial) call. *)\n let register_if_needed (tynm : type_name) : unit =\n if vertices |> SynonymNameSet.mem tynm then\n SynonymNameHashSet.add hashset tynm ()\n else\n ()\n in\n let rec aux ((_, mtymain) : manual_type) : unit =\n match mtymain with\n | MTypeName(tynm, mtyargs) ->\n List.iter aux mtyargs;\n register_if_needed tynm\n\n | MFuncType((mtydoms, mndlabmtys, mrow), mtycod) ->\n aux_labeled_list mndlabmtys;\n aux_row mrow;\n aux mtycod\n\n | MProductType(mtys) ->\n mtys |> TupleList.to_list |> List.iter aux\n\n | MRecordType(mrow) ->\n aux_row mrow\n\n | MEffType((mtydoms, mndlabmtys, mrow), mty1, mty2) ->\n aux_labeled_list mndlabmtys;\n aux_row mrow;\n List.iter aux mtydoms;\n aux mty1;\n aux mty2\n\n | MTypeVar(typaram) ->\n ()\n\n | MModProjType(utmod1, tyident2, mtyargs) ->\n ()\n\n | MPackType(utsig) ->\n aux_signature utsig\n\n and aux_labeled_list (labmtys : labeled_manual_type list) : unit =\n labmtys |> List.iter (fun (_, mty) -> aux mty)\n\n and aux_row (mrow : manual_row) : unit =\n match mrow with\n | MRow(optlabmtys, _) -> aux_labeled_list optlabmtys\n\n and aux_signature (utsig : untyped_signature) : unit =\n () (* TODO: implement this or restrict the syntax of `pack` *)\n in\n aux mty;\n SynonymNameHashSet.fold (fun sid () set ->\n set |> SynonymNameSet.add sid\n ) hashset SynonymNameSet.empty\n\n\nlet find_module (tyenv : Typeenv.t) ((rng, m) : module_name ranged) : module_entry =\n match tyenv |> Typeenv.find_module m with\n | None -> raise_error (UnboundModuleName(rng, m))\n | Some(v) -> v\n\n\nlet find_module_from_chain (tyenv : Typeenv.t) ((modident, projs) : module_name_chain) : module_entry =\n let init = find_module tyenv modident in\n let (rng, _) = modident in\n let (ret, _) =\n projs |> List.fold_left (fun (mentry, rng) proj ->\n let modsig = mentry.mod_signature in\n match modsig with\n | (_, ConcFunctor(_)) ->\n raise_error (NotOfStructureType(rng, modsig))\n\n | (_, ConcStructure(sigr)) ->\n let (rngproj, modnm) = proj in\n begin\n match sigr |> SigRecord.find_module modnm with\n | None ->\n raise_error (UnboundModuleName(rngproj, modnm))\n\n | Some(mentry) ->\n let (rng, _) = proj in\n (mentry, rng)\n end\n ) (init, rng)\n in\n ret\n\n\nlet update_type_environment_by_signature_record (sigr : SigRecord.t) (tyenv : Typeenv.t) : Typeenv.t =\n sigr |> SigRecord.fold\n ~v:(fun x ventry tyenv ->\n let pty = ventry.val_type in\n let gname = ventry.val_global in\n tyenv |> Typeenv.add_value x pty (OutputIdentifier.Global(gname))\n )\n ~c:(fun ctornm centry tyenv ->\n tyenv |> Typeenv.add_constructor ctornm centry\n )\n ~f:(fun _tynm _pty tyenv ->\n tyenv\n )\n ~t:(fun tynm tentry tyenv ->\n tyenv |> Typeenv.add_type tynm tentry\n )\n ~m:(fun modnm mentry tyenv ->\n tyenv |> Typeenv.add_module modnm mentry\n )\n ~s:(fun signm absmodsig ->\n Typeenv.add_signature signm absmodsig\n )\n tyenv\n\n\nlet add_open_specs_to_type_environment (openspecs : module_name_chain list) (tyenv : Typeenv.t) : Typeenv.t =\n openspecs |> List.fold_left (fun tyenv openspec ->\n let mentry = find_module_from_chain tyenv openspec in\n let modsig = mentry.mod_signature in\n match modsig with\n | (_, ConcFunctor(_)) ->\n let rng0 = get_module_name_chain_position openspec in\n raise_error (NotOfStructureType(rng0, modsig))\n\n | (_, ConcStructure(sigr)) ->\n tyenv |> update_type_environment_by_signature_record sigr\n ) tyenv\n\n\nlet iapply (efun : ast) (mrow : mono_row) ((eargs, mndargmap, optargmap) : ast list * ast LabelAssoc.t * ast LabelAssoc.t) : ast =\n match efun with\n | IVar(name) ->\n IApply(name, mrow, eargs, mndargmap, optargmap)\n\n | _ ->\n let lname = OutputIdentifier.fresh () in\n ILetIn(lname, efun, IApply(OutputIdentifier.Local(lname), mrow, eargs, mndargmap, optargmap))\n\n\nlet ilambda ((ordipats, mndipatmap, optipatmap) : pattern list * pattern LabelAssoc.t * (pattern * ast option) LabelAssoc.t) (e0 : ast) : ast =\n ILambda(None, ordipats, mndipatmap, optipatmap, e0)\n\n\nlet iletpatin (ipat : pattern) (e1 : ast) (e2 : ast) : ast =\n ICase(e1, [ IBranch(ipat, e2) ])\n\n\nlet iletrecin_single (_, _, name_outer, name_inner, e1) (e2 : ast) : ast =\n match e1 with\n | ILambda(None, ordnames, mndnamemap, optnamemap, e0) ->\n ILetIn(name_outer, ILambda(Some(name_inner), ordnames, mndnamemap, optnamemap, e0), e2)\n\n | _ ->\n assert false\n\n\nlet iletrecin_multiple (binds : (identifier * poly_type * local_name * local_name * ast) List2.t) (e2 : ast) : ast =\n let (bind1, bind2, bindrest) = List2.decompose binds in\n let binds = TupleList.make bind1 (bind2 :: bindrest) in\n\n let ipat_inner_tuple =\n IPTuple(binds |> TupleList.map (fun (_, _, _, name_inner, _) -> IPVar(name_inner)))\n in\n let name_for_whole_rec = OutputIdentifier.fresh () in\n let tuple_entries =\n binds |> TupleList.map (fun (_, _, _name_outer, _name_inner, e1) ->\n match e1 with\n | ILambda(None, ordnames, mndnamemap, optnamemap, e0) ->\n ILambda(None, ordnames, mndnamemap, optnamemap,\n iletpatin ipat_inner_tuple\n (IApply(OutputIdentifier.Local(name_for_whole_rec),\n RowEmpty, [], LabelAssoc.empty, LabelAssoc.empty)) e0)\n\n | _ ->\n assert false\n )\n in\n let ipat_outer_tuple =\n IPTuple(binds |> TupleList.map (fun (_, _, name_outer, _, _) -> IPVar(name_outer)))\n in\n iletpatin ipat_outer_tuple\n (iapply\n (ILambda(Some(name_for_whole_rec), [], LabelAssoc.empty, LabelAssoc.empty, ITuple(tuple_entries)))\n RowEmpty\n ([], LabelAssoc.empty, LabelAssoc.empty))\n e2\n\n\nlet iletrecin (binds : (identifier * poly_type * local_name * local_name * ast) list) (e2 : ast) : ast =\n match binds with\n | [] -> assert false\n | [bind] -> iletrecin_single bind e2\n | bind1 :: bind2 :: rest -> iletrecin_multiple (List2.make bind1 bind2 rest) e2\n\n\nlet occurs (fid : FreeID.t) (ty : mono_type) : bool =\n let lev = FreeID.get_level fid in\n let rec aux ((_, tymain) : mono_type) : bool =\n match tymain with\n | BaseType(_) ->\n false\n\n | FuncType(domain, tycod) ->\n let bdom = aux_domain domain in\n let bcod = aux tycod in\n bdom || bcod\n (* Must not be short-circuit due to the level inference. *)\n\n | ProductType(tys) ->\n tys |> TupleList.to_list |> aux_list\n\n | RecordType(row) ->\n aux_row row\n\n | TypeApp(_tyid, tyargs) ->\n aux_list tyargs\n\n | EffType(domain, eff, ty0) ->\n let bdom = aux_domain domain in\n let beff = aux_effect eff in\n let b0 = aux ty0 in\n bdom || beff || b0\n (* Must not be short-circuit due to the level inference. *)\n\n | PidType(pidty) ->\n aux_pid_type pidty\n\n | TypeVar(Updatable{contents = Link(ty)}) ->\n aux ty\n\n | TypeVar(Updatable{contents = Free(fidx)}) ->\n if FreeID.equal fid fidx then true else\n begin\n FreeID.update_level fidx lev;\n(*\n Format.printf \"LEVEL %a L%d --> L%d\\n\" FreeID.pp fidx (FreeID.get_level fidx) lev; (* for debug *)\n*)\n false\n end\n\n | TypeVar(MustBeBound(_)) ->\n false\n\n | PackType(_modsig) ->\n false\n (* Signatures do not contain free IDs. *)\n\n and aux_domain (domain : mono_domain_type) : bool =\n let {ordered = tydoms; mandatory = mndlabmap; optional = optrow} = domain in\n let b1 = aux_list tydoms in\n let bmnd = aux_label_assoc mndlabmap in\n let bopt = aux_row optrow in\n b1 || bmnd || bopt\n\n and aux_effect (Effect(ty)) =\n aux ty\n\n and aux_pid_type (Pid(ty)) =\n aux ty\n\n and aux_row = function\n | RowCons(_, ty, row) ->\n let b1 = aux ty in\n let b2 = aux_row row in\n b1 || b2\n\n | RowVar(UpdatableRow{contents = FreeRow(_)}) ->\n false\n\n | RowVar(UpdatableRow{contents = LinkRow(row)}) ->\n aux_row row\n\n | RowVar(MustBeBoundRow(_)) ->\n false\n\n | RowEmpty ->\n false\n\n and aux_label_assoc (labmap : mono_type LabelAssoc.t) =\n LabelAssoc.fold (fun _ ty bacc ->\n let b = aux ty in\n b || bacc\n ) labmap false\n\n and aux_list (tys : mono_type list) : bool =\n tys |> List.map aux |> List.fold_left ( || ) false\n (* Must not be short-circuit due to the level inference *)\n in\n aux ty\n\n\nlet occurs_row (frid : FreeRowID.t) (row : mono_row) : bool =\n let rec aux (_, tymain) =\n match tymain with\n | BaseType(_) ->\n false\n\n | FuncType(domain, tycod) ->\n let bdom = aux_domain domain in\n let bcod = aux tycod in\n bdom || bcod\n (* Must not be short-circuit due to the level inference. *)\n\n | PidType(pidty) ->\n aux_pid pidty\n\n | EffType(domain, effty, ty0) ->\n let bdom = aux_domain domain in\n let beff = aux_effect effty in\n let b0 = aux ty0 in\n bdom || beff || b0\n (* Must not be short-circuit due to the level inference. *)\n\n | TypeVar(_) ->\n false\n\n | ProductType(tys) ->\n tys |> TupleList.to_list |> aux_list\n\n | RecordType(row) ->\n aux_row row\n\n | TypeApp(_tyid, tyargs) ->\n aux_list tyargs\n\n | PackType(_modsig) ->\n false\n (* Signatures do not contain free row IDs. *)\n\n and aux_domain (domain : mono_domain_type) =\n let {ordered = tydoms; mandatory = mndlabmap; optional = optrow} = domain in\n let b1 = aux_list tydoms in\n let bmnd = aux_label_assoc mndlabmap in\n let bopt = aux_row optrow in\n b1 || bmnd || bopt\n\n and aux_pid (Pid(ty)) =\n aux ty\n\n and aux_effect (Effect(ty)) =\n aux ty\n\n and aux_row = function\n | RowCons(_, ty, row) ->\n let b1 = aux ty in\n let b2 = aux_row row in\n b1 || b2\n\n | RowVar(UpdatableRow{contents = LinkRow(row)}) ->\n aux_row row\n\n | RowVar(UpdatableRow{contents = FreeRow(fridx)}) ->\n FreeRowID.equal fridx frid\n\n | RowVar(MustBeBoundRow(_mbbrid)) ->\n false\n\n | RowEmpty ->\n false\n\n and aux_label_assoc (labmap : mono_type LabelAssoc.t) =\n LabelAssoc.fold (fun _ ty bacc ->\n let b = aux ty in\n bacc || b\n ) labmap false\n\n and aux_list tys =\n tys |> List.map aux |> List.fold_left ( || ) false\n (* Must not be short-circuit due to the level inference. *)\n in\n aux_row row\n\n\nlet rec opaque_occurs_in_type_scheme : 'a 'b. (quantifier -> TypeID.t -> bool) -> ('a -> bool) -> quantifier -> ('a, 'b) typ -> bool =\nfun tyidp tvp quant ->\n let rec aux (_, ptymain) =\n match ptymain with\n | BaseType(_) -> false\n | PidType(typid) -> aux_pid typid\n | ProductType(tys) -> tys |> TupleList.to_list |> List.exists aux\n\n | EffType(domain, tyeff, tysub) ->\n aux_domain domain || aux_effect tyeff || aux tysub\n\n | FuncType(domain, tycod) ->\n aux_domain domain || aux tycod\n\n | TypeApp(tyid, tyargs) ->\n tyidp quant tyid || List.exists aux tyargs\n\n | RecordType(row) ->\n aux_row row\n\n | TypeVar(tv) ->\n tvp tv\n\n | PackType(absmodsig) ->\n let (_quant, modsig) = absmodsig in\n opaque_occurs quant modsig\n (* Strictly speaking, we should ensure that `quant` and `_quant` are disjoint. *)\n\n and aux_domain domain =\n let {ordered = tydoms; mandatory = mndlabmap; optional = optrow} = domain in\n List.exists aux tydoms || aux_label_assoc mndlabmap || aux_row optrow\n\n and aux_pid = function\n | Pid(ty) -> aux ty\n\n and aux_effect = function\n | Effect(ty) -> aux ty\n\n and aux_row = function\n | RowCons(_, ty, row) ->\n let b1 = aux ty in\n let b2 = aux_row row in\n b1 || b2\n\n | RowVar(_) ->\n false\n\n | RowEmpty ->\n false\n\n and aux_label_assoc labmap =\n LabelAssoc.fold (fun _ ty bacc ->\n let b = aux ty in\n b || bacc\n ) labmap false\n in\n aux\n\n\nand opaque_occurs_in_mono_type (quant : quantifier) : mono_type -> bool =\n let tvp : mono_type_var -> bool = function\n | Updatable({contents = Link(ty)}) -> opaque_occurs_in_mono_type quant ty\n | _ -> false\n in\n opaque_occurs_in_type_scheme opaque_occurs_in_type_id tvp quant\n\n\nand opaque_occurs_in_poly_type (quant : quantifier) : poly_type -> bool =\n let tvp : poly_type_var -> bool = function\n | Mono(Updatable({contents = Link(ty)})) -> opaque_occurs_in_mono_type quant ty\n | _ -> false\n in\n opaque_occurs_in_type_scheme opaque_occurs_in_type_id tvp quant\n\n\nand opaque_occurs_in_type_id (quant : quantifier) (tyid : TypeID.t) : bool =\n quant |> OpaqueIDMap.mem tyid\n\n\nand opaque_occurs (quant : quantifier) (modsig : module_signature) : bool =\n match modsig with\n | (_, ConcStructure(sigr)) ->\n opaque_occurs_in_structure quant sigr\n\n | (_, ConcFunctor(sigftor)) ->\n let Domain(_, sigr) = sigftor.domain in\n let (_quantcod, modsigcod) = sigftor.codomain in\n opaque_occurs_in_structure quant sigr || opaque_occurs quant modsigcod\n\n\nand opaque_occurs_in_structure (quant : quantifier) (sigr : SigRecord.t) : bool =\n sigr |> SigRecord.fold\n ~v:(fun _x ventry b ->\n let pty = ventry.val_type in\n b || opaque_occurs_in_poly_type quant pty\n )\n ~c:(fun _ctornm centry b ->\n let ptys = centry.parameter_types in\n b || ptys |> List.exists (opaque_occurs_in_poly_type quant)\n )\n ~f:(fun _tynm _pty b ->\n b\n )\n ~t:(fun _tynm tentry b ->\n let (_bids, pty_body, _tyentity) = tentry.type_scheme in\n b || opaque_occurs_in_poly_type quant pty_body\n )\n ~m:(fun _modnm mentry b ->\n let modsig = mentry.mod_signature in\n b || opaque_occurs quant modsig\n )\n ~s:(fun _ sentry b ->\n let (_quant, modsig) = sentry.sig_signature in\n b || opaque_occurs quant modsig\n )\n false\n\n\nlet label_assoc_union =\n LabelAssoc.union (fun _ _ ty2 -> Some(ty2))\n\n\nlet fresh_type_variable ?name:nameopt (lev : int) (rng : Range.t) : mono_type =\n let fid = FreeID.fresh ~message:\"fresh_type_variable\" lev in\n let mtvu = ref (Free(fid)) in\n let ty = (rng, TypeVar(Updatable(mtvu))) in\n(*\n let name = nameopt |> Option.map (fun x -> x ^ \" : \") |> Option.value ~default:\"\" in\n Format.printf \"GEN %sL%d %a :: %a\\n\" name lev pp_mono_type ty pp_mono_base_kind mbkd; (* for debug *)\n*)\n ty\n\n\nlet fresh_row_variable (lev : int) (labset : LabelSet.t) : mono_row =\n let frid = FreeRowID.fresh ~message:\"fresh_row_variable\" lev in\n KindStore.register_free_row frid labset;\n let mrvu = ref (FreeRow(frid)) in\n RowVar(UpdatableRow(mrvu))\n\n\nlet check_properly_used (tyenv : Typeenv.t) ((rng, x) : identifier ranged) =\n match tyenv |> Typeenv.is_val_properly_used x with\n | None -> assert false\n | Some(true) -> ()\n | Some(false) -> Logging.warn_val_not_used rng x\n\n\nlet get_space_name (rng : Range.t) (m : module_name) : space_name =\n match OutputIdentifier.space_of_module_name m with\n | None -> raise_error (InvalidIdentifier(rng, m))\n | Some(sname) -> sname\n\n\nlet generate_local_name (rng : Range.t) (x : identifier) : local_name =\n match OutputIdentifier.generate_local x with\n | None -> raise_error (InvalidIdentifier(rng, x))\n | Some(lname) -> lname\n\n\nlet generate_global_name ~(is_test_suite : bool) ~(arity : int) ~(has_option : bool) (rng : Range.t) (x : identifier) : global_name =\n let suffix = if is_test_suite then \"_test_\" else \"\" in\n match OutputIdentifier.generate_global x ~suffix:suffix ~arity:arity ~has_option:has_option with\n | None -> raise_error (InvalidIdentifier(rng, x))\n | Some(gname) -> gname\n\n\nlet local_name_scheme letbind =\n let (rngv, x) = letbind.vb_identifier in\n let lname_inner = generate_local_name rngv x in\n let lname_outer = OutputIdentifier.fresh () in\n (lname_inner, lname_outer)\n\n\nlet global_name_scheme (is_test_suite : bool) valbind =\n let arity = List.length valbind.vb_parameters + List.length valbind.vb_mandatories in\n let has_option = (List.length valbind.vb_optionals > 0) in\n let (rngv, x) = valbind.vb_identifier in\n let gname = generate_global_name ~is_test_suite ~arity:arity ~has_option:has_option rngv x in\n (gname, gname)\n\n\nlet types_of_format (lev : int) (fmtelems : format_element list) : mono_type list =\n fmtelems |> List.map (function\n | FormatHole(hole, _) ->\n let rng = Range.dummy \"format\" in\n let ty =\n match hole with\n | HoleC ->\n (rng, BaseType(CharType))\n\n | HoleF\n | HoleE\n | HoleG ->\n (rng, BaseType(FloatType))\n\n | HoleS ->\n (rng, BaseType(BinaryType))\n\n | HoleP\n | HoleW ->\n fresh_type_variable lev rng\n in\n [ ty ]\n\n | FormatConst(_)\n | FormatDQuote\n | FormatBreak\n | FormatTilde ->\n []\n\n ) |> List.concat\n\n\nlet type_of_base_constant (lev : int) (rng : Range.t) (bc : base_constant) =\n match bc with\n | Unit -> (rng, BaseType(UnitType))\n | Bool(_) -> (rng, BaseType(BoolType))\n | Int(_) -> (rng, BaseType(IntType))\n | Float(_) -> (rng, BaseType(FloatType))\n | BinaryByString(_)\n | BinaryByInts(_) -> (rng, BaseType(BinaryType))\n | String(_) -> Primitives.list_type rng (Range.dummy \"string_literal\", BaseType(CharType))\n | Char(_) -> (rng, BaseType(CharType))\n\n | FormatString(fmtelems) ->\n let tyarg =\n match types_of_format lev fmtelems with\n | [] -> (Range.dummy \"format\", BaseType(UnitType))\n | ty1 :: tys -> (Range.dummy \"format\", ProductType(TupleList.make ty1 tys))\n in\n Primitives.format_type rng tyarg\n\n\nlet rec unify_aux (ty1 : mono_type) (ty2 : mono_type) : (unit, unification_error) result =\n let open ResultMonad in\n let (_, ty1main) = ty1 in\n let (_, ty2main) = ty2 in\n match (ty1main, ty2main) with\n | (TypeVar(Updatable{contents = Link(ty1l)}), _) ->\n unify_aux ty1l ty2\n\n | (_, TypeVar(Updatable{contents = Link(ty2l)})) ->\n unify_aux ty1 ty2l\n\n | (TypeVar(MustBeBound(mbbid1)), TypeVar(MustBeBound(mbbid2))) ->\n if MustBeBoundID.equal mbbid1 mbbid2 then\n return ()\n else\n err Contradiction\n\n | (TypeApp(tyid1, tyargs1), TypeApp(tyid2, tyargs2)) ->\n if TypeID.equal tyid1 tyid2 then\n unify_aux_list tyargs1 tyargs2\n else\n err Contradiction\n\n | (BaseType(bt1), BaseType(bt2)) ->\n if bt1 = bt2 then\n return ()\n else\n err Contradiction\n\n | (FuncType(domain1, ty1cod), FuncType(domain2, ty2cod)) ->\n unify_aux_domain domain1 domain2 >>= fun () ->\n unify_aux ty1cod ty2cod\n\n | (EffType(domain1, eff1, tysub1), EffType(domain2, eff2, tysub2)) ->\n unify_aux_domain domain1 domain2 >>= fun () ->\n unify_aux_effect eff1 eff2 >>= fun () ->\n unify_aux tysub1 tysub2\n\n | (PidType(pidty1), PidType(pidty2)) ->\n unify_aux_pid_type pidty1 pidty2\n\n | (ProductType(tys1), ProductType(tys2)) ->\n unify_aux_list (tys1 |> TupleList.to_list) (tys2 |> TupleList.to_list)\n\n | (RecordType(row1), RecordType(row2)) ->\n unify_aux_row row1 row2\n\n | (PackType(absmodsig1), PackType(absmodsig2)) ->\n begin\n try\n subtype_abstract_with_abstract\n ~cause:(Range.dummy \"unify1\")\n ~address:Address.root\n absmodsig1 absmodsig2;\n subtype_abstract_with_abstract\n ~cause:(Range.dummy \"unify2\")\n ~address:Address.root\n absmodsig2 absmodsig1;\n return ()\n with\n | _ ->\n err Contradiction\n end\n\n | (TypeVar(Updatable({contents = Free(fid1)} as mtvu1)), TypeVar(Updatable{contents = Free(fid2)})) ->\n if FreeID.equal fid1 fid2 then\n return ()\n else begin\n mtvu1 := Link(ty2);\n return ()\n end\n\n | (TypeVar(Updatable({contents = Free(fid1)} as mtvu1)), _) ->\n unify_aux_free_id_and_record fid1 mtvu1 ty2\n\n | (_, TypeVar(Updatable({contents = Free(fid2)} as mtvu2))) ->\n unify_aux_free_id_and_record fid2 mtvu2 ty1\n\n | _ ->\n err Contradiction\n\n\nand unify_aux_free_id_and_record (fid1 : FreeID.t) (mtvu1 : mono_type_var_updatable ref) (ty2 : mono_type) =\n let open ResultMonad in\n let b = occurs fid1 ty2 in\n if b then\n err @@ Inclusion(fid1)\n else begin\n mtvu1 := Link(ty2);\n return ()\n end\n\n\nand unify_aux_list tys1 tys2 =\n let open ResultMonad in\n try\n List.fold_left2 (fun res ty1 ty2 ->\n res >>= fun () ->\n unify_aux ty1 ty2\n ) (return ()) tys1 tys2\n with\n | Invalid_argument(_) ->\n err Contradiction\n\n\nand unify_aux_domain domain1 domain2 =\n let open ResultMonad in\n let {ordered = ty1doms; mandatory = mndlabmap1; optional = optrow1} = domain1 in\n let {ordered = ty2doms; mandatory = mndlabmap2; optional = optrow2} = domain2 in\n unify_aux_list ty1doms ty2doms >>= fun () ->\n unify_aux_label_assoc_exact mndlabmap1 mndlabmap2 >>= fun () ->\n unify_aux_row optrow1 optrow2\n\n\nand unify_aux_effect (Effect(ty1)) (Effect(ty2)) =\n unify_aux ty1 ty2\n\n\nand unify_aux_pid_type (Pid(ty1)) (Pid(ty2)) =\n unify_aux ty1 ty2\n\n\nand unify_aux_row (row1 : mono_row) (row2 : mono_row) =\n let open ResultMonad in\n match (row1, row2) with\n | (RowVar(UpdatableRow{contents = LinkRow(row1sub)}), _) ->\n unify_aux_row row1sub row2\n\n | (_, RowVar(UpdatableRow{contents = LinkRow(row2sub)})) ->\n unify_aux_row row1 row2sub\n\n | (RowVar(UpdatableRow({contents = FreeRow(frid1)} as mtvu1)), RowVar(UpdatableRow{contents = FreeRow(frid2)})) ->\n if FreeRowID.equal frid1 frid2 then\n return ()\n else begin\n let labset1 = KindStore.get_free_row frid1 in\n let labset2 = KindStore.get_free_row frid2 in\n let labset = LabelSet.union labset1 labset2 in\n mtvu1 := LinkRow(row2);\n KindStore.register_free_row frid2 labset;\n return ()\n end\n\n | (RowVar(UpdatableRow({contents = FreeRow(frid1)} as mrvu1)), _) ->\n if occurs_row frid1 row2 then\n err @@ InclusionRow(frid1)\n else begin\n let labset1 = KindStore.get_free_row frid1 in\n solve_disjointness_aux row2 labset1 >>= fun () ->\n mrvu1 := LinkRow(row2);\n return ()\n end\n\n | (_, RowVar(UpdatableRow({contents = FreeRow(frid2)} as mrvu2))) ->\n if occurs_row frid2 row1 then\n err @@ InclusionRow(frid2)\n else begin\n let labset2 = KindStore.get_free_row frid2 in\n solve_disjointness_aux row1 labset2 >>= fun () ->\n mrvu2 := LinkRow(row1);\n return ()\n end\n\n | (RowVar(MustBeBoundRow(mbbrid1)), RowVar(MustBeBoundRow(mbbrid2))) ->\n if MustBeBoundRowID.equal mbbrid1 mbbrid2 then\n return ()\n else\n err Contradiction\n\n | (RowVar(MustBeBoundRow(_)), _)\n | (_, RowVar(MustBeBoundRow(_))) ->\n err Contradiction\n\n | (RowCons((rng, label), ty, row1sub), _) ->\n solve_membership_aux rng label ty row2 >>= fun row2rest ->\n unify_aux_row row1sub row2rest\n\n | (RowEmpty, RowEmpty) ->\n return ()\n\n | (RowEmpty, RowCons(_, _, _)) ->\n err Contradiction\n\n\n(* Check that `labmap2` is more specific than or equal to `labmap1`,\n i.e., the domain of `labmap1` is contained in that of `labmap2`. *)\nand unify_aux_label_assoc_subtype ~specific:labmap2 ~general:labmap1 =\n let open ResultMonad in\n LabelAssoc.fold (fun label ty1 res ->\n res >>= fun () ->\n match labmap2 |> LabelAssoc.find_opt label with\n | None -> err Contradiction\n | Some(ty2) -> unify_aux ty1 ty2\n ) labmap1 (return ())\n\n\nand unify_aux_label_assoc_exact labmap1 labmap2 =\n let open ResultMonad in\n let merged =\n LabelAssoc.merge (fun _ tyopt1 tyopt2 ->\n match (tyopt1, tyopt2) with\n | (None, None) -> None\n | (Some(ty1), Some(ty2)) -> Some(unify_aux ty1 ty2)\n | _ -> Some(err Contradiction)\n ) labmap1 labmap2\n in\n LabelAssoc.fold (fun _ res resacc -> resacc >>= fun () -> res) merged (return ())\n\n\nand unify_aux_label_assoc_intersection labmap1 labmap2 =\n let open ResultMonad in\n let intersection =\n LabelAssoc.merge (fun _ opt1 opt2 ->\n match (opt1, opt2) with\n | (Some(ty1), Some(ty2)) -> Some((ty1, ty2))\n | _ -> None\n ) labmap1 labmap2\n in\n LabelAssoc.fold (fun label (ty1, ty2) res ->\n res >>= fun () ->\n unify_aux ty1 ty2\n ) intersection (return ())\n\n\n(* Solves the constraint that `label : ty` is a field of `row`.\n Returns `Ok(row_rest)` if the constraint is solved where `row_rest` stands for the other fields. *)\nand solve_membership_aux (rng : Range.t) (label : label) (ty : mono_type) (row : mono_row) : (mono_row, unification_error) result =\n let open ResultMonad in\n match row with\n | RowCons((rng0, label0), ty0, row0) ->\n if String.equal label0 label then\n unify_aux ty0 ty >>= fun () ->\n return row0\n else\n solve_membership_aux rng label ty row0 >>= fun row0rest ->\n return @@ RowCons((rng0, label0), ty0, row0rest)\n\n | RowVar(UpdatableRow{contents = LinkRow(row0)}) ->\n solve_membership_aux rng label ty row0\n\n | RowVar(UpdatableRow({contents = FreeRow(frid0)} as mrvu0)) ->\n let labset0 = KindStore.get_free_row frid0 in\n if labset0 |> LabelSet.mem label then\n err Contradiction (* TODO (error): reject for the disjointness *)\n else begin\n let lev = FreeRowID.get_level frid0 in\n let frid1 = FreeRowID.fresh ~message:\"solve_membership_aux\" lev in\n KindStore.register_free_row frid1 LabelSet.empty;\n let mrvu1 = ref (FreeRow(frid1)) in\n let row_rest = RowVar(UpdatableRow(mrvu1)) in\n let row_new = RowCons((rng, label), ty, row_rest) in\n mrvu0 := LinkRow(row_new);\n return row_rest\n end\n\n | RowVar(MustBeBoundRow(_)) ->\n err Contradiction (* TODO (error): solve_membership_aux, reject for must-be-bound row IDs *)\n\n | RowEmpty ->\n err Contradiction (* TODO (error): solve_membership_aux, RowEmpty *)\n\n\n(* Solves the constraint that `row` does not have any label in `labset`. *)\nand solve_disjointness_aux (row : mono_row) (labset : LabelSet.t) =\n let open ResultMonad in\n match row with\n | RowCons((rng, label), ty, rowsub) ->\n if labset |> LabelSet.mem label then\n err Contradiction\n else\n solve_disjointness_aux rowsub labset\n\n | RowVar(UpdatableRow{contents = LinkRow(rowsub)}) ->\n solve_disjointness_aux rowsub labset\n\n | RowVar(UpdatableRow{contents = FreeRow(frid0)}) ->\n let labset0 = KindStore.get_free_row frid0 in\n KindStore.register_free_row frid0 (LabelSet.union labset0 labset);\n return ()\n\n | RowVar(MustBeBoundRow(mbbrid0)) ->\n let labset0 = KindStore.get_bound_row (MustBeBoundRowID.to_bound mbbrid0) in\n if LabelSet.subset labset labset0 then\n return ()\n else\n err @@ InsufficientRowConstraint{ id = mbbrid0; given = labset0; required = labset; }\n\n | RowEmpty ->\n return ()\n\n\nand unify (tyact : mono_type) (tyexp : mono_type) : unit =\n let res = unify_aux tyact tyexp in\n match res with\n | Ok(()) -> ()\n | Error(e) -> raise_error (UnificationError{ actual = tyact; expected = tyexp; detail = e; })\n\n\nand unify_effect (Effect(tyact) : mono_effect) (Effect(tyexp) : mono_effect) : unit =\n let res = unify_aux tyact tyexp in\n match res with\n | Ok(()) -> ()\n | Error(e) -> raise_error (UnificationError{ actual = tyact; expected = tyexp; detail = e; })\n\n\nand make_rec_initial_type_from_annotation (preL : pre) (letbind : untyped_let_binding) : pre * poly_type option =\n let (rngv, x) = letbind.vb_identifier in\n let ordparams = letbind.vb_parameters in\n let mndparams = letbind.vb_mandatories in\n let optparams = letbind.vb_optionals in\n\n (* First, add local type/row parameters at level `levS`. *)\n let preS =\n let (pre, _assoc) = make_type_parameter_assoc preL letbind.vb_forall in\n let levS = pre.level + 1 in\n let preS = { pre with level = levS } in\n preS |> add_local_row_parameter letbind.vb_forall_row\n in\n\n let ptyopt =\n let open OptionMonad in\n\n ordparams |> List.fold_left (fun opt ordparam ->\n opt >>= fun tyacc ->\n let (_, mtyopt) = ordparam in\n mtyopt |> Option.map (fun mty ->\n let ty = decode_manual_type preS mty in\n Alist.extend tyacc ty\n )\n ) (Some(Alist.empty)) >>= fun ordtyacc ->\n\n mndparams |> List.fold_left (fun opt mndparam ->\n opt >>= fun labmap ->\n let ((rnglabel, label), (_, mtyopt)) = mndparam in\n if labmap |> LabelAssoc.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n mtyopt |> Option.map (fun mty ->\n let ty = decode_manual_type preS mty in\n labmap |> LabelAssoc.add label ty\n )\n ) (Some(LabelAssoc.empty)) >>= fun mndlabmap ->\n\n optparams |> List.fold_left (fun opt optparam ->\n opt >>= fun (labset_defined, row) ->\n let (((rnglabel, label), (_, mtyopt)), _) = optparam in\n if labset_defined |> LabelSet.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n mtyopt |> Option.map (fun mty ->\n let ty = decode_manual_type preS mty in\n let row = RowCons((rnglabel, label), ty, row) in\n let labset_defined = labset_defined |> LabelSet.add label in\n (labset_defined, row)\n )\n ) (Some((LabelSet.empty, RowEmpty))) >>= fun (_, row) ->\n\n let domty =\n {\n ordered = Alist.to_list ordtyacc;\n mandatory = mndlabmap;\n optional = row;\n }\n in\n let tyopt =\n match letbind.vb_return with\n | Pure((mtyopt, _)) ->\n mtyopt |> Option.map (fun mtycod ->\n let tycod = decode_manual_type preS mtycod in\n (rngv, FuncType(domty, tycod))\n )\n\n | Effectful((mtypairopt, _)) ->\n mtypairopt |> Option.map (fun (mtyeff, mtycod) ->\n let tyeff = decode_manual_type preS mtyeff in\n let tycod = decode_manual_type preS mtycod in\n (rngv, EffType(domty, Effect(tyeff), tycod))\n )\n in\n tyopt |> Option.map (TypeConv.generalize preL.level)\n in\n (preS, ptyopt)\n\n\nand make_type_parameter_assoc (pre : pre) (tyvarnms : type_variable_binder list) : pre * type_parameter_assoc =\n tyvarnms |> List.fold_left (fun (pre, assoc) ((rng, tyvarnm), kdannot) ->\n let mbbid = MustBeBoundID.fresh (\"$\" ^ tyvarnm) (pre.level + 1) in\n match assoc |> TypeParameterAssoc.add_last tyvarnm mbbid with\n | None ->\n raise_error (TypeParameterBoundMoreThanOnce(rng, tyvarnm))\n\n | Some(assoc) ->\n let localtyparams = pre.local_type_parameters |> TypeParameterMap.add tyvarnm mbbid in\n let pre = { pre with local_type_parameters = localtyparams } in\n (pre, assoc)\n ) (pre, TypeParameterAssoc.empty)\n\n\nand decode_manual_base_kind (pre : pre) ((rng, mnbkdmain) : manual_base_kind) : base_kind =\n match mnbkdmain with\n | MKindName(kdnm) ->\n begin\n match kdnm with\n | \"o\" -> TypeKind\n | _ -> raise_error (UndefinedKindName(rng, kdnm))\n end\n\n\nand decode_manual_kind (pre : pre) (mnkd : manual_kind) : kind =\n match mnkd with\n | (_, MKind(mnbkddoms, mnbkdcod)) ->\n let bkddoms = mnbkddoms |> List.map (decode_manual_base_kind pre) in\n let bkdcod = decode_manual_base_kind pre mnbkdcod in\n Kind(bkddoms, bkdcod)\n\n\nand decode_manual_type (pre : pre) (mty : manual_type) : mono_type =\n\n let tyenv = pre.tyenv in\n let typarams = pre.local_type_parameters in\n let rowparams = pre.local_row_parameters in\n\n let invalid rng tynm ~expect:len_expected ~actual:len_actual =\n raise_error (InvalidNumberOfTypeArguments(rng, tynm, len_expected, len_actual))\n in\n\n let aux_labeled_list =\n decode_manual_record_type pre\n in\n\n let rec aux (rng, mtymain) =\n let tymain =\n match mtymain with\n | MTypeName(tynm, mtyargs) ->\n let tyargs = mtyargs |> List.map aux in\n let len_actual = List.length tyargs in\n begin\n match tyenv |> Typeenv.find_type tynm with\n | None ->\n begin\n match (tynm, tyargs) with\n | (\"unit\", []) -> BaseType(UnitType)\n | (\"unit\", _) -> invalid rng \"unit\" ~expect:0 ~actual:len_actual\n | (\"bool\", []) -> BaseType(BoolType)\n | (\"bool\", _) -> invalid rng \"bool\" ~expect:0 ~actual:len_actual\n | (\"int\", []) -> BaseType(IntType)\n | (\"int\", _) -> invalid rng \"int\" ~expect:0 ~actual:len_actual\n | (\"float\", []) -> BaseType(FloatType)\n | (\"float\", _) -> invalid rng \"float\" ~expect:0 ~actual:len_actual\n | (\"binary\", []) -> BaseType(BinaryType)\n | (\"binary\", _) -> invalid rng \"binary\" ~expect:0 ~actual:len_actual\n | (\"char\", []) -> BaseType(CharType)\n | (\"char\", _) -> invalid rng \"char\" ~expect:0 ~actual:len_actual\n | (\"pid\", [ty]) -> PidType(Pid(ty))\n | (\"pid\", _) -> invalid rng \"pid\" ~expect:1 ~actual:len_actual\n | _ -> raise_error (UndefinedTypeName(rng, tynm))\n end\n\n | Some(tentry) ->\n let len_expected = TypeConv.arity_of_kind tentry.type_kind in\n let tyscheme =\n let (bids, tybody, _) = tentry.type_scheme in\n (bids, tybody)\n in\n begin\n match TypeConv.apply_type_scheme_mono tyscheme tyargs with\n | Some((_, tymain)) -> tymain\n | None -> invalid rng tynm ~expect:len_expected ~actual:len_actual\n end\n end\n\n | MFuncType((mtydoms, mndlabmtys, mrow), mtycod) ->\n let mndlabmap = aux_labeled_list mndlabmtys in\n let optrow = aux_row mrow in\n FuncType({ordered = List.map aux mtydoms; mandatory = mndlabmap; optional = optrow}, aux mtycod)\n\n | MProductType(mtys) ->\n ProductType(TupleList.map aux mtys)\n\n | MRecordType(mrow) ->\n let row = aux_row mrow in\n RecordType(row)\n\n | MEffType((mtydoms, mndlabmtys, mrow), mty1, mty2) ->\n let mndlabmap = aux_labeled_list mndlabmtys in\n let optrow = aux_row mrow in\n let domain = {ordered = List.map aux mtydoms; mandatory = mndlabmap; optional = optrow} in\n EffType(domain, Effect(aux mty1), aux mty2)\n\n | MTypeVar(typaram) ->\n begin\n match typarams |> TypeParameterMap.find_opt typaram with\n | None ->\n raise_error (UnboundTypeParameter(rng, typaram))\n\n | Some(mbbid) ->\n TypeVar(MustBeBound(mbbid))\n end\n\n | MModProjType(utmod1, tyident2, mtyargs) ->\n let (rng2, tynm2) = tyident2 in\n let (absmodsig1, _) = typecheck_module ~address:Address.root tyenv utmod1 in\n let (quant1, modsig1) = absmodsig1 in\n begin\n match modsig1 with\n | (_, ConcFunctor(_)) ->\n let (rng1, _) = utmod1 in\n raise_error (NotOfStructureType(rng1, modsig1))\n\n | (_, ConcStructure(sigr)) ->\n begin\n match sigr |> SigRecord.find_type tynm2 with\n | None ->\n raise_error (UndefinedTypeName(rng2, tynm2))\n\n | Some(tentry2) ->\n let tyargs = mtyargs |> List.map aux in\n let len_actual = List.length tyargs in\n let len_expected = TypeConv.arity_of_kind tentry2.type_kind in\n let tyscheme =\n let (bids, tybody, _) = tentry2.type_scheme in\n (bids, tybody)\n in\n begin\n match TypeConv.apply_type_scheme_mono tyscheme tyargs with\n | Some((_, tymain) as ty) ->\n if opaque_occurs_in_mono_type quant1 ty then\n (* Combining (T-Path) and the second premise “Γ ⊢ Σ : Ω” of (P-Mod)\n in the original paper “F-ing modules” [Rossberg, Russo & Dreyer 2014],\n we must assert that opaque type variables do not extrude their scope. *)\n raise_error (OpaqueIDExtrudesScopeViaType(rng, tentry2))\n else\n tymain\n\n | None ->\n invalid rng tynm2 ~expect:len_expected ~actual:len_actual\n end\n end\n end\n\n | MPackType(utsig) ->\n let absmodsig = typecheck_signature ~address:Address.root tyenv utsig in\n PackType(absmodsig)\n in\n (rng, tymain)\n\n and aux_row (mrow : manual_row) : mono_row =\n match mrow with\n | MRow(optlabmtys, rowvar_opt) ->\n let row_last =\n match rowvar_opt with\n | None ->\n RowEmpty\n\n | Some((rng, rowparam)) ->\n begin\n match rowparams |> RowParameterMap.find_opt rowparam with\n | None ->\n raise_error (UnboundRowParameter(rng, rowparam))\n\n | Some((mbbrid, _)) ->\n RowVar(MustBeBoundRow(mbbrid))\n end\n in\n optlabmtys |> List.fold_left (fun row_acc (rlabel, mty) ->\n let ty = aux mty in\n RowCons(rlabel, ty, row_acc)\n ) row_last\n\n in\n aux mty\n\n\nand decode_manual_record_type (pre : pre) (labmtys : labeled_manual_type list) : mono_type LabelAssoc.t =\n let aux = decode_manual_type pre in\n labmtys |> List.fold_left (fun labmap (rlabel, mty) ->\n let (rnglabel, label) = rlabel in\n if labmap |> LabelAssoc.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n let ty = aux mty in\n labmap |> LabelAssoc.add label ty\n ) LabelAssoc.empty\n\n\nand add_local_row_parameter (rowvars : (row_variable_name ranged * (label ranged) list) list) (pre : pre) : pre =\n rowvars |> List.fold_left (fun pre ((rng, rowvarnm), mkind) ->\n let rowparams = pre.local_row_parameters in\n if rowparams |> RowParameterMap.mem rowvarnm then\n raise_error (RowParameterBoundMoreThanOnce(rng, rowvarnm))\n else\n let mbbrid = MustBeBoundRowID.fresh (\"?$\" ^ rowvarnm) pre.level in\n let labset =\n mkind |> List.fold_left (fun labset rlabel ->\n let (rnglabel, label) = rlabel in\n if labset |> LabelSet.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n labset |> LabelSet.add label\n ) LabelSet.empty\n in\n KindStore.register_bound_row (MustBeBoundRowID.to_bound mbbrid) labset;\n let rowparams = rowparams |> RowParameterMap.add rowvarnm (mbbrid, labset) in\n { pre with local_row_parameters = rowparams }\n ) pre\n\n\nand decode_type_annotation_or_fresh (pre : pre) (((rng, x), tyannot) : binder) : mono_type =\n match tyannot with\n | None ->\n fresh_type_variable ~name:x pre.level rng\n\n | Some(mty) ->\n decode_manual_type pre mty\n\n\nand decode_parameter (pre : pre) (binder : binder) : mono_type * pattern * binding_map =\n let (utpat, _) = binder in\n let (typat, ipat, bindmap) = typecheck_pattern pre utpat in\n let tydom = decode_type_annotation_or_fresh pre binder in\n unify typat tydom;\n (tydom, ipat, bindmap)\n\n\nand add_binding_map_to_type_environment (bindmap : binding_map) (tyenv : Typeenv.t) : Typeenv.t =\n BindingMap.fold (fun x (ty, lname, _) tyenv ->\n tyenv |> Typeenv.add_value x (TypeConv.lift ty) (OutputIdentifier.Local(lname))\n ) bindmap tyenv\n\n\nand add_ordered_parameters_to_type_environment (pre : pre) (binders : binder list) : Typeenv.t * mono_type list * pattern list =\n let (tyenv, ipatacc, tydomacc) =\n List.fold_left (fun (tyenv, ipatacc, ptydomacc) binder ->\n let (tydom, ipat, bindmap) = decode_parameter pre binder in\n let tyenv = tyenv |> add_binding_map_to_type_environment bindmap in\n (tyenv, Alist.extend ipatacc ipat, Alist.extend ptydomacc tydom)\n ) (pre.tyenv, Alist.empty, Alist.empty) binders\n in\n let ipats = ipatacc |> Alist.to_list in\n let tydoms = tydomacc |> Alist.to_list in\n (tyenv, tydoms, ipats)\n\n\nand add_labeled_optional_parameters_to_type_environment (pre : pre) (optbinders : (labeled_binder * untyped_ast option) list) : Typeenv.t * mono_row * (pattern * ast option) LabelAssoc.t =\n optbinders |> List.fold_left (fun (tyenv, optrow, optipatmap) ((rlabel, binder), utdefault) ->\n let (rnglabel, label) = rlabel in\n if optipatmap |> LabelAssoc.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n let (ty_inner, ipat, bindmap) = decode_parameter pre binder in\n let (ty_outer, default) =\n match utdefault with\n | None ->\n let ty_outer = fresh_type_variable pre.level (Range.dummy \"optional\") in\n unify ty_inner (Primitives.option_type (Range.dummy \"option\") ty_outer);\n (ty_outer, None)\n\n | Some(utast) ->\n let (ty, e) = typecheck pre utast in\n unify ty_inner ty;\n (ty_inner, Some(e))\n in\n let optrow = RowCons(rlabel, ty_outer, optrow) in\n let tyenv = tyenv |> add_binding_map_to_type_environment bindmap in\n let optipatmap = optipatmap |> LabelAssoc.add label (ipat, default) in\n (tyenv, optrow, optipatmap)\n ) (pre.tyenv, RowEmpty, LabelAssoc.empty)\n\n\nand add_labeled_mandatory_parameters_to_type_environment (pre : pre) (mndbinders : labeled_binder list) : Typeenv.t * mono_type LabelAssoc.t * pattern LabelAssoc.t =\n mndbinders |> List.fold_left (fun (tyenv, labmap, optipatmap) (rlabel, binder) ->\n let (rnglabel, label) = rlabel in\n if labmap |> LabelAssoc.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n let (ty, ipat, bindmap) = decode_parameter pre binder in\n let labmap = labmap |> LabelAssoc.add label ty in\n let tyenv = tyenv |> add_binding_map_to_type_environment bindmap in\n let optipatmap = optipatmap |> LabelAssoc.add label ipat in\n (tyenv, labmap, optipatmap)\n ) (pre.tyenv, LabelAssoc.empty, LabelAssoc.empty)\n\n\nand add_parameters_to_type_environment (pre : pre) ((ordbinders, mndbinders, optbinders) : untyped_parameters) =\n let (tyenv, tydoms, ordnames) =\n add_ordered_parameters_to_type_environment pre ordbinders\n in\n let (tyenv, mndlabmap, mndnamemap) =\n add_labeled_mandatory_parameters_to_type_environment { pre with tyenv } mndbinders\n in\n let (tyenv, optrow, optnamemap) =\n add_labeled_optional_parameters_to_type_environment { pre with tyenv } optbinders\n in\n let domain = {ordered = tydoms; mandatory = mndlabmap; optional = optrow} in\n let ibinders = (ordnames, mndnamemap, optnamemap) in\n (tyenv, domain, ibinders)\n\n\nand typecheck (pre : pre) ((rng, utastmain) : untyped_ast) : mono_type * ast =\n match utastmain with\n | BaseConst(bc) ->\n let ty = type_of_base_constant pre.level rng bc in\n (ty, IBaseConst(bc))\n\n | Var(modidents1, (rng2, x2)) ->\n begin\n match modidents1 with\n | [] ->\n begin\n match pre.tyenv |> Typeenv.find_value x2 with\n | None ->\n raise_error (UnboundVariable(rng2, x2))\n\n | Some((_, ptymain), name) ->\n let pty = (rng, ptymain) in\n let ty = TypeConv.instantiate pre.level pty in\n (ty, IVar(name))\n end\n\n | modident :: projs ->\n let sigr1 = get_structure_signature pre.tyenv modident projs in\n(*\n let (quant1, modsig1) = absmodsig1 in\n*)\n begin\n match sigr1 |> SigRecord.find_value x2 with\n | None ->\n raise_error (UnboundVariable(rng2, x2))\n\n | Some(ventry) ->\n let (_, ptymain2) = ventry.val_type in\n let gname2 = ventry.val_global in\n let pty2 = (rng, ptymain2) in\n(*\n if opaque_occurs_in_poly_type quant1 pty2 then\n (* Combining (E-Path) and the second premise “Γ ⊢ Σ : Ω” of (P-Mod)\n in the original paper “F-ing modules” [Rossberg, Russo & Dreyer 2014],\n we must assert that opaque type variables do not extrude their scope.\n *)\n raise_error (OpaqueIDExtrudesScopeViaValue(rng, pty2))\n else\n*)\n let ty = TypeConv.instantiate pre.level pty2 in\n (ty, IVar(OutputIdentifier.Global(gname2)))\n end\n end\n\n | Lambda(binders, utast0) ->\n let (tyenv, domain, ibinders) = add_parameters_to_type_environment pre binders in\n let pre = { pre with tyenv } in\n let (tycod, e0) = typecheck pre utast0 in\n let ty = (rng, FuncType(domain, tycod)) in\n (ty, ilambda ibinders e0)\n\n | LambdaEff(binders, utcomp0) ->\n let (tyenv, domain, ibinders) = add_parameters_to_type_environment pre binders in\n let pre = { pre with tyenv } in\n let ((eff, ty0), e0) = typecheck_computation pre utcomp0 in\n let ty = (rng, EffType(domain, eff, ty0)) in\n (ty, ilambda ibinders e0)\n\n | Apply(utastfun, utargs) ->\n let (tyfun, efun) = typecheck pre utastfun in\n begin\n match TypeConv.canonicalize_root tyfun with\n | (_, FuncType(domain_expected, tyret)) ->\n (* A slight trick for making error messages easier to comprehend. *)\n let iargs = typecheck_arguments_against_domain pre rng utargs domain_expected in\n let tyret =\n let (_, tyretmain) = tyret in\n (rng, tyretmain)\n in\n (tyret, iapply efun domain_expected.optional iargs)\n\n | _ ->\n let (domain, optrow, iargs) = typecheck_arguments pre rng utargs in\n let tyret = fresh_type_variable ~name:\"(Apply)\" pre.level rng in\n unify tyfun (Range.dummy \"Apply\", FuncType(domain, tyret));\n (tyret, iapply efun optrow iargs)\n end\n\n | Freeze(rngapp, frozenfun, utastargs, restrngs) ->\n let (ptyfun, gname) =\n match frozenfun with\n | FrozenModFun(modidentchain1, ident2) ->\n let mentry = find_module_from_chain pre.tyenv modidentchain1 in\n let modsig1 = mentry.mod_signature in\n begin\n match modsig1 with\n | (_, ConcFunctor(_)) ->\n let ((rng1, _), _) = modidentchain1 in\n raise_error (NotOfStructureType(rng1, modsig1))\n\n | (_, ConcStructure(sigr)) ->\n let (rng2, x) = ident2 in\n begin\n match sigr |> SigRecord.find_value x with\n | None -> raise_error (UnboundVariable(rng2, x))\n | Some(ventry) -> (ventry.val_type, ventry.val_global)\n end\n end\n\n | FrozenFun((rng0, x)) ->\n begin\n match pre.tyenv |> Typeenv.find_value x with\n | None ->\n raise_error (UnboundVariable(rng0, x))\n\n | Some((_, ptymain), name) ->\n begin\n match name with\n | OutputIdentifier.Global(gname) -> ((rng0, ptymain), gname)\n | _ -> raise_error (CannotFreezeNonGlobalName(rng0, x))\n end\n end\n in\n let tyfun = TypeConv.instantiate pre.level ptyfun in\n let tyeargs = List.map (typecheck pre) utastargs in\n let tyargs = List.map fst tyeargs in\n let eargs = List.map snd tyeargs in\n let tyrests =\n restrngs |> List.map (fun restrng ->\n fresh_type_variable ~name:\"Freeze, rest\" pre.level restrng\n )\n in\n let tyargsall = List.append tyargs tyrests in\n\n let tyrecv = fresh_type_variable ~name:\"Freeze, recv\" pre.level rng in\n let eff = Effect(tyrecv) in\n let tyret = fresh_type_variable ~name:\"Freeze, ret\" pre.level rng in\n let domain = {ordered = tyargsall; mandatory = LabelAssoc.empty; optional = RowEmpty} in\n unify tyfun (Range.dummy \"Freeze1\", EffType(domain, eff, tyret));\n let tyrest =\n let dr = Range.dummy \"Freeze2\" in\n match tyrests with\n | [] -> (dr, BaseType(UnitType))\n | ty :: tys -> (dr, ProductType(TupleList.make ty tys))\n in\n (Primitives.frozen_type rng ~rest:tyrest ~receive:tyrecv ~return:tyret, IFreeze(gname, eargs))\n\n | FreezeUpdate(utast0, utastargs, restrngs) ->\n let (ty0, e0) = typecheck pre utast0 in\n let tyeargs = List.map (typecheck pre) utastargs in\n let tyargs = List.map fst tyeargs in\n let eargs = List.map snd tyeargs in\n let tyholes =\n restrngs |> List.map (fun restrng ->\n fresh_type_variable ~name:\"FreezeUpdate, rest1\" pre.level restrng\n )\n in\n let tyrecv =\n fresh_type_variable ~name:\"FreezeUpdate, recv\" pre.level (Range.dummy \"FreezeUpdate, recv\")\n in\n let tyret =\n fresh_type_variable ~name:\"FreezeUpdate, ret\" pre.level (Range.dummy \"FreezeUpdate, ret\")\n in\n let ty_expected =\n let tyrest_expected =\n let dr = Range.dummy \"FreezeUpdate, rest2\" in\n match List.append tyargs tyholes with\n | [] -> (dr, BaseType(UnitType))\n | ty :: tys -> (dr, ProductType(TupleList.make ty tys))\n in\n Primitives.frozen_type (Range.dummy \"FreezeUpdate\") ~rest:tyrest_expected ~receive:tyrecv ~return:tyret\n in\n unify ty0 ty_expected;\n let tyrest =\n let dr = Range.dummy \"FreezeUpdate, rest3\" in\n match tyholes with\n | [] -> (dr, BaseType(UnitType))\n | ty :: tys -> (dr, ProductType(TupleList.make ty tys))\n in\n (Primitives.frozen_type rng ~rest:tyrest ~receive:tyrecv ~return:tyret, IFreezeUpdate(e0, eargs))\n\n\n | If(utast0, utast1, utast2) ->\n let (ty0, e0) = typecheck pre utast0 in\n unify ty0 (Range.dummy \"If\", BaseType(BoolType));\n let (ty1, e1) = typecheck pre utast1 in\n let (ty2, e2) = typecheck pre utast2 in\n unify ty1 ty2;\n let ibranches = [ IBranch(IPBool(true), e1); IBranch(IPBool(false), e2) ] in\n (ty1, ICase(e0, ibranches))\n\n | LetIn(NonRec(letbind), utast2) ->\n let (pty, lname, e1) = typecheck_let generate_local_name pre letbind in\n let tyenv =\n let (_, x) = letbind.vb_identifier in\n pre.tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname)) in\n let (ty2, e2) = typecheck { pre with tyenv } utast2 in\n check_properly_used tyenv letbind.vb_identifier;\n (ty2, ILetIn(lname, e1, e2))\n\n | LetIn(Rec(letbinds), utast2) ->\n let proj lname = OutputIdentifier.Local(lname) in\n let binds = typecheck_letrec_mutual local_name_scheme proj pre letbinds in\n let (ty2, e2) =\n let tyenv =\n binds |> List.fold_left (fun tyenv (x, pty, lname_outer, _, _) ->\n tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname_outer))\n ) pre.tyenv\n in\n typecheck { pre with tyenv } utast2\n in\n (ty2, iletrecin binds e2)\n\n | Tuple(utasts) ->\n let tyes = utasts |> TupleList.map (typecheck pre) in\n let tys = tyes |> TupleList.map fst in\n let es = tyes |> TupleList.map snd in\n let ty = (rng, ProductType(tys)) in\n (ty, ITuple(es))\n\n | ListNil ->\n let tysub = fresh_type_variable pre.level (Range.dummy \"list-nil\") in\n let ty = Primitives.list_type rng tysub in\n (ty, IListNil)\n\n | ListCons(utast1, utast2) ->\n let (ty1, e1) = typecheck pre utast1 in\n let (ty2, e2) = typecheck pre utast2 in\n unify ty2 (Primitives.list_type (Range.dummy \"list-cons\") ty1);\n (ty2, IListCons(e1, e2))\n\n | Case(utast0, branches) ->\n let (ty0, e0) = typecheck pre utast0 in\n let tyret = fresh_type_variable pre.level rng in\n let ibrs = branches |> List.map (typecheck_pure_case_branch pre ~pattern:ty0 ~return:tyret) in\n (tyret, ICase(e0, ibrs))\n\n | LetPatIn(utpat, utast1, utast2) ->\n let (tyenv, ipat, bindmap, e1) = typecheck_let_pattern pre rng utpat utast1 in\n let (ty2, e2) = typecheck { pre with tyenv } utast2 in\n check_binding_map_properly_used tyenv bindmap;\n (ty2, iletpatin ipat e1 e2)\n\n | Constructor(modidents, ctornm, utastargs) ->\n let (tyid, ctorid, tyargs, tys_expected) = typecheck_constructor pre rng modidents ctornm in\n begin\n match List.combine utastargs tys_expected with\n | exception Invalid_argument(_) ->\n let len_expected = List.length tys_expected in\n let len_actual = List.length utastargs in\n raise_error (InvalidNumberOfConstructorArguments(rng, ctornm, len_expected, len_actual))\n\n | zipped ->\n let eacc =\n zipped |> List.fold_left (fun eacc (utast, ty_expected) ->\n let (ty, e) = typecheck pre utast in\n unify ty ty_expected;\n Alist.extend eacc e\n ) Alist.empty\n in\n let ty = (rng, TypeApp(tyid, tyargs)) in\n let e = IConstructor(ctorid, Alist.to_list eacc) in\n (ty, e)\n end\n\n | BinaryByList(nrs) ->\n let ns =\n nrs |> List.map (fun (rngn, n) ->\n if 0 <= n && n <= 255 then n else\n raise_error (InvalidByte(rngn))\n )\n in\n ((rng, BaseType(BinaryType)), IBaseConst(BinaryByInts(ns)))\n\n | Record(labasts) ->\n let (emap, row) =\n labasts |> List.fold_left (fun (emap, row) (rlabel, utast) ->\n let (rnglabel, label) = rlabel in\n if emap |> LabelAssoc.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n let (ty, e) = typecheck pre utast in\n let row = RowCons(rlabel, ty, row) in\n let emap = emap |> LabelAssoc.add label e in\n (emap, row)\n ) (LabelAssoc.empty, RowEmpty)\n in\n ((rng, RecordType(row)), IRecord(emap))\n\n | RecordAccess(utast1, ((_, label) as rlabel)) ->\n let (ty1, e1) = typecheck pre utast1 in\n let ty_ret = fresh_type_variable pre.level rng in\n let row_rest = fresh_row_variable pre.level (LabelSet.singleton label) in\n unify ty1 (Range.dummy \"RecordAccess\", RecordType(RowCons(rlabel, ty_ret, row_rest)));\n (ty_ret, IRecordAccess(e1, label))\n\n | RecordUpdate(utast1, ((_, label) as rlabel), utast2) ->\n let (ty1, e1) = typecheck pre utast1 in\n let (ty2, e2) = typecheck pre utast2 in\n let row_rest = fresh_row_variable pre.level (LabelSet.singleton label) in\n unify ty1 (Range.dummy \"RecordUpdate\", RecordType(RowCons(rlabel, ty2, row_rest)));\n (ty1, IRecordUpdate(e1, label, e2))\n\n | Pack(modidentchain1, utsig2) ->\n let mentry = find_module_from_chain pre.tyenv modidentchain1 in\n let modsig1 = mentry.mod_signature in\n let sname1 = mentry.mod_name in\n let absmodsig2 = typecheck_signature ~address:Address.root pre.tyenv utsig2 in\n let absmodsig = coerce_signature ~cause:rng ~address:Address.root modsig1 absmodsig2 in\n ((rng, PackType(absmodsig)), IPack(sname1))\n\n | Assert(utast0) ->\n let (ty0, e0) = typecheck pre utast0 in\n unify ty0 Primitives.assertion_function_type;\n ((rng, BaseType(UnitType)), IAssert(rng, e0))\n\n\nand typecheck_let_pattern (pre : pre) (rng : Range.t) (utpat : untyped_pattern) (utast1 : untyped_ast) =\n let (ty1, e1) = typecheck { pre with level = pre.level + 1 } utast1 in\n let (typat, ipat, bindmap) = typecheck_pattern pre utpat in\n unify ty1 typat;\n let tyenv =\n BindingMap.fold (fun x (ty, lname, _) tyenv ->\n let pty = TypeConv.generalize pre.level ty in\n tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname))\n ) bindmap pre.tyenv\n in\n (tyenv, ipat, bindmap, e1)\n\n\nand typecheck_computation (pre : pre) (utcomp : untyped_computation_ast) : (mono_effect * mono_type) * ast =\n let (rng, utcompmain) = utcomp in\n match utcompmain with\n | CompDo(binder, utcomp1, utcomp2) ->\n let ((eff1, ty1), e1) = typecheck_computation pre utcomp1 in\n let (utpat, _) = binder in\n let tyx = decode_type_annotation_or_fresh pre binder in\n let (typat, ipat, bindmap) = typecheck_pattern pre utpat in\n unify typat tyx;\n unify ty1 tyx;\n let tyenv = pre.tyenv |> add_binding_map_to_type_environment bindmap in\n let ((eff2, ty2), e2) = typecheck_computation { pre with tyenv } utcomp2 in\n unify_effect eff1 eff2;\n let e = ICase(e1, [ IBranch(ipat, e2) ]) in\n ((eff2, ty2), e)\n\n | CompReceive(branches, after_opt) ->\n let lev = pre.level in\n let effexp =\n let ty = fresh_type_variable lev (Range.dummy \"receive-recv\") in\n Effect(ty)\n in\n let tyret = fresh_type_variable lev (Range.dummy \"receive-ret\") in\n let ibrs = branches |> List.map (typecheck_receive_branch pre effexp tyret) in\n let iafter_opt =\n after_opt |> Option.map (fun (utast1, utcomp2) ->\n let (ty1, e1) = typecheck pre utast1 in\n unify ty1 (Range.dummy \"after\", BaseType(IntType));\n let ((eff2, ty2), e2) = typecheck_computation pre utcomp2 in\n unify_effect eff2 effexp;\n unify ty2 tyret;\n (e1, e2)\n )\n in\n ((effexp, tyret), IReceive(ibrs, iafter_opt))\n\n | CompLetIn(NonRec(letbind), utcomp2) ->\n let (pty, lname, e1) = typecheck_let generate_local_name pre letbind in\n let tyenv =\n let (_, x) = letbind.vb_identifier in\n pre.tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname)) in\n let ((eff2, ty2), e2) = typecheck_computation { pre with tyenv } utcomp2 in\n check_properly_used tyenv letbind.vb_identifier;\n ((eff2, ty2), ILetIn(lname, e1, e2))\n\n | CompLetIn(Rec(letbinds), utcomp2) ->\n let proj lname = OutputIdentifier.Local(lname) in\n let binds = typecheck_letrec_mutual local_name_scheme proj pre letbinds in\n let ((eff2, ty2), e2) =\n let tyenv =\n binds |> List.fold_left (fun tyenv (x, pty, lname_outer, _, _) ->\n tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname_outer))\n ) pre.tyenv\n in\n typecheck_computation { pre with tyenv } utcomp2\n in\n ((eff2, ty2), iletrecin binds e2)\n\n | CompLetPatIn(utpat, utast1, utcomp2) ->\n let (tyenv, ipat, bindmap, e1) = typecheck_let_pattern pre rng utpat utast1 in\n let ((eff2, ty2), e2) = typecheck_computation { pre with tyenv } utcomp2 in\n ((eff2, ty2), iletpatin ipat e1 e2)\n\n | CompIf(utast0, utcomp1, utcomp2) ->\n let (ty0, e0) = typecheck pre utast0 in\n unify ty0 (Range.dummy \"If\", BaseType(BoolType));\n let ((eff1, ty1), e1) = typecheck_computation pre utcomp1 in\n let ((eff2, ty2), e2) = typecheck_computation pre utcomp2 in\n unify_effect eff1 eff2;\n unify ty1 ty2;\n let ibranches = [ IBranch(IPBool(true), e1); IBranch(IPBool(false), e2) ] in\n ((eff1, ty1), ICase(e0, ibranches))\n\n | CompCase(utast0, branches) ->\n let (ty0, e0) = typecheck pre utast0 in\n let eff =\n let tyrecv = fresh_type_variable pre.level (Range.dummy \"CompCase1\") in\n Effect(tyrecv)\n in\n let tyret = fresh_type_variable pre.level (Range.dummy \"CompCase2\") in\n let ibrs = branches |> List.map (typecheck_effectful_case_branch pre ~pattern:ty0 ~return:(eff, tyret)) in\n ((eff, tyret), ICase(e0, ibrs))\n\n | CompApply(utastfun, utargs) ->\n let (tyfun, efun) = typecheck pre utastfun in\n let (domain, optrow, iargs) = typecheck_arguments pre rng utargs in\n let eff =\n let tyrecv = fresh_type_variable ~name:\"(CompApply2)\" pre.level rng in\n Effect(tyrecv)\n in\n let tyret = fresh_type_variable ~name:\"(CompApply1)\" pre.level rng in\n unify tyfun (Range.dummy \"CompApply\", EffType(domain, eff, tyret));\n ((eff, tyret), iapply efun optrow iargs)\n\n\nand get_structure_signature (tyenv : Typeenv.t) (modident : module_name ranged) (projs : (module_name ranged) list) : SigRecord.t =\n let (rnginit, _) = modident in\n let mentry = find_module tyenv modident in\n let modsig = mentry.mod_signature in\n let (modsig, rnglast) =\n projs |> List.fold_left (fun (modsig, rnglast) proj ->\n match modsig with\n | (_, ConcFunctor(_)) ->\n raise_error (NotOfStructureType(rnglast, modsig))\n\n | (_, ConcStructure(sigr)) ->\n let (rng, modnm) = proj in\n begin\n match sigr |> SigRecord.find_module modnm with\n | None -> raise_error (UnboundModuleName(rng, modnm))\n | Some(mentry) -> (mentry.mod_signature, rng)\n end\n ) (modsig, rnginit)\n in\n begin\n match modsig with\n | (_, ConcFunctor(_)) -> raise_error (NotOfStructureType(rnglast, modsig))\n | (_, ConcStructure(sigr)) -> sigr\n end\n\n\nand typecheck_arguments (pre : pre) (rng : Range.t) ((utastargs, mndutastargs, optutastargs) : untyped_arguments) =\n let tyeargs = List.map (typecheck pre) utastargs in\n let tyargs = List.map fst tyeargs in\n let eargs = List.map snd tyeargs in\n\n let (mndlabmap, mndargmap) =\n mndutastargs |> List.fold_left (fun (mndlabmap, mndargmap) (rlabel, utast) ->\n let (rnglabel, label) = rlabel in\n if mndlabmap |> LabelAssoc.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n let (ty, e) = typecheck pre utast in\n let mndlabmap = mndlabmap |> LabelAssoc.add label ty in\n let mndargmap = mndargmap |> LabelAssoc.add label e in\n (mndlabmap, mndargmap)\n ) (LabelAssoc.empty, LabelAssoc.empty)\n in\n\n let (optrow, optargmap) =\n let frid = FreeRowID.fresh ~message:\"Apply, row\" pre.level in\n (* Note: the initial kind for `frid` will be assigned after traversing the given optional arguments. *)\n let row_init =\n let mrvu = ref (FreeRow(frid)) in\n RowVar(UpdatableRow(mrvu))\n in\n let (optrow, optlabset, optargmap) =\n optutastargs |> List.fold_left (fun (optrow, optlabset, optargmap) (rlabel, utast) ->\n let (rnglabel, label) = rlabel in\n if optlabset |> LabelSet.mem label then\n raise_error (DuplicatedLabel(rnglabel, label))\n else\n let (ty, e) = typecheck pre utast in\n let optrow = RowCons(rlabel, ty, optrow) in\n let optlabset = optlabset |> LabelSet.add label in\n let optargmap = optargmap |> LabelAssoc.add label e in\n (optrow, optlabset, optargmap)\n ) (row_init, LabelSet.empty, LabelAssoc.empty)\n in\n KindStore.register_free_row frid optlabset;\n(*\n Format.printf \"!!! typecheck_arguments (range: %a, length: %d, optrow: %a)\\n\" Range.pp rng (List.length optutastargs) TypeConv.(pp_mono_row DisplayMap.empty) optrow;\n*)\n (optrow, optargmap)\n in\n\n let domain = {ordered = tyargs; mandatory = mndlabmap; optional = optrow} in\n (domain, optrow, (eargs, mndargmap, optargmap))\n\n\nand typecheck_arguments_against_domain (pre : pre) (rng : Range.t) ((utastargs, mndutastargs, optutastargs) : untyped_arguments) (domain_expected : mono_domain_type) =\n let {ordered = tys_expected; mandatory = mndlabmap_expected; optional = optrow_expected} = domain_expected in\n let eargs =\n let numord_got = List.length utastargs in\n let numord_expected = List.length tys_expected in\n if numord_got = numord_expected then\n List.fold_left2 (fun eargacc utastarg ty_expected ->\n let (ty_got, e) = typecheck pre utastarg in\n unify ty_got ty_expected;\n Alist.extend eargacc e\n ) Alist.empty utastargs tys_expected |> Alist.to_list\n else\n raise_error @@ BadArityOfOrderedArguments{range = rng; got = numord_got; expected = numord_expected}\n in\n let mndargmap =\n let (mndlabmap_rest, mndargmap) =\n mndutastargs |> List.fold_left (fun (mndlabmap_rest, mndargmap) (rlabel, utast) ->\n let (rnglabel, label) = rlabel in\n if mndargmap |> LabelAssoc.mem label then\n raise_error @@ DuplicatedLabel(rnglabel, label)\n else\n match mndlabmap_rest |> LabelAssoc.find_opt label with\n | None ->\n raise_error @@ UnexpectedMandatoryLabel{range = rnglabel; label = label}\n\n | Some(ty_expected) ->\n let (ty_got, e) = typecheck pre utast in\n unify ty_got ty_expected;\n let mndlabmap_rest = mndlabmap_rest |> LabelAssoc.remove label in\n let mndargmap = mndargmap |> LabelAssoc.add label e in\n (mndlabmap_rest, mndargmap)\n\n ) (mndlabmap_expected, LabelAssoc.empty)\n in\n match mndlabmap_rest |> LabelAssoc.bindings with\n | [] -> mndargmap\n | (label, ty) :: _ -> raise_error @@ MissingMandatoryLabel{range = rng; label = label; typ = ty}\n in\n let optargmap =\n let NormalizedRow(labmap_known, rowvar_opt) = TypeConv.normalize_mono_row optrow_expected in\n let (all_labset, unknown_labels, optargmap) =\n optutastargs |> List.fold_left (fun (all_labset, unknown_labels, optargmap) (rlabel, utast) ->\n let (rng_label, label) = rlabel in\n if optargmap |> LabelAssoc.mem label then\n raise_error (DuplicatedLabel(rng, label))\n else\n let (ty_got, e) = typecheck pre utast in\n let optargmap = optargmap |> LabelAssoc.add label e in\n let all_labset = all_labset |> LabelSet.add label in\n match labmap_known |> LabelAssoc.find_opt label with\n | None ->\n (all_labset, unknown_labels |> LabelAssoc.add label (rng_label, ty_got), optargmap)\n\n | Some(ty_expected) ->\n unify ty_got ty_expected;\n (all_labset, unknown_labels, optargmap)\n\n ) (LabelSet.empty, LabelAssoc.empty, LabelAssoc.empty)\n in\n\n begin\n match LabelAssoc.bindings unknown_labels with\n | (label, _) :: _ ->\n begin\n match rowvar_opt with\n | Some(UpdatableRow({contents = FreeRow(frid)} as mrvu)) ->\n let row_unknown =\n let row_init =\n let frid0 = FreeRowID.fresh ~message:\"typecheck_arguments_against_domain\" pre.level in\n KindStore.register_free_row frid0 all_labset;\n let mrvu0 = ref (FreeRow(frid0)) in\n RowVar(UpdatableRow(mrvu0))\n in\n LabelAssoc.fold (fun label (rng, ty) row_acc ->\n RowCons((rng, label), ty, row_acc)\n ) unknown_labels row_init\n in\n(*\n Format.printf \"!!! against_domain (range: %a, unknown: %a, row: %a)\\n\" Range.pp rng (LabelAssoc.pp (fun ppf _ -> Format.fprintf ppf \"_\")) unknown_labels TypeConv.(pp_mono_row DisplayMap.empty) row_unknown;\n*)\n mrvu := LinkRow(row_unknown)\n\n | _ ->\n raise_error @@ UnexpectedOptionalLabel{range = rng; label = label}\n end\n\n | _ ->\n ()\n end;\n optargmap\n in\n (eargs, mndargmap, optargmap)\n\n\nand typecheck_constructor (pre : pre) (rng : Range.t) (modidents : (module_name ranged) list) (ctornm : constructor_name) =\n match modidents with\n | [] ->\n begin\n match pre.tyenv |> Typeenv.find_constructor ctornm with\n | None ->\n raise_error (UndefinedConstructor(rng, ctornm))\n\n | Some(centry) ->\n let tyid = centry.belongs in\n let ctorid = centry.constructor_id in\n let bids = centry.type_variables in\n let ptys = centry.parameter_types in\n let (tyargs, tys_expected) = TypeConv.instantiate_type_arguments pre.level bids ptys in\n (tyid, ctorid, tyargs, tys_expected)\n end\n\n | modident :: projs ->\n let sigr1 = get_structure_signature pre.tyenv modident projs in\n begin\n match sigr1 |> SigRecord.find_constructor ctornm with\n | None ->\n raise_error (UndefinedConstructor(rng, ctornm))\n\n | Some(centry) ->\n let vid = centry.belongs in\n let ctorid = centry.constructor_id in\n let bids = centry.type_variables in\n let ptys = centry.parameter_types in\n let (tyargs, tys_expected) = TypeConv.instantiate_type_arguments pre.level bids ptys in\n (vid, ctorid, tyargs, tys_expected)\n end\n\n\nand typecheck_pure_case_branch (pre : pre) ~pattern:typatexp ~return:tyret (CaseBranch(pat, utast1)) =\n let (typat, ipat, bindmap) = typecheck_pattern pre pat in\n let tyenv = pre.tyenv |> add_binding_map_to_type_environment bindmap in\n let (ty1, e1) = typecheck { pre with tyenv } utast1 in\n check_binding_map_properly_used tyenv bindmap;\n unify typat typatexp;\n unify ty1 tyret;\n IBranch(ipat, e1)\n\n\nand typecheck_effectful_case_branch (pre : pre) ~pattern:typatexp ~return:(eff, tyret) (CompCaseBranch(pat, utcomp1)) =\n let (typat, ipat, bindmap) = typecheck_pattern pre pat in\n let tyenv = pre.tyenv |> add_binding_map_to_type_environment bindmap in\n let ((eff1, ty1), e1) = typecheck_computation { pre with tyenv } utcomp1 in\n check_binding_map_properly_used tyenv bindmap;\n unify typat typatexp;\n unify_effect eff1 eff;\n unify ty1 tyret;\n IBranch(ipat, e1)\n\n\nand typecheck_receive_branch (pre : pre) (effexp : mono_effect) (tyret : mono_type) (ReceiveBranch(pat, utcomp1)) =\n let (typat, ipat, bindmap) = typecheck_pattern pre pat in\n let tyenv = pre.tyenv |> add_binding_map_to_type_environment bindmap in\n let ((eff1, ty1), e1) = typecheck_computation { pre with tyenv } utcomp1 in\n check_binding_map_properly_used tyenv bindmap;\n unify_effect (Effect(typat)) effexp;\n unify_effect eff1 effexp;\n unify ty1 tyret;\n IBranch(ipat, e1)\n\n\nand check_binding_map_properly_used (tyenv : Typeenv.t) (bindmap : binding_map) : unit =\n BindingMap.iter (fun x (_, _, rng) ->\n check_properly_used tyenv (rng, x)\n ) bindmap\n\n\nand typecheck_pattern (pre : pre) ((rng, patmain) : untyped_pattern) : mono_type * pattern * binding_map =\n let immediate tymain ipat = ((rng, tymain), ipat, BindingMap.empty) in\n match patmain with\n | PUnit -> immediate (BaseType(UnitType)) IPUnit\n | PBool(b) -> immediate (BaseType(BoolType)) (IPBool(b))\n | PInt(n) -> immediate (BaseType(IntType)) (IPInt(n))\n\n | PBinary(s) -> immediate (BaseType(BinaryType)) (IPBinary(s))\n\n | PChar(uchar) ->\n immediate (BaseType(CharType)) (IPChar(uchar))\n\n | PVar(x) ->\n let ty = fresh_type_variable ~name:x pre.level rng in\n let lname = generate_local_name rng x in\n (ty, IPVar(lname), BindingMap.singleton x (ty, lname, rng))\n\n | PWildCard ->\n let ty = fresh_type_variable ~name:\"_\" pre.level rng in\n (ty, IPWildCard, BindingMap.empty)\n\n | PListNil ->\n let ty =\n let tysub = fresh_type_variable pre.level rng in\n Primitives.list_type rng tysub\n in\n (ty, IPListNil, BindingMap.empty)\n\n | PListCons(pat1, pat2) ->\n let (ty1, ipat1, bindmap1) = typecheck_pattern pre pat1 in\n let (ty2, ipat2, bindmap2) = typecheck_pattern pre pat2 in\n let bindmap = binding_map_union rng bindmap1 bindmap2 in\n unify ty2 (Primitives.list_type (Range.dummy \"pattern-cons\") ty1);\n (ty2, IPListCons(ipat1, ipat2), bindmap)\n\n | PTuple(pats) ->\n let triples = pats |> TupleList.map (typecheck_pattern pre) in\n let tys = triples |> TupleList.map (fun (ty, _, _) -> ty) in\n let ipats = triples |> TupleList.map (fun (_, ipat, _) -> ipat) in\n let bindmaps = triples |> TupleList.map (fun (_, _, bindmap) -> bindmap) in\n let bindmap =\n bindmaps |> TupleList.to_list\n |> List.fold_left (binding_map_union rng) BindingMap.empty\n in\n let ty = (rng, ProductType(tys)) in\n (ty, IPTuple(ipats), bindmap)\n\n | PConstructor(modidents, ctornm, pats) ->\n let (tyid, ctorid, tyargs, tys_expected) = typecheck_constructor pre rng modidents ctornm in\n begin\n try\n let (ipatacc, bindmap) =\n List.fold_left2 (fun (ipatacc, bindmapacc) ty_expected pat ->\n let (ty, ipat, bindmap) = typecheck_pattern pre pat in\n unify ty ty_expected;\n (Alist.extend ipatacc ipat, binding_map_union rng bindmapacc bindmap)\n ) (Alist.empty, BindingMap.empty) tys_expected pats\n in\n let ty = (rng, TypeApp(tyid, tyargs)) in\n (ty, IPConstructor(ctorid, Alist.to_list ipatacc), bindmap)\n with\n | Invalid_argument(_) ->\n let len_expected = List.length tys_expected in\n let len_actual = List.length pats in\n raise_error (InvalidNumberOfConstructorArguments(rng, ctornm, len_expected, len_actual))\n end\n\n\nand typecheck_let : 'n. (Range.t -> identifier -> 'n) -> pre -> untyped_let_binding -> poly_type * 'n * ast =\nfun namef preL letbind ->\n let (rngv, x) = letbind.vb_identifier in\n let ordparams = letbind.vb_parameters in\n let mndparams = letbind.vb_mandatories in\n let optparams = letbind.vb_optionals in\n\n let (ty1, e0, ibinders) =\n\n (* First, add local type/row parameters at level `levS`. *)\n let preS =\n let (preL, _assoc) = make_type_parameter_assoc preL letbind.vb_forall in\n { preL with level = preL.level + 1 } |> add_local_row_parameter letbind.vb_forall_row\n in\n\n (* Second, add local value parameters at level `levS`. *)\n let (tyenv, domain, ibinders) = add_parameters_to_type_environment preS (ordparams, mndparams, optparams) in\n let preS = { preS with tyenv } in\n\n (* Finally, typecheck the body expression. *)\n match letbind.vb_return with\n | Pure((tyretopt, utast0)) ->\n let (ty0, e0) = typecheck preS utast0 in\n tyretopt |> Option.map (fun mty0 ->\n let ty0_expected = decode_manual_type preS mty0 in\n unify ty0 ty0_expected\n ) |> Option.value ~default:();\n let ty1 = (rngv, FuncType(domain, ty0)) in\n (ty1, e0, ibinders)\n\n | Effectful((tyretopt, utcomp0)) ->\n let ((eff0, ty0), e0) = typecheck_computation preS utcomp0 in\n tyretopt |> Option.map (fun (mty1, mty2) ->\n let ty1_expected = decode_manual_type preS mty1 in\n let ty2_expected = decode_manual_type preS mty2 in\n unify_effect eff0 (Effect(ty1_expected));\n unify ty0 ty2_expected\n ) |> Option.value ~default:();\n let ty1 = (rngv, EffType(domain, eff0, ty0)) in\n (ty1, e0, ibinders)\n in\n let e1 = ilambda ibinders e0 in\n let pty1 = TypeConv.generalize preL.level ty1 in\n let name = namef rngv x in\n (pty1, name, e1)\n\n\nand typecheck_letrec_mutual : 'n. (untyped_let_binding -> 'n * 'n) -> ('n -> name) -> pre -> untyped_let_binding list -> (identifier * poly_type * 'n * 'n * ast) list =\nfun namesf proj preL letbinds ->\n\n let levS = preL.level + 1 in\n\n (* Register type variables and names for output corresponding to bound names\n before traversing definitions *)\n let (tupleacc, tyenv) =\n letbinds |> List.fold_left (fun (tupleacc, tyenv) letbind ->\n let (rngv, x) = letbind.vb_identifier in\n let (name_inner, name_outer) = namesf letbind in\n let (preS, ptyopt) = make_rec_initial_type_from_annotation preL letbind in\n let (tyenv, morph) =\n match ptyopt with\n | Some(pty) ->\n let tyenv = tyenv |> Typeenv.add_value x pty (proj name_inner) in\n (tyenv, PolyRec(pty))\n\n | None ->\n let tyf = fresh_type_variable ~name:x levS rngv in\n let tyenv = tyenv |> Typeenv.add_value x (TypeConv.lift tyf) (proj name_inner) in\n (tyenv, MonoRec(tyf))\n in\n (Alist.extend tupleacc (letbind, name_inner, name_outer, morph, preS), tyenv)\n ) (Alist.empty, preL.tyenv)\n in\n\n let bindacc =\n tupleacc |> Alist.to_list |> List.fold_left (fun bindacc (letbind, name_inner, name_outer, morph, preS) ->\n let preS = { preS with tyenv } in\n let (pty, e1) = typecheck_letrec_single preS letbind morph in\n let (_, x) = letbind.vb_identifier in\n Alist.extend bindacc (x, pty, name_outer, name_inner, e1)\n ) Alist.empty\n in\n bindacc |> Alist.to_list\n\n\nand typecheck_letrec_single (preS : pre) (letbind : untyped_let_binding) (morph : rec_morph) : poly_type * ast =\n let (rngv, x) = letbind.vb_identifier in\n let ordparams = letbind.vb_parameters in\n let mndparams = letbind.vb_mandatories in\n let optparams = letbind.vb_optionals in\n\n let (ty1, e0, ibinders) =\n (* Add local value parameters at level `pre.level`. *)\n let (tyenv, domain, ibinders) = add_parameters_to_type_environment preS (ordparams, mndparams, optparams) in\n let preS = { preS with tyenv } in\n\n (* Finally, typecheck the body expression. *)\n match letbind.vb_return with\n | Pure((tyretopt, utast0)) ->\n let (ty0, e0) = typecheck preS utast0 in\n begin\n match (morph, tyretopt) with\n | (MonoRec(_), Some(mty0)) ->\n let ty0_expected = decode_manual_type preS mty0 in\n unify ty0 ty0_expected\n\n | _ ->\n ()\n end;\n let ty1 = (rngv, FuncType(domain, ty0)) in\n (ty1, e0, ibinders)\n\n | Effectful((tyretopt, utcomp0)) ->\n let ((eff0, ty0), e0) = typecheck_computation preS utcomp0 in\n begin\n match (morph, tyretopt) with\n | (MonoRec(_), Some((mty1, mty2))) ->\n let ty1_expected = decode_manual_type preS mty1 in\n let ty2_expected = decode_manual_type preS mty2 in\n unify_effect eff0 (Effect(ty1_expected));\n unify ty0 ty2_expected\n\n | _ ->\n ()\n end;\n let ty1 = (rngv, EffType(domain, eff0, ty0)) in\n (ty1, e0, ibinders)\n in\n let e1 = ilambda ibinders e0 in\n let ptyf = TypeConv.generalize (preS.level - 1) ty1 in\n begin\n match morph with\n | MonoRec(tyf) ->\n unify ty1 tyf\n\n | PolyRec(ptyannot) ->\n if subtype_poly_type ptyf ptyannot then\n ()\n else\n raise_error (PolymorphicContradiction(rngv, x, ptyf, ptyannot))\n end;\n (ptyf, e1)\n\n\nand make_constructor_branch_map (pre : pre) (ctorbrs : constructor_branch list) : constructor_map =\n ctorbrs |> List.fold_left (fun ctormap ctorbr ->\n match ctorbr with\n | ConstructorBranch(attrs, (rng, ctornm), mtyargs) ->\n let (ctorattr, warnings) = ConstructorAttribute.decode attrs in\n warnings |> List.iter Logging.warn_invalid_attribute;\n let tyargs = mtyargs |> List.map (decode_manual_type pre) in\n let ptyargs = tyargs |> List.map (TypeConv.generalize pre.level) in\n let ctorid =\n match ctorattr.target_atom with\n | None ->\n begin\n match ConstructorID.from_upper_camel_case ctornm with\n | Some(ctorid) -> ctorid\n | None -> raise_error (InvalidIdentifier(rng, ctornm))\n end\n\n | Some((rng_atom, target_atom)) ->\n begin\n match ConstructorID.from_snake_case target_atom with\n | Some(ctorid) -> ctorid\n | None -> raise_error (InvalidIdentifier(rng_atom, target_atom))\n end\n in\n ctormap |> ConstructorMap.add ctornm (ctorid, ptyargs)\n ) ConstructorMap.empty\n\n\n(* `subtype_poly_type_impl internbid internbrid pty1 pty2` checks that\n whether `pty1` is more general than (or equal to) `pty2`.\n Note that being more general means being smaller as polymorphic types;\n we have `pty1 <= pty2` in that if `x : pty1` holds and `pty1` is more general than `pty2`, then `x : pty2`.\n For example, we have `(∀α. α → α) <= (int → int)`.\n The parameter `internbid` is used for `internbid bid pty`, which returns\n whether the bound ID `bid` occurring in `pty1` is mapped to a type equivalent to `pty`.\n*)\nand subtype_poly_type_impl (internbid : type_intern) (internbrid : row_intern) (pty1 : poly_type) (pty2 : poly_type) : bool =\n let rec aux pty1 pty2 =\n(*\n let (sbt1, sbr1, sty1) = TypeConv.show_poly_type TypeConv.DisplayMap.empty pty1 in\n let (sbt2, sbr2, sty2) = TypeConv.show_poly_type TypeConv.DisplayMap.empty pty2 in\n Format.printf \"!!! {subtype_poly_type_impl> %s Format.fprintf ppf \", \") Format.pp_print_string) (List.concat [sbt1; sbr1; sbt2; sbr2]);\n*)\n let (_, ptymain1) = pty1 in\n let (_, ptymain2) = pty2 in\n match (ptymain1, ptymain2) with\n | (TypeVar(Mono(_)), _)\n | (_, TypeVar(Mono(_))) ->\n assert false\n (* Monomorphic type variables cannot occur at level 0, according to type generalization. *)\n\n | (BaseType(bt1), BaseType(bt2)) ->\n bt1 = bt2\n\n | (FuncType(pdomain1, ptycod1), FuncType(pdomain2, ptycod2)) ->\n let bdom = aux_domain pdomain1 pdomain2 in\n let bcod = aux ptycod1 ptycod2 in\n bdom && bcod\n\n | (PidType(pidty1), PidType(pidty2)) ->\n aux_pid pidty1 pidty2\n\n | (EffType(domain1, effty1, pty1), EffType(domain2, effty2, pty2)) ->\n let b0 = aux_domain domain1 domain2 in\n let b1 = aux_effect effty1 effty2 in\n let b2 = aux pty1 pty2 in\n b0 && b1 && b2\n\n | (ProductType(ptys1), ProductType(ptys2)) ->\n aux_list (TupleList.to_list ptys1) (TupleList.to_list ptys2)\n\n | (RecordType(prow1), RecordType(prow2)) ->\n subtype_row_with_equal_domain internbid internbrid prow1 prow2\n\n | (PackType(absmodsig1), PackType(absmodsig2)) ->\n begin\n try\n subtype_abstract_with_abstract\n ~cause:(Range.dummy \"subtype_poly_type1\")\n ~address:Address.root\n absmodsig1 absmodsig2;\n subtype_abstract_with_abstract\n ~cause:(Range.dummy \"subtype_poly_type2\")\n ~address:Address.root\n absmodsig2 absmodsig1;\n true\n with\n | _ -> false\n end\n\n | (TypeVar(Bound(bid1)), _) ->\n internbid bid1 pty2\n\n | (TypeApp(tyid1, ptyargs1), TypeApp(tyid2, ptyargs2)) ->\n TypeID.equal tyid1 tyid2 && aux_list ptyargs1 ptyargs2\n\n | _ ->\n false\n\n and aux_list ptys1 ptys2 =\n match List.combine ptys1 ptys2 with\n | exception Invalid_argument(_) ->\n false\n\n | ptypairs ->\n ptypairs |> List.fold_left (fun bacc (pty1, pty2) ->\n let b = aux pty1 pty2 in\n bacc && b\n ) true\n\n and aux_domain domain1 domain2 =\n let {ordered = ptydoms1; mandatory = mndlabmap1; optional = poptrow1} = domain1 in\n let {ordered = ptydoms2; mandatory = mndlabmap2; optional = poptrow2} = domain2 in\n let b1 = aux_list ptydoms1 ptydoms2 in\n let bmnd = subtype_label_assoc_with_equal_domain internbid internbrid mndlabmap1 mndlabmap2 in\n let bopt = subtype_row_with_equal_domain internbid internbrid poptrow1 poptrow2 in\n b1 && bmnd && bopt\n\n and aux_pid (Pid(pty1)) (Pid(pty2)) =\n aux pty1 pty2\n\n and aux_effect (Effect(pty1)) (Effect(pty2)) =\n aux pty1 pty2\n in\n aux pty1 pty2\n\n\n(* Checks that `dom plabmap1 ⊆ dom plabmap2` and `∀label ∈ dom plabmap1. plabmap1(label) <: plabmap2(label)`\n by referring and updating `internbid` and `internbrid`. *)\nand subtype_label_assoc_inclusive (internbid : type_intern) (internbrid : row_intern) (plabmap1 : poly_type LabelAssoc.t) (plabmap2 : poly_type LabelAssoc.t) : (poly_type LabelAssoc.t) option =\n let merged =\n LabelAssoc.merge (fun label pty1_opt pty2_opt ->\n match (pty1_opt, pty2_opt) with\n | (Some(pty1), Some(pty2)) -> Some(Ok(subtype_poly_type_impl internbid internbrid pty1 pty2))\n | (None, Some(pty2)) -> Some(Error(pty2))\n | _ -> Some(Ok(false))\n ) plabmap1 plabmap2\n in\n if merged |> LabelAssoc.for_all (fun _label res -> Result.value ~default:true res) then\n let plabmap_diff =\n merged |> LabelAssoc.filter_map (fun _label res ->\n match res with\n | Ok(_) -> None\n | Error(pty2) -> Some(pty2)\n )\n in\n Some(plabmap_diff)\n else\n None\n\n\nand subtype_label_assoc_with_equal_domain (internbid : type_intern) (internbrid : row_intern) (plabmap1 : poly_type LabelAssoc.t) (plabmap2 : poly_type LabelAssoc.t) : bool =\n LabelAssoc.merge (fun label pty1_opt pty2_opt ->\n match (pty1_opt, pty2_opt) with\n | (Some(pty1), Some(pty2)) -> Some(subtype_poly_type_impl internbid internbrid pty1 pty2)\n | _ -> Some(false)\n ) plabmap1 plabmap2 |> LabelAssoc.for_all (fun _label b -> b)\n\n\nand subtype_row_with_equal_domain (internbid : type_intern) (internbrid : row_intern) (prow1 : poly_row) (prow2 : poly_row) : bool =\n(*\n let (sbt1, sbr1, sty1) = TypeConv.show_poly_row TypeConv.DisplayMap.empty prow1 in\n let (sbt2, sbr2, sty2) = TypeConv.show_poly_row TypeConv.DisplayMap.empty prow2 in\n Format.printf \"!!! {subtype_row_with_equal_domain> %s Format.fprintf ppf \", \") Format.pp_print_string) (List.concat [sbt1; sbr1; sbt2; sbr2]);\n*)\n let NormalizedRow(plabmap1, rowvar1_opt) = TypeConv.normalize_poly_row prow1 in\n let NormalizedRow(plabmap2, rowvar2_opt) = TypeConv.normalize_poly_row prow2 in\n\n match (rowvar1_opt, rowvar2_opt) with\n | (None, None) ->\n subtype_label_assoc_with_equal_domain internbid internbrid plabmap1 plabmap2\n\n | (Some(MonoRow(_)), _) | (_, Some(MonoRow(_))) ->\n assert false\n\n | (None, Some(BoundRow(_brid2))) ->\n false\n\n | (Some(BoundRow(brid1)), _) ->\n let opt = subtype_label_assoc_inclusive internbid internbrid plabmap1 plabmap2 in\n begin\n match opt with\n | None -> false\n | Some(plabmap_diff) -> internbrid brid1 (NormalizedRow(plabmap_diff, rowvar2_opt))\n end\n\n\nand subtype_poly_type (pty1 : poly_type) (pty2 : poly_type) : bool =\n let bidht = BoundIDHashTable.create 32 in\n let bridht = BoundRowIDHashTable.create 32 in\n let internbid (bid1 : BoundID.t) (pty2 : poly_type) : bool =\n match BoundIDHashTable.find_opt bidht bid1 with\n | None ->\n BoundIDHashTable.add bidht bid1 pty2;\n true\n\n | Some(pty) ->\n poly_type_equal pty pty2\n in\n let internbrid (brid1 : BoundRowID.t) (nomrow2 : normalized_poly_row) : bool =\n match BoundRowIDHashTable.find_opt bridht brid1 with\n | None ->\n BoundRowIDHashTable.add bridht brid1 nomrow2;\n true\n\n | Some(nomrow) ->\n normalized_poly_row_equal nomrow nomrow2\n in\n subtype_poly_type_impl internbid internbrid pty1 pty2\n\n\n(* Checks that `prow1` and `prow2` are exactly the same up to reordering.\n Here, `Mono` and `MonoRow` are not supposed to occur in `prow1` nor `prow2`. *)\nand poly_row_equal (prow1 : poly_row) (prow2 : poly_row) : bool =\n normalized_poly_row_equal (TypeConv.normalize_poly_row prow1) (TypeConv.normalize_poly_row prow2)\n\n\nand normalized_poly_row_equal (nomrow1 : normalized_poly_row) (nomrow2 : normalized_poly_row) : bool =\n let NormalizedRow(plabmap1, rowvar1_opt) = nomrow1 in\n let NormalizedRow(plabmap2, rowvar2_opt) = nomrow2 in\n let bmap =\n LabelAssoc.merge (fun _ ptyopt1 ptyopt2 ->\n match (ptyopt1, ptyopt2) with\n | (None, None) -> None\n | (Some(pty1), Some(pty2)) -> Some(poly_type_equal pty1 pty2)\n | _ -> Some(false)\n ) plabmap1 plabmap2 |> LabelAssoc.for_all (fun _ b -> b)\n in\n if bmap then\n match (rowvar1_opt, rowvar2_opt) with\n | (None, None) -> true\n | (Some(BoundRow(brid1)), Some(BoundRow(brid2))) -> BoundRowID.equal brid1 brid2\n | _ -> false\n else\n false\n\n\n(* Checks that `pty1` and `pty2` is exactly equal (up to reordering of records, etc.).\n Here, `Mono` and `MonoRow` are not supposed to occur in `pty1` nor `pty2`. *)\nand poly_type_equal (pty1 : poly_type) (pty2 : poly_type) : bool =\n let rec aux (pty1 : poly_type) (pty2 : poly_type) : bool =\n let (_, ptymain1) = pty1 in\n let (_, ptymain2) = pty2 in\n match (ptymain1, ptymain2) with\n\n | (BaseType(bty1), BaseType(bty2)) ->\n bty1 = bty2\n\n | (FuncType(pdomain1, pty1cod), FuncType(pdomain2, pty2cod)) ->\n let bdom = aux_domain pdomain1 pdomain2 in\n bdom && aux pty1cod pty2cod\n\n | (EffType(pdomain1, peff1, ptysub1), EffType(pdomain2, peff2, ptysub2)) ->\n let bdom = aux_domain pdomain1 pdomain2 in\n bdom && aux_effect peff1 peff2 && aux ptysub1 ptysub2\n\n | (PidType(ppidty1), PidType(ppidty2)) ->\n aux_pid_type ppidty1 ppidty2\n\n | (ProductType(ptys1), ProductType(ptys2)) ->\n aux_list (ptys1 |> TupleList.to_list) (ptys2 |> TupleList.to_list)\n\n | (RecordType(prow1), RecordType(prow2)) ->\n poly_row_equal prow1 prow2\n\n | (PackType(absmodsig1), PackType(absmodsig2)) ->\n begin\n try\n subtype_abstract_with_abstract\n ~cause:(Range.dummy \"poly_type_equal1\")\n ~address:Address.root\n absmodsig1 absmodsig2;\n subtype_abstract_with_abstract\n ~cause:(Range.dummy \"poly_type_equal2\")\n ~address:Address.root\n absmodsig2 absmodsig1;\n true\n with\n | _ ->\n false\n end\n\n | (TypeApp(vid1, ptyargs1), TypeApp(vid2, ptyargs2)) ->\n TypeID.equal vid1 vid2 && aux_list ptyargs1 ptyargs2\n\n | (TypeVar(Bound(bid1)), TypeVar(Bound(bid2))) ->\n BoundID.equal bid1 bid2\n\n | (TypeVar(Mono(_)), _)\n | (_, TypeVar(Mono(_))) ->\n assert false\n\n | _ ->\n false\n\n and aux_list tys1 tys2 =\n try\n List.fold_left2 (fun b ty1 ty2 -> b && aux ty1 ty2) true tys1 tys2\n with\n | Invalid_argument(_) -> false\n\n and aux_domain pdomain1 pdomain2 =\n let {ordered = pty1doms; mandatory = pmndlabmap1; optional = poptrow1} = pdomain1 in\n let {ordered = pty2doms; mandatory = pmndlabmap2; optional = poptrow2} = pdomain2 in\n aux_list pty1doms pty2doms &&\n poly_label_assoc_equal pmndlabmap1 pmndlabmap2 &&\n poly_row_equal poptrow1 poptrow2\n\n and aux_effect (Effect(pty1)) (Effect(pty2)) =\n aux pty1 pty2\n\n and aux_pid_type (Pid(pty1)) (Pid(pty2)) =\n aux pty1 pty2\n\n in\n aux pty1 pty2\n\n\nand poly_label_assoc_equal plabmap1 plabmap2 =\n let merged =\n LabelAssoc.merge (fun _ ptyopt1 ptyopt2 ->\n match (ptyopt1, ptyopt2) with\n | (None, None) -> None\n | (None, Some(_)) -> Some(false)\n | (Some(_), None) -> Some(false)\n | (Some(pty1), Some(pty2)) -> Some(poly_type_equal pty1 pty2)\n ) plabmap1 plabmap2\n in\n merged |> LabelAssoc.for_all (fun _ b -> b)\n\n\nand subtype_base_kind (bkd1 : base_kind) (bkd2 : base_kind) =\n match (bkd1, bkd2) with\n | (TypeKind, TypeKind) -> true\n | (RowKind(labset1), RowKind(labset2)) -> LabelSet.subset labset2 labset1\n | _ -> false\n\n\nand subtype_type_scheme (tyscheme1 : type_scheme) (tyscheme2 : type_scheme) : bool * BoundID.t BoundIDMap.t =\n let (bids1, pty_body1) = tyscheme1 in\n let (bids2, pty_body2) = tyscheme2 in\n match List.combine bids1 bids2 with\n | exception Invalid_argument(_) ->\n (false, BoundIDMap.empty)\n\n | zipped ->\n let bidmap =\n zipped |> List.fold_left (fun bidmap (bid1, bid2) ->\n bidmap |> BoundIDMap.add bid1 bid2\n ) BoundIDMap.empty\n in\n let internbid = internbidf bidmap in\n let internbrid = internbridf bidmap in\n let b = subtype_poly_type_impl internbid internbrid pty_body1 pty_body2 in\n (b, bidmap)\n\n\nand lookup_type_entry (tynm : type_name) (tentry1 : type_entry) (tentry2 : type_entry) : substitution option =\n let Kind(pbkds1, _) = tentry1.type_kind in\n let Kind(pbkds2, _) = tentry2.type_kind in\n if List.length pbkds1 = List.length pbkds2 then\n let subst =\n match TypeConv.get_opaque_type tentry2.type_scheme with\n | None -> SubstMap.empty\n | Some(tyid2) -> SubstMap.empty |> SubstMap.add tyid2 tentry1.type_scheme\n in\n Some(subst)\n else\n None\n\n\nand lookup_record (rng : Range.t) (modsig1 : module_signature) (modsig2 : module_signature) : substitution =\n let take_left = (fun _tyid to1 _to2 -> Some(to1)) in\n match (modsig1, modsig2) with\n | ((_, ConcStructure(sigr1)), (_, ConcStructure(sigr2))) ->\n sigr2 |> SigRecord.fold\n ~v:(fun _x2 _ventry2 subst ->\n subst\n )\n ~c:(fun ctornm2 _centry2 subst ->\n subst\n )\n ~f:(fun tynm2 _pty2 subst ->\n subst\n )\n ~t:(fun tynm2 tentry2 subst ->\n match sigr1 |> SigRecord.find_type tynm2 with\n | None ->\n raise_error (MissingRequiredTypeName(rng, tynm2, tentry2))\n\n | Some(tentry1) ->\n begin\n match lookup_type_entry tynm2 tentry1 tentry2 with\n | None ->\n raise_error (NotASubtypeTypeDefinition(rng, tynm2, tentry1, tentry2))\n\n | Some(subst0) ->\n SubstMap.union take_left subst0 subst\n end\n )\n ~m:(fun modnm2 mentry2 subst ->\n let modsig2 = mentry2.mod_signature in\n match sigr1 |> SigRecord.find_module modnm2 with\n | None ->\n raise_error (MissingRequiredModuleName(rng, modnm2, modsig2))\n\n | Some(mentry1) ->\n let modsig1 = mentry1.mod_signature in\n let subst0 = lookup_record rng modsig1 modsig2 in\n SubstMap.union take_left subst0 subst\n )\n ~s:(fun _ _ subst ->\n subst\n )\n SubstMap.empty\n\n | _ ->\n SubstMap.empty\n\n\nand subtype_abstract_with_abstract ~(cause : Range.t) ~(address : Address.t) (absmodsig1 : module_signature abstracted) (absmodsig2 : module_signature abstracted) : unit =\n let (_, modsig1) = absmodsig1 in\n let _ = subtype_concrete_with_abstract ~cause ~address modsig1 absmodsig2 in\n ()\n\n\n(* `subtype_concrete_with_concrete address rng modsig1 modsig2` asserts that `modsig1 <= modsig2` holds. *)\nand subtype_concrete_with_concrete ~(cause : Range.t) ~(address : Address.t) (modsig1 : module_signature) (modsig2 : module_signature) : unit =\n match (modsig1, modsig2) with\n | ((_, ConcFunctor(sigftor1)), (_, ConcFunctor(sigftor2))) ->\n let (quant1, Domain(isig1, sigr1), absmodsigcod1) = (sigftor1.opaques, sigftor1.domain, sigftor1.codomain) in\n let (quant2, Domain(isig2, sigr2), absmodsigcod2) = (sigftor2.opaques, sigftor2.domain, sigftor2.codomain) in\n let subst =\n let modsigdom1 = (isig1, ConcStructure(sigr1)) in\n let modsigdom2 = (isig2, ConcStructure(sigr2)) in\n subtype_concrete_with_abstract ~cause ~address modsigdom2 (quant1, modsigdom1)\n in\n let absmodsigcod1 = absmodsigcod1 |> substitute_abstract ~cause subst in\n subtype_abstract_with_abstract ~cause ~address absmodsigcod1 absmodsigcod2\n\n | ((_, ConcStructure(sigr1)), (_, ConcStructure(sigr2))) ->\n sigr2 |> SigRecord.fold\n ~v:(fun x2 ventry2 () ->\n let pty2 = ventry2.val_type in\n match sigr1 |> SigRecord.find_value x2 with\n | None ->\n raise_error (MissingRequiredValName(cause, x2, pty2))\n\n | Some(ventry1) ->\n let pty1 = ventry1.val_type in\n if subtype_poly_type pty1 pty2 then\n ()\n else\n raise_error (PolymorphicContradiction(cause, x2, pty1, pty2))\n )\n ~c:(fun ctornm2 centry2 () ->\n match sigr1 |> SigRecord.find_constructor ctornm2 with\n | None ->\n raise_error (MissingRequiredConstructorName(cause, ctornm2, centry2))\n\n | Some(centry1) ->\n let tyscheme1 = make_type_scheme_from_constructor_entry centry1 in\n let tyscheme2 = make_type_scheme_from_constructor_entry centry2 in\n let (b, _) = subtype_type_scheme tyscheme1 tyscheme2 in\n if b then\n ()\n else\n raise_error (NotASubtypeConstructorDefinition(cause, ctornm2, centry1, centry2))\n )\n ~f:(fun tynm2 pty2 () ->\n match sigr1 |> SigRecord.find_dummy_fold tynm2 with\n | None ->\n begin\n match sigr2 |> SigRecord.find_type tynm2 with\n | None -> assert false\n | Some(tentry2) -> raise_error (MissingRequiredTypeName(cause, tynm2, tentry2))\n end\n\n | Some(pty1) ->\n if subtype_poly_type pty1 pty2 then\n ()\n else\n begin\n match (sigr1 |> SigRecord.find_type tynm2, sigr2 |> SigRecord.find_type tynm2) with\n | (Some(tentry1), Some(tentry2)) ->\n raise_error (NotASubtypeTypeDefinition(cause, tynm2, tentry1, tentry2))\n\n | _ ->\n assert false\n end\n )\n ~t:(fun tynm2 tentry2 () ->\n match sigr1 |> SigRecord.find_type tynm2 with\n | None ->\n raise_error (MissingRequiredTypeName(cause, tynm2, tentry2))\n\n | Some(tentry1) ->\n let tyscheme1 =\n let (bids1, pty_body1, _) = tentry1.type_scheme in\n (bids1, pty_body1)\n in\n let tyscheme2 =\n let (bids2, pty_body2, _) = tentry2.type_scheme in\n (bids2, pty_body2)\n in\n let (b1, bidmap1) = subtype_type_scheme tyscheme1 tyscheme2 in\n let (b2, _) = subtype_type_scheme tyscheme2 tyscheme1 in\n let Kind(_, bkdcod1) = tentry1.type_kind in\n let Kind(_, bkdcod2) = tentry2.type_kind in\n let b0 = subtype_base_kind bkdcod1 bkdcod2 in\n if b1 && b2 && b0 then\n ()\n else\n raise_error (NotASubtypeTypeDefinition(cause, tynm2, tentry1, tentry2))\n )\n ~m:(fun modnm2 mentry2 () ->\n let modsig2 = mentry2.mod_signature in\n match sigr1 |> SigRecord.find_module modnm2 with\n | None ->\n raise_error (MissingRequiredModuleName(cause, modnm2, modsig2))\n\n | Some(mentry1) ->\n let modsig1 = mentry1.mod_signature in\n subtype_concrete_with_concrete ~cause ~address modsig1 modsig2\n )\n ~s:(fun signm2 sentry2 () ->\n let absmodsig2 = sentry2.sig_signature in\n match sigr1 |> SigRecord.find_signature signm2 with\n | None ->\n raise_error (MissingRequiredSignatureName(cause, signm2, absmodsig2))\n\n | Some(sentry1) ->\n let absmodsig1 = sentry1.sig_signature in\n subtype_abstract_with_abstract ~cause ~address absmodsig1 absmodsig2;\n subtype_abstract_with_abstract ~cause ~address absmodsig2 absmodsig1;\n ()\n )\n ()\n\n | _ ->\n raise_error (NotASubtype(cause, modsig1, modsig2))\n\n\nand subtype_concrete_with_abstract ~(cause : Range.t) ~(address : Address.t) (modsig1 : module_signature) (absmodsig2 : module_signature abstracted) : substitution =\n let (quant2, modsig2) = absmodsig2 in\n let subst = lookup_record cause modsig1 modsig2 in\n let modsig2 = modsig2 |> substitute_concrete ~cause subst in\n subtype_concrete_with_concrete ~cause ~address modsig1 modsig2;\n subst\n\n\nand subtype_signature ~(cause : Range.t) ~(address : Address.t) (modsig1 : module_signature) (absmodsig2 : module_signature abstracted) =\n subtype_concrete_with_abstract ~cause ~address modsig1 absmodsig2\n\n\nand substitute_signature_source (subst : substitution) (isig : signature_source) : signature_source =\n isig (* TODO *)\n\n\nand substitute_concrete ~(cause : Range.t) (subst : substitution) (modsig : module_signature) : module_signature =\n match modsig with\n | (isig, ConcFunctor(sigftor)) ->\n let (quant, Domain(isigdom, sigr), absmodsigcod) = (sigftor.opaques, sigftor.domain, sigftor.codomain) in\n let sigr = sigr |> substitute_structure ~cause subst in\n let absmodsigcod = absmodsigcod |> substitute_abstract ~cause subst in\n let sigftor =\n { sigftor with\n opaques = quant;\n domain = Domain(isigdom |> substitute_signature_source subst, sigr);\n codomain = absmodsigcod;\n }\n in\n (isig |> substitute_signature_source subst, ConcFunctor(sigftor))\n (* Strictly speaking, we should assert that `quant` and the domain of `subst` be disjoint. *)\n\n | (isig, ConcStructure(sigr)) ->\n let sigr = sigr |> substitute_structure ~cause subst in\n (isig |> substitute_signature_source subst, ConcStructure(sigr))\n\n\n(* Given `modsig1` and `modsig2` which are already known to satisfy `modsig1 <= modsig2`,\n `copy_closure` copies every closure and every global name occurred in `modsig1`\n into the corresponding occurrence in `modsig2`. *)\nand copy_closure (modsig1 : module_signature) (modsig2 : module_signature) : module_signature =\n match (modsig1, modsig2) with\n | ((_isig1, ConcStructure(sigr1)), (isig2, ConcStructure(sigr2))) ->\n let sigr2new = copy_closure_in_structure sigr1 sigr2 in\n (isig2, ConcStructure(sigr2new))\n\n | ((_isig1, ConcFunctor(sigftor1)), (isig2, ConcFunctor(sigftor2))) ->\n let Domain(_isigdom1, sigrdom1) = sigftor1.domain in\n let Domain(isigdom2, sigrdom2) = sigftor2.domain in\n let sigrdom2new = copy_closure_in_structure sigrdom1 sigrdom2 in\n let (_, modsig1) = sigftor1.codomain in\n let (quant2, modsig2) = sigftor2.codomain in\n let modsig2new = copy_closure modsig1 modsig2 in\n (isig2, ConcFunctor({ sigftor2 with\n domain = Domain(isigdom2, sigrdom2new);\n codomain = (quant2, modsig2new);\n closure = sigftor1.closure;\n }))\n\n | _ ->\n assert false\n\n\nand copy_closure_in_structure (sigr1 : SigRecord.t) (sigr2 : SigRecord.t) : SigRecord.t =\n sigr2 |> SigRecord.map\n ~v:(fun x ventry2 ->\n match sigr1 |> SigRecord.find_value x with\n | None -> assert false\n | Some(ventry1) -> { ventry2 with val_global = ventry1.val_global }\n )\n ~c:(fun _ctornm centry2 -> centry2)\n ~f:(fun _tynm pty2 -> pty2)\n ~t:(fun _tynm tentry2 -> tentry2)\n ~m:(fun modnm mentry2 ->\n match sigr1 |> SigRecord.find_module modnm with\n | None ->\n assert false\n\n | Some(mentry1) ->\n let modsig2 = copy_closure mentry1.mod_signature mentry2.mod_signature in\n {\n mod_signature = modsig2;\n mod_name = mentry1.mod_name;\n mod_doc = mentry2.mod_doc; (* Should use `mentry2`, not `mentry1` for doc comments. *)\n }\n )\n ~s:(fun signm sentry2 ->\n match sigr1 |> SigRecord.find_signature signm with\n | None ->\n assert false\n\n | Some(sentry1) ->\n {\n sig_signature = sentry2.sig_signature;\n sig_doc = sentry2.sig_doc;\n sig_address = sentry1.sig_address;\n }\n )\n\n\nand substitute_type_id (subst : substitution) (tyid_from : TypeID.t) : TypeID.t =\n match subst |> SubstMap.find_opt tyid_from with\n | None ->\n tyid_from\n\n | Some(tyscheme) ->\n begin\n match TypeConv.get_opaque_type tyscheme with\n | None ->\n assert false\n\n | Some(tyid_to) ->\n tyid_to\n end\n\n\nand update_subsignature (modnms : module_name list) (updater : module_signature -> module_signature) (modsig : module_signature) : module_signature =\n match modnms with\n | [] ->\n updater modsig\n\n | modnm0 :: modnms ->\n begin\n match modsig with\n | (_, ConcFunctor(_)) ->\n modsig\n\n | (isig, ConcStructure(sigr)) ->\n begin\n let sigr =\n sigr |> SigRecord.map\n ~v:(fun _x ventry -> ventry)\n ~c:(fun _ctornm centry -> centry)\n ~f:(fun _tynm pty -> pty)\n ~t:(fun _tynm tentry -> tentry)\n ~m:(fun modnm mentry ->\n if String.equal modnm modnm0 then\n let modsig = mentry.mod_signature |> update_subsignature modnms updater in\n { mentry with mod_signature = modsig }\n else\n mentry\n )\n ~s:(fun _signm absmodsig -> absmodsig)\n in\n (isig, ConcStructure(sigr))\n end\n end\n\n\nand substitute_type_entity ~(cause : Range.t) (bids_source : BoundID.t list) (subst : substitution) (tyentity : type_entity) : type_entity =\n match tyentity with\n | Opaque(tyid_from) ->\n begin\n match subst |> SubstMap.find_opt tyid_from with\n | None ->\n Opaque(tyid_from)\n\n | Some((bids_target, _, tyentity_target)) ->\n begin\n match tyentity_target with\n | Opaque(tyid_to) ->\n Opaque(tyid_to)\n\n | Synonym ->\n Synonym\n\n | Variant(ctormap_target) ->\n let bidmap =\n match List.combine bids_target bids_source with\n | exception Invalid_argument(_) ->\n assert false\n\n | zipped ->\n zipped |> List.fold_left (fun bidmap (bid_from, bid_to) ->\n let pty_to = (Range.dummy \"substitute_type_entity\", TypeVar(Bound(bid_to))) in\n bidmap |> BoundIDMap.add bid_from pty_to\n ) BoundIDMap.empty\n in\n let ctormap =\n ctormap_target |> ConstructorMap.map (fun (ctorid, ptys) ->\n (ctorid, ptys |> List.map (fun pty ->\n TypeConv.substitute_poly_type bidmap pty)\n )\n )\n in\n Variant(ctormap)\n end\n end\n\n | Synonym ->\n Synonym\n\n | Variant(ctormap) ->\n let ctormap =\n ctormap |> ConstructorMap.map (fun (ctorid, ptys) ->\n (ctorid, ptys |> List.map (substitute_poly_type ~cause subst))\n )\n in\n Variant(ctormap)\n\n\nand substitute_structure ~(cause : Range.t) (subst : substitution) (sigr : SigRecord.t) : SigRecord.t =\n sigr |> SigRecord.map\n ~v:(fun _x ventry ->\n { ventry with val_type = ventry.val_type |> substitute_poly_type ~cause subst }\n )\n ~c:(fun _ctornm centry ->\n { centry with\n belongs = centry.belongs |> substitute_type_id subst;\n parameter_types = centry.parameter_types |> List.map (substitute_poly_type ~cause subst);\n }\n )\n ~f:(fun _tynm pty ->\n pty |> substitute_poly_type ~cause subst\n )\n ~t:(fun _tynm tentry ->\n let (bids, pty_body, tyentity) = tentry.type_scheme in\n let pty_body = pty_body |> substitute_poly_type ~cause subst in\n let tyentity = tyentity |> substitute_type_entity ~cause bids subst in\n {\n type_scheme = (bids, pty_body, tyentity);\n type_kind = tentry.type_kind;\n type_doc = tentry.type_doc;\n }\n )\n ~m:(fun _ mentry ->\n { mentry with mod_signature = mentry.mod_signature |> substitute_concrete ~cause subst }\n )\n ~s:(fun _ sentry ->\n let absmodsig = sentry.sig_signature |> substitute_abstract ~cause subst in\n { sentry with sig_signature = absmodsig }\n )\n\n\nand substitute_abstract ~(cause : Range.t) (subst : substitution) (absmodsig : module_signature abstracted) : module_signature abstracted =\n let (quant, modsig) = absmodsig in\n let modsig = substitute_concrete ~cause subst modsig in\n (quant, modsig)\n (* Strictly speaking, we should assert that `quant` and the domain of `subst` be disjoint. *)\n\n\n(* Applies the subtitution `subst` to `pty`. Here, `MonoRow` are not supposed to occur in `pty`. *)\nand substitute_poly_type ~(cause : Range.t) (subst : substitution) (pty : poly_type) : poly_type =\n let rec aux (rng, ptymain) =\n let ptymain =\n match ptymain with\n | BaseType(_) -> ptymain\n | PidType(ppid) -> PidType(aux_pid ppid)\n | TypeVar(_) -> ptymain\n | ProductType(ptys) -> ProductType(ptys |> TupleList.map aux)\n\n | EffType(pdomain, peff, ptysub) ->\n EffType(aux_domain pdomain, aux_effect peff, aux ptysub)\n\n | FuncType(pdomain, ptycod) ->\n FuncType(aux_domain pdomain, aux ptycod)\n\n | RecordType(prow) ->\n RecordType(aux_row prow)\n\n | TypeApp(tyid_from, ptyargs) ->\n begin\n match subst |> SubstMap.find_opt tyid_from with\n | None ->\n TypeApp(tyid_from, ptyargs |> List.map aux)\n\n | Some((bids, pty_body, _)) ->\n let tyscheme = (bids, pty_body) in\n begin\n match TypeConv.apply_type_scheme_poly tyscheme (ptyargs |> List.map aux) with\n | None -> assert false (* Arity mismatch; this cannot happen. *)\n | Some((_, ptymain)) -> ptymain\n end\n\n end\n\n | PackType(absmodsig) ->\n let absmodsig = substitute_abstract ~cause subst absmodsig in\n PackType(absmodsig)\n in\n (rng, ptymain)\n\n and aux_domain pdomain =\n let {ordered = ptydoms; mandatory = pmndlabmap; optional = poptrow} = pdomain in\n {\n ordered = ptydoms |> List.map aux;\n mandatory = pmndlabmap |> LabelAssoc.map aux;\n optional = aux_row poptrow;\n }\n\n and aux_pid = function\n | Pid(pty) -> Pid(aux pty)\n\n and aux_effect = function\n | Effect(pty) -> Effect(aux pty)\n\n and aux_row (prow : poly_row) =\n match prow with\n | RowCons(rlabel, ty, prow) -> RowCons(rlabel, aux ty, aux_row prow)\n | RowVar(_) -> prow (* Assumes that `MonoRow` does not occur in rows. *)\n | RowEmpty -> RowEmpty\n in\n aux pty\n\n\nand typecheck_declaration ~(address : Address.t) (tyenv : Typeenv.t) (utdecl : untyped_declaration) : SigRecord.t abstracted =\n let (attrs, utdeclmain) = utdecl in\n match utdeclmain with\n | DeclVal((_, x), typarams, rowparams, mty, attrs) ->\n let (declattr, warnings) = DeclarationAttribute.decode attrs in\n warnings |> List.iter Logging.warn_invalid_attribute;\n let pre =\n let pre_init =\n {\n level = 0;\n tyenv = tyenv;\n local_type_parameters = TypeParameterMap.empty;\n local_row_parameters = RowParameterMap.empty;\n }\n in\n let (pre, _) = make_type_parameter_assoc pre_init typarams in\n { pre with level = 1 } |> add_local_row_parameter rowparams\n in\n let ty = decode_manual_type pre mty in\n let pty = TypeConv.generalize 0 ty in\n let gname = OutputIdentifier.fresh_global_dummy () in\n let ventry =\n {\n val_type = pty;\n val_global = gname;\n val_doc = declattr.doc;\n }\n in\n let sigr = SigRecord.empty |> SigRecord.add_value x ventry in\n (OpaqueIDMap.empty, sigr)\n\n | DeclTypeOpaque(tyident, kdannot, attrs) ->\n let (declattr, warnings) = DeclarationAttribute.decode attrs in\n warnings |> List.iter Logging.warn_invalid_attribute;\n let (_, tynm) = tyident in\n let pre_init =\n {\n level = 0;\n tyenv = tyenv;\n local_type_parameters = TypeParameterMap.empty;\n local_row_parameters = RowParameterMap.empty;\n }\n in\n let kd =\n match kdannot with\n | None -> Kind([], TypeKind)\n | Some(mnkd) -> decode_manual_kind pre_init mnkd\n in\n let oid = TypeID.fresh address tynm in\n let Kind(bkds, _) = kd in\n let tentry =\n let (bids, pty_body) = TypeConv.make_opaque_type_scheme_from_base_kinds bkds oid in\n {\n type_scheme = (bids, pty_body, Opaque(oid));\n type_kind = kd;\n type_doc = declattr.doc;\n }\n in\n let sigr = SigRecord.empty |> SigRecord.add_type tynm tentry in\n (OpaqueIDMap.singleton oid kd, sigr)\n\n | DeclModule(modident, utsig, attrs) ->\n let (declattr, warnings) = DeclarationAttribute.decode attrs in\n warnings |> List.iter Logging.warn_invalid_attribute;\n let (rngm, m) = modident in\n let absmodsig = typecheck_signature ~address:(address |> Address.append_member m) tyenv utsig in\n let (quant, modsig) = absmodsig in\n let sname = get_space_name rngm m in\n let mentry =\n {\n mod_signature = modsig;\n mod_name = sname;\n mod_doc = declattr.doc;\n }\n in\n let sigr = SigRecord.empty |> SigRecord.add_module m mentry in\n (quant, sigr)\n\n | DeclSig(sigident, utsig, attrs) ->\n let (declattr, warnings) = DeclarationAttribute.decode attrs in\n warnings |> List.iter Logging.warn_invalid_attribute;\n let (_, signm) = sigident in\n let absmodsig = typecheck_signature ~address:Address.root tyenv utsig in\n let sigr =\n let sentry =\n {\n sig_signature = absmodsig;\n sig_doc = declattr.doc;\n sig_address = address;\n }\n in\n SigRecord.empty |> SigRecord.add_signature signm sentry\n in\n (OpaqueIDMap.empty, sigr)\n\n | DeclInclude(utsig) ->\n let absmodsig = typecheck_signature ~address tyenv utsig in\n let (quant, modsig) = absmodsig in\n begin\n match modsig with\n | (_, ConcFunctor(_)) ->\n let (rng, _) = utsig in\n raise_error (NotAStructureSignature(rng, modsig))\n\n | (isig, ConcStructure(sigr)) ->\n (quant, sigr)\n end\n\n\nand typecheck_declaration_list ~(address : Address.t) (tyenv : Typeenv.t) (utdecls : untyped_declaration list) : SigRecord.t abstracted =\n let (quantacc, sigracc, _) =\n utdecls |> List.fold_left (fun (quantacc, sigracc, tyenv) ((rng, _) as utdecl) ->\n let (quant, sigr) = typecheck_declaration ~address tyenv utdecl in\n let quantacc = merge_quantifier quantacc quant in\n let sigracc =\n match SigRecord.disjoint_union sigracc sigr with\n | Ok(sigr) -> sigr\n | Error(s) -> raise_error (ConflictInSignature(rng, s))\n in\n let tyenv = tyenv |> update_type_environment_by_signature_record sigr in\n (quantacc, sigracc, tyenv)\n ) (OpaqueIDMap.empty, SigRecord.empty, tyenv)\n in\n (quantacc, sigracc)\n\n\nand copy_abstract_signature ~(cause : Range.t) ~(address_to : Address.t) (absmodsig_from : module_signature abstracted) : module_signature abstracted =\n let (quant_from, modsig_from) = absmodsig_from in\n let (quant_to, subst) =\n OpaqueIDMap.fold (fun oid_from pkd (quant_to, subst) ->\n let oid_to =\n let s = TypeID.name oid_from in\n TypeID.fresh address_to s\n in\n let quant_to = quant_to |> OpaqueIDMap.add oid_to pkd in\n let Kind(pbkds, _) = pkd in\n let (bids, pty_body) = TypeConv.make_opaque_type_scheme_from_base_kinds pbkds oid_to in\n let subst = subst |> SubstMap.add oid_from (bids, pty_body, Opaque(oid_to)) in\n (quant_to, subst)\n ) quant_from (OpaqueIDMap.empty, SubstMap.empty)\n in\n let modsig_to = modsig_from |> substitute_concrete ~cause subst in\n (quant_to, modsig_to)\n\n\nand typecheck_signature ~(address : Address.t) (tyenv : Typeenv.t) (utsig : untyped_signature) : module_signature abstracted =\n let (rng, utsigmain) = utsig in\n match utsigmain with\n | SigVar(signm) ->\n begin\n match tyenv |> Typeenv.find_signature signm with\n | None ->\n raise_error (UnboundSignatureName(rng, signm))\n\n | Some(sentry_from) ->\n let absmodsig_from = sentry_from.sig_signature in\n let address_sigvar = sentry_from.sig_address in\n let absmodsig_to = copy_abstract_signature ~cause:rng ~address_to:address absmodsig_from in\n let (quant, (_, modsigmain)) = absmodsig_to in\n (quant, (ISigVar(address_sigvar, signm), modsigmain))\n (* We need to rename opaque IDs here, since otherwise\n we would mistakenly make the following program pass:\n\n ```\n signature S = sig\n type t :: 0\n end\n\n module F = fun(X : S) -> fun(Y : S) -> struct\n type f(x : X.t) : Y.t = x\n end\n ```\n\n This issue was reported by `@elpinal`:\n https://twitter.com/elpin1al/status/1269198048967589889?s=20\n *)\n end\n\n | SigPath(utmod1, sigident2) ->\n let (absmodsig1, _) = typecheck_module ~address:Address.root tyenv utmod1 in\n let (quant1, modsig1) = absmodsig1 in\n begin\n match modsig1 with\n | (_, ConcFunctor(_)) ->\n let (rng1, _) = utmod1 in\n raise_error (NotOfStructureType(rng1, modsig1))\n\n | (_, ConcStructure(sigr1)) ->\n let (rng2, signm2) = sigident2 in\n begin\n match sigr1 |> SigRecord.find_signature signm2 with\n | None ->\n raise_error (UnboundSignatureName(rng2, signm2))\n\n | Some(sentry2) ->\n let absmodsig2 = sentry2.sig_signature in\n let (_, modsig2) = absmodsig2 in\n if opaque_occurs quant1 modsig2 then\n raise_error (OpaqueIDExtrudesScopeViaSignature(rng, absmodsig2))\n else\n absmodsig2\n (* Combining typing rules (P-Mod) and (S-Path)\n in the original paper \"F-ing modules\" [Rossberg, Russo & Dreyer 2014],\n we can ignore `quant1` here.\n However, we CANNOT SIMPLY ignore `quant1`;\n according to the second premise “Γ ⊢ Σ : Ω” of (P-Mod),\n we must assert `absmodsig2` do not contain every type variable in `quant1`.\n (we have again realized this thanks to `@elpinal`.)\n https://twitter.com/elpin1al/status/1272110415435010048?s=20\n *)\n end\n end\n\n | SigDecls(openspecs, utdecls) ->\n let tyenv = tyenv |> add_open_specs_to_type_environment openspecs in\n let (quant, sigr) = typecheck_declaration_list ~address tyenv utdecls in\n (quant, (ISigDecls(sigr), ConcStructure(sigr)))\n\n | SigFunctor(modident, utsigdom, utsigcod) ->\n let (rngm, m) = modident in\n let (quant, sigdom) =\n let address = Address.root |> Address.append_member m in\n typecheck_signature ~address tyenv utsigdom\n in\n let abssigcod =\n let sname = get_space_name rngm m in\n let mentry =\n {\n mod_signature = sigdom;\n mod_name = sname;\n mod_doc = None;\n }\n in\n let tyenv = tyenv |> Typeenv.add_module m mentry in\n let address = address |> Address.append_functor_body ~arg:m in\n typecheck_signature ~address tyenv utsigcod\n in\n begin\n match sigdom with\n | (isigdom, ConcStructure(sigr)) ->\n let sigftor =\n {\n opaques = quant;\n domain = Domain(isigdom, sigr);\n codomain = abssigcod;\n closure = None;\n }\n in\n let (_, (isigcod, _)) = abssigcod in\n (OpaqueIDMap.empty, (ISigFunctor(m, isigdom, isigcod), ConcFunctor(sigftor)))\n\n | _ ->\n raise_error (SupportOnlyFirstOrderFunctor(rng))\n end\n\n | SigWith(utsig0, modidents, tybinds) ->\n let (rng0, _) = utsig0 in\n let absmodsig0 = typecheck_signature ~address tyenv utsig0 in\n let (quant0, modsig0) = absmodsig0 in\n let sigr_last =\n let (rng_last, modsig_last) =\n modidents |> List.fold_left (fun (rngpre, modsig) (rng, modnm) ->\n match modsig with\n | (_, ConcFunctor(_)) ->\n raise_error (NotAStructureSignature(rngpre, modsig))\n\n | (_, ConcStructure(sigr)) ->\n begin\n match sigr |> SigRecord.find_module modnm with\n | None -> raise_error (UnboundModuleName(rng, modnm))\n | Some(mentry) -> (rng, mentry.mod_signature)\n end\n ) (rng0, modsig0)\n in\n match modsig_last with\n | (_, ConcFunctor(_)) -> raise_error (NotAStructureSignature(rng_last, modsig_last))\n | (_, ConcStructure(sigr_last)) -> sigr_last\n in\n let (tydefs, ctordefs) = bind_types ~address tyenv tybinds in\n let (subst, quant) =\n tydefs |> List.fold_left (fun (subst, quant) (tynm1, tentry1) ->\n let (tyid0, pkd_expected) =\n match sigr_last |> SigRecord.find_type tynm1 with\n | None ->\n raise_error (UndefinedTypeName(rng, tynm1))\n\n | Some(tentry0) ->\n begin\n match TypeConv.get_opaque_type tentry0.type_scheme with\n | Some(tyid0) ->\n assert (quant0 |> OpaqueIDMap.mem tyid0);\n (tyid0, tentry0.type_kind)\n\n | None ->\n raise_error (CannotRestrictTransparentType(rng, tynm1, tentry1))\n end\n in\n let pkd_actual = tentry1.type_kind in\n unify_kind rng tynm1 ~actual:pkd_actual ~expected:pkd_expected;\n let subst = subst |> SubstMap.add tyid0 tentry1.type_scheme in\n let quant = quant |> OpaqueIDMap.remove tyid0 in\n (subst, quant)\n ) (SubstMap.empty, quant0)\n in\n let modsig_ret = modsig0 |> substitute_concrete ~cause:rng subst in\n let modsig_ret =\n modsig_ret |> update_subsignature (modidents |> List.map snd) (fun modsig_last ->\n match modsig_last with\n | (_, ConcFunctor(_)) ->\n assert false\n\n | (_, ConcStructure(sigr_last)) ->\n let sigr_last = sigr_last |> add_constructor_definitions ctordefs in\n let (_, (isig0, _)) = absmodsig0 in\n (ISigWith(isig0, tydefs), ConcStructure(sigr_last))\n )\n in\n (quant, modsig_ret)\n\n\n(* Checks that `kd1` and `kd2` are the same. *)\nand unify_kind (rng : Range.t) (tynm : type_name) ~actual:(kd1 : kind) ~expected:(kd2 : kind) : unit =\n let Kind(bkdsdom1, bkdcod1) = kd1 in\n let Kind(bkdsdom2, bkdcod2) = kd2 in\n match List.combine bkdsdom1 bkdsdom2 with\n | exception Invalid_argument(_) ->\n let arity_actual = List.length bkdsdom1 in\n let arity_expected = List.length bkdsdom2 in\n raise_error (InvalidNumberOfTypeArguments(rng, tynm, arity_expected, arity_actual))\n\n | bkddomzips ->\n let bdom = bkddomzips |> List.for_all (fun (bkd1, bkd2) -> base_kind_equal bkd1 bkd2) in\n if bdom && base_kind_equal bkdcod1 bkdcod2 then\n ()\n else\n raise_error (KindContradiction(rng, tynm, kd1, kd2))\n\n\nand base_kind_equal (bkd1 : base_kind) (bkd2 : base_kind) : bool =\n match (bkd1, bkd2) with\n | (TypeKind, TypeKind) -> true\n | (RowKind(labset1), RowKind(labset2)) -> LabelSet.equal labset1 labset2\n | _ -> false\n\n\nand typecheck_binding ~(address : Address.t) (tyenv : Typeenv.t) (utbind : untyped_binding) : SigRecord.t abstracted * (ModuleAttribute.t * binding list) =\n let (_, utbindmain) = utbind in\n match utbindmain with\n | BindVal(attrs, External(extbind)) ->\n let (valattr, warnings) = ValueAttribute.decode attrs in\n warnings |> List.iter Logging.warn_invalid_attribute;\n let mty = extbind.ext_type_annot in\n let (rngv, x) = extbind.ext_identifier in\n let arity = extbind.ext_arity in\n let pty =\n let pre =\n let pre_init =\n {\n level = 0;\n tyenv = tyenv;\n local_type_parameters = TypeParameterMap.empty;\n local_row_parameters = RowParameterMap.empty;\n }\n in\n let (pre, _) = make_type_parameter_assoc pre_init extbind.ext_type_params in\n { pre with level = 1 } |> add_local_row_parameter extbind.ext_row_params\n in\n let ty = decode_manual_type pre mty in\n TypeConv.generalize 0 ty\n in\n let has_option = extbind.ext_has_option in\n let gname =\n let is_test_suite = valattr.is_test_suite in\n generate_global_name ~is_test_suite ~arity:arity ~has_option:has_option rngv x\n in\n let sigr =\n let ventry =\n {\n val_type = pty;\n val_global = gname;\n val_doc = None;\n }\n in\n SigRecord.empty |> SigRecord.add_value x ventry\n in\n let ibinds = [ IBindVal(IExternal(gname, extbind.ext_code)) ] in\n ((OpaqueIDMap.empty, sigr), (ModuleAttribute.empty, ibinds))\n\n | BindVal(attrs, Internal(rec_or_nonrec)) ->\n let (valattr, warnings) = ValueAttribute.decode attrs in\n warnings |> List.iter Logging.warn_invalid_attribute;\n let is_test_suite = valattr.is_test_suite in\n let pre_init =\n {\n level = 0;\n tyenv = tyenv;\n local_type_parameters = TypeParameterMap.empty;\n local_row_parameters = RowParameterMap.empty;\n }\n in\n let (sigr, i_rec_or_nonrec) =\n match rec_or_nonrec with\n | Rec([]) ->\n assert false\n\n | Rec(valbinds) ->\n let proj gname = OutputIdentifier.Global(gname) in\n let recbinds = typecheck_letrec_mutual (global_name_scheme is_test_suite) proj pre_init valbinds in\n let (sigr, irecbindacc) =\n recbinds |> List.fold_left (fun (sigr, irecbindacc) (x, pty, gname_outer, _, e) ->\n let ventry =\n {\n val_type = pty;\n val_global = gname_outer;\n val_doc = None;\n }\n in\n let sigr = sigr |> SigRecord.add_value x ventry in\n let irecbindacc = Alist.extend irecbindacc (x, gname_outer, pty, e) in\n (sigr, irecbindacc)\n ) (SigRecord.empty, Alist.empty)\n in\n (sigr, IRec(Alist.to_list irecbindacc))\n\n | NonRec(valbind) ->\n let (pty, gname, e) =\n let arity = List.length valbind.vb_parameters + List.length valbind.vb_mandatories in\n let has_option = (List.length valbind.vb_optionals > 0) in\n let gnamef = generate_global_name ~is_test_suite ~arity:arity ~has_option:has_option in\n typecheck_let gnamef pre_init valbind\n in\n let (_, x) = valbind.vb_identifier in\n let sigr =\n let ventry =\n {\n val_type = pty;\n val_global = gname;\n val_doc = None;\n }\n in\n SigRecord.empty |> SigRecord.add_value x ventry\n in\n (sigr, INonRec(x, gname, pty, e))\n in\n let ibinds = [ IBindVal(i_rec_or_nonrec) ] in\n ((OpaqueIDMap.empty, sigr), (ModuleAttribute.empty, ibinds))\n\n | BindType([]) ->\n assert false\n\n | BindType((_ :: _) as tybinds) ->\n let (tydefs, ctordefs) = bind_types ~address tyenv tybinds in\n let sigr =\n tydefs |> List.fold_left (fun sigr (tynm, tentry) ->\n sigr |> SigRecord.add_type tynm tentry\n ) SigRecord.empty\n in\n let sigr = sigr |> add_constructor_definitions ctordefs in\n ((OpaqueIDMap.empty, sigr), (ModuleAttribute.empty, []))\n\n | BindModule(modident, utsigopt2, utmod1) ->\n let (rngm, m) = modident in\n let (absmodsig1, (modattrsub, ibindssub)) =\n let address = address |> Address.append_member m in\n typecheck_module ~address tyenv utmod1\n in\n let (quant, modsig) =\n match utsigopt2 with\n | None ->\n absmodsig1\n\n | Some(utsig2) ->\n let (_, modsig1) = absmodsig1 in\n let absmodsig2 = typecheck_signature ~address:(address |> Address.append_member m) tyenv utsig2 in\n coerce_signature ~cause:rngm ~address modsig1 absmodsig2\n in\n let sname = get_space_name rngm m in\n let mentry =\n {\n mod_signature = modsig;\n mod_name = sname;\n mod_doc = None;\n }\n in\n let sigr = SigRecord.empty |> SigRecord.add_module m mentry in\n let ibinds =\n match ibindssub with\n | [] -> []\n | _ :: _ -> [IBindModule(sname, modattrsub, ibindssub)]\n in\n ((quant, sigr), (ModuleAttribute.empty, ibinds))\n\n | BindInclude(utmod) ->\n let (absmodsig, (attrs, ibinds)) = typecheck_module ~address tyenv utmod in\n let (quant, modsig) = absmodsig in\n begin\n match modsig with\n | (_, ConcFunctor(_)) ->\n let (rng, _) = utmod in\n raise_error (NotOfStructureType(rng, modsig))\n\n | (_, ConcStructure(sigr)) ->\n ((quant, sigr), (attrs, ibinds))\n end\n\n | BindSig(sigident, sigbind) ->\n let (_, signm) = sigident in\n let absmodsig = typecheck_signature ~address:Address.root tyenv sigbind in\n let sigr =\n let sentry =\n {\n sig_signature = absmodsig;\n sig_doc = None;\n sig_address = address;\n }\n in\n SigRecord.empty |> SigRecord.add_signature signm sentry\n in\n ((OpaqueIDMap.empty, sigr), (ModuleAttribute.empty, []))\n\n\nand bind_types ~(address : Address.t) (tyenv : Typeenv.t) (tybinds : type_binding list) : (type_name * type_entry) list * variant_definition list =\n let pre_init =\n {\n level = 0;\n tyenv = tyenv;\n local_type_parameters = TypeParameterMap.empty;\n local_row_parameters = RowParameterMap.empty;\n }\n in\n\n (* Add the arity of each variant type to the type environment,\n Construct the graph for checking dependency among synonym types. *)\n let (synacc, vntacc, vertices, graph, tyenv) =\n tybinds |> List.fold_left (fun (synacc, vntacc, vertices, graph, tyenv) (tyident, tyvars, syn_or_vnt) ->\n let (rng, tynm) = tyident in\n let kd =\n let bkddoms =\n tyvars |> List.map (fun (_, kdannot) ->\n match kdannot with\n | None -> TypeKind\n | Some(mnbkd) -> decode_manual_base_kind pre_init mnbkd\n )\n in\n Kind(bkddoms, TypeKind)\n in\n match syn_or_vnt with\n | BindSynonym(synbind) ->\n let syndata =\n DependencyGraph.{\n position = rng;\n type_variables = tyvars;\n definition_body = synbind;\n kind = kd;\n }\n in\n let graph = graph |> DependencyGraph.add_vertex tynm syndata in\n let synacc = Alist.extend synacc (tyident, synbind) in\n let vertices = vertices |> SynonymNameSet.add tynm in\n (synacc, vntacc, vertices, graph, tyenv)\n\n | BindVariant(vntbind) ->\n let Kind(bkds, _) = kd in\n let tyid = TypeID.fresh address tynm in\n let tentry =\n let (bids_temp, pty_body_temp) = TypeConv.make_opaque_type_scheme_from_base_kinds bkds tyid in\n {\n type_scheme = (bids_temp, pty_body_temp, Opaque(tyid));\n type_kind = kd;\n type_doc = None;\n }\n (* `type_scheme` will be changed to `(_, _, Variant(_))` afterwards. *)\n in\n let tyenv = tyenv |> Typeenv.add_type tynm tentry in\n let vntacc = Alist.extend vntacc (tyident, tyvars, vntbind, tyid, kd, tentry) in\n (synacc, vntacc, vertices, graph, tyenv)\n ) (Alist.empty, Alist.empty, SynonymNameSet.empty, DependencyGraph.empty, tyenv)\n in\n let pre = { pre_init with tyenv = tyenv } in\n\n (* Traverse the definition of each synonym type\n in order to add to the graph the edges that stand for dependencies between synonym types. *)\n let graph =\n synacc |> Alist.to_list |> List.fold_left (fun graph syn ->\n let (tyident, mtyreal) = syn in\n let (_, tynm) = tyident in\n let dependencies = get_dependency_on_synonym_types vertices pre mtyreal in\n graph |> SynonymNameSet.fold (fun tynm_dep graph ->\n graph |> DependencyGraph.add_edge ~depended:tynm_dep ~depending:tynm\n ) dependencies\n ) graph\n in\n\n (* Check that no cyclic dependency exists among synonym types\n and make the signature to be returned from the type definitions. *)\n let syns =\n match DependencyGraph.topological_sort graph with\n | Error(cycle) -> raise_error (CyclicSynonymTypeDefinition(cycle))\n | Ok(syns) -> syns\n in\n\n (* Add the definition of the synonym types to the type environment. *)\n let (tyenv, tydefacc) =\n syns |> List.fold_left (fun (tyenv, tydefacc) syn ->\n let pre = { pre with tyenv = tyenv } in\n let (tynm, syndata) = syn in\n let\n DependencyGraph.{\n type_variables = tyvars;\n definition_body = mtyreal;\n kind = pkd;\n _\n } = syndata\n in\n let (pre, typaramassoc) = make_type_parameter_assoc pre tyvars in\n let bids = typaramassoc |> TypeParameterAssoc.values |> List.map MustBeBoundID.to_bound in\n let ty_body = decode_manual_type pre mtyreal in\n let pty_body = TypeConv.generalize 0 ty_body in\n let tentry =\n {\n type_scheme = (bids, pty_body, Synonym);\n type_kind = pkd;\n type_doc = None;\n }\n in\n let tyenv = tyenv |> Typeenv.add_type tynm tentry in\n let tydefacc = Alist.extend tydefacc (tynm, tentry) in\n (tyenv, tydefacc)\n ) (tyenv, Alist.empty)\n in\n let pre = { pre with tyenv } in\n\n (* Traverse the definition of each variant type. *)\n let (tydefacc, ctordefacc) =\n vntacc |> Alist.to_list |> List.fold_left (fun (tydefacc, ctordefacc) vnt ->\n let (tyident, tyvars, ctorbrs, tyid, pkd, tentry) = vnt in\n let (_, tynm) = tyident in\n let (pre, typaramassoc) = make_type_parameter_assoc pre tyvars in\n let bids = typaramassoc |> TypeParameterAssoc.values |> List.map MustBeBoundID.to_bound in\n let ctormap = make_constructor_branch_map pre ctorbrs in\n let tentry =\n let (bids_temp, pty_body_temp, _) = tentry.type_scheme in\n let bidmap =\n match List.combine bids_temp bids with\n | exception Invalid_argument(_) ->\n assert false\n\n | zipped ->\n zipped |> List.fold_left (fun bidmap (bid_from, bid_to) ->\n let pty_to = (Range.dummy \"substitute_type_entity\", TypeVar(Bound(bid_to))) in\n bidmap |> BoundIDMap.add bid_from pty_to\n ) BoundIDMap.empty\n in\n let pty_body = TypeConv.substitute_poly_type bidmap pty_body_temp in\n { tentry with type_scheme = (bids, pty_body, Variant(ctormap)) }\n in\n let tydefacc = Alist.extend tydefacc (tynm, tentry) in\n let ctordefacc = Alist.extend ctordefacc (tynm, tyid, bids, ctormap) in\n (tydefacc, ctordefacc)\n ) (tydefacc, Alist.empty)\n in\n (Alist.to_list tydefacc, Alist.to_list ctordefacc)\n\n\nand typecheck_module ~(address : Address.t) (tyenv : Typeenv.t) (utmod : untyped_module) : module_signature abstracted * (ModuleAttribute.t * binding list) =\n let (rng, utmodmain) = utmod in\n match utmodmain with\n | ModVar(m) ->\n let mentry = find_module tyenv (rng, m) in\n let modsig = mentry.mod_signature in\n let absmodsig = (OpaqueIDMap.empty, modsig) in\n (absmodsig, (ModuleAttribute.empty, []))\n\n | ModBinds(attrs, openspecs, utbinds) ->\n let (modattr, warnings) = ModuleAttribute.decode attrs in\n warnings |> List.iter Logging.warn_invalid_attribute;\n let tyenv = tyenv |> add_open_specs_to_type_environment openspecs in\n let (abssigr, (modattr_included, ibinds)) = typecheck_binding_list ~address tyenv utbinds in\n let (quant, sigr) = abssigr in\n let isig = ISigDecls(sigr) in\n let absmodsig = (quant, (isig, ConcStructure(sigr))) in\n (absmodsig, (ModuleAttribute.merge modattr modattr_included, ibinds))\n\n | ModProjMod(utmod, modident) ->\n let (absmodsig, imod) = typecheck_module ~address tyenv utmod in\n let (quant, modsig) = absmodsig in\n begin\n match modsig with\n | (_, ConcFunctor(_)) ->\n let (rng, _) = utmod in\n raise_error (NotOfStructureType(rng, modsig))\n\n | (_, ConcStructure(sigr)) ->\n let (rng, m) = modident in\n begin\n match sigr |> SigRecord.find_module m with\n | None ->\n raise_error (UnboundModuleName(rng, m))\n\n | Some(mentry) ->\n let absmodsigp = (quant, mentry.mod_signature) in\n (absmodsigp, imod)\n end\n end\n\n | ModFunctor(modident, utsigdom, utmod0) ->\n let (rngm, m) = modident in\n let absmodsigdom =\n let address = Address.root |> Address.append_member m in\n typecheck_signature ~address tyenv utsigdom\n in\n let (quant, modsigdom) = absmodsigdom in\n let (absmodsigcod, _) =\n let sname = get_space_name rngm m in\n(*\n Printf.printf \"MOD-FUNCTOR %s\\n\" m; (* for debug *)\n display_signature 0 modsigdom; (* for debug *)\n*)\n let mentry =\n {\n mod_signature = modsigdom;\n mod_name = sname;\n mod_doc = None;\n }\n in\n let tyenv = tyenv |> Typeenv.add_module m mentry in\n let address = address |> Address.append_functor_body ~arg:m in\n typecheck_module ~address tyenv utmod0\n in\n let absmodsig =\n begin\n match modsigdom with\n | (isigdom, ConcStructure(sigrdom)) ->\n let sigftor =\n {\n opaques = quant;\n domain = Domain(isigdom, sigrdom);\n codomain = absmodsigcod;\n closure = Some(modident, utmod0, tyenv);\n }\n in\n let (_, (isigcod, _)) = absmodsigcod in\n let isig = ISigFunctor(m, isigdom, isigcod) in\n (OpaqueIDMap.empty, (isig, ConcFunctor(sigftor)))\n\n | _ ->\n raise_error (SupportOnlyFirstOrderFunctor(rng))\n end\n in\n (absmodsig, (ModuleAttribute.empty, []))\n\n | ModApply(modidentchain1, modidentchain2) ->\n let mentry1 = find_module_from_chain tyenv modidentchain1 in\n let modsig1 = mentry1.mod_signature in\n let mentry2 = find_module_from_chain tyenv modidentchain2 in\n let modsig2 = mentry2.mod_signature in\n let sname2 = mentry2.mod_name in\n begin\n match modsig1 with\n | (_, ConcStructure(_)) ->\n let rng1 = get_module_name_chain_position modidentchain1 in\n raise_error (NotOfFunctorType(rng1, modsig1))\n\n | (_, ConcFunctor(sigftor1)) ->\n let\n {\n opaques = quant;\n domain = Domain(_, sigrdom1);\n codomain = absmodsigcod1;\n _\n } = sigftor1\n in\n begin\n match sigftor1.closure with\n | None ->\n assert false\n\n | Some(modident0, utmodC, tyenv0) ->\n (* Check the subtype relation between the signature `modsig2` of the argument module\n and the domain `modsigdom1` of the applied functor. *)\n let subst =\n let ((rng2, _), _) = modidentchain2 in\n let isig = ISigDecls(sigrdom1) in\n let modsigdom1 = (isig, ConcStructure(sigrdom1)) in\n subtype_signature ~cause:rng2 ~address modsig2 (quant, modsigdom1)\n in\n let ((_, modsig0), ibinds) =\n let tyenv0 =\n let (_, m0) = modident0 in\n let mentry =\n {\n mod_signature = modsig2;\n mod_name = sname2;\n mod_doc = None;\n }\n in\n tyenv0 |> Typeenv.add_module m0 mentry\n in\n typecheck_module ~address tyenv0 utmodC\n in\n let (quant1subst, modsigcod1subst) = absmodsigcod1 |> substitute_abstract ~cause:rng subst in\n let absmodsig = (quant1subst, copy_closure modsig0 modsigcod1subst) in\n (absmodsig, ibinds)\n end\n end\n\n | ModCoerce(modident1, utsig2) ->\n let mentry1 = find_module tyenv modident1 in\n let modsig1 = mentry1.mod_signature in\n let (rng1, _) = modident1 in\n let absmodsig2 = typecheck_signature ~address tyenv utsig2 in\n let absmodsig = coerce_signature ~cause:rng1 ~address modsig1 absmodsig2 in\n (absmodsig, (ModuleAttribute.empty, []))\n\n\nand typecheck_binding_list ~(address : Address.t) (tyenv : Typeenv.t) (utbinds : untyped_binding list) : SigRecord.t abstracted * (ModuleAttribute.t * binding list) =\n let (_tyenv, quantacc, sigracc, (modattracc, ibindacc)) =\n utbinds |> List.fold_left (fun (tyenv, quantacc, sigracc, (modattracc, ibindacc)) utbind ->\n let (abssigr, (modattr, ibinds)) = typecheck_binding ~address tyenv utbind in\n let (quant, sigr) = abssigr in\n let tyenv = tyenv |> update_type_environment_by_signature_record sigr in\n let quantacc = merge_quantifier quantacc quant in\n let sigracc =\n match SigRecord.disjoint_union sigracc sigr with\n | Ok(sigr) -> sigr\n | Error(s) -> let (rng, _) = utbind in raise_error (ConflictInSignature(rng, s))\n (* In the original paper \"F-ing modules\" [Rossberg, Russo & Dreyer 2014],\n this operation is not disjoint union, but union with right-hand side precedence.\n For the sake of clarity, however, we adopt disjoint union here, at least for now.\n *)\n in\n let modattracc = ModuleAttribute.merge modattracc modattr in\n let ibindacc = Alist.append ibindacc ibinds in\n (tyenv, quantacc, sigracc, (modattracc, ibindacc))\n ) (tyenv, OpaqueIDMap.empty, SigRecord.empty, (ModuleAttribute.empty, Alist.empty))\n in\n ((quantacc, sigracc), (modattracc, Alist.to_list ibindacc))\n\n\nand coerce_signature ~(cause : Range.t) ~(address : Address.t) (modsig1 : module_signature) (absmodsig2 : module_signature abstracted) =\n let _subst = subtype_signature ~cause ~address modsig1 absmodsig2 in\n let (quant2, modsig2) = absmodsig2 in\n (quant2, copy_closure modsig1 modsig2)\n\n\nlet main (tyenv : Typeenv.t) (modident : module_name ranged) (absmodsigopt2 : (module_signature abstracted) option) (utmod1 : untyped_module) : Typeenv.t * (signature_source * SigRecord.t) abstracted * space_name * (ModuleAttribute.t * binding list) =\n let (rng, modnm) = modident in\n let address = Address.root |> Address.append_member modnm in\n let (absmodsig1, imod) = typecheck_module ~address tyenv utmod1 in\n let sname = get_space_name rng modnm in\n let (quant, modsig) =\n match absmodsigopt2 with\n | None -> absmodsig1\n | Some(absmodsig2) -> let (_, modsig1) = absmodsig1 in coerce_signature ~cause:rng ~address modsig1 absmodsig2\n in\n match modsig with\n | (_, ConcFunctor(_)) ->\n let (rng, _) = utmod1 in\n raise_error (RootModuleMustBeStructure(rng))\n\n | (isig, ConcStructure(sigr)) ->\n let mentry =\n {\n mod_signature = modsig;\n mod_name = sname;\n mod_doc = None; (* TODO: add doc comments *)\n }\n in\n let tyenv = tyenv |> Typeenv.add_module modnm mentry in\n (tyenv, (quant, (isig, sigr)), sname, imod)\n" }, { "path": "src/typechecker.mli", "content": "\nopen Syntax\nopen IntermediateSyntax\nopen Env\nopen Errors\n\nexception TypeError of type_error\n\nval typecheck_signature : address:Address.t -> Typeenv.t -> untyped_signature -> module_signature abstracted\n\nval main : Typeenv.t -> module_name ranged -> (module_signature abstracted) option -> untyped_module -> Typeenv.t * (signature_source * SigRecord.t) abstracted * space_name * (ModuleAttribute.t * binding list)\n" }, { "path": "src/valueAttribute.ml", "content": "\nopen MyUtil\nopen Syntax\n\n\ntype t = {\n is_test_suite : bool;\n}\n\n\nlet default =\n {\n is_test_suite = false;\n }\n\n\nlet decode (attrs : attribute list) : t * attribute_warning list =\n let (r, warn_acc) =\n attrs |> List.fold_left (fun (r, warn_acc) attr ->\n let Attribute((rng, attr_main)) = attr in\n match attr_main with\n | (\"test\", utast_opt) ->\n let warn_acc =\n match utast_opt with\n | None ->\n warn_acc\n\n | Some(_) ->\n let warn =\n {\n position = rng;\n tag = \"test\";\n message = \"argument is ignored\";\n }\n in\n Alist.extend warn_acc warn\n in\n ({ is_test_suite = true }, warn_acc)\n\n | (tag, _) ->\n let warn =\n {\n position = rng;\n tag = tag;\n message = \"unsupported attribute\";\n }\n in\n (r, Alist.extend warn_acc warn)\n\n ) (default, Alist.empty)\n in\n (r, Alist.to_list warn_acc)\n" }, { "path": "src/yamlDecoder.ml", "content": "\nopen MyUtil\n\n\ntype error =\n | FieldNotFound of string\n | NotAFloat\n | NotAString\n | NotABool\n | NotAnArray\n | NotAnObject\n | OtherMessage of string\n\n\nlet pp_error (ppf : Format.formatter) =\n let p = Format.fprintf in\n function\n | FieldNotFound(field) -> p ppf \"field '%s' not found\" field\n | NotAFloat -> p ppf \"not a float value\"\n | NotAString -> p ppf \"not a string value\"\n | NotABool -> p ppf \"not a Boolean value\"\n | NotAnArray -> p ppf \"not an array\"\n | NotAnObject -> p ppf \"not an object\"\n | OtherMessage(msg) -> p ppf \"%s\" msg\n\n\ntype 'a t = Yaml.value -> ('a, error) result\n\n\nlet run (d : 'a t) (s : string) : ('a, error) result =\n let open ResultMonad in\n match Yaml.of_string s with\n | Ok(yval) -> d yval\n | Error(`Msg(s)) -> err (OtherMessage(s))\n\n\nlet succeed (a : 'a) : 'a t =\n fun _ -> Ok(a)\n\n\nlet failure (msg : string) : 'a t =\n fun _ -> Error(OtherMessage(msg))\n\n\nlet bind (d : 'a t) (df : 'a -> 'b t) : 'b t =\nfun yval ->\n match d yval with\n | Ok(a) -> df a yval\n | Error(_) as e -> e\n\n\nlet ( >>= ) = bind\n\n\nlet get_scheme (field : string) (d : 'a t) (k : unit -> ('a, error) result) : 'a t =\n let open ResultMonad in\n function\n | `O(keyvals) ->\n begin\n match\n List.find_map (fun (k, v) -> if String.equal k field then Some(v) else None) keyvals\n with\n | None -> k ()\n | Some(v) -> d v\n end\n\n | _ ->\n err NotAnObject\n\n\nlet get (field : string) (d : 'a t) : 'a t =\n let open ResultMonad in\n get_scheme field d (fun () -> err (FieldNotFound(field)))\n\n\nlet get_opt (field : string) (d : 'a t) : ('a option) t =\n let d_some =\n d >>= fun v -> succeed (Some(v))\n in\n let open ResultMonad in\n get_scheme field d_some (fun () -> return None)\n\n\nlet get_or_else (field : string) (d : 'a t) (default : 'a) : 'a t =\n let open ResultMonad in\n get_scheme field d (fun () -> return default)\n\n\nlet number : float t =\n let open ResultMonad in\n function\n | `Float(x) -> return x\n | _ -> err NotAFloat\n\n\nlet string : string t =\n let open ResultMonad in\n function\n | `String(x) -> return x\n | _ -> err NotAString\n\n\nlet bool : bool t =\n let open ResultMonad in\n function\n | `Bool(x) -> return x\n | _ -> err NotABool\n\n\nlet list (d : 'a t) : ('a list) t =\n let open ResultMonad in\n function\n | `A(yvals) ->\n yvals |> List.fold_left (fun res yval ->\n res >>= fun acc ->\n d yval >>= fun a ->\n return (Alist.extend acc a)\n ) (return Alist.empty) >>= fun acc ->\n return (Alist.to_list acc)\n\n | _ ->\n err NotAnArray\n\n\ntype 'a branch = string * 'a t\n\n\nlet branch (field : string) (branches : ('a branch) list) ~on_error:(errorf : string -> string) : 'a t =\n get field string >>= fun tag_gotten ->\n match\n branches |> List.find_map (fun (tag_candidate, d) ->\n if String.equal tag_gotten tag_candidate then Some(d) else None\n )\n with\n | None -> failure (errorf tag_gotten)\n | Some(d) -> d\n\n\nlet ( ==> ) (label : string) (d : 'a t) : 'a branch = (label, d)\n\n\nlet map (f : 'a -> 'b) (d : 'a t) : 'b t =\n let open ResultMonad in\n fun yval ->\n d yval >>= fun a ->\n return (f a)\n\n\nlet map2 (f : 'a1 -> 'a2 -> 'b) (d1 : 'a1 t) (d2 : 'a2 t) : 'b t =\n let open ResultMonad in\n fun yval ->\n d1 yval >>= fun a1 ->\n d2 yval >>= fun a2 ->\n return (f a1 a2)\n\n\nlet map3 (f : 'a1 -> 'a2 -> 'a3 -> 'b) (d1 : 'a1 t) (d2 : 'a2 t) (d3 : 'a3 t) : 'b t =\n let open ResultMonad in\n fun yval ->\n d1 yval >>= fun a1 ->\n d2 yval >>= fun a2 ->\n d3 yval >>= fun a3 ->\n return (f a1 a2 a3)\n" }, { "path": "src/yamlDecoder.mli", "content": "\ntype error\n\nval pp_error : Format.formatter -> error -> unit\n\ntype 'a t\n\nval run : 'a t -> string -> ('a, error) result\n\nval succeed : 'a -> 'a t\n\nval failure : string -> 'a t\n\nval bind : 'a t -> ('a -> 'b t) -> 'b t\n\nval ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t\n\nval get : string -> 'a t -> 'a t\n\nval get_opt : string -> 'a t -> ('a option) t\n\nval get_or_else : string -> 'a t -> 'a -> 'a t\n\nval number : float t\n\nval string : string t\n\nval bool : bool t\n\nval list : 'a t -> ('a list) t\n\ntype 'a branch\n\nval branch : string -> ('a branch) list -> on_error:(string -> string) -> 'a t\n\nval ( ==> ) : string -> 'a t -> 'a branch\n\nval map : ('a -> 'b) -> 'a t -> 'b t\n\nval map2 : ('a1 -> 'a2 -> 'b) -> 'a1 t -> 'a2 t -> 'b t\n\nval map3 : ('a1 -> 'a2 -> 'a3 -> 'b) -> 'a1 t -> 'a2 t -> 'a3 t -> 'b t\n" }, { "path": "test/concept/cell.sest", "content": "/* The current type checker does NOT accept this module. */\nmodule Cell :> sig\n type t :: (o) -> o\n val start<$a, $content> : fun($content) -> [$a]t<$content>\n val set<$a, $content> : fun(t<$content>, $content) -> [$a]unit\n val get<$a, $content> : fun(t<$content>) -> [$a]$content\n val stop<$a, $content> : fun(t<$content>) -> [$a]unit\nend = struct\n\n type request<$a, $content> =\n | Get(pid<$a>)\n | Set(pid<$a>, $content)\n | Stop\n\n type response<$content> =\n | Content($content)\n | Done\n\n type t<$content> = pid, $content>>\n\n val rec loop(v) =\n receive\n | Get(from) ->\n do send(from, Content(v)) in\n loop(v)\n\n | Set(from, v_new) ->\n do send(from, Done) in\n loop(v_new)\n\n | Stop ->\n return({})\n end\n\n val start(v) =\n spawn(loop(v))\n\n val get(cell) =\n do me <- self in\n do send(cell, Get(me)) in\n receive\n | Content(v) ->\n return(v)\n end\n\n val set(cell, v) =\n do me <- self in\n do send(cell, Set(me, v)) in\n receive\n | Done ->\n return({})\n end\n\n val stop(cell) =\n send(cell, Stop)\n\nend\n" }, { "path": "test/concept/counter.sest", "content": "/* This is just a conceptual example and cannot be compiled. */\n\ntype option<$a> = None | Some($a)\ntype result<$a, $b> = Ok($a) | Error($b)\n\nmodule Counter = struct\n\n /* Abstract types for associating responses with requests. */\n type get_number\n type get_name\n\n /* `GenServer.Make` is a functor of the following signature:\n\n ```\n (forall\n state :: 0,\n init_arg :: 0,\n init_error :: 0,\n cast_message :: 0,\n request :: 1,\n response :: 1,\n stop_reason :: 0\n ) (fun(sig\n type state :: 0\n type init_arg :: 0\n type init_error :: 0\n val init : fun(init_arg) -> result\n type cast_message :: 0\n type request :: 1\n type response :: 1\n val handle_cast : fun(cast_message, state) -> result\n val handle_call<$a> : fun(request<$a>, GenServer.session<$a>, state) -> result<(state, response<$a>), stop_reason>\n end) -> (exists proc :: 0) (sig\n type proc :: 0\n val start_link<$s> : fun(init_arg) -> [$s]result\n val cast<$s> : fun(proc, cast_message) -> [$s]unit\n val call<$s, $a> : fun(proc, request<$a>, time) -> [$s]result, error>\n end))\n ```\n\n - `init`, `handle_cast`, and `handle_call`: callback functions required by `gen_server`.\n - `proc`: The type for abstracted PIDs of processes generated by `gen_server` callback modules.\n - `cast`: `cast(proc, msg)` corresponds to `gen_server:cast(?MODULE, proc, msg)`.\n - `call`: `call(proc, msg, timeout)` corresponds to `gen_server:call(?MODULE, proc, msg, timeout)`.\n */\n include GenServer.Make(struct\n\n type state = { number : int, name : string }\n\n type init_arg = string\n\n let init(name : init_arg) =\n Ok({ number = 0, name = name })\n\n type cast_message =\n | Increment\n | Decrement\n | ResetNumber(int)\n\n /* A GADT for request messages. */\n type request :: 1 =\n | GetNumber : request\n | GetName : request\n\n /* A GADT for response messages. */\n type response :: 1 =\n | Number(int) : response\n | Name(string) : response\n\n let handle_cast(msg : cast_message, state : state) : result =\n case msg of\n | Increment -> Ok({ state with number = state.number + 1 })\n | Decrement -> Ok({ state with number = state.number - 1 })\n | ResetNumber(m) -> Ok({ state with number = m })\n end\n\n let handle_call<$a>(msg : request<$a>, ses : GenServer.session<$a>, state : state) =\n case msg of\n | GetNumber -> Ok((state, Number(state.number)))\n | GetName -> Ok((state, Number(state.name)))\n end\n end)\n\n let increment(pid : proc) : [_]unit = cast(pid, Increment)\n let decrement(pid : proc) : [_]unit = cast(pid, Decrement)\n let reset(pid : proc, m : int) : [_]unit = cast(pid, Reset(m))\n\n let get_number(pid : proc, ?timeout = 5000s : time) : [_]result =\n do r : result, GenServer.error> <- call(pid, GetNumber, timeout) in\n let v =\n r |> Result.bind(fun(res) ->\n case res of Number(n) -> Ok(n) end\n end)\n in\n return(v)\n\n let get_name(pid : proc) : [_]result =\n do r <- call(pid, GetName) in\n let v =\n r |> Result.bind(fun(res) ->\n case res of Name(name) -> Ok(name) end\n end)\n in\n return(v)\n\nend :> sig\n type proc :: 0\n val start_link<$s> : fun(int) -> [$s]result\n val increment<$s> : fun(proc) -> [$s]unit\n val decrement<$s> : fun(proc) -> [$s]unit\n val get_number<$s> : fun(proc) -> [$s]result\n val get_name<$s> : fun(proc) -> [$s]result\nend\n" }, { "path": "test/dune", "content": "(tests\n (names\n testRange\n testLanguageVersion\n testIdentifierScheme)\n (libraries\n alcotest\n ocamlgraph\n semver2\n core))\n\n(copy_files ../src/*.ml)\n" }, { "path": "test/fail/error01.sest", "content": "module Error01 = struct\n val main() =\n let x = /* here is /* a comment */ 1 in\n x\nend\n" }, { "path": "test/fail/error_arity.sest", "content": "module ErrorArity = struct\n\n val add(x, y) = x + y\n\n val main() = add(42)\n\nend\n" }, { "path": "test/fail/error_coercion.sest", "content": "module ErrorCoercion = struct\n module Sub = struct\n module Impl = struct\n val rec aux(acc, n, x) =\n if n <= 0 then acc else\n aux(x * acc, n - 1, x)\n\n val power(n, x) =\n aux(1, n, x)\n end\n\n include (Impl :> sig\n val power : fun(int, int) -> int\n end)\n end\n\n val main() =\n Sub.aux(1, 4, 3)\n\nend\n" }, { "path": "test/fail/error_coercion2.sest", "content": "module ErrorCoercion2 :> sig\n val f<$a> : fun($a) -> $a\nend = struct\n val f(n) = n + 1\nend\n" }, { "path": "test/fail/error_coercion3.sest", "content": "module ErrorCoercion3 = struct\n module Impl = struct\n val f(n) = n + 1\n end\n module Api = Impl :> sig\n val f<$a> : fun($a) -> $a\n end\nend\n" }, { "path": "test/fail/error_coercion4.sest", "content": "module ErrorCoercion4 = struct\n module Sub :> sig\n val power : fun(int, int) -> int\n end = struct\n val rec aux(acc, n, x) =\n if n <= 0 then acc else\n aux(x * acc, n - 1, x)\n\n val power(n, x) =\n aux(1, n, x)\n end\n\n val main() =\n Sub.aux(1, 4, 3)\n\nend\n" }, { "path": "test/fail/error_coercion5.sest", "content": "module ErrorCoercion5 = struct\n module Impl = struct\n type t = int\n val make(x) = x\n end\n\n module Sub = Impl :> sig\n type t :: o\n val make : fun(int) -> t\n end\n\n val main() =\n Sub.make(5) + 1\nend\n" }, { "path": "test/fail/error_coercion6.sest", "content": "module ErrorCoercion6 = struct\n module Sub :> sig\n type t :: o\n val make : fun(int) -> t\n end = struct\n type t = int\n val make(x) = x\n end\n\n val main() =\n Sub.make(5) + 1\nend\n" }, { "path": "test/fail/error_contradiction.sest", "content": "module ErrorContradiction = struct\n\n val add(x, y) = x + y\n\n val main() = add(\"foo\", 42)\n\nend\n" }, { "path": "test/fail/error_cyclic/error_cyclic.sest", "content": "import ErrorCyclicFoo\nimport ErrorCyclicBar\n\nmodule ErrorCyclic = struct\n val main() =\n {ErrorCyclicFoo.main(), ErrorCyclicBar.main()}\nend\n" }, { "path": "test/fail/error_cyclic/error_cyclic_bar.sest", "content": "import ErrorCyclicFoo\n\nmodule ErrorCyclicBar = struct\n val main() = {}\nend\n" }, { "path": "test/fail/error_cyclic/error_cyclic_foo.sest", "content": "import ErrorCyclicBar\n\nmodule ErrorCyclicFoo = struct\n val main() = {}\nend\n" }, { "path": "test/fail/error_cyclic/sesterl.yaml", "content": "package: test_fail_error_cyclic\n\nsource_directories:\n - \"./\"\n\nmain_module: \"ErrorCyclic\"\n" }, { "path": "test/fail/error_first_class_module.sest", "content": "module ErrorFirstClassModule :> sig\n val f : fun(pack sig end) -> int\nend = struct\n val f(x : pack sig val n : int end) = 3\nend\n/* Unsoundness reported by `@elpinal` https://twitter.com/elpin1al/status/1389366123246673921?s=20 */\n" }, { "path": "test/fail/error_freeze.sest", "content": "module ErrorFreeze = struct\n\n val g() =\n let f(x) = x in\n freeze f(42)\n\nend\n" }, { "path": "test/fail/error_functor.sest", "content": "module ErrorFunctor = struct\n\n signature S = sig\n type t :: o\n end\n\n module F = fun(X : S) -> fun(Y : S) -> struct\n val f(x : X.t) : Y.t = x\n end\n\nend\n" }, { "path": "test/fail/error_inference.sest", "content": "module ErrorInference = struct\n\n val f(x) =\n x.foo\n\n val main(_) =\n f(42)\n\nend\n" }, { "path": "test/fail/error_kind.sest", "content": "module ErrorKind = struct\n\n module Impl = struct\n type t = binary\n val v() = \"Hello\"\n end\n\n include Impl :> sig\n type t :: {foo : int}\n val v : fun() -> t\n end\n\nend\n" }, { "path": "test/fail/error_kind2.sest", "content": "module ErrorKind2 = struct\n\n val f(n : int, b : bool) : { foo : int, bar : bool, ?$r } =\n { foo = n, bar = b }\n\nend\n" }, { "path": "test/fail/error_kind3.sest", "content": "module ErrorKind3 = struct\n\n val f(r : { foo : int, bar : bool, ?$r }, n : int, b : bool) : { foo : int, bar : bool, ?$r } =\n { r | foo = n, bar = b }\n\nend\n" }, { "path": "test/fail/error_kinded_parameter.sest", "content": "module ErrorKindedParameter = struct\n\n type t<$a :: {foo : int}> =\n | HasFoo($a)\n\n val f(x) =\n case x of\n | HasFoo(r) -> r\n end\n\n val g(b, x, y) =\n case x of\n | HasFoo(r) ->\n if b then r else { y | bar = x }\n end\n\nend\n" }, { "path": "test/fail/error_mandatory_parameter.sest", "content": "module ErrorMandatoryParameter = struct\n\n val get_or_else(x, -default d) =\n case x of\n | Some(v) -> v\n | None -> d\n end\n\n val main() =\n get_or_else(Some(42))\n\nend\n" }, { "path": "test/fail/error_mandatory_parameter2.sest", "content": "module ErrorMandatoryParameter2 = struct\n\n val get_or_else(x, -default d) =\n case x of\n | Some(v) -> v\n | None -> d\n end\n\n val main() =\n get_or_else(Some(42), -or 57)\n\nend\n" }, { "path": "test/fail/error_mutrec.sest", "content": "module ErrorMutrec = struct\n\n type foo =\n {int, bar}\n\n and baz<$a> =\n | Baz(foo, bar)\n\n and bar =\n {bool, baz}\n\nend\n" }, { "path": "test/fail/error_optional_parameter.sest", "content": "module ErrorOptionalParameter = struct\n\n module Impl = struct\n val f(g) =\n {g(42), g(42, ?foo 57)}\n end\n\n include Impl :> sig\n val f<$a> : fun(fun(int) -> $a) -> {$a, $a}\n end\n\nend\n" }, { "path": "test/fail/error_optional_parameter_unify.sest", "content": "module ErrorOptionalParameterUnify = struct\n\n val f1(g) = g(?foo 42)\n\n val f2(g) = g(?foo 42, ?bar true)\n\n val f(flag, g) = if flag then f1(g) else f2(g)\n\n val main(_) =\n let h(?foo nopt) =\n case nopt of\n | None -> 0\n | Some(n) -> n\n end\n in\n let res = f(true, h) in\n print_debug(res)\n\nend\n" }, { "path": "test/fail/error_optional_parameter_unify2.sest", "content": "module ErrorOptionalParameterUnify2 = struct\n\n val g1(?foo nopt) = {nopt, None}\n\n val g2(?foo nopt, ?bar bopt) = {nopt, bopt}\n\n val g(flag) = if flag then g1 else g2\n\nend\n" }, { "path": "test/fail/error_recursive_type_parameter.sest", "content": "module ErrorRecursiveTypeParameter = struct\n\n val f(x) = { x | foo = x }\n\nend\n" }, { "path": "test/fail/error_recursive_type_parameter2.sest", "content": "module ErrorRecursiveTypeParameter2 = struct\n\n val f(x, y) = {{ x | foo = y }, { y | bar = x }}\n\nend\n" }, { "path": "test/fail/error_type_cyclic.sest", "content": "module ErrorTypeCyclic = struct\n\n type t_x =\n t_y\n\n and t_y =\n t_x\n\nend\n" }, { "path": "test/fail/error_variant.sest", "content": "module ErrorVariant :> sig\n type t =\n | Foo(int)\nend = struct\n type t =\n | Foo(int)\n | Bar\nend\n" }, { "path": "test/fail/error_with.sest", "content": "module ErrorWith = struct\n\n module Impl = struct\n type t = int\n end\n\n module Api = Impl :> (sig\n type t\n end with type t = bool)\n\nend\n" }, { "path": "test/fail/recursive.sest", "content": "module Recursive = struct\n\n signature E = sig end\n\n signature X = sig\n signature A = sig end\n /* In OCaml one can declare “abstract” signatures\n by declarations of the form like `signature A`,\n and it causes the possibility of the non-termination\n during type checking.\n F-ing modules does not allow such declarations. */\n\n signature F =\n fun(Dummy : sig\n signature A = A\n signature F = fun(Dummy : A) -> E\n end) -> E\n end\n\n signature Y = sig\n signature A = X\n signature F = fun(Dummy : A) -> E\n end\n\n module ForceSubtyping = fun(V : Y) -> V :> X\n\nend\n" }, { "path": "test/pass/adt.sest", "content": "module Adt = struct\n\n val rec foldl(f, i, l) =\n case l of\n | [] -> i\n | x :: xs -> foldl(f, f(i, x), xs)\n end\n\n val reverse_map(f, xs) =\n foldl(fun(acc, x) -> f(x) :: acc end, [], xs)\n\n val sum(ns) =\n foldl(fun(m, n) -> m + n end, 0, ns)\n\n type tree<$a> =\n | Node($a, list>)\n\n val leaf(x) =\n Node(x, [])\n\n val rec tree_size(tr) =\n let Node(_, children) = tr in\n case children of\n | [] -> 1\n | _ :: _ -> 1 + sum(reverse_map(tree_size, children))\n end\n\n type oddlist<$a> =\n | OddCons($a, evenlist<$a>)\n\n and evenlist<$b> =\n | Nil\n | EvenCons($b, oddlist<$b>)\n\n val main(_) =\n let tr =\n Node(3, [\n Node(1, [\n leaf(4),\n Node(1, [\n leaf(5),\n leaf(9),\n ]),\n leaf(2),\n ])\n ])\n in\n let size = tree_size(tr) in\n let t = OddCons(3, Nil()) in\n print_debug({size, t})\n\nend\n" }, { "path": "test/pass/arith.sest", "content": "module Arith = struct\n\n val main(_) =\n let 13 = 3 * 4 + 1 in\n let 13 = 1 + 3 * 4 in\n let 1 = 4 / 2 / 2 in\n let 8 = 8 * 2 / 2 in\n let 14 = 57 - 42 - 1 in\n let 16 = 57 - 42 + 1 in\n {}\n\nend\n" }, { "path": "test/pass/coercion.sest", "content": "module Coercion = struct\n module Sub = struct\n module Impl = struct\n val rec aux(acc, n, x) =\n if n <= 0 then acc else\n aux(x * acc, n - 1, x)\n\n val power(n, x) =\n aux(1, n, x)\n end\n\n include (Impl :> sig\n val power : fun(int, int) -> int\n end)\n end\n\n val main(_) =\n print_debug(Sub.power(4, 3))\n\nend\n" }, { "path": "test/pass/coercion2.sest", "content": "module Coercion2 :> sig\n val apply<$a, $b> : fun(fun($a) -> $b, $a) -> $b\n val apply2 : fun(fun(int) -> bool, int) -> bool\nend = struct\n val apply(f, x) = f(x)\n val apply2(f, x) = apply(f, x)\n val succ(n) = n + 1\n val main(_) = print_debug(apply(succ, 42))\nend\n" }, { "path": "test/pass/ctor.sest", "content": "module Ctor = struct\n\n module Sub = struct\n type t =\n | Foo\n | Bar(int)\n end\n\n val to_int(x) =\n case x of\n | Sub.Foo -> 0\n | Sub.Bar(n) -> n\n end\n\n val is_foo_and_bar(xs) =\n case xs of\n | [Sub.Foo, Sub.Bar(_)] -> true\n | _ -> false\n end\n\n val main(_) =\n let _ =\n print_debug([\n to_int(Sub.Bar(42)),\n to_int(Sub.Bar(0)),\n to_int(Sub.Foo),\n ])\n in\n print_debug([\n is_foo_and_bar([]),\n is_foo_and_bar([Sub.Foo, Sub.Bar(42)]),\n is_foo_and_bar([Sub.Foo]),\n ])\n\nend\n" }, { "path": "test/pass/ctor_attr.sest", "content": "module CtorAttr = struct\n\n type t =\n | #[atom(\"bar\")] Foo(int)\n\n val f(n) =\n Foo(n)\n\n val main<$a> : $a = external 1 ```\n main(_) ->\n case f(42) of\n {bar, 42} -> ok;\n Other -> erlang:error({unexpected, Other})\n end.\n ```\n\nend\n" }, { "path": "test/pass/ffi.sest", "content": "module Ffi = struct\n\n type option<$a> =\n | None\n | Some($a)\n\n val assoc<$a> : fun(int, list<{int, $a}>) -> option<{$a, list<{int, $a}>}> = external 2 ```\nassoc(Key, Xs) ->\n case lists:keytake(Key, 1, Xs) of\n false -> none;\n {value, {_, V}, Rest} -> {some, {V, Rest}}\n end.\n ```\n\n val main(_) =\n let ans =\n assoc(1, [\n {3, \"Komaba\"},\n {1, \"Hongo\"},\n {4, \"Yayoi\"},\n {1, \"Asano\"},\n {5, \"Kashiwa\"},\n ])\n in\n print_debug(ans)\nend\n" }, { "path": "test/pass/first.sest", "content": "module First = struct\n\n val rec foldn(f, i, c) =\n if i <= 0 then c else\n foldn(f, i - 1, f(i, c))\n\n val main(_) =\n let ans = foldn(fun(i, c) -> i + c end, 10, 0) in\n print_debug(ans)\n\nend\n" }, { "path": "test/pass/functor.sest", "content": "module Functor = struct\n\n val n() = 42\n\n signature S = sig\n type t :: o\n val zero : fun() -> t\n end\n\n module F = fun(X : S) -> fun(Y : S) -> struct\n val f(x : X.t) : X.t = x\n val g(y : Y.t) : Y.t = y\n val m() = n()\n val zeroes() = {X.zero(), Y.zero()}\n end\n\n module Int = struct\n type t = int\n val zero() = 0\n end\n\n module Sub = struct\n module Bool = struct\n type t = bool\n val zero() = false\n end\n end\n\n module G = F(Int)\n module B = Sub.Bool\n module M = G(B)\n\n val main(_) =\n print_debug(M.zeroes())\n\nend\n" }, { "path": "test/pass/functor2.sest", "content": "module Functor2 = struct\n\n signature S = sig\n type t :: o\n val zero : fun() -> t\n end\n\n module F = fun(X : S) -> struct\n val f(x : X.t) : X.t = x\n val zeroes() = {X.zero(), X.zero()}\n end\n\n module Int = struct\n type t = int\n val zero() = 0\n end\n\n module M = F(Int)\n\n val main(_) =\n print_debug(M.zeroes())\n\nend\n" }, { "path": "test/pass/functor3.sest", "content": "module Functor3 = struct\n\n signature S = sig\n type t :: o\n val zero : fun() -> t\n end\n\n signature T = sig\n module M : S\n module N : S\n end\n\n module F = fun(X : T) -> struct\n module P = X.M\n module Q = X.N\n val f(x : P.t,) : P.t = x /* inserting a comma is a temporary dirty hack for parsing */\n val g(y : Q.t,) : Q.t = y\n val zeroes() = {P.zero(), Q.zero()}\n end\n\n module Int = struct\n type t = int\n val zero() = 0\n end\n\n module Bool = struct\n type t = bool\n val zero() = false\n end\n\n module Pair = struct\n module M = Int\n module N = Bool\n end\n\n module M = F(Pair)\n\nend\n" }, { "path": "test/pass/inference.sest", "content": "module Inference = struct\n\n val f(r : {foo : int, ?$a}, x) =\n {x.foo, if true then x else r}\n\n val main(_) =\n f({ foo = 42 }, { foo = 57 })\n\nend\n" }, { "path": "test/pass/kind.sest", "content": "module Kind = struct\n\n module Impl = struct\n type t = {foo : int, bar : bool}\n val v() = {foo = 42, bar = true}\n end\n\n include Impl :> sig\n type t :: o\n val v : fun() -> t\n end\n\nend\n" }, { "path": "test/pass/kinded_parameter.sest", "content": "module KindedParameter = struct\n/* (not supported yet)\n type t =\n | HasFoo({foo : int, ?$r})\n\n val f(x) =\n case x of\n | HasFoo(r) -> r\n end\n\n val g(b, x, y) =\n case x of\n | HasFoo(r) ->\n if b then r else { y | bar = b }\n end\n*/\nend\n" }, { "path": "test/pass/mandatory_parameter.sest", "content": "module MandatoryParameter = struct\n\n module Impl = struct\n val rec foldl(-f f, -init init, -list xs) =\n case xs of\n | [] -> init\n | y :: ys -> foldl(-init f(init, y), -list ys, -f f)\n end\n end\n\n include Impl :> sig\n val foldl<$a, $b> :\n fun(\n -f fun($a, $b) -> $a,\n -init $a,\n -list list<$b>,\n ) -> $a\n end\n\n val main(_) =\n let res =\n foldl(\n -f fun(x, y) -> x + y end,\n -init 0,\n -list [3, 1, 4, 1, 5, 9, 2])\n in\n print_debug(res)\n\nend\n" }, { "path": "test/pass/mod.sest", "content": "module Mod = struct\n\n signature Ord = sig\n type s :: o\n val compare : fun(s, s) -> int\n end\n\n module Map = fun(Elem : Ord) ->\n struct\n type elem = Elem.s\n type t<$a> = list<{elem, $a}>\n val rec find<$b>(x : elem, assoc : t<$b>) : option<$b> =\n case assoc of\n | [] ->\n None\n\n | {k, v} :: tail ->\n if Elem.compare(k, x) == 0 then\n Some(v)\n else\n find(x, tail)\n end\n end\n\n module Int = struct\n type s = int\n val compare(x : int, y : int) = y - x\n end\n\n module IntMap = Map(Int)\n\nend\n" }, { "path": "test/pass/mod2.sest", "content": "module Mod2 = struct\n\n module Counter = struct\n type t = int\n val initial() : t = 0\n val increment(c : t) : t =\n c + 1\n end\n\n val main(_) =\n let x = Counter.initial() in\n print_debug(Counter.increment(x) == 0)\n\nend\n" }, { "path": "test/pass/mod3.sest", "content": "module Mod3 = struct\n\n module List = struct\n type t<$a> = list<$a>\n\n val empty<$b>() : t<$b> =\n []\n\n val rec foldl(f, i, l) =\n case l of\n | [] -> i\n | x :: xs -> foldl(f, f(i, x), xs)\n end\n\n val reverse<$c>(xs : list<$c>) : list<$c> =\n foldl(fun(acc, x) -> x :: acc end, [], xs)\n end\n\n signature Eq = sig\n type t :: o\n val equal : fun(t, t) -> bool\n end\n\nend\n" }, { "path": "test/pass/mod_seq.sest", "content": "module ModSeq = struct\n\n type option<$a> =\n | None\n | Some($a)\n\n signature Decomposable = sig\n type s :: (o) -> o\n val decompose<$a> : fun(s<$a>) -> option<{$a, s<$a>}>\n end\n\n module Seq = fun(D : Decomposable) ->\n struct\n type t<$a> = D.s<$a>\n val to_reversed_list<$a>(xs : t<$a>) : list<$a> =\n let rec aux(acc : list<$a>, xs : t<$a>) =\n case D.decompose(xs) of\n | None -> acc\n | Some({x, tail}) -> aux(x :: acc, tail)\n end\n in\n aux([], xs)\n end\n\n module ListD = struct\n type s<$a> = list<$a>\n val decompose(xs) =\n case xs of\n | [] -> None\n | x :: tail -> Some({x, tail})\n end\n end\n\n module ListSeq = Seq(ListD)\n\n val main(_) =\n let ans = ListSeq.to_reversed_list([3, 1, 4]) in\n print_debug(ans)\n\nend\n" }, { "path": "test/pass/mod_stack.sest", "content": "module ModStack = struct\n\n type option<$a> =\n | None\n | Some($a)\n\n module Stack = struct\n\n type t<$a> = list<$a>\n\n val empty() = []\n\n val pop<$a>(s : t<$a>) : option<{$a, t<$a>}> =\n case s of\n | [] -> None\n | top :: rest -> Some({top, rest})\n end\n\n val push(s, x) = x :: s\n\n end\n\nend\n" }, { "path": "test/pass/mutrec.sest", "content": "module Mutrec = struct\n\n val main(_) =\n let\n rec odd(n) =\n let _ = print_debug(n) in\n even(n - 1)\n\n and even(n) =\n let _ = print_debug(n) in\n if n <= 0 then\n {}\n else\n odd(n - 1)\n in\n even(10)\n\nend\n" }, { "path": "test/pass/mutrec2.sest", "content": "module Mutrec2 = struct\n\n val rec odd(n) =\n let _ = print_debug(n) in\n even(n - 1)\n\n and even(n) =\n let _ = print_debug(n) in\n if n <= 0 then\n {}\n else\n odd(n - 1)\n\n val main(_) =\n even(10)\n\nend\n" }, { "path": "test/pass/optional_parameter.sest", "content": "module OptionalParameter = struct\n\n val pure_succ(n) = n + 1\n\n val succ(n : int, ?diff dopt : option) =\n case dopt of\n | None -> pure_succ(n)\n | Some(d) -> n + d\n end\n\n val succ_concise(n : int, ?diff d : int = 1) =\n n + d\n\n val make_pair<$a>(x : $a, ?other y : $a = x) =\n {x, y}\n\n val f(g) =\n {g(36), g(36, ?diff 64)}\n\n val main(_) =\n let ans1 = {succ(42), succ(42, ?diff 15), f(succ)} in\n let ans2 = {succ_concise(42), succ_concise(42, ?diff 15), f(succ_concise)} in\n let ans3 = {make_pair(\"first\"), make_pair(\"first\", ?other \"second\")} in\n print_debug({ans1, ans2, ans3})\n\nend\n" }, { "path": "test/pass/optional_parameter2.sest", "content": "module OptionalParameter2 = struct\n\n module Impl = struct\n val f1(g) = {g(42), g(42, ?foo 57)}\n val f2(g) = f1(g)\n val f3(g) = f1(g)\n end\n\n include Impl :> sig\n val f1<$a, ?$r :: (foo, bar)> : fun(fun(int, ?foo int, ?bar binary, ?$r) -> $a) -> {$a, $a}\n val f2<$a, ?$r :: (foo)> : fun(fun(int, ?foo int, ?$r) -> $a) -> {$a, $a}\n val f3<$a> : fun(fun(int, ?foo int, ?baz bool) -> $a) -> {$a, $a}\n end\n\n val main(_) =\n let ans1 =\n f2(fun(n, ?foo topt) ->\n case topt of\n | None -> n * 2\n | Some(t) -> n * t\n end\n end)\n in\n let ans2 =\n f2(fun(n, ?foo t = 2) ->\n n * t\n end)\n in\n print_debug({ans1, ans2})\n\nend\n" }, { "path": "test/pass/optional_parameter_unify.sest", "content": "module OptionalParameterUnify = struct\n\n val f1(g) = g(?foo 42)\n\n val f2(g) = g(?foo 42, ?bar true)\n\n val f(flag, g) = if flag then f1(g) else f2(g)\n\n val main(_) =\n let h(?foo nopt, ?bar binopt) =\n case {nopt, binopt} of\n | {None, _} -> false\n | {Some(n), None} -> n > 0\n | {Some(n), Some(b)} -> n > 0 && b\n end\n in\n let res = f(true, h) in\n print_debug(res)\n\nend\n" }, { "path": "test/pass/poly.sest", "content": "module Poly = struct\n\n val rec foldl(f, i, l) =\n case l of\n | [] -> i\n | x :: xs -> foldl(f, f(i, x), xs)\n end\n\n val sum(ns) =\n foldl(fun(m, n) -> m + n end, 0, ns)\n\n val count_true(bs) =\n foldl(fun(n, b) -> if b then n + 1 else n end, 0, bs)\n\n val main(_) =\n let ans =\n {\n sum([3, 1, 4, 1, 5, 9, 2]),\n count_true([true, false, true, true, false])\n }\n in\n print_debug(ans)\n\nend\n" }, { "path": "test/pass/record_test.sest", "content": "module RecordTest = struct\n\n val get_foo(x) = x.foo\n\n val update_bar(x) = { x | bar = false }\n\n val add_foo_and_bar(x) =\n x.foo + (if x.bar then 1 else 0)\n\n val record() = { foo = 42, bar = true }\n\n val default(b, x) =\n if b then record() else x\n\n val main(_) =\n let r = record() in\n print_debug({\n original = r,\n projection = get_foo(r),\n update = update_bar(r),\n operation = add_foo_and_bar(r),\n })\n\nend\n" }, { "path": "test/pass/record_test2.sest", "content": "module RecordTest2 = struct\n\n module Impl = struct\n val record() = { foo = 42, bar = true }\n val get_foo(x) = x.foo\n val get_foo2(x) = get_foo(x)\n end\n\n module Api = Impl :> sig\n val record : fun() -> { foo : int, bar : bool }\n val get_foo<$a, ?$b :: (foo)> : fun({ foo : $a, ?$b }) -> $a\n val get_foo2 : fun({ foo : binary, bar : float }) -> binary\n end\n\nend\n" }, { "path": "test/pass/sample_project/.gitignore", "content": "_build/\n_doc/\nrebar.config\n" }, { "path": "test/pass/sample_project/sample_project.sest", "content": "module SampleProject = struct\n open Stdlib\n\n module Server :> sig\n type proc\n type error = GenServer.start_link_error\n val start_link<$a> : fun({number : int, name : binary}) -> [$a]result\n val stop<$a> : fun(proc) -> [$a]unit\n val set_number<$a> : fun(proc, int) -> [$a]unit\n val get_number<$a> : fun(proc, ?timeout int) -> [$a]int\n end = struct\n\n type error = GenServer.start_link_error\n\n module Callback = struct\n\n type request =\n | GetNumber\n | GetName\n\n type response =\n | Number(int)\n | Name(binary)\n\n type cast_message =\n | SetNumber(int)\n\n type state = { number : int, name : binary }\n type init_arg = state\n type global = unit\n\n type info =\n | InfoDummy\n\n val init(state) = act\n let _ = print_debug({\"init\", state}) in\n GenServer.init_ok(state)\n\n val handle_call(req, _, state) = act\n let _ = print_debug({\"handle_call\", req, state}) in\n case req of\n | GetNumber -> GenServer.reply(Number(state.number), state)\n | GetName -> GenServer.reply(Name(state.name), state)\n end\n\n val handle_cast(msg, state) = act\n let _ = print_debug({\"handle_cast\", msg, state}) in\n case msg of\n | SetNumber(m) -> GenServer.no_reply({ number = m, name = state.name })\n end\n\n val handle_timeout(state) = act\n let _ = print_debug({\"timeout\", state}) in\n GenServer.no_reply(state)\n\n val handle_down(mref, pid, reason, state) = act\n let _ = print_debug({\"down\", mref, pid, reason, state}) in\n GenServer.no_reply(state)\n\n val handle_info(info, state) = act\n let _ = print_debug({\"info\", info, state}) in\n GenServer.no_reply(state)\n\n val terminate(reason, state) = act\n let _ = print_debug({\"terminate\", reason, state}) in\n return({})\n\n end\n\n include GenServer.Make(Callback)\n\n val set_number<$a>(pid : proc, m : int) : [$a]unit = act\n cast(pid, Callback.SetNumber(m))\n\n val get_number<$a>(pid : proc, ?timeout t_opt) : [$a]int = act\n do res <-\n case t_opt of\n | None -> call(pid, Callback.GetNumber)\n | Some(t) -> call(pid, Callback.GetNumber, ?timeout t)\n end\n in\n case res of\n | Ok(Callback.Number(n)) -> return(n)\n end\n\n end\n\n module Main = struct\n\n val async_increment(pid) = act\n do n <- Server.get_number(pid) in\n do _ <- Server.set_number(pid, n + 1) in\n return(n + 1)\n\n val rec loop(t, pid) = act\n if t <= 0 then\n Server.stop(pid)\n else\n do n <- async_increment(pid) in\n let _ = print_debug({t, n}) in\n loop(t - 1, pid)\n\n val main() = act\n do res <- Server.start_link({number = 57, name = \"Sample Store\"}) in\n case res of\n | Error(reason) ->\n let _ = print_debug({\"failed to start a process\", reason}) in\n return({})\n\n | Ok(pid) ->\n do x <- Server.get_number(pid, ?timeout 1000) in\n let _ = print_debug({\"first get\", x}) in\n do _ <- Server.set_number(pid, 42) in\n loop(10, pid)\n end\n end\n\n val main(_) = act\n Main.main()\n\nend\n" }, { "path": "test/pass/sample_project/sesterl.yaml", "content": "package: sample_project\nsource_directories:\n - \"./\"\n\nmain_module: \"SampleProject\"\n\ndocument_outputs:\n - format:\n type: \"html\"\n output_directory: \"./_doc\"\n\ndependencies:\n - name: \"stdlib\"\n source:\n type: \"local\"\n directory: \"../../../external/stdlib\"\n\ntest_dependencies:\n - name: \"testing\"\n source:\n type: \"local\"\n directory: \"../../../external/testing\"\n\nerlang:\n output_directory: \"../../_generated\"\n test_output_directory: \"../../_generated_test\"\n" }, { "path": "test/pass/sample_sup_usage/sample_sup_usage.sest", "content": "module SampleSupUsage = struct\n open Stdlib\n\n module G = GenServer\n module S = Supervisor.Static\n\n module Sup :> sig\n type proc\n type error = S.start_link_error\n val start_link<$a> : fun(unit) -> [$a]result\n end = struct\n\n type error = S.start_link_error\n\n module Child1 = struct\n\n module Callback = struct\n type init_arg = int\n type request =\n | Get\n type response =\n | Got(int)\n type cast_message =\n | Set(int)\n type info = unit\n type global = unit\n type state = int\n\n val init(n) = act\n G.init_ok(n)\n\n val handle_call(request, _, n) = act\n case request of\n | Get -> G.reply(Got(n), n)\n end\n\n val handle_cast(msg, _) = act\n case msg of\n | Set(m) -> G.no_reply(m)\n end\n\n val handle_timeout(n) = act\n G.no_reply(n)\n\n val handle_down(_, _, _, n) = act\n G.no_reply(n)\n\n val handle_info(_, n) = act\n G.no_reply(n)\n\n val terminate(_, _) = act\n return({})\n end\n\n include G.Make(Callback)\n end\n\n module SupCallback = struct\n\n type child_id = int\n type init_arg = unit\n type info = unit\n type global = unit\n\n val start_child1(n) = act\n S.make_child_proc(fun() -> act\n do res <- Child1.start_link(n) in\n return(Result.map(Child1.as_pid, res))\n end)\n\n val init(_) = act\n let sup_flags =\n S.make_sup_flags(\n ?strategy S.OneForOne,\n ?intensity 1,\n ?period 5,\n )\n in\n let child_specs =\n [\n S.make_child_spec(\n -id 1,\n -start (freeze start_child1(42)),\n )\n ]\n in\n S.init_ok(sup_flags, child_specs)\n end\n\n include S.Make(SupCallback)\n end\n\n val main(_) = act\n do res <- Sup.start_link({}) in\n case res of\n | Error(reason) ->\n let _ = print_debug({\"did not start\", reason}) in\n return({})\n\n | Ok(_) ->\n let _ = print_debug(\"ok\") in\n return({})\n end\n\nend\n" }, { "path": "test/pass/sample_sup_usage/sesterl.yaml", "content": "package: sample_sup_usage\nsource_directories:\n - \"./\"\n\nmain_module: \"SampleSupUsage\"\n\ndependencies:\n - name: \"stdlib\"\n source:\n type: \"local\"\n directory: \"../../../external/stdlib\"\n\nerlang:\n output_directory: \"../../_generated\"\n test_output_directory: \"../../_generated_test\"\n" }, { "path": "test/pass/sample_test_dep/rebar.config", "content": "{plugins, [{rebar_sesterl, {git, \"https://github.com/gfngfn/rebar_sesterl_plugin.git\", {branch, \"master\"}}}]}.\n{src_dirs, [\"_generated\", \"./src\"]}.\n{deps, []}.\n{profiles, [{test, [{deps, [{sesterl_testing, {git, \"https://github.com/gfngfn/sesterl_testing\", {tag, \"v0.0.2\"}}}]}]}]}.\n{eunit_tests, [{dir, \"_generated_test\"}, {dir, \"./test\"}]}.\n{sesterl_opts, [{output_dir, \"_generated\"},{test_output_dir, \"_generated_test\"}]}.\n" }, { "path": "test/pass/sample_test_dep/sesterl.yaml", "content": "package: \"sesterl_stdlib\"\n\nsource_directories:\n - \"./src\"\n\ntest_directories:\n - \"./test\"\n\nmain_module: \"Main\"\n\ntest_dependencies:\n - name: \"sesterl_testing\"\n source:\n type: \"git\"\n repository: \"https://github.com/gfngfn/sesterl_testing\"\n spec:\n type: \"tag\"\n value: \"v0.0.2\"\n" }, { "path": "test/pass/sample_test_dep/src/Main.sest", "content": "module Main :> sig\n val f : fun() -> int\nend = struct\n\n val f() =\n 42 + 57\n\nend\n" }, { "path": "test/pass/sample_test_dep/test/MainTest.sest", "content": "import Main\n\nmodule MainTest = #[test] struct\n\n #[test]\n val f_test() =\n Testing.it(\"equal to 99\", fun() ->\n assert Testing.equal(\n -expect 99,\n -got Main.f(),\n )\n end)\n\nend\n" }, { "path": "test/pass/send.sest", "content": "module Send = struct\n\n type bintree<$a> =\n | Node($a, bintree<$a>, bintree<$a>)\n | Empty\n\n val bintree_of_int(n : int) : bintree =\n let rec aux(top, n) =\n if n <= 0 then\n Empty\n else\n let n1 = (n - 1) / 2 in\n let n2 = (n - 1) - n1 in\n let tr1 = aux(top + 1, n1) in\n let tr2 = aux(top + n1 + 1, n2) in\n Node(top, tr1, tr2)\n in\n aux(1, n)\n\n val reverse_list<$a>(xs : list<$a>) : list<$a> =\n let rec aux(rev : list<$a>, xs : list<$a>) =\n case xs of\n | [] -> rev\n | x :: tail -> aux(x :: rev, tail)\n end\n in\n aux([], xs)\n\n val rec wait_all<$b>(r : $b, n : int) = act\n if n <= 0 then\n let _ = print_debug(\"\\\"end!\\\"\") in\n return(r)\n else\n receive\n | msg ->\n let _ = print_debug(msg) in\n wait_all(r, n - 1)\n end\n\n val rec spawn_all<$m>(acc, n : int) : [{pid<$m>, bintree}]list> = act\n if n <= 0 then\n return(reverse_list(acc))\n else\n do parent <- self() in\n do pid : pid<$m> <-\n spawn(fun() -> act\n do me <- self() in\n send(parent, {me, bintree_of_int(n)})\n end)\n in\n spawn_all(pid :: acc, n - 1)\n\n val main(_) = act\n let m = 10 in\n do pids <- spawn_all([], m) in\n let _ = print_debug(pids) in\n wait_all({}, m)\n\nend\n" }, { "path": "test/pass/send2.sest", "content": "module Send2 = struct\n\n val some_heavy_calculation(n) =\n n\n\n val rec wait_all(msgacc, n) = act\n if n <= 0 then\n return(msgacc)\n else\n receive\n | {pid, msg} ->\n let _ = print_debug(format(f'message ~p received from: ~p~n', {msg, pid})) in\n wait_all(msg :: msgacc, n - 1)\n end\n\n val rec spawn_all(pidacc, n) = act\n if n <= 0 then\n return(pidacc)\n else\n do parent <- self() in\n do pid <-\n spawn(fun() -> act\n do me <- self() in\n let msg = some_heavy_calculation(n) in\n send(parent, {me, msg})\n end)\n in\n spawn_all(pid :: pidacc, n - 1)\n\n val main(_) = act\n let n = 10 in\n do pids <- spawn_all([], n) in\n let _ = print_debug(format(f'spawned: ~p~n', {pids})) in\n do msgs <- wait_all([], n) in\n let _ = print_debug(msgs) in\n return({})\n\nend\n" }, { "path": "test/pass/test_after.sest", "content": "module TestAfter = struct\n\n module Sub :> sig\n val wait<$a> : fun(int) -> [$a]bool\n end = struct\n\n val wait(timeout) = act\n receive\n | _ ->\n return(true)\n after timeout ->\n return(false)\n end\n\n end\n\n val main(_) = act\n receive\n | 42 ->\n let _ = print_debug(\"Forty two\") in\n return({})\n after (64 + 36) ->\n let _ = print_debug(\"Hey\") in\n return({})\n end\n\nend\n" }, { "path": "test/pass/test_binary.sest", "content": "module TestBinary = struct\n\n val check : fun({binary, binary, binary, binary, binary}) -> {binary, binary, binary, binary, binary} = external 1 ```\n check({A, B, C, D, E}) ->\n <<240,159,145,169,226,128,141,240,159,148,172>> = A,\n <<\"👩‍🔬\"/utf8>> = A,\n <<10,13,9,34,39,92>> = B,\n <<\"\\n\\r\\t\\\"\\'\\\\\"/utf8>> = B,\n <<39>> = C,\n <<\"\\'\"/utf8>> = C,\n <<33,34,39,96,92,92>> = D,\n <<\"!\\\"\\'`\\\\\\\\\"/utf8>> = D,\n <<111,110,101,10,116,119,111>> = E,\n <<\"one\\ntwo\"/utf8>> = E,\n {A, B, C, D, E}.\n ```\n\n val main(_) =\n let woman_scientist = \"👩‍🔬\" in\n let escape_sequences = \"\\n\\r\\t\\\"\\'\\\\\" in\n let single_quote = \"'\" in\n let raw = ``!\"'`\\\\`` in\n let multiline = ```\none\ntwo```\n in\n let examples = {woman_scientist, escape_sequences, single_quote, raw, multiline} in\n print_debug(check(examples))\n\nend\n" }, { "path": "test/pass/test_binary_pattern.sest", "content": "module TestBinaryPattern = struct\n\n val check(s) =\n case s of\n | \"one\" -> Some(1)\n | \"two\" -> Some(2)\n | _ -> None\n end\n\n val main(_) =\n print_debug({check(\"one\"), check(\"two\"), check(\"other\")})\n\nend\n" }, { "path": "test/pass/test_first_class_module.sest", "content": "module TestFirstClassModule = struct\n module Sub = struct\n type t = int\n val compare(n1, n2) = n2 - n1\n end\n\n signature Ord = sig\n type t\n val compare : fun(t, t) -> int\n end\n\n val f(x : pack Ord) =\n x\n\n val main(_) =\n print_debug(f(pack Sub : Ord))\n\nend\n" }, { "path": "test/pass/test_first_class_module2.sest", "content": "module TestFirstClassModule2 :> sig\n signature Ord = sig\n type t\n val compare : fun(t, t) -> int\n end\nend = struct\n signature Ord = sig\n type t\n val compare : fun(t, t) -> int\n end\nend\n" }, { "path": "test/pass/test_float.sest", "content": "module TestFloat = struct\n\n val add(x, y) = x +. y\n\n val main(_) =\n print_debug(add(42.57, 1.))\n\nend\n" }, { "path": "test/pass/test_format.sest", "content": "module TestFormat = struct\n\n val f1() = f'Hello, ~s!'\n val f2() = f'~~ Hello, ~p and ~p! ~~'\n val f3() = f'repeat: ~10c, bound: ~20s'\n val f4() = f'\\\"Hello, ~10.3f!\\\"'\n val f5() = f'Hello.'\n\n val main(_) =\n let res1 = format(f1(), {\"World\"}) in\n let res2 = format(f2(), {42, true}) in\n let res3 = format(f3(), {$'*', \"The quick brown fox jumps over the lazy dog.\"}) in\n let res4 = format(f4(), {3.14159265}) in\n let res5 = format(f5(), {}) in\n print_debug({res1, res2, res3, res4, res5})\n\nend\n" }, { "path": "test/pass/test_freeze.sest", "content": "module TestFreeze = struct\n\n module Sub = struct\n val add_pure(x, y) =\n x + y\n\n val add(x, y) = act\n return(add_pure(x, y))\n\n val rec foldl_pure(f, i, l) =\n case l of\n | [] -> i\n | x :: xs -> foldl_pure(f, f(i, x), xs)\n end\n\n val foldl(f, i, l) = act\n return(foldl_pure(f, i, l))\n end\n\n type info = unit\n\n val negate(n) = act\n return(0 - n)\n\n val partial(x) : frozen<{int}, info, int> =\n freeze Sub.add(x, _)\n\n val full(y) : frozen =\n let p = partial(42) in\n freeze (p) with (y)\n\n val partial1() : frozen<{int, list}, info, int> =\n freeze Sub.foldl(Sub.add_pure, _, _)\n\n val partial2() : frozen<{list}, info, int> =\n freeze (partial1()) with (0, _)\n\n val impl() : list> =\n [\n freeze Sub.add(42, 57),\n freeze negate(100),\n freeze (partial2()) with ([3, 1, 4, 5, 9, 2]),\n ]\n\n val main<$a> : fun($a) -> unit = external 1 ```\nmain(_) ->\n List = impl(),\n lists:foreach(\n fun({M, F, Args}) ->\n Result = apply(M, F, Args),\n io:format(\"~p~n\", [Result])\n end,\n List).\n ```\nend\n" }, { "path": "test/pass/test_import/import_depended.sest", "content": "module ImportDepended = struct\n\n val hello() =\n \"Hello\"\n\nend\n" }, { "path": "test/pass/test_import/import_depending.sest", "content": "import ImportDepended\n\nmodule ImportDepending = struct\n\n val main(_) =\n print_debug(ImportDepended.hello())\n\nend\n" }, { "path": "test/pass/test_import/sesterl.yaml", "content": "package: test_import\nsource_directories:\n - \"./\"\n\nmain_module: \"ImportDepending\"\n" }, { "path": "test/pass/test_poly_rec.sest", "content": "module TestPolyRec = struct\n\n val rec pair<$a>(x : $a) : {$a, $a} =\n {x, x}\n\n and trues() =\n pair(true)\n\n and ones() =\n pair(1)\n\nend\n" }, { "path": "test/pass/test_public_type.sest", "content": "module TestPublicType = struct\n/*\n signature S = sig\n type t\n type u = t\n end\n*/\n signature T = sig\n type u\n type t = u\n end\n/*\n module F = fun(X : S) -> X :> T\n*/\nend\n/* This test case was given by @elpinal.\n See: https://twitter.com/elpin1al/status/1317752613052452864?s=20\n*/\n" }, { "path": "test/pass/test_result.sest", "content": "module TestResult = struct\n\n val f(res) =\n case res of\n | Ok(n) -> n\n | Error({a, b}) -> a + b\n end\n\n val main(_) =\n print_debug([\n f(Ok(4423)),\n f(Error({42, 57})),\n ])\n\nend\n" }, { "path": "test/pass/test_string.sest", "content": "module TestString = struct\n\n val phrase() =\n 'Hello World!'\n\n val chop_first(s) =\n case s of\n | [] -> None\n | ch :: tail -> Some({ch, tail})\n end\n\n val starts_with_h(s) =\n case s of\n | $'H' :: _ -> true\n | _ -> false\n end\n\n val main(_) =\n let s = phrase() in\n let ans1 = chop_first(s) in\n let ans2 = $'F' :: 'oo' in\n let ans3 = starts_with_h(s) in\n print_debug({s, ans1, ans2, ans3})\n\nend\n" }, { "path": "test/pass/test_testing.sest", "content": "module TestTesting = #[test] struct\n\n val sub(x, y) =\n x == y\n\n #[test]\n val main() =\n sub(42, 42)\n\nend\n" }, { "path": "test/pass/test_type.sest", "content": "module TestType = struct\n\n type t_a =\n t_b\n\n and t_b =\n t_c\n\n and t_c =\n int\n\n type position<$num> =\n { x : $num, y : $num }\n\n and geometry =\n | Circle(circle_info)\n | Rectangle(rectangle_info)\n\n and circle_info<$cnum, $rnum> =\n { center : position<$cnum>, radius : $rnum }\n\n and rectangle_info<$num> =\n { lower_right : position<$num>, upper_left : position<$num> }\n\n and rational =\n { denominator : int, numerator : int }\n\nend\n" }, { "path": "test/pass/test_with.sest", "content": "module TestWith = struct\n\n module Impl1 = struct\n type t = int\n end\n\n module Api1 = Impl1 :> (sig\n type t\n end with type t = int)\n\n module Impl2 = struct\n module M = struct\n type t = int\n end\n end\n\n module Api2 = Impl2 :> (sig\n module M : sig\n type t\n end\n end with M type t = int)\n\n module Impl3 = struct\n type t =\n | Foo(int)\n | Bar(binary)\n end\n\n module Api3 = Impl3 :> (sig\n type t :: o\n end with\n type t =\n | Foo(int)\n | Bar(binary)\n )\n\n module Api4 = Impl3 :> sig\n type t =\n | Foo(int)\n | Bar(binary)\n end\n\n val main(_) =\n let res = Api3.Foo(1) in\n print_debug(res)\n\nend\n" }, { "path": "test/pass/variant.sest", "content": "module Variant :> sig\n\n type foo<$a> =\n | Foo(int)\n | Bar($a)\n\nend = struct\n\n type foo<$a> =\n | Foo(int)\n | Bar($a)\n\nend\n" }, { "path": "test/rebar_test/.gitignore", "content": "_build/\n_generated/\n_gen/\n" }, { "path": "test/rebar_test/README.md", "content": "\n## How to compile\n\nFirst, generate `rebar.config`:\n\n```console\n$ sesterl config ./\n```\n\nThen, run rebar3 with a plugin for Sesterl compiler:\n\n```console\n$ rebar3 sesterl compile\n```\n" }, { "path": "test/rebar_test/rebar.config", "content": "{plugins, [{rebar_sesterl, {git, \"https://github.com/gfngfn/rebar_sesterl_plugin.git\", {branch, \"master\"}}}]}.\n{src_dirs, [\"_gen\", \"./src\"]}.\n{deps, [{jsone, {git, \"https://github.com/sile/jsone.git\", {branch, \"master\"}}}]}.\n{sesterl_opts, [{output_dir, \"_gen\"}]}.\n" }, { "path": "test/rebar_test/sesterl.yaml", "content": "package: \"foo_rebar_test\"\nsource_directories:\n - \"./src\"\n\ndependencies: []\n\nmain_module: \"Foo\"\n\nerlang:\n output_directory: \"_gen\"\n erlang_dependencies:\n - name: \"jsone\"\n source:\n type: \"git\"\n repository: \"https://github.com/sile/jsone.git\"\n spec:\n type: \"branch\"\n value: \"master\"\n" }, { "path": "test/rebar_test/src/foo.app.src", "content": "{application, foo, [\n {description, \"foo for rebar3 plugin test\"},\n {vsn, \"0.0.1\"},\n {applications, [\n kernel,\n stdlib\n ]}\n]}.\n" }, { "path": "test/rebar_test/src/foo.sest", "content": "module Foo = struct\n\n val fact(n) =\n let rec aux(acc, n) =\n if n <= 0 then acc else aux(n * acc, n - 1)\n in\n aux(1, n)\n\n val main() =\n let _ = print_debug(fact(10)) in\n {}\n\nend\n" }, { "path": "test/testIdentifierScheme.ml", "content": "\nmodule SnakeCase = struct\n\n type t = {\n message : string;\n input : string;\n expects : (string list) option;\n }\n\n let test (r : t) () =\n let actual =\n IdentifierScheme.from_snake_case r.input |> Option.map (fun x -> x.IdentifierScheme.fragments)\n in\n Alcotest.(check (option (list string))) r.message r.expects actual\n\nend\n\n\nmodule CamelCase = struct\n\n type t = {\n message : string;\n input : string;\n expects : (string list) option;\n }\n\n let test (r : t) () =\n let actual =\n IdentifierScheme.from_upper_camel_case r.input |> Option.map (fun x -> x.IdentifierScheme.fragments)\n in\n Alcotest.(check (option (list string))) r.message r.expects actual\n\nend\n\n\nlet () =\n let open Alcotest in\n run \"IdentifierScheme\" [\n (\"from_snake_case\", List.map (fun tuple ->\n test_case \"equal\" `Quick (SnakeCase.test tuple))\n SnakeCase.[\n { message = \"single\";\n input = \"foo\";\n expects = Some[\"foo\"];\n };\n { message = \"double\";\n input = \"foo_bar\";\n expects = Some[\"foo\"; \"bar\"];\n };\n { message = \"triple\";\n input = \"foo_bar_baz\";\n expects = Some[\"foo\"; \"bar\"; \"baz\"];\n };\n { message = \"allow words to start with a digit\";\n input = \"x86_64\";\n expects = Some[\"x86\"; \"64\"];\n };\n { message = \"cannot use the empty string\";\n input = \"\";\n expects = None;\n };\n { message = \"cannot include adjacent underscores\";\n input = \"foo__bar\";\n expects = None;\n };\n { message = \"cannot begin with an underscore\";\n input = \"_foo\";\n expects = None;\n };\n { message = \"cannot end with an underscore\";\n input = \"foo_\";\n expects = None;\n };\n { message = \"cannot include uppercase letters (1)\";\n input = \"Foo\";\n expects = None;\n };\n { message = \"cannot include uppercase letters (2)\";\n input = \"fOo\";\n expects = None;\n };\n { message = \"cannot include uppercase letters (1)\";\n input = \"foo_Bar\";\n expects = None;\n };\n { message = \"cannot include uppercase letters (2)\";\n input = \"foo_bAr\";\n expects = None;\n };\n ]);\n (\"from_upper_camel_case\", List.map (fun tuple ->\n test_case \"equal\" `Quick (CamelCase.test tuple))\n CamelCase.[\n { message = \"single\";\n input = \"Foo\";\n expects = Some[\"foo\"];\n };\n { message = \"double\";\n input = \"FooBar\";\n expects = Some[\"foo\"; \"bar\"];\n };\n { message = \"triple\";\n input = \"FooBarBaz\";\n expects = Some[\"foo\"; \"bar\"; \"baz\"];\n };\n { message = \"includes number (1)\";\n input = \"Foo3Bar\";\n expects = Some[\"foo3\"; \"bar\"];\n };\n { message = \"includes number (2)\";\n input = \"Fo3oBar\";\n expects = Some[\"fo3o\"; \"bar\"];\n };\n { message = \"includes number (3)\";\n input = \"F3ooBar\";\n expects = Some[\"f3oo\"; \"bar\"];\n };\n { message = \"includes number (4)\";\n input = \"Fo42oBar\";\n expects = Some[\"fo42o\"; \"bar\"];\n };\n { message = \"includes number (5)\";\n input = \"Foo42Bar\";\n expects = Some[\"foo42\"; \"bar\"];\n };\n { message = \"includes number (6)\";\n input = \"FooBar3\";\n expects = Some[\"foo\"; \"bar3\"];\n };\n { message = \"includes number (7)\";\n input = \"FooB3ar\";\n expects = Some[\"foo\"; \"b3ar\"];\n };\n { message = \"underscore + digit\";\n input = \"X86_64\";\n expects = Some[\"x86\"; \"64\"];\n };\n { message = \"cannot include underscores that are not followed by digits\";\n input = \"Foo_Bar\";\n expects = None;\n };\n { message = \"cannot use double underscore\";\n input = \"X86__64\";\n expects = None;\n };\n { message = \"cannot end with underscores\";\n input = \"Foo_\";\n expects = None;\n };\n ]);\n ]\n" }, { "path": "test/testLanguageVersion.ml", "content": "\ntype test_case = {\n before : string;\n after : string;\n expects : bool;\n}\n\n\nlet test_is_compatible (r : test_case) () =\n match (LanguageVersion.parse r.before, LanguageVersion.parse r.after) with\n | (Some(before), Some(after)) ->\n let message = Printf.sprintf \"(%s, %s)\" r.before r.after in\n Alcotest.(check bool) message r.expects (LanguageVersion.is_compatible ~before ~after)\n\n | _ ->\n Alcotest.fail \"parse failed\"\n\n\nlet () =\n let open Alcotest in\n run \"LanguageVersion\" [\n (\"is_compatible\", List.map (fun r ->\n test_case \"check\" `Quick (test_is_compatible r))\n [\n { before = \"v0.1.3\";\n after = \"v0.1.4\";\n expects = true;\n };\n { before = \"v0.1.4\";\n after = \"v0.1.4\";\n expects = true;\n };\n { before = \"v0.1.5\";\n after = \"v0.1.4\";\n expects = false;\n };\n { before = \"v0.1.3\";\n after = \"v0.2.4\";\n expects = false;\n };\n { before = \"v0.1.5\";\n after = \"v0.2.4\";\n expects = false;\n };\n { before = \"v0.1.3\";\n after = \"v1.2.4\";\n expects = false;\n };\n { before = \"v1.1.5\";\n after = \"v1.2.4\";\n expects = true;\n };\n ]\n );\n ]\n" }, { "path": "test/testRange.ml", "content": "\nlet test_pp_dummy () =\n let rng = Range.dummy \"foo\" in\n Alcotest.(check string) \"same string\" \"(foo)\" (Format.asprintf \"%a\" Range.pp rng)\n\n\nlet () =\n let open Alcotest in\n run \"Range\" [\n (\"dummy\", [\n test_case \"pp dummy\" `Quick test_pp_dummy;\n ]);\n ]\n" }, { "path": "test/testTypechecker.ml", "content": "\nopen Syntax\n\n\nmodule rec MonoTypeVarUpdatable : sig\n type t = mono_type_var_updatable\n val pp : Format.formatter -> t -> unit\n val equal : t -> t -> bool\nend = struct\n\n type t = mono_type_var_updatable\n\n let pp ppf mtv =\n Format.fprintf ppf \"%s\" (show_mono_type_var_updatable mtv)\n\n let equal (mtvu1 : t) (mtvu2 : t) : bool =\n match (mtvu1, mtvu2) with\n | (Link(ty1), Link(ty2)) -> MonoType.equal ty1 ty2\n | (Free(fid1), Free(fid2)) -> FreeID.equal fid1 fid2\n | _ -> false\nend\n\nand MonoType : sig\n type t = mono_type\n val pp : Format.formatter -> t -> unit\n val equal : t -> t -> bool\nend = struct\n\n type t = mono_type\n\n let pp = pp_mono_type\n\n let equal (ty1 : t) (ty2 : t) : bool =\n\n let rec aux ((_, tymain1) : t) ((_, tymain2) : t) : bool =\n match (tymain1, tymain2) with\n | (BaseType(bt1), BaseType(bt2)) ->\n bt1 = bt2\n\n | (FuncType(tydoms1, tycod1), FuncType(tydoms2, tycod2)) ->\n aux_list tydoms1 tydoms2 && aux tycod1 tycod2\n\n | (PidType(pidty1), PidType(pidty2)) ->\n aux_pid pidty1 pidty2\n\n | (EffType(effty1, ty1), EffType(effty2, ty2)) ->\n aux_effect effty1 effty2 && aux ty1 ty2\n\n | (TypeVar(MustBeBound(mbbid1)), TypeVar(MustBeBound(mbbid2))) ->\n MustBeBoundID.equal mbbid1 mbbid2\n\n | (TypeVar(Updatable(r1)), TypeVar(Updatable(r2))) ->\n MonoTypeVarUpdatable.equal !r1 !r2\n\n | (ProductType(tys1), ProductType(tys2)) ->\n aux_list (TupleList.to_list tys1) (TupleList.to_list tys2)\n\n | (ListType(ty1), ListType(ty2)) ->\n aux ty1 ty2\n\n | (DataType(tyid1, tys1), DataType(tyid2, tys2)) ->\n TypeID.equal tyid1 tyid2 && aux_list tys1 tys2\n\n | _ ->\n false\n\n and aux_list (tys1 : t list) (tys2 : t list) : bool =\n match List.combine tys1 tys2 with\n | exception Invalid_argument(_) -> false\n | typairs -> typairs |> List.for_all (fun (ty1, ty2) -> aux ty1 ty2)\n\n\n and aux_pid (Pid(ty1)) (Pid(ty2)) =\n aux ty1 ty2\n\n and aux_effect (Effect(ty1)) (Effect(ty2)) =\n aux ty1 ty2\n\n in\n aux ty1 ty2\n\nend\n\n\nlet mono_type_var_updatable_witness : mono_type_var_updatable Alcotest.testable =\n (module MonoTypeVarUpdatable : Alcotest.TESTABLE with type t = mono_type_var_updatable)\n\n\nlet test_unify (ty1, ty2, assoc) () =\n Typechecker.unify ty1 ty2;\n assoc |> List.iter (fun (fid, mtvu_nonref) ->\n Alcotest.check mono_type_var_updatable_witness \"free variable\" !fid mtvu_nonref\n )\n\n\nlet dr = Range.dummy \"test\"\n\n\nlet () =\n let open Alcotest in\n run \"Typechecker\" [\n (\"unify\",\n List.map (fun tuple ->\n test_case \"unify\" `Quick (test_unify tuple)\n ) [\n begin\n let fid = FreeID.fresh 0 in\n let mtvu = ref (Free(fid)) in\n let ty1 = (dr, TypeVar(Updatable(mtvu))) in\n let ty2 = (dr, BaseType(IntType)) in\n (ty1, ty2, [ (mtvu, Link(ty2)) ])\n end\n ]);\n ]\n" } ]