Repository: gfngfn/Sesterl Branch: master Commit: f8c4de3b53a3 Files: 193 Total size: 520.6 KB Directory structure: gitextract_laa9jxxo/ ├── .github/ │ └── workflows/ │ └── ci.yml ├── .gitignore ├── .gitmodules ├── CHANGELOG.md ├── Makefile ├── README.md ├── dune-project ├── examples/ │ ├── echo_server/ │ │ ├── README.md │ │ ├── rebar.config │ │ ├── sesterl.yaml │ │ ├── src/ │ │ │ ├── echo_server.app.src │ │ │ ├── echo_server.sest │ │ │ ├── handler.sest │ │ │ └── sup.sest │ │ └── test/ │ │ └── handler_tests.sest │ └── hello_world/ │ ├── README.md │ ├── rebar.config │ ├── sesterl.yaml │ └── src/ │ ├── Main.sest │ └── hello_world.app.src ├── run-negative-blackbox-tests.sh ├── run-positive-blackbox-tests.sh ├── sesterl.opam ├── src/ │ ├── address.ml │ ├── address.mli │ ├── assocList.ml │ ├── boundID.ml │ ├── boundID.mli │ ├── configLoader.ml │ ├── constants.ml │ ├── constructorAttribute.ml │ ├── constructorID.ml │ ├── constructorID.mli │ ├── declarationAttribute.ml │ ├── dependencyGraph.ml │ ├── dependencyGraph.mli │ ├── displayMap.ml │ ├── displayMap.mli │ ├── documentGenerator.ml │ ├── dune │ ├── env.ml │ ├── env.mli │ ├── errors.ml │ ├── fileDependencyGraph.ml │ ├── fileDependencyGraph.mli │ ├── freeID.ml │ ├── freeID.mli │ ├── identifierScheme.ml │ ├── identifierScheme.mli │ ├── intermediateSyntax.ml │ ├── kindStore.ml │ ├── kindStore.mli │ ├── languageVersion.ml │ ├── lexer.mll │ ├── list1.ml │ ├── list1.mli │ ├── list2.ml │ ├── list2.mli │ ├── logging.ml │ ├── main.ml │ ├── moduleAttribute.ml │ ├── mustBeBoundID.ml │ ├── myUtil.ml │ ├── outputErlangCode.ml │ ├── outputErlangCode.mli │ ├── outputIdentifier.ml │ ├── outputIdentifier.mli │ ├── outputRebarConfig.ml │ ├── packageChecker.ml │ ├── packageLoader.ml │ ├── packageLoader.mli │ ├── parser.mly │ ├── parserInterface.ml │ ├── parserInterface.mli │ ├── primitives.ml │ ├── primitives.mli │ ├── range.ml │ ├── range.mli │ ├── sourceLoader.ml │ ├── sourceLoader.mli │ ├── syntax.ml │ ├── typeConv.ml │ ├── typeID.ml │ ├── typeID.mli │ ├── typechecker.ml │ ├── typechecker.mli │ ├── valueAttribute.ml │ ├── yamlDecoder.ml │ └── yamlDecoder.mli └── test/ ├── concept/ │ ├── cell.sest │ └── counter.sest ├── dune ├── fail/ │ ├── error01.sest │ ├── error_arity.sest │ ├── error_coercion.sest │ ├── error_coercion2.sest │ ├── error_coercion3.sest │ ├── error_coercion4.sest │ ├── error_coercion5.sest │ ├── error_coercion6.sest │ ├── error_contradiction.sest │ ├── error_cyclic/ │ │ ├── error_cyclic.sest │ │ ├── error_cyclic_bar.sest │ │ ├── error_cyclic_foo.sest │ │ └── sesterl.yaml │ ├── error_first_class_module.sest │ ├── error_freeze.sest │ ├── error_functor.sest │ ├── error_inference.sest │ ├── error_kind.sest │ ├── error_kind2.sest │ ├── error_kind3.sest │ ├── error_kinded_parameter.sest │ ├── error_mandatory_parameter.sest │ ├── error_mandatory_parameter2.sest │ ├── error_mutrec.sest │ ├── error_optional_parameter.sest │ ├── error_optional_parameter_unify.sest │ ├── error_optional_parameter_unify2.sest │ ├── error_recursive_type_parameter.sest │ ├── error_recursive_type_parameter2.sest │ ├── error_type_cyclic.sest │ ├── error_variant.sest │ ├── error_with.sest │ └── recursive.sest ├── pass/ │ ├── adt.sest │ ├── arith.sest │ ├── coercion.sest │ ├── coercion2.sest │ ├── ctor.sest │ ├── ctor_attr.sest │ ├── ffi.sest │ ├── first.sest │ ├── functor.sest │ ├── functor2.sest │ ├── functor3.sest │ ├── inference.sest │ ├── kind.sest │ ├── kinded_parameter.sest │ ├── mandatory_parameter.sest │ ├── mod.sest │ ├── mod2.sest │ ├── mod3.sest │ ├── mod_seq.sest │ ├── mod_stack.sest │ ├── mutrec.sest │ ├── mutrec2.sest │ ├── optional_parameter.sest │ ├── optional_parameter2.sest │ ├── optional_parameter_unify.sest │ ├── poly.sest │ ├── record_test.sest │ ├── record_test2.sest │ ├── sample_project/ │ │ ├── .gitignore │ │ ├── sample_project.sest │ │ └── sesterl.yaml │ ├── sample_sup_usage/ │ │ ├── sample_sup_usage.sest │ │ └── sesterl.yaml │ ├── sample_test_dep/ │ │ ├── rebar.config │ │ ├── sesterl.yaml │ │ ├── src/ │ │ │ └── Main.sest │ │ └── test/ │ │ └── MainTest.sest │ ├── send.sest │ ├── send2.sest │ ├── test_after.sest │ ├── test_binary.sest │ ├── test_binary_pattern.sest │ ├── test_first_class_module.sest │ ├── test_first_class_module2.sest │ ├── test_float.sest │ ├── test_format.sest │ ├── test_freeze.sest │ ├── test_import/ │ │ ├── import_depended.sest │ │ ├── import_depending.sest │ │ └── sesterl.yaml │ ├── test_poly_rec.sest │ ├── test_public_type.sest │ ├── test_result.sest │ ├── test_string.sest │ ├── test_testing.sest │ ├── test_type.sest │ ├── test_with.sest │ └── variant.sest ├── rebar_test/ │ ├── .gitignore │ ├── README.md │ ├── rebar.config │ ├── sesterl.yaml │ └── src/ │ ├── foo.app.src │ └── foo.sest ├── testIdentifierScheme.ml ├── testLanguageVersion.ml ├── testRange.ml └── testTypechecker.ml ================================================ FILE CONTENTS ================================================ ================================================ FILE: .github/workflows/ci.yml ================================================ name: CI on: - pull_request - push jobs: build: name: Build strategy: fail-fast: false matrix: os: - macos-latest - ubuntu-latest ocaml-compiler: - 4.11.x - 4.12.x - 4.13.x runs-on: ${{ matrix.os }} steps: - name: Checkout code uses: actions/checkout@v2 - name: Setup OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v2 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} dune-cache: ${{ matrix.os != 'macos-latest' }} opam-depext-flags: --with-test - name: Setup Erlang if: ${{ matrix.os == 'macos-latest' }} run: brew install erlang - name: Install opam packages run: opam install . --deps-only --with-test - name: Build Sesterl run: opam exec -- make all - name: Run unit tests run: opam exec -- make test-unit - name: Run positive blackbox tests run: opam exec -- make test-blackbox-positive - name: Run negative blackbox tests run: opam exec -- make test-blackbox-negative - name: Upload compiler artifact if: ${{ matrix.ocaml-compiler == '4.13.x' }} uses: actions/upload-artifact@v2 with: name: sesterl-${{ matrix.os }} path: sesterl ================================================ FILE: .gitignore ================================================ _opam/ _build/ *~ .merlin .DS_Store sesterl _generated/ *.install _generated_test/ ================================================ FILE: .gitmodules ================================================ [submodule "external/stdlib"] path = external/stdlib url = https://github.com/gfngfn/sesterl_stdlib [submodule "external/testing"] path = external/testing url = https://github.com/gfngfn/sesterl_testing ================================================ FILE: CHANGELOG.md ================================================ # Changelog All notable changes to this project will be documented in this file. The 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). ## [Unreleased] ## [0.2.1] - 2021-12-12 ### Fixed - **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). - **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). ### Added - Support OCaml 4.13 ([PR\#50](https://github.com/gfngfn/Sesterl/pull/50) by @smorimoto). ## [0.2.0] - 2021-10-03 ### Fixed - 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). ### Added - Add a new field `language` to the config file format ([PR\#36](https://github.com/gfngfn/Sesterl/pull/36)). - 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)). - Allow patterns for function parameters ([PR\#45](https://github.com/gfngfn/Sesterl/pull/45)). - Allow `receive`-expressions to have `after`-branches ([PR\#46](https://github.com/gfngfn/Sesterl/pull/46); **breaking change** due to a new keyword `after`). ### Changed - 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**). - Change the type for the hole `~s` in patterns from `list` to `binary` ([PR\#33](https://github.com/gfngfn/Sesterl/pull/33); **breaking change**). - Omit the fallback mechanism for the old config file name `package.yaml` ([PR\#40](https://github.com/gfngfn/Sesterl/pull/40); **breaking change**). - 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**). - Reject `do`-expressions without binders ([PR\#45](https://github.com/gfngfn/Sesterl/pull/45); **breaking change**). - Remove floating-point-number-related primitives ([PR\#48](https://github.com/gfngfn/Sesterl/pull/48); **breaking change**). ## [0.1.5] - 2021-08-14 ### Fixed - Fix an unsound type-checking behavior about record kinds ([PR\#35](https://github.com/gfngfn/Sesterl/pull/35)). ## [0.1.4] - 2021-07-15 ### Changed - 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). ## [0.1.3] - 2021-07-11 ### Fixed - Fix how to load test dependencies. - Fix how to output string/binary literals about non-ASCII characters ([PR\#22](https://github.com/gfngfn/Sesterl/pull/22) by @michallepicki). - Update GitHub Actions workflow ([PR\#12](https://github.com/gfngfn/Sesterl/pull/12) by @smorimoto). - Fix how to check type definitions ([PR\#30](https://github.com/gfngfn/Sesterl/pull/30)). - Fix how to perform the universal quantification ([PR\#31](https://github.com/gfngfn/Sesterl/pull/31)). ### Added - Add binary literal patterns ([PR\#28](https://github.com/gfngfn/Sesterl/pull/28)). - Support fully-annotated polymorphic recursion ([PR\#31](https://github.com/gfngfn/Sesterl/pull/31)). ## [0.1.2] - 2021-05-29 ### Added - Introduce the notion of attributes of the form `#[foo(…)]`. - Introduce attributes `#[test]`, `#[behavior(…)]`, and `#[atom(…)]`. - Add the syntax `assert e` for tracking code positions in unit tests. - Separate test dependencies from dependencies. - Collaborate with EUnit. - Add the syntax `open M`. ### Changed - Change how to compile `None` and `Some` (**breaking change for FFIs**). ### Fixed - Largely fix the type-checking algorithm (mainly about how to track type synonyms). - Fix how to treat relative paths given via command lines. ## [0.1.1] - 2021-05-16 ### Added - Add the syntax sugar of list patterns. - Add patterns of the form `Module.Constructor`. - Add the variant type `result`. - Add first-class modules based on the formalization of F-ing modules. - Add option `-p` for specifying paths of external packages, which will be used mainly for the collaboration with Rebar3. ### Changed - Change output module names from `foo_bar_baz.erl` to `Foo.Bar.Baz.erl` (**breaking change for FFIs**). ### Fixed - Fix the parser about unit patterns and Boolean patterns. - Quote global names in order to avoid clashes with keywords. ## [0.1.0] - 2021-05-02 ### Added - Develop the collabration with Rebar3. - Add the command line `sesterl config ` for generating `rebar.config`. ### Changed - Change the command line spec from `sesterl -o ` to `sesterl build -o `. - Change the syntax of effect types from `[τ]τ` to `fun(τ, …, τ) -> [τ]τ` (**breaking change**). - Separate the syntax of expressions and that of computations by using the newly introduced keyword `act` (**breaking change**). ## 0.0.1 - 2020-10-29 The initial release [Unreleased]: https://github.com/gfngfn/Sesterl/compare/v0.2.1...HEAD [0.2.1]: https://github.com/gfngfn/Sesterl/compare/v0.2.0...v0.2.1 [0.2.0]: https://github.com/gfngfn/Sesterl/compare/v0.1.5...v0.2.0 [0.1.5]: https://github.com/gfngfn/Sesterl/compare/v0.1.4...v0.1.5 [0.1.4]: https://github.com/gfngfn/Sesterl/compare/v0.1.3...v0.1.4 [0.1.3]: https://github.com/gfngfn/Sesterl/compare/v0.1.2...v0.1.3 [0.1.2]: https://github.com/gfngfn/Sesterl/compare/v0.1.1...v0.1.2 [0.1.1]: https://github.com/gfngfn/Sesterl/compare/v0.1.0...v0.1.1 [0.1.0]: https://github.com/gfngfn/Sesterl/compare/v0.0.1...v0.1.0 ================================================ FILE: Makefile ================================================ .PHONY: all all: dune build -p sesterl cp _build/default/src/main.exe ./sesterl .PHONY: test test: test-blackbox-positive test-blackbox-negative test-unit .PHONY: test-unit test-unit: dune exec test/testRange.exe dune exec test/testLanguageVersion.exe dune exec test/testIdentifierScheme.exe .PHONY: test-blackbox-positive test-blackbox-positive: submodule ./run-positive-blackbox-tests.sh .PHONY: test-blackbox-negative test-blackbox-negative: submodule ./run-negative-blackbox-tests.sh .PHONY: submodule submodule: git submodule update --init --recursive .PHONY: clean clean: dune clean .PHONY: clean-test clean-test: rm -f test/_generated/* ================================================ FILE: README.md ================================================ # Sesterl: A Session-Typed Erlang ## Summary *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: * First-class higher-order functions * ADTs and pattern matching * The standard *Damas–Milner polymorphism* (i.e. so-called the *let-polymorphism*) and *Hindley–Milner type inference* \[Hindley 1969\]\[Milner 1978\] * Type-level distinction between pure calculations and concurrent computations by a kind of monads \[Fowler 2019\] * A module system equipped with functors and first-class modules based on *F-ing modules* \[Rossberg, Russo & Dreyer 2014\] ## Table of contents - [How to install](#how-to-install) - [How to build source files for development](#how-to-build-source-files-for-development) - [How to use](#how-to-use) - [Example code](#example-code) - [Libraries](#libraries) - [Features](#features) - [Function definition](#function-definition) - [Polymorphism](#polymorphism) - [ADTs](#adts) - [Pattern matching](#pattern-matching) - [Concurrency](#concurrency) - [Module system](#module-system) - [OTP as functors](#otp-as-functors) - [FFI](#ffi) - [Labeled optional parameters](#labeled-optional-parameters) - [Labeled mandatory parameters](#labeled-mandatory-parameters) - [Records](#records) - [Doc comments](#doc-comments) - [Writing tests](#writing-tests) - [Major differences from similar projects](#major-differences-from-similar-projects) - [Future work](#future-work) - [TODO list](#todo-list) - [Configuration file format](#configuration-file-format) - [Overall syntax](#overall-syntax) - [References](#references) ## How to install Under the condition that Dune (≥ 2.5) and OPAM are installed, invoke: ```console $ git clone https://github.com/gfngfn/Sesterl.git $ cd Sesterl $ opam pin add sesterl . # Probably this command asks you whether to install the package (and its dependencies). # You may answer Y to do so. $ sesterl --version ``` ## How to build source files for development Under the condition that Dune (≥ 2.5) and Make are installed, invoke: ``` $ opam install . --deps-only --with-test $ make ``` ## How to use ### Building a single source file Invoke: ```console $ sesterl build -o ``` where `` 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`). ### Building with Rebar3 [*Rebar3*](https://github.com/erlang/rebar3) is a popular build system for Erlang programs. Sesterl can collaborate with Rebar3. Based on a configuration file (i.e., `sesterl.yaml`), the following command will generate `rebar.config`: ```console $ sesterl config ./ ``` Then you can invoke the following command to compile Sesterl programs before Rebar3 compiles Erlang code: ```console $ rebar3 sesterl compile ``` Here, `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). Running unit tests (by using [*EUnit*](http://erlang.org/doc/apps/eunit/chapter.html)) can be done by the following: ```console $ rebar3 sesterl test ``` ## Example code Example usages can be seen in the following: * [`examples/` in this repository](https://github.com/gfngfn/Sesterl/tree/master/examples) * [`test/pass/` in this repository](https://github.com/gfngfn/Sesterl/tree/master/test/pass) * [`game_tianjiupai`](https://github.com/gfngfn/game_tianjiupai) ## Libraries * [`sesterl_stdlib`](https://github.com/gfngfn/sesterl_stdlib) - The standard library for Sesterl. - Contains modules for manipulating basic values and collections (e.g. `Binary`, `List`). - Contains modules for constructing OTP-compliant processes (e.g. `GenServer`, `Supervisor`). * [`sesterl_testing`](https://github.com/gfngfn/sesterl_testing) - A testing library for Sesterl. - Uses [*EUnit*](http://erlang.org/doc/apps/eunit/chapter.html). - Tests written by this module can be run by `rebar3 sesterl test`. * [`sesterl_json`](https://github.com/gfngfn/sesterl_json) - A JSON-handling library. - Has APIs similar to those of Elm’s [`elm/json`](https://package.elm-lang.org/packages/elm/json/latest/). - Uses [*jsone*](https://github.com/sile/jsone) internally. * [`sesterl_cowboy`](https://github.com/gfngfn/sesterl_cowboy) - A small wrapper for [*Cowboy*](https://github.com/ninenines/cowboy). ## Features Sesterl provides many ML-inspired features (i.e. basically resembles OCaml, Standard ML, F\#, ReScript, etc.). ### Function definition Top-level (resp. local) functions are defined by `val`-bindings (resp. `let`-expressions): ``` val add(x, y) = x + y val add_partial(x) = let f(y) = x + y in f ``` Unlike 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)`. By using `fun`-expressions (i.e. *lambda abstractions*), `add_partial` can also be defined as follows: ``` val add_partial(x) = fun(y) -> x + y end ``` Incidentally, 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: ``` val add(x : int, y : int) : int = x + y ``` You can define higher-order functions, of course: ``` val apply(f, x) = f(x) ``` As is the case in ML, `apply` has a polymorphic type. Features related to type polymorphism is explained later. Recursive or mutually recursive functions can be defined by using `rec`/`and` keywords, not only globally but also in a local scope: ``` val rec fact(n) = if n <= 0 then 1 else n * fact(n - 1) val is_even_nat(n) = let rec odd(n) = if n == 0 then false else even(n - 1) and even(n) = if n == 0 then true else odd(n - 1) in if n < 0 then false else even(n) ``` Note 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. ### Polymorphism Values 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): ``` val proj1(x, y) = x ``` Instead of relying upon type inference, you can also annotate polymorphic types and check that the defined function is indeed polymorphic: ``` val proj1<$a, $b>(x : $a, y : $b) : $a = x ``` ### ADTs You can define (non-generalized) algebraic data types and type synonyms in a standard way like the following: ``` type name = binary type with_number<$a> = {$a, int} type bintree<$b> = | Node($b, bintree<$b>, bintree<$b>) | Empty ``` Here, `{$a, int}` is an example use of standard product types. As 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 `$`. Each 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: ``` type bintree<$b> | #[atom("branch")] Node($b, bintree<$b>, bintree<$b>) | #[atom("leaf")] Empty ``` List-generating constructors, `[]` (nil) and `::` (cons), are also supported by default. Optionals are also provided by default as follows: ``` type option<$a> = | #[atom("error")] None | #[atom("ok")] Some($a) ``` ### Pattern matching You can decompose values of ADTs by using `case`-expressions in an ordinary way like the following: ``` val reverse<$a>(xs : list<$a>) : list<$a> = let rec aux(acc, xs) = case xs of | [] -> acc | x :: tail -> aux(x :: acc, tail) end in aux([], xs) val rec tree_size<$a>(t : bintree<$a>) = case t of | Empty -> 0 | Node(_, t1, t2) -> 1 + tree_size(t1) + tree_size(t2) end ``` ### Concurrency As 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: * `self<$p> : fun() -> [$p]pid<$p>` * `send<$p, $q> : fun(pid<$q>, $q) -> [$p]unit` * `spawn<$p, $q> : fun(fun() -> [$q]unit) -> [$p]pid<$q>` Intuitively, `[τ]τ'` 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: ``` module Example = struct /* dummy */ val some_heavy_calculation(n) = n val rec wait_all(msgacc, n) = act if n <= 0 then return(msgacc) else receive | {pid, msg} -> let _ = print_debug(format(f'message ~p received from: ~p~n', {msg, pid})) in wait_all(msg :: msgacc, n - 1) end val rec spawn_all(pidacc, n) = act if n <= 0 then return(pidacc) else do parent <- self() in do pid <- spawn(fun() -> act do me <- self() in let msg = some_heavy_calculation(n) in send(parent, {me, msg}) end) in spawn_all(pid :: pidacc, n - 1) val main(arg) = act let n = 10 in do pids <- spawn_all([], n) in let _ = print_debug(format(f'spawned: ~p~n', {pids})) in do msgs <- wait_all([], n) in let _ = print_debug(msgs) in return({}) end ``` Here, 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. The 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`: * `spawn_all<$p, $q> : fun(list>, int) -> [$p]list>` * `wait_all<$q> : fun(list, list>) -> [{pid<$q>, answer}]list` As 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\]. ### Module system One 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: ``` /* mod.sest */ module Mod = struct signature Ord = sig type s :: o val compare : fun(s, s) -> int end module Map = fun(Elem : Ord) -> struct type elem = Elem.s type t<$a> = list<{elem, $a}> val rec find<$b>(x : elem, assoc : t<$b>) : option<$b> = case assoc of | [] -> None | {k, v} :: tail -> if Elem.compare(k, x) == 0 then Some(v) else find(x, tail) end end module Int = struct type s = int val compare(x : int, y : int) = y - x end module IntMap = Map(Int) end ``` The program above is compiled to the following Erlang modules (where line breaks and indentation are manually added for clarity): ```erlang -module('Mod.Int'). -export([compare/2]). compare(S13X, S14Y) -> (S14Y - S13X). ``` ```erlang -module('Mod.IntMap'). -export([find/2]). find(S17X, S18Assoc) -> case S18Assoc of [] -> error; [{S19K, S20V} | S21Tail] -> case ('Mod.Int':compare(S19K, S17X) == 0) of true -> {ok, S20V}; false -> 'Mod.IntMap':find(S17X, S21Tail) end end. ``` Note that nested modules are flattened and given names of the form `'.. ... .'` where each `` is a module identifier. What 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\]. ### OTP as functors One 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`: ``` module GenServer : sig type initialized :: (o) -> o val init_ok<$msg, $state> : fun($state) -> [$msg]initialized<$state> val init_stop<$msg, $state> : fun(StopReason.t) -> [$msg]initialized<$state> type reply :: (o, o, o) -> o val reply<$msg, $response, $state> : fun($response, $state, ?timeout int) -> [$msg]reply<$msg, $response, $state> val reply_and_stop<$msg, $response, $state> : fun(StopReason.t, $response, $state) -> [$msg]reply<$msg, $response, $state> type no_reply :: (o) -> o val no_reply<$msg, $state> : fun($state, ?timeout int) -> [$msg]no_reply<$state> val no_reply_and_stop<$msg, $state> : fun(StopReason.t, $state) -> [$msg]no_reply<$state> type start_link_error = RawValue.t type call_error = RawValue.t signature Behaviour = sig type init_arg :: o type request :: o type response :: o type cast_message :: o type info :: o type state :: o type global :: o val init : fun(init_arg) -> [info]initialized val handle_call<$a> : fun(request, pid<$a>, state) -> [info]reply val handle_cast : fun(cast_message, state) -> [info]no_reply val handle_info : fun(info, state) -> [info]no_reply val handle_timeout : fun(state) -> [info]no_reply val handle_down<$a> : fun(MonitorRef.t, pid<$a>, StopReason.t, state) -> [info]no_reply val terminate : fun(StopReason.t, state) -> [info]unit end module Make : fun(Callback : Behaviour) -> sig type proc :: o val as_pid : fun(proc) -> pid val from_pid : fun(pid) -> proc val call<$a> : fun(proc, Callback.request, ?timeout int) -> [$a]result val cast<$a> : fun(proc, Callback.cast_message) -> [$a]unit val send_info<$a> : fun(proc, Callback.info) -> [$a]unit val start_link<$a> : fun(Callback.init_arg) -> [$a]result val start_link_name<$a> : fun(Callback.init_arg, -name name) -> [$a]result val where_is_local<$a> : fun(binary) -> [$a]option val where_is_global<$a> : fun(Callback.global) -> [$a]option val stop<$a> : fun(proc) -> [$a]unit end end ``` ### FFI Functions written in Erlang can be called from Sesterl via FFI (foreign function interface) as follows: ```` module FfiExample = struct val assoc<$a> : fun(int, list<(int, $a)>) -> option<($a, list<(int, $a)>)> = external 2 ``` assoc(Key, Xs) -> case lists:keytake(Key, 1, Xs) of false -> error; {value, {_, V}, Rest} -> {ok, {V, Rest}} end. ``` val main() = assoc(1, [ (3, "Komaba"), (1, "Hongo"), (4, "Yayoi"), (1, "Asano"), (5, "Kashiwa") ]) end ```` This program compiles to the following implementation: ```erlang -module('FfiExample'). -export([assoc/2, main/0]). assoc(Key, Xs) -> case lists:keytake(Key, 1, Xs) of false -> error; {value, {_, V}, Rest} -> {ok, {V, Rest}} end. main() -> 'FfiExample':assoc(1, [ {3, <<"Komaba">>}, {1, <<"Hongo">>}, {4, <<"Yayoi">>}, {1, <<"Asano">>}, {5, <<"Kashiwa">>}]). ``` ### Labeled optional parameters Functions can have labeled optional parameters: ``` val succ(n : int, ?diff dopt : option) = case dopt of | None -> n + 1 | Some(d) -> n + d end val f(g) = {g(36), g(36, ?diff 64)} val main() = {succ(42), succ(42, ?diff 15), f(succ)} /* This evaluates to {43, 57, {37, 100}} in Erlang. */ ``` In 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. The functions `succ` and `f` defined above are given types as follows: ``` val succ : fun(int, ?diff int) -> int val f<$a, ?$r :: (diff)> : fun(fun(int, ?diff int, ?$r) -> $a) -> ($a, $a) ``` Here, `?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`. `?$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). ### Labeled mandatory parameters You can also use labeled mandatory parameters/arguments: ``` val rec foldl(-f f, -init init, -list xs) = case xs of | [] -> init | y :: ys -> foldl(-init f(init, y), -list ys, -f f) end ``` Here, `-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: ``` val fold<$a, $b> : fun( -f fun($a, $b) -> $a, -init $a, -list list<$b>, ) -> $a ``` You can use non-labeled parameters (resp. arguments) and labeled ones for the same function. At least currently, however, their order must be: 1. (possibly empty) non-labeled parameters (resp. arguments), 2. (possibly empty) labeled mandatory ones, and 3. (possibly empty) labeled optional ones. In other words, abstractions (resp. applications) must be of the following form: ``` fun(param1, …, paramL, -m1 mparam1, … -mM mparamM, ?o1 oparam1, … ?oN oparamN) -> … f(arg1, …, argL, -m1 marg1, … -mM margM, ?o1 oarg1, … ?oN oargN) ``` ### Records A *record* is a labeled tuple that has the following syntax: ``` {foo = 42, bar = true} ``` Labels should be distinct from each other in one record value. The expression above has the following type: ``` {foo : int, bar : bool} ``` You can also extract values from records as follows: ``` let r = {foo = 42, bar = true} in r.foo /* => 42 */ ``` In 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: ``` val get_foo(x) = x.foo ``` The function `get_foo` is typed like the following: ``` val get_foo<$a, ?$r :: (foo)> : fun({foo : $a, ?$r}) -> $a ``` Here, `(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: ``` val main() = get_foo({foo = 42, bar = true}) ``` and the following is ill-typed on the other hand: ``` val main() = get_foo({bar = true}) ``` Note: Prior to Sesterl 0.2.0, polymorphic typing for records was based on the one used in *SML\#* \[Ohori 1995\]. ### Doc comments You 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: ```` module List :> sig ... #[doc(``` `map f [v_1, …, v_n]` applies function `f` to each `v_i` in the given order, and builds the list [f v_1, …, f v_n] with the results produced by `f`. ```)] val map<$a, $b> : fun(fun($a) -> $b, list<$a>) -> list<$b> ... end = struct ... end ```` (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.) You can, for example, generate documents `./_docs/your_package.html` by specifying the following description in your configuration file: ```yaml document_outputs: - format: type: "html" output_directory: "./_doc" ``` ## Writing tests You can write test modules like the following: ``` ./ ├── README.md ├── sesterl.yaml ├── rebar.config ├── rebar.lock ├── src/ │   └── Adder.sest └── test/ └── AdderTests.sest ``` `sesterl.yaml`: ``` package: "adder" language: "v0.2.0" source_directories: - "./src" main_module: "Adder" test_directories: - "./test" ``` `src/Adder.sest`: ``` module Adder = struct val add(m, n) = m + n end ``` `test/AdderTests.sest`: ``` import Adder module AdderTests = #[test] struct #[test] val adder_test() = Testing.it("42 plus 57 equals 99", fun() -> assert Testing.equal( -expect 99, -got Adder.add(42, 57), ) end) end ``` The following makes the test run: ``` $ sesterl config ./ $ rebar3 sesterl test ``` ## Major differences from similar projects There have been brilliant functional languages that compile to Erlang or BEAM (i.e. bytecode for Erlang VM). Some of them are the following: * [*Elixir*](https://elixir-lang.org/) \[Valim et al. 2011–2021\] - Definitely the most well-known AltErlang language, and well-used in productions. - Compiles to Erlang AST. - Untyped (i.e. dynamically typed). - Has Ruby-like syntax. - Supports Lisp-like meta-programming features by quoting/unquoting. * [*Alpaca*](https://github.com/alpaca-lang/alpaca) \[Pierre et al. 2016–2019\] - Statically typed. - Compiles to Core Erlang compiler IR. - Has static guarantee about types of messages sent or received between processes. - Has OCaml- or Elm-like syntax. - Implemented in Erlang. * [*Gleam*](https://github.com/gleam-lang/gleam) \[Pilfold et al. 2018–2021\] - Statically typed. - Compiles to sources in Erlang. - Has Rust-like syntax. - Implemented in Rust. Major differences between the features of Sesterl and those of the languages above are: * an ML-like module system that supports: - abstraction by using signatures, and - functors and their elimination at compilation time (called the *static interpretation* \[Elsman, Henriksen, Annenkov & Oancea 2018\]); * a kind of monadic types for distinguishing pure calculations from concurrent computations. Also, though not supporting them currently, we want to add features like the following (see “[Future work](#future-work)” for detail): * GADTs for typing synchronous message-passing operations more strictly. * Session types in a gradually-typed manner. ## Future work * Support recursive modules. * Support GADTs. - This is mainly for typing `gen_server` callbacks as to synchronous messages. - The formalization of such a type system and a type inference algorithm will probably be based on *choice types* \[Chen & Erwig 2016\]. * Support (multiparty) session types. - 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. ### TODO list * [ ] Message-passing primitives * [x] `spawn` * [x] `receive`-expressions * [x] `send` * [x] `self` * [x] `MonitorRef.monitor<$a, $b> : fun(pid<$b>) -> [$a]MonitorRef.t` * [x] `MonitorRef.demonitor<$a> : fun(MonitorRef.t) -> [$a]unit` * [ ] Special message `down(MonitorRef.t, StopReason.t)` representing `{'DOWN', MRef, process, Pid, Reason}` * [ ] `link<$a, $b> : fun(pid<$b>) -> [$a]unit` * [ ] `unlink<$a, $b> : fun(pid<$b>) -> [$a]unit` * [x] Principal type inference * [x] Type annotation * [x] Output Erlang code * [x] FFI * [ ] Data types * [x] Strings (as lists of code points) * [x] Binaries * [x] Monitoring references `MonitorRef.t` * [ ] Unique references * [x] Product types * [x] Lists * [x] User-defined ADTs * [x] Type synonyms * [x] Records * [x] Functions with labeled optional parameters * [x] Functions with labeled mandatory parameters * [ ] GADTs (especially for typing synchronous messages) * [x] Mutual recursion by generalized `val rec`-expressions * [ ] Pattern matching * [x] `case`-expressions * [x] Generalized `let`-expressions * [ ] Exhaustiveness check * [x] Module system * [x] Support for F-ing modules * [x] Compilation using the static interpretation * [x] First-class modules * [x] Configuration * [x] Loading external modules by `import` * [x] Package system * [x] Embedding external modules as submodules * [x] Connection with Rebar3 * [ ] (Multiparty) session types ## Configuration file format Configuration 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: ``` Config := { package: String # The name of the package. Example: "sesterl_json" language: String # The minimum version of Sesterl required by the package. # Example: "v0.2.0" # The Sesterl compiler refers to this field for checking that # the compiler is backward-compatible with the required version. # This field is optional. No check will be performed if omitted. source_directories: Array # The list of directories where source files are placed. # All the source files (i.e. files that have # ".sest", ".erl", or ".app.src" as their extension) # that are exactly at one of the specified directories will be used for compilation. # Specified directories must be relative to the configuration file. # Example: [ "./src", "./src/generated" ] main_module: String # The name of the main module of the package. # The *main module* of a package is defined to be # the sole module visible from the outside of the package. test_directories: Array # The list of directories where test files are placed. # Specified directories must be relative to the configuration file. # This field is optional. Default: [] # Example: [ "./test" ] dependencies: Array # This field is optional. Default: [] test_dependencies: Array # This field is optional. Default: [] erlang: ErlangConfig # This field is optional. Default: {} document_outputs: Array # Settings for the document generation. # This field is optional. Default: [] } Dependency := { name: String # The name of the dependency. source: (GitSource | LocalSource) # Describes how to get the dependency. } GitSource := { type: "git" repository: String # The URI of the Git repository. spec: (TagSpec | RefSpec | BranchSpec) # Describes which commit to use. } TagSpec := { type: "tag" value: String # Example: "v1.3.0" } RefSpec := { type: "ref" value: String # A commit hash. } BranchSpec := { type: "branch" value: String # Example: "master" } LocalSource := { type: "local" directory: String # The directory where the dependency is placed. } HexSource := { type: "hex" version: String # The version number. } ErlangConfig := { output_directory: String # The directory at which Erlang modules are generated. # Must be relative to the configuration file. # This field is Optional. Default: "./_generated" test_output_directory: String # The directory at which Erlang test modules for EUnit are generated. # Must be relative to the configuration file. # This field is Optional. Default: "./_generated_test" erlang_dependencies: Array # The Erlang libraries on which the package depends. # This field is optional. Default: [] relx: Relx # This field is optional. # No `relx` stanza will be written on `rebar.config` if omitted. } ErlangDependency := { name: String # The name of the package. Example: "cowboy" source: (HexSource | GitSource) # Describes how to get the Erlang library. } Relx := { release: RelxRelease dev_mode: Boolean # This field is optional. Default: false } RelxRelease := { name: String version: String applications: Array } DocumentOutput := { format: { type: "html" } # The format of output documents. # Only HTML is supported so far. output_directory: String # The directory at which documents are generated. # Must be relative to the configuration file. # Example: [ "./_doc" ] } ``` ## Overall syntax How to read: * a word enclosed by single quotation marks (e.g. `'let'` or `'('`): - a keyword token or a symbol token * a word without quotations (e.g. `E` or `val-args`): - a metavariable of the (extended) BNF * `(empty)` - the empty sequence of tokens * `( DESCR )*` - a possibly empty finite repetition of `DESCR` * `( DESCR )+` - equals `DESCR ( DESCR )*` * `(empty)` - no token (i.e. a token sequence of length zero) * `(DESCR1 | DESCR2)` - either `DESCR1` or `DESCR2` * `( DESCR )?` - equals `((empty) | DESCR)` ``` n ::= (decimal or hexadecimal integer literals) float-lit ::= (floating-point number literals) bin-lit ::= (string literals enclosed by double quotation marks) X, C ::= (capitalized identifiers) x, t, k, l ::= (lowercased identifiers other than keywords) $a ::= (lowercased identifiers preceded by a dollar sign) ?$a ::= (lowercased identifiers preceded by a question mark and a dollar sign) -l ::= (lowercased identifiers preceded by a hyphen) ?l ::= (lowercased identifiers preceded by a question mark) # source files: source-file ::= | ('import' X)* 'module' X (':>' S) '=' 'struct' (open-spec)* (bind)* 'end' # value expressions: E ::= | '(' E ')' | E binary-operator E | (X '.')* x | (X '.')* C # variant constructors | E '(' val-args ')' # function applications | 'let' bind-val-local 'in' E # local bindings | 'let' pattern '=' E 'in' E # local bindings by the pattern matching | 'fun' '(' val-params ')' '->' E 'end' # pure abstractions | 'fun' '(' val-params ')' '->' 'act' P 'end' # effectful abstractions | 'if' E 'then' E 'else' E # conditionals | 'case' E 'of' (pure-case)+ 'end' # pattern-matching expressions | '{' '}' # the unit value | '{' E (',' E)* (',')? '}' # tuples | '{' l '=' E (',' l '=' E)* (',')? '}' # records | E '.' l # record access | '{' E '|' l '=' E (',' l '=' E)* (',')? '}' # record update | 'freeze' (X '.')* x '(' freeze-args ')' # so-called (possibly partial) mfargs() in Erlang | 'freeze' '(' E ')' 'with' '(' freeze-args ')' # addition of arguments to partial mfargs() | 'pack' M ':' S # packed first-class modules | 'assert' E # assertion for tests | E '::' E # cons | '[' ']' # nil | n | float-lit | bin-lit | 'true' | 'false' | ... pure-case ::= | '|' pattern '->' E # effectful computations: P ::= | 'do' pattern '<-' P 'in' P # sequential compositions (i.e. so-called monadic binds) | 'receive' (effectful-case)+ after-branch 'end' # selective receive | E '(' val-args ')' # function applications | 'if' E 'then' P 'else' P # conditionals | 'case' E 'of' (effectful-case)+ 'end' # pattern-matching expressions effectful-case ::= | '|' pattern '->' P after-branch ::= | (empty) | 'after' E '->' P # sequences of arguments for function applications: val-args ::= | E (',' val-args)? | val-labeled-args val-labeled-args ::= | -l E (',' val-labeled-args)? | val-optional-args val-optional-args ::= | ?l E (',' val-optional-args)? | (empty) # patterns for the pattern matching: pattern ::= | '_' # wildcard | x # variable binding | C # constructors with no argument | C '(' pattern (',' pattern)* (',')? ')' # constructors with arguments | '{' '}' # the unit pattern | '{' pattern (',' pattern)* (',')? '}' # tuples | pattern '::' pattern # cons | '[' ']' # nil | n | bin | 'true' | 'false' | ... # types: T ::= | $a # type variables | (X '.')* t ty-args # applications of type constructors | 'fun' '(' ty-doms ')' '->' T # function types | 'fun' '(' ty-doms ')' '->' '[' T ']' T # action types | '{' T (',' T)* (',')? '}' # product types | '{' l '=' T (',' l '=' T)* (',')? '}' # record types | 'pack' S # types for first-class modules # sequences of type arguments: ty-args ::= | ('<' ty-args-sub '>')? ty-args-sub ::= | T (',' ty-args-sub)? | (empty) # sequences of domain types: ty-doms ::= | T (',' ty-doms)? | ty-labeled-doms ty-labeled-doms ::= | -l T (',' ty-labeled-doms)? | ty-optional-doms | ?$a ty-optinal-doms ::= | ?l T (',' ty-optional-doms)? | (empty) # a kind: K ::= | kd-base # base kinds (i.e. order-0 kinds) | '(' kd-base (',' kd-base)* (',')? ')' '->' kd-base # order-1 kinds kd-base ::= | k # named base kinds (currently only 'o' is provided) | kd-row # row kinds kd-row ::= | '(' labels ')' labels ::= | l ',' labels | l | (empty) open-spec ::= | 'open' (X '.')* X # module expressions: M ::= | '(' M ')' | (X '.')* X | 'struct' (open-spec)* (bind)* 'end' # structures | 'fun' '(' X ':' S ')' '->' M # functor abstractions | (X '.')* X '( M )' # functor applications | X ':>' S # coercion # bindings (i.e. members of structures): bind ::= | 'val' (bind-val-local | bind-val-ffi) | 'type' bind-ty | 'module' X (':>' S)? '=' M | 'signature' X '=' S | 'include' M # signature expressions: S ::= | '(' S ')' | (X '.')* X | 'sig' (open-spec)* (decl)* 'end' # structure signatures | 'fun' '(' X ':' S ')' '->' S # functor signatures | S 'with' 'type' bind-ty # declarations (i.e. members of structure signatures): decl ::= | 'val' x ty-quant ':' T | 'type' t ('::' K)? | 'type' t '=' bind-ty | 'module' X ':' S | 'signature' X '=' S bind-val-local ::= | bind-val-single # non-recursive definitions | 'rec' bind-val-single ('and' bind-val-single)* # (mutually) recursive definitions bind-val-single ::= | x ty-quant '(' val-params ')' (':' T)? '=' E # function definitions | x ty-quant '(' val-params ')' (':' '[' T ']' T)? '=' 'act' P # action definitions bind-val-ffi ::= | x ty-quant ':' T '=' 'external' n ('+')? string-block # FFI bind-ty ::= | bind-ty-single ('and' bind-ty-single)* bind-ty-single ::= | t ty-quant '=' ('|')? ctor-branch ('|' ctor-branch)* # variant type definitions | t ty-quant '=' T # type synonym definitions ctor-branch ::= | C ('(' T (',' T)* ')')? # a definition of a constructor and its parameter types # comma-separated sequences of value parameters (for function definitions): val-params ::= | pattern (':' T)? (',' val-params)? | val-labeled-params # comma-separated labeled parameters: val-labeled-params ::= | -l pattern (':' T)? (',' val-labeled-params)? | val-optional-params # comma-separated labeled optional parameters (possibly with default expressions): val-optional-params ::= | ?l pattern (':' T)? ('=' E)? (',' val-optional-params)? | (empty) # sequences of universal quantifiers for type parameters and row parameters ty-quant ::= | ('<' ty-params '>')? ty-params ::= | $a ',' ty-params | $a | row-params row-params ::= | ?$a '::' kd-row (',' row-params)? | (empty) ``` ## References * 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. * 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. * 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. * 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. * Roger Hindley. The principal type-scheme of an object in combinatory logic. *Transactions of the American Mathematical Society*, **146**, pp. 29–60, 1969. * Robin Milner. A theory of type polymorphism in programming. *Journal of Computer and System Sciences*, **17**, pp. 348–375, 1978. * 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. * 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. * 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. ================================================ FILE: dune-project ================================================ (lang dune 2.5) (name sesterl) (version 0.2.1) (using menhir 2.0) (generate_opam_files true) (source (github gfngfn/Sesterl)) (license MIT) (authors "T. Suwa") (maintainers "bd[dot]gfngfn[at]gmail[dot]com") (package (name sesterl) (synopsis "Sesterl: A Session-Typed Erlang") (description "Sesterl: A Session-Typed Erlang") (depends (alcotest :with-test) (dune (>= 2.5)) (menhir (>= 20200211)) (menhirLib (>= 20200211)) (cmdliner (>= 1.0.4)) (ocamlgraph (>= 1.8.8)) (semver2 (>= 1.2.0)) (core (>= 0.13.0)) (uutf (>= 1.0.2)) (yaml (>= 2.1.0)) (omd (>= 1.3.1)) (ppx_deriving (>= 4.4.1)))) ================================================ FILE: examples/echo_server/README.md ================================================ ## How to Compile and Run ```console # Generate `rebar.config` $ sesterl config ./ # Compile sources $ rebar3 sesterl compile # Run (after compiling sources) $ rebar3 shell # Test (after compiling sources) $ rebar3 eunit ``` Then you can see `http://localhost:8080` on your browser or some CLI tool: ``` $ curl "http://localhost:8080" Hello, Sesterl! (no text was given, 2) $ curl "http://localhost:8080/?text" Hello, Sesterl! (no text was given, 1) $ curl "http://localhost:8080/?text=foo" foo $ curl "http://localhost:8080/?text=Hello%20World" Hello World $ curl "http://localhost:8080/users/taro" taro ``` ================================================ FILE: examples/echo_server/rebar.config ================================================ {plugins, [{rebar_sesterl, {git, "https://github.com/gfngfn/rebar_sesterl_plugin.git", {branch, "master"}}}]}. {src_dirs, ["./_generated", "./src"]}. {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"}]}. {profiles, [{test, [{deps, [{sesterl_testing, {git, "https://github.com/gfngfn/sesterl_testing", {tag, "v0.0.2"}}}]}]}]}. {eunit_tests, [{dir, "./_generated_test"}, {dir, "./test"}]}. {relx, [{release, {echo_server, "0.1.0"}, [cowboy, echo_server]}, {dev_mode, true}]}. {sesterl_opts, [{output_dir, "./_generated"},{test_output_dir, "./_generated_test"}]}. ================================================ FILE: examples/echo_server/sesterl.yaml ================================================ package: "echo_server" language: "v0.2.0" source_directories: - "./src" test_directories: - "./test" main_module: "App" dependencies: - name: "sesterl_stdlib" source: type: "git" repository: "https://github.com/gfngfn/sesterl_stdlib" spec: type: "tag" value: "v0.4.0" - name: "sesterl_cowboy" source: type: "git" repository: "https://github.com/gfngfn/sesterl_cowboy" spec: type: "tag" value: "v0.1.0" test_dependencies: - name: "sesterl_testing" source: type: "git" repository: "https://github.com/gfngfn/sesterl_testing" spec: type: "tag" value: "v0.0.2" erlang: output_directory: "./_generated" test_output_directory: "./_generated_test" erlang_dependencies: - name: "cowboy" source: type: "hex" version: "2.8.0" relx: release: name: "echo_server" version: "0.1.0" applications: - "cowboy" - "echo_server" dev_mode: true ================================================ FILE: examples/echo_server/src/echo_server.app.src ================================================ {application, echo_server, [ {description, "An example echo server written in Sesterl"}, {vsn, "0.1.0"}, {registered, []}, {mod, {'EchoServer.App', []}}, {applications, [ kernel, stdlib, cowboy ]}, {env, []}, {modules, []}, {licenses, ["MIT"]}, {links, []} ]}. ================================================ FILE: examples/echo_server/src/echo_server.sest ================================================ import Sup import Handler module App = struct val start(start_type, start_args) = act let error = fun(x) -> Error(Stdlib.RawValue.forget(x)) end in let dispatch_res = Cowboy.make_dispatch_table(pack Handler : Cowboy.Handler, [ {"/", {}}, {"/users/:user_name", {}}, ]) in case dispatch_res of | Error(e) -> return(error(e)) | Ok(dispatch) -> do res <- Cowboy.start_clear(-name "echo_server", -port 8080, -dispatch dispatch) in case res of | Error(e) -> return(error(e)) | Ok(_) -> Sup.start_link({}) end end val stop(state) = act Cowboy.stop_listener("echo_server") end ================================================ FILE: examples/echo_server/src/handler.sest ================================================ module Handler = struct open Stdlib val status_code() = 200 val init(req, state) = act let bs = Cowboy.bindings(req) in let body = case RawMap.find("user_name", bs) of | Some(user_name) -> user_name | None -> let qs = Cowboy.parse_qs(req) in case RawMap.find("text", qs) of | Some(Some(text)) -> text | Some(None) -> "Hello, Sesterl! ('text' was given but no content)" | None -> "Hello, Sesterl! ('text' was not given)" end end in let header = RawMap.put("content-type", "text/plain", RawMap.new()) in do req <- Cowboy.reply( status_code(), header, body, req, ) in Cowboy.init_ok(req, state) end ================================================ FILE: examples/echo_server/src/sup.sest ================================================ module Sup = struct open Stdlib module S = Supervisor.Static module Callback = struct type child_id = unit type init_arg = unit type info = unit type global = unit val init(args) = act let sup_flags = S.make_sup_flags() in let child_specs = [] in S.init_ok(sup_flags, child_specs) end include S.Make(Callback) end ================================================ FILE: examples/echo_server/test/handler_tests.sest ================================================ import Handler module HandlerTests = #[test] struct #[test] val status_code_test() = Testing.it("status code test", fun() -> assert Testing.equal( -expect 200, -got Handler.status_code()) end) end ================================================ FILE: examples/hello_world/README.md ================================================ ```console # Generate/update `rebar.config` $ sesterl config ./ output written on '/path/to/repo/examples/hello_world/rebar.config'. # Build $ rebar3 sesterl compile ===> Verifying dependencies... ===> Compiling Sesterl programs (command: "sesterl build ./") ... parsing '/path/to/repo/examples/hello_world/src/Main.sest' ... type checking '/path/to/repo/examples/hello_world/src/Main.sest' ... output written on '/path/to/repo/examples/hello_world/_generated/HelloWorld.Main.erl'. output written on '/path/to/repo/examples/hello_world/_generated/sesterl_internal_prim.erl'. ===> Analyzing applications... ===> Compiling hello_world # Run $ rebar3 shell ===> Verifying dependencies... ===> Analyzing applications... ===> Compiling hello_world Erlang/OTP 24 [erts-12.0.1] [source] [64-bit] [smp:4:4] [ds:4:4:10] [async-threads:1] [jit] [dtrace] Eshell V12.0.1 (abort with ^G) 1> 'HelloWorld.Main':show(). <<"Hello World!">> ok 2> ``` ================================================ FILE: examples/hello_world/rebar.config ================================================ {plugins, [{rebar_sesterl, {git, "https://github.com/gfngfn/rebar_sesterl_plugin.git", {branch, "master"}}}]}. {src_dirs, ["_generated", "./src"]}. {deps, []}. {profiles, [{test, [{deps, []}]}]}. {eunit_tests, [{dir, "_generated_test"}]}. {sesterl_opts, [{output_dir, "_generated"},{test_output_dir, "_generated_test"}]}. ================================================ FILE: examples/hello_world/sesterl.yaml ================================================ package: "hello_world" language: "v0.2.0" main_module: "Main" source_directories: - "./src" ================================================ FILE: examples/hello_world/src/Main.sest ================================================ module Main = struct val show() = print_debug("Hello World!") end ================================================ FILE: examples/hello_world/src/hello_world.app.src ================================================ {application, hello_world, [ {description, "A Hello World Program"}, {vsn, "0.0.1"}, {registered, []}, {modules, []}, {applications, [kernel, stdlib]}, {env, []}, {modules, []}, {licenses, ["MIT"]}, {links, []} ]}. ================================================ FILE: run-negative-blackbox-tests.sh ================================================ #!/bin/bash BIN="./sesterl" SOURCE_DIR="test/fail" TARGET_DIR="test/_generated" mkdir -p "$TARGET_DIR" NO_ERRORS=() for PKG_DIR in "$SOURCE_DIR"/*/; do echo "Compiling package '$PKG_DIR' ..." "$BIN" build "$PKG_DIR" -o "$TARGET_DIR" STATUS=$? if [ $STATUS -eq 0 ]; then NO_ERRORS+=("$PKG_DIR") fi done for SOURCE in "$SOURCE_DIR"/*.sest; do echo "Compiling standalone file '$SOURCE' ..." "$BIN" build "$SOURCE" -o "$TARGET_DIR" STATUS=$? if [ $STATUS -eq 0 ]; then NO_ERRORS+=("$SOURCE") fi done RET=0 for X in "${NO_ERRORS[@]}"; do RET=1 echo "[FAIL] $X" done if [ $RET -eq 0 ]; then echo "All tests have passed." fi exit $RET ================================================ FILE: run-positive-blackbox-tests.sh ================================================ #!/bin/bash CURDIR=$(pwd) command -v gsed STATUS=$? if [ $STATUS -eq 0 ]; then GNU_SED="gsed" else command -v sed STATUS=$? if [ $STATUS -eq 0 ]; then GNU_SED="sed" else echo "GNU sed is not installed. Stop." exit 1 fi fi BIN="./sesterl" SOURCE_DIR="test/pass" TARGET_DIR="test/_generated" mkdir -p "$TARGET_DIR" ERRORS=() # Compiles all the packages. for PKG_DIR in "$SOURCE_DIR"/*/; do echo "Compiling package '$PKG_DIR' ..." "$BIN" build "$PKG_DIR" -p sesterl_stdlib:external/stdlib -p sesterl_testing:external/testing STATUS=$? if [ $STATUS -ne 0 ]; then ERRORS+=("$PKG_DIR") fi done # Compiles all the single source files. for SOURCE in "$SOURCE_DIR"/*.sest; do echo "Compiling standalone file '$SOURCE' by sesterl ..." "$BIN" build "$SOURCE" -o "$TARGET_DIR" STATUS=$? if [ $STATUS -ne 0 ]; then ERRORS+=("$SOURCE") fi done # Checks whether every generated Erlang code successfully compiles. for TARGET in "$TARGET_DIR"/*.erl; do echo "Compiling '$TARGET' by erlc ..." erlc -o "$TARGET_DIR" "$TARGET" STATUS=$? if [ $STATUS -ne 0 ]; then ERRORS+=("$TARGET") fi done # Runs every generated Erlang code that has `main/1`. cd "$TARGET_DIR" || exit for TARGET in *.erl; do NUM="$(grep -c "'main'/1" "$TARGET")" if [ "$NUM" -eq 0 ]; then echo "Skip '$TARGET' due to the absence of main/1." else echo "Executing '$TARGET' by escript ..." $GNU_SED '1s|^|#!/usr/local/bin/escript\n|' -i "$TARGET" escript "$TARGET" STATUS=$? if [ $STATUS -ne 0 ]; then ERRORS+=("$TARGET") fi fi done cd "$CURDIR" || exit RET=0 for X in "${ERRORS[@]}"; do RET=1 echo "[FAIL] $X" done if [ $RET -eq 0 ]; then echo "All tests have passed." fi exit $RET ================================================ FILE: sesterl.opam ================================================ # This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "0.2.1" synopsis: "Sesterl: A Session-Typed Erlang" description: "Sesterl: A Session-Typed Erlang" maintainer: ["bd[dot]gfngfn[at]gmail[dot]com"] authors: ["T. Suwa"] license: "MIT" homepage: "https://github.com/gfngfn/Sesterl" bug-reports: "https://github.com/gfngfn/Sesterl/issues" depends: [ "alcotest" {with-test} "dune" {>= "2.5"} "menhir" {>= "20200211"} "menhirLib" {>= "20200211"} "cmdliner" {>= "1.0.4"} "ocamlgraph" {>= "1.8.8"} "semver2" {>= "1.2.0"} "core" {>= "0.13.0"} "uutf" {>= "1.0.2"} "yaml" {>= "2.1.0"} "omd" {>= "1.3.1"} "ppx_deriving" {>= "4.4.1"} ] build: [ ["dune" "subst"] {pinned} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/gfngfn/Sesterl.git" ================================================ FILE: src/address.ml ================================================ open MyUtil type element = | Member of string | FunctorBody of { arg : string } [@@deriving show { with_path = false }] type t = element Alist.t let root = Alist.empty let append_member (modnm : string) (address : t) = Alist.extend address (Member(modnm)) let append_functor_body ~arg:(modnm : string) (address : t) = Alist.extend address (FunctorBody{ arg = modnm }) let to_list (address : t) = Alist.to_list address let subtract ~(long : t) ~(short : t) : t = let elems_long = Alist.to_list long in let elems_short = Alist.to_list short in let rec aux (elems_long : element list) (elems_short : element list) = match (elems_long, elems_short) with | ([], _) -> Alist.empty | (_ :: _, []) -> Alist.from_list elems_long | (elem1 :: tail1, elem2 :: tail2) -> begin match (elem1, elem2) with | (Member(modnm1), Member(modnm2)) -> if String.equal modnm1 modnm2 then aux tail1 tail2 else Alist.from_list elems_long | (FunctorBody(_), FunctorBody(_)) -> aux tail1 tail2 | _ -> Alist.from_list elems_long end in aux elems_long elems_short let show (address : t) : string = let adelems = to_list address in let ss = adelems |> List.mapi (fun index adelem -> match adelem with | Member(modnm) -> if index = 0 then modnm else Printf.sprintf ".%s" modnm | FunctorBody(r) -> Printf.sprintf "(%s = ...)" r.arg ) in let s_last = if adelems = [] then "" else "." in (List.append ss [ s_last ]) |> String.concat "" let pp (ppf : Format.formatter) (address : t) = let pp_sep ppf () = Format.fprintf ppf ":" in Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep pp_element) (to_list address) ================================================ FILE: src/address.mli ================================================ type element = | Member of string | FunctorBody of { arg : string } type t val root : t val append_member : string -> t -> t val append_functor_body : arg:string -> t -> t val to_list : t -> element list val subtract : long:t -> short:t -> t val show : t -> string val pp : Format.formatter -> t -> unit ================================================ FILE: src/assocList.ml ================================================ module type EQ = sig type t val equal : t -> t -> bool end module Make(Key : EQ) : sig type elem type 'v t val empty : 'v t val add_last : elem -> 'v -> 'v t -> ('v t) option val find_opt : elem -> 'v t -> 'v option val fold_left : ('a -> elem -> 'v -> 'a) -> 'a -> 'v t -> 'a val values : 'v t -> 'v list val length : 'v t -> int end with type elem = Key.t = struct type elem = Key.t type 'v t = (elem * 'v) list let empty = [] let add_last k v assoc = let rec aux acc xs = match xs with | [] -> Some(List.rev ((k, v) :: acc)) | ((kx, _) as x) :: tail -> if Key.equal k kx then None else aux (x :: acc) tail in aux [] assoc let rec find_opt k assoc = match assoc with | [] -> None | (kx, vx) :: tail -> if Key.equal k kx then Some(vx) else find_opt k tail let fold_left f init assoc = List.fold_left (fun acc (k, v) -> f acc k v) init assoc let values assoc = assoc |> List.map snd let length = List.length end ================================================ FILE: src/boundID.ml ================================================ type t = { id : int; } let equal bid1 bid2 = bid1.id = bid2.id let hash bid = bid.id let compare bid1 bid2 = bid2.id - bid1.id let current_max = ref 0 let initialize () = current_max := 0 let fresh () = incr current_max; { id = !current_max; } let pp ppf bid = Format.fprintf ppf "'#%d" bid.id ================================================ FILE: src/boundID.mli ================================================ type t val initialize : unit -> unit val fresh : unit -> t val equal : t -> t -> bool val hash : t -> int val compare : t -> t -> int val pp : Format.formatter -> t -> unit ================================================ FILE: src/configLoader.ml ================================================ open MyUtil open Errors open Syntax type git_spec = | Tag of string | Ref of string | Branch of string type erlang_library_source = | ErlangLibFromHex of { version : string } | ErlangLibFromGit of { repository : string; git_spec : git_spec } type erlang_library = { erlang_library_name : string; erlang_library_source : erlang_library_source; } type relx_release = { relx_name : string; relx_version : string; relx_applications : string list; } type relx = { relx_release : relx_release; relx_dev_mode : bool; } type erlang_config = { output_directory : relative_dir; test_output_directory : relative_dir; erlang_dependencies : erlang_library list; relx : relx option; } type document_output_format = | Html type document_output_config = { document_output_format : document_output_format; document_output_directory : relative_dir; } type dependency_source = | Local of absolute_path | Git of { repository : string; git_spec : git_spec } type dependency = { dependency_name : package_name; dependency_source : dependency_source; } let default_erlang_config : erlang_config = { output_directory = RelativeDir(Constants.default_output_directory); test_output_directory = RelativeDir(Constants.default_test_output_directory); erlang_dependencies = []; relx = None; } type config = { language_version : string option; config_directory : absolute_dir; package_name : package_name; main_module_name : module_name; source_directories : relative_dir list; test_directories : relative_dir list; document_outputs : document_output_config list; dependencies : dependency list; test_dependencies : dependency list; erlang_config : erlang_config; } let git_spec_decoder : git_spec YamlDecoder.t = let open YamlDecoder in branch "type" [ "tag" ==> begin get "value" string >>= fun tag -> succeed (Tag(tag)) end; "ref" ==> begin get "value" string >>= fun hash -> succeed (Ref(hash)) end; "branch" ==> begin get "value" string >>= fun branch -> succeed (Branch(branch)) end; ] ~on_error:(fun other -> Printf.sprintf "unsupported type '%s' for specifying sources from Git" other ) let erlang_library_decoder : erlang_library_source YamlDecoder.t = let open YamlDecoder in branch "type" [ "hex" ==> begin get "version" string >>= fun version -> succeed (ErlangLibFromHex{ version = version }) end; "git" ==> begin get "repository" string >>= fun repository -> get "spec" git_spec_decoder >>= fun git_spec -> succeed (ErlangLibFromGit{ repository = repository; git_spec = git_spec }) end; ] ~on_error:(fun other -> Printf.sprintf "unsupported type '%s' for specifying dependency sources" other ) let erlang_dependency_decoder : erlang_library YamlDecoder.t = let open YamlDecoder in get "name" string >>= fun name -> get "source" erlang_library_decoder >>= fun erlsrc -> succeed { erlang_library_name = name; erlang_library_source = erlsrc; } let relx_release_decoder : relx_release YamlDecoder.t = let open YamlDecoder in get "name" string >>= fun name -> get "version" string >>= fun version -> get "applications" (list string) >>= fun applications -> succeed { relx_name = name; relx_version = version; relx_applications = applications; } let relx_decoder : relx YamlDecoder.t = let open YamlDecoder in get "release" relx_release_decoder >>= fun release -> get_or_else "dev_mode" bool false >>= fun dev_mode -> succeed { relx_release = release; relx_dev_mode = dev_mode; } let erlang_config_decoder : erlang_config YamlDecoder.t = let open YamlDecoder in get_or_else "output_directory" string Constants.default_output_directory >>= fun reldir_out -> get_or_else "test_output_directory" string Constants.default_test_output_directory >>= fun reldir_test_out -> get_or_else "erlang_dependencies" (list erlang_dependency_decoder) [] >>= fun erldeps -> get_opt "relx" relx_decoder >>= fun relx_opt -> succeed { output_directory = RelativeDir(reldir_out); test_output_directory = RelativeDir(reldir_test_out); erlang_dependencies = erldeps; relx = relx_opt; } let source_decoder (confdir : absolute_dir) : dependency_source YamlDecoder.t = let open YamlDecoder in branch "type" [ "local" ==> begin get "directory" string >>= fun dirstr -> succeed (Local(make_absolute_path confdir dirstr)) end; "git" ==> begin get "repository" string >>= fun repository -> get "spec" git_spec_decoder >>= fun git_spec -> succeed (Git{ repository = repository; git_spec = git_spec }) end; ] ~on_error:(fun other -> Printf.sprintf "unsupported type '%s' for specifying dependency sources" other ) let dependency_decoder (confdir : absolute_dir) : dependency YamlDecoder.t = let open YamlDecoder in get "name" string >>= fun name -> get "source" (source_decoder confdir) >>= fun source -> succeed { dependency_name = name; dependency_source = source; } let document_output_format_decoder : document_output_format YamlDecoder.t = let open YamlDecoder in branch "type" [ "html" ==> succeed Html ] ~on_error:(fun other -> Printf.sprintf "unsupported type '%s' for specifying document output format" other ) let document_output_decoder : document_output_config YamlDecoder.t = let open YamlDecoder in get "output_directory" string >>= fun reldir_out -> get "format" document_output_format_decoder >>= fun format -> succeed { document_output_format = format; document_output_directory = RelativeDir(reldir_out); } let config_decoder (confdir : absolute_dir) : config YamlDecoder.t = let open YamlDecoder in get_opt "language" string >>= fun language_opt -> get "package" string >>= fun package_name -> get "source_directories" (list string) >>= fun srcdirs -> get "main_module" string >>= fun main_module_name -> get_or_else "test_directories" (list string) [] >>= fun testdirs -> get_or_else "dependencies" (list (dependency_decoder confdir)) [] >>= fun dependencies -> get_or_else "test_dependencies" (list (dependency_decoder confdir)) [] >>= fun test_dependencies -> get_or_else "document_outputs" (list document_output_decoder) [] >>= fun document_outputs -> get_or_else "erlang" erlang_config_decoder default_erlang_config >>= fun erlang_config -> let config = { language_version = language_opt; config_directory = confdir; package_name = package_name; main_module_name = main_module_name; source_directories = srcdirs |> List.map (fun srcdir -> RelativeDir(srcdir)); test_directories = testdirs |> List.map (fun testdir -> RelativeDir(testdir)); document_outputs = document_outputs; dependencies = dependencies; test_dependencies = test_dependencies; erlang_config = erlang_config; } in succeed config let load (confpath : absolute_path) : (config, config_error) result = let open ResultMonad in begin try return (open_in confpath) with | Sys_error(_) -> err (ConfigFileNotFound(confpath)) end >>= fun fin -> let confdir = Filename.dirname confpath in let s = Core.In_channel.input_all fin in close_in fin; YamlDecoder.run (config_decoder confdir) s |> map_err (fun e -> ConfigFileError(e)) ================================================ FILE: src/constants.ml ================================================ let semantic_version = "v0.2.1" let config_file_name = "sesterl.yaml" let default_output_directory = "_generated" let default_test_output_directory = "_generated_test" let plugin_name = "rebar_sesterl" let plugin_url = "https://github.com/gfngfn/rebar_sesterl_plugin.git" let message_tag_atom = "'$sesterl'" ================================================ FILE: src/constructorAttribute.ml ================================================ open MyUtil open Syntax type t = { target_atom : (string ranged) option; } let default = { target_atom = None } let decode (attrs : attribute list) : t * attribute_warning list = let (acc, warn_acc) = attrs |> List.fold_left (fun (acc, warn_acc) attr -> let Attribute((rng, attr_main)) = attr in match attr_main with | ("atom", utast_opt) -> begin match utast_opt with | Some((rngs, BaseConst(BinaryByString(s)))) -> ({ target_atom = Some((rngs, s)) }, warn_acc) | _ -> let warn = { position = rng; tag = "atom"; message = "argument should be a string literal" } in (acc, Alist.extend warn_acc warn) end | (tag, _) -> let warn = { position = rng; tag = tag; message = "unsupported attribute"; } in (acc, Alist.extend warn_acc warn) ) (default, Alist.empty) in (acc, Alist.to_list warn_acc) ================================================ FILE: src/constructorID.ml ================================================ type t = IdentifierScheme.t let from_upper_camel_case : string -> t option = IdentifierScheme.from_upper_camel_case let from_snake_case : string -> t option = IdentifierScheme.from_snake_case let pp ppf ctorid = Format.fprintf ppf "C\"%a\"" IdentifierScheme.pp ctorid let output (ctorid : t) : string = Printf.sprintf "'%s'" (IdentifierScheme.to_snake_case ctorid) ================================================ FILE: src/constructorID.mli ================================================ type t val from_upper_camel_case : string -> t option val from_snake_case : string -> t option val pp : Format.formatter -> t -> unit val output : t -> string ================================================ FILE: src/declarationAttribute.ml ================================================ open MyUtil open Syntax type t = { doc : string option; } let default = { doc = None; } let decode (attrs : attribute list) : t * attribute_warning list = let (r, warn_acc) = attrs |> List.fold_left (fun (r, warn_acc) attr -> let Attribute((rng, attr_main)) = attr in match attr_main with | ("doc", utast_opt) -> begin match utast_opt with | Some((_, BaseConst(BinaryByString(s)))) -> ({ doc = Some(s) }, warn_acc) | Some((_, BaseConst(BinaryByInts(chs)))) -> let s = chs |> List.map Char.chr |> List.to_seq |> String.of_seq in ({ doc = Some(s) }, warn_acc) | _ -> let warn = { position = rng; tag = "doc"; message = "invalid argument"; } in (r, Alist.extend warn_acc warn) end | (tag, _) -> let warn = { position = rng; tag = tag; message = "unsupported attribute"; } in (r, Alist.extend warn_acc warn) ) (default, Alist.empty) in (r, Alist.to_list warn_acc) ================================================ FILE: src/dependencyGraph.ml ================================================ open MyUtil open Syntax open Env module IDMap = Map.Make(String) module GraphImpl = Graph.Persistent.Digraph.Abstract(String) module ComponentImpl = Graph.Components.Make(GraphImpl) module TopologicalImpl = Graph.Topological.Make(GraphImpl) type data = { position : Range.t; type_variables : type_variable_binder list; definition_body : manual_type; kind : kind; } type t = { labels : (data * GraphImpl.V.t) IDMap.t; main : GraphImpl.t; } let empty : t = { labels = IDMap.empty; main = GraphImpl.empty; } let add_vertex (tynm : type_name) (data : data) (graph : t) : t = let vertex = GraphImpl.V.create tynm in { labels = graph.labels |> IDMap.add tynm (data, vertex); main = GraphImpl.add_vertex graph.main vertex; } let get_vertex_token (map : (data * GraphImpl.V.t) IDMap.t) (tynm : type_name) : GraphImpl.V.t = match map |> IDMap.find_opt tynm with | None -> assert false | Some(_, vertex) -> vertex let add_edge ~depended:(tynm1 : type_name) ~depending:(tynm2 : type_name) (graph : t) : t = let map = graph.labels in let vertex1 = get_vertex_token map tynm1 in let vertex2 = get_vertex_token map tynm2 in { graph with main = GraphImpl.add_edge graph.main vertex1 vertex2 } let extract_vertex_info graph v = let tynm = GraphImpl.V.label v in match graph.labels |> IDMap.find_opt tynm with | None -> assert false | Some((data, _)) -> (tynm, data) let extract_vertex_error_info graph v = let (tynm, data) = extract_vertex_info graph v in (data.position, tynm) let find_loop g = GraphImpl.fold_vertex (fun v acc -> match acc with | Some(_) -> acc | None -> if GraphImpl.mem_edge g v v then Some(v) else None ) g None let topological_sort (graph : t) : ((type_name * data) list, (type_name ranged) cycle) result = match find_loop graph.main with | Some(v) -> Error(Loop(extract_vertex_error_info graph v)) | None -> let sccs = ComponentImpl.scc_list graph.main in begin match sccs |> List.find_map (fun scc -> match scc with | [] -> assert false | [_] -> None | v1 :: v2 :: vrest -> let vs = List2.make v1 v2 vrest in Some(Cycle(vs |> List2.map (extract_vertex_error_info graph))) ) with | Some(cycle) -> Error(cycle) | None -> let acc = TopologicalImpl.fold (fun v acc -> let info = extract_vertex_info graph v in Alist.extend acc info ) graph.main Alist.empty in Ok(Alist.to_list acc) end ================================================ FILE: src/dependencyGraph.mli ================================================ open Syntax open Env type t type data = { position : Range.t; type_variables : type_variable_binder list; definition_body : manual_type; kind : kind; } val empty : t val add_vertex : type_name -> data -> t -> t val add_edge : depended:type_name -> depending:type_name -> t -> t val topological_sort : t -> ((type_name * data) list, (type_name ranged) cycle) result ================================================ FILE: src/displayMap.ml ================================================ open Syntax module FreeIDMap = Map.Make(FreeID) module FreeRowIDMap = Map.Make(FreeRowID) module BoundIDMap = Map.Make(BoundID) module BoundRowIDMap = Map.Make(BoundRowID) type t = { current_max : int; free_ids : string FreeIDMap.t; free_row_ids : (string * LabelSet.t) FreeRowIDMap.t; bound_ids : string BoundIDMap.t; bound_row_ids : (string * LabelSet.t) BoundRowIDMap.t; } let empty = { current_max = 0; free_ids = FreeIDMap.empty; free_row_ids = FreeRowIDMap.empty; bound_ids = BoundIDMap.empty; bound_row_ids = BoundRowIDMap.empty; } let make_value (prefix : string) (i : int) = let rec aux chs i = let q = i / 26 in let r = i mod 26 in let ch = Char.chr (Char.code 'a' + r) in if q <= 0 then ch :: chs else aux (ch :: chs) r in let chs = aux [] i in prefix ^ (Core_kernel.String.of_char_list chs) let add_free_id fid dispmap = let fids = dispmap.free_ids in if fids |> FreeIDMap.mem fid then dispmap else let i = dispmap.current_max in let s = make_value "'" i in { dispmap with current_max = i + 1; free_ids = fids |> FreeIDMap.add fid s; } let add_free_row_id frid labset dispmap = let frids = dispmap.free_row_ids in if frids |> FreeRowIDMap.mem frid then dispmap else let i = dispmap.current_max in let s = make_value "?'" i in { dispmap with current_max = i + 1; free_row_ids = dispmap.free_row_ids |> FreeRowIDMap.add frid (s, labset); } let add_bound_id bid dispmap = let bids = dispmap.bound_ids in if bids |> BoundIDMap.mem bid then dispmap else let i = dispmap.current_max in let s = make_value "#" i in { dispmap with current_max = i + 1; bound_ids = bids |> BoundIDMap.add bid s; } let add_bound_row_id brid labset dispmap = let brids = dispmap.bound_row_ids in if brids |> BoundRowIDMap.mem brid then dispmap else let i = dispmap.current_max in let s = make_value "?#" i in { dispmap with current_max = i + 1; bound_row_ids = brids |> BoundRowIDMap.add brid (s, labset); } let find_free_id fid dispmap = match dispmap.free_ids |> FreeIDMap.find_opt fid with | Some(s) -> s | None -> Format.asprintf "!!%a!!" FreeID.pp fid let find_free_row_id frid dispmap = match dispmap.free_row_ids |> FreeRowIDMap.find_opt frid with | Some((s, _)) -> s | None -> Format.asprintf "!!%a!!" FreeRowID.pp frid let find_bound_id bid dispmap = match dispmap.bound_ids |> BoundIDMap.find_opt bid with | Some(s) -> s | None -> Format.asprintf "!!%a!!" BoundID.pp bid let find_bound_row_id brid dispmap = match dispmap.bound_row_ids |> BoundRowIDMap.find_opt brid with | Some((s, _)) -> s | None -> Format.asprintf "!!%a!!" BoundRowID.pp brid let make_free_id_hash_set dispmap = let fidht = FreeIDHashTable.create 32 in dispmap.free_ids |> FreeIDMap.iter (fun fid _ -> FreeIDHashTable.add fidht fid () ); fidht let make_free_row_id_hash_set dispmap = let fridht = FreeRowIDHashTable.create 32 in dispmap.free_row_ids |> FreeRowIDMap.iter (fun frid (_, labset) -> FreeRowIDHashTable.add fridht frid labset ); fridht let make_bound_id_hash_set dispmap = let bidht = BoundIDHashTable.create 32 in dispmap.bound_ids |> BoundIDMap.iter (fun bid _ -> BoundIDHashTable.add bidht bid () ); bidht let make_bound_row_id_hash_set dispmap = let bridht = BoundRowIDHashTable.create 32 in dispmap.bound_row_ids |> BoundRowIDMap.iter (fun brid (_, labset) -> BoundRowIDHashTable.add bridht brid labset ); bridht let fold_free_id f acc dispmap = FreeIDMap.fold f dispmap.free_ids acc let fold_free_row_id f acc dispmap = FreeRowIDMap.fold f dispmap.free_row_ids acc let fold_bound_id f acc dispmap = BoundIDMap.fold f dispmap.bound_ids acc let fold_bound_row_id f acc dispmap = BoundRowIDMap.fold f dispmap.bound_row_ids acc ================================================ FILE: src/displayMap.mli ================================================ open Syntax type t val empty : t val add_free_id : FreeID.t -> t -> t val add_free_row_id : FreeRowID.t -> LabelSet.t -> t -> t val add_bound_id : BoundID.t -> t -> t val add_bound_row_id : BoundRowID.t -> LabelSet.t -> t -> t val find_free_id : FreeID.t -> t -> string val find_free_row_id : FreeRowID.t -> t -> string val find_bound_id : BoundID.t -> t -> string val find_bound_row_id : BoundRowID.t -> t -> string val make_free_id_hash_set : t -> unit FreeIDHashTable.t val make_free_row_id_hash_set : t -> LabelSet.t FreeRowIDHashTable.t val make_bound_id_hash_set : t -> unit BoundIDHashTable.t val make_bound_row_id_hash_set : t -> LabelSet.t BoundRowIDHashTable.t val fold_free_id : (FreeID.t -> string -> 'a -> 'a) -> 'a -> t -> 'a val fold_free_row_id : (FreeRowID.t -> string * LabelSet.t -> 'a -> 'a) -> 'a -> t -> 'a val fold_bound_id : (BoundID.t -> string -> 'a -> 'a) -> 'a -> t -> 'a val fold_bound_row_id : (BoundRowID.t -> string * LabelSet.t -> 'a -> 'a) -> 'a -> t -> 'a ================================================ FILE: src/documentGenerator.ml ================================================ open MyUtil open Syntax open Env open IntermediateSyntax type document_tree_element_main = | DocVal of identifier * poly_type | DocType of type_name * type_scheme_with_entity | DocModule of module_name * document_tree_signature | DocSig of signature_name * document_tree_signature and document_tree_element = document_tree_element_main * string option and document_tree_signature = | DocSigVar of Address.t * signature_name | DocSigFunctor of module_name * document_tree_signature * document_tree_signature | DocSigWith of document_tree_signature * (type_name * type_scheme_with_entity) list | DocSigDecls of document_tree_element list let trim_indentation (s : string) : string = let lines = Core.String.split_lines s in let acc = lines |> List.fold_left (fun acc line -> (* `res` will be: - `Error(n)` if the indentation depth of `line` is `n`. - `Ok(_)` if `line` consists only of spaces. *) let res = Core.String.fold_result s ~init:0 ~f:(fun n ch -> if Char.equal ch ' ' then Ok(n + 1) else Error(n) ) in match (acc, res) with | (Some(min_indent), Ok(_)) -> Some(min_indent) | (Some(min_indent), Error(indent)) -> Some(Stdlib.min min_indent indent) | (None, Ok(_)) -> None | (None, Error(indent)) -> Some(indent) ) None in match acc with | None -> (* If `s` consists only of space lines. *) "" | Some(min_indent) -> lines |> List.map (fun line -> Core.String.drop_prefix line min_indent) |> String.concat "\n" let rec traverse_signature (modsig : module_signature) : document_tree_signature = let (isig, _) = modsig in traverse_signature_source isig and traverse_signature_source (isig : signature_source) : document_tree_signature = match isig with | ISigVar(address, signm) -> DocSigVar(address, signm) | ISigWith(isig0, tydefs) -> let withs = tydefs |> List.map (fun (tynm, tentry) -> (tynm, tentry.type_scheme)) in DocSigWith(traverse_signature_source isig0, withs) | ISigFunctor(m, isigdom, isigcod) -> let docsigdom = traverse_signature_source isigdom in let docsigcod = traverse_signature_source isigcod in DocSigFunctor(m, docsigdom, docsigcod) | ISigDecls(sigr) -> DocSigDecls(traverse_structure sigr) and traverse_structure (sigr : SigRecord.t) : document_tree_element list = let acc = sigr |> SigRecord.fold ~v:(fun x ventry acc -> Alist.extend acc (DocVal(x, ventry.val_type), ventry.val_doc) ) ~c:(fun _ _ acc -> acc) ~f:(fun _ _ acc -> acc) ~t:(fun tynm tentry acc -> Alist.extend acc (DocType(tynm, tentry.type_scheme), tentry.type_doc) ) ~m:(fun modnm mentry acc -> let docelems = traverse_signature mentry.mod_signature in Alist.extend acc (DocModule(modnm, docelems), mentry.mod_doc) ) ~s:(fun signm sentry acc -> let (_, modsig) = sentry.sig_signature in let docsig = traverse_signature modsig in Alist.extend acc (DocSig(signm, docsig), sentry.sig_doc) ) Alist.empty in acc |> Alist.to_list let stringify_type ~token:(s_token : string) ~doc:(s_doc : string) ~(seen_from : Address.t) (tynm : type_name) (tyscheme : type_scheme_with_entity) : string list = let spec = TypeConv.display_spec_html in let (bids, tybody, tyentity) = tyscheme in let dispmap = bids |> List.fold_left (fun dispmap bid -> dispmap |> DisplayMap.add_bound_id bid ) DisplayMap.empty in let s_typarams = let ss = bids |> List.map (fun bid -> dispmap |> DisplayMap.find_bound_id bid) in match ss with | [] -> "" | _ :: _ -> Printf.sprintf "<%s>" (String.concat ", " ss) in let ss_body = match tyentity with | Opaque(_tyid) -> [ Printf.sprintf "%s" s_typarams ] | Synonym -> [ Format.asprintf "%s = %a" s_typarams (TypeConv.pp_poly_type ~spec ~seen_from dispmap) tybody ] | Variant(ctormap) -> let ss_elems = ConstructorMap.bindings ctormap |> List.map (fun (ctornm, (_, ptys)) -> let s_param = match ptys with | [] -> "" | _ :: _ -> let pp_sep = (fun ppf () -> Format.fprintf ppf ", ") in Format.asprintf "(%a)" (Format.pp_print_list ~pp_sep:pp_sep (TypeConv.pp_poly_type ~spec ~seen_from dispmap)) ptys in Printf.sprintf "
  • | %s%s
    • " ctornm s_param ) in List.concat [ [ Printf.sprintf "%s =
      " s_typarams ]; ss_elems; [ "
    " ]; ] in [ Printf.sprintf "
  • %s %s%s%s
    • " (spec.token s_token) tynm (String.concat "" ss_body) s_doc; ] let rec stringify_document_element ~(seen_from : Address.t) ((docelem, doc_opt) : document_tree_element) : string list = let spec = TypeConv.display_spec_html in let s_doc = match doc_opt with | None -> "" | Some(doc_md_raw) -> let doc_md = trim_indentation doc_md_raw in let doc_html = Omd.to_html (Omd.of_string doc_md) in Printf.sprintf "
    %s
    " doc_html in match docelem with | DocVal(x, pty) -> let dispmap = DisplayMap.empty |> TypeConv.collect_ids_poly pty in let sty = Format.asprintf "%a" (TypeConv.pp_poly_type ~spec ~seen_from dispmap) pty in let sq = let acc = dispmap |> DisplayMap.fold_bound_id (fun bid name acc -> Alist.extend acc name ) Alist.empty in let acc = dispmap |> DisplayMap.fold_bound_row_id (fun brid (name, labset) acc -> let s_labs = labset |> LabelSet.elements |> String.concat ", " in Alist.extend acc (Printf.sprintf "%s :: (%s)" name s_labs) ) acc in match Alist.to_list acc with | [] -> "" | ss -> Printf.sprintf "<%s>" (String.concat ", " ss) in [ Printf.sprintf "
  • %s %s%s : %s%s
    • " (spec.token "val") x sq sty s_doc ] | DocType(tynm, tyscheme) -> stringify_type ~token:"type" ~doc:s_doc ~seen_from tynm tyscheme | DocModule(modnm, docsig) -> let ss = docsig |> (stringify_document_signature ~seen_from:(seen_from |> Address.append_member modnm)) in List.concat [ [ Printf.sprintf "
  • %s %s%s : " (spec.token "module") modnm s_doc ]; ss; [ "
    • " ]; ] | DocSig(signm, docsig) -> let ss = docsig |> (stringify_document_signature ~seen_from) in List.concat [ [ Printf.sprintf "
  • %s %s%s = " (spec.token "signature") signm s_doc ]; ss; [ "
    • " ]; ] and stringify_document_signature ~(seen_from : Address.t) (docsig : document_tree_signature) : string list = let spec = TypeConv.display_spec_html in match docsig with | DocSigVar(address, signm) -> let diff_address = Address.subtract ~long:address ~short:seen_from in [ Printf.sprintf "%s%s" (Address.show diff_address) signm ] | DocSigWith(docsig0, withs) -> let ss1 = stringify_document_signature ~seen_from docsig0 in let ss2 = withs |> List.mapi (fun index (tynm, tyscheme) -> let token = if index = 0 then "type" else "and" in stringify_type ~token ~doc:"" ~seen_from tynm tyscheme ) |> List.concat in List.concat [ [ Printf.sprintf "(" ]; ss1; [ Printf.sprintf "%s" (spec.token "with") ]; ss2; [ Printf.sprintf ")" ]; ] | DocSigDecls(docelems) -> List.concat [ [ Printf.sprintf "%s" (spec.token "sig"); "
      "; ]; docelems |> List.map (stringify_document_element ~seen_from) |> List.concat; [ "
    "; Printf.sprintf "%s" (spec.token "end"); ]; ] | DocSigFunctor(m, docsig1, docsig2) -> List.concat [ [ Printf.sprintf "%s(%s : " (spec.token "fun") m ]; stringify_document_signature ~seen_from docsig1; [ Printf.sprintf ") -> " ]; stringify_document_signature ~seen_from:(seen_from |> Address.append_functor_body ~arg:m) docsig2; ] let main (abspath_doc_out : absolute_path) (out : PackageChecker.single_output) : unit = let (_, (isig, _sigr)) = out.signature in let docelem = (DocModule(out.module_name, traverse_signature_source isig), None) in let lines = List.concat [ [ ""; ""; ""; Printf.sprintf "%s" out.module_name; ""; ""; "
      "; ]; stringify_document_element ~seen_from:Address.root docelem; [ "
    "; ""; ]; ] in let fout = open_out abspath_doc_out in lines |> List.iter (fun line -> output_string fout line ); close_out fout; Logging.output_written abspath_doc_out ================================================ FILE: src/dune ================================================ (executable (public_name sesterl) (package sesterl) (name main) (flags (-w -3 -bin-annot -thread)) (libraries menhirLib cmdliner ocamlgraph semver2 core uutf yaml omd) (preprocess (pps ppx_deriving.show))) (ocamllex (modules lexer)) (menhir (modules parser) (flags (--table --explain))) ================================================ FILE: src/env.ml ================================================ open MyUtil open Syntax type ('a, 'b) typ = (('a, 'b) typ_main) ranged and ('a, 'b) typ_main = | BaseType of base_type | FuncType of ('a, 'b) domain_type * ('a, 'b) typ | PidType of ('a, 'b) pid_type | EffType of ('a, 'b) domain_type * ('a, 'b) effect * ('a, 'b) typ | TypeVar of 'a | ProductType of (('a, 'b) typ) TupleList.t | TypeApp of TypeID.t * (('a, 'b) typ) list | RecordType of ('a, 'b) row | PackType of module_signature abstracted [@printer (fun ppf (qt, modsig) -> Format.fprintf ppf "PackType(%a, _)" pp_opaque_id_quantifier qt)] and ('a, 'b) domain_type = { ordered : (('a, 'b) typ) list; mandatory : (('a, 'b) typ) LabelAssoc.t; optional : ('a, 'b) row; } and ('a, 'b) effect = | Effect of ('a, 'b) typ and ('a, 'b) pid_type = | Pid of ('a, 'b) typ and ('a, 'b) row = | RowCons of label ranged * (('a, 'b) typ) * ('a, 'b) row | RowVar of 'b | RowEmpty and base_kind = | TypeKind | RowKind of LabelSet.t and module_signature_main = | ConcStructure of record_signature | ConcFunctor of functor_signature and module_signature = signature_source * module_signature_main and signature_source = | ISigVar of Address.t * signature_name | ISigWith of signature_source * (type_name * type_entry) list | ISigFunctor of signature_name * signature_source * signature_source | ISigDecls of record_signature and functor_signature = { opaques : quantifier; [@printer pp_opaque_id_quantifier] domain : functor_domain; codomain : module_signature abstracted; [@printer (fun ppf (qt, modsig) -> Format.fprintf ppf "(%a, _)" pp_opaque_id_quantifier qt)] closure : (module_name ranged * untyped_module * environment) option; } and functor_domain = | Domain of signature_source * record_signature and env_value_entry = { typ : poly_type; name : name; mutable is_used : bool; } and value_entry = { val_type : poly_type; val_global : global_name; val_doc : string option; } and type_scheme = BoundID.t list * poly_type and constructor_map = (ConstructorID.t * poly_type list) ConstructorMap.t [@printer (fun ppf _ -> Format.fprintf ppf "")] and type_entity = | Opaque of TypeID.t | Synonym | Variant of constructor_map and type_scheme_with_entity = BoundID.t list * poly_type * type_entity and type_entry = { type_scheme : type_scheme_with_entity; type_kind : kind; type_doc : string option; } and module_entry = { mod_signature : module_signature; mod_name : space_name; mod_doc : string option; } and signature_entry = { sig_signature : module_signature abstracted; sig_doc : string option; sig_address : Address.t; } and constructor_entry = { belongs : TypeID.t; constructor_id : ConstructorID.t; type_variables : BoundID.t list; parameter_types : poly_type list; } and opaque_entry = { opaque_kind : kind; } and environment = { values : env_value_entry ValNameMap.t; [@printer (fun ppf _ -> Format.fprintf ppf "")] constructors : constructor_entry ConstructorMap.t; [@printer (fun ppf _ -> Format.fprintf ppf "")] types : type_entry TypeNameMap.t; [@printer (fun ppf _ -> Format.fprintf ppf "")] opaques : kind OpaqueIDMap.t; [@printer (fun ppf _ -> Format.fprintf ppf "")] modules : module_entry ModuleNameMap.t; [@printer (fun ppf _ -> Format.fprintf ppf "")] signatures : signature_entry SignatureNameMap.t; [@printer (fun ppf _ -> Format.fprintf ppf "")] } and record_signature = record_signature_entry Alist.t [@printer (fun ppf acc -> Format.fprintf ppf "%a" (Format.pp_print_list pp_record_signature_entry) (Alist.to_list acc) )] and record_signature_entry = | SRVal of identifier * value_entry [@printer (fun ppf _ -> Format.fprintf ppf "")] | SRCtor of constructor_name * constructor_entry [@printer (fun ppf _ -> Format.fprintf ppf "")] | SRFold of type_name * poly_type | SRType of type_name * type_entry [@printer (fun ppf _ -> Format.fprintf ppf "")] | SRModule of module_name * module_entry | SRSig of signature_name * signature_entry [@printer (fun ppf _ -> Format.fprintf ppf "")] [@@deriving show { with_path = false }] and kind = | Kind of (base_kind) list * base_kind (* Handles order-0 or order-1 kind only. *) and mono_type_var_updatable = | Free of FreeID.t | Link of mono_type and mono_type_var = | Updatable of mono_type_var_updatable ref | MustBeBound of MustBeBoundID.t and mono_row_var_updatable = | FreeRow of FreeRowID.t | LinkRow of mono_row and mono_row_var = | UpdatableRow of mono_row_var_updatable ref | MustBeBoundRow of MustBeBoundRowID.t and mono_type = (mono_type_var, mono_row_var) typ and mono_row = (mono_type_var, mono_row_var) row and mono_effect = (mono_type_var, mono_row_var) effect and mono_domain_type = (mono_type_var, mono_row_var) domain_type and poly_type_var = | Mono of mono_type_var | Bound of BoundID.t and poly_row_var = | MonoRow of mono_row_var | BoundRow of BoundRowID.t and poly_type = (poly_type_var, poly_row_var) typ and poly_row = (poly_type_var, poly_row_var) row and poly_domain_type = (poly_type_var, poly_row_var) domain_type and quantifier = kind OpaqueIDMap.t [@printer pp_opaque_id_quantifier] and 'a abstracted = quantifier * 'a type ('a, 'b) normalized_row = | NormalizedRow of (('a, 'b) typ) LabelAssoc.t * 'b option type normalized_mono_row = (mono_type_var, mono_row_var) normalized_row type normalized_poly_row = (poly_type_var, poly_row_var) normalized_row type local_row_parameter_map = (MustBeBoundRowID.t * LabelSet.t) RowParameterMap.t module Typeenv = struct type t = environment let empty = { values = ValNameMap.empty; types = TypeNameMap.empty; opaques = OpaqueIDMap.empty; constructors = ConstructorMap.empty; modules = ModuleNameMap.empty; signatures = SignatureNameMap.empty; } let map ~v:(fv : poly_type * name -> poly_type * name) ~m:(fm : module_signature * space_name -> module_signature * space_name) (tyenv : t) : t = let values = tyenv.values |> ValNameMap.map (fun ventry -> let (typ, name) = fv (ventry.typ, ventry.name) in { ventry with typ = typ; name = name } ) in let modules = tyenv.modules |> ModuleNameMap.map (fun mentry -> let (modsig, sname) = fm (mentry.mod_signature, mentry.mod_name) in { mentry with mod_signature = modsig; mod_name = sname } ) in { tyenv with values = values; modules = modules } let add_value (x : identifier) (pty : poly_type) (name : name) (tyenv : t) : t = let entry = { typ = pty; name = name; is_used = false; } in let values = tyenv.values |> ValNameMap.add x entry in { tyenv with values = values; } let find_value (x : identifier) (tyenv : t) = tyenv.values |> ValNameMap.find_opt x |> Option.map (fun entry -> entry.is_used <- true; (entry.typ, entry.name) ) let is_val_properly_used (x : identifier) (tyenv : t) : bool option = tyenv.values |> ValNameMap.find_opt x |> Option.map (fun entry -> entry.is_used ) let fold_value f tyenv acc = ValNameMap.fold (fun x entry acc -> f x entry.typ acc) tyenv.values acc let add_constructor (ctornm : constructor_name) (ctorentry : constructor_entry) (tyenv : t) : t = { tyenv with constructors = tyenv.constructors |> ConstructorMap.add ctornm ctorentry; } let find_constructor (ctornm : constructor_name) (tyenv : t) = tyenv.constructors |> ConstructorMap.find_opt ctornm let add_type (tynm : type_name) (tentry : type_entry) (tyenv : t) : t = { tyenv with types = tyenv.types |> TypeNameMap.add tynm tentry; } let add_opaque_id (tynm : type_name) (oid : TypeID.t) (kd : kind) (tyenv : t) : t = { tyenv with opaques = tyenv.opaques |> OpaqueIDMap.add oid kd; } let find_type (tynm : type_name) (tyenv : t) : type_entry option = tyenv.types |> TypeNameMap.find_opt tynm let add_module (modnm : module_name) (mentry : module_entry) (tyenv : t) : t = { tyenv with modules = tyenv.modules |> ModuleNameMap.add modnm mentry; } let find_module (modnm : module_name) (tyenv : t) : module_entry option = tyenv.modules |> ModuleNameMap.find_opt modnm let add_signature (signm : signature_name) (sentry : signature_entry) (tyenv : t) : t = { tyenv with signatures = tyenv.signatures |> SignatureNameMap.add signm sentry; } let find_signature (signm : signature_name) (tyenv : t) : signature_entry option = tyenv.signatures |> SignatureNameMap.find_opt signm end module SigRecord = struct type t = record_signature let empty : t = Alist.empty let add_value (x : identifier) (ventry : value_entry) (sigr : t) : t = Alist.extend sigr (SRVal(x, ventry)) let find_value (x0 : identifier) (sigr : t) : value_entry option = sigr |> Alist.to_rev_list |> List.find_map (function | SRVal(x, ventry) -> if String.equal x x0 then Some(ventry) else None | _ -> None ) let add_type (tynm : type_name) (tentry : type_entry) (sigr : t) : t = Alist.extend sigr (SRType(tynm, tentry)) let find_type (tynm0 : type_name) (sigr : t) : type_entry option = sigr |> Alist.to_rev_list |> List.find_map (function | SRType(tynm, tentry) -> if String.equal tynm tynm0 then Some(tentry) else None | _ -> None ) let add_constructor (ctornm : constructor_name) (centry : constructor_entry) (sigr : t) : t = Alist.extend sigr (SRCtor(ctornm, centry)) let find_constructor (ctornm0 : constructor_name) (sigr : t) : constructor_entry option = sigr |> Alist.to_rev_list |> List.find_map (function | SRCtor(ctornm, centry) -> if String.equal ctornm ctornm0 then Some(centry) else None | _ -> None ) let add_dummy_fold (tynm : type_name) (pty : poly_type) (sigr : t) : t = Alist.extend sigr (SRFold(tynm, pty)) let find_dummy_fold (tynm0 : type_name) (sigr : t) : poly_type option = sigr |> Alist.to_rev_list |> List.find_map (function | SRFold(tynm, pty) -> if String.equal tynm tynm0 then Some(pty) else None | _ -> None ) let add_module (modnm : module_name) (mentry : module_entry) (sigr : t) : t = Alist.extend sigr (SRModule(modnm, mentry)) let find_module (modnm0 : module_name) (sigr : t) : module_entry option = sigr |> Alist.to_list |> List.find_map (function | SRModule(modnm, mentry) -> if String.equal modnm modnm0 then Some(mentry) else None | _ -> None ) let add_signature (signm : signature_name) (sentry : signature_entry) (sigr : t) : t = Alist.extend sigr (SRSig(signm, sentry)) let find_signature (signm0 : signature_name) (sigr : t) : signature_entry option = sigr |> Alist.to_list |> List.find_map (function | SRSig(signm, sentry) -> if String.equal signm signm0 then Some(sentry) else None | _ -> None ) let fold (type a) ~v:(fv : identifier -> value_entry -> a -> a) ~c:(fc : constructor_name -> constructor_entry -> a -> a) ~f:(ff : type_name -> poly_type -> a -> a) ~t:(ft : type_name -> type_entry -> a -> a) ~m:(fm : module_name -> module_entry -> a -> a) ~s:(fs : signature_name -> signature_entry -> a -> a) (init : a) (sigr : t) : a = sigr |> Alist.to_list |> List.fold_left (fun acc entry -> match entry with | SRVal(x, ventry) -> fv x ventry acc | SRCtor(ctornm, centry) -> fc ctornm centry acc | SRFold(tynm, pty) -> ff tynm pty acc | SRType(tynm, tentry) -> ft tynm tentry acc | SRModule(modnm, mentry) -> fm modnm mentry acc | SRSig(signm, sentry) -> fs signm sentry acc ) init let map_and_fold (type a) ~v:(fv : identifier -> value_entry -> a -> value_entry * a) ~c:(fc : constructor_name -> constructor_entry -> a -> constructor_entry * a) ~f:(ff : type_name -> poly_type -> a -> poly_type * a) ~t:(ft : type_name -> type_entry -> a -> type_entry * a) ~m:(fm : module_name -> module_entry -> a -> module_entry * a) ~s:(fs : signature_name -> signature_entry -> a -> signature_entry * a) (init : a) (sigr : t) : t * a = sigr |> Alist.to_list |> List.fold_left (fun (sigracc, acc) entry -> match entry with | SRVal(x, ventry) -> let (ventry, acc) = fv x ventry acc in (Alist.extend sigracc (SRVal(x, ventry)), acc) | SRCtor(ctornm, centry) -> let (centry, acc) = fc ctornm centry acc in (Alist.extend sigracc (SRCtor(ctornm, centry)), acc) | SRFold(tynm, pty) -> let (pty, acc) = ff tynm pty acc in (Alist.extend sigracc (SRFold(tynm, pty)), acc) | SRType(tynm, tentry) -> let (tentry, acc) = ft tynm tentry acc in (Alist.extend sigracc (SRType(tynm, tentry)), acc) | SRModule(modnm, mentry) -> let (mentry, acc) = fm modnm mentry acc in (Alist.extend sigracc (SRModule(modnm, mentry)), acc) | SRSig(signm, sentry) -> let (sentry, acc) = fs signm sentry acc in (Alist.extend sigracc (SRSig(signm, sentry)), acc) ) (Alist.empty, init) let map (type a) ~v:(fv : identifier -> value_entry -> value_entry) ~c:(fc : constructor_name -> constructor_entry -> constructor_entry) ~f:(ff : type_name -> poly_type -> poly_type) ~t:(ft : type_name -> type_entry -> type_entry) ~m:(fm : module_name -> module_entry -> module_entry) ~s:(fs : signature_name -> signature_entry -> signature_entry) (sigr : t) : t = let (sigr, ()) = sigr |> map_and_fold ~v:(fun x ventry () -> (fv x ventry, ())) ~c:(fun ctornm centry () -> (fc ctornm centry, ())) ~f:(fun tynm pty () -> (ff tynm pty, ())) ~t:(fun tynm tentry () -> (ft tynm tentry, ())) ~m:(fun modnm mentry () -> (fm modnm mentry, ())) ~s:(fun signm sentry () -> (fs signm sentry, ())) () in sigr (* let overwrite (superior : t) (inferior : t) : t = let left _ x _ = Some(x) in let sr_vals = ValNameMap.union left superior.sr_vals inferior.sr_vals in let sr_types = TypeNameMap.union left superior.sr_types inferior.sr_types in let sr_modules = ModuleNameMap.union left superior.sr_modules inferior.sr_modules in let sr_sigs = SignatureNameMap.union left superior.sr_sigs inferior.sr_sigs in let sr_ctors = ConstructorMap.union left superior.sr_ctors inferior.sr_ctors in { sr_vals; sr_types; sr_modules; sr_sigs; sr_ctors } *) exception Conflict of string let disjoint_union (sigr1 : t) (sigr2 : t) : (t, string) result = let check_none s opt = match opt with | None -> () | Some(_) -> raise (Conflict(s)) in try let sigr = sigr2 |> Alist.to_list |> List.fold_left (fun sigracc entry -> let () = match entry with | SRVal(x, _) -> check_none x (find_value x sigr1) | SRCtor(ctornm, _) -> check_none ctornm (find_constructor ctornm sigr1) | SRFold(_, _) -> () | SRType(tynm, _) -> check_none tynm (find_type tynm sigr1) | SRModule(modnm, _) -> check_none modnm (find_module modnm sigr1) | SRSig(signm, _) -> check_none signm (find_signature signm sigr1) in Alist.extend sigracc entry ) sigr1 in Ok(sigr) with | Conflict(s) -> Error(s) end (* let pp_comma ppf () = Format.fprintf ppf ", " let pp_bound_type_id ppf bid = let pkd = KindStore.get_bound_id bid in match pkd with | UniversalKind -> Format.fprintf ppf "%a" BoundID.pp bid | _ -> let (_, _, skd) = TypeConv.show_poly_base_kind pkd in Format.fprintf ppf "%a :: %s" BoundID.pp bid skd let pp_type_parameters ppf typarams = match typarams with | [] -> () | _ :: _ -> Format.fprintf ppf "<%a>" (Format.pp_print_list ~pp_sep:pp_comma pp_bound_type_id) typarams let display_poly_type pty = let (sbids, sbrids, sty) = TypeConv.show_poly_type pty in let ssub = let ss = List.append sbids sbrids in if ss = [] then "" else "<" ^ (String.concat ", " ss) ^ ">" in (ssub, sty) let display_poly_type_params (ptys : poly_type list) = match ptys with | [] -> "" | _ :: _ -> let ss = ptys |> List.map display_poly_type |> List.map (fun (_, sty) -> sty) in Printf.sprintf "(%s)" (String.concat ", " ss) let rec display_signature (depth : int) (modsig : module_signature) : unit = let indent = String.make (depth * 2) ' ' in match modsig with | ConcStructure(sigr) -> Format.printf "%ssig\n" indent; display_structure (depth + 1) sigr; Format.printf "%send\n" indent | ConcFunctor(sigftor) -> let (oidset1, Domain(sigr1), (oidset2, modsigcod)) = (sigftor.opaques, sigftor.domain, sigftor.codomain) in let modsigdom = ConcStructure(sigr1) in let sx1 = stringify_opaque_id_set oidset1 in let sx2 = stringify_opaque_id_set oidset2 in Format.printf "%s(forall%s) fun(\n" indent sx1; display_signature (depth + 1) modsigdom; Format.printf "%s) -> (exists%s)\n" indent sx2; display_signature (depth + 1) modsigcod and display_structure (depth : int) (sigr : SigRecord.t) : unit = let indent = String.make (depth * 2) ' ' in sigr |> SigRecord.fold ~v:(fun x (pty, _) () -> let (ssub, sty) = display_poly_type pty in Format.printf "%sval %s%s : %s\n" indent x ssub sty ) ~t:(fun tydefs () -> tydefs |> List.iter (fun (tynm, tyopac) -> let (tyid, pkd) = tyopac in match tyid with | TypeID.Synonym(sid) -> let (typarams, ptyreal) = TypeDefinitionStore.find_synonym_type sid in let (_, sty) = display_poly_type ptyreal in Format.printf "%stype %a%a = %s\n" indent TypeID.Synonym.pp sid pp_type_parameters typarams sty | TypeID.Variant(vid) -> let (typarams, ctorbrs) = TypeDefinitionStore.find_variant_type vid in Format.printf "%stype %a%a =\n" indent TypeID.Variant.pp vid pp_type_parameters typarams; ctorbrs |> ConstructorMap.iter (fun ctor (ctorid, ptyparams) -> let sparam = display_poly_type_params ptyparams in Format.printf "%s | %s%s\n" indent ctor sparam ) | TypeID.Opaque(oid) -> let (_, _, skd) = TypeConv.show_poly_kind pkd in Format.printf "%stype %a :: %s\n" indent TypeID.Opaque.pp oid skd ) ) ~m:(fun modnm (modsig, _) () -> Format.printf "%smodule %s :\n" indent modnm; display_signature (depth + 1) modsig ) ~s:(fun signm (oidset, modsig) () -> let sx = stringify_opaque_id_set oidset in Format.printf "%ssignature %s =\n" indent signm; Format.printf "%s (exists%s)\n" indent sx; display_signature (depth + 2) modsig ) () let display_top_structure ((_, modnm) : module_name ranged) (sigr : SigRecord.t) = Format.printf " --------------------------------\n"; Format.printf " module %s =\n" modnm; display_structure 2 sigr; Format.printf " --------------------------------\n" *) ================================================ FILE: src/env.mli ================================================ open Syntax type environment type record_signature type ('a, 'b) typ = (('a, 'b) typ_main) ranged and ('a, 'b) typ_main = | BaseType of base_type | FuncType of ('a, 'b) domain_type * ('a, 'b) typ | PidType of ('a, 'b) pid_type | EffType of ('a, 'b) domain_type * ('a, 'b) effect * ('a, 'b) typ | TypeVar of 'a | ProductType of (('a, 'b) typ) TupleList.t | TypeApp of TypeID.t * (('a, 'b) typ) list | RecordType of ('a, 'b) row | PackType of module_signature abstracted and ('a, 'b) domain_type = { ordered : (('a, 'b) typ) list; mandatory : (('a, 'b) typ) LabelAssoc.t; optional : ('a, 'b) row; } and ('a, 'b) effect = | Effect of ('a, 'b) typ and ('a, 'b) pid_type = | Pid of ('a, 'b) typ and ('a, 'b) row = | RowCons of label ranged * (('a, 'b) typ) * ('a, 'b) row | RowVar of 'b | RowEmpty and base_kind = | TypeKind | RowKind of LabelSet.t and module_signature_main = | ConcStructure of record_signature | ConcFunctor of functor_signature and module_signature = signature_source * module_signature_main and signature_source = | ISigVar of Address.t * signature_name | ISigWith of signature_source * (type_name * type_entry) list | ISigFunctor of signature_name * signature_source * signature_source | ISigDecls of record_signature and functor_signature = { opaques : quantifier; domain : functor_domain; codomain : module_signature abstracted; closure : (module_name ranged * untyped_module * environment) option; } and functor_domain = | Domain of signature_source * record_signature and kind = | Kind of (base_kind) list * base_kind (* Handles order-0 or order-1 kind only. *) and mono_type_var_updatable = | Free of FreeID.t | Link of mono_type and mono_type_var = | Updatable of mono_type_var_updatable ref | MustBeBound of MustBeBoundID.t and mono_row_var_updatable = | FreeRow of FreeRowID.t | LinkRow of mono_row and mono_row_var = | UpdatableRow of mono_row_var_updatable ref | MustBeBoundRow of MustBeBoundRowID.t and mono_type = (mono_type_var, mono_row_var) typ and mono_row = (mono_type_var, mono_row_var) row and mono_effect = (mono_type_var, mono_row_var) effect and mono_domain_type = (mono_type_var, mono_row_var) domain_type and poly_type_var = | Mono of mono_type_var | Bound of BoundID.t and poly_row_var = | MonoRow of mono_row_var | BoundRow of BoundRowID.t and poly_type = (poly_type_var, poly_row_var) typ and poly_row = (poly_type_var, poly_row_var) row and poly_domain_type = (poly_type_var, poly_row_var) domain_type and quantifier = kind OpaqueIDMap.t and 'a abstracted = quantifier * 'a and type_entry = { type_scheme : type_scheme_with_entity; type_kind : kind; type_doc : string option; } [@@deriving show { with_path = false }] and type_scheme_with_entity = BoundID.t list * poly_type * type_entity and type_entity = | Opaque of TypeID.t | Synonym | Variant of constructor_map and constructor_map = (ConstructorID.t * poly_type list) ConstructorMap.t val pp_module_signature : Format.formatter -> module_signature -> unit type ('a, 'b) normalized_row = | NormalizedRow of (('a, 'b) typ) LabelAssoc.t * 'b option type normalized_mono_row = (mono_type_var, mono_row_var) normalized_row type normalized_poly_row = (poly_type_var, poly_row_var) normalized_row type value_entry = { val_type : poly_type; val_global : global_name; val_doc : string option; } type type_scheme = BoundID.t list * poly_type type module_entry = { mod_signature : module_signature; mod_name : space_name; mod_doc : string option; } type signature_entry = { sig_signature : module_signature abstracted; sig_doc : string option; sig_address : Address.t; } type constructor_entry = { belongs : TypeID.t; constructor_id : ConstructorID.t; type_variables : BoundID.t list; parameter_types : poly_type list; } type local_row_parameter_map = (MustBeBoundRowID.t * LabelSet.t) RowParameterMap.t module Typeenv : sig type t = environment val empty : t val map : v:(poly_type * name -> poly_type * name) -> m:(module_signature * space_name -> module_signature * space_name) -> t -> t val add_value : identifier -> poly_type -> name -> t -> t val find_value : identifier -> t -> (poly_type * name) option val is_val_properly_used : identifier -> t -> bool option val fold_value : (identifier -> poly_type -> 'a -> 'a) -> t -> 'a -> 'a val add_constructor : constructor_name -> constructor_entry -> t -> t val find_constructor : constructor_name -> t -> constructor_entry option val add_type : type_name -> type_entry -> t -> t val add_opaque_id : type_name -> TypeID.t -> kind -> t -> t val find_type : type_name -> t -> type_entry option val add_module : module_name -> module_entry -> t -> t val find_module : module_name -> t -> module_entry option val add_signature : signature_name -> signature_entry -> t -> t val find_signature : signature_name -> t -> signature_entry option end module SigRecord : sig type t = record_signature val empty : t val add_value : identifier -> value_entry -> t -> t val find_value : identifier -> t -> value_entry option val add_constructor : constructor_name -> constructor_entry -> t -> t val find_constructor : constructor_name -> t -> constructor_entry option val add_dummy_fold : type_name -> poly_type -> t -> t val find_dummy_fold : type_name -> t -> poly_type option val add_type : type_name -> type_entry -> t -> t val find_type : type_name -> t -> type_entry option val add_module : module_name -> module_entry -> t -> t val find_module : module_name -> t -> module_entry option val add_signature : signature_name -> signature_entry -> t -> t val find_signature : signature_name -> t -> signature_entry option val fold : v:(identifier -> value_entry -> 'a -> 'a) -> c:(constructor_name -> constructor_entry -> 'a -> 'a) -> f:(type_name -> poly_type -> 'a -> 'a) -> t:(type_name -> type_entry -> 'a -> 'a) -> m:(module_name -> module_entry -> 'a -> 'a) -> s:(signature_name -> signature_entry -> 'a -> 'a) -> 'a -> t -> 'a val map_and_fold : v:(identifier -> value_entry -> 'a -> value_entry * 'a) -> c:(constructor_name -> constructor_entry -> 'a -> constructor_entry * 'a) -> f:(type_name -> poly_type -> 'a -> poly_type * 'a) -> t:(type_name -> type_entry -> 'a -> type_entry * 'a) -> m:(module_name -> module_entry -> 'a -> module_entry * 'a) -> s:(signature_name -> signature_entry -> 'a -> signature_entry * 'a) -> 'a -> t -> t * 'a val map : v:(identifier -> value_entry -> value_entry) -> c:(constructor_name -> constructor_entry -> constructor_entry) -> f:(type_name -> poly_type -> poly_type) -> t:(type_name -> type_entry -> type_entry) -> m:(module_name -> module_entry -> module_entry) -> s:(signature_name -> signature_entry -> signature_entry) -> t -> t val disjoint_union : t -> t -> (t, string) result end (* val display_signature : int -> module_signature -> unit val display_structure : int -> SigRecord.t -> unit val display_top_structure : module_name ranged -> SigRecord.t -> unit *) ================================================ FILE: src/errors.ml ================================================ open MyUtil open Syntax open Env type config_error = | CyclicFileDependencyFound of absolute_path cycle | ConfigFileError of YamlDecoder.error | MultipleModuleOfTheSameName of module_name * absolute_path * absolute_path | ModuleNotFound of Range.t * module_name | InvalidPackageName of string | CannotSpecifyDependency | MainModuleNotFound of package_name * module_name | UnrecognizableExtension of string | ConfigFileNotFound of absolute_dir | SourceFileDependsOnTestFile of module_name * module_name | NoOutputSpecForSingleSource | UnsupportedLanguageVersion of string exception ConfigError of config_error type package_error = | DuplicatedPackageName of package_name * absolute_path * absolute_path | PackageDirNotFound of absolute_dir | NotFoundInExternalMap of package_name * external_map type lexer_error = | UnidentifiedToken of Range.t * string | SeeEndOfFileInComment of Range.t | SeeEndOfFileInStringLiteral of Range.t | BlockClosedWithTooManyBackQuotes of Range.t | SeeBreakInStringLiteral of Range.t | NotASingleCodePoint of Range.t | UnknownEscapeSequence of Range.t type syntax_error = | LexerError of lexer_error | ParseError of Range.t type unification_error = | Contradiction | Inclusion of FreeID.t | InclusionRow of FreeRowID.t | InsufficientRowConstraint of { id : MustBeBoundRowID.t; given : LabelSet.t; required : LabelSet.t; } type type_error = | UnboundVariable of Range.t * identifier | UnificationError of { actual : mono_type; expected : mono_type; detail : unification_error; } | BadArityOfOrderedArguments of { range : Range.t; got : int; expected : int; } | BoundMoreThanOnceInPattern of Range.t * identifier | UnboundTypeParameter of Range.t * type_variable_name | UnboundRowParameter of Range.t * row_variable_name | UndefinedConstructor of Range.t * constructor_name | InvalidNumberOfConstructorArguments of Range.t * constructor_name * int * int | UndefinedTypeName of Range.t * type_name | UndefinedKindName of Range.t * kind_name | InvalidNumberOfTypeArguments of Range.t * type_name * int * int | KindContradiction of Range.t * type_name * kind * kind | TypeParameterBoundMoreThanOnce of Range.t * type_variable_name | RowParameterBoundMoreThanOnce of Range.t * row_variable_name | InvalidByte of Range.t | CyclicSynonymTypeDefinition of (type_name ranged) cycle | UnboundModuleName of Range.t * module_name | NotOfStructureType of Range.t * module_signature | NotOfFunctorType of Range.t * module_signature | NotAFunctorSignature of Range.t * module_signature | NotAStructureSignature of Range.t * module_signature | UnboundSignatureName of Range.t * signature_name | CannotRestrictTransparentType of Range.t * type_name * type_entry | PolymorphicContradiction of Range.t * identifier * poly_type * poly_type | PolymorphicInclusion of Range.t * FreeID.t * poly_type * poly_type | MissingRequiredValName of Range.t * identifier * poly_type | MissingRequiredConstructorName of Range.t * constructor_name * constructor_entry | MissingRequiredTypeName of Range.t * type_name * type_entry | MissingRequiredModuleName of Range.t * module_name * module_signature | MissingRequiredSignatureName of Range.t * signature_name * module_signature abstracted | NotASubtype of Range.t * module_signature * module_signature | NotASubtypeTypeDefinition of Range.t * type_name * type_entry * type_entry | NotASubtypeConstructorDefinition of Range.t * constructor_name * constructor_entry * constructor_entry | NotASubtypeVariant of Range.t * TypeID.t * TypeID.t * constructor_name | OpaqueIDExtrudesScopeViaValue of Range.t * poly_type | OpaqueIDExtrudesScopeViaType of Range.t * type_entry | OpaqueIDExtrudesScopeViaSignature of Range.t * module_signature abstracted | SupportOnlyFirstOrderFunctor of Range.t | RootModuleMustBeStructure of Range.t | InvalidIdentifier of Range.t * string | ConflictInSignature of Range.t * string | DuplicatedLabel of Range.t * label | UnexpectedMandatoryLabel of { range : Range.t; label : label; } | MissingMandatoryLabel of { range : Range.t; label : label; typ : mono_type; } | UnexpectedOptionalLabel of { range : Range.t; label : label; } | NullaryFormatString of Range.t | CannotFreezeNonGlobalName of Range.t * identifier ================================================ FILE: src/fileDependencyGraph.ml ================================================ open MyUtil open Syntax module GraphImpl = Graph.Persistent.Digraph.Abstract(String) module ComponentImpl = Graph.Components.Make(GraphImpl) module TopologicalImpl = Graph.Topological.Make(GraphImpl) module PathMap = Map.Make(String) type vertex = GraphImpl.V.t type entry = { vertex : vertex; } type t = { paths : entry PathMap.t; main : GraphImpl.t; } let empty : t = { paths = PathMap.empty; main = GraphImpl.empty; } let find_vertex (fpath : absolute_path) (graph : t) : vertex option = graph.paths |> PathMap.find_opt fpath |> Option.map (fun entry -> entry.vertex) let add_vertex (abspath : absolute_path) (graph : t) : t * vertex = let vertex = GraphImpl.V.create abspath in let entry = { vertex = vertex; } in let graph = { paths = graph.paths |> PathMap.add abspath entry; main = GraphImpl.add_vertex graph.main vertex; } in (graph, vertex) let add_edge ~depending:(vertex2 : vertex) ~depended:(vertex1 : vertex) (graph : t) : t = { graph with main = GraphImpl.add_edge graph.main vertex1 vertex2 } let find_loop g = GraphImpl.fold_vertex (fun v acc -> match acc with | Some(_) -> acc | None -> if GraphImpl.mem_edge g v v then Some(v) else None ) g None let topological_sort (graph : t) : (absolute_path list, absolute_path cycle) result = match find_loop graph.main with | Some(v) -> Error(Loop(GraphImpl.V.label v)) | None -> let sccs = ComponentImpl.scc_list graph.main in match sccs |> List.find_map (fun vertices -> match vertices with | [] -> assert false | [ _ ] -> None | v1 :: v2 :: vrest -> Some(Cycle(List2.make v1 v2 vrest |> List2.map GraphImpl.V.label)) ) with | Some(cycle) -> Error(cycle) | None -> let acc = TopologicalImpl.fold (fun vertex acc -> let abspath = GraphImpl.V.label vertex in Alist.extend acc abspath ) graph.main Alist.empty in Ok(Alist.to_list acc) ================================================ FILE: src/fileDependencyGraph.mli ================================================ open MyUtil open Syntax type vertex type t val empty : t val find_vertex : absolute_path -> t -> vertex option val add_vertex : absolute_path -> t -> t * vertex val add_edge : depending:vertex -> depended:vertex -> t -> t val topological_sort : t -> (absolute_path list, absolute_path cycle) result (** [topological_sort g] returns either: {ul {- [Ok(paths)] where [paths] is the sorted list of absolute paths of source files, or} {- [Error(cycle)] where [cycle] is a list of mutually dependent source files.} } *) ================================================ FILE: src/freeID.ml ================================================ type level = int type t = { id : int; mutable level : level; } let pp ppf fid = Format.fprintf ppf "'%d" fid.id let equal fid1 fid2 = fid1.id = fid2.id let compare fid1 fid2 = fid2.id - fid1.id let hash fid = fid.id let current_max = ref 0 let initialize () = current_max := 0 let fresh ~message:_msg lev = incr current_max; let ret = { id = !current_max; level = lev; } in (* print_endline (Format.asprintf "generate %a (%s)" pp ret msg); (* for debug *) *) ret let get_level fid = fid.level let update_level fid lev = fid.level <- min fid.level lev ================================================ FILE: src/freeID.mli ================================================ type level = int type t val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int val initialize : unit -> unit val fresh : message:string -> level -> t val get_level : t -> level val update_level : t -> level -> unit val pp : Format.formatter -> t -> unit ================================================ FILE: src/identifierScheme.ml ================================================ (** Every fragment should be a non-empty string consisting only of lowercase letters and digits. `to_upper_camel_case name` outputs `name` in upper camel case (with inserting underscores before every fragment that begins with a digit): *) type t = { fragments : string list; original : string; } let is_digit ch = '0' <= ch && ch <= '9' let is_lowercase ch = 'a' <= ch && ch <= 'z' let is_uppercase ch = 'A' <= ch && ch <= 'Z' let to_lowercase ch = Char.chr (Char.code ch + 0x20) let string_of_chars (chs : char list) : string = let len = List.length chs in let buf = Buffer.create len in chs |> List.iter (Buffer.add_char buf); Buffer.contents buf let is_valid_fragment s = String.length s > 0 && String.equal s (String.lowercase_ascii s) let is_valid = List.for_all is_valid_fragment let from_snake_case (original : string) : t option = let fragments = String.split_on_char '_' original in if is_valid fragments then Some({ fragments; original; }) else None let from_upper_camel_case (original : string) : t option = let len = String.length original in let rec aux (fragacc : string list) (chacc : char list) (index : int) = if index >= len then let fragment = string_of_chars (List.rev chacc) in let fragments = List.rev (fragment :: fragacc) in Some{ fragments; original } else let ch = String.get original index in if is_uppercase ch then let fragment = string_of_chars (List.rev chacc) in aux (fragment :: fragacc) [ to_lowercase ch ] (index + 1) else if is_lowercase ch || is_digit ch then aux fragacc (ch :: chacc) (index + 1) else if ch = '_' then let ch2 = String.get original (index + 1) in if is_digit ch2 then let fragment = string_of_chars (List.rev chacc) in aux (fragment :: fragacc) [ ch2 ] (index + 2) else None else None in try let ch0 = String.get original 0 in if is_uppercase ch0 then aux [] [ to_lowercase ch0 ] 1 else None with | Invalid_argument(_) -> None let original (name : t) : string = name.original let to_snake_case (name : t) : string = name.fragments |> String.concat "_" let capitalize (is_lower_first : bool) (fragment : string) = if is_lower_first then fragment else String.capitalize_ascii fragment let camel_case (is_lower : bool) (name : t) : string = let rec aux is_lower_first acc = function | [] -> List.rev acc | x :: [] -> List.rev (capitalize is_lower_first x :: acc) | x :: ((y :: _) as rest) -> let xcap = capitalize is_lower_first x in if is_digit (String.get y 0) then aux false ((xcap ^ "_") :: acc) rest else aux false (xcap :: acc) rest in aux is_lower [] name.fragments |> String.concat "" let to_lower_camel_case = camel_case true let to_upper_camel_case = camel_case false let pp ppf name = Format.fprintf ppf "<\"%s\">" (to_snake_case name) let compare name1 name2 = String.compare name1.original name2.original ================================================ FILE: src/identifierScheme.mli ================================================ (** `IdentifierScheme` is a module that abstracts identifiers for equating the snake case and the upper camel case. *) type t val from_snake_case : string -> t option (** [from_snake_case s] converts the original identifier string [s] into its corresponding list of word fragments. Here, [s] should match [ * ('_' +)*]. {[ from_snake_case "foo_bar" (* ==> Some{ fragments = ["foo"; "bar"]; ... } *) from_snake_case "foo_Bar" (* ==> None *) from_snake_case "foo__bar" (* ==> None *) from_snake_case "foo_bar_" (* ==> None *) from_snake_case "x86_64" (* ==> Some{ fragments = ["x86"; "64"]; ... } *) ]} *) val from_upper_camel_case : string -> t option val original : t -> string val to_snake_case : t -> string val to_lower_camel_case : t -> string val to_upper_camel_case : t -> string (** {[ to_upper_camel_case { fragments = ["foo"; "bar"]; ... } (* ==> "FooBar" *) to_upper_camel_case { fragments = ["x86"; "64"]; ... } (* ==> "X86_64" *) ]} *) val pp : Format.formatter -> t -> unit val compare : t -> t -> int ================================================ FILE: src/intermediateSyntax.ml ================================================ open MyUtil open Syntax open Env type pattern = | IPUnit | IPBool of bool | IPInt of int | IPBinary of string | IPChar of Uchar.t [@printer (fun ppf uchar -> Format.fprintf ppf "IPChar(%a)" pp_uchar uchar)] | IPVar of local_name | IPWildCard | IPListNil | IPListCons of pattern * pattern | IPTuple of pattern TupleList.t | IPConstructor of ConstructorID.t * pattern list [@@deriving show { with_path = false; } ] type val_binding = | INonRec of (identifier * global_name * poly_type * ast) | IRec of (identifier * global_name * poly_type * ast) list | IExternal of global_name * string and binding = | IBindVal of val_binding | IBindModule of space_name * ModuleAttribute.t * binding list and ast = | IBaseConst of base_constant | IVar of name | ILambda of local_name option * pattern list * pattern LabelAssoc.t * (pattern * ast option) LabelAssoc.t * ast | IApply of name * mono_row * ast list * ast LabelAssoc.t * ast LabelAssoc.t | ILetIn of local_name * ast * ast | ICase of ast * branch list | IReceive of branch list * (ast * ast) option | ITuple of ast TupleList.t | IListNil | IListCons of ast * ast | IConstructor of ConstructorID.t * ast list | IRecord of ast LabelAssoc.t | IRecordAccess of ast * label | IRecordUpdate of ast * label * ast | IFreeze of global_name * ast list | IFreezeUpdate of ast * ast list | IPack of space_name | IAssert of Range.t * ast and branch = | IBranch of pattern * ast let pp_sep_comma ppf () = Format.fprintf ppf ",@ " let rec pp_val_binding_sub ppf (gname, e) = Format.fprintf ppf "%a =@[@ %a@]@," OutputIdentifier.pp_global gname pp_ast e and pp_val_binding ppf = function | INonRec(_, gname, _, e) -> Format.fprintf ppf "val %a" pp_val_binding_sub (gname, e) | IRec(recbinds) -> let pairs = recbinds |> List.map (fun (_, gname, _, e) -> (gname, e)) in Format.fprintf ppf "val %a" (Format.pp_print_list ~pp_sep:pp_sep_comma pp_val_binding_sub) pairs | IExternal(gname, code) -> Format.fprintf ppf "val %a = external@ \"%s\"@," OutputIdentifier.pp_global gname code and pp_binding ppf = function | IBindVal(valbind) -> pp_val_binding ppf valbind | IBindModule(sname, _modattr, ibinds) -> Format.fprintf ppf "module %a = @[{%a}@]@," OutputIdentifier.pp_space sname (Format.pp_print_list pp_binding) ibinds and pp_ast ppf = function | IBaseConst(bc) -> pp_base_constant ppf bc | IVar(name) -> OutputIdentifier.pp ppf name | ILambda(lnamerecopt, ordipats, mndipatmap, optipatmap, e) -> let snamerec = match lnamerecopt with | Some(lnamerec) -> Format.asprintf "%a" OutputIdentifier.pp_local lnamerec | None -> "" in Format.fprintf ppf "\\%s(%a -{%a} ?{%a}) ->@[@ %a@]" snamerec (Format.pp_print_list ~pp_sep:pp_sep_comma pp_pattern) ordipats (LabelAssoc.pp pp_pattern) mndipatmap (LabelAssoc.pp (fun ppf (ipat, astopt) -> match astopt with | None -> Format.fprintf ppf "%a" pp_pattern ipat | Some(ast) -> Format.fprintf ppf "%a = %a" pp_pattern ipat pp_ast ast )) optipatmap pp_ast e | IApply(name, _, eargs, mndargmap, optargmap) -> Format.fprintf ppf "%a@[(%a -{%a} ?{%a})@]" OutputIdentifier.pp name (Format.pp_print_list ~pp_sep:pp_sep_comma pp_ast) eargs (LabelAssoc.pp pp_ast) mndargmap (LabelAssoc.pp pp_ast) optargmap | ILetIn(lname, e1, e2) -> Format.fprintf ppf "(let %a =@[@ %a@]@ in@ %a)" OutputIdentifier.pp_local lname pp_ast e1 pp_ast e2 | ICase(e0, ibrs) -> Format.fprintf ppf "(case@[@ %a@]@ of@[@ %a@]@ end)" pp_ast e0 (Format.pp_print_list pp_branch) ibrs | ITuple(es) -> Format.fprintf ppf "{%a}" (Format.pp_print_list ~pp_sep:pp_sep_comma pp_ast) (es |> TupleList.to_list) | _ -> Format.fprintf ppf "..." and pp_branch ppf = function | IBranch(ipat, e) -> Format.fprintf ppf "%a ->@[@ %a@];@ " pp_pattern ipat pp_ast e module GlobalNameMap = Map.Make(OutputIdentifier.Global) module SpaceNameMap = Map.Make(OutputIdentifier.Space) type name_map = string GlobalNameMap.t * string SpaceNameMap.t (* The type for maps tracking which module every global name belongs to. This is used by 'Primitives' and 'OutputErlangCode'. *) ================================================ FILE: src/kindStore.ml ================================================ open Syntax open Env module FreeRowHashTable = Hashtbl.Make(FreeRowID) module BoundRowHashTable = Hashtbl.Make(BoundRowID) let free_row_hash_table = FreeRowHashTable.create 1024 let bound_row_hash_table = BoundRowHashTable.create 1024 let register_free_row (frid : FreeRowID.t) (labset : LabelSet.t) : unit = FreeRowHashTable.add free_row_hash_table frid labset let get_free_row (frid : FreeRowID.t) : LabelSet.t = match FreeRowHashTable.find_opt free_row_hash_table frid with | None -> assert false | Some(labset) -> labset let register_bound_row (brid : BoundRowID.t) (labset : LabelSet.t) : unit = BoundRowHashTable.add bound_row_hash_table brid labset let get_bound_row (brid : BoundRowID.t) : LabelSet.t = match BoundRowHashTable.find_opt bound_row_hash_table brid with | None -> assert false | Some(labset) -> labset ================================================ FILE: src/kindStore.mli ================================================ open Syntax open Env val register_free_row : FreeRowID.t -> LabelSet.t -> unit val get_free_row : FreeRowID.t -> LabelSet.t val register_bound_row : BoundRowID.t -> LabelSet.t -> unit val get_bound_row : BoundRowID.t -> LabelSet.t ================================================ FILE: src/languageVersion.ml ================================================ type t = Semver.t let parse (s : string) : t option = Option.bind (Core.String.chop_prefix s ~prefix:"v") Semver.of_string let is_compatible ~(before : t) ~(after : t) = let open Semver in match (before.major, after.major) with | (0, 0) -> before.minor = after.minor && before.patch <= after.patch | _ -> before.major = after.major && ((before.minor < after.minor) || (before.minor == after.minor && before.patch <= after.patch)) let is_supported (specified_language_version : string) : bool = match (parse specified_language_version, parse Constants.semantic_version) with | (_, None) -> assert false | (None, _) -> false | (Some(specified), Some(required)) -> is_compatible ~before:specified ~after:required ================================================ FILE: src/lexer.mll ================================================ { open MyUtil open Syntax open Parser open Errors exception Error of lexer_error let raise_error e = raise (Error(e)) let hole_of_char = function | 'c' -> HoleC | 'f' -> HoleF | 'e' -> HoleE | 'g' -> HoleG | 's' -> HoleS | 'p' -> HoleP | 'w' -> HoleW | _ -> assert false let int_of_string_or_empty = function | "" -> None | s -> Some(int_of_string s) let flush_buffer strbuf = let s = Buffer.contents strbuf in Buffer.clear strbuf; FormatConst(s) let escape_sequence c rngL = match c with | 'n' -> '\n' | 'r' -> '\r' | 't' -> '\t' | '\\' | '"' | '\'' -> c | _ -> raise_error (UnknownEscapeSequence(rngL)) } let space = [' ' '\t'] let break = ['\n' '\r'] let nzdigit = ['1'-'9'] let digit = (nzdigit | "0") let hex = (digit | ['A'-'F']) let capital = ['A'-'Z'] let small = ['a'-'z'] let latin = (small | capital) let identifier = (small (digit | latin | "_")*) let constructor = (capital (digit | latin | "_")*) let nssymbol = ['&' '|' '=' '/' '+' '-' '.'] let fmtdigits = (("-" digit+) | (digit*)) let hole = ['c' 'f' 'e' 'g' 's' 'p' 'w'] rule token = parse | space { token lexbuf } | break { Lexing.new_line lexbuf; token lexbuf } | eof { EOI } | identifier { let s = Lexing.lexeme lexbuf in let pos = Range.from_lexbuf lexbuf in match s with | "let" -> LET(pos) | "rec" -> REC(pos) | "and" -> AND(pos) | "in" -> IN(pos) | "fun" -> LAMBDA(pos) | "if" -> IF(pos) | "then" -> THEN(pos) | "else" -> ELSE(pos) | "true" -> TRUE(pos) | "false" -> FALSE(pos) | "act" -> ACT(pos) | "do" -> DO(pos) | "receive" -> RECEIVE(pos) | "after" -> AFTER(pos) | "end" -> END(pos) | "case" -> CASE(pos) | "of" -> OF(pos) | "val" -> VAL(pos) | "type" -> TYPE(pos) | "module" -> MODULE(pos) | "struct" -> STRUCT(pos) | "signature" -> SIGNATURE(pos) | "sig" -> SIG(pos) | "with" -> WITH(pos) | "external" -> EXTERNAL(pos) | "include" -> INCLUDE(pos) | "import" -> IMPORT(pos) | "freeze" -> FREEZE(pos) | "pack" -> PACK(pos) | "assert" -> ASSERT(pos) | "open" -> OPEN(pos) | _ -> LOWER(pos, s) } | "f\'" { let posL = Range.from_lexbuf lexbuf in let strbuf = Buffer.create 128 in let (rng, fmtelemacc) = format_literal posL strbuf Alist.empty lexbuf in FORMAT(rng, Alist.to_list fmtelemacc) } | constructor { let s = Lexing.lexeme lexbuf in let pos = Range.from_lexbuf lexbuf in UPPER(pos, s) } | ("0" | nzdigit (digit*) | ("0x" | "0X") hex+) { let s = Lexing.lexeme lexbuf in let pos = Range.from_lexbuf lexbuf in INT(pos, int_of_string s) } | (("0" | nzdigit (digit*)) "." (digit*)) { let s = Lexing.lexeme lexbuf in let pos = Range.from_lexbuf lexbuf in FLOAT(pos, float_of_string s) } | ("." (constructor as s)) { let pos = Range.from_lexbuf lexbuf in DOTUPPER(pos, s) } | ("." (identifier as s)) { let pos = Range.from_lexbuf lexbuf in DOTLOWER(pos, s) } | ("?" (identifier as s)) { let pos = Range.from_lexbuf lexbuf in OPTLABEL(pos, s) } | ("?$" (identifier as s)) { let pos = Range.from_lexbuf lexbuf in ROWPARAM(pos, s) } | ("$" (identifier as s)) { let pos = Range.from_lexbuf lexbuf in TYPARAM(pos, s) } | "$\'" { let posL = Range.from_lexbuf lexbuf in let strbuf = Buffer.create 16 in let (rng, s) = string_literal posL strbuf lexbuf in match MyUtil.Utf.uchar_of_utf8 s with | [ uchar ] -> CHAR(rng, uchar) | _ -> raise_error (NotASingleCodePoint(rng)) } | "_" { UNDERSCORE(Range.from_lexbuf lexbuf) } | "," { COMMA(Range.from_lexbuf lexbuf) } | "(" { LPAREN(Range.from_lexbuf lexbuf) } | ")" { RPAREN(Range.from_lexbuf lexbuf) } | "[" { LSQUARE(Range.from_lexbuf lexbuf) } | "]" { RSQUARE(Range.from_lexbuf lexbuf) } | "{" { LBRACE(Range.from_lexbuf lexbuf) } | "}" { RBRACE(Range.from_lexbuf lexbuf) } | "#[" { ATTRIBUTE(Range.from_lexbuf lexbuf) } | "::" { CONS(Range.from_lexbuf lexbuf) } | ":" { COLON(Range.from_lexbuf lexbuf) } | ":>" { COERCE(Range.from_lexbuf lexbuf) } | ("&" (nssymbol*)) { BINOP_AMP(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | "|" { BAR(Range.from_lexbuf lexbuf) } | ("|" (nssymbol+)) { BINOP_BAR(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | "=" { DEFEQ(Range.from_lexbuf lexbuf) } | ("=" (nssymbol+)) { BINOP_EQ(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | "<-" { REVARROW(Range.from_lexbuf lexbuf) } | "<<" { LTLT(Range.from_lexbuf lexbuf) } | "<" { LT_EXACT(Range.from_lexbuf lexbuf) } | ("<" (nssymbol+)) { BINOP_LT(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | (">" space) { GT_SPACES(Range.from_lexbuf lexbuf) } | (">" break) { Lexing.new_line lexbuf; GT_SPACES(Range.from_lexbuf lexbuf) } | ">" { GT_NOSPACE(Range.from_lexbuf lexbuf) } | (">" (nssymbol+)) { BINOP_GT(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | ("*" (nssymbol*)) { BINOP_TIMES(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | "/*" { comment (Range.from_lexbuf lexbuf) lexbuf; token lexbuf } | ("/" (nssymbol*)) { BINOP_DIVIDES(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | ("+" (nssymbol*)) { BINOP_PLUS(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | "->" { ARROW(Range.from_lexbuf lexbuf) } | ("-" (nssymbol*)) { BINOP_MINUS(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } | ("-" (identifier as s)) { let pos = Range.from_lexbuf lexbuf in MNDLABEL(pos, s) } | "\"" { let posL = Range.from_lexbuf lexbuf in let strbuf = Buffer.create 128 in let (rng, s) = binary_literal posL strbuf lexbuf in BINARY(rng, s) } | "\'" { let posL = Range.from_lexbuf lexbuf in let strbuf = Buffer.create 128 in let (rng, s) = string_literal posL strbuf lexbuf in STRING(rng, s) } | ("`"+ break) { (* When first character in a string block is a line break, ignore this line break *) Lexing.new_line lexbuf; let posL = Range.from_lexbuf lexbuf in let num_start = String.length (String.trim (Lexing.lexeme lexbuf)) in let strbuf = Buffer.create 128 in string_block num_start posL strbuf lexbuf } | ("`"+) { let posL = Range.from_lexbuf lexbuf in let num_start = String.length (Lexing.lexeme lexbuf) in let strbuf = Buffer.create 128 in string_block num_start posL strbuf lexbuf } | _ as c { raise_error (UnidentifiedToken(Range.from_lexbuf lexbuf, String.make 1 c)) } and binary_literal posL strbuf = parse | break { raise_error (SeeBreakInStringLiteral(posL)) } | eof { raise_error (SeeEndOfFileInStringLiteral(posL)) } | ("\\" (_ as c)) { Buffer.add_char strbuf (escape_sequence c posL); binary_literal posL strbuf lexbuf } | "\"" { let posR = Range.from_lexbuf lexbuf in (Range.unite posL posR, Buffer.contents strbuf) } | _ as c { Buffer.add_char strbuf c; binary_literal posL strbuf lexbuf } and string_literal posL strbuf = parse | break { raise_error (SeeBreakInStringLiteral(posL)) } | eof { raise_error (SeeEndOfFileInStringLiteral(posL)) } | ("\\" (_ as c)) { Buffer.add_char strbuf (escape_sequence c posL); string_literal posL strbuf lexbuf } | "\'" { let posR = Range.from_lexbuf lexbuf in (Range.unite posL posR, Buffer.contents strbuf) } | _ as c { Buffer.add_char strbuf c; string_literal posL strbuf lexbuf } and format_literal posL strbuf acc = parse | break { raise_error (SeeBreakInStringLiteral(posL)) } | eof { raise_error (SeeEndOfFileInStringLiteral(posL)) } | "\'" { let posR = Range.from_lexbuf lexbuf in let elem = flush_buffer strbuf in (Range.unite posL posR, Alist.extend acc elem) } | "\\\'" { Buffer.add_char strbuf '\''; format_literal posL strbuf acc lexbuf } | "~~" { let elem = flush_buffer strbuf in format_literal posL strbuf (Alist.append acc [elem; FormatTilde]) lexbuf } | "~n" { let elem = flush_buffer strbuf in format_literal posL strbuf (Alist.append acc [elem; FormatBreak]) lexbuf } | ("~" (fmtdigits as s1) (hole as c)) { let elem = flush_buffer strbuf in let hole = hole_of_char c in let control = { field_width = int_of_string_or_empty s1; precision = None; padding = None; } in format_literal posL strbuf (Alist.append acc [elem; FormatHole(hole, control)]) lexbuf } | ("~" (fmtdigits as s1) "." (fmtdigits as s2) (hole as c)) { let elem = flush_buffer strbuf in let hole = hole_of_char c in let control = { field_width = int_of_string_or_empty s1; precision = int_of_string_or_empty s2; padding = None; } in format_literal posL strbuf (Alist.append acc [elem; FormatHole(hole, control)]) lexbuf } | "\\\"" { let elem = flush_buffer strbuf in format_literal posL strbuf (Alist.append acc [elem; FormatDQuote]) lexbuf } | _ as c { Buffer.add_char strbuf c; format_literal posL strbuf acc lexbuf } and string_block num_start posL strbuf = parse | ("`" +) { let posR = Range.from_lexbuf lexbuf in let s = Lexing.lexeme lexbuf in let num_end = String.length s in if num_end > num_start then raise_error (BlockClosedWithTooManyBackQuotes(posR)) else if num_end = num_start then STRING_BLOCK(Range.unite posL posR, Buffer.contents strbuf) else begin Buffer.add_string strbuf s; string_block num_start posL strbuf lexbuf end } | break { let s = Lexing.lexeme lexbuf in Lexing.new_line lexbuf; Buffer.add_string strbuf s; string_block num_start posL strbuf lexbuf } | eof { raise_error (SeeEndOfFileInStringLiteral(posL)) } | _ as c { Buffer.add_char strbuf c; string_block num_start posL strbuf lexbuf } and comment rng = parse | "/*" { comment (Range.from_lexbuf lexbuf) lexbuf; comment rng lexbuf } | "*/" { () } | break { Lexing.new_line lexbuf; comment rng lexbuf } | eof { raise_error (SeeEndOfFileInComment(rng)) } | _ { comment rng lexbuf } ================================================ FILE: src/list1.ml ================================================ open MyUtil type 'a t = 'a * 'a list let make x1 xs = (x1, xs) let map f (x1, xs) = let y1 = f x1 in (y1, xs |> List.map f) let map_and_fold : 'a 'b 'c. ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t = fun f acc0 (x1, xs) -> let (acc1, y1) = f acc0 x1 in let (acc, yacc) = xs |> List.fold_left (fun (acc, yacc) x -> let (acc, y) = f acc x in (acc, Alist.extend yacc y) ) (acc1, Alist.empty) in (acc, (y1, Alist.to_list yacc)) let to_list (x1, xs) = x1 :: xs let pp (type a) (ppa : Format.formatter -> a -> unit) (ppf : Format.formatter) ((x1, xs) : a t) = Format.fprintf ppf "%a@ %a" ppa x1 (Format.pp_print_list ppa) xs ================================================ FILE: src/list1.mli ================================================ type 'a t (** ['a t] is the type for lists (of values of type ['a]) the length of which is more than or equal to 1. *) val make : 'a -> 'a list -> 'a t (** [make e1 es] corresponds to [e1 :: es]. *) val map : ('a -> 'b) -> 'a t -> 'b t val map_and_fold : ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t val to_list : 'a t -> 'a list (** [to_list] forgets the constraint of the length. *) val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit ================================================ FILE: src/list2.ml ================================================ open MyUtil type 'a t = 'a * 'a * 'a list let make x1 x2 xs = (x1, x2, xs) let map f (x1, x2, xs) = let y1 = f x1 in let y2 = f x2 in (y1, y2, xs |> List.map f) let map_and_fold : 'a 'b 'c. ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t = fun f acc0 (x1, x2, xs) -> let (acc1, y1) = f acc0 x1 in let (acc2, y2) = f acc1 x2 in let (acc, yacc) = xs |> List.fold_left (fun (acc, yacc) x -> let (acc, y) = f acc x in (acc, Alist.extend yacc y) ) (acc2, Alist.empty) in (acc, (y1, y2, Alist.to_list yacc)) let to_list (x1, x2, xs) = x1 :: x2 :: xs let decompose (v : 'a t) = v let pp (type a) (ppa : Format.formatter -> a -> unit) (ppf : Format.formatter) ((x1, x2, xs) : a t) = Format.fprintf ppf "%a@ %a@ %a" ppa x1 ppa x2 (Format.pp_print_list ppa) xs ================================================ FILE: src/list2.mli ================================================ type 'a t (** ['a t] is the type for lists (of values of type ['a]) the length of which is more than or equal to 2. *) val make : 'a -> 'a -> 'a list -> 'a t (** [make e1 e2 es] corresponds to [e1 :: e2 :: es]. *) val map : ('a -> 'b) -> 'a t -> 'b t val map_and_fold : ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t val to_list : 'a t -> 'a list (** [to_list] forgets the constraint of the length. *) val decompose : 'a t -> 'a * 'a * 'a list val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit ================================================ FILE: src/logging.ml ================================================ open MyUtil open Syntax open Env open Errors let warn_val_not_used (rng : Range.t) (x : identifier) = Format.printf "* [Warning] %a: variable '%s' is unused\n" Range.pp rng x let warn_invalid_attribute (warning : attribute_warning) = Format.printf "* [Warning] %a: tag '%s': %s\n" Range.pp warning.position warning.tag warning.message let output_written (fpath : string) = Format.printf " output written on '%s'.\n" fpath let begin_to_parse (abspath : absolute_path) = Format.printf " parsing '%s' ...\n" abspath let begin_to_typecheck (abspath : absolute_path) = Format.printf " type checking '%s' ...\n" abspath let report_unsupported_feature (msg : string) = Format.printf "! [Unsupported] \"%s\"\n" msg let report_invalid_external_spec (s : string) = Format.printf "! [Error] invalid external spec: \"%s\"\n" s let report_system_error (msg : string) = Format.printf "! [Error] system error: %s\n" msg let report_parser_error (rng : Range.t) = Format.printf "%a: syntax error\n" Range.pp rng let report_lexer_error (e : lexer_error) : unit = Format.printf "! [Syntax error] "; match e with | UnidentifiedToken(rng, s) -> Format.printf "%a: unidentified token '%s'\n" Range.pp rng s | SeeEndOfFileInComment(rngL) -> Format.printf "%a: an unclosed comment begins here\n" Range.pp rngL | SeeEndOfFileInStringLiteral(rngL) -> Format.printf "%a: an unclosed string literal begins here\n" Range.pp rngL | SeeBreakInStringLiteral(rngL) -> Format.printf "%a: a string literal that contains a break begins here\n" Range.pp rngL | BlockClosedWithTooManyBackQuotes(rngR) -> Format.printf "%a: a string block ends with too many back quotes\n" Range.pp rngR | NotASingleCodePoint(rng) -> Format.printf "%a: not a single code point\n" Range.pp rng | UnknownEscapeSequence(rngL) -> Format.printf "%a: unknown escape sequence \n" Range.pp rngL let report_config_error (e : config_error) : unit = Format.printf "! [Build error] "; match e with | ConfigFileError(e) -> Format.printf "malformed config file; %a\n" YamlDecoder.pp_error e | CyclicFileDependencyFound(cycle) -> begin match cycle with | Loop(abspath) -> Format.printf "file '%s' is dependent on itself.\n" abspath | Cycle(abspaths) -> Format.printf "cyclic file dependency found among:\n"; abspaths |> List2.to_list |> List.iter (fun abspath -> Format.printf " - '%s'\n" abspath ) end | MultipleModuleOfTheSameName(modnm, abspath1, abspath2) -> Format.printf "multiple module bound with the same name '%s':\n - %s\n - %s\n" modnm abspath1 abspath2 | ModuleNotFound(rng, modnm) -> Format.printf "%a: module '%s' not found\n" Range.pp rng modnm | InvalidPackageName(s) -> Format.printf "invalid package name '%s'\n" s | CannotSpecifyDependency -> Format.printf "cannot specify dependency at standalone file\n" | MainModuleNotFound(pkgname, modnm) -> Format.printf "main module '%s' not found in package '%s'\n" modnm pkgname | UnrecognizableExtension(ext) -> Format.printf "unrecognizable extension '%s' for a source file\n" ext | ConfigFileNotFound(abspath) -> Format.printf "config file '%s' not found\n" abspath | SourceFileDependsOnTestFile(mod_src, mod_test) -> Format.printf "source module '%s' depends on test module '%s'\n" mod_src mod_test | NoOutputSpecForSingleSource -> Format.printf "no output spec ('--output' or '-o') for single source file\n" | UnsupportedLanguageVersion(language_version) -> Format.printf "unsupported language version '%s' (the version of this compiler is '%s')\n" language_version Constants.semantic_version let report_package_error (e : package_error) : unit = Format.printf "! [Build error] "; match e with | DuplicatedPackageName(pkgname, abspath1, abspath2) -> Format.printf "multiple package have the same name '%s':\n - %s\n - %s\n" pkgname abspath1 abspath2 | PackageDirNotFound(absdir) -> Format.printf "package directory '%s' not found\n" absdir | NotFoundInExternalMap(pkgname, external_map) -> let knowns = external_map |> ExternalMap.bindings in Format.printf "package '%s' not found in:\n" pkgname; knowns |> List.iter (fun (name, path) -> Format.printf " - %s (%s)\n" name path ) let pp_type_parameter_list dispmap ppf bids = match bids with | [] -> () | _ :: _ -> let pp_bound_id ppf bid = Format.fprintf ppf "%s" (dispmap |> DisplayMap.find_bound_id bid) in let pp_sep ppf () = Format.fprintf ppf ", " in Format.fprintf ppf "<%a>" (Format.pp_print_list ~pp_sep pp_bound_id) bids let make_display_map_from_mono_types = DisplayMap.empty |> List.fold_left (fun dispmap ty -> dispmap |> TypeConv.collect_ids_mono ty) let make_display_map_from_poly_types = DisplayMap.empty |> List.fold_left (fun dispmap pty -> dispmap |> TypeConv.collect_ids_poly pty) let print_free_rows_and_base_kinds (dispmap : DisplayMap.t) = let row_names = dispmap |> DisplayMap.fold_free_row_id (fun frid (row_name, labset) acc -> let s = labset |> LabelSet.elements |> String.concat ", " in Alist.extend acc (row_name, s) ) Alist.empty |> Alist.to_rev_list in match row_names with | [] -> () | _ :: _ -> Format.printf " where\n"; row_names |> List.iter (fun (row_name, skd) -> Format.printf " - %s :: (%s)\n" row_name skd ) let print_bound_ids (ss : string list) = match ss with | [] -> () | _ :: _ -> Format.printf " where\n"; ss |> List.iter (fun s -> Format.printf " - %s\n" s ) let report_unification_error ~actual:(ty1 : mono_type) ~expected:(ty2 : mono_type) (e : unification_error) : unit = match e with | Contradiction -> let dispmap = make_display_map_from_mono_types [ty1; ty2] in let (rng1, _) = ty1 in Format.printf "%a:\n" Range.pp rng1; Format.printf " this expression has type\n"; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty1; Format.printf " but is expected of type\n"; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty2; print_free_rows_and_base_kinds dispmap | Inclusion(fid) -> let dispmap = make_display_map_from_mono_types [ty1; ty2] in let (rng1, _) = ty1 in Format.printf "%a:" Range.pp rng1; Format.printf " this expression has type\n"; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty1; Format.printf " and type\n"; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty2; Format.printf " at the same time, but these types are inconsistent as to the occurrence of type variable %s\n" (dispmap |> DisplayMap.find_free_id fid); print_free_rows_and_base_kinds dispmap | InclusionRow(frid) -> let dispmap = make_display_map_from_mono_types [ty1; ty2] in let (rng1, _) = ty1 in Format.printf "%a:\n" Range.pp rng1; Format.printf " this expression has type\n"; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty1; Format.printf " and type\n"; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty2; Format.printf " at the same time, but these types are inconsistent as to the occurrence of row variable %s\n" (dispmap |> DisplayMap.find_free_row_id frid); print_free_rows_and_base_kinds dispmap | InsufficientRowConstraint(r) -> let dispmap = make_display_map_from_mono_types [ty1; ty2] in let (rng1, _) = ty1 in Format.printf "%a:\n" Range.pp rng1; Format.printf " this expression has type\n"; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty1; Format.printf " but is expected of type\n"; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty2; print_free_rows_and_base_kinds dispmap; Format.printf " The row parameter %a is specified so that it does not contain the following label(s):\n" MustBeBoundRowID.pp_rich r.id; Format.printf " %s\n" (r.given |> LabelSet.elements |> String.concat ", "); Format.printf " but the following label(s) should also be specified:\n"; Format.printf " %s\n" (r.required |> LabelSet.elements |> String.concat ", ") let report_type_error (e : type_error) : unit = Format.printf "! [Type error] "; match e with | UnboundVariable(rng, x) -> Format.printf "%a:\n" Range.pp rng; Format.printf " unbound variable '%s'\n" x | UnificationError(r) -> report_unification_error ~actual:r.actual ~expected:r.expected r.detail | BoundMoreThanOnceInPattern(rng, x) -> Format.printf "%a:\n" Range.pp rng; Format.printf " this pattern binds '%s' more than once.\n" x | UnboundTypeParameter(rng, tyvar) -> Format.printf "%a:\n" Range.pp rng; Format.printf " unbound type variable '$%s'\n" tyvar | UnboundRowParameter(rng, rowvar) -> Format.printf "%a:\n" Range.pp rng; Format.printf " unbound row variable '?$%s'\n" rowvar | UndefinedConstructor(rng, ctor) -> Format.printf "%a:\n" Range.pp rng; Format.printf " undefined constructor '%s'\n" ctor | InvalidNumberOfConstructorArguments(rng, ctor, len_expected, len_actual) -> Format.printf "%a:\n" Range.pp rng; Format.printf " constructor '%s' expects %d argument(s), but is here applied to %d argument(s)\n" ctor len_expected len_actual | UndefinedTypeName(rng, tynm) -> Format.printf "%a:\n" Range.pp rng; Format.printf " undefined type or type constructor '%s'\n" tynm | UndefinedKindName(rng, kdnm) -> Format.printf "%a:\n" Range.pp rng; Format.printf " undefined kind '%s'\n" kdnm | InvalidNumberOfTypeArguments(rng, tynm, len_expected, len_actual) -> Format.printf "%a:\n" Range.pp rng; Format.printf " type constructor '%s' expects %d argument(s), but is here applied to %d argument(s)\n" tynm len_expected len_actual | KindContradiction(rng, tynm, kd_expected, kd_actual) -> Format.printf "%a:\n" Range.pp rng; Format.printf " type constructor '%s' has kind %s, but is expected of kind %s\n" tynm (TypeConv.show_kind kd_actual) (TypeConv.show_kind kd_expected) | TypeParameterBoundMoreThanOnce(rng, tyvar) -> Format.printf "%a:\n" Range.pp rng; Format.printf " type variable '%s' is bound more than once\n" tyvar | RowParameterBoundMoreThanOnce(rng, rowvar) -> Format.printf "%a:\n" Range.pp rng; Format.printf " row variable '%s' is bound more than once\n" rowvar | InvalidByte(rng) -> Format.printf "%a:\n" Range.pp rng; Format.printf " invalid byte\n" | CyclicSynonymTypeDefinition(cycle) -> let tyidents = match cycle with | Loop(tyident) -> [ tyident ] | Cycle(tyidents) -> tyidents |> List2.to_list in Format.printf "cyclic type definitions:\n"; tyidents |> List.iter (fun (rng, tynm) -> Format.printf " - %s (%a)\n" tynm Range.pp rng ) | UnboundModuleName(rng, modnm) -> Format.printf "%a:\n" Range.pp rng; Format.printf " unbound module name '%s'\n" modnm | NotOfStructureType(rng, modsig) -> Format.printf "%a:\n" Range.pp rng; Format.printf " this module expression is not of a structure signature\n" | NotOfFunctorType(rng, modsig) -> Format.printf "%a:\n" Range.pp rng; Format.printf " this module expression is not of a functor signature\n" | NotAStructureSignature(rng, modsig) -> Format.printf "%a:\n" Range.pp rng; Format.printf " this signature expression is not a structure\n" | NotAFunctorSignature(rng, modsig) -> Format.printf "%a:\n" Range.pp rng; Format.printf " this signature expression is not a functor\n" | UnboundSignatureName(rng, signm) -> Format.printf "%a:\n" Range.pp rng; Format.printf " unbound signature name '%s'\n" signm | CannotRestrictTransparentType(rng, tynm, _) -> Format.printf "%a:\n" Range.pp rng; Format.printf " the specified type '%s' is already transparent\n" tynm | PolymorphicContradiction(rng, x, pty1, pty2) -> let dispmap = make_display_map_from_poly_types [pty1; pty2] in let sbids = TypeConv.show_bound_type_ids dispmap in let sbrids = TypeConv.show_bound_row_ids dispmap in Format.printf "%a:\n" Range.pp rng; Format.printf " as to value '%s', type\n" x; Format.printf " %a\n" (TypeConv.pp_poly_type dispmap) pty1; Format.printf " is not a subtype of\n"; Format.printf " %a\n" (TypeConv.pp_poly_type dispmap) pty2; print_bound_ids (List.append sbids sbrids) | PolymorphicInclusion(rng, fid, pty1, pty2) -> let dispmap = make_display_map_from_poly_types [pty1; pty2] in let sbids = TypeConv.show_bound_type_ids dispmap in let sbrids = TypeConv.show_bound_row_ids dispmap in Format.printf "%a:\n" Range.pp rng; Format.printf " type\n"; Format.printf " %a\n" (TypeConv.pp_poly_type dispmap) pty1; Format.printf " is inconsistent with type\n"; Format.printf " %a\n" (TypeConv.pp_poly_type dispmap) pty2; Format.printf " as to type variable %s\n" (dispmap |> DisplayMap.find_free_id fid); print_bound_ids (List.append sbids sbrids) | MissingRequiredValName(rng, x, pty) -> let dispmap = make_display_map_from_poly_types [pty] in let sbids = TypeConv.show_bound_type_ids dispmap in let sbrids = TypeConv.show_bound_row_ids dispmap in Format.printf "%a:\n" Range.pp rng; Format.printf " missing required value '%s' of type\n" x; Format.printf " %a\n" (TypeConv.pp_poly_type dispmap) pty; print_bound_ids (List.concat [sbids; sbrids]) | MissingRequiredConstructorName(rng, ctornm, _centry) -> Format.printf "%a:\n" Range.pp rng; Format.printf " missing required constructor '%s'\n" ctornm | MissingRequiredTypeName(rng, tynm, tentry) -> Format.printf "%a:\n" Range.pp rng; Format.printf " missing required type name '%s' of arity %d\n" tynm (TypeConv.arity_of_kind tentry.type_kind) | MissingRequiredModuleName(rng, modnm, _modsign) -> Format.printf "%a:\n" Range.pp rng; Format.printf " missing required module name '%s'\n" modnm | MissingRequiredSignatureName(rng, signm, _absmodsig) -> Format.printf "%a:\n" Range.pp rng; Format.printf " missing required module name '%s'\n" signm | NotASubtype(rng, modsig1, modsig2) -> Format.printf "%a:\n" Range.pp rng; Format.printf " not a subtype (TODO: detailed explanation)\n" | NotASubtypeTypeDefinition(rng, tynm, _tentry1, _tentry2) -> Format.printf "%a:\n" Range.pp rng; Format.printf " not a subtype; type '%s' cannot be encapsulated (TODO: detailed explanation)\n" tynm | NotASubtypeConstructorDefinition(rng, ctornm, _centry1, _centry2) -> Format.printf "%a:\n" Range.pp rng; Format.printf " not a subtype; constructor '%s' cannot be encapsulated (TODO: detailed explanation)\n" ctornm | NotASubtypeVariant(rng, _vid1, _vid2, ctor) -> Format.printf "%a:\n" Range.pp rng; Format.printf " not a subtype about constructor '%s' (TODO: detailed explanation)\n" ctor | OpaqueIDExtrudesScopeViaValue(rng, _pty) -> Format.printf "%a:\n" Range.pp rng; Format.printf " an abstract type extrudes its scope via value (TODO: detailed explanation)\n" | OpaqueIDExtrudesScopeViaType(rng, _tyopac) -> Format.printf "%a:\n" Range.pp rng; Format.printf " an abstract type extrudes its scope via type (TODO: detailed explanation)\n" | OpaqueIDExtrudesScopeViaSignature(rng, _absmodsig) -> Format.printf "%a:\n" Range.pp rng; Format.printf " an abstract type extrudes its scope via signature (TODO: detailed explanation)\n" | SupportOnlyFirstOrderFunctor(rng) -> Format.printf "%a:\n" Range.pp rng; Format.printf " only first-order functors are supported\n" | RootModuleMustBeStructure(rng) -> Format.printf "%a:\n" Range.pp rng; Format.printf " root modules must be structures\n" | InvalidIdentifier(rng, s) -> Format.printf "%a:\n" Range.pp rng; Format.printf " invalid identifier '%s'\n" s | ConflictInSignature(rng, x) -> Format.printf "%a:\n" Range.pp rng; Format.printf " '%s' is already defined in the signature\n" x | DuplicatedLabel(rng, label) -> Format.printf "%a:\n" Range.pp rng; Format.printf " label '%s' is used more than once in a binding\n" label | BadArityOfOrderedArguments(info) -> Format.printf "%a:\n" Range.pp info.range; Format.printf " the function expects %d ordered argument(s), but is applied to %d ordered argument(s) here\n" info.expected info.got | MissingMandatoryLabel(info) -> let ty = info.typ in let dispmap = make_display_map_from_mono_types [ty] in Format.printf "%a:\n" Range.pp info.range; Format.printf " missing mandatory label '-%s' with an argument of type\n" info.label; Format.printf " %a\n" (TypeConv.pp_mono_type dispmap) ty; print_free_rows_and_base_kinds dispmap | UnexpectedMandatoryLabel(info) -> Format.printf "%a:\n" Range.pp info.range; Format.printf " unexpected mandatory label '-%s'\n" info.label | UnexpectedOptionalLabel(info) -> Format.printf "%a:\n" Range.pp info.range; Format.printf " unexpected optional label '?%s'\n" info.label | NullaryFormatString(rng) -> Format.printf "%a:\n" Range.pp rng; Format.printf " nullary format string\n" | CannotFreezeNonGlobalName(rng, x) -> Format.printf "%a:\n" Range.pp rng; Format.printf " cannot freeze non-top-level identifier '%s'\n" x ================================================ FILE: src/main.ml ================================================ open MyUtil open Syntax open Errors open Env exception InvalidExternalSpec of string let catch_error (k : unit -> unit) = try k () with | Sys_error(msg) -> Logging.report_system_error msg; exit 1 | Failure(msg) -> Logging.report_unsupported_feature msg; exit 1 | InvalidExternalSpec(s) -> Logging.report_invalid_external_spec s; exit 1 | PackageLoader.PackageError(e) -> Logging.report_package_error e; exit 1 | SourceLoader.SyntaxError(LexerError(e)) -> Logging.report_lexer_error e; exit 1 | SourceLoader.SyntaxError(ParseError(rng)) -> Logging.report_parser_error rng; exit 1 | ConfigError(e) -> Logging.report_config_error e; exit 1 | Typechecker.TypeError(e) -> Logging.report_type_error e; exit 1 let build (fpath_in : string) (dir_out_spec : string option) (is_verbose : bool) (externals : string list) = catch_error (fun () -> let current_directory = Sys.getcwd () in let abspath_in = make_absolute_path current_directory fpath_in in let external_map = externals |> List.fold_left (fun map s -> match String.split_on_char ':' s with | [pkgname; path_in] -> let absdir = make_absolute_path current_directory path_in in map |> ExternalMap.add pkgname absdir | _ -> raise (InvalidExternalSpec(s)) ) ExternalMap.empty in let (pkgs, absdir_out, absdir_test_out, doc_configs_opt) = let (_, extopt) = Core.Filename.split_extension abspath_in in match extopt with | Some("sest") -> let source = SourceLoader.single abspath_in in let pkgs = [ (None, [], source, []) ] in let absdir_out = match dir_out_spec with | None -> raise (ConfigError(NoOutputSpecForSingleSource)) | Some(dir_out) -> append_dir current_directory (RelativeDir(dir_out)) in (pkgs, absdir_out, absdir_out, None) | Some(ext) -> raise (ConfigError(UnrecognizableExtension(ext))) | _ -> assert (is_existing_directory abspath_in); (* The existence of given directories has been checked by 'cmdliner'. *) let absdir_in = abspath_in in let (pkgconfigs, main_config) = PackageLoader.main external_map absdir_in in let pkgs = pkgconfigs |> List.map (fun (_, config) -> let requires_tests = String.equal config.ConfigLoader.package_name main_config.ConfigLoader.package_name in let pkg = SourceLoader.main ~requires_tests config in (Some(pkg.SourceLoader.space_name), pkg.SourceLoader.aux_modules, pkg.SourceLoader.main_module, pkg.SourceLoader.test_modules) ) in (pkgs, append_dir absdir_in main_config.erlang_config.output_directory, append_dir absdir_in main_config.erlang_config.test_output_directory, Some((absdir_in, main_config.document_outputs))) in (* Typecheck each package. *) let (tyenv, _) = Primitives.initial_environment in let (_, pkgoutsacc) = pkgs |> List.fold_left (fun (tyenv, outsacc) pkg -> let (pkgnameopt, auxmods, mainmod, testmods) = pkg in let (tyenv, auxouts, mainout, testouts) = PackageChecker.main ~is_verbose tyenv ~aux:auxmods ~main:mainmod ~test:testmods in (tyenv, Alist.extend outsacc (pkgnameopt, auxouts, mainout, testouts)) ) (tyenv, Alist.empty) in let spec = { module_name_output_spec = DottedCamels; } in (* Generate and output code corresponding to each package. *) Core.Unix.mkdir_p absdir_out; Core.Unix.mkdir_p absdir_test_out; let (_, gmap) = Primitives.initial_environment in pkgoutsacc |> Alist.to_list |> List.fold_left (fun gmap (pkgnameopt, auxouts, mainout, testouts) -> doc_configs_opt |> Option.map (fun (absdir_in, doc_configs) -> doc_configs |> List.iter (fun doc_config -> let ConfigLoader.Html = doc_config.ConfigLoader.document_output_format in let absdir_doc_out = append_dir absdir_in doc_config.ConfigLoader.document_output_directory in Core.Unix.mkdir_p absdir_doc_out; let abspath_doc_out = match pkgnameopt with | None -> append_path absdir_doc_out (RelativePath("doc.html")) | Some(pkgname) -> let relpath = Printf.sprintf "%s.html" (OutputIdentifier.output_space_to_snake pkgname) in append_path absdir_doc_out (RelativePath(relpath)) in DocumentGenerator.main abspath_doc_out mainout ) ) |> Option.value ~default:(); let outs = List.concat [ auxouts |> List.map (fun out -> (out, false)); [ (mainout, false) ]; testouts |> List.map (fun out -> (out, true)); ] in outs |> List.fold_left (fun gmap (out, is_for_test) -> let sname = out.PackageChecker.space_name in let imod = (out.PackageChecker.attribute, out.PackageChecker.bindings) in let absdir = if is_for_test then absdir_test_out else absdir_out in OutputErlangCode.main spec absdir gmap ~package_name:pkgnameopt ~module_name:sname imod ) gmap ) gmap |> ignore; OutputErlangCode.write_primitive_module absdir_out ) let config (fpath_in : string) = catch_error (fun () -> let absdir_in = let dir = Sys.getcwd () in make_absolute_path dir fpath_in in let absdir_out = absdir_in in let config = PackageLoader.load_config absdir_in in OutputRebarConfig.main absdir_out config ) let flag_output : (string option) Cmdliner.Term.t = let open Cmdliner in let doc = "Specify output path." in Arg.(value (opt (some string) None (info [ "o"; "output" ] ~docv:"OUTPUT" ~doc))) let flag_verbose : bool Cmdliner.Term.t = let open Cmdliner in let doc = "Makes reports more detailed." in Arg.(value (flag (info [ "verbose" ] ~doc))) let flag_packages : (string list) Cmdliner.Term.t = let open Cmdliner in let doc = "Specify paths of external packages." in Arg.(value (opt_all string [] (info [ "p"; "package" ] ~docv:"PACKAGE" ~doc))) let arg_in : string Cmdliner.Term.t = let open Cmdliner in Arg.(required (pos 0 (some file) None (info []))) let command_build = let open Cmdliner in let term : unit Term.t = Term.(const build $ arg_in $ flag_output $ flag_verbose $ flag_packages) in let info : Term.info = Term.info "build" in (term, info) let command_config = let open Cmdliner in let term : unit Term.t = Term.(const config $ arg_in) in let info : Term.info = Term.info "config" in (term, info) let command_main = let open Cmdliner in let term : unit Term.t = Term.(ret (const (`Error(true, "No subcommand specified.")))) in let info : Term.info = Term.info ~version:Constants.semantic_version "sesterl" in (term, info) let () = let open Cmdliner in let subcommands = [ command_build; command_config; ] in Term.(exit (eval_choice command_main subcommands)) ================================================ FILE: src/moduleAttribute.ml ================================================ open MyUtil open Syntax type accumulator = { acc_behaviours : StringSet.t; acc_for_test : bool; } type t = { behaviours : StringSet.t; for_test : bool; } let empty : t = { behaviours = StringSet.empty; for_test = false; } let merge (modattr1 : t) (modattr2 : t) : t = { behaviours = StringSet.union modattr1.behaviours modattr2.behaviours; for_test = modattr1.for_test || modattr2.for_test; } let decode (attrs : attribute list) : t * attribute_warning list = let r = { acc_behaviours = StringSet.empty; acc_for_test = false; } in let (r, warn_acc) = attrs |> List.fold_left (fun (r, warn_acc) attr -> let Attribute((rng, attr_main)) = attr in match attr_main with | ((("behaviour" | "behavior") as tag), utast_opt) -> begin match utast_opt with | Some((_, BaseConst(BinaryByString(s)))) -> let r = { r with acc_behaviours = r.acc_behaviours |> StringSet.add s } in (r, warn_acc) | _ -> let warn = { position = rng; tag = tag; message = "argument should be a string literal"; } in (r, Alist.extend warn_acc warn) end | ("test", utast_opt) -> let warn_acc = match utast_opt with | None -> warn_acc | Some(_) -> let warn = { position = rng; tag = "test"; message = "argument is ignored"; } in Alist.extend warn_acc warn in let r = { r with acc_for_test = true } in (r, warn_acc) | (tag, _) -> let warn = { position = rng; tag = tag; message = "unsupported attribute"; } in (r, Alist.extend warn_acc warn) ) (r, Alist.empty) in let t = { behaviours = r.acc_behaviours; for_test = r.acc_for_test; } in (t, Alist.to_list warn_acc) ================================================ FILE: src/mustBeBoundID.ml ================================================ type t = { main : BoundID.t; name : string; level : int; } let fresh (name : string) (lev : int) : t = let bid = BoundID.fresh () in { main = bid; name = name; level = lev; } let equal (mbbid1 : t) (mbbid2 : t) : bool = BoundID.equal mbbid1.main mbbid2.main let get_level (mbbid : t) : int = mbbid.level let to_bound (mbbid : t) : BoundID.t = mbbid.main let pp_rich (ppf : Format.formatter) (mbbid : t) : unit = Format.fprintf ppf "%s" mbbid.name let pp (ppf : Format.formatter) (mbbid : t) : unit = Format.fprintf ppf "_%aL%d" BoundID.pp mbbid.main mbbid.level ================================================ FILE: src/myUtil.ml ================================================ module StringSet = Set.Make(String) module Alist : sig type 'a t val empty : 'a t val extend : 'a t -> 'a -> 'a t val append : 'a t -> 'a list -> 'a t val length : 'a t -> int val to_list : 'a t -> 'a list val to_rev_list : 'a t -> 'a list val from_list : 'a list -> 'a t val is_empty : 'a t -> bool end = struct type 'a t = 'a list let empty = [] let extend acc x = x :: acc let append acc xs = List.rev_append xs acc let length acc = List.length acc let to_list = List.rev let to_rev_list acc = acc let from_list = List.rev let is_empty acc = match acc with | [] -> true | _ :: _ -> false end module ResultMonad : sig val return : 'a -> ('a, 'e) result val err : 'e -> ('a, 'e) result val map_err : ('e1 -> 'e2) -> ('a, 'e1) result -> ('a, 'e2) result val ( >>= ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result end = struct let return v = Ok(v) let err e = Error(e) let ( >>= ) v f = match v with | Ok(x) -> f x | Error(e) -> Error(e) let map_err f v = match v with | Ok(x) -> Ok(x) | Error(e) -> Error(f e) end module OptionMonad : sig val return : 'a -> 'a option val none : 'a option val ( >>= ) : 'a option -> ('a -> 'b option) -> 'b option end = struct let return x = Some(x) let none = None let ( >>= ) = Option.bind end type absolute_path = string type absolute_dir = string type relative_path = RelativePath of string type relative_dir = RelativeDir of string let make_absolute_path ?canonicalize:(canonicalize = false) (absdir : absolute_dir) (fpath : string) : absolute_path = let f = if canonicalize then Core.Filename.realpath else (fun s -> s) in if Filename.is_relative fpath then f (Filename.concat absdir fpath) else f fpath let append_dir (absdir : absolute_dir) (RelativeDir(reldir) : relative_dir) : absolute_dir = Filename.concat absdir reldir let append_path (absdir : absolute_dir) (RelativePath(relpath) : relative_path) : absolute_path = Filename.concat absdir relpath let canonicalize_path (abspath : absolute_path) : absolute_path option = try Some(Core.Filename.realpath abspath) with | Unix.Unix_error(_) -> None let is_existing_directory (abspath : absolute_path) : bool = let abspath0 = Core.Filename.concat abspath Filename.current_dir_name in try Option.equal String.equal (canonicalize_path abspath) (canonicalize_path abspath0) with | _ -> false module Utf : sig val uchar_of_utf8 : string -> Uchar.t list end = struct let uchar_of_utf8 (s : string) = let decoder = Uutf.decoder ~encoding:`UTF_8 (`String(s)) in let rec iter acc = match Uutf.decode decoder with | `End -> Alist.to_list acc | `Uchar(u) -> iter (Alist.extend acc u) | `Await -> iter acc | `Malformed(_) -> iter (Alist.extend acc Uutf.u_rep) (* Silently replaces malformed sequences with `Uutf.u_rep`. *) in iter Alist.empty end ================================================ FILE: src/outputErlangCode.ml ================================================ open MyUtil open Syntax open Env open IntermediateSyntax let fresh_local_symbol () = OutputIdentifier.output_local (OutputIdentifier.fresh ()) type val_binding_output = | OBindVal of global_name * pattern list * pattern LabelAssoc.t * (pattern * ast option) LabelAssoc.t * name_map * ast | OBindValExternal of global_name * string type module_binding_output = | OBindModule of { basename : string; atom : string; attributes : ModuleAttribute.t; bindings : val_binding_output list; } let traverse_val_single (nmap : name_map) (_, gnamefun, _, ast) : val_binding_output = match ast with | ILambda(None, ipats, mndipatmap, optipatmap, ast0) -> OBindVal(gnamefun, ipats, mndipatmap, optipatmap, nmap, ast0) | _ -> assert false let make_module_string ~(suffix : string) (spec : output_spec) (spacepath : space_name Alist.t) : string * string = let spaces = spacepath |> Alist.to_list in match spec.module_name_output_spec with | SingleSnake -> let s = spaces |> List.map OutputIdentifier.output_space_to_snake |> String.concat "_" in (s, s) | DottedCamels -> let s = spaces |> List.map OutputIdentifier.output_space_to_camel |> String.concat "." in let s = s ^ suffix in (s, Printf.sprintf "'%s'" s) let 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 = let suffix = if modattr.for_test then "_tests" else "" in let (smod_basename, smod_atom) = make_module_string ~suffix spec spacepath in let smap = smap |> SpaceNameMap.add sname smod_atom in (* Associates value identifiers in the current space with `spacepath` beforehand. *) let gmap = ibinds |> List.fold_left (fun gmap ibind -> match ibind with | IBindVal(INonRec(valbind)) -> let (_, gnamefun, _, _) = valbind in gmap |> GlobalNameMap.add gnamefun smod_atom | IBindVal(IRec(valbinds)) -> valbinds |> List.fold_left (fun gmap valbind -> let (_, gnamefun, _, _) = valbind in gmap |> GlobalNameMap.add gnamefun smod_atom ) gmap | IBindVal(IExternal(gnamefun, _)) -> gmap |> GlobalNameMap.add gnamefun smod_atom | IBindModule(_) -> gmap ) gmap in let nmap = (gmap, smap) in (* Traverses all the submodules. *) let (omodbindacc, nmap) = ibinds |> List.fold_left (fun ((omodbindacc, nmap) as original) ibind -> match ibind with | IBindVal(_) -> original | IBindModule(snamesub, attrssub, ibindssub) -> let (omodbindssub, nmap) = let spacepathsub = Alist.extend spacepath snamesub in traverse_binding_list spec snamesub nmap spacepathsub attrssub ibindssub in (Alist.append omodbindacc omodbindssub, nmap) ) (Alist.empty, nmap) in (* Constructs the output module corresponding to the current space (if not empty). *) let omodbindacc = let ovalbinds = ibinds |> List.map (fun ibind -> match ibind with | IBindVal(INonRec(valbind)) -> [ traverse_val_single nmap valbind ] | IBindVal(IRec(valbinds)) -> valbinds |> List.map (traverse_val_single nmap) | IBindVal(IExternal(gname, code)) -> [ OBindValExternal(gname, code) ] | IBindModule(_) -> [] ) |> List.concat in match ovalbinds with | [] -> omodbindacc | _ :: _ -> let omodbind = OBindModule{ basename = smod_basename; atom = smod_atom; attributes = modattr; bindings = ovalbinds; } in Alist.extend omodbindacc omodbind in (Alist.to_list omodbindacc, nmap) let unit_atom = "ok" let stringify_hole = function | HoleC -> "c" | HoleF -> "f" | HoleE -> "e" | HoleG -> "g" | HoleS -> "s" | HoleP -> "p" | HoleW -> "w" let stringify_format_element = function | FormatBreak -> (0, "~n") | FormatTilde -> (0, "~~") | FormatDQuote -> (0, "\\\"") | FormatConst(s) -> (0, s) | FormatHole(hole, control) -> let ch = stringify_hole hole in let s = match (control.field_width, control.precision) with | (Some(n1), Some(n2)) -> Printf.sprintf "%d.%d" n1 n2 | (Some(n1), None) -> Printf.sprintf "%d" n1 | (None, Some(n2)) -> Printf.sprintf ".%d" n2 | (None, None) -> "" in (1, Printf.sprintf "~%s%s" s ch) let escape_character c = match Uchar.to_int c with | 10 -> [ Uchar.of_char '\\'; Uchar.of_char 'n' ] | 13 -> [ Uchar.of_char '\\'; Uchar.of_char 'r' ] | 9 -> [ Uchar.of_char '\\'; Uchar.of_char 't' ] | 92 -> [ Uchar.of_char '\\'; Uchar.of_char '\\' ] | 34 -> [ Uchar.of_char '\\'; Uchar.of_char '"' ] | 39 -> [ Uchar.of_char '\\'; Uchar.of_char '\'' ] | _ -> [c] let escape_string s = let buffer = Buffer.create 0 in s |> MyUtil.Utf.uchar_of_utf8 |> List.map escape_character |> List.flatten |> List.iter (Buffer.add_utf_8_uchar buffer); Buffer.contents buffer let stringify_base_constant (bc : base_constant) = match bc with | Unit -> unit_atom | Bool(true) -> "true" | Bool(false) -> "false" | Int(n) -> string_of_int n | Float(r) -> if Float.is_finite r then string_of_float r ^ "0" (* DOUBTFUL; are all of the string representations made in this way valid as constants in Erlang source? *) else assert false | BinaryByString(s) -> Printf.sprintf "<<\"%s\"/utf8>>" (escape_string s) | BinaryByInts(ns) -> Printf.sprintf "<<%s>>" (ns |> List.map string_of_int |> String.concat ", ") | String(s) -> Printf.sprintf "\"%s\"" (escape_string s) | Char(uchar) -> Printf.sprintf "%d" (Uchar.to_int uchar) | FormatString(fmtelems) -> let pairs = fmtelems |> List.map stringify_format_element in let s = pairs |> List.map (fun (_, s) -> s) |> String.concat "" in let arity = pairs |> List.fold_left (fun arity (n, _) -> arity + n) 0 in Printf.sprintf "{\"%s\", %d}" s arity let get_module_string ((gmap, _) : name_map) (gname : global_name) : string = match gmap |> GlobalNameMap.find_opt gname with | None -> assert false | Some(smod) -> smod let stringify_single (nmap : name_map) = function | OutputIdentifier.Local(lname) -> OutputIdentifier.output_local lname | OutputIdentifier.Global(gname) -> let r = OutputIdentifier.output_global gname in let smod = get_module_string nmap gname in let arity = if r.has_option then r.arity + 1 else r.arity in Printf.sprintf "(fun %s:%s/%d)" smod r.function_name arity (* Use syntax `fun M:F/Arity` for global function names in order to avoid being confused with atoms. Here, arities are incremented in order to conform to labeled optional parameters. *) | OutputIdentifier.Operator(oname) -> let sop = OutputIdentifier.output_operator oname in let s1 = fresh_local_symbol () in let s2 = fresh_local_symbol () in Printf.sprintf "(fun(%s, %s) -> %s %s %s end)" s1 s2 s1 sop s2 let make_mandatory_parameters (ordipats : pattern list) (mndipatmap : pattern LabelAssoc.t) : pattern list = let mndipats = mndipatmap |> LabelAssoc.bindings |> List.map (fun (_, ipat) -> ipat) (* Labeled mandatory parameters are placed in alphabetical order. *) in List.append ordipats mndipats let rec stringify_option_decoding_operation (nmap : name_map) (sname_map : string) (optipatmap : (pattern * ast option) LabelAssoc.t) : string = LabelAssoc.fold (fun label (ipat, default) acc -> let spat = stringify_pattern ipat in let s = match default with | None -> Printf.sprintf "%s = %s:%s(%s, %s), " spat Primitives.primitive_module_name Primitives.decode_option_function sname_map label | Some(ast) -> Printf.sprintf "%s = %s:%s(%s, %s, fun() -> %s end), " spat Primitives.primitive_module_name Primitives.decode_option_function_with_default sname_map label (stringify_ast nmap ast) in Alist.extend acc s ) optipatmap Alist.empty |> Alist.to_list |> String.concat "" and stringify_arguments (nmap : name_map) (mrow : mono_row) (ordastargs : ast list) (mndargmap : ast LabelAssoc.t) (optargmap : ast LabelAssoc.t) = let iter = stringify_ast nmap in let astargs = let mndastargs = mndargmap |> LabelAssoc.bindings |> List.map (fun (_, ast) -> ast) (* Labeled mandatory arguments are placed in alphabetical order. *) in List.append ordastargs mndastargs in let sargs = astargs |> List.map iter in let soptmap = mapify_label_assoc nmap optargmap in let can_take_optional = TypeConv.can_row_take_optional mrow in let no_mandatory_argument = (List.length astargs = 0) in (sargs, soptmap, can_take_optional, no_mandatory_argument) and stringify_ast (nmap : name_map) (ast : ast) = let iter = stringify_ast nmap in match ast with | IVar(name) -> stringify_single nmap name | IBaseConst(bc) -> stringify_base_constant bc | ILambda(recopt, ordipats, mndipatmap, optipatmap, ast0) -> let snames = let ipats = make_mandatory_parameters ordipats mndipatmap in ipats |> List.map stringify_pattern in let s0 = iter ast0 in let srec = match recopt with | None -> "" | Some(namerec) -> " " ^ OutputIdentifier.output_local namerec in if LabelAssoc.cardinal optipatmap = 0 then let sparamscat = snames |> String.concat ", " in Printf.sprintf "fun%s(%s) -> %s end" srec sparamscat s0 else let sparamscatcomma = snames |> List.map (fun s -> s ^ ", ") |> String.concat "" in let sname_map = fresh_local_symbol () in let sgetopts = stringify_option_decoding_operation nmap sname_map optipatmap in Printf.sprintf "fun%s(%s%s) -> %s%s end" srec sparamscatcomma sname_map sgetopts s0 | IApply(name, mrow, ordastargs, mndargmap, optargmap) -> let (sargs, soptmap, can_take_optional, no_mandatory_argument) = stringify_arguments nmap mrow ordastargs mndargmap optargmap in begin match (name, sargs) with | (OutputIdentifier.Local(lname), _) -> let sname = OutputIdentifier.output_local lname in let sargscat = String.concat ", " sargs in if can_take_optional then if no_mandatory_argument then Printf.sprintf "%s(#{%s})" sname soptmap else Printf.sprintf "%s(%s, #{%s})" sname sargscat soptmap else Printf.sprintf "%s(%s)" sname sargscat | (OutputIdentifier.Global(gname), _) -> let r = OutputIdentifier.output_global gname in let smod = get_module_string nmap gname in let sfun = r.function_name in let sopts = if LabelAssoc.cardinal optargmap = 0 then "" (* When no optional argument is given, we do not output the empty map for it. In response to this, functions defined with optional parameters are compiled into two variants; one has its innate arity, and the other can receive a map for optional arguments via an additional argument. *) else if no_mandatory_argument then Printf.sprintf "#{%s}" soptmap else Printf.sprintf ", #{%s}" soptmap in Printf.sprintf "%s:%s(%s%s)" smod sfun (String.concat ", " sargs) sopts | (OutputIdentifier.Operator(op), [sarg1; sarg2]) -> let sop = OutputIdentifier.output_operator op in Printf.sprintf "(%s %s %s)" sarg1 sop sarg2 | _ -> assert false end | IFreeze(gname, astargs) -> let sargs = List.map iter astargs in let r = OutputIdentifier.output_global gname in let smod = get_module_string nmap gname in let sfun = r.function_name in Printf.sprintf "{%s, %s, [%s]}" smod sfun (String.concat ", " sargs) | IFreezeUpdate(ast0, astargs) -> let s0 = iter ast0 in let sargs = List.map iter astargs in let varM = fresh_local_symbol () in let varF = fresh_local_symbol () in let varArgs = fresh_local_symbol () in Printf.sprintf "begin {%s, %s, %s} = %s, {%s, %s, %s ++ [%s]} end" varM varF varArgs s0 varM varF varArgs (String.concat ", " sargs) | IRecord(emap) -> let s = mapify_label_assoc nmap emap in Printf.sprintf "#{%s}" s | IRecordAccess(ast1, label) -> let s1 = iter ast1 in Printf.sprintf "maps:get(%s, %s)" label s1 | IRecordUpdate(ast1, label, ast2) -> let s1 = iter ast1 in let s2 = iter ast2 in Printf.sprintf "maps:put(%s, %s, %s)" label s2 s1 | ILetIn(lname, ast1, ast2) -> let s0 = OutputIdentifier.output_local lname in let s1 = iter ast1 in let s2 = iter ast2 in Printf.sprintf "begin %s = %s, %s end" s0 s1 s2 | ICase(ast1, [ IBranch(ipat, ast2) ]) -> (* -- slight optimization of case-expressions into pattern-matching let-expressions -- *) let spat = stringify_pattern ipat in let s1 = iter ast1 in let s2 = iter ast2 in Printf.sprintf "begin %s = %s, %s end" spat s1 s2 | ICase(ast0, branches) -> let s0 = iter ast0 in let sbrs = branches |> List.map (stringify_case_branch nmap) in Printf.sprintf "case %s of %s end" s0 (String.concat "; " sbrs) | IReceive(branches, iafter_opt) -> let sbrs = branches |> List.map (stringify_receive_branch nmap) |> String.concat "; " in begin match iafter_opt with | None -> Printf.sprintf "receive %s end" sbrs | Some((ast1, ast2)) -> let sv = fresh_local_symbol () in let s1 = iter ast1 in let s2 = iter ast2 in Printf.sprintf "begin %s = %s, receive %s after %s -> %s end end" sv s1 sbrs sv s2 end | ITuple(es) -> let ss = es |> TupleList.to_list |> List.map iter in Printf.sprintf "{%s}" (String.concat ", " ss) | IListNil -> "[]" | IListCons(e1, e2) -> let s1 = iter e1 in let s2 = iter e2 in Printf.sprintf "[%s | %s]" s1 s2 | IConstructor(ctorid, es) -> let sctor = ConstructorID.output ctorid in begin match es with | [] -> sctor | _ :: _ -> let ss = es |> List.map iter in Printf.sprintf "{%s, %s}" sctor (String.concat ", " ss) end | IPack(sname) -> let (_, smap) = nmap in begin match smap |> SpaceNameMap.find_opt sname with | None -> assert false | Some(smod) -> smod end | IAssert(rng, e0) -> let s0 = iter e0 in let var = fresh_local_symbol () in Printf.sprintf "begin %s = %s, %s(<<\"%s\">>, %d) end" var s0 var (Range.get_file_name rng) (Range.get_start_line rng) and mapify_label_assoc (nmap : name_map) (emap : ast LabelAssoc.t) = LabelAssoc.fold (fun label ast acc -> let sarg = stringify_ast nmap ast in let s = Printf.sprintf "%s => %s" label sarg in Alist.extend acc s ) emap Alist.empty |> Alist.to_list |> String.concat ", " and stringify_case_branch (nmap : name_map) (br : branch) = match br with | IBranch(pat, ast1) -> let spat = stringify_pattern pat in let s1 = stringify_ast nmap ast1 in Printf.sprintf "%s -> %s" spat s1 and stringify_receive_branch (nmap : name_map) (br : branch) = match br with | IBranch(pat, ast1) -> let spat = stringify_pattern pat in let s1 = stringify_ast nmap ast1 in Printf.sprintf "{%s, %s} -> %s" Constants.message_tag_atom spat s1 and stringify_pattern (ipat : pattern) = match ipat with | IPUnit -> unit_atom | IPBool(true) -> "true" | IPBool(false) -> "false" | IPInt(n) -> string_of_int n | IPBinary(s) -> Printf.sprintf "<<\"%s\"/utf8>>" (escape_string s) | IPChar(uchar) -> string_of_int (Uchar.to_int uchar) | IPVar(lname) -> OutputIdentifier.output_local lname | IPWildCard -> "_" | IPListNil -> "[]" | IPListCons(ipat1, ipat2) -> let s1 = stringify_pattern ipat1 in let s2 = stringify_pattern ipat2 in Printf.sprintf "[%s | %s]" s1 s2 | IPTuple(ipats) -> let ss = ipats |> TupleList.to_list |> List.map stringify_pattern in Printf.sprintf "{%s}" (String.concat ", " ss) | IPConstructor(ctorid, ipats) -> let atom = ConstructorID.output ctorid in begin match ipats with | [] -> atom | _ :: _ -> let ss = ipats |> List.map stringify_pattern in Printf.sprintf "{%s, %s}" atom (String.concat ", " ss) end let stringify_val_binding_output : val_binding_output -> string list = function | OBindVal(gnamefun, ordlnames, mndnamemap, optnamemap, gmap, ast0) -> let r = OutputIdentifier.output_global gnamefun in let sparams = let ipats = make_mandatory_parameters ordlnames mndnamemap in ipats |> List.map stringify_pattern in let sparamscat = String.concat ", " sparams in let sparamscatcomma = sparams |> List.map (fun s -> s ^ ", ") |> String.concat "" in let sname_map = fresh_local_symbol () in let sgetopts = stringify_option_decoding_operation gmap sname_map optnamemap in let s0 = stringify_ast gmap ast0 in if r.has_option then let s_without_option = Printf.sprintf "%s(%s) -> ?MODULE:%s(%s#{})." r.function_name sparamscat r.function_name sparamscatcomma in let s_with_option = Printf.sprintf "%s(%s%s) -> %s%s." r.function_name sparamscatcomma sname_map sgetopts s0 in [ s_without_option; s_with_option ] else let s = Printf.sprintf "%s(%s) -> %s." r.function_name sparamscat s0 in [ s ] | OBindValExternal(_, code) -> [code] let stringify_module_binding_output (omodbind : module_binding_output) : string * string list = match omodbind with | OBindModule{ basename = smod_basename; atom = smod_atom; attributes = modattr; bindings = ovalbinds; } -> let exports = ovalbinds |> List.map (function | OBindVal(gnamefun, _, _, _, _, _) | OBindValExternal(gnamefun, _) -> let r = OutputIdentifier.output_global gnamefun in if r.has_option then [ Printf.sprintf "%s/%d" r.function_name r.arity; Printf.sprintf "%s/%d" r.function_name (r.arity + 1); ] else [ Printf.sprintf "%s/%d" r.function_name r.arity; ] ) |> List.concat in let ss = ovalbinds |> List.map stringify_val_binding_output |> List.concat in let lines = List.concat [ [ Printf.sprintf "-module(%s)." smod_atom ]; modattr.behaviours |> StringSet.elements |> List.map (fun s -> Printf.sprintf "-behaviour(%s)." s); [ Printf.sprintf "-export([%s])." (String.concat ", " exports) ]; ss; ] in (smod_basename, lines) let write_file (absdir_out : absolute_dir) (smod_basename : string) (lines : string list) : unit = let abspath_out = Core.Filename.concat absdir_out (Printf.sprintf "%s.erl" smod_basename) in let fout = open_out abspath_out in lines |> List.iter (fun line -> output_string fout line; output_string fout "\n" ); close_out fout; Logging.output_written abspath_out let write_module_to_file (absdir_out : absolute_dir) (omodbind : module_binding_output) : unit = let (smod_basename, lines) = stringify_module_binding_output omodbind in write_file absdir_out smod_basename lines let write_primitive_module (dir_out : string) : unit = let smod = Primitives.primitive_module_name in let primdefs = Primitives.primitive_definitions in let exports = primdefs |> List.map (fun primdef -> let open Primitives in let targetdef = primdef.target in let arity = List.length targetdef.parameters in Printf.sprintf "%s/%d" targetdef.target_name arity ) in let lines = List.concat [ [ Printf.sprintf "-module(%s)." smod; Printf.sprintf "-export([%s])." (String.concat ", " exports); ]; primdefs |> List.map (fun primdef -> let open Primitives in let targetdef = primdef.target in Printf.sprintf "%s(%s) -> %s." targetdef.target_name (String.concat ", " targetdef.parameters) targetdef.code ); ] in write_file dir_out smod lines let 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 = (* Format.printf "OutputErlangCode | package: %a, module: %a\n" OutputIdentifier.pp_space pkgname OutputIdentifier.pp_space sname; (* for debug *) *) let (omodbinds, nmap_after) = let spacepath = match pkgnameopt with | Some(pkgname) -> Alist.extend (Alist.extend Alist.empty pkgname) sname | None -> Alist.extend Alist.empty sname in traverse_binding_list spec sname nmap spacepath modattr ibinds in omodbinds |> List.iter (fun omodbind -> write_module_to_file absdir_out omodbind ); nmap_after ================================================ FILE: src/outputErlangCode.mli ================================================ open MyUtil open Syntax open IntermediateSyntax val main : output_spec -> string -> name_map -> package_name:(space_name option) -> module_name:space_name -> ModuleAttribute.t * binding list -> name_map (** [main spec dir_out nmap ~package_name:pkgopt ~module_name:sname binds] produces Erlang source files corresponding to [binds] in the directory [dir_out]. The name of the resulting module is determined by [pkgopt] and [sname]. The path [dir_out] can be either relative or absolute, and the directory specified by the path must be guaranteed existent beforehand. *) val write_primitive_module : absolute_dir -> unit ================================================ FILE: src/outputIdentifier.ml ================================================ type space = | ReprSpace of { number : int; main : IdentifierScheme.t; } type local = | ReprLocal of { number : int; hint : IdentifierScheme.t option; } | ReprUnused type global = | ReprGlobal of { number : int; function_name : IdentifierScheme.t; suffix : string; arity : int; has_option : bool; } | ReprDummy of { number : int; } type operator = | ReprOperator of string type t = | Local of local | Global of global | Operator of operator type global_answer = { function_name : string; arity : int; has_option : bool; } let fresh_number : unit -> int = let current_max = ref 0 in (fun () -> incr current_max; !current_max ) let space_of_module_name (s : string) : space option = let n = fresh_number () in IdentifierScheme.from_upper_camel_case s |> Option.map (fun space -> ReprSpace{ number = n; main = space; } ) let space_of_package_name (s : string) : space option = let n = fresh_number () in IdentifierScheme.from_snake_case s |> Option.map (fun space -> ReprSpace{ number = n; main = space; } ) let fresh () : local = let n = fresh_number () in ReprLocal{ hint = None; number = n } let fresh_global_dummy () : global = let n = fresh_number () in ReprDummy{ number = n; } let generate_local (s : string) : local option = IdentifierScheme.from_snake_case s |> Option.map (fun ident -> let n = fresh_number () in ReprLocal{ hint = Some(ident); number = n } ) let generate_global (s : string) ~(suffix : string) ~(arity : int) ~(has_option : bool) : global option = IdentifierScheme.from_snake_case s |> Option.map (fun ident -> let n = fresh_number () in ReprGlobal{ number = n; function_name = ident; suffix = suffix; arity = arity; has_option = has_option; } ) let operator (s : string) : operator = ReprOperator(s) let unused : local = ReprUnused module Space = struct type t = space let compare (ReprSpace(sname1)) (ReprSpace(sname2)) = Int.compare sname2.number sname1.number end module Local = struct type t = local let compare lname1 lname2 = match (lname1, lname2) with | (ReprUnused, ReprUnused) -> 0 | (ReprUnused, _) -> -1 | (_, ReprUnused) -> 1 | (ReprLocal(r1), ReprLocal(r2)) -> r2.number - r1.number end module Global = struct type t = global let compare gname1 gname2 = let extract_number = function | ReprDummy(r) -> r.number | ReprGlobal(r) -> r.number in extract_number gname2 - extract_number gname1 end let output_space_to_snake (ReprSpace(sname) : space) = IdentifierScheme.to_snake_case sname.main let output_space_to_camel (ReprSpace(sname) : space) = IdentifierScheme.to_upper_camel_case sname.main let output_local = function | ReprLocal(r) -> let hint = match r.hint with | None -> "" | Some(ident) -> IdentifierScheme.to_upper_camel_case ident in Printf.sprintf "S%d%s" r.number hint | ReprUnused -> "_" let output_global = function | ReprGlobal(r) -> { function_name = Printf.sprintf "'%s%s'" (r.function_name |> IdentifierScheme.to_snake_case) r.suffix; arity = r.arity; has_option = r.has_option; } | ReprDummy(r) -> (* Format.printf "attempted to output G%d(dummy)\n" r.number; (* for debug *) *) assert false let output_operator = function | ReprOperator(s) -> s let pp_space ppf (ReprSpace(sname) : space) = Format.fprintf ppf "%a" IdentifierScheme.pp sname.main let pp_local ppf = function | ReprLocal(r) -> begin match r.hint with | None -> Format.fprintf ppf "L%d" r.number | Some(ident) -> Format.fprintf ppf "L%d%a" r.number IdentifierScheme.pp ident end | ReprUnused -> Format.fprintf ppf "UNUSED" let pp_global ppf = function | ReprGlobal(r) -> Format.fprintf ppf "G%d%a/%d" r.number IdentifierScheme.pp r.function_name r.arity | ReprDummy(r) -> Format.fprintf ppf "G%d(dummy)" r.number let pp_operator ppf = function | ReprOperator(s) -> Format.fprintf ppf "O\"%s\"" s let pp ppf = function | Local(l) -> pp_local ppf l | Global(g) -> pp_global ppf g | Operator(o) -> pp_operator ppf o ================================================ FILE: src/outputIdentifier.mli ================================================ type space (** The type for abstracting module names in outputs. *) type local type global type operator type t = | Local of local | Global of global | Operator of operator type global_answer = { function_name : string; arity : int; has_option : bool; } val space_of_module_name : string -> space option val space_of_package_name : string -> space option val fresh : unit -> local val fresh_global_dummy : unit -> global val generate_local : string -> local option val generate_global : string -> suffix:string -> arity:int -> has_option:bool -> global option val operator : string -> operator val unused : local module Space : sig type t = space val compare : t -> t -> int end module Local : sig type t = local val compare : t -> t -> int end module Global : sig type t = global val compare : t -> t -> int end val output_space_to_snake : space -> string val output_space_to_camel : space -> string val output_local : local -> string val output_global : global -> global_answer val output_operator : operator -> string val pp_space : Format.formatter -> space -> unit val pp_local : Format.formatter -> local -> unit val pp_global : Format.formatter -> global -> unit val pp_operator : Format.formatter -> operator -> unit val pp : Format.formatter -> t -> unit ================================================ FILE: src/outputRebarConfig.ml ================================================ open MyUtil type value = | Int of int | String of string | Atom of string | Bool of bool | List of value list | Keyed of string * value list | Assoc of assoc and assoc = (string * value) list let rec stringify_value = function | Int(n) -> string_of_int n | String(s) -> Printf.sprintf "\"%s\"" (String.escaped s) | Atom(s) -> s | Bool(true) -> "true" | Bool(false) -> "false" | List(vs) -> let s = vs |> List.map stringify_value |> String.concat ", " in Printf.sprintf "[%s]" s | Keyed(key, vs) -> let ss = vs |> List.map stringify_value in Printf.sprintf "{%s}" (String.concat ", " (key :: ss)) | Assoc(assoc) -> let ss = assoc |> List.map (fun (key, v) -> Printf.sprintf "{%s, %s}" key (stringify_value v) ) in Printf.sprintf "[%s]" (String.concat "," ss) let ( ==> ) (key : string) (v : value) = (key, v) let keyed (key : string) (vs : value list) = Keyed(key, vs) let relative_dir_to_string (RelativeDir(s) : relative_dir) : value = String(s) let make_git_spec (git_spec : ConfigLoader.git_spec) = match git_spec with | Tag(s) -> keyed "tag" [ String(s) ] | Ref(s) -> keyed "ref" [ String(s) ] | Branch(s) -> keyed "branch" [ String(s) ] let make (config : ConfigLoader.config) : assoc = let entry_plugins = let v_git_spec = keyed "branch" [ String "master" ] in "plugins" ==> Assoc[ Constants.plugin_name ==> keyed "git" [ String(Constants.plugin_url); v_git_spec ] ] in let reldir_out = config.erlang_config.output_directory in let reldir_test_out = config.erlang_config.test_output_directory in let entry_src_dirs = let reldirs = (reldir_out :: config.source_directories) in "src_dirs" ==> List(reldirs |> List.map relative_dir_to_string) in let entry_eunit_tests = let reldirs = (reldir_test_out :: config.test_directories) in "eunit_tests" ==> List(reldirs |> List.map (fun reldir -> Keyed("dir", [ relative_dir_to_string reldir ]))) in let entry_deps = let deps_sesterl = config.dependencies |> List.fold_left (fun acc dep -> let name = dep.ConfigLoader.dependency_name in match dep.ConfigLoader.dependency_source with | Local(_) -> acc | Git{ repository = uri; git_spec = git_spec } -> let v_git_spec = make_git_spec git_spec in let v_dep = keyed "git" [ String(uri); v_git_spec ] in Alist.extend acc (name, v_dep) ) Alist.empty |> Alist.to_list in let deps_erlang = config.erlang_config.erlang_dependencies |> List.map (fun erldep -> let name = erldep.ConfigLoader.erlang_library_name in let v_dep = match erldep.ConfigLoader.erlang_library_source with | ErlangLibFromHex{ version = version } -> String(version) | ErlangLibFromGit{ repository = uri; git_spec = git_spec } -> let v_git_spec = make_git_spec git_spec in keyed "git" [ String(uri); v_git_spec ] in (name, v_dep) ) in "deps" ==> Assoc(List.append deps_sesterl deps_erlang) in let entry_profile = let test_deps_sesterl = config.ConfigLoader.test_dependencies |> List.fold_left (fun acc dep -> let name = dep.ConfigLoader.dependency_name in match dep.ConfigLoader.dependency_source with | Local(_) -> acc | Git{ repository = uri; git_spec = git_spec } -> let v_git_spec = make_git_spec git_spec in let v_dep = keyed "git" [ String(uri); v_git_spec ] in Alist.extend acc (name, v_dep) ) Alist.empty |> Alist.to_list in "profiles" ==> Assoc[ "test" ==> Assoc[ "deps" ==> Assoc(test_deps_sesterl) ] ] in let entries_relx = let open ConfigLoader in match config.erlang_config.relx with | None -> [] | Some(relx) -> let release = relx.relx_release in let entry = "relx" ==> List[ Keyed("release", [ Keyed(release.relx_name, [ String(release.relx_version) ]); List( release.relx_applications |> List.map (fun app -> Atom(app)) ); ]); Keyed("dev_mode", [ Bool(relx.relx_dev_mode) ]) ] in [ entry ] in let entry_sesterl_opts = "sesterl_opts" ==> Assoc[ "output_dir" ==> relative_dir_to_string reldir_out; "test_output_dir" ==> relative_dir_to_string reldir_test_out; ] in List.concat [ [ entry_plugins; entry_src_dirs; entry_deps; entry_profile; entry_eunit_tests; ]; entries_relx; [ entry_sesterl_opts; ]; ] let main (absdir_out : absolute_dir) (config : ConfigLoader.config) = let top_assoc = make config in let s = top_assoc |> List.map (fun (key, v) -> Printf.sprintf "{%s, %s}.\n" key (stringify_value v) ) |> String.concat "" in let fpath_out = Filename.concat absdir_out "rebar.config" in let fout = open_out fpath_out in output_string fout s; close_out fout; Logging.output_written fpath_out ================================================ FILE: src/packageChecker.ml ================================================ open MyUtil open Syntax open IntermediateSyntax open Env open Errors module SigRecordMap = Map.Make(String) type sig_record_map = ((signature_source * SigRecord.t) abstracted * space_name) SigRecordMap.t type single_output = { module_name : module_name; signature : (signature_source * SigRecord.t) abstracted; space_name : space_name; attribute : ModuleAttribute.t; bindings : binding list; } let 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 = let abspath = source.SourceLoader.source_path in let modident = source.SourceLoader.module_identifier in let utsigopt = source.SourceLoader.signature in let utmod = source.SourceLoader.module_content in let deps = source.SourceLoader.dependencies in Logging.begin_to_typecheck abspath; let tyenv_for_mod = deps |> List.fold_left (fun tyenv (rng, depmodnm) -> match sigrmap |> SigRecordMap.find_opt depmodnm with | None -> assert false | Some(((_, (isig, sigr)), sname)) -> let mentry = { mod_signature = (isig, ConcStructure(sigr)); mod_name = sname; mod_doc = None; } in tyenv |> Typeenv.add_module depmodnm mentry ) tyenv_before in let (_, modnm) = modident in let absmodsigopt = let tyenv_for_sig = if is_main_module then tyenv_before else tyenv_for_mod in let address = Address.root |> Address.append_member modnm in utsigopt |> Option.map (Typechecker.typecheck_signature ~address tyenv_for_sig) in let (_, abssigr, sname, (modattr, ibinds)) = Typechecker.main tyenv_for_mod modident absmodsigopt utmod in let out = { module_name = modnm; signature = abssigr; space_name = sname; attribute = modattr; bindings = ibinds; } in (abssigr, out) let 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 = let (sigrmap, auxoutacc) = auxmods |> List.fold_left (fun (sigrmap, auxoutacc) auxmod -> let (abssigr, auxout) = check_single ~is_verbose ~is_main_module:false sigrmap tyenv_before auxmod in let sigrmap = let (_, modnm) = auxmod.SourceLoader.module_identifier in let sname = auxout.space_name in sigrmap |> SigRecordMap.add modnm (abssigr, sname) in let auxoutacc = Alist.extend auxoutacc auxout in (sigrmap, auxoutacc) ) (SigRecordMap.empty, Alist.empty) in let (abssigr_main, mainout) = check_single ~is_verbose ~is_main_module:true sigrmap tyenv_before mainmod in let sigrmap = let (_, modnm_main) = mainmod.SourceLoader.module_identifier in let sname_main = mainout.space_name in sigrmap |> SigRecordMap.add modnm_main (abssigr_main, sname_main) in let (_sigrmap, testoutacc) = testmods |> List.fold_left (fun (sigrmap, testoutacc) testmod -> let (abssigr, testout) = check_single ~is_verbose ~is_main_module:false sigrmap tyenv_before testmod in let sname = testout.space_name in let sigrmap = let (_, modnm) = testmod.SourceLoader.module_identifier in sigrmap |> SigRecordMap.add modnm (abssigr, sname) in let testoutacc = Alist.extend testoutacc testout in (sigrmap, testoutacc) ) (sigrmap, Alist.empty) in let tyenv = let (_, mainmod) = mainmod.SourceLoader.module_identifier in let mainsname = mainout.space_name in let (_, (mainisig, mainsigr)) = abssigr_main in let mentry = { mod_signature = (mainisig, ConcStructure(mainsigr)); mod_name = mainsname; mod_doc = None; } in tyenv_before |> Typeenv.add_module mainmod mentry in let auxouts = Alist.to_list auxoutacc in let testouts = Alist.to_list testoutacc in (tyenv, auxouts, mainout, testouts) ================================================ FILE: src/packageLoader.ml ================================================ open MyUtil open Syntax open Errors exception PackageError of package_error let load_config absdir_in = let abspath_in = Core.Filename.concat absdir_in Constants.config_file_name in let config = match ConfigLoader.load abspath_in with | Ok(config) -> config | Error(e) -> raise (ConfigError(e)) in match config.ConfigLoader.language_version with | None -> config | Some(language_version) -> if LanguageVersion.is_supported language_version then config else raise (ConfigError(UnsupportedLanguageVersion(language_version))) module PackageDirMap = Map.Make(String) module PackageNameMap = Map.Make(String) type reading_state = { loaded_dirs : ConfigLoader.config PackageDirMap.t; loaded_names : absolute_dir PackageNameMap.t; graph : FileDependencyGraph.t; } let main (external_map : external_map) (absdir : absolute_dir) : ((absolute_dir * ConfigLoader.config) list * ConfigLoader.config) = let rec aux ~(requires_test_deps : bool) (state : reading_state) (vertex : FileDependencyGraph.vertex) (absdir : absolute_dir) : ConfigLoader.config * reading_state = let config = load_config absdir in let pkgname = config.ConfigLoader.package_name in match state.loaded_names |> PackageNameMap.find_opt pkgname with | Some(absdir0) -> raise (PackageError(DuplicatedPackageName(pkgname, absdir0, absdir))) | None -> let loaded_dirs = state.loaded_dirs |> PackageDirMap.add absdir config in let loaded_names = state.loaded_names |> PackageNameMap.add pkgname absdir in let state = { state with loaded_dirs = loaded_dirs; loaded_names = loaded_names } in let state = let deps = if requires_test_deps then List.append config.ConfigLoader.dependencies config.ConfigLoader.test_dependencies else config.ConfigLoader.dependencies in deps |> List.fold_left (fun state dependency -> let graph = state.graph in let pkgname_sub = dependency.ConfigLoader.dependency_name in let absdir_sub = match dependency.ConfigLoader.dependency_source with | ConfigLoader.Local(absdir_sub) -> absdir_sub | ConfigLoader.Git(_git_spec) -> begin match external_map |> ExternalMap.find_opt pkgname_sub with | None -> raise (PackageError(NotFoundInExternalMap(pkgname_sub, external_map))) | Some(absdir_sub) -> absdir_sub end in let absdir_sub = match canonicalize_path absdir_sub with | None -> raise (PackageError(PackageDirNotFound(absdir_sub))) | Some(absdir) -> absdir in match graph |> FileDependencyGraph.find_vertex absdir_sub with | Some(vertex_sub) -> (* If the depended source file has already been parsed *) let graph = graph |> FileDependencyGraph.add_edge ~depending:vertex ~depended:vertex_sub in { state with graph = graph } | None -> (* If the depended source file has not been parsed yet *) let (graph, vertex_sub) = graph |> FileDependencyGraph.add_vertex absdir_sub in let graph = graph |> FileDependencyGraph.add_edge ~depending:vertex ~depended:vertex_sub in let (_, state) = aux ~requires_test_deps:false { state with graph = graph } vertex_sub absdir_sub in state ) state in (config, state) in let (config, state) = let (graph, vertex) = FileDependencyGraph.empty |> FileDependencyGraph.add_vertex absdir in let state = { graph = graph; loaded_dirs = PackageDirMap.empty; loaded_names = PackageNameMap.empty; } in aux ~requires_test_deps:true state vertex absdir in match FileDependencyGraph.topological_sort state.graph with | Error(cycle) -> raise (ConfigError(CyclicFileDependencyFound(cycle))) | Ok(absdirs) -> let pkgconfigs = absdirs |> List.map (fun absdir -> match state.loaded_dirs |> PackageDirMap.find_opt absdir with | None -> assert false | Some(config) -> (absdir, config) ) in (pkgconfigs, config) ================================================ FILE: src/packageLoader.mli ================================================ open MyUtil open Syntax open Errors exception PackageError of package_error val load_config : absolute_dir -> ConfigLoader.config (** [load_config absdir] loads the configuration file placed in [absdir]. May raise [ConfigError(_)] for invalid data. Note that paths contained in return values of this function have not been guaranteed existent. *) val main : external_map -> absolute_dir -> (absolute_dir * ConfigLoader.config) list * ConfigLoader.config (** [main absdir] lists up the package placed in [absdir] and all the packages on which the package depends either directly or indirectly, and sorts them in a topological order according to the dependency among them. May raise [ConfigError(_)] or [PackageError(_)]. *) ================================================ FILE: src/parser.mly ================================================ %{ open Syntax open MyUtil type 'a range_spec = | Token of Range.t | Ranged of (Range.t * 'a) let make_range rs1 rs2 = let aux = function | Token(rng) -> rng | Ranged((rng, _)) -> rng in let rng1 = aux rs1 in let rng2 = aux rs2 in Range.unite rng1 rng2 let chop_last modchain = let (uident, uidents) = modchain in let (tokL, _) = uident in let (modidents, ctor) = match List.rev (uident :: uidents) with | [] -> assert false | ctor :: revmodidents -> (List.rev revmodidents, ctor) in (tokL, modidents, ctor) let fold_module_chain modchainraw = let (modident, projs) = modchainraw in let utmod = let (rng, modnm) = modident in (rng, ModVar(modnm)) in projs |> List.fold_left (fun utmod proj -> let rng = make_range (Ranged(utmod)) (Ranged(proj)) in (rng, ModProjMod(utmod, proj)) ) utmod let make_list_pattern pats = List.fold_right (fun pat patacc -> (Range.dummy "pattern-cons", PListCons(pat, patacc))) pats (Range.dummy "pattern-nil", PListNil) let binary e1 op e2 = let rng = make_range (Ranged(e1)) (Ranged(e2)) in let (rngop, _) = op in (rng, Apply((rngop, Var([], op)), ([e1; e2], [], []))) (* let syntax_sugar_module_application : Range.t -> untyped_module -> untyped_module -> untyped_module = let fresh = let r = ref 0 in (fun () -> incr r; Printf.sprintf "SesterlInternalModule%d" !r) in (* TODO: sophisticate how to generate dummy module identifiers *) fun rng utmod1 utmod2 -> let modident1 = (Range.dummy "appident1", fresh ()) in let modident2 = (Range.dummy "appident2", fresh ()) in let modidentA = (Range.dummy "appidentA", fresh ()) in let utbinds = [ (Range.dummy "appbind1", BindModule(modident1, utmod1)); (Range.dummy "appbind2", BindModule(modident2, utmod2)); (Range.dummy "appbindA", BindModule(modidentA, (Range.dummy "appA", ModApply(modident1, modident2)))); ] in (rng, ModProjMod((Range.dummy "appB", ModBinds(utbinds)), modidentA)) *) let base_kind_o = (Range.dummy "base_kind_o", MKindName("o")) (* TODO: fix such an ad-hoc insertion of kinds *) let decl_type_transparent (attrs : attribute list) (tokL : Range.t) (tybinds : type_binding list) : untyped_declaration = let rng = Range.dummy "decl_type_transparent" in (* TODO: give appropriate code ranges *) let dr = Range.dummy "decl_type_transparent" in let decls : untyped_declaration list = tybinds |> List.map (fun (tyident, tyvars, syn_or_vnt) -> let mnbkddoms = tyvars |> List.map (function | (_, None) -> base_kind_o | (_, Some(mnbkd)) -> mnbkd ) in let mnkd = (dr, MKind(mnbkddoms, base_kind_o)) in (dr, DeclTypeOpaque(tyident, Some(mnkd), attrs)) ) in (rng, DeclInclude((dr, SigWith((dr, SigDecls([], decls)), [], tybinds)))) %} %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 %token LPAREN RPAREN LSQUARE RSQUARE LBRACE RBRACE ATTRIBUTE %token DEFEQ COMMA ARROW REVARROW BAR UNDERSCORE CONS COLON COERCE %token GT_SPACES GT_NOSPACE LTLT LT_EXACT %token LOWER DOTLOWER UPPER DOTUPPER TYPARAM ROWPARAM MNDLABEL OPTLABEL %token BINOP_TIMES BINOP_DIVIDES BINOP_PLUS BINOP_MINUS BINOP_AMP BINOP_BAR BINOP_EQ BINOP_LT BINOP_GT %token INT %token FLOAT %token BINARY STRING STRING_BLOCK %token FORMAT %token CHAR %token EOI %start main %type bindtop %type<(Syntax.module_name Syntax.ranged) list * Syntax.module_name Syntax.ranged * Syntax.untyped_signature option * Syntax.untyped_module> main %type ty %type params %type labparams %type optparams %type args %type labargs %type optargs %type tydoms %type labtydoms %type opttydoms %type<(Range.t * Syntax.label) list> labels %type typarams %type<((Range.t * Syntax.row_variable_name) * (Range.t * Syntax.label) list) list> rowparams %type bindvalsingle %type bindvaltop %type bindvallocal %type bindtypesingle %type modexprbot %type decl %% main: | deps=list(dep); bindmod=bindmod; EOI { let (_, modident, utsigopt, utmod) = bindmod in (deps, modident, utsigopt, utmod) } ; dep: | IMPORT; modident=UPPER { modident } ; ident: | ident=LOWER { ident } ; bindtop: | TYPE; tybind=bindtypesingle; tybinds=list(bindtypesub) { let rng = Range.dummy "bindtop-1" in (* TODO: give appropriate code range *) (rng, BindType(tybind :: tybinds)) } | attrs=list(attr); bindval=bindvaltop { let rng = Range.dummy "bindtop-1" in (* TODO: give appropriate code range *) let (_, valbinding) = bindval in (rng, BindVal(attrs, valbinding)) } | bindmod=bindmod { let (rng, modident, utsigopt, utmod) = bindmod in (rng, BindModule(modident, utsigopt, utmod)) } | tokL=SIGNATURE; sigident=UPPER; DEFEQ; utsig=sigexpr { let rng = make_range (Token(tokL)) (Ranged(utsig)) in (rng, BindSig(sigident, utsig)) } | tokL=INCLUDE; utmod=modexpr { let rng = make_range (Token(tokL)) (Ranged(utmod)) in (rng, BindInclude(utmod)) } ; bindmod: | tokL=MODULE; modident=UPPER; utsigopt=option(coercion); DEFEQ; utmod=modexpr { let rng = make_range (Token(tokL)) (Ranged(utmod)) in (rng, modident, utsigopt, utmod) } ; coercion: | COERCE; utsig=sigexpr { utsig } ; bindtypesingle: | ident=LOWER; tyrowparams=typarams; DEFEQ; ctorbrs=ctorbranches { let (typarams, _) = tyrowparams in (* TODO: restrict that the second entry is `[]` *) (ident, typarams, BindVariant(ctorbrs)) } | ident=LOWER; tyrowparams=typarams; DEFEQ; mty=ty { let (typarams, _) = tyrowparams in (* TODO: restrict that the second entry is `[]` *) (ident, typarams, BindSynonym(mty)) } ; bindtypesub: | AND; tybind=bindtypesingle { tybind } ; typarams: | { ([], []) } | tylparen; typarams=typaramssub tyrparen { typarams } ; typaramssub: | rowparams=rowparams { ([], rowparams) } | typaram=TYPARAM { ([ (typaram, None) ], []) } | typaram=TYPARAM; CONS; mnbkd=bkd { ([ (typaram, Some(mnbkd)) ], []) } | typaram=TYPARAM; COMMA; tail=typaramssub { let (typarams, rowparams) = tail in ((typaram, None) :: typarams, rowparams) } | typaram=TYPARAM; CONS; mnbkd=bkd COMMA; tail=typaramssub { let (typarams, rowparams) = tail in ((typaram, Some(mnbkd)) :: typarams, rowparams) } ; rowparams: | { [] } | rowparam=ROWPARAM; CONS; LPAREN; labels=labels; RPAREN { [ (rowparam, labels) ] } | rowparam=ROWPARAM; CONS; LPAREN; labels=labels; RPAREN; COMMA; tail=rowparams { (rowparam, labels) :: tail } ; labels: | { [] } | tok=LOWER { [ tok ] } | tok=LOWER; COMMA; tail=labels { tok :: tail } ; bindvallocal: | valbinding=bindvalsingle { NonRec(valbinding) } | REC; valbinding=bindvalsingle; tail=list(recbinds) { Rec(valbinding :: tail) } ; bindvaltop: | tokL=VAL; rec_or_nonrec=bindvallocal { (tokL, Internal(rec_or_nonrec)) (* TODO: give appropriate range *) } | tokL=VAL; ident=LOWER; tyrowparams=typarams; COLON; mty=ty; DEFEQ; EXTERNAL; inttok=INT; has_option=has_option; strblock=STRING_BLOCK { let (typarams, rowparams) = tyrowparams in let (tokR, erlang_bind) = strblock in let (_, arity) = inttok in let rng = make_range (Token(tokL)) (Token(tokR)) in let extbind = { ext_identifier = ident; ext_type_params = typarams; ext_row_params = rowparams; ext_type_annot = mty; ext_arity = arity; ext_has_option = has_option; ext_code = erlang_bind; } in (rng, External(extbind)) } ; has_option: | { false } | BINOP_PLUS { true } (* TODO: fix this ad-hoc implementation *) ; recbinds: | AND; valbinding=bindvalsingle { valbinding } ; bindvalsingle: | ident=LOWER; tyrowparams=typarams; LPAREN; params=params; RPAREN; ret=bindvalret { let (typarams, rowparams) = tyrowparams in let (ordparams, (mndparams, optparams)) = params in { vb_identifier = ident; vb_forall = typarams; vb_forall_row = rowparams; vb_parameters = ordparams; vb_mandatories = mndparams; vb_optionals = optparams; vb_return = ret; } } ; bindvalret: | DEFEQ; e=exprlet { Pure(None, e) } | COLON; mty=ty DEFEQ; e=exprlet { Pure(Some(mty), e) } | DEFEQ; ACT; c=comp { Effectful(None, c) } | COLON; LSQUARE; mty1=ty; RSQUARE; mty2=ty DEFEQ; ACT; c=comp { Effectful(Some(mty1, mty2), c) } ; ctorbranches: | ctorbrs=nonempty_list(ctorbranch) { ctorbrs } ; ctorbranch: | BAR; attrs=list(attr); ctor=UPPER { ConstructorBranch(attrs, ctor, []) } | BAR; attrs=list(attr); ctor=UPPER; LPAREN; paramtys=tys; RPAREN { ConstructorBranch(attrs, ctor, paramtys) } ; params: | labparams=labparams { ([], labparams) } | pat=patcons; tyannot=tyannot { ([ (pat, tyannot) ], ([], [])) } | pat=patcons; tyannot=tyannot; COMMA; tail=params { let (ordparams, labparams) = tail in ((pat, tyannot) :: ordparams, labparams) } ; labparams: | optparams=optparams { ([], optparams) } | rlabel=MNDLABEL; pat=patcons; tyannot=tyannot { ([ (rlabel, (pat, tyannot)) ], []) } | rlabel=MNDLABEL; pat=patcons; tyannot=tyannot; COMMA; tail=labparams { let (mndparams, optparams) = tail in ((rlabel, (pat, tyannot)) :: mndparams, optparams) } ; optparams: | { [] } | optparam=optparam { [ optparam ] } | optparam=optparam; COMMA; tail=optparams { optparam :: tail } ; optparam: | rlabel=OPTLABEL; pat=patcons; tyannot=tyannot { ((rlabel, (pat, tyannot)), None) } | rlabel=OPTLABEL; pat=patcons; tyannot=tyannot; DEFEQ; utast=exprlet { ((rlabel, (pat, tyannot)), Some(utast)) } ; tyannot: | { None } | COLON; mty=ty { Some(mty) } ; decl: | attrs=list(attr); tokL=VAL; ident=LOWER; tyrowparams=typarams; COLON; mty=ty { let (typarams, rowparams) = tyrowparams in let rng = make_range (Token(tokL)) (Ranged(mty)) in (rng, DeclVal(ident, typarams, rowparams, mty, attrs)) } | attrs=list(attr); tokL=TYPE; tyident=LOWER; CONS; kd=kd { let rng = make_range (Token(tokL)) (Ranged(kd)) in (rng, DeclTypeOpaque(tyident, Some(kd), attrs)) } | attrs=list(attr); tokL=TYPE; tyident=LOWER { let rng = make_range (Token(tokL)) (Ranged(tyident)) in (rng, DeclTypeOpaque(tyident, None, attrs)) } | attrs=list(attr); tokL=TYPE; tybind=bindtypesingle; tybinds=list(bindtypesub) { decl_type_transparent attrs tokL (tybind :: tybinds) } | attrs=list(attr); tokL=MODULE; modident=UPPER; COLON; utsig=sigexpr { let rng = make_range (Token(tokL)) (Ranged(utsig)) in (rng, DeclModule(modident, utsig, attrs)) } | attrs=list(attr); tokL=SIGNATURE; sigident=UPPER; DEFEQ; utsig=sigexpr { let rng = make_range (Token(tokL)) (Ranged(utsig)) in (rng, DeclSig(sigident, utsig, attrs)) } ; modexpr: | tokL=LAMBDA; LPAREN; modident=UPPER; COLON; utsig=sigexpr; RPAREN; ARROW; utmod=modexpr { let rng = make_range (Token(tokL)) (Ranged(utmod)) in (rng, ModFunctor(modident, utsig, utmod)) } | modident=UPPER; COERCE; utsig=sigexprbot { let rng = make_range (Ranged(modident)) (Ranged(utsig)) in (rng, ModCoerce(modident, utsig)) } | utmod=modapp { utmod } ; modapp: | modchain1=modchainraw; LPAREN; modchain2=modchainraw; tokR=RPAREN { let (modident1, _) = modchain1 in let rng = make_range (Ranged(modident1)) (Token(tokR)) in (rng, ModApply(modchain1, modchain2)) } | utmod=modexprbot { utmod } ; modexprbot: | utmod=modexprunit { utmod } | utmod=modchain { utmod } ; modexprunit: | attrs=list(attr); tokL=STRUCT; openspecs=list(openspec) utbinds=list(bindtop); tokR=END { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, ModBinds(attrs, openspecs, utbinds)) } | tokL=LPAREN; utmod=modexpr; tokR=RPAREN { let rng = make_range (Token(tokL)) (Token(tokR)) in let (_, utmodmain) = utmod in (rng, utmodmain) } ; modchain: | modchainraw=modchainraw { fold_module_chain modchainraw } ; modchainraw: | modident=UPPER; projs=list(DOTUPPER) { (modident, projs) } ; openspec: | OPEN; modchain=modchainraw { modchain } ; attr: | tokL=ATTRIBUTE; ident=LOWER; LPAREN; utast=exprlet; RPAREN; tokR=RSQUARE { let (_, attr_name) = ident in let rng = make_range (Token(tokL)) (Token(tokR)) in Attribute((rng, (attr_name, Some(utast)))) } | tokL=ATTRIBUTE; ident=LOWER; tokR=RSQUARE { let (_, attr_name) = ident in let rng = make_range (Token(tokL)) (Token(tokR)) in Attribute((rng, (attr_name, None))) } ; sigexpr: | tokL=LAMBDA; LPAREN; sigident=UPPER; COLON; utsig1=sigexpr; RPAREN; ARROW; utsig2=sigexpr { let rng = make_range (Token(tokL)) (Ranged(utsig2)) in (rng, SigFunctor(sigident, utsig1, utsig2)) } | utsig=sigexprwith { utsig } ; sigexprwith: | utsig=sigexprbot; WITH; modidents=withproj; TYPE; tybind=bindtypesingle; tybinds=list(bindtypesub) { let rng = Range.dummy "sigexpr" in (* TODO: give appropriate code ranges *) (rng, SigWith(utsig, modidents, tybind :: tybinds)) } | utsig=sigexprbot { utsig } ; withproj: | { [] } | modident=UPPER; modidents=list(DOTUPPER) { modident :: modidents } ; sigexprbot: | utmod=modexprunit; sigident=DOTUPPER { let rng = make_range (Ranged(utmod)) (Ranged(sigident)) in (rng, SigPath(utmod, sigident)) } | modchain=modchainraw { let (tokL, modidents, sigident) = chop_last modchain in let rng = make_range (Token(tokL)) (Ranged(sigident)) in match modidents with | [] -> let (_, signm) = sigident in (rng, SigVar(signm)) | modident :: projs -> let utmod = fold_module_chain (modident, projs) in (rng, SigPath(utmod, sigident)) } | tokL=SIG; openspecs=list(openspec); utdecls=list(decl); tokR=END { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, SigDecls(openspecs, utdecls)) } | tokL=LPAREN; utsig=sigexpr; tokR=RPAREN { let rng = make_range (Token(tokL)) (Token(tokR)) in let (_, utsigmain) = utsig in (rng, utsigmain) } ; comp: | tokL=DO; pat=patcons; tyannot=tyannot; REVARROW; c1=comp; IN; c2=comp { let rng = make_range (Token(tokL)) (Ranged(c2)) in (rng, CompDo((pat, tyannot), c1, c2)) } | tokL=RECEIVE; branches=nonempty_list(receive_branch); after=option(after); tokR=END { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, CompReceive(branches, after)) } | tokL=LET; rec_or_nonrec=bindvallocal; IN; c2=comp { let rng = make_range (Token(tokL)) (Ranged(c2)) in (rng, CompLetIn(rec_or_nonrec, c2)) } | tokL=LET; pat=patcons; DEFEQ; e1=exprlet; IN; c2=comp { let rng = make_range (Token(tokL)) (Ranged(c2)) in (rng, CompLetPatIn(pat, e1, c2)) } | tokL=IF; e0=exprlet; THEN; c1=comp; ELSE c2=comp { let rng = make_range (Token(tokL)) (Ranged(c2)) in (rng, CompIf(e0, c1, c2)) } | tokL=CASE; e=exprlet; OF; branches=nonempty_list(comp_case_branch); tokR=END { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, CompCase(e, branches)) } | efun=exprapp; LPAREN; args=args; tokR=RPAREN { let (ordargs, (mndargs, optargs)) = args in let rng = make_range (Ranged(efun)) (Token(tokR)) in (rng, CompApply(efun, (ordargs, mndargs, optargs))) } ; after: | AFTER; e=exprapp; ARROW; c=comp { (e, c) } ; exprlet: | tokL=LET; rec_or_nonrec=bindvallocal; IN; e2=exprlet { let rng = make_range (Token(tokL)) (Ranged(e2)) in (rng, LetIn(rec_or_nonrec, e2)) } | tokL=LET; pat=patcons; DEFEQ; e1=exprlet; IN; e2=exprlet { let rng = make_range (Token(tokL)) (Ranged(e2)) in (rng, LetPatIn(pat, e1, e2)) } | tokL=IF; e0=exprlet; THEN; e1=exprlet; ELSE; e2=exprlet { let rng = make_range (Token(tokL)) (Ranged(e2)) in (rng, If(e0, e1, e2)) } | tokL=ASSERT; e0=exprlet { let rng = make_range (Token(tokL)) (Ranged(e0)) in (rng, Assert(e0)) } | e=exprfun { e } ; exprfun: | tokL=LAMBDA; LPAREN; params=params; RPAREN; ARROW; cod=exprcod; tokR=END { let (ordparams, (mndparams, optparams)) = params in let lamparams = (ordparams, mndparams, optparams) in let rng = make_range (Token(tokL)) (Token(tokR)) in match cod with | Pure(e) -> (rng, Lambda(lamparams, e)) | Effectful(c) -> (rng, LambdaEff(lamparams, c)) } | tokL=CASE; e=exprlet; OF; branches=nonempty_list(case_branch); tokR=END { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, Case(e, branches)) } | e=exprland { e } ; exprcod: | e=exprlet { Pure(e) } | ACT; c=comp { Effectful(c) } ; exprland: | e1=exprlor; op=BINOP_AMP; e2=exprland { binary e1 op e2 } | e=exprlor { e } ; exprlor: | e1=exprcomp; op=BINOP_BAR; e2=exprlor { binary e1 op e2 } | e=exprcomp { e } ; exprcomp: | e1=exprcons; op=BINOP_EQ; e2=exprcomp { binary e1 op e2 } | e1=exprcons; op=oplt; e2=exprcomp { binary e1 op e2 } | e1=exprcons; op=opgt; e2=exprcomp { binary e1 op e2 } | e=exprcons { e } ; oplt: | op=BINOP_LT { op } | rng=LT_EXACT { (rng, "<") } ; opgt: | op=BINOP_GT { op } | rng=GT_SPACES { (rng, ">") } | rng=GT_NOSPACE { (rng, ">") } ; exprcons: | e1=exprtimes; CONS; e2=exprcons { let rng = make_range (Ranged(e1)) (Ranged(e2)) in (rng, ListCons(e1, e2)) } | e=exprplus { e } ; exprplus: | e1=exprplus; op=BINOP_PLUS; e2=exprtimes { binary e1 op e2 } | e1=exprplus; op=BINOP_MINUS; e2=exprtimes { binary e1 op e2 } | e=exprtimes { e } ; exprtimes: | e1=exprtimes; op=BINOP_TIMES; e2=exprapp { binary e1 op e2 } | e1=exprtimes; op=BINOP_DIVIDES; e2=exprapp { binary e1 op e2 } | e=exprapp { e } ; exprapp: | efun=exprapp; LPAREN; args=args; tokR=RPAREN { let (ordargs, (mndargs, optargs)) = args in let rng = make_range (Ranged(efun)) (Token(tokR)) in (rng, Apply(efun, (ordargs, mndargs, optargs))) } | tokL=PACK; modchain=modchainraw; COLON; utsig=sigexprbot { let rng = make_range (Token(tokL)) (Ranged(utsig)) in (rng, Pack(modchain, utsig)) } | tokL=FREEZE; modchain=modchainraw; ident=DOTLOWER; LPAREN; args=freezeargs; tokR=RPAREN { let (ordargs, rngs) = args in let ((rng1, _), _) = modchain in let rngapp = make_range (Token(rng1)) (Token(tokR)) in let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, Freeze(rngapp, FrozenModFun(modchain, ident), ordargs, rngs)) } | tokL=FREEZE; ident=LOWER; LPAREN; args=freezeargs; tokR=RPAREN { let (ordargs, rngs) = args in let rngapp = make_range (Ranged(ident)) (Token(tokR)) in let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, Freeze(rngapp, FrozenFun(ident), ordargs, rngs)) } | tokL=FREEZE; LPAREN; e=exprlet; RPAREN; WITH; LPAREN; args=freezeargs; tokR=RPAREN { let (ordargs, rngs) = args in let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, FreezeUpdate(e, ordargs, rngs)) } | modchain=modchainraw; LPAREN; args=args; tokR=RPAREN { let (tokL, modidents, ctor) = chop_last modchain in let (ordargs, optargs) = args in let rng = make_range (Token(tokL)) (Token(tokR)) in let (_, ctornm) = ctor in (rng, Constructor(modidents, ctornm, ordargs)) (* TODO: emit errors when `optargs` is not nil *) } | modchain=modchainraw { let (tokL, modidents, ctor) = chop_last modchain in let rng = make_range (Token(tokL)) (Ranged(ctor)) in let (_, ctornm) = ctor in (rng, Constructor(modidents, ctornm, [])) } | modchain=modchainraw; ident=DOTLOWER { let (modident, modidents) = modchain in let rng = make_range (Ranged(modident)) (Ranged(ident)) in (rng, Var(modident :: modidents, ident)) } | e=exprbot { e } ; args: | labargs=labargs { ([], labargs) } | e=exprlet { ([ e ], ([], [])) } | e=exprlet; COMMA; tail=args { let (ordargs, labargs) = tail in (e :: ordargs, labargs) } ; labargs: | optargs=optargs { ([], optargs) } | rlabel=MNDLABEL; e=exprlet { ([ (rlabel, e) ], []) } | rlabel=MNDLABEL; e=exprlet; COMMA; tail=labargs { let (mndargs, optargs) = tail in ((rlabel, e) :: mndargs, optargs) } ; optargs: | { [] } | rlabel=OPTLABEL; e=exprlet { [ (rlabel, e) ] } | rlabel=OPTLABEL; e=exprlet; COMMA; tail=optargs { (rlabel, e) :: tail } ; freezeargs: | rngs=holeargs { ([], rngs) } | e=exprlet { ([ e ], []) } | e=exprlet; COMMA; tail=freezeargs { let (ordargs, rngs) = tail in (e :: ordargs, rngs) } ; holeargs: | { [] } | tok=UNDERSCORE { [ tok ] } | tok=UNDERSCORE; COMMA; tail=holeargs { tok :: tail } ; record: | { [] } | rlabel=LOWER; DEFEQ; e=exprlet { [ (rlabel, e) ] } | rlabel=LOWER; DEFEQ; e=exprlet; COMMA; tail=record { (rlabel, e) :: tail } ; exprs: | { [] } | e=exprlet { [ e ] } | e=exprlet; COMMA; tail=exprs { e :: tail } ; exprbot: | rng=TRUE { (rng, BaseConst(Bool(true))) } | rng=FALSE { (rng, BaseConst(Bool(false))) } | tokL=LBRACE; tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, BaseConst(Unit)) } | c=INT { let (rng, n) = c in (rng, BaseConst(Int(n))) } | c=FLOAT { let (rng, r) = c in (rng, BaseConst(Float(r))) } | ident=ident { let (rng, _) = ident in (rng, Var([], ident)) } | LPAREN; e=exprlet; RPAREN { e } | tokL=LBRACE; e1=exprlet; es=list(tuplesub); tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, Tuple(TupleList.make e1 es)) } | tokL=LSQUARE; es=exprs; tokR=RSQUARE { let rng = make_range (Token(tokL)) (Token(tokR)) in let dr = Range.dummy "list" in let (_, emain) = List.fold_right (fun e tail -> (dr, ListCons(e, tail))) es (dr, ListNil) in (rng, emain) } | tokL=LTLT; ns=bytes tokR=gtgt { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, BinaryByList(ns)) } | binlit=BINARY { let (rng, s) = binlit in (rng, BaseConst(BinaryByString(s))) } | strblock=STRING_BLOCK { let (rng, s) = strblock in (rng, BaseConst(BinaryByInts(s |> String.to_seq |> List.of_seq |> List.map Char.code))) } | strlit=STRING { let (rng, s) = strlit in (rng, BaseConst(String(s))) } | fmtlit=FORMAT { let (rng, fmtelems) = fmtlit in (rng, BaseConst(FormatString(fmtelems))) } | charlit=CHAR { let (rng, uchar) = charlit in (rng, BaseConst(Char(uchar))) } | tokL=LBRACE; les=record; tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, Record(les)) } | tokL=LBRACE; e1=exprbot; BAR; les=record; tokR=RBRACE { let (_, eaccmain) = List.fold_left (fun eacc (rlabel, e2) -> let rng = make_range (Token(tokL)) (Ranged(e2)) in (rng, RecordUpdate(eacc, rlabel, e2)) ) e1 les in let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, eaccmain) } | e=exprbot; rlabel=DOTLOWER { let rng = make_range (Ranged(e)) (Ranged(rlabel)) in (rng, RecordAccess(e, rlabel)) } ; bytes: | { [] } | tok=INT { tok :: [] } | tok=INT; COMMA; tail=bytes { tok :: tail } ; gtgt: | GT_NOSPACE; tokR=GT_NOSPACE { tokR } | GT_NOSPACE; tokR=GT_SPACES { tokR } ; tuplesub: COMMA; e=exprlet { e } ; receive_branch: | BAR; pat=patcons; ARROW; c=comp { ReceiveBranch(pat, c) } ; case_branch: | BAR; pat=patcons; ARROW; e=exprlet { CaseBranch(pat, e) } ; comp_case_branch: | BAR; pat=patcons; ARROW; c=comp { CompCaseBranch(pat, c) } ; patcons: | p1=patbot; CONS; p2=patcons { let rng = make_range (Ranged(p1)) (Ranged(p2)) in (rng, PListCons(p1, p2)) } | p=patbot { p } ; patbot: | rng=TRUE { (rng, PBool(true)) } | rng=FALSE { (rng, PBool(false)) } | tokL=LBRACE; tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, PUnit) } | c=INT { let (rng, n) = c in (rng, PInt(n)) } | charlit=CHAR { let (rng, uchar) = charlit in (rng, PChar(uchar)) } | binlit=BINARY { let (rng, s) = binlit in (rng, PBinary(s)) } | ident=ident { let (rng, x) = ident in (rng, PVar(x)) } | rng=UNDERSCORE { (rng, PWildCard) } | tokL=LSQUARE; tokR=RSQUARE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, PListNil) } | tokL=LSQUARE; p1=patcons; pats=list(pattuplesub); tokR=RSQUARE { let rng = make_range (Token(tokL)) (Token(tokR)) in let (_, pmain) = make_list_pattern (p1 :: pats) in (rng, pmain) } | tokL=LBRACE; p1=patcons; pats=list(pattuplesub); tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, PTuple(TupleList.make p1 pats)) } | modchain=modchainraw { let (tokL, modidents, ctor) = chop_last modchain in let rng = make_range (Token(tokL)) (Ranged(ctor)) in let (_, ctornm) = ctor in (rng, PConstructor(modidents, ctornm, [])) } | modchain=modchainraw; LPAREN; pats=pats; tokR=RPAREN { let (tokL, modidents, ctor) = chop_last modchain in let rng = make_range (Token(tokL)) (Token(tokR)) in let (_, ctornm) = ctor in (rng, PConstructor(modidents, ctornm, pats)) } ; pats: | { [] } | pat=patcons { pat :: [] } | pat=patcons; COMMA; tail=pats { pat :: tail } ; pattuplesub: | COMMA; p=patcons { p } ; tys: | { [] } | mty=ty { mty :: [] } | mty=ty; COMMA; tail=tys { mty :: tail } ; tydoms: | labmtydoms=labtydoms { ([], labmtydoms) } | mty=ty { ([ mty ], ([], MRow([], None))) } | mty=ty; COMMA; tail=tydoms { let (ordmtydoms, labmtydoms) = tail in (mty :: ordmtydoms, labmtydoms) } ; labtydoms: | optmtydoms=opttydoms { ([], optmtydoms) } | rlabel=MNDLABEL; mty=ty { ([ (rlabel, mty) ], MRow([], None)) } | rlabel=MNDLABEL; mty=ty; COMMA; tail=labtydoms { let (mndmtydoms, optmtydoms) = tail in ((rlabel, mty) :: mndmtydoms, optmtydoms) } ; opttydoms: | sub=opttydomssub { let (pairs, rowvaropt) = sub in MRow(pairs, rowvaropt) } ; opttydomssub: | { ([], None) } | rlabel=OPTLABEL; mty=ty { ([ (rlabel, mty) ], None) } | tok=ROWPARAM { ([], Some(tok)) } | rlabel=OPTLABEL; mty=ty; COMMA; tail=opttydomssub { let (pairs, rowvaropt) = tail in ((rlabel, mty) :: pairs, rowvaropt) } ; kd: | tokL=LPAREN; bkddoms=bkds; RPAREN; ARROW; bkdcod=bkd { let rng = make_range (Token(tokL)) (Ranged(bkdcod)) in (rng, MKind(bkddoms, bkdcod)) } | bkd=bkd { let (rng, _) = bkd in (rng, MKind([], bkd)) } ; bkds: | bkd=bkd { [ bkd ] } | bkd=bkd; COMMA { [ bkd ] } | bkd=bkd; COMMA; tail=bkds { bkd :: tail } ; bkd: | ident=LOWER { let (rng, kdnm) = ident in (rng, MKindName(kdnm)) } ty: | utmod=modchain; tyident=DOTLOWER { let rng = make_range (Ranged(utmod)) (Ranged(tyident)) in (rng, MModProjType(utmod, tyident, [])) } | utmod=modchain; tyident=DOTLOWER; tylparen; mtyargs=tys; tokR=tyrparen { let rng = make_range (Ranged(utmod)) (Token(tokR)) in (rng, MModProjType(utmod, tyident, mtyargs)) } | mty=tybot { mty } ; tybot: | tok=TYPARAM { let (rng, typaram) = tok in (rng, MTypeVar(typaram)) } | ident=LOWER { let (rng, tynm) = ident in (rng, MTypeName(tynm, [])) } | ident=LOWER; tylparen; mtyargs=tys; tokR=tyrparen { let (tokL, tynm) = ident in let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, MTypeName(tynm, mtyargs)) } | tokL=LAMBDA; LPAREN; tydoms=tydoms; RPAREN; ARROW; cod=tycod { let (ordmtydoms, (mndmtydoms, optmtydoms)) = tydoms in match cod with | Pure(mtycod) -> let rng = make_range (Token(tokL)) (Ranged(mtycod)) in (rng, MFuncType((ordmtydoms, mndmtydoms, optmtydoms), mtycod)) | Effectful(rngL, mty1, mty2) -> let rng = make_range (Token(tokL)) (Token(rngL)) in (rng, MEffType((ordmtydoms, mndmtydoms, optmtydoms), mty1, mty2)) } | tokL=LBRACE; mty1=ty; mtys=list(tytuplesub) tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in (rng, MProductType(TupleList.make mty1 mtys)) } | tokL=LBRACE; tyrecord=tyrecord; tokR=RBRACE { let rng = make_range (Token(tokL)) (Token(tokR)) in let (pairs, rowvaropt) = tyrecord in (rng, MRecordType(MRow(pairs, rowvaropt))) } | tokL=PACK; utsig=sigexprbot { let rng = make_range (Token(tokL)) (Ranged(utsig)) in (rng, MPackType(utsig)) } ; tycod: | mtycod=ty { Pure(mtycod) } | tokL=LSQUARE; mty1=ty; RSQUARE; mty2=ty { let rng = make_range (Token(tokL)) (Ranged(mty2)) in Effectful(rng, mty1, mty2) } ; tyrecord: | { ([], None) } | rlabel=LOWER; COLON; mty=ty { ([ (rlabel, mty) ], None) } | tok=ROWPARAM { ([], Some(tok)) } | rlabel=LOWER; COLON; mty=ty; COMMA; tail=tyrecord { let (pairs, rowvaropt) = tail in ((rlabel, mty) :: pairs, rowvaropt) } ; tytuplesub: | COMMA; mty=ty { mty } ; tylparen: | tok=LT_EXACT { tok } ; tyrparen: | tok=GT_NOSPACE { tok } | tok=GT_SPACES { tok } ; ================================================ FILE: src/parserInterface.ml ================================================ open Syntax open Errors module I = Parser.MenhirInterpreter let k_success x = Ok(x) let k_fail chkpt = match chkpt with | I.HandlingError(penv) -> let rng = Range.from_positions (I.positions penv) in Error(ParseError(rng)) | _ -> assert false let process ~fname:(fname : string) (lexbuf : Lexing.lexbuf) : ((module_name ranged) list * module_name ranged * untyped_signature option * untyped_module, syntax_error) result = try lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = fname }; let supplier = I.lexer_lexbuf_to_supplier Lexer.token lexbuf in I.loop_handle k_success k_fail supplier (Parser.Incremental.main lexbuf.Lexing.lex_curr_p) with | Lexer.Error(e) -> Error(LexerError(e)) ================================================ FILE: src/parserInterface.mli ================================================ open Syntax open Errors val process : fname:string -> Lexing.lexbuf -> ((module_name ranged) list * module_name ranged * untyped_signature option * untyped_module, syntax_error) result ================================================ FILE: src/primitives.ml ================================================ open MyUtil open Syntax open IntermediateSyntax open Env let primitive_module_name = "sesterl_internal_prim" let decode_option_function = "decode_option" let decode_option_function_with_default = "decode_option_with_default" let vid_option = TypeID.fresh Address.root "option" let vid_result = TypeID.fresh Address.root "result" let vid_list = TypeID.fresh Address.root "list" let vid_format = TypeID.fresh Address.root "format" let vid_frozen = TypeID.fresh Address.root "frozen" let option_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ = (rng, TypeApp(vid_option, [ty])) let list_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ = (rng, TypeApp(vid_list, [ty])) let format_type (rng : Range.t) (ty : ('a, 'b) typ) : ('a, 'b) typ = (rng, TypeApp(vid_format, [ty])) let frozen_type (rng : Range.t) ~rest:(tyrest : ('a, 'b) typ) ~receive:(tyrecv : ('a, 'b) typ) ~return:(tycod : ('a, 'b) typ) : ('a, 'b) typ = (rng, TypeApp(vid_frozen, [tyrest; tyrecv; tycod])) let assertion_function_type : mono_type = let dr = Range.dummy "assertion_function_type" in let domty = { ordered = [(dr, BaseType(BinaryType)); (dr, BaseType(IntType))]; mandatory = LabelAssoc.empty; optional = RowEmpty; } in (dr, FuncType(domty, (dr, BaseType(UnitType)))) let fresh_bound () = let bid = BoundID.fresh () in (Range.dummy "primitives-bound", TypeVar(Bound(bid))) let dr = Range.dummy "primitives" let u = (dr, BaseType(UnitType)) let b = (dr, BaseType(BoolType)) let i = (dr, BaseType(IntType)) let f = (dr, BaseType(FloatType)) let c = (dr, BaseType(CharType)) let ( @-> ) tydoms tycod = let domain = { ordered = tydoms; mandatory = LabelAssoc.empty; optional = RowEmpty; } in (dr, FuncType(domain, tycod)) let eff tydoms tyrcv ty0 = let domain = { ordered = tydoms; mandatory = LabelAssoc.empty; optional = RowEmpty; } in (dr, EffType(domain, Effect(tyrcv), ty0)) let pid tyrcv = (dr, PidType(Pid(tyrcv))) let tylogic : poly_type = [b; b] @-> b let tycomp : poly_type = [i; i] @-> b let tyarith : poly_type = [i; i] @-> i let tyarith_float : poly_type = [f; f] @-> f let tyspawn : poly_type = let tyrecv = fresh_bound () in let tyrecvnew = fresh_bound () in eff [eff [] tyrecvnew u] tyrecv (pid tyrecvnew) let tysend : poly_type = let tyrecv = fresh_bound () in let tyrecvremote = fresh_bound () in eff [pid tyrecvremote; tyrecvremote] tyrecv u let tyreturn : poly_type = let tyrecv = fresh_bound () in let tyres = fresh_bound () in eff [tyres] tyrecv tyres let tyself : poly_type = let tyrecv = fresh_bound () in eff [] tyrecv (pid tyrecv) let typrintdebug : poly_type = let typaram = fresh_bound () in [typaram] @-> u let tyformat : poly_type = let typaram = fresh_bound () in [format_type dr typaram; typaram] @-> list_type dr c type source_definition = { identifier : string; typ : poly_type; } type target_definition = { target_name : string; parameters : string list; code : string; } type primitive_definition = { source : source_definition option; target : target_definition; } let primitive_definitions = [ { source = Some{ identifier = "spawn"; typ = tyspawn; }; target = { target_name = "spawn"; parameters = ["F"]; code = "erlang:spawn(F)"; }; }; { source = Some{ identifier = "send"; typ = tysend; }; target = { target_name = "send"; parameters = ["Pid"; "Msg"]; code = Printf.sprintf "Pid ! {%s, Msg}, ok" Constants.message_tag_atom; }; }; { source = Some{ identifier = "return"; typ = tyreturn; }; target = { target_name = "return"; parameters = ["X"]; code = "X"; } }; { source = Some{ identifier = "self"; typ = tyself; }; target = { target_name = "self"; parameters = []; code = "erlang:self()"; }; }; { source = Some{ identifier = "print_debug"; typ = typrintdebug; }; target = { target_name = "print_debug"; parameters = ["X"]; code = "io:format(\"~p~n\", [X]), ok"; }; }; { source = Some{ identifier = "format"; typ = tyformat; }; target = { target_name = "format"; parameters = ["{Fmt, _Arity}"; "Arg"]; code = "Args = case Arg of ok -> []; _ -> tuple_to_list(Arg) end, lists:flatten(io_lib:format(Fmt, Args))" }; }; { source = None; target = { target_name = decode_option_function; parameters = ["Options"; "Key"]; code = "maps:find(Key, Options)"; }; }; { source = None; target = { target_name = decode_option_function_with_default; parameters = ["Options"; "Key"; "Thunk"]; code = "case maps:find(Key, Options) of error -> Thunk(); {ok, Value} -> Value end"; }; }; ] let make_constructor_id (ctor : string) (atom_opt : string option) = match atom_opt with | None -> begin match ConstructorID.from_upper_camel_case ctor with | None -> assert false | Some(ctorid) -> ctorid end | Some(atom) -> begin match ConstructorID.from_snake_case atom with | None -> assert false | Some(ctorid) -> ctorid end type constructor_definition = constructor_name * string option * poly_type list let add_variant_types (vntdefs : (type_name * TypeID.t * BoundID.t list * constructor_definition list) list) (tyenv, gmap) = let tyenv : Typeenv.t = vntdefs |> List.fold_left (fun tyenv vntdef -> let (tynm, vid, bids, ctordefs) = vntdef in let pkd = TypeConv.kind_of_arity (List.length bids) in let (centryacc, ctormap) = ctordefs |> List.fold_left (fun (centryacc, ctormap) ctordef -> let (ctornm, atom_opt, paramtys) = ctordef in let ctorid = make_constructor_id ctornm atom_opt in let centry = { belongs = vid; constructor_id = ctorid; type_variables = bids; parameter_types = paramtys; } in let centryacc = Alist.extend centryacc (ctornm, centry) in let ctormap = ctormap |> ConstructorMap.add ctornm (ctorid, paramtys) in (centryacc, ctormap) ) (Alist.empty, ConstructorMap.empty) in let tentry = let (bids, tybody) = TypeConv.make_opaque_type_scheme bids vid in { type_scheme = (bids, tybody, Variant(ctormap)); type_kind = pkd; type_doc = None; } in let tyenv = tyenv |> Typeenv.add_type tynm tentry in let tyenv = centryacc |> Alist.to_list |> List.fold_left (fun tyenv (ctornm, centry) -> tyenv |> Typeenv.add_constructor ctornm centry ) tyenv in tyenv ) tyenv in (tyenv, gmap) let add_operators (ops : (string * poly_type * string) list) ((tyenv, nmap) : Typeenv.t * name_map) : Typeenv.t * name_map = let tyenv = ops |> List.fold_left (fun tyenv (x, pty, target) -> let name = OutputIdentifier.Operator(OutputIdentifier.operator target) in tyenv |> Typeenv.add_value x pty name ) tyenv in (tyenv, nmap) let add_primitives (prims : primitive_definition list) ((tyenv, nmap) : Typeenv.t * name_map) : Typeenv.t * name_map = prims |> List.fold_left (fun (tyenv, nmap) primdef -> let (gmap, smap) = nmap in match primdef.source with | None -> (tyenv, nmap) | Some(srcdef) -> let targetdef = primdef.target in let gname = let arity = List.length targetdef.parameters in match OutputIdentifier.generate_global targetdef.target_name ~suffix:"" ~arity:arity ~has_option:false with | None -> assert false | Some(gname) -> gname in let tyenv = tyenv |> Typeenv.add_value srcdef.identifier srcdef.typ (OutputIdentifier.Global(gname)) in let gmap = gmap |> GlobalNameMap.add gname primitive_module_name in (tyenv, (gmap, smap)) ) (tyenv, nmap) let initial_environment = (Typeenv.empty, (GlobalNameMap.empty, SpaceNameMap.empty)) |> add_variant_types [ begin let bid = BoundID.fresh () in ("option", vid_option, [bid], [ ("None", Some("error"), []); ("Some", Some("ok"), [(dr, TypeVar(Bound(bid)))]); ]) end; begin let bid_ok = BoundID.fresh () in let bid_error = BoundID.fresh () in ("result", vid_result, [bid_ok; bid_error], [ ("Ok", None, [(dr, TypeVar(Bound(bid_ok)))]); ("Error", None, [(dr, TypeVar(Bound(bid_error)))]); ]) end; begin let bid = BoundID.fresh () in ("list", vid_list, [bid], [ (* Here is no constructor definition because `ListNil` and `ListCons` are provided for type `untyped_ast`. *) ]) end; begin let bid = BoundID.fresh () in ("format", vid_format, [bid], [ ]) end; begin let bid1 = BoundID.fresh () in let bid2 = BoundID.fresh () in let bid3 = BoundID.fresh () in ("frozen", vid_frozen, [bid1; bid2; bid3], [ ]) end; ] |> add_operators [ ("&&", tylogic, "and"); ("||", tylogic, "or" ); ("==", tycomp , "==" ); ("<=", tycomp , "=<" ); (">=", tycomp , ">=" ); ("<" , tycomp , "<" ); (">" , tycomp , ">" ); ("*" , tyarith, "*" ); ("/" , tyarith, "div"); ("+" , tyarith, "+" ); ("-" , tyarith, "-" ); ("+.", tyarith_float, "+"); ("-.", tyarith_float, "-"); ("*.", tyarith_float, "*"); ("/.", tyarith_float, "/"); ] |> add_primitives primitive_definitions ================================================ FILE: src/primitives.mli ================================================ open Syntax open IntermediateSyntax open Env val primitive_module_name : string val decode_option_function : string val decode_option_function_with_default : string type source_definition = { identifier : string; typ : poly_type; } type target_definition = { target_name : string; parameters : string list; code : string; } type primitive_definition = { source : source_definition option; target : target_definition; } val primitive_definitions : primitive_definition list val option_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ val list_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ val format_type : Range.t -> ('a, 'b) typ -> ('a, 'b) typ val frozen_type : Range.t -> rest:('a, 'b) typ -> receive:('a, 'b) typ -> return:('a, 'b) typ -> ('a, 'b) typ val assertion_function_type : mono_type val initial_environment : Typeenv.t * name_map ================================================ FILE: src/range.ml ================================================ type real = { file_name : string; start_line : int; start_column : int; last_line : int; last_column : int; } type t = | Dummy of string | Real of real let pp ppf rng = match rng with | Dummy(s) -> Format.fprintf ppf "(%s)" s | Real(r) -> if r.start_line = r.last_line then Format.fprintf ppf "file '%s', line %d, characters %d-%d" r.file_name r.start_line r.start_column r.last_column else Format.fprintf ppf "file '%s', line %d, character %d to line %d, character %d" r.file_name r.start_line r.start_column r.last_line r.last_column let from_positions (posS, posE) = let fname = posS.Lexing.pos_fname in let lnum = posS.Lexing.pos_lnum in let cnumS = posS.Lexing.pos_cnum - posS.Lexing.pos_bol in let cnumE = posE.Lexing.pos_cnum - posE.Lexing.pos_bol in Real{ file_name = fname; start_line = lnum; start_column = cnumS; last_line = lnum; last_column = cnumE; } let from_lexbuf lexbuf = let posS = Lexing.lexeme_start_p lexbuf in let posE = Lexing.lexeme_end_p lexbuf in from_positions (posS, posE) let dummy s = Dummy(s) let unite r1 r2 = match (r1, r2) with | (Real(_), Dummy(_)) -> r1 | (Dummy(_), Real(_)) -> r2 | (Dummy(s1), Dummy(s2)) -> Dummy(s1 ^ "/" ^ s2) | (Real(x1), Real(x2)) -> Real{ file_name = x1.file_name; start_line = x1.start_line; start_column = x1.start_column; last_line = x2.last_line; last_column = x2.last_column; } let get_file_name (rng : t) = match rng with | Dummy(s) -> Printf.sprintf "(%s)" s | Real(r) -> r.file_name let get_start_line (rng : t) = match rng with | Dummy(_) -> 0 | Real(r) -> r.start_line ================================================ FILE: src/range.mli ================================================ type t val pp : Format.formatter -> t -> unit val from_lexbuf : Lexing.lexbuf -> t val from_positions : Lexing.position * Lexing.position -> t val dummy : string -> t val unite : t -> t -> t val get_file_name : t -> string val get_start_line : t -> int ================================================ FILE: src/sourceLoader.ml ================================================ open MyUtil open Syntax open Errors exception SyntaxError of syntax_error type loaded_module = { source_path : absolute_path; module_identifier : module_name ranged; signature : untyped_signature option; module_content : untyped_module; dependencies : (module_name ranged) list; } type loaded_package = { space_name : space_name; aux_modules : loaded_module list; main_module : loaded_module; test_modules : loaded_module list; } let listup_sources_in_directory (dir : absolute_dir) : absolute_path list = let filenames = Core.Sys.ls_dir dir in filenames |> List.filter_map (fun filename -> if Core.String.is_suffix filename ~suffix:".sest" then Some(Core.Filename.concat dir filename) else None ) let read_source (abspath_in : absolute_path) : loaded_module = Logging.begin_to_parse abspath_in; let inc = open_in abspath_in in let lexbuf = Lexing.from_channel inc in let fname = Filename.basename abspath_in in let res = let open ResultMonad in ParserInterface.process ~fname:fname lexbuf >>= fun (deps, modident, utsigopt, utmod) -> return { source_path = abspath_in; module_identifier = modident; signature = utsigopt; module_content = utmod; dependencies = deps; } in close_in inc; match res with | Ok(baremod) -> baremod | Error(err) -> raise (SyntaxError(err)) let resolve_dependency_scheme (nmmap_known : absolute_path ModuleNameMap.t) (baremods : loaded_module list) : loaded_module list * absolute_path ModuleNameMap.t = (* First, adds the vertices to the graph for solving dependency. *) let (graph, nmmap) = baremods |> List.fold_left (fun (graph, nmmap) baremod -> let (_, modnm) = baremod.module_identifier in let abspath = baremod.source_path in begin match nmmap |> ModuleNameMap.find_opt modnm with | Some((_, baremod0)) -> let abspath0 = baremod0.source_path in raise (ConfigError(MultipleModuleOfTheSameName(modnm, abspath0, abspath))) | None -> begin match nmmap_known |> ModuleNameMap.find_opt modnm with | Some(abspath0) -> raise (ConfigError(MultipleModuleOfTheSameName(modnm, abspath0, abspath))) | None -> let (graph, vertex) = graph |> FileDependencyGraph.add_vertex modnm in let nmmap = nmmap |> ModuleNameMap.add modnm (vertex, baremod) in (graph, nmmap) end end ) (FileDependencyGraph.empty, ModuleNameMap.empty) in (* Second, adds the dependency edges to the graph. *) let graph = ModuleNameMap.fold (fun modnm (vertex, baremod) graph -> let deps = baremod.dependencies in deps |> List.fold_left (fun graph (rng, modnm_dep) -> match nmmap |> ModuleNameMap.find_opt modnm_dep with | None -> if nmmap_known |> ModuleNameMap.mem modnm_dep then (* If the depended one has already been resolved (i.e. if the dependency is on a source file from a test file) *) graph else raise (ConfigError(ModuleNotFound(rng, modnm_dep))) | Some((vertex_dep, baremod_dep)) -> graph |> FileDependencyGraph.add_edge ~depending:vertex ~depended:vertex_dep ) graph ) nmmap graph in (* Finally, resolves dependency among Auxs. *) let resolved_auxs = match FileDependencyGraph.topological_sort graph with | Error(cycle) -> raise (ConfigError(CyclicFileDependencyFound(cycle))) | Ok(sorted_paths) -> sorted_paths |> List.map (fun modnm -> match nmmap |> ModuleNameMap.find_opt modnm with | None -> assert false | Some((_, baremod)) -> baremod ) in let nmmap_added = ModuleNameMap.fold (fun modnm (_, baremod) nmmap_added -> nmmap_added |> ModuleNameMap.add modnm baremod.source_path ) nmmap ModuleNameMap.empty in (resolved_auxs, nmmap_added) let resolve_dependency_among_auxiliary ~aux:(bareauxs : loaded_module list) : loaded_module list * absolute_path ModuleNameMap.t = resolve_dependency_scheme ModuleNameMap.empty bareauxs let check_dependency_of_main_on_auxiliary (nmmap_aux : absolute_path ModuleNameMap.t) ~main:(baremain : loaded_module) : unit = baremain.dependencies |> List.iter (fun (rng, modnm_dep) -> if nmmap_aux |> ModuleNameMap.mem modnm_dep then () else raise (ConfigError(ModuleNotFound(rng, modnm_dep))) ) let resolve_dependency_among_test (nmmap_src : absolute_path ModuleNameMap.t) ~test:(baretests : loaded_module list) : loaded_module list = let (resolved_tests, _) = resolve_dependency_scheme nmmap_src baretests in resolved_tests let resolve_dependency ~aux:(bareauxs : loaded_module list) ~main:(baremain : loaded_module) ~test:(baretests : loaded_module list) : loaded_module list * loaded_module list = let (resolved_auxs, nmmap_aux) = resolve_dependency_among_auxiliary ~aux:bareauxs in check_dependency_of_main_on_auxiliary nmmap_aux ~main:baremain; let nmmap_src = let (_, modnm_main) = baremain.module_identifier in let abspath_main = baremain.source_path in nmmap_aux |> ModuleNameMap.add modnm_main abspath_main in let resolved_tests = resolve_dependency_among_test nmmap_src ~test:baretests in (resolved_auxs, resolved_tests) let single (abspath_in : absolute_path) : loaded_module = let baremod = read_source abspath_in in let deps = baremod.dependencies in if List.length deps > 0 then raise (ConfigError(CannotSpecifyDependency)) else baremod let separate_main_module (config : ConfigLoader.config) (baresrcs : loaded_module list) : loaded_module * loaded_module list = let main_module_name = config.ConfigLoader.main_module_name in let (baremains, baresubs) = baresrcs |> List.partition (fun baremod -> let (_, modnm) = baremod.module_identifier in String.equal modnm main_module_name ) in match baremains with | [] -> let pkgname = config.ConfigLoader.package_name in raise (ConfigError(MainModuleNotFound(pkgname, main_module_name))) | baremain1 :: baremain2 :: _ -> let abspath1 = baremain1.source_path in let abspath2 = baremain2.source_path in raise (ConfigError(MultipleModuleOfTheSameName(main_module_name, abspath1, abspath2))) | [ baremain ] -> (baremain, baresubs) let main ~(requires_tests : bool) (config : ConfigLoader.config) : loaded_package = let srcdirs = let srcreldirs = config.ConfigLoader.source_directories in let confdir = config.ConfigLoader.config_directory in srcreldirs |> List.map (function RelativeDir(reldir) -> Core.Filename.concat confdir reldir) in let testdirs = let testreldirs = config.ConfigLoader.test_directories in let confdir = config.ConfigLoader.config_directory in testreldirs |> List.map (function RelativeDir(reldir) -> Core.Filename.concat confdir reldir) in let abspaths_src = srcdirs |> List.map listup_sources_in_directory |> List.concat in let abspaths_test = testdirs |> List.map listup_sources_in_directory |> List.concat in let baresrcs = abspaths_src |> List.map read_source in let baretests = if requires_tests then abspaths_test |> List.map read_source else [] in let (baremain, bareauxs) = separate_main_module config baresrcs in let (resolved_auxs, resolved_tests) = resolve_dependency ~aux:bareauxs ~main:baremain ~test:baretests in let spkgname = let pkgname = config.package_name in match OutputIdentifier.space_of_package_name pkgname with | Some(spkgname) -> spkgname | None -> raise (ConfigError(InvalidPackageName(pkgname))) in { space_name = spkgname; aux_modules = resolved_auxs; main_module = baremain; test_modules = resolved_tests; } ================================================ FILE: src/sourceLoader.mli ================================================ open MyUtil open Syntax open Errors exception SyntaxError of syntax_error type loaded_module = { source_path : absolute_path; module_identifier : module_name ranged; signature : untyped_signature option; module_content : untyped_module; dependencies : (module_name ranged) list; } type loaded_package = { space_name : space_name; aux_modules : loaded_module list; main_module : loaded_module; test_modules : loaded_module list; } val single : absolute_path -> loaded_module (** Receiving an absolute path [p] to a single source file, [single p] loads the source file. May raise [ConfigError(_)] or [SyntaxError(_)]. *) val main : requires_tests:bool -> ConfigLoader.config -> loaded_package (** Receiving a package configuration value [config], [main config] loads all the source files constituting the package into modules, and returns [pkg] where: {ul {- [pkg.space_name] is the space name corresponding to the name of the package;} {- [pkg.submodules] is the list of loaded submodules sorted by a topological order that reflects the dependency between modules; and} {- [pkg.main_module] is the main module of the package.}} May raise [ConfigError(_)] or [SyntaxError(_)]. *) ================================================ FILE: src/syntax.ml ================================================ open MyUtil module TupleList = List1 type module_name_output_spec = | SingleSnake | DottedCamels type output_spec = { module_name_output_spec : module_name_output_spec; } type package_name = string module ExternalMap = Map.Make(String) type external_map = absolute_dir ExternalMap.t type ('a, 'b) pure_or_effectful = | Pure of 'a | Effectful of 'b [@@deriving show { with_path = false; } ] type 'a cycle = | Loop of 'a | Cycle of 'a List2.t type 'a ranged = Range.t * 'a let pp_ranged ppsub ppf (_, x) = Format.fprintf ppf "%a" ppsub x type identifier = string type type_name = string [@@deriving show { with_path = false; } ] type kind_name = string [@@deriving show { with_path = false; } ] type constructor_name = string [@@deriving show { with_path = false; } ] type type_variable_name = string [@@deriving show { with_path = false; } ] type row_variable_name = string [@@deriving show { with_path = false; } ] type module_name = string [@@deriving show { with_path = false; } ] type signature_name = string [@@deriving show { with_path = false; } ] type label = string [@@deriving show { with_path = false; } ] module LabelAssoc : (sig include Map.S val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit end with type key = string) = struct module Impl = Map.Make(String) include Impl let pp ppsub ppf labmap = labmap |> Impl.iter (fun label v -> Format.fprintf ppf "%s -> %a; " label ppsub v ) end module LabelSet : (sig include Set.S val pp : Format.formatter -> t -> unit end with type elt = label) = struct module Impl = Set.Make(String) include Impl let pp ppf labset = labset |> Impl.iter (fun label -> Format.fprintf ppf "%s,@ " label ) end let pp_identifier ppf s = Format.fprintf ppf "\"%s\"" s let pp_uchar ppf uchar = Format.fprintf ppf "U+%X" (Uchar.to_int uchar) type module_name_chain = module_name ranged * (module_name ranged) list [@@deriving show { with_path = false; } ] type base_type = | IntType | FloatType | BoolType | UnitType | BinaryType | CharType [@@deriving show { with_path = false; } ] (* `format_*` are the types for representing format string literals. For the detail of format strings, see: http://erlang.org/doc/man/io.html *) type format_hole = | HoleC (* Characters. *) | HoleF (* `[-]ddd.ddd` for floating-point numbers. *) | HoleE (* `[-]d.ddde+-ddd` for floating-point numbers. *) | HoleG (* Same as `HoleF` for `[0.1, 10000)` and same as `HoleE` otherwise. *) | HoleS (* Strings. *) | HoleP | HoleW [@@deriving show {with_path = false; } ] type format_control = { field_width : int option; precision : int option; padding : char option; } [@@deriving show {with_path = false; } ] type format_element = | FormatTilde | FormatBreak | FormatDQuote | FormatConst of string | FormatHole of format_hole * format_control [@@deriving show {with_path = false; } ] type base_constant = | Unit | Bool of bool | Int of int | Float of float | BinaryByString of string | BinaryByInts of int list | String of string | Char of Uchar.t [@printer (fun ppf uchar -> Format.fprintf ppf "Char(%a)" pp_uchar uchar)] | FormatString of format_element list [@@deriving show { with_path = false; } ] type manual_kind = manual_kind_main ranged and manual_kind_main = | MKind of manual_base_kind list * manual_base_kind and manual_base_kind = manual_base_kind_main ranged and manual_base_kind_main = | MKindName of kind_name and manual_type = manual_type_main ranged and manual_type_main = | MTypeName of type_name * manual_type list | MFuncType of manual_domain_type * manual_type | MProductType of manual_type TupleList.t | MRecordType of manual_row | MEffType of manual_domain_type * manual_type * manual_type | MTypeVar of type_variable_name | MModProjType of untyped_module * type_name ranged * manual_type list | MPackType of untyped_signature and manual_domain_type = manual_type list * labeled_manual_type list * manual_row and manual_row = | MRow of (label ranged * manual_type) list * (Range.t * row_variable_name) option and binder = untyped_pattern * manual_type option and constructor_branch = | ConstructorBranch of attribute list * constructor_name ranged * manual_type list and synonym_or_variant = | BindSynonym of manual_type | BindVariant of constructor_branch list and untyped_ast = untyped_ast_main ranged and untyped_ast_main = | BaseConst of base_constant | Var of (module_name ranged) list * identifier ranged | Lambda of untyped_parameters * untyped_ast | LambdaEff of untyped_parameters * untyped_computation_ast | Apply of untyped_ast * untyped_arguments | If of untyped_ast * untyped_ast * untyped_ast | LetIn of rec_or_nonrec * untyped_ast | LetPatIn of untyped_pattern * untyped_ast * untyped_ast | Tuple of untyped_ast TupleList.t | ListNil | ListCons of untyped_ast * untyped_ast | Case of untyped_ast * untyped_case_branch list | Constructor of (module_name ranged) list * constructor_name * untyped_ast list | BinaryByList of (int ranged) list | Record of labeled_untyped_ast list | RecordAccess of untyped_ast * label ranged | RecordUpdate of untyped_ast * label ranged * untyped_ast | Freeze of Range.t * frozen_fun * untyped_ast list * Range.t list | FreezeUpdate of untyped_ast * untyped_ast list * Range.t list | Pack of module_name_chain * untyped_signature | Assert of untyped_ast and untyped_parameters = binder list * labeled_binder list * labeled_optional_binder list and untyped_computation_ast = untyped_computation_ast_main ranged and untyped_computation_ast_main = | CompDo of binder * untyped_computation_ast * untyped_computation_ast | CompReceive of untyped_receive_branch list * (untyped_ast * untyped_computation_ast) option | CompLetIn of rec_or_nonrec * untyped_computation_ast | CompLetPatIn of untyped_pattern * untyped_ast * untyped_computation_ast | CompIf of untyped_ast * untyped_computation_ast * untyped_computation_ast | CompCase of untyped_ast * untyped_computation_case_branch list | CompApply of untyped_ast * untyped_arguments and untyped_arguments = untyped_ast list * labeled_untyped_ast list * labeled_untyped_ast list and frozen_fun = | FrozenModFun of module_name_chain * identifier ranged | FrozenFun of identifier ranged and internal_or_external = | Internal of rec_or_nonrec | External of external_binding and rec_or_nonrec = | NonRec of untyped_let_binding | Rec of untyped_let_binding list and type_variable_binder = type_variable_name ranged * manual_base_kind option and external_binding = { ext_identifier : identifier ranged; ext_type_params : type_variable_binder list; ext_row_params : ((row_variable_name ranged) * (label ranged) list) list; ext_type_annot : manual_type; ext_arity : int; ext_has_option : bool; ext_code : string; } and untyped_let_binding = { vb_identifier : identifier ranged; vb_forall : type_variable_binder list; vb_forall_row : (row_variable_name ranged * (label ranged) list) list; vb_parameters : binder list; vb_mandatories : labeled_binder list; vb_optionals : labeled_optional_binder list; vb_return : (pure_return, effectful_return) pure_or_effectful; } and pure_return = manual_type option * untyped_ast and effectful_return = (manual_type * manual_type) option * untyped_computation_ast and untyped_receive_branch = | ReceiveBranch of untyped_pattern * untyped_computation_ast and untyped_case_branch = | CaseBranch of untyped_pattern * untyped_ast and untyped_computation_case_branch = | CompCaseBranch of untyped_pattern * untyped_computation_ast and untyped_pattern = untyped_pattern_main ranged [@printer (fun ppf (_, utpatmain) -> pp_untyped_pattern_main ppf utpatmain)] and untyped_pattern_main = | PUnit | PBool of bool | PInt of int | PBinary of string | PChar of Uchar.t [@printer (fun ppf uchar -> Format.fprintf ppf "PChar(%a)" pp_uchar uchar) ] | PVar of identifier | PWildCard | PListNil | PListCons of untyped_pattern * untyped_pattern | PTuple of untyped_pattern TupleList.t | PConstructor of (module_name ranged) list * constructor_name * untyped_pattern list [@@deriving show { with_path = false; } ] and untyped_module = untyped_module_main ranged and untyped_module_main = | ModVar of module_name | ModBinds of attribute list * module_name_chain list * untyped_binding list | ModProjMod of untyped_module * module_name ranged | ModFunctor of module_name ranged * untyped_signature * untyped_module | ModApply of module_name_chain * module_name_chain | ModCoerce of module_name ranged * untyped_signature and untyped_binding = untyped_binding_main ranged and untyped_binding_main = | BindVal of attribute list * internal_or_external | BindType of type_binding list | BindModule of module_name ranged * untyped_signature option * untyped_module | BindSig of signature_name ranged * untyped_signature | BindInclude of untyped_module and type_binding = type_name ranged * type_variable_binder list * synonym_or_variant and untyped_signature = untyped_signature_main ranged and untyped_signature_main = | SigVar of signature_name | SigPath of untyped_module * signature_name ranged | SigDecls of module_name_chain list * untyped_declaration list | SigFunctor of module_name ranged * untyped_signature * untyped_signature | SigWith of untyped_signature * (module_name ranged) list * type_binding list and untyped_declaration = untyped_declaration_main ranged and untyped_declaration_main = | DeclVal of identifier ranged * type_variable_binder list * (row_variable_name ranged * (label ranged) list) list * manual_type * attribute list | DeclTypeOpaque of type_name ranged * manual_kind option * attribute list | DeclModule of module_name ranged * untyped_signature * attribute list | DeclSig of signature_name ranged * untyped_signature * attribute list | DeclInclude of untyped_signature and labeled_binder = label ranged * binder and labeled_optional_binder = labeled_binder * untyped_ast option and labeled_untyped_ast = label ranged * untyped_ast and labeled_manual_type = label ranged * manual_type [@@deriving show { with_path = false; } ] and attribute = Attribute of (string * untyped_ast option) ranged type attribute_warning = { position : Range.t; tag : string; message : string; } module FreeRowID = struct include FreeID end module BoundRowID = struct include BoundID end module MustBeBoundRowID = struct include MustBeBoundID end module BoundBothID = struct type t = | Type of BoundID.t | Row of BoundRowID.t let hash = function | Type(bid) -> BoundID.hash bid | Row(brid) -> BoundRowID.hash brid let compare x1 x2 = match (x1, x2) with | (Type(bid1), Type(bid2)) -> BoundID.compare bid1 bid2 | (Row(brid1), Row(brid2)) -> BoundRowID.compare brid1 brid2 | (Type(_), Row(_)) -> 1 | (Row(_), Type(_)) -> -1 let equal x1 x2 = compare x1 x2 = 0 (* let pp ppf = function | Type(bid) -> BoundID.pp_raw ppf bid | Row(brid) -> BoundRowID.pp_raw ppf brid *) end module FreeIDHashTable = Hashtbl.Make(FreeID) module FreeRowIDHashTable = Hashtbl.Make(FreeRowID) module BoundIDHashTable = Hashtbl.Make(BoundID) module BoundRowIDHashTable = Hashtbl.Make(BoundRowID) module BoundIDMap = Map.Make(BoundID) type space_name = OutputIdentifier.space [@@deriving show { with_path = false; } ] type local_name = OutputIdentifier.local [@@deriving show { with_path = false; } ] type global_name = OutputIdentifier.global [@@deriving show { with_path = false; } ] type operator_name = OutputIdentifier.operator [@@deriving show { with_path = false; } ] type name = OutputIdentifier.t [@@deriving show { with_path = false; } ] module ConstructorMap = Map.Make(String) module TypeParameterAssoc = AssocList.Make(String) type type_parameter_assoc = MustBeBoundID.t TypeParameterAssoc.t module TypeParameterMap = Map.Make(String) type local_type_parameter_map = MustBeBoundID.t TypeParameterMap.t module RowParameterMap = Map.Make(String) module OpaqueIDMap = Map.Make(TypeID) let stringify_opaque_id_quantifier qt = OpaqueIDMap.fold (fun oid pkd acc -> Alist.extend acc (Format.asprintf "%a" (TypeID.pp ~seen_from:Address.root) oid) ) qt Alist.empty |> Alist.to_list |> List.map (fun s -> " " ^ s) |> String.concat "," let pp_opaque_id_quantifier ppf qt = Format.fprintf ppf "%s" (stringify_opaque_id_quantifier qt) module OpaqueIDHashTable = Hashtbl.Make(TypeID) module ValNameMap = Map.Make(String) module TypeNameMap = Map.Make(String) module ModuleNameMap = Map.Make(String) module SignatureNameMap = Map.Make(String) ================================================ FILE: src/typeConv.ml ================================================ open MyUtil open Syntax open Env let collect_ids_scheme (fidht : unit FreeIDHashTable.t) (fridht : LabelSet.t FreeRowIDHashTable.t) (bidht : unit BoundIDHashTable.t) (bridht : LabelSet.t BoundRowIDHashTable.t) = let aux_free_id (fid : FreeID.t) = if FreeIDHashTable.mem fidht fid then () else FreeIDHashTable.add fidht fid () in let aux_free_row_id (frid : FreeRowID.t) = if FreeRowIDHashTable.mem fridht frid then () else let labset = KindStore.get_free_row frid in FreeRowIDHashTable.add fridht frid labset in let aux_bound_id (bid : BoundID.t) = if BoundIDHashTable.mem bidht bid then () else BoundIDHashTable.add bidht bid () in let aux_bound_row_id (brid : BoundRowID.t) = if BoundRowIDHashTable.mem bridht brid then () else let labset = KindStore.get_bound_row brid in BoundRowIDHashTable.add bridht brid labset in let rec aux_mono ((_, tymain) : mono_type) : unit = match tymain with | BaseType(_) -> () | TypeVar(Updatable{contents = Link(ty)}) -> aux_mono ty | TypeVar(Updatable{contents = Free(fid)}) -> aux_free_id fid | TypeVar(MustBeBound(mbbid)) -> () | FuncType(domain, tycod) -> aux_mono_domain domain; aux_mono tycod | EffType(domain, eff, ty0) -> aux_mono_domain domain; aux_mono_effect eff; aux_mono ty0 | PidType(pidty) -> aux_mono_pid_type pidty | ProductType(tys) -> tys |> TupleList.to_list |> List.iter aux_mono | RecordType(row) -> aux_mono_row row | TypeApp(tyid, tyargs) -> tyargs |> List.iter aux_mono | PackType(_absmodsig) -> () (* TODO: traverse signatures *) and aux_poly ((_, ptymain) : poly_type) : unit = match ptymain with | BaseType(_) -> () | TypeVar(ptv) -> begin match ptv with | Mono(Updatable{contents = Link(ty)}) -> aux_mono ty | Mono(Updatable{contents = Free(fid)}) -> aux_free_id fid | Mono(MustBeBound(_)) -> () | Bound(bid) -> aux_bound_id bid end | FuncType(pdomain, ptycod) -> aux_poly_domain pdomain; aux_poly ptycod | EffType(pdomain, peff, pty0) -> aux_poly_domain pdomain; aux_poly_effect peff; aux_poly pty0 | PidType(ppidty) -> aux_poly_pid_type ppidty | ProductType(ptys) -> ptys |> TupleList.to_list |> List.iter aux_poly | RecordType(prow) -> aux_poly_row prow | TypeApp(tyid, ptyargs) -> ptyargs |> List.iter aux_poly | PackType(_absmodsig) -> () (* TODO: traverse signatures *) and aux_mono_label_assoc (labmap : mono_type LabelAssoc.t) : unit = LabelAssoc.iter (fun _ ty -> aux_mono ty) labmap and aux_poly_label_assoc (plabmap : poly_type LabelAssoc.t) : unit = LabelAssoc.iter (fun _ pty -> aux_poly pty) plabmap and aux_mono_domain (domain : mono_domain_type) : unit = domain.ordered |> List.iter aux_mono; aux_mono_label_assoc domain.mandatory; aux_mono_row domain.optional and aux_poly_domain (pdomain : poly_domain_type) : unit = pdomain.ordered |> List.iter aux_poly; aux_poly_label_assoc pdomain.mandatory; aux_poly_row pdomain.optional and aux_mono_effect (Effect(ty)) = aux_mono ty and aux_poly_effect (Effect(pty)) = aux_poly pty and aux_mono_pid_type (Pid(ty)) = aux_mono ty and aux_poly_pid_type (Pid(pty)) = aux_poly pty and aux_mono_row : mono_row -> unit = function | RowCons(_rlabel, ty, row) -> aux_mono ty; aux_mono_row row | RowVar(UpdatableRow{contents = LinkRow(row)}) -> aux_mono_row row | RowVar(UpdatableRow{contents = FreeRow(frid)}) -> aux_free_row_id frid | RowVar(MustBeBoundRow(mbbrid)) -> () | RowEmpty -> () and aux_poly_row : poly_row -> unit = function | RowCons(_rlabel, pty, prow) -> aux_poly pty; aux_poly_row prow | RowVar(MonoRow(prv)) -> begin match prv with | UpdatableRow{contents = LinkRow(row)} -> aux_mono_row row | UpdatableRow{contents = FreeRow(frid)} -> aux_free_row_id frid | MustBeBoundRow(_) -> () end | RowVar(BoundRow(brid)) -> aux_bound_row_id brid | RowEmpty -> () in (aux_mono, aux_poly) let collect_ids_mono (ty : mono_type) (dispmap : DisplayMap.t) : DisplayMap.t = let fidht = DisplayMap.make_free_id_hash_set dispmap in let fridht = DisplayMap.make_free_row_id_hash_set dispmap in let bidht = DisplayMap.make_bound_id_hash_set dispmap in let bridht = DisplayMap.make_bound_row_id_hash_set dispmap in let (aux_mono, _) = collect_ids_scheme fidht fridht bidht bridht in aux_mono ty; let dispmap = FreeIDHashTable.fold (fun fid () dispmap -> dispmap |> DisplayMap.add_free_id fid ) fidht dispmap in let dispmap = FreeRowIDHashTable.fold (fun frid labset dispmap -> dispmap |> DisplayMap.add_free_row_id frid labset ) fridht dispmap in dispmap let collect_ids_poly (pty : poly_type) (dispmap : DisplayMap.t) : DisplayMap.t = let fidht = DisplayMap.make_free_id_hash_set dispmap in let fridht = DisplayMap.make_free_row_id_hash_set dispmap in let bidht = DisplayMap.make_bound_id_hash_set dispmap in let bridht = DisplayMap.make_bound_row_id_hash_set dispmap in let (_, aux_poly) = collect_ids_scheme fidht fridht bidht bridht in aux_poly pty; let dispmap = FreeIDHashTable.fold (fun fid () dispmap -> dispmap |> DisplayMap.add_free_id fid ) fidht dispmap in let dispmap = FreeRowIDHashTable.fold (fun frid labset dispmap -> dispmap |> DisplayMap.add_free_row_id frid labset ) fridht dispmap in let dispmap = BoundIDHashTable.fold (fun bid () dispmap -> dispmap |> DisplayMap.add_bound_id bid ) bidht dispmap in let dispmap = BoundRowIDHashTable.fold (fun brid labset dispmap -> dispmap |> DisplayMap.add_bound_row_id brid labset ) bridht dispmap in dispmap let normalize_row_general : ('a, 'b) row -> ('a, 'b) normalized_row = fun prow -> let rec aux plabmap = function | RowCons((_, label), pty, prow) -> aux (plabmap |> LabelAssoc.add label pty) prow | RowVar(prv) -> NormalizedRow(plabmap, Some(prv)) | RowEmpty -> NormalizedRow(plabmap, None) in aux LabelAssoc.empty prow (* Normalizes the polymorphic row `prow`. Here, `MonoRow` is not supposed to occur in `prow`. *) let normalize_poly_row (prow : poly_row) : normalized_poly_row = normalize_row_general prow let normalize_mono_row (row : mono_row) : normalized_mono_row = let rec aux labmap = function | RowCons((_, label), ty, row) -> aux (labmap |> LabelAssoc.add label ty) row | RowVar(UpdatableRow{contents = LinkRow(row)}) -> aux labmap row | RowVar(rv) -> NormalizedRow(labmap, Some(rv)) | RowEmpty -> NormalizedRow(labmap, None) in aux LabelAssoc.empty row (* Arguments: - `levpred`: Given a level of free/must-be-bound ID, this predicate returns whether it should be bound or not. *) let lift_scheme (rngf : Range.t -> Range.t) (levpred : int -> bool) (ty : mono_type) : poly_type = let fidht = FreeIDHashTable.create 32 in let fridht = FreeRowIDHashTable.create 32 in let rec intern (fid : FreeID.t) : BoundID.t = match FreeIDHashTable.find_opt fidht fid with | Some(bid) -> bid | None -> let bid = BoundID.fresh () in FreeIDHashTable.add fidht fid bid; bid and intern_row (frid : FreeRowID.t) : BoundRowID.t = match FreeRowIDHashTable.find_opt fridht frid with | Some(brid) -> brid | None -> let brid = BoundRowID.fresh () in FreeRowIDHashTable.add fridht frid brid; let labset = KindStore.get_free_row frid in KindStore.register_bound_row brid labset; brid and aux_label_assoc (labmap : mono_type LabelAssoc.t) : poly_type LabelAssoc.t = LabelAssoc.fold (fun label ty plabmap -> let pty = aux ty in plabmap |> LabelAssoc.add label pty ) labmap LabelAssoc.empty and aux_domain (domain : mono_domain_type) : poly_domain_type = let {ordered = tydoms; mandatory = mndlabmap; optional = optrow} = domain in let ptydoms = tydoms |> List.map aux in let pmndlabmap = aux_label_assoc mndlabmap in let poptrow = aux_row optrow in {ordered = ptydoms; mandatory = pmndlabmap; optional = poptrow} and aux ((rng, tymain) : mono_type) : poly_type = match tymain with | BaseType(bty) -> let pty = (rngf rng, BaseType(bty)) in pty | TypeVar(Updatable{contents = Link(ty)}) -> aux ty | TypeVar(Updatable{contents = Free(fid)} as mtv) -> let ptv = if levpred (FreeID.get_level fid) then let bid = intern fid in Bound(bid) else Mono(mtv) in (rngf rng, TypeVar(ptv)) | TypeVar(MustBeBound(mbbid) as mtv) -> let ptv = if levpred (MustBeBoundID.get_level mbbid) then let bid = MustBeBoundID.to_bound mbbid in Bound(bid) else Mono(mtv) in (rngf rng, TypeVar(ptv)) | FuncType(domain, tycod) -> let pdomain = aux_domain domain in let ptycod = aux tycod in (rngf rng, FuncType(pdomain, ptycod)) | EffType(domain, eff, ty0) -> let pdomain = aux_domain domain in let peff = aux_effect eff in let pty0 = aux ty0 in (rngf rng, EffType(pdomain, peff, pty0)) | PidType(pidty) -> let ppidty = aux_pid_type pidty in (rngf rng, PidType(ppidty)) | ProductType(tys) -> let ptys = tys |> TupleList.map aux in (rngf rng, ProductType(ptys)) | RecordType(row) -> let prow = aux_row row in (rngf rng, RecordType(prow)) | TypeApp(tyid, tyargs) -> let ptyargs = tyargs |> List.map aux in (rngf rng, TypeApp(tyid, ptyargs)) | PackType(absmodsig) -> (rngf rng, PackType(absmodsig)) and aux_effect (Effect(ty)) = let pty = aux ty in Effect(pty) and aux_pid_type (Pid(ty)) = let pty = aux ty in Pid(pty) and aux_row : mono_row -> poly_row = function | RowCons(rlabel, ty, row) -> let pty = aux ty in let prow = aux_row row in RowCons(rlabel, pty, prow) | RowVar(UpdatableRow{contents = LinkRow(row)}) -> aux_row row | RowVar((UpdatableRow{contents = FreeRow(frid)}) as mrv) -> if levpred (FreeRowID.get_level frid) then let brid = intern_row frid in RowVar(BoundRow(brid)) else RowVar(MonoRow(mrv)) | RowVar(MustBeBoundRow(mbbrid)) -> if levpred (MustBeBoundRowID.get_level mbbrid) then let brid = MustBeBoundRowID.to_bound mbbrid in RowVar(BoundRow(brid)) (* We do not need to register a kind to `KindStore`, since it has been done when `mbbrid` was created. *) else RowVar(MonoRow(MustBeBoundRow(mbbrid))) | RowEmpty -> RowEmpty in aux ty (* `generalize lev ty` transforms a monotype `ty` into a polytype by binding type variables the level of which is higher than `lev`. *) let generalize (lev : int) (ty : mono_type) : poly_type = lift_scheme (fun _ -> Range.dummy "erased") (fun levx -> lev < levx) ty (* `lift` projects monotypes into polytypes without binding any type variables. *) let lift (ty : mono_type) : poly_type = lift_scheme (fun rng -> rng) (fun _ -> false) ty let instantiate_scheme : 'a 'b. (Range.t -> poly_type_var -> ('a, 'b) typ) -> (poly_row_var -> 'b) -> poly_type -> ('a, 'b) typ = fun intern intern_row pty -> let rec aux (rng, ptymain) = match ptymain with | BaseType(bty) -> (rng, BaseType(bty)) | TypeVar(ptv) -> intern rng ptv | FuncType(pdomain, ptycod) -> let domain = aux_domain pdomain in let tycod = aux ptycod in (rng, FuncType(domain, tycod)) | EffType(pdomain, peff, pty0) -> let domain = aux_domain pdomain in let eff = aux_effect peff in let ty0 = aux pty0 in (rng, EffType(domain, eff, ty0)) | PidType(ppidty) -> let pidty = aux_pid_type ppidty in (rng, PidType(pidty)) | ProductType(ptys) -> let tys = ptys |> TupleList.map aux in (rng, ProductType(tys)) | RecordType(prow) -> let row = aux_row prow in (rng, RecordType(row)) | TypeApp(tyid, ptyargs) -> (rng, TypeApp(tyid, ptyargs |> List.map aux)) | PackType(absmodsig) -> (rng, PackType(absmodsig)) and aux_row = function | RowCons(rlabel, pty, prow) -> let ty = aux pty in let row = aux_row prow in RowCons(rlabel, ty, row) | RowVar(prv) -> RowVar(intern_row prv) | RowEmpty -> RowEmpty and aux_domain pdomain = let {ordered = ptydoms; mandatory = pmndlabmap; optional = poptrow} = pdomain in let tydoms = ptydoms |> List.map aux in let mndlabmap = pmndlabmap |> LabelAssoc.map aux in let optrow = aux_row poptrow in {ordered = tydoms; mandatory = mndlabmap; optional = optrow} and aux_effect (Effect(pty)) = let ty = aux pty in Effect(ty) and aux_pid_type (Pid(pty)) = let ty = aux pty in Pid(ty) in aux pty let instantiate_by_hash_table bidht bridht (lev : int) (pty : poly_type) : mono_type = let rec intern (rng : Range.t) (ptv : poly_type_var) : mono_type = match ptv with | Mono(mtv) -> (rng, TypeVar(mtv)) | Bound(bid) -> let mtv = match BoundIDHashTable.find_opt bidht bid with | Some(mtvu) -> Updatable(mtvu) | None -> let fid = FreeID.fresh ~message:"instantiate, intern" lev in let mtvu = ref (Free(fid)) in BoundIDHashTable.add bidht bid mtvu; Updatable(mtvu) in (rng, TypeVar(mtv)) and intern_row (prv : poly_row_var) : mono_row_var = match prv with | MonoRow(mrv) -> mrv | BoundRow(brid) -> begin match BoundRowIDHashTable.find_opt bridht brid with | Some(mrvu) -> UpdatableRow(mrvu) | None -> let labset = KindStore.get_bound_row brid in let frid = FreeRowID.fresh ~message:"instantiate, intern_row" lev in KindStore.register_free_row frid labset; let mrvu = ref (FreeRow(frid)) in UpdatableRow(mrvu) end and aux pty = instantiate_scheme intern intern_row pty in aux pty let instantiate (lev : int) (pty : poly_type) = let bidht = BoundIDHashTable.create 32 in let bridht = BoundRowIDHashTable.create 32 in (* Hash tables are created at every (non-partial) call of `instantiate`. *) instantiate_by_hash_table bidht bridht lev pty let make_bound_to_free_hash_table bidht bridht (lev : int) (typarams : BoundID.t list) : mono_type list = let tyargacc = typarams |> List.fold_left (fun tyargacc bid -> let mtv = match BoundIDHashTable.find_opt bidht bid with | Some(mtvu) -> Updatable(mtvu) | None -> let fid = FreeID.fresh ~message:"make_bound_to_free_hash_table" lev in let mtvu = ref (Free(fid)) in BoundIDHashTable.add bidht bid mtvu; Updatable(mtvu) in let ty = (Range.dummy "constructor-arg", TypeVar(mtv)) in (* Format.printf "BTOF L%d %a\n" lev pp_mono_type ty; (* for debug *) *) Alist.extend tyargacc ty ) Alist.empty in Alist.to_list tyargacc let instantiate_type_arguments (lev : int) (typarams : BoundID.t list) (ptys : poly_type list) : mono_type list * mono_type list = let bidht = BoundIDHashTable.create 32 in let bridht = BoundRowIDHashTable.create 32 in let tyargs = make_bound_to_free_hash_table bidht bridht lev typarams in let tys_expected = ptys |> List.map (instantiate_by_hash_table bidht bridht lev) in (tyargs, tys_expected) let substitute_mono_type (substmap : mono_type BoundIDMap.t) : poly_type -> mono_type = let intern (rng : Range.t) (ptv : poly_type_var) : mono_type = match ptv with | Mono(mtv) -> (rng, TypeVar(mtv)) | Bound(bid) -> begin match substmap |> BoundIDMap.find_opt bid with | None -> assert false | Some(ty) -> ty end in let intern_row (prv : poly_row_var) = failwith "TODO: substitute_mono_type, intern_row" in instantiate_scheme intern intern_row let substitute_poly_type (substmap : poly_type BoundIDMap.t) : poly_type -> poly_type = let intern (rng : Range.t) (ptv : poly_type_var) : poly_type = match ptv with | Mono(_) -> (rng, TypeVar(ptv)) | Bound(bid) -> begin match substmap |> BoundIDMap.find_opt bid with | None -> assert false | Some(pty) -> pty end in let intern_row (prv : poly_row_var) = failwith "TODO: substitute_poly_type, intern_row" in instantiate_scheme intern intern_row let apply_type_scheme_mono ((bids, pty_body) : type_scheme) (tyargs : mono_type list) : mono_type option = try let substmap = List.fold_left2 (fun substmap bid tyarg -> substmap |> BoundIDMap.add bid tyarg ) BoundIDMap.empty bids tyargs in Some(substitute_mono_type substmap pty_body) with | Invalid_argument(_) -> None let apply_type_scheme_poly ((bids, pty_body) : type_scheme) (ptyargs : poly_type list) : poly_type option = try let substmap = List.fold_left2 (fun substmap bid ptyarg -> substmap |> BoundIDMap.add bid ptyarg ) BoundIDMap.empty bids ptyargs in Some(substitute_poly_type substmap pty_body) with | Invalid_argument(_) -> None let make_opaque_type_scheme (bids : BoundID.t list) (tyid : TypeID.t) : type_scheme = let dr = Range.dummy "make_opaque_type_scheme" in let ptyargs = bids |> List.map (fun bid -> (dr, TypeVar(Bound(bid)))) in (bids, (dr, TypeApp(tyid, ptyargs))) let make_opaque_type_scheme_from_base_kinds (bkds : base_kind list) (tyid : TypeID.t) : type_scheme = let bids = bkds |> List.map (fun _bkd -> BoundID.fresh ()) in make_opaque_type_scheme bids tyid let get_opaque_type ((bids, pty_body, _) : type_scheme_with_entity) : TypeID.t option = match pty_body with | (_, TypeApp(tyid, ptyargs)) -> begin match List.combine bids ptyargs with | exception Invalid_argument(_) -> None | zipped -> if zipped |> List.for_all (fun (bid, ptyarg) -> match ptyarg with | (_, TypeVar(Bound(bid0))) -> BoundID.equal bid bid0 | _ -> false ) then Some(tyid) else None end | _ -> None let overwrite_range_of_type (rng : Range.t) (_, tymain) = (rng, tymain) let rec can_row_take_optional : mono_row -> bool = function | RowCons(_, _, _) -> true | RowVar(UpdatableRow{contents = FreeRow(frid)}) -> false | RowVar(UpdatableRow{contents = LinkRow(row)}) -> can_row_take_optional row | RowVar(MustBeBoundRow(mbbrid)) -> false | RowEmpty -> false let rec kind_of_arity n = let bkddoms = List.init n (fun _ -> TypeKind) in Kind(bkddoms, TypeKind) let rec arity_of_kind = function Kind(bkddoms, _) -> List.length bkddoms (* Omit redundant structures of the given type. *) let rec canonicalize_root = function | (_, TypeVar(Updatable({contents = Link(ty)}))) -> canonicalize_root ty | ty -> ty type display_spec = { token : string -> string; arrow : string; paren : string -> string; bracket : string -> string; angle : string -> string; } let display_spec_tty = { token = (fun s -> s); arrow = "->"; paren = (fun s -> Printf.sprintf "(%s)" s); bracket = (fun s -> Printf.sprintf "[%s]" s); angle = (fun s -> Printf.sprintf "<%s>" s); } let display_spec_html = { token = (fun s -> Printf.sprintf "%s" s); arrow = "->"; paren = (fun s -> Printf.sprintf "(%s)" s); bracket = (fun s -> Printf.sprintf "[%s]" s); angle = (fun s -> Printf.sprintf "<%s>" s); } let show_base_type = function | UnitType -> "unit" | BoolType -> "bool" | IntType -> "int" | FloatType -> "float" | BinaryType -> "binary" | CharType -> "char" let 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 = fun ~prefix:prefix ~suffix:suffix spec seen_from showtv showrv labmap -> if LabelAssoc.cardinal labmap = 0 then None else let s = LabelAssoc.fold (fun label ty acc -> let sty = show_type spec seen_from showtv showrv ty in Alist.extend acc (prefix ^ label ^ suffix ^ " " ^ sty) ) labmap Alist.empty |> Alist.to_list |> String.concat ", " in Some(s) and show_domain : 'a 'b. display_spec -> Address.t -> ('a -> string) -> ('b -> string option) -> ('a, 'b) domain_type -> string = fun spec seen_from showtv showrv domain -> let sdoms = domain.ordered |> List.map (show_type spec seen_from showtv showrv) in let sdomscat = String.concat ", " sdoms in let is_ord_empty = (sdoms = []) in let (is_mnds_empty, smnds) = match show_label_assoc ~prefix:"-" ~suffix:"" spec seen_from showtv showrv domain.mandatory with | None -> (true, "") | Some(s) -> (false, s) in let (is_opts_empty, sopts) = match show_row ~prefix:"?" ~suffix:"" spec seen_from showtv showrv domain.optional with | None -> (true, "") | Some(s) -> (false, s) in let smid1 = if is_ord_empty then "" else if is_mnds_empty && is_opts_empty then "" else ", " in let smid2 = if is_mnds_empty || is_opts_empty then "" else if is_ord_empty then "" else ", " in Printf.sprintf "%s%s%s%s%s" sdomscat smid1 smnds smid2 sopts and show_type : 'a 'b. display_spec -> Address.t -> ('a -> string) -> ('b -> string option) -> ('a, 'b) typ -> string = fun spec seen_from showtv showrv ty -> let rec aux (_, tymain) = match tymain with | BaseType(bty) -> show_base_type bty | FuncType(domain, tycod) -> let sdom = show_domain spec seen_from showtv showrv domain in let scod = aux tycod in Printf.sprintf "%s%s %s %s" (spec.token "fun") (spec.paren sdom) spec.arrow scod | EffType(domain, eff, ty0) -> let sdom = show_domain spec seen_from showtv showrv domain in let seff = aux_effect eff in let s0 = aux ty0 in Printf.sprintf "%s%s %s %s%s" (spec.token "fun") (spec.paren sdom) spec.arrow seff s0 | PidType(pidty) -> let spid = aux_pid_type pidty in Printf.sprintf "pid%s" (spec.angle spid) | TypeVar(tv) -> showtv tv | ProductType(tys) -> let ss = tys |> TupleList.to_list |> List.map aux in Printf.sprintf "{%s}" (String.concat ", " ss) | RecordType(row) -> begin match show_row ~prefix:"" ~suffix:" :" spec seen_from showtv showrv row with | None -> "{}" | Some(s) -> Printf.sprintf "{%s}" s end | TypeApp(tyid, tyargs) -> begin match tyargs with | [] -> Format.asprintf "%a" (TypeID.pp ~seen_from) tyid | _ :: _ -> let ss = tyargs |> List.map aux in Format.asprintf "%a%s" (TypeID.pp ~seen_from) tyid (spec.angle (String.concat ", " ss)) end | PackType(_absmodsig) -> "(signature)" (* TODO: show signatures *) and aux_effect (Effect(ty)) = let s = aux ty in spec.bracket s and aux_pid_type (Pid(ty)) = aux ty in aux ty and show_row : 'a 'b. prefix:string -> suffix:string -> display_spec -> Address.t -> ('a -> string) -> ('b -> string option) -> ('a, 'b) row -> string option = fun ~prefix ~suffix spec seen_from showtv showrv row -> let NormalizedRow(labmap, rowvar_opt) = normalize_row_general row in let smain_opt = labmap |> show_label_assoc ~prefix ~suffix spec seen_from showtv showrv in let svar_opt = match rowvar_opt with | Some(rv) -> showrv rv | None -> None in match (smain_opt, svar_opt) with | (Some(smain), Some(svar)) -> Some(Printf.sprintf "%s, %s" smain svar) | (Some(smain), None) -> Some(smain) | (None, Some(svar)) -> Some(svar) | (None, None) -> None and show_mono_type_var (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) (mtv : mono_type_var) : string = match mtv with | MustBeBound(mbbid) -> Format.asprintf "%a" MustBeBoundID.pp_rich mbbid | Updatable(mtvu) -> show_mono_type_var_updatable spec seen_from dispmap !mtvu and show_mono_type_var_updatable (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) (mtvu : mono_type_var_updatable) : string = match mtvu with | Link(ty) -> show_type spec seen_from (show_mono_type_var spec seen_from dispmap) (show_mono_row_var spec seen_from dispmap) ty | Free(fid) -> dispmap |> DisplayMap.find_free_id fid and show_mono_row_var (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) (mrv : mono_row_var) : string option = match mrv with | UpdatableRow(mrvu) -> show_mono_row_var_updatable spec seen_from dispmap !mrvu | MustBeBoundRow(mbbrid) -> Some(Format.asprintf "%a" MustBeBoundRowID.pp_rich mbbrid) and show_mono_row_var_updatable (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) (mrvu : mono_row_var_updatable) : string option = match mrvu with | LinkRow(row) -> show_row ~prefix:"?" ~suffix:"" spec seen_from (show_mono_type_var spec seen_from dispmap) (show_mono_row_var spec seen_from dispmap) row | FreeRow(frid) -> let s = dispmap |> DisplayMap.find_free_row_id frid in Some(s) let show_mono_type ?(spec : display_spec = display_spec_tty) ?(seen_from : Address.t = Address.root) (dispmap : DisplayMap.t) : mono_type -> string = show_type spec seen_from (show_mono_type_var spec seen_from dispmap) (show_mono_row_var spec seen_from dispmap) let 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 = show_row ~prefix ~suffix spec seen_from (show_mono_type_var spec seen_from dispmap) (show_mono_row_var spec seen_from dispmap) let pp_mono_type ?(spec : display_spec = display_spec_tty) dispmap ppf ty = Format.fprintf ppf "%s" (show_mono_type ~spec dispmap ty) let pp_mono_row ?(spec : display_spec = display_spec_tty) dispmap ppf row = Format.fprintf ppf "%s" (Option.value ~default:"(empty)" (show_mono_row ~prefix:"" ~suffix:"" ~spec dispmap row)) let rec show_poly_type_var (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) = function | Bound(bid) -> dispmap |> DisplayMap.find_bound_id bid | Mono(mtv) -> show_mono_type_var spec seen_from dispmap mtv and show_poly_row_var (spec : display_spec) (seen_from : Address.t) (dispmap : DisplayMap.t) = function | BoundRow(brid) -> Some(dispmap |> DisplayMap.find_bound_row_id brid) | MonoRow(mrv) -> show_mono_row_var spec seen_from dispmap mrv and show_poly_type ?(spec : display_spec = display_spec_tty) ?(seen_from : Address.t = Address.root) (dispmap : DisplayMap.t) : poly_type -> string = show_type spec seen_from (show_poly_type_var spec seen_from dispmap) (show_poly_row_var spec seen_from dispmap) let show_poly_row ?(spec : display_spec = display_spec_tty) ?(seen_from : Address.t = Address.root) (dispmap : DisplayMap.t) : poly_row -> string option = show_row ~prefix:"" ~suffix:"" spec seen_from (show_poly_type_var spec seen_from dispmap) (show_poly_row_var spec seen_from dispmap) let 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 = Format.fprintf ppf "%s" (show_poly_type ~spec ~seen_from dispmap pty) let show_bound_type_ids (dispmap : DisplayMap.t) = dispmap |> DisplayMap.fold_bound_id (fun bid sb acc -> Alist.extend acc (Printf.sprintf "%s :: o" sb) ) Alist.empty |> Alist.to_rev_list let show_bound_row_ids (dispmap : DisplayMap.t) = dispmap |> DisplayMap.fold_bound_row_id (fun brid (sb, labset) acc -> let skd = labset |> LabelSet.elements |> String.concat ", " in Alist.extend acc (Printf.sprintf "%s :: (%s)" sb skd) ) Alist.empty |> Alist.to_rev_list let show_base_kind (bkd : base_kind) : string = match bkd with | TypeKind -> "o" | RowKind(labset) -> Printf.sprintf "(%s)" (labset |> LabelSet.elements |> String.concat ", ") let show_kind (kd : kind) : string = let Kind(bkddoms, bkdcod) = kd in let sdoms = bkddoms |> List.map show_base_kind in let scod = show_base_kind bkdcod in match sdoms with | [] -> scod | _ :: _ -> Printf.sprintf "(%s) -> %s" (String.concat ", " sdoms) scod let pp_debug_poly_type ~(raw : bool) (ppf : Format.formatter) (pty : poly_type) : unit = let dispmap = if raw then DisplayMap.empty else DisplayMap.empty |> collect_ids_poly pty in let ss1 = show_bound_type_ids dispmap in let ss2 = show_bound_row_ids dispmap in let s3 = show_poly_type dispmap pty in Format.fprintf ppf "<%s> <%s> %s" (String.concat ", " ss1) (String.concat ", " ss2) s3 let pp_debug_mono_type ~(raw : bool) (ppf : Format.formatter) (ty : mono_type) : unit = let dispmap = if raw then DisplayMap.empty else DisplayMap.empty |> collect_ids_mono ty in let s = show_mono_type dispmap ty in Format.printf "%s" s ================================================ FILE: src/typeID.ml ================================================ type t = { number : int; address : Address.t; name : string; } let fresh = let current_max = ref 0 in (fun (address : Address.t) (name : string) -> incr current_max; { number = !current_max; address = address; name = name; } ) let hash tyid = tyid.number let compare tyid1 tyid2 = tyid2.number - tyid1.number let equal tyid1 tyid2 = tyid1.number = tyid2.number let name tyid = tyid.name let address tyid = tyid.address let pp (ppf : Format.formatter) ?(seen_from : Address.t = Address.root) (tyid : t) = let address = Address.subtract ~long:tyid.address ~short:seen_from in Format.fprintf ppf "%s%s" (Address.show address) tyid.name let pp_raw (ppf : Format.formatter) (tyid : t) = Format.fprintf ppf "%s/%d" tyid.name tyid.number ================================================ FILE: src/typeID.mli ================================================ type t val fresh : Address.t -> string -> t val hash : t -> int val compare : t -> t -> int val equal : t -> t -> bool val name : t -> string val address : t -> Address.t val pp : Format.formatter -> ?seen_from:Address.t -> t -> unit val pp_raw : Format.formatter -> t -> unit ================================================ FILE: src/typechecker.ml ================================================ open MyUtil open Syntax open IntermediateSyntax open Env open Errors exception TypeError of type_error module BindingMap = Map.Make(String) module SubstMap = Map.Make(TypeID) type substitution = type_scheme_with_entity SubstMap.t type type_intern = BoundID.t -> poly_type -> bool type row_intern = BoundRowID.t -> normalized_poly_row -> bool type subtyping_error = unit type binding_map = (mono_type * local_name * Range.t) BindingMap.t type variant_definition = type_name * TypeID.t * BoundID.t list * constructor_map type rec_morph = | MonoRec of mono_type | PolyRec of poly_type type pre = { level : int; tyenv : Typeenv.t; local_type_parameters : local_type_parameter_map; local_row_parameters : local_row_parameter_map; } module GlobalNameMap = Map.Make(OutputIdentifier.Global) module SynonymNameSet = Set.Make(String) module SynonymNameHashSet = Hashtbl.Make( struct type t = type_name let equal = String.equal let hash = Hashtbl.hash end) let raise_error e = raise (TypeError(e)) let merge_quantifier (quant1 : quantifier) (quant2 : quantifier) : quantifier = OpaqueIDMap.union (fun _ pkd1 _pkd2 -> Some(pkd1)) quant1 quant2 let internbidf (bidmap : BoundID.t BoundIDMap.t) (bid1 : BoundID.t) (pty2 : poly_type) : bool = match pty2 with | (_, TypeVar(Bound(bid2))) -> begin match bidmap |> BoundIDMap.find_opt bid1 with | None -> false | Some(bid) -> BoundID.equal bid bid2 end | _ -> false let internbridf (_bidmap : BoundID.t BoundIDMap.t) (_brid1 : BoundRowID.t) (_nomrow2 : normalized_poly_row) : bool = (* TODO: implement this when type definitions become able to take row parameters *) false let add_dummy_fold (tynm : type_name) (tyid : TypeID.t) (bids : BoundID.t list) (ctormap : constructor_map) (sigr : SigRecord.t) : SigRecord.t = let bid = BoundID.fresh () in let dr = Range.dummy "add_dummy_fold" in let plabmap = ConstructorMap.fold (fun ctornm (_ctorid, ptyargs) plabmap -> let domty = { ordered = ptyargs; mandatory = LabelAssoc.empty; optional = RowEmpty; } in plabmap |> LabelAssoc.add ctornm (dr, FuncType(domty, (dr, TypeVar(Bound(bid))))) ) ctormap LabelAssoc.empty in let domty = { ordered = [(dr, TypeApp(tyid, bids |> List.map (fun bid -> (dr, TypeVar(Bound(bid))))))]; mandatory = plabmap; optional = RowEmpty; } in let pty = (dr, FuncType(domty, (dr, TypeVar(Bound(bid))))) in sigr |> SigRecord.add_dummy_fold tynm pty let add_constructor_definitions (ctordefs : variant_definition list) (sigr : SigRecord.t) : SigRecord.t = ctordefs |> List.fold_left (fun sigr ctordef -> let (tynm, tyid, bids, ctorbrmap) = ctordef in let sigr = ConstructorMap.fold (fun ctornm (ctorid, ptyargs) sigr -> let centry = { belongs = tyid; constructor_id = ctorid; type_variables = bids; parameter_types = ptyargs; } in sigr |> SigRecord.add_constructor ctornm centry ) ctorbrmap sigr in sigr |> add_dummy_fold tynm tyid bids ctorbrmap ) sigr let make_type_scheme_from_constructor_entry (centry : constructor_entry) : type_scheme = let { belongs = tyid; type_variables = bids; parameter_types = ptys; _ } = centry in let dr = Range.dummy "make_type_scheme_from_constructor_entry" in let domty = { ordered = ptys; mandatory = LabelAssoc.empty; optional = RowEmpty; } in let ty_cod = (dr, TypeApp(tyid, bids |> List.map (fun bid -> (dr, TypeVar(Bound(bid)))))) in (bids, (dr, FuncType(domty, ty_cod))) let make_address_module_list (address : Address.t) : module_name list = address |> Address.to_list |> List.fold_left (fun opt adelem -> match (opt, adelem) with | (Some(acc), Address.Member(modnm)) -> Some(Alist.extend acc modnm) | _ -> None ) (Some(Alist.empty)) |> Option.value ~default:Alist.empty |> Alist.to_list let get_module_name_chain_position (modchain : module_name_chain) : Range.t = let ((rngL, _), projs) = modchain in match List.rev projs with | [] -> rngL | (rngR, _) :: _ -> Range.unite rngL rngR let binding_map_union rng = BindingMap.union (fun x _ _ -> raise_error (BoundMoreThanOnceInPattern(rng, x)) ) let get_dependency_on_synonym_types (vertices : SynonymNameSet.t) (pre : pre) (mty : manual_type) : SynonymNameSet.t = let hashset = SynonymNameHashSet.create 32 in (* A hash set is created on every (non-partial) call. *) let register_if_needed (tynm : type_name) : unit = if vertices |> SynonymNameSet.mem tynm then SynonymNameHashSet.add hashset tynm () else () in let rec aux ((_, mtymain) : manual_type) : unit = match mtymain with | MTypeName(tynm, mtyargs) -> List.iter aux mtyargs; register_if_needed tynm | MFuncType((mtydoms, mndlabmtys, mrow), mtycod) -> aux_labeled_list mndlabmtys; aux_row mrow; aux mtycod | MProductType(mtys) -> mtys |> TupleList.to_list |> List.iter aux | MRecordType(mrow) -> aux_row mrow | MEffType((mtydoms, mndlabmtys, mrow), mty1, mty2) -> aux_labeled_list mndlabmtys; aux_row mrow; List.iter aux mtydoms; aux mty1; aux mty2 | MTypeVar(typaram) -> () | MModProjType(utmod1, tyident2, mtyargs) -> () | MPackType(utsig) -> aux_signature utsig and aux_labeled_list (labmtys : labeled_manual_type list) : unit = labmtys |> List.iter (fun (_, mty) -> aux mty) and aux_row (mrow : manual_row) : unit = match mrow with | MRow(optlabmtys, _) -> aux_labeled_list optlabmtys and aux_signature (utsig : untyped_signature) : unit = () (* TODO: implement this or restrict the syntax of `pack` *) in aux mty; SynonymNameHashSet.fold (fun sid () set -> set |> SynonymNameSet.add sid ) hashset SynonymNameSet.empty let find_module (tyenv : Typeenv.t) ((rng, m) : module_name ranged) : module_entry = match tyenv |> Typeenv.find_module m with | None -> raise_error (UnboundModuleName(rng, m)) | Some(v) -> v let find_module_from_chain (tyenv : Typeenv.t) ((modident, projs) : module_name_chain) : module_entry = let init = find_module tyenv modident in let (rng, _) = modident in let (ret, _) = projs |> List.fold_left (fun (mentry, rng) proj -> let modsig = mentry.mod_signature in match modsig with | (_, ConcFunctor(_)) -> raise_error (NotOfStructureType(rng, modsig)) | (_, ConcStructure(sigr)) -> let (rngproj, modnm) = proj in begin match sigr |> SigRecord.find_module modnm with | None -> raise_error (UnboundModuleName(rngproj, modnm)) | Some(mentry) -> let (rng, _) = proj in (mentry, rng) end ) (init, rng) in ret let update_type_environment_by_signature_record (sigr : SigRecord.t) (tyenv : Typeenv.t) : Typeenv.t = sigr |> SigRecord.fold ~v:(fun x ventry tyenv -> let pty = ventry.val_type in let gname = ventry.val_global in tyenv |> Typeenv.add_value x pty (OutputIdentifier.Global(gname)) ) ~c:(fun ctornm centry tyenv -> tyenv |> Typeenv.add_constructor ctornm centry ) ~f:(fun _tynm _pty tyenv -> tyenv ) ~t:(fun tynm tentry tyenv -> tyenv |> Typeenv.add_type tynm tentry ) ~m:(fun modnm mentry tyenv -> tyenv |> Typeenv.add_module modnm mentry ) ~s:(fun signm absmodsig -> Typeenv.add_signature signm absmodsig ) tyenv let add_open_specs_to_type_environment (openspecs : module_name_chain list) (tyenv : Typeenv.t) : Typeenv.t = openspecs |> List.fold_left (fun tyenv openspec -> let mentry = find_module_from_chain tyenv openspec in let modsig = mentry.mod_signature in match modsig with | (_, ConcFunctor(_)) -> let rng0 = get_module_name_chain_position openspec in raise_error (NotOfStructureType(rng0, modsig)) | (_, ConcStructure(sigr)) -> tyenv |> update_type_environment_by_signature_record sigr ) tyenv let iapply (efun : ast) (mrow : mono_row) ((eargs, mndargmap, optargmap) : ast list * ast LabelAssoc.t * ast LabelAssoc.t) : ast = match efun with | IVar(name) -> IApply(name, mrow, eargs, mndargmap, optargmap) | _ -> let lname = OutputIdentifier.fresh () in ILetIn(lname, efun, IApply(OutputIdentifier.Local(lname), mrow, eargs, mndargmap, optargmap)) let ilambda ((ordipats, mndipatmap, optipatmap) : pattern list * pattern LabelAssoc.t * (pattern * ast option) LabelAssoc.t) (e0 : ast) : ast = ILambda(None, ordipats, mndipatmap, optipatmap, e0) let iletpatin (ipat : pattern) (e1 : ast) (e2 : ast) : ast = ICase(e1, [ IBranch(ipat, e2) ]) let iletrecin_single (_, _, name_outer, name_inner, e1) (e2 : ast) : ast = match e1 with | ILambda(None, ordnames, mndnamemap, optnamemap, e0) -> ILetIn(name_outer, ILambda(Some(name_inner), ordnames, mndnamemap, optnamemap, e0), e2) | _ -> assert false let iletrecin_multiple (binds : (identifier * poly_type * local_name * local_name * ast) List2.t) (e2 : ast) : ast = let (bind1, bind2, bindrest) = List2.decompose binds in let binds = TupleList.make bind1 (bind2 :: bindrest) in let ipat_inner_tuple = IPTuple(binds |> TupleList.map (fun (_, _, _, name_inner, _) -> IPVar(name_inner))) in let name_for_whole_rec = OutputIdentifier.fresh () in let tuple_entries = binds |> TupleList.map (fun (_, _, _name_outer, _name_inner, e1) -> match e1 with | ILambda(None, ordnames, mndnamemap, optnamemap, e0) -> ILambda(None, ordnames, mndnamemap, optnamemap, iletpatin ipat_inner_tuple (IApply(OutputIdentifier.Local(name_for_whole_rec), RowEmpty, [], LabelAssoc.empty, LabelAssoc.empty)) e0) | _ -> assert false ) in let ipat_outer_tuple = IPTuple(binds |> TupleList.map (fun (_, _, name_outer, _, _) -> IPVar(name_outer))) in iletpatin ipat_outer_tuple (iapply (ILambda(Some(name_for_whole_rec), [], LabelAssoc.empty, LabelAssoc.empty, ITuple(tuple_entries))) RowEmpty ([], LabelAssoc.empty, LabelAssoc.empty)) e2 let iletrecin (binds : (identifier * poly_type * local_name * local_name * ast) list) (e2 : ast) : ast = match binds with | [] -> assert false | [bind] -> iletrecin_single bind e2 | bind1 :: bind2 :: rest -> iletrecin_multiple (List2.make bind1 bind2 rest) e2 let occurs (fid : FreeID.t) (ty : mono_type) : bool = let lev = FreeID.get_level fid in let rec aux ((_, tymain) : mono_type) : bool = match tymain with | BaseType(_) -> false | FuncType(domain, tycod) -> let bdom = aux_domain domain in let bcod = aux tycod in bdom || bcod (* Must not be short-circuit due to the level inference. *) | ProductType(tys) -> tys |> TupleList.to_list |> aux_list | RecordType(row) -> aux_row row | TypeApp(_tyid, tyargs) -> aux_list tyargs | EffType(domain, eff, ty0) -> let bdom = aux_domain domain in let beff = aux_effect eff in let b0 = aux ty0 in bdom || beff || b0 (* Must not be short-circuit due to the level inference. *) | PidType(pidty) -> aux_pid_type pidty | TypeVar(Updatable{contents = Link(ty)}) -> aux ty | TypeVar(Updatable{contents = Free(fidx)}) -> if FreeID.equal fid fidx then true else begin FreeID.update_level fidx lev; (* Format.printf "LEVEL %a L%d --> L%d\n" FreeID.pp fidx (FreeID.get_level fidx) lev; (* for debug *) *) false end | TypeVar(MustBeBound(_)) -> false | PackType(_modsig) -> false (* Signatures do not contain free IDs. *) and aux_domain (domain : mono_domain_type) : bool = let {ordered = tydoms; mandatory = mndlabmap; optional = optrow} = domain in let b1 = aux_list tydoms in let bmnd = aux_label_assoc mndlabmap in let bopt = aux_row optrow in b1 || bmnd || bopt and aux_effect (Effect(ty)) = aux ty and aux_pid_type (Pid(ty)) = aux ty and aux_row = function | RowCons(_, ty, row) -> let b1 = aux ty in let b2 = aux_row row in b1 || b2 | RowVar(UpdatableRow{contents = FreeRow(_)}) -> false | RowVar(UpdatableRow{contents = LinkRow(row)}) -> aux_row row | RowVar(MustBeBoundRow(_)) -> false | RowEmpty -> false and aux_label_assoc (labmap : mono_type LabelAssoc.t) = LabelAssoc.fold (fun _ ty bacc -> let b = aux ty in b || bacc ) labmap false and aux_list (tys : mono_type list) : bool = tys |> List.map aux |> List.fold_left ( || ) false (* Must not be short-circuit due to the level inference *) in aux ty let occurs_row (frid : FreeRowID.t) (row : mono_row) : bool = let rec aux (_, tymain) = match tymain with | BaseType(_) -> false | FuncType(domain, tycod) -> let bdom = aux_domain domain in let bcod = aux tycod in bdom || bcod (* Must not be short-circuit due to the level inference. *) | PidType(pidty) -> aux_pid pidty | EffType(domain, effty, ty0) -> let bdom = aux_domain domain in let beff = aux_effect effty in let b0 = aux ty0 in bdom || beff || b0 (* Must not be short-circuit due to the level inference. *) | TypeVar(_) -> false | ProductType(tys) -> tys |> TupleList.to_list |> aux_list | RecordType(row) -> aux_row row | TypeApp(_tyid, tyargs) -> aux_list tyargs | PackType(_modsig) -> false (* Signatures do not contain free row IDs. *) and aux_domain (domain : mono_domain_type) = let {ordered = tydoms; mandatory = mndlabmap; optional = optrow} = domain in let b1 = aux_list tydoms in let bmnd = aux_label_assoc mndlabmap in let bopt = aux_row optrow in b1 || bmnd || bopt and aux_pid (Pid(ty)) = aux ty and aux_effect (Effect(ty)) = aux ty and aux_row = function | RowCons(_, ty, row) -> let b1 = aux ty in let b2 = aux_row row in b1 || b2 | RowVar(UpdatableRow{contents = LinkRow(row)}) -> aux_row row | RowVar(UpdatableRow{contents = FreeRow(fridx)}) -> FreeRowID.equal fridx frid | RowVar(MustBeBoundRow(_mbbrid)) -> false | RowEmpty -> false and aux_label_assoc (labmap : mono_type LabelAssoc.t) = LabelAssoc.fold (fun _ ty bacc -> let b = aux ty in bacc || b ) labmap false and aux_list tys = tys |> List.map aux |> List.fold_left ( || ) false (* Must not be short-circuit due to the level inference. *) in aux_row row let rec opaque_occurs_in_type_scheme : 'a 'b. (quantifier -> TypeID.t -> bool) -> ('a -> bool) -> quantifier -> ('a, 'b) typ -> bool = fun tyidp tvp quant -> let rec aux (_, ptymain) = match ptymain with | BaseType(_) -> false | PidType(typid) -> aux_pid typid | ProductType(tys) -> tys |> TupleList.to_list |> List.exists aux | EffType(domain, tyeff, tysub) -> aux_domain domain || aux_effect tyeff || aux tysub | FuncType(domain, tycod) -> aux_domain domain || aux tycod | TypeApp(tyid, tyargs) -> tyidp quant tyid || List.exists aux tyargs | RecordType(row) -> aux_row row | TypeVar(tv) -> tvp tv | PackType(absmodsig) -> let (_quant, modsig) = absmodsig in opaque_occurs quant modsig (* Strictly speaking, we should ensure that `quant` and `_quant` are disjoint. *) and aux_domain domain = let {ordered = tydoms; mandatory = mndlabmap; optional = optrow} = domain in List.exists aux tydoms || aux_label_assoc mndlabmap || aux_row optrow and aux_pid = function | Pid(ty) -> aux ty and aux_effect = function | Effect(ty) -> aux ty and aux_row = function | RowCons(_, ty, row) -> let b1 = aux ty in let b2 = aux_row row in b1 || b2 | RowVar(_) -> false | RowEmpty -> false and aux_label_assoc labmap = LabelAssoc.fold (fun _ ty bacc -> let b = aux ty in b || bacc ) labmap false in aux and opaque_occurs_in_mono_type (quant : quantifier) : mono_type -> bool = let tvp : mono_type_var -> bool = function | Updatable({contents = Link(ty)}) -> opaque_occurs_in_mono_type quant ty | _ -> false in opaque_occurs_in_type_scheme opaque_occurs_in_type_id tvp quant and opaque_occurs_in_poly_type (quant : quantifier) : poly_type -> bool = let tvp : poly_type_var -> bool = function | Mono(Updatable({contents = Link(ty)})) -> opaque_occurs_in_mono_type quant ty | _ -> false in opaque_occurs_in_type_scheme opaque_occurs_in_type_id tvp quant and opaque_occurs_in_type_id (quant : quantifier) (tyid : TypeID.t) : bool = quant |> OpaqueIDMap.mem tyid and opaque_occurs (quant : quantifier) (modsig : module_signature) : bool = match modsig with | (_, ConcStructure(sigr)) -> opaque_occurs_in_structure quant sigr | (_, ConcFunctor(sigftor)) -> let Domain(_, sigr) = sigftor.domain in let (_quantcod, modsigcod) = sigftor.codomain in opaque_occurs_in_structure quant sigr || opaque_occurs quant modsigcod and opaque_occurs_in_structure (quant : quantifier) (sigr : SigRecord.t) : bool = sigr |> SigRecord.fold ~v:(fun _x ventry b -> let pty = ventry.val_type in b || opaque_occurs_in_poly_type quant pty ) ~c:(fun _ctornm centry b -> let ptys = centry.parameter_types in b || ptys |> List.exists (opaque_occurs_in_poly_type quant) ) ~f:(fun _tynm _pty b -> b ) ~t:(fun _tynm tentry b -> let (_bids, pty_body, _tyentity) = tentry.type_scheme in b || opaque_occurs_in_poly_type quant pty_body ) ~m:(fun _modnm mentry b -> let modsig = mentry.mod_signature in b || opaque_occurs quant modsig ) ~s:(fun _ sentry b -> let (_quant, modsig) = sentry.sig_signature in b || opaque_occurs quant modsig ) false let label_assoc_union = LabelAssoc.union (fun _ _ ty2 -> Some(ty2)) let fresh_type_variable ?name:nameopt (lev : int) (rng : Range.t) : mono_type = let fid = FreeID.fresh ~message:"fresh_type_variable" lev in let mtvu = ref (Free(fid)) in let ty = (rng, TypeVar(Updatable(mtvu))) in (* let name = nameopt |> Option.map (fun x -> x ^ " : ") |> Option.value ~default:"" in Format.printf "GEN %sL%d %a :: %a\n" name lev pp_mono_type ty pp_mono_base_kind mbkd; (* for debug *) *) ty let fresh_row_variable (lev : int) (labset : LabelSet.t) : mono_row = let frid = FreeRowID.fresh ~message:"fresh_row_variable" lev in KindStore.register_free_row frid labset; let mrvu = ref (FreeRow(frid)) in RowVar(UpdatableRow(mrvu)) let check_properly_used (tyenv : Typeenv.t) ((rng, x) : identifier ranged) = match tyenv |> Typeenv.is_val_properly_used x with | None -> assert false | Some(true) -> () | Some(false) -> Logging.warn_val_not_used rng x let get_space_name (rng : Range.t) (m : module_name) : space_name = match OutputIdentifier.space_of_module_name m with | None -> raise_error (InvalidIdentifier(rng, m)) | Some(sname) -> sname let generate_local_name (rng : Range.t) (x : identifier) : local_name = match OutputIdentifier.generate_local x with | None -> raise_error (InvalidIdentifier(rng, x)) | Some(lname) -> lname let generate_global_name ~(is_test_suite : bool) ~(arity : int) ~(has_option : bool) (rng : Range.t) (x : identifier) : global_name = let suffix = if is_test_suite then "_test_" else "" in match OutputIdentifier.generate_global x ~suffix:suffix ~arity:arity ~has_option:has_option with | None -> raise_error (InvalidIdentifier(rng, x)) | Some(gname) -> gname let local_name_scheme letbind = let (rngv, x) = letbind.vb_identifier in let lname_inner = generate_local_name rngv x in let lname_outer = OutputIdentifier.fresh () in (lname_inner, lname_outer) let global_name_scheme (is_test_suite : bool) valbind = let arity = List.length valbind.vb_parameters + List.length valbind.vb_mandatories in let has_option = (List.length valbind.vb_optionals > 0) in let (rngv, x) = valbind.vb_identifier in let gname = generate_global_name ~is_test_suite ~arity:arity ~has_option:has_option rngv x in (gname, gname) let types_of_format (lev : int) (fmtelems : format_element list) : mono_type list = fmtelems |> List.map (function | FormatHole(hole, _) -> let rng = Range.dummy "format" in let ty = match hole with | HoleC -> (rng, BaseType(CharType)) | HoleF | HoleE | HoleG -> (rng, BaseType(FloatType)) | HoleS -> (rng, BaseType(BinaryType)) | HoleP | HoleW -> fresh_type_variable lev rng in [ ty ] | FormatConst(_) | FormatDQuote | FormatBreak | FormatTilde -> [] ) |> List.concat let type_of_base_constant (lev : int) (rng : Range.t) (bc : base_constant) = match bc with | Unit -> (rng, BaseType(UnitType)) | Bool(_) -> (rng, BaseType(BoolType)) | Int(_) -> (rng, BaseType(IntType)) | Float(_) -> (rng, BaseType(FloatType)) | BinaryByString(_) | BinaryByInts(_) -> (rng, BaseType(BinaryType)) | String(_) -> Primitives.list_type rng (Range.dummy "string_literal", BaseType(CharType)) | Char(_) -> (rng, BaseType(CharType)) | FormatString(fmtelems) -> let tyarg = match types_of_format lev fmtelems with | [] -> (Range.dummy "format", BaseType(UnitType)) | ty1 :: tys -> (Range.dummy "format", ProductType(TupleList.make ty1 tys)) in Primitives.format_type rng tyarg let rec unify_aux (ty1 : mono_type) (ty2 : mono_type) : (unit, unification_error) result = let open ResultMonad in let (_, ty1main) = ty1 in let (_, ty2main) = ty2 in match (ty1main, ty2main) with | (TypeVar(Updatable{contents = Link(ty1l)}), _) -> unify_aux ty1l ty2 | (_, TypeVar(Updatable{contents = Link(ty2l)})) -> unify_aux ty1 ty2l | (TypeVar(MustBeBound(mbbid1)), TypeVar(MustBeBound(mbbid2))) -> if MustBeBoundID.equal mbbid1 mbbid2 then return () else err Contradiction | (TypeApp(tyid1, tyargs1), TypeApp(tyid2, tyargs2)) -> if TypeID.equal tyid1 tyid2 then unify_aux_list tyargs1 tyargs2 else err Contradiction | (BaseType(bt1), BaseType(bt2)) -> if bt1 = bt2 then return () else err Contradiction | (FuncType(domain1, ty1cod), FuncType(domain2, ty2cod)) -> unify_aux_domain domain1 domain2 >>= fun () -> unify_aux ty1cod ty2cod | (EffType(domain1, eff1, tysub1), EffType(domain2, eff2, tysub2)) -> unify_aux_domain domain1 domain2 >>= fun () -> unify_aux_effect eff1 eff2 >>= fun () -> unify_aux tysub1 tysub2 | (PidType(pidty1), PidType(pidty2)) -> unify_aux_pid_type pidty1 pidty2 | (ProductType(tys1), ProductType(tys2)) -> unify_aux_list (tys1 |> TupleList.to_list) (tys2 |> TupleList.to_list) | (RecordType(row1), RecordType(row2)) -> unify_aux_row row1 row2 | (PackType(absmodsig1), PackType(absmodsig2)) -> begin try subtype_abstract_with_abstract ~cause:(Range.dummy "unify1") ~address:Address.root absmodsig1 absmodsig2; subtype_abstract_with_abstract ~cause:(Range.dummy "unify2") ~address:Address.root absmodsig2 absmodsig1; return () with | _ -> err Contradiction end | (TypeVar(Updatable({contents = Free(fid1)} as mtvu1)), TypeVar(Updatable{contents = Free(fid2)})) -> if FreeID.equal fid1 fid2 then return () else begin mtvu1 := Link(ty2); return () end | (TypeVar(Updatable({contents = Free(fid1)} as mtvu1)), _) -> unify_aux_free_id_and_record fid1 mtvu1 ty2 | (_, TypeVar(Updatable({contents = Free(fid2)} as mtvu2))) -> unify_aux_free_id_and_record fid2 mtvu2 ty1 | _ -> err Contradiction and unify_aux_free_id_and_record (fid1 : FreeID.t) (mtvu1 : mono_type_var_updatable ref) (ty2 : mono_type) = let open ResultMonad in let b = occurs fid1 ty2 in if b then err @@ Inclusion(fid1) else begin mtvu1 := Link(ty2); return () end and unify_aux_list tys1 tys2 = let open ResultMonad in try List.fold_left2 (fun res ty1 ty2 -> res >>= fun () -> unify_aux ty1 ty2 ) (return ()) tys1 tys2 with | Invalid_argument(_) -> err Contradiction and unify_aux_domain domain1 domain2 = let open ResultMonad in let {ordered = ty1doms; mandatory = mndlabmap1; optional = optrow1} = domain1 in let {ordered = ty2doms; mandatory = mndlabmap2; optional = optrow2} = domain2 in unify_aux_list ty1doms ty2doms >>= fun () -> unify_aux_label_assoc_exact mndlabmap1 mndlabmap2 >>= fun () -> unify_aux_row optrow1 optrow2 and unify_aux_effect (Effect(ty1)) (Effect(ty2)) = unify_aux ty1 ty2 and unify_aux_pid_type (Pid(ty1)) (Pid(ty2)) = unify_aux ty1 ty2 and unify_aux_row (row1 : mono_row) (row2 : mono_row) = let open ResultMonad in match (row1, row2) with | (RowVar(UpdatableRow{contents = LinkRow(row1sub)}), _) -> unify_aux_row row1sub row2 | (_, RowVar(UpdatableRow{contents = LinkRow(row2sub)})) -> unify_aux_row row1 row2sub | (RowVar(UpdatableRow({contents = FreeRow(frid1)} as mtvu1)), RowVar(UpdatableRow{contents = FreeRow(frid2)})) -> if FreeRowID.equal frid1 frid2 then return () else begin let labset1 = KindStore.get_free_row frid1 in let labset2 = KindStore.get_free_row frid2 in let labset = LabelSet.union labset1 labset2 in mtvu1 := LinkRow(row2); KindStore.register_free_row frid2 labset; return () end | (RowVar(UpdatableRow({contents = FreeRow(frid1)} as mrvu1)), _) -> if occurs_row frid1 row2 then err @@ InclusionRow(frid1) else begin let labset1 = KindStore.get_free_row frid1 in solve_disjointness_aux row2 labset1 >>= fun () -> mrvu1 := LinkRow(row2); return () end | (_, RowVar(UpdatableRow({contents = FreeRow(frid2)} as mrvu2))) -> if occurs_row frid2 row1 then err @@ InclusionRow(frid2) else begin let labset2 = KindStore.get_free_row frid2 in solve_disjointness_aux row1 labset2 >>= fun () -> mrvu2 := LinkRow(row1); return () end | (RowVar(MustBeBoundRow(mbbrid1)), RowVar(MustBeBoundRow(mbbrid2))) -> if MustBeBoundRowID.equal mbbrid1 mbbrid2 then return () else err Contradiction | (RowVar(MustBeBoundRow(_)), _) | (_, RowVar(MustBeBoundRow(_))) -> err Contradiction | (RowCons((rng, label), ty, row1sub), _) -> solve_membership_aux rng label ty row2 >>= fun row2rest -> unify_aux_row row1sub row2rest | (RowEmpty, RowEmpty) -> return () | (RowEmpty, RowCons(_, _, _)) -> err Contradiction (* Check that `labmap2` is more specific than or equal to `labmap1`, i.e., the domain of `labmap1` is contained in that of `labmap2`. *) and unify_aux_label_assoc_subtype ~specific:labmap2 ~general:labmap1 = let open ResultMonad in LabelAssoc.fold (fun label ty1 res -> res >>= fun () -> match labmap2 |> LabelAssoc.find_opt label with | None -> err Contradiction | Some(ty2) -> unify_aux ty1 ty2 ) labmap1 (return ()) and unify_aux_label_assoc_exact labmap1 labmap2 = let open ResultMonad in let merged = LabelAssoc.merge (fun _ tyopt1 tyopt2 -> match (tyopt1, tyopt2) with | (None, None) -> None | (Some(ty1), Some(ty2)) -> Some(unify_aux ty1 ty2) | _ -> Some(err Contradiction) ) labmap1 labmap2 in LabelAssoc.fold (fun _ res resacc -> resacc >>= fun () -> res) merged (return ()) and unify_aux_label_assoc_intersection labmap1 labmap2 = let open ResultMonad in let intersection = LabelAssoc.merge (fun _ opt1 opt2 -> match (opt1, opt2) with | (Some(ty1), Some(ty2)) -> Some((ty1, ty2)) | _ -> None ) labmap1 labmap2 in LabelAssoc.fold (fun label (ty1, ty2) res -> res >>= fun () -> unify_aux ty1 ty2 ) intersection (return ()) (* Solves the constraint that `label : ty` is a field of `row`. Returns `Ok(row_rest)` if the constraint is solved where `row_rest` stands for the other fields. *) and solve_membership_aux (rng : Range.t) (label : label) (ty : mono_type) (row : mono_row) : (mono_row, unification_error) result = let open ResultMonad in match row with | RowCons((rng0, label0), ty0, row0) -> if String.equal label0 label then unify_aux ty0 ty >>= fun () -> return row0 else solve_membership_aux rng label ty row0 >>= fun row0rest -> return @@ RowCons((rng0, label0), ty0, row0rest) | RowVar(UpdatableRow{contents = LinkRow(row0)}) -> solve_membership_aux rng label ty row0 | RowVar(UpdatableRow({contents = FreeRow(frid0)} as mrvu0)) -> let labset0 = KindStore.get_free_row frid0 in if labset0 |> LabelSet.mem label then err Contradiction (* TODO (error): reject for the disjointness *) else begin let lev = FreeRowID.get_level frid0 in let frid1 = FreeRowID.fresh ~message:"solve_membership_aux" lev in KindStore.register_free_row frid1 LabelSet.empty; let mrvu1 = ref (FreeRow(frid1)) in let row_rest = RowVar(UpdatableRow(mrvu1)) in let row_new = RowCons((rng, label), ty, row_rest) in mrvu0 := LinkRow(row_new); return row_rest end | RowVar(MustBeBoundRow(_)) -> err Contradiction (* TODO (error): solve_membership_aux, reject for must-be-bound row IDs *) | RowEmpty -> err Contradiction (* TODO (error): solve_membership_aux, RowEmpty *) (* Solves the constraint that `row` does not have any label in `labset`. *) and solve_disjointness_aux (row : mono_row) (labset : LabelSet.t) = let open ResultMonad in match row with | RowCons((rng, label), ty, rowsub) -> if labset |> LabelSet.mem label then err Contradiction else solve_disjointness_aux rowsub labset | RowVar(UpdatableRow{contents = LinkRow(rowsub)}) -> solve_disjointness_aux rowsub labset | RowVar(UpdatableRow{contents = FreeRow(frid0)}) -> let labset0 = KindStore.get_free_row frid0 in KindStore.register_free_row frid0 (LabelSet.union labset0 labset); return () | RowVar(MustBeBoundRow(mbbrid0)) -> let labset0 = KindStore.get_bound_row (MustBeBoundRowID.to_bound mbbrid0) in if LabelSet.subset labset labset0 then return () else err @@ InsufficientRowConstraint{ id = mbbrid0; given = labset0; required = labset; } | RowEmpty -> return () and unify (tyact : mono_type) (tyexp : mono_type) : unit = let res = unify_aux tyact tyexp in match res with | Ok(()) -> () | Error(e) -> raise_error (UnificationError{ actual = tyact; expected = tyexp; detail = e; }) and unify_effect (Effect(tyact) : mono_effect) (Effect(tyexp) : mono_effect) : unit = let res = unify_aux tyact tyexp in match res with | Ok(()) -> () | Error(e) -> raise_error (UnificationError{ actual = tyact; expected = tyexp; detail = e; }) and make_rec_initial_type_from_annotation (preL : pre) (letbind : untyped_let_binding) : pre * poly_type option = let (rngv, x) = letbind.vb_identifier in let ordparams = letbind.vb_parameters in let mndparams = letbind.vb_mandatories in let optparams = letbind.vb_optionals in (* First, add local type/row parameters at level `levS`. *) let preS = let (pre, _assoc) = make_type_parameter_assoc preL letbind.vb_forall in let levS = pre.level + 1 in let preS = { pre with level = levS } in preS |> add_local_row_parameter letbind.vb_forall_row in let ptyopt = let open OptionMonad in ordparams |> List.fold_left (fun opt ordparam -> opt >>= fun tyacc -> let (_, mtyopt) = ordparam in mtyopt |> Option.map (fun mty -> let ty = decode_manual_type preS mty in Alist.extend tyacc ty ) ) (Some(Alist.empty)) >>= fun ordtyacc -> mndparams |> List.fold_left (fun opt mndparam -> opt >>= fun labmap -> let ((rnglabel, label), (_, mtyopt)) = mndparam in if labmap |> LabelAssoc.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else mtyopt |> Option.map (fun mty -> let ty = decode_manual_type preS mty in labmap |> LabelAssoc.add label ty ) ) (Some(LabelAssoc.empty)) >>= fun mndlabmap -> optparams |> List.fold_left (fun opt optparam -> opt >>= fun (labset_defined, row) -> let (((rnglabel, label), (_, mtyopt)), _) = optparam in if labset_defined |> LabelSet.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else mtyopt |> Option.map (fun mty -> let ty = decode_manual_type preS mty in let row = RowCons((rnglabel, label), ty, row) in let labset_defined = labset_defined |> LabelSet.add label in (labset_defined, row) ) ) (Some((LabelSet.empty, RowEmpty))) >>= fun (_, row) -> let domty = { ordered = Alist.to_list ordtyacc; mandatory = mndlabmap; optional = row; } in let tyopt = match letbind.vb_return with | Pure((mtyopt, _)) -> mtyopt |> Option.map (fun mtycod -> let tycod = decode_manual_type preS mtycod in (rngv, FuncType(domty, tycod)) ) | Effectful((mtypairopt, _)) -> mtypairopt |> Option.map (fun (mtyeff, mtycod) -> let tyeff = decode_manual_type preS mtyeff in let tycod = decode_manual_type preS mtycod in (rngv, EffType(domty, Effect(tyeff), tycod)) ) in tyopt |> Option.map (TypeConv.generalize preL.level) in (preS, ptyopt) and make_type_parameter_assoc (pre : pre) (tyvarnms : type_variable_binder list) : pre * type_parameter_assoc = tyvarnms |> List.fold_left (fun (pre, assoc) ((rng, tyvarnm), kdannot) -> let mbbid = MustBeBoundID.fresh ("$" ^ tyvarnm) (pre.level + 1) in match assoc |> TypeParameterAssoc.add_last tyvarnm mbbid with | None -> raise_error (TypeParameterBoundMoreThanOnce(rng, tyvarnm)) | Some(assoc) -> let localtyparams = pre.local_type_parameters |> TypeParameterMap.add tyvarnm mbbid in let pre = { pre with local_type_parameters = localtyparams } in (pre, assoc) ) (pre, TypeParameterAssoc.empty) and decode_manual_base_kind (pre : pre) ((rng, mnbkdmain) : manual_base_kind) : base_kind = match mnbkdmain with | MKindName(kdnm) -> begin match kdnm with | "o" -> TypeKind | _ -> raise_error (UndefinedKindName(rng, kdnm)) end and decode_manual_kind (pre : pre) (mnkd : manual_kind) : kind = match mnkd with | (_, MKind(mnbkddoms, mnbkdcod)) -> let bkddoms = mnbkddoms |> List.map (decode_manual_base_kind pre) in let bkdcod = decode_manual_base_kind pre mnbkdcod in Kind(bkddoms, bkdcod) and decode_manual_type (pre : pre) (mty : manual_type) : mono_type = let tyenv = pre.tyenv in let typarams = pre.local_type_parameters in let rowparams = pre.local_row_parameters in let invalid rng tynm ~expect:len_expected ~actual:len_actual = raise_error (InvalidNumberOfTypeArguments(rng, tynm, len_expected, len_actual)) in let aux_labeled_list = decode_manual_record_type pre in let rec aux (rng, mtymain) = let tymain = match mtymain with | MTypeName(tynm, mtyargs) -> let tyargs = mtyargs |> List.map aux in let len_actual = List.length tyargs in begin match tyenv |> Typeenv.find_type tynm with | None -> begin match (tynm, tyargs) with | ("unit", []) -> BaseType(UnitType) | ("unit", _) -> invalid rng "unit" ~expect:0 ~actual:len_actual | ("bool", []) -> BaseType(BoolType) | ("bool", _) -> invalid rng "bool" ~expect:0 ~actual:len_actual | ("int", []) -> BaseType(IntType) | ("int", _) -> invalid rng "int" ~expect:0 ~actual:len_actual | ("float", []) -> BaseType(FloatType) | ("float", _) -> invalid rng "float" ~expect:0 ~actual:len_actual | ("binary", []) -> BaseType(BinaryType) | ("binary", _) -> invalid rng "binary" ~expect:0 ~actual:len_actual | ("char", []) -> BaseType(CharType) | ("char", _) -> invalid rng "char" ~expect:0 ~actual:len_actual | ("pid", [ty]) -> PidType(Pid(ty)) | ("pid", _) -> invalid rng "pid" ~expect:1 ~actual:len_actual | _ -> raise_error (UndefinedTypeName(rng, tynm)) end | Some(tentry) -> let len_expected = TypeConv.arity_of_kind tentry.type_kind in let tyscheme = let (bids, tybody, _) = tentry.type_scheme in (bids, tybody) in begin match TypeConv.apply_type_scheme_mono tyscheme tyargs with | Some((_, tymain)) -> tymain | None -> invalid rng tynm ~expect:len_expected ~actual:len_actual end end | MFuncType((mtydoms, mndlabmtys, mrow), mtycod) -> let mndlabmap = aux_labeled_list mndlabmtys in let optrow = aux_row mrow in FuncType({ordered = List.map aux mtydoms; mandatory = mndlabmap; optional = optrow}, aux mtycod) | MProductType(mtys) -> ProductType(TupleList.map aux mtys) | MRecordType(mrow) -> let row = aux_row mrow in RecordType(row) | MEffType((mtydoms, mndlabmtys, mrow), mty1, mty2) -> let mndlabmap = aux_labeled_list mndlabmtys in let optrow = aux_row mrow in let domain = {ordered = List.map aux mtydoms; mandatory = mndlabmap; optional = optrow} in EffType(domain, Effect(aux mty1), aux mty2) | MTypeVar(typaram) -> begin match typarams |> TypeParameterMap.find_opt typaram with | None -> raise_error (UnboundTypeParameter(rng, typaram)) | Some(mbbid) -> TypeVar(MustBeBound(mbbid)) end | MModProjType(utmod1, tyident2, mtyargs) -> let (rng2, tynm2) = tyident2 in let (absmodsig1, _) = typecheck_module ~address:Address.root tyenv utmod1 in let (quant1, modsig1) = absmodsig1 in begin match modsig1 with | (_, ConcFunctor(_)) -> let (rng1, _) = utmod1 in raise_error (NotOfStructureType(rng1, modsig1)) | (_, ConcStructure(sigr)) -> begin match sigr |> SigRecord.find_type tynm2 with | None -> raise_error (UndefinedTypeName(rng2, tynm2)) | Some(tentry2) -> let tyargs = mtyargs |> List.map aux in let len_actual = List.length tyargs in let len_expected = TypeConv.arity_of_kind tentry2.type_kind in let tyscheme = let (bids, tybody, _) = tentry2.type_scheme in (bids, tybody) in begin match TypeConv.apply_type_scheme_mono tyscheme tyargs with | Some((_, tymain) as ty) -> if opaque_occurs_in_mono_type quant1 ty then (* Combining (T-Path) and the second premise “Γ ⊢ Σ : Ω” of (P-Mod) in the original paper “F-ing modules” [Rossberg, Russo & Dreyer 2014], we must assert that opaque type variables do not extrude their scope. *) raise_error (OpaqueIDExtrudesScopeViaType(rng, tentry2)) else tymain | None -> invalid rng tynm2 ~expect:len_expected ~actual:len_actual end end end | MPackType(utsig) -> let absmodsig = typecheck_signature ~address:Address.root tyenv utsig in PackType(absmodsig) in (rng, tymain) and aux_row (mrow : manual_row) : mono_row = match mrow with | MRow(optlabmtys, rowvar_opt) -> let row_last = match rowvar_opt with | None -> RowEmpty | Some((rng, rowparam)) -> begin match rowparams |> RowParameterMap.find_opt rowparam with | None -> raise_error (UnboundRowParameter(rng, rowparam)) | Some((mbbrid, _)) -> RowVar(MustBeBoundRow(mbbrid)) end in optlabmtys |> List.fold_left (fun row_acc (rlabel, mty) -> let ty = aux mty in RowCons(rlabel, ty, row_acc) ) row_last in aux mty and decode_manual_record_type (pre : pre) (labmtys : labeled_manual_type list) : mono_type LabelAssoc.t = let aux = decode_manual_type pre in labmtys |> List.fold_left (fun labmap (rlabel, mty) -> let (rnglabel, label) = rlabel in if labmap |> LabelAssoc.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else let ty = aux mty in labmap |> LabelAssoc.add label ty ) LabelAssoc.empty and add_local_row_parameter (rowvars : (row_variable_name ranged * (label ranged) list) list) (pre : pre) : pre = rowvars |> List.fold_left (fun pre ((rng, rowvarnm), mkind) -> let rowparams = pre.local_row_parameters in if rowparams |> RowParameterMap.mem rowvarnm then raise_error (RowParameterBoundMoreThanOnce(rng, rowvarnm)) else let mbbrid = MustBeBoundRowID.fresh ("?$" ^ rowvarnm) pre.level in let labset = mkind |> List.fold_left (fun labset rlabel -> let (rnglabel, label) = rlabel in if labset |> LabelSet.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else labset |> LabelSet.add label ) LabelSet.empty in KindStore.register_bound_row (MustBeBoundRowID.to_bound mbbrid) labset; let rowparams = rowparams |> RowParameterMap.add rowvarnm (mbbrid, labset) in { pre with local_row_parameters = rowparams } ) pre and decode_type_annotation_or_fresh (pre : pre) (((rng, x), tyannot) : binder) : mono_type = match tyannot with | None -> fresh_type_variable ~name:x pre.level rng | Some(mty) -> decode_manual_type pre mty and decode_parameter (pre : pre) (binder : binder) : mono_type * pattern * binding_map = let (utpat, _) = binder in let (typat, ipat, bindmap) = typecheck_pattern pre utpat in let tydom = decode_type_annotation_or_fresh pre binder in unify typat tydom; (tydom, ipat, bindmap) and add_binding_map_to_type_environment (bindmap : binding_map) (tyenv : Typeenv.t) : Typeenv.t = BindingMap.fold (fun x (ty, lname, _) tyenv -> tyenv |> Typeenv.add_value x (TypeConv.lift ty) (OutputIdentifier.Local(lname)) ) bindmap tyenv and add_ordered_parameters_to_type_environment (pre : pre) (binders : binder list) : Typeenv.t * mono_type list * pattern list = let (tyenv, ipatacc, tydomacc) = List.fold_left (fun (tyenv, ipatacc, ptydomacc) binder -> let (tydom, ipat, bindmap) = decode_parameter pre binder in let tyenv = tyenv |> add_binding_map_to_type_environment bindmap in (tyenv, Alist.extend ipatacc ipat, Alist.extend ptydomacc tydom) ) (pre.tyenv, Alist.empty, Alist.empty) binders in let ipats = ipatacc |> Alist.to_list in let tydoms = tydomacc |> Alist.to_list in (tyenv, tydoms, ipats) and 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 = optbinders |> List.fold_left (fun (tyenv, optrow, optipatmap) ((rlabel, binder), utdefault) -> let (rnglabel, label) = rlabel in if optipatmap |> LabelAssoc.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else let (ty_inner, ipat, bindmap) = decode_parameter pre binder in let (ty_outer, default) = match utdefault with | None -> let ty_outer = fresh_type_variable pre.level (Range.dummy "optional") in unify ty_inner (Primitives.option_type (Range.dummy "option") ty_outer); (ty_outer, None) | Some(utast) -> let (ty, e) = typecheck pre utast in unify ty_inner ty; (ty_inner, Some(e)) in let optrow = RowCons(rlabel, ty_outer, optrow) in let tyenv = tyenv |> add_binding_map_to_type_environment bindmap in let optipatmap = optipatmap |> LabelAssoc.add label (ipat, default) in (tyenv, optrow, optipatmap) ) (pre.tyenv, RowEmpty, LabelAssoc.empty) and add_labeled_mandatory_parameters_to_type_environment (pre : pre) (mndbinders : labeled_binder list) : Typeenv.t * mono_type LabelAssoc.t * pattern LabelAssoc.t = mndbinders |> List.fold_left (fun (tyenv, labmap, optipatmap) (rlabel, binder) -> let (rnglabel, label) = rlabel in if labmap |> LabelAssoc.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else let (ty, ipat, bindmap) = decode_parameter pre binder in let labmap = labmap |> LabelAssoc.add label ty in let tyenv = tyenv |> add_binding_map_to_type_environment bindmap in let optipatmap = optipatmap |> LabelAssoc.add label ipat in (tyenv, labmap, optipatmap) ) (pre.tyenv, LabelAssoc.empty, LabelAssoc.empty) and add_parameters_to_type_environment (pre : pre) ((ordbinders, mndbinders, optbinders) : untyped_parameters) = let (tyenv, tydoms, ordnames) = add_ordered_parameters_to_type_environment pre ordbinders in let (tyenv, mndlabmap, mndnamemap) = add_labeled_mandatory_parameters_to_type_environment { pre with tyenv } mndbinders in let (tyenv, optrow, optnamemap) = add_labeled_optional_parameters_to_type_environment { pre with tyenv } optbinders in let domain = {ordered = tydoms; mandatory = mndlabmap; optional = optrow} in let ibinders = (ordnames, mndnamemap, optnamemap) in (tyenv, domain, ibinders) and typecheck (pre : pre) ((rng, utastmain) : untyped_ast) : mono_type * ast = match utastmain with | BaseConst(bc) -> let ty = type_of_base_constant pre.level rng bc in (ty, IBaseConst(bc)) | Var(modidents1, (rng2, x2)) -> begin match modidents1 with | [] -> begin match pre.tyenv |> Typeenv.find_value x2 with | None -> raise_error (UnboundVariable(rng2, x2)) | Some((_, ptymain), name) -> let pty = (rng, ptymain) in let ty = TypeConv.instantiate pre.level pty in (ty, IVar(name)) end | modident :: projs -> let sigr1 = get_structure_signature pre.tyenv modident projs in (* let (quant1, modsig1) = absmodsig1 in *) begin match sigr1 |> SigRecord.find_value x2 with | None -> raise_error (UnboundVariable(rng2, x2)) | Some(ventry) -> let (_, ptymain2) = ventry.val_type in let gname2 = ventry.val_global in let pty2 = (rng, ptymain2) in (* if opaque_occurs_in_poly_type quant1 pty2 then (* Combining (E-Path) and the second premise “Γ ⊢ Σ : Ω” of (P-Mod) in the original paper “F-ing modules” [Rossberg, Russo & Dreyer 2014], we must assert that opaque type variables do not extrude their scope. *) raise_error (OpaqueIDExtrudesScopeViaValue(rng, pty2)) else *) let ty = TypeConv.instantiate pre.level pty2 in (ty, IVar(OutputIdentifier.Global(gname2))) end end | Lambda(binders, utast0) -> let (tyenv, domain, ibinders) = add_parameters_to_type_environment pre binders in let pre = { pre with tyenv } in let (tycod, e0) = typecheck pre utast0 in let ty = (rng, FuncType(domain, tycod)) in (ty, ilambda ibinders e0) | LambdaEff(binders, utcomp0) -> let (tyenv, domain, ibinders) = add_parameters_to_type_environment pre binders in let pre = { pre with tyenv } in let ((eff, ty0), e0) = typecheck_computation pre utcomp0 in let ty = (rng, EffType(domain, eff, ty0)) in (ty, ilambda ibinders e0) | Apply(utastfun, utargs) -> let (tyfun, efun) = typecheck pre utastfun in begin match TypeConv.canonicalize_root tyfun with | (_, FuncType(domain_expected, tyret)) -> (* A slight trick for making error messages easier to comprehend. *) let iargs = typecheck_arguments_against_domain pre rng utargs domain_expected in let tyret = let (_, tyretmain) = tyret in (rng, tyretmain) in (tyret, iapply efun domain_expected.optional iargs) | _ -> let (domain, optrow, iargs) = typecheck_arguments pre rng utargs in let tyret = fresh_type_variable ~name:"(Apply)" pre.level rng in unify tyfun (Range.dummy "Apply", FuncType(domain, tyret)); (tyret, iapply efun optrow iargs) end | Freeze(rngapp, frozenfun, utastargs, restrngs) -> let (ptyfun, gname) = match frozenfun with | FrozenModFun(modidentchain1, ident2) -> let mentry = find_module_from_chain pre.tyenv modidentchain1 in let modsig1 = mentry.mod_signature in begin match modsig1 with | (_, ConcFunctor(_)) -> let ((rng1, _), _) = modidentchain1 in raise_error (NotOfStructureType(rng1, modsig1)) | (_, ConcStructure(sigr)) -> let (rng2, x) = ident2 in begin match sigr |> SigRecord.find_value x with | None -> raise_error (UnboundVariable(rng2, x)) | Some(ventry) -> (ventry.val_type, ventry.val_global) end end | FrozenFun((rng0, x)) -> begin match pre.tyenv |> Typeenv.find_value x with | None -> raise_error (UnboundVariable(rng0, x)) | Some((_, ptymain), name) -> begin match name with | OutputIdentifier.Global(gname) -> ((rng0, ptymain), gname) | _ -> raise_error (CannotFreezeNonGlobalName(rng0, x)) end end in let tyfun = TypeConv.instantiate pre.level ptyfun in let tyeargs = List.map (typecheck pre) utastargs in let tyargs = List.map fst tyeargs in let eargs = List.map snd tyeargs in let tyrests = restrngs |> List.map (fun restrng -> fresh_type_variable ~name:"Freeze, rest" pre.level restrng ) in let tyargsall = List.append tyargs tyrests in let tyrecv = fresh_type_variable ~name:"Freeze, recv" pre.level rng in let eff = Effect(tyrecv) in let tyret = fresh_type_variable ~name:"Freeze, ret" pre.level rng in let domain = {ordered = tyargsall; mandatory = LabelAssoc.empty; optional = RowEmpty} in unify tyfun (Range.dummy "Freeze1", EffType(domain, eff, tyret)); let tyrest = let dr = Range.dummy "Freeze2" in match tyrests with | [] -> (dr, BaseType(UnitType)) | ty :: tys -> (dr, ProductType(TupleList.make ty tys)) in (Primitives.frozen_type rng ~rest:tyrest ~receive:tyrecv ~return:tyret, IFreeze(gname, eargs)) | FreezeUpdate(utast0, utastargs, restrngs) -> let (ty0, e0) = typecheck pre utast0 in let tyeargs = List.map (typecheck pre) utastargs in let tyargs = List.map fst tyeargs in let eargs = List.map snd tyeargs in let tyholes = restrngs |> List.map (fun restrng -> fresh_type_variable ~name:"FreezeUpdate, rest1" pre.level restrng ) in let tyrecv = fresh_type_variable ~name:"FreezeUpdate, recv" pre.level (Range.dummy "FreezeUpdate, recv") in let tyret = fresh_type_variable ~name:"FreezeUpdate, ret" pre.level (Range.dummy "FreezeUpdate, ret") in let ty_expected = let tyrest_expected = let dr = Range.dummy "FreezeUpdate, rest2" in match List.append tyargs tyholes with | [] -> (dr, BaseType(UnitType)) | ty :: tys -> (dr, ProductType(TupleList.make ty tys)) in Primitives.frozen_type (Range.dummy "FreezeUpdate") ~rest:tyrest_expected ~receive:tyrecv ~return:tyret in unify ty0 ty_expected; let tyrest = let dr = Range.dummy "FreezeUpdate, rest3" in match tyholes with | [] -> (dr, BaseType(UnitType)) | ty :: tys -> (dr, ProductType(TupleList.make ty tys)) in (Primitives.frozen_type rng ~rest:tyrest ~receive:tyrecv ~return:tyret, IFreezeUpdate(e0, eargs)) | If(utast0, utast1, utast2) -> let (ty0, e0) = typecheck pre utast0 in unify ty0 (Range.dummy "If", BaseType(BoolType)); let (ty1, e1) = typecheck pre utast1 in let (ty2, e2) = typecheck pre utast2 in unify ty1 ty2; let ibranches = [ IBranch(IPBool(true), e1); IBranch(IPBool(false), e2) ] in (ty1, ICase(e0, ibranches)) | LetIn(NonRec(letbind), utast2) -> let (pty, lname, e1) = typecheck_let generate_local_name pre letbind in let tyenv = let (_, x) = letbind.vb_identifier in pre.tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname)) in let (ty2, e2) = typecheck { pre with tyenv } utast2 in check_properly_used tyenv letbind.vb_identifier; (ty2, ILetIn(lname, e1, e2)) | LetIn(Rec(letbinds), utast2) -> let proj lname = OutputIdentifier.Local(lname) in let binds = typecheck_letrec_mutual local_name_scheme proj pre letbinds in let (ty2, e2) = let tyenv = binds |> List.fold_left (fun tyenv (x, pty, lname_outer, _, _) -> tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname_outer)) ) pre.tyenv in typecheck { pre with tyenv } utast2 in (ty2, iletrecin binds e2) | Tuple(utasts) -> let tyes = utasts |> TupleList.map (typecheck pre) in let tys = tyes |> TupleList.map fst in let es = tyes |> TupleList.map snd in let ty = (rng, ProductType(tys)) in (ty, ITuple(es)) | ListNil -> let tysub = fresh_type_variable pre.level (Range.dummy "list-nil") in let ty = Primitives.list_type rng tysub in (ty, IListNil) | ListCons(utast1, utast2) -> let (ty1, e1) = typecheck pre utast1 in let (ty2, e2) = typecheck pre utast2 in unify ty2 (Primitives.list_type (Range.dummy "list-cons") ty1); (ty2, IListCons(e1, e2)) | Case(utast0, branches) -> let (ty0, e0) = typecheck pre utast0 in let tyret = fresh_type_variable pre.level rng in let ibrs = branches |> List.map (typecheck_pure_case_branch pre ~pattern:ty0 ~return:tyret) in (tyret, ICase(e0, ibrs)) | LetPatIn(utpat, utast1, utast2) -> let (tyenv, ipat, bindmap, e1) = typecheck_let_pattern pre rng utpat utast1 in let (ty2, e2) = typecheck { pre with tyenv } utast2 in check_binding_map_properly_used tyenv bindmap; (ty2, iletpatin ipat e1 e2) | Constructor(modidents, ctornm, utastargs) -> let (tyid, ctorid, tyargs, tys_expected) = typecheck_constructor pre rng modidents ctornm in begin match List.combine utastargs tys_expected with | exception Invalid_argument(_) -> let len_expected = List.length tys_expected in let len_actual = List.length utastargs in raise_error (InvalidNumberOfConstructorArguments(rng, ctornm, len_expected, len_actual)) | zipped -> let eacc = zipped |> List.fold_left (fun eacc (utast, ty_expected) -> let (ty, e) = typecheck pre utast in unify ty ty_expected; Alist.extend eacc e ) Alist.empty in let ty = (rng, TypeApp(tyid, tyargs)) in let e = IConstructor(ctorid, Alist.to_list eacc) in (ty, e) end | BinaryByList(nrs) -> let ns = nrs |> List.map (fun (rngn, n) -> if 0 <= n && n <= 255 then n else raise_error (InvalidByte(rngn)) ) in ((rng, BaseType(BinaryType)), IBaseConst(BinaryByInts(ns))) | Record(labasts) -> let (emap, row) = labasts |> List.fold_left (fun (emap, row) (rlabel, utast) -> let (rnglabel, label) = rlabel in if emap |> LabelAssoc.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else let (ty, e) = typecheck pre utast in let row = RowCons(rlabel, ty, row) in let emap = emap |> LabelAssoc.add label e in (emap, row) ) (LabelAssoc.empty, RowEmpty) in ((rng, RecordType(row)), IRecord(emap)) | RecordAccess(utast1, ((_, label) as rlabel)) -> let (ty1, e1) = typecheck pre utast1 in let ty_ret = fresh_type_variable pre.level rng in let row_rest = fresh_row_variable pre.level (LabelSet.singleton label) in unify ty1 (Range.dummy "RecordAccess", RecordType(RowCons(rlabel, ty_ret, row_rest))); (ty_ret, IRecordAccess(e1, label)) | RecordUpdate(utast1, ((_, label) as rlabel), utast2) -> let (ty1, e1) = typecheck pre utast1 in let (ty2, e2) = typecheck pre utast2 in let row_rest = fresh_row_variable pre.level (LabelSet.singleton label) in unify ty1 (Range.dummy "RecordUpdate", RecordType(RowCons(rlabel, ty2, row_rest))); (ty1, IRecordUpdate(e1, label, e2)) | Pack(modidentchain1, utsig2) -> let mentry = find_module_from_chain pre.tyenv modidentchain1 in let modsig1 = mentry.mod_signature in let sname1 = mentry.mod_name in let absmodsig2 = typecheck_signature ~address:Address.root pre.tyenv utsig2 in let absmodsig = coerce_signature ~cause:rng ~address:Address.root modsig1 absmodsig2 in ((rng, PackType(absmodsig)), IPack(sname1)) | Assert(utast0) -> let (ty0, e0) = typecheck pre utast0 in unify ty0 Primitives.assertion_function_type; ((rng, BaseType(UnitType)), IAssert(rng, e0)) and typecheck_let_pattern (pre : pre) (rng : Range.t) (utpat : untyped_pattern) (utast1 : untyped_ast) = let (ty1, e1) = typecheck { pre with level = pre.level + 1 } utast1 in let (typat, ipat, bindmap) = typecheck_pattern pre utpat in unify ty1 typat; let tyenv = BindingMap.fold (fun x (ty, lname, _) tyenv -> let pty = TypeConv.generalize pre.level ty in tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname)) ) bindmap pre.tyenv in (tyenv, ipat, bindmap, e1) and typecheck_computation (pre : pre) (utcomp : untyped_computation_ast) : (mono_effect * mono_type) * ast = let (rng, utcompmain) = utcomp in match utcompmain with | CompDo(binder, utcomp1, utcomp2) -> let ((eff1, ty1), e1) = typecheck_computation pre utcomp1 in let (utpat, _) = binder in let tyx = decode_type_annotation_or_fresh pre binder in let (typat, ipat, bindmap) = typecheck_pattern pre utpat in unify typat tyx; unify ty1 tyx; let tyenv = pre.tyenv |> add_binding_map_to_type_environment bindmap in let ((eff2, ty2), e2) = typecheck_computation { pre with tyenv } utcomp2 in unify_effect eff1 eff2; let e = ICase(e1, [ IBranch(ipat, e2) ]) in ((eff2, ty2), e) | CompReceive(branches, after_opt) -> let lev = pre.level in let effexp = let ty = fresh_type_variable lev (Range.dummy "receive-recv") in Effect(ty) in let tyret = fresh_type_variable lev (Range.dummy "receive-ret") in let ibrs = branches |> List.map (typecheck_receive_branch pre effexp tyret) in let iafter_opt = after_opt |> Option.map (fun (utast1, utcomp2) -> let (ty1, e1) = typecheck pre utast1 in unify ty1 (Range.dummy "after", BaseType(IntType)); let ((eff2, ty2), e2) = typecheck_computation pre utcomp2 in unify_effect eff2 effexp; unify ty2 tyret; (e1, e2) ) in ((effexp, tyret), IReceive(ibrs, iafter_opt)) | CompLetIn(NonRec(letbind), utcomp2) -> let (pty, lname, e1) = typecheck_let generate_local_name pre letbind in let tyenv = let (_, x) = letbind.vb_identifier in pre.tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname)) in let ((eff2, ty2), e2) = typecheck_computation { pre with tyenv } utcomp2 in check_properly_used tyenv letbind.vb_identifier; ((eff2, ty2), ILetIn(lname, e1, e2)) | CompLetIn(Rec(letbinds), utcomp2) -> let proj lname = OutputIdentifier.Local(lname) in let binds = typecheck_letrec_mutual local_name_scheme proj pre letbinds in let ((eff2, ty2), e2) = let tyenv = binds |> List.fold_left (fun tyenv (x, pty, lname_outer, _, _) -> tyenv |> Typeenv.add_value x pty (OutputIdentifier.Local(lname_outer)) ) pre.tyenv in typecheck_computation { pre with tyenv } utcomp2 in ((eff2, ty2), iletrecin binds e2) | CompLetPatIn(utpat, utast1, utcomp2) -> let (tyenv, ipat, bindmap, e1) = typecheck_let_pattern pre rng utpat utast1 in let ((eff2, ty2), e2) = typecheck_computation { pre with tyenv } utcomp2 in ((eff2, ty2), iletpatin ipat e1 e2) | CompIf(utast0, utcomp1, utcomp2) -> let (ty0, e0) = typecheck pre utast0 in unify ty0 (Range.dummy "If", BaseType(BoolType)); let ((eff1, ty1), e1) = typecheck_computation pre utcomp1 in let ((eff2, ty2), e2) = typecheck_computation pre utcomp2 in unify_effect eff1 eff2; unify ty1 ty2; let ibranches = [ IBranch(IPBool(true), e1); IBranch(IPBool(false), e2) ] in ((eff1, ty1), ICase(e0, ibranches)) | CompCase(utast0, branches) -> let (ty0, e0) = typecheck pre utast0 in let eff = let tyrecv = fresh_type_variable pre.level (Range.dummy "CompCase1") in Effect(tyrecv) in let tyret = fresh_type_variable pre.level (Range.dummy "CompCase2") in let ibrs = branches |> List.map (typecheck_effectful_case_branch pre ~pattern:ty0 ~return:(eff, tyret)) in ((eff, tyret), ICase(e0, ibrs)) | CompApply(utastfun, utargs) -> let (tyfun, efun) = typecheck pre utastfun in let (domain, optrow, iargs) = typecheck_arguments pre rng utargs in let eff = let tyrecv = fresh_type_variable ~name:"(CompApply2)" pre.level rng in Effect(tyrecv) in let tyret = fresh_type_variable ~name:"(CompApply1)" pre.level rng in unify tyfun (Range.dummy "CompApply", EffType(domain, eff, tyret)); ((eff, tyret), iapply efun optrow iargs) and get_structure_signature (tyenv : Typeenv.t) (modident : module_name ranged) (projs : (module_name ranged) list) : SigRecord.t = let (rnginit, _) = modident in let mentry = find_module tyenv modident in let modsig = mentry.mod_signature in let (modsig, rnglast) = projs |> List.fold_left (fun (modsig, rnglast) proj -> match modsig with | (_, ConcFunctor(_)) -> raise_error (NotOfStructureType(rnglast, modsig)) | (_, ConcStructure(sigr)) -> let (rng, modnm) = proj in begin match sigr |> SigRecord.find_module modnm with | None -> raise_error (UnboundModuleName(rng, modnm)) | Some(mentry) -> (mentry.mod_signature, rng) end ) (modsig, rnginit) in begin match modsig with | (_, ConcFunctor(_)) -> raise_error (NotOfStructureType(rnglast, modsig)) | (_, ConcStructure(sigr)) -> sigr end and typecheck_arguments (pre : pre) (rng : Range.t) ((utastargs, mndutastargs, optutastargs) : untyped_arguments) = let tyeargs = List.map (typecheck pre) utastargs in let tyargs = List.map fst tyeargs in let eargs = List.map snd tyeargs in let (mndlabmap, mndargmap) = mndutastargs |> List.fold_left (fun (mndlabmap, mndargmap) (rlabel, utast) -> let (rnglabel, label) = rlabel in if mndlabmap |> LabelAssoc.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else let (ty, e) = typecheck pre utast in let mndlabmap = mndlabmap |> LabelAssoc.add label ty in let mndargmap = mndargmap |> LabelAssoc.add label e in (mndlabmap, mndargmap) ) (LabelAssoc.empty, LabelAssoc.empty) in let (optrow, optargmap) = let frid = FreeRowID.fresh ~message:"Apply, row" pre.level in (* Note: the initial kind for `frid` will be assigned after traversing the given optional arguments. *) let row_init = let mrvu = ref (FreeRow(frid)) in RowVar(UpdatableRow(mrvu)) in let (optrow, optlabset, optargmap) = optutastargs |> List.fold_left (fun (optrow, optlabset, optargmap) (rlabel, utast) -> let (rnglabel, label) = rlabel in if optlabset |> LabelSet.mem label then raise_error (DuplicatedLabel(rnglabel, label)) else let (ty, e) = typecheck pre utast in let optrow = RowCons(rlabel, ty, optrow) in let optlabset = optlabset |> LabelSet.add label in let optargmap = optargmap |> LabelAssoc.add label e in (optrow, optlabset, optargmap) ) (row_init, LabelSet.empty, LabelAssoc.empty) in KindStore.register_free_row frid optlabset; (* Format.printf "!!! typecheck_arguments (range: %a, length: %d, optrow: %a)\n" Range.pp rng (List.length optutastargs) TypeConv.(pp_mono_row DisplayMap.empty) optrow; *) (optrow, optargmap) in let domain = {ordered = tyargs; mandatory = mndlabmap; optional = optrow} in (domain, optrow, (eargs, mndargmap, optargmap)) and typecheck_arguments_against_domain (pre : pre) (rng : Range.t) ((utastargs, mndutastargs, optutastargs) : untyped_arguments) (domain_expected : mono_domain_type) = let {ordered = tys_expected; mandatory = mndlabmap_expected; optional = optrow_expected} = domain_expected in let eargs = let numord_got = List.length utastargs in let numord_expected = List.length tys_expected in if numord_got = numord_expected then List.fold_left2 (fun eargacc utastarg ty_expected -> let (ty_got, e) = typecheck pre utastarg in unify ty_got ty_expected; Alist.extend eargacc e ) Alist.empty utastargs tys_expected |> Alist.to_list else raise_error @@ BadArityOfOrderedArguments{range = rng; got = numord_got; expected = numord_expected} in let mndargmap = let (mndlabmap_rest, mndargmap) = mndutastargs |> List.fold_left (fun (mndlabmap_rest, mndargmap) (rlabel, utast) -> let (rnglabel, label) = rlabel in if mndargmap |> LabelAssoc.mem label then raise_error @@ DuplicatedLabel(rnglabel, label) else match mndlabmap_rest |> LabelAssoc.find_opt label with | None -> raise_error @@ UnexpectedMandatoryLabel{range = rnglabel; label = label} | Some(ty_expected) -> let (ty_got, e) = typecheck pre utast in unify ty_got ty_expected; let mndlabmap_rest = mndlabmap_rest |> LabelAssoc.remove label in let mndargmap = mndargmap |> LabelAssoc.add label e in (mndlabmap_rest, mndargmap) ) (mndlabmap_expected, LabelAssoc.empty) in match mndlabmap_rest |> LabelAssoc.bindings with | [] -> mndargmap | (label, ty) :: _ -> raise_error @@ MissingMandatoryLabel{range = rng; label = label; typ = ty} in let optargmap = let NormalizedRow(labmap_known, rowvar_opt) = TypeConv.normalize_mono_row optrow_expected in let (all_labset, unknown_labels, optargmap) = optutastargs |> List.fold_left (fun (all_labset, unknown_labels, optargmap) (rlabel, utast) -> let (rng_label, label) = rlabel in if optargmap |> LabelAssoc.mem label then raise_error (DuplicatedLabel(rng, label)) else let (ty_got, e) = typecheck pre utast in let optargmap = optargmap |> LabelAssoc.add label e in let all_labset = all_labset |> LabelSet.add label in match labmap_known |> LabelAssoc.find_opt label with | None -> (all_labset, unknown_labels |> LabelAssoc.add label (rng_label, ty_got), optargmap) | Some(ty_expected) -> unify ty_got ty_expected; (all_labset, unknown_labels, optargmap) ) (LabelSet.empty, LabelAssoc.empty, LabelAssoc.empty) in begin match LabelAssoc.bindings unknown_labels with | (label, _) :: _ -> begin match rowvar_opt with | Some(UpdatableRow({contents = FreeRow(frid)} as mrvu)) -> let row_unknown = let row_init = let frid0 = FreeRowID.fresh ~message:"typecheck_arguments_against_domain" pre.level in KindStore.register_free_row frid0 all_labset; let mrvu0 = ref (FreeRow(frid0)) in RowVar(UpdatableRow(mrvu0)) in LabelAssoc.fold (fun label (rng, ty) row_acc -> RowCons((rng, label), ty, row_acc) ) unknown_labels row_init in (* 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; *) mrvu := LinkRow(row_unknown) | _ -> raise_error @@ UnexpectedOptionalLabel{range = rng; label = label} end | _ -> () end; optargmap in (eargs, mndargmap, optargmap) and typecheck_constructor (pre : pre) (rng : Range.t) (modidents : (module_name ranged) list) (ctornm : constructor_name) = match modidents with | [] -> begin match pre.tyenv |> Typeenv.find_constructor ctornm with | None -> raise_error (UndefinedConstructor(rng, ctornm)) | Some(centry) -> let tyid = centry.belongs in let ctorid = centry.constructor_id in let bids = centry.type_variables in let ptys = centry.parameter_types in let (tyargs, tys_expected) = TypeConv.instantiate_type_arguments pre.level bids ptys in (tyid, ctorid, tyargs, tys_expected) end | modident :: projs -> let sigr1 = get_structure_signature pre.tyenv modident projs in begin match sigr1 |> SigRecord.find_constructor ctornm with | None -> raise_error (UndefinedConstructor(rng, ctornm)) | Some(centry) -> let vid = centry.belongs in let ctorid = centry.constructor_id in let bids = centry.type_variables in let ptys = centry.parameter_types in let (tyargs, tys_expected) = TypeConv.instantiate_type_arguments pre.level bids ptys in (vid, ctorid, tyargs, tys_expected) end and typecheck_pure_case_branch (pre : pre) ~pattern:typatexp ~return:tyret (CaseBranch(pat, utast1)) = let (typat, ipat, bindmap) = typecheck_pattern pre pat in let tyenv = pre.tyenv |> add_binding_map_to_type_environment bindmap in let (ty1, e1) = typecheck { pre with tyenv } utast1 in check_binding_map_properly_used tyenv bindmap; unify typat typatexp; unify ty1 tyret; IBranch(ipat, e1) and typecheck_effectful_case_branch (pre : pre) ~pattern:typatexp ~return:(eff, tyret) (CompCaseBranch(pat, utcomp1)) = let (typat, ipat, bindmap) = typecheck_pattern pre pat in let tyenv = pre.tyenv |> add_binding_map_to_type_environment bindmap in let ((eff1, ty1), e1) = typecheck_computation { pre with tyenv } utcomp1 in check_binding_map_properly_used tyenv bindmap; unify typat typatexp; unify_effect eff1 eff; unify ty1 tyret; IBranch(ipat, e1) and typecheck_receive_branch (pre : pre) (effexp : mono_effect) (tyret : mono_type) (ReceiveBranch(pat, utcomp1)) = let (typat, ipat, bindmap) = typecheck_pattern pre pat in let tyenv = pre.tyenv |> add_binding_map_to_type_environment bindmap in let ((eff1, ty1), e1) = typecheck_computation { pre with tyenv } utcomp1 in check_binding_map_properly_used tyenv bindmap; unify_effect (Effect(typat)) effexp; unify_effect eff1 effexp; unify ty1 tyret; IBranch(ipat, e1) and check_binding_map_properly_used (tyenv : Typeenv.t) (bindmap : binding_map) : unit = BindingMap.iter (fun x (_, _, rng) -> check_properly_used tyenv (rng, x) ) bindmap and typecheck_pattern (pre : pre) ((rng, patmain) : untyped_pattern) : mono_type * pattern * binding_map = let immediate tymain ipat = ((rng, tymain), ipat, BindingMap.empty) in match patmain with | PUnit -> immediate (BaseType(UnitType)) IPUnit | PBool(b) -> immediate (BaseType(BoolType)) (IPBool(b)) | PInt(n) -> immediate (BaseType(IntType)) (IPInt(n)) | PBinary(s) -> immediate (BaseType(BinaryType)) (IPBinary(s)) | PChar(uchar) -> immediate (BaseType(CharType)) (IPChar(uchar)) | PVar(x) -> let ty = fresh_type_variable ~name:x pre.level rng in let lname = generate_local_name rng x in (ty, IPVar(lname), BindingMap.singleton x (ty, lname, rng)) | PWildCard -> let ty = fresh_type_variable ~name:"_" pre.level rng in (ty, IPWildCard, BindingMap.empty) | PListNil -> let ty = let tysub = fresh_type_variable pre.level rng in Primitives.list_type rng tysub in (ty, IPListNil, BindingMap.empty) | PListCons(pat1, pat2) -> let (ty1, ipat1, bindmap1) = typecheck_pattern pre pat1 in let (ty2, ipat2, bindmap2) = typecheck_pattern pre pat2 in let bindmap = binding_map_union rng bindmap1 bindmap2 in unify ty2 (Primitives.list_type (Range.dummy "pattern-cons") ty1); (ty2, IPListCons(ipat1, ipat2), bindmap) | PTuple(pats) -> let triples = pats |> TupleList.map (typecheck_pattern pre) in let tys = triples |> TupleList.map (fun (ty, _, _) -> ty) in let ipats = triples |> TupleList.map (fun (_, ipat, _) -> ipat) in let bindmaps = triples |> TupleList.map (fun (_, _, bindmap) -> bindmap) in let bindmap = bindmaps |> TupleList.to_list |> List.fold_left (binding_map_union rng) BindingMap.empty in let ty = (rng, ProductType(tys)) in (ty, IPTuple(ipats), bindmap) | PConstructor(modidents, ctornm, pats) -> let (tyid, ctorid, tyargs, tys_expected) = typecheck_constructor pre rng modidents ctornm in begin try let (ipatacc, bindmap) = List.fold_left2 (fun (ipatacc, bindmapacc) ty_expected pat -> let (ty, ipat, bindmap) = typecheck_pattern pre pat in unify ty ty_expected; (Alist.extend ipatacc ipat, binding_map_union rng bindmapacc bindmap) ) (Alist.empty, BindingMap.empty) tys_expected pats in let ty = (rng, TypeApp(tyid, tyargs)) in (ty, IPConstructor(ctorid, Alist.to_list ipatacc), bindmap) with | Invalid_argument(_) -> let len_expected = List.length tys_expected in let len_actual = List.length pats in raise_error (InvalidNumberOfConstructorArguments(rng, ctornm, len_expected, len_actual)) end and typecheck_let : 'n. (Range.t -> identifier -> 'n) -> pre -> untyped_let_binding -> poly_type * 'n * ast = fun namef preL letbind -> let (rngv, x) = letbind.vb_identifier in let ordparams = letbind.vb_parameters in let mndparams = letbind.vb_mandatories in let optparams = letbind.vb_optionals in let (ty1, e0, ibinders) = (* First, add local type/row parameters at level `levS`. *) let preS = let (preL, _assoc) = make_type_parameter_assoc preL letbind.vb_forall in { preL with level = preL.level + 1 } |> add_local_row_parameter letbind.vb_forall_row in (* Second, add local value parameters at level `levS`. *) let (tyenv, domain, ibinders) = add_parameters_to_type_environment preS (ordparams, mndparams, optparams) in let preS = { preS with tyenv } in (* Finally, typecheck the body expression. *) match letbind.vb_return with | Pure((tyretopt, utast0)) -> let (ty0, e0) = typecheck preS utast0 in tyretopt |> Option.map (fun mty0 -> let ty0_expected = decode_manual_type preS mty0 in unify ty0 ty0_expected ) |> Option.value ~default:(); let ty1 = (rngv, FuncType(domain, ty0)) in (ty1, e0, ibinders) | Effectful((tyretopt, utcomp0)) -> let ((eff0, ty0), e0) = typecheck_computation preS utcomp0 in tyretopt |> Option.map (fun (mty1, mty2) -> let ty1_expected = decode_manual_type preS mty1 in let ty2_expected = decode_manual_type preS mty2 in unify_effect eff0 (Effect(ty1_expected)); unify ty0 ty2_expected ) |> Option.value ~default:(); let ty1 = (rngv, EffType(domain, eff0, ty0)) in (ty1, e0, ibinders) in let e1 = ilambda ibinders e0 in let pty1 = TypeConv.generalize preL.level ty1 in let name = namef rngv x in (pty1, name, e1) and typecheck_letrec_mutual : 'n. (untyped_let_binding -> 'n * 'n) -> ('n -> name) -> pre -> untyped_let_binding list -> (identifier * poly_type * 'n * 'n * ast) list = fun namesf proj preL letbinds -> let levS = preL.level + 1 in (* Register type variables and names for output corresponding to bound names before traversing definitions *) let (tupleacc, tyenv) = letbinds |> List.fold_left (fun (tupleacc, tyenv) letbind -> let (rngv, x) = letbind.vb_identifier in let (name_inner, name_outer) = namesf letbind in let (preS, ptyopt) = make_rec_initial_type_from_annotation preL letbind in let (tyenv, morph) = match ptyopt with | Some(pty) -> let tyenv = tyenv |> Typeenv.add_value x pty (proj name_inner) in (tyenv, PolyRec(pty)) | None -> let tyf = fresh_type_variable ~name:x levS rngv in let tyenv = tyenv |> Typeenv.add_value x (TypeConv.lift tyf) (proj name_inner) in (tyenv, MonoRec(tyf)) in (Alist.extend tupleacc (letbind, name_inner, name_outer, morph, preS), tyenv) ) (Alist.empty, preL.tyenv) in let bindacc = tupleacc |> Alist.to_list |> List.fold_left (fun bindacc (letbind, name_inner, name_outer, morph, preS) -> let preS = { preS with tyenv } in let (pty, e1) = typecheck_letrec_single preS letbind morph in let (_, x) = letbind.vb_identifier in Alist.extend bindacc (x, pty, name_outer, name_inner, e1) ) Alist.empty in bindacc |> Alist.to_list and typecheck_letrec_single (preS : pre) (letbind : untyped_let_binding) (morph : rec_morph) : poly_type * ast = let (rngv, x) = letbind.vb_identifier in let ordparams = letbind.vb_parameters in let mndparams = letbind.vb_mandatories in let optparams = letbind.vb_optionals in let (ty1, e0, ibinders) = (* Add local value parameters at level `pre.level`. *) let (tyenv, domain, ibinders) = add_parameters_to_type_environment preS (ordparams, mndparams, optparams) in let preS = { preS with tyenv } in (* Finally, typecheck the body expression. *) match letbind.vb_return with | Pure((tyretopt, utast0)) -> let (ty0, e0) = typecheck preS utast0 in begin match (morph, tyretopt) with | (MonoRec(_), Some(mty0)) -> let ty0_expected = decode_manual_type preS mty0 in unify ty0 ty0_expected | _ -> () end; let ty1 = (rngv, FuncType(domain, ty0)) in (ty1, e0, ibinders) | Effectful((tyretopt, utcomp0)) -> let ((eff0, ty0), e0) = typecheck_computation preS utcomp0 in begin match (morph, tyretopt) with | (MonoRec(_), Some((mty1, mty2))) -> let ty1_expected = decode_manual_type preS mty1 in let ty2_expected = decode_manual_type preS mty2 in unify_effect eff0 (Effect(ty1_expected)); unify ty0 ty2_expected | _ -> () end; let ty1 = (rngv, EffType(domain, eff0, ty0)) in (ty1, e0, ibinders) in let e1 = ilambda ibinders e0 in let ptyf = TypeConv.generalize (preS.level - 1) ty1 in begin match morph with | MonoRec(tyf) -> unify ty1 tyf | PolyRec(ptyannot) -> if subtype_poly_type ptyf ptyannot then () else raise_error (PolymorphicContradiction(rngv, x, ptyf, ptyannot)) end; (ptyf, e1) and make_constructor_branch_map (pre : pre) (ctorbrs : constructor_branch list) : constructor_map = ctorbrs |> List.fold_left (fun ctormap ctorbr -> match ctorbr with | ConstructorBranch(attrs, (rng, ctornm), mtyargs) -> let (ctorattr, warnings) = ConstructorAttribute.decode attrs in warnings |> List.iter Logging.warn_invalid_attribute; let tyargs = mtyargs |> List.map (decode_manual_type pre) in let ptyargs = tyargs |> List.map (TypeConv.generalize pre.level) in let ctorid = match ctorattr.target_atom with | None -> begin match ConstructorID.from_upper_camel_case ctornm with | Some(ctorid) -> ctorid | None -> raise_error (InvalidIdentifier(rng, ctornm)) end | Some((rng_atom, target_atom)) -> begin match ConstructorID.from_snake_case target_atom with | Some(ctorid) -> ctorid | None -> raise_error (InvalidIdentifier(rng_atom, target_atom)) end in ctormap |> ConstructorMap.add ctornm (ctorid, ptyargs) ) ConstructorMap.empty (* `subtype_poly_type_impl internbid internbrid pty1 pty2` checks that whether `pty1` is more general than (or equal to) `pty2`. Note that being more general means being smaller as polymorphic types; we have `pty1 <= pty2` in that if `x : pty1` holds and `pty1` is more general than `pty2`, then `x : pty2`. For example, we have `(∀α. α → α) <= (int → int)`. The parameter `internbid` is used for `internbid bid pty`, which returns whether the bound ID `bid` occurring in `pty1` is mapped to a type equivalent to `pty`. *) and subtype_poly_type_impl (internbid : type_intern) (internbrid : row_intern) (pty1 : poly_type) (pty2 : poly_type) : bool = let rec aux pty1 pty2 = (* let (sbt1, sbr1, sty1) = TypeConv.show_poly_type TypeConv.DisplayMap.empty pty1 in let (sbt2, sbr2, sty2) = TypeConv.show_poly_type TypeConv.DisplayMap.empty pty2 in Format.printf "!!! {subtype_poly_type_impl> %s Format.fprintf ppf ", ") Format.pp_print_string) (List.concat [sbt1; sbr1; sbt2; sbr2]); *) let (_, ptymain1) = pty1 in let (_, ptymain2) = pty2 in match (ptymain1, ptymain2) with | (TypeVar(Mono(_)), _) | (_, TypeVar(Mono(_))) -> assert false (* Monomorphic type variables cannot occur at level 0, according to type generalization. *) | (BaseType(bt1), BaseType(bt2)) -> bt1 = bt2 | (FuncType(pdomain1, ptycod1), FuncType(pdomain2, ptycod2)) -> let bdom = aux_domain pdomain1 pdomain2 in let bcod = aux ptycod1 ptycod2 in bdom && bcod | (PidType(pidty1), PidType(pidty2)) -> aux_pid pidty1 pidty2 | (EffType(domain1, effty1, pty1), EffType(domain2, effty2, pty2)) -> let b0 = aux_domain domain1 domain2 in let b1 = aux_effect effty1 effty2 in let b2 = aux pty1 pty2 in b0 && b1 && b2 | (ProductType(ptys1), ProductType(ptys2)) -> aux_list (TupleList.to_list ptys1) (TupleList.to_list ptys2) | (RecordType(prow1), RecordType(prow2)) -> subtype_row_with_equal_domain internbid internbrid prow1 prow2 | (PackType(absmodsig1), PackType(absmodsig2)) -> begin try subtype_abstract_with_abstract ~cause:(Range.dummy "subtype_poly_type1") ~address:Address.root absmodsig1 absmodsig2; subtype_abstract_with_abstract ~cause:(Range.dummy "subtype_poly_type2") ~address:Address.root absmodsig2 absmodsig1; true with | _ -> false end | (TypeVar(Bound(bid1)), _) -> internbid bid1 pty2 | (TypeApp(tyid1, ptyargs1), TypeApp(tyid2, ptyargs2)) -> TypeID.equal tyid1 tyid2 && aux_list ptyargs1 ptyargs2 | _ -> false and aux_list ptys1 ptys2 = match List.combine ptys1 ptys2 with | exception Invalid_argument(_) -> false | ptypairs -> ptypairs |> List.fold_left (fun bacc (pty1, pty2) -> let b = aux pty1 pty2 in bacc && b ) true and aux_domain domain1 domain2 = let {ordered = ptydoms1; mandatory = mndlabmap1; optional = poptrow1} = domain1 in let {ordered = ptydoms2; mandatory = mndlabmap2; optional = poptrow2} = domain2 in let b1 = aux_list ptydoms1 ptydoms2 in let bmnd = subtype_label_assoc_with_equal_domain internbid internbrid mndlabmap1 mndlabmap2 in let bopt = subtype_row_with_equal_domain internbid internbrid poptrow1 poptrow2 in b1 && bmnd && bopt and aux_pid (Pid(pty1)) (Pid(pty2)) = aux pty1 pty2 and aux_effect (Effect(pty1)) (Effect(pty2)) = aux pty1 pty2 in aux pty1 pty2 (* Checks that `dom plabmap1 ⊆ dom plabmap2` and `∀label ∈ dom plabmap1. plabmap1(label) <: plabmap2(label)` by referring and updating `internbid` and `internbrid`. *) and 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 = let merged = LabelAssoc.merge (fun label pty1_opt pty2_opt -> match (pty1_opt, pty2_opt) with | (Some(pty1), Some(pty2)) -> Some(Ok(subtype_poly_type_impl internbid internbrid pty1 pty2)) | (None, Some(pty2)) -> Some(Error(pty2)) | _ -> Some(Ok(false)) ) plabmap1 plabmap2 in if merged |> LabelAssoc.for_all (fun _label res -> Result.value ~default:true res) then let plabmap_diff = merged |> LabelAssoc.filter_map (fun _label res -> match res with | Ok(_) -> None | Error(pty2) -> Some(pty2) ) in Some(plabmap_diff) else None and subtype_label_assoc_with_equal_domain (internbid : type_intern) (internbrid : row_intern) (plabmap1 : poly_type LabelAssoc.t) (plabmap2 : poly_type LabelAssoc.t) : bool = LabelAssoc.merge (fun label pty1_opt pty2_opt -> match (pty1_opt, pty2_opt) with | (Some(pty1), Some(pty2)) -> Some(subtype_poly_type_impl internbid internbrid pty1 pty2) | _ -> Some(false) ) plabmap1 plabmap2 |> LabelAssoc.for_all (fun _label b -> b) and subtype_row_with_equal_domain (internbid : type_intern) (internbrid : row_intern) (prow1 : poly_row) (prow2 : poly_row) : bool = (* let (sbt1, sbr1, sty1) = TypeConv.show_poly_row TypeConv.DisplayMap.empty prow1 in let (sbt2, sbr2, sty2) = TypeConv.show_poly_row TypeConv.DisplayMap.empty prow2 in Format.printf "!!! {subtype_row_with_equal_domain> %s Format.fprintf ppf ", ") Format.pp_print_string) (List.concat [sbt1; sbr1; sbt2; sbr2]); *) let NormalizedRow(plabmap1, rowvar1_opt) = TypeConv.normalize_poly_row prow1 in let NormalizedRow(plabmap2, rowvar2_opt) = TypeConv.normalize_poly_row prow2 in match (rowvar1_opt, rowvar2_opt) with | (None, None) -> subtype_label_assoc_with_equal_domain internbid internbrid plabmap1 plabmap2 | (Some(MonoRow(_)), _) | (_, Some(MonoRow(_))) -> assert false | (None, Some(BoundRow(_brid2))) -> false | (Some(BoundRow(brid1)), _) -> let opt = subtype_label_assoc_inclusive internbid internbrid plabmap1 plabmap2 in begin match opt with | None -> false | Some(plabmap_diff) -> internbrid brid1 (NormalizedRow(plabmap_diff, rowvar2_opt)) end and subtype_poly_type (pty1 : poly_type) (pty2 : poly_type) : bool = let bidht = BoundIDHashTable.create 32 in let bridht = BoundRowIDHashTable.create 32 in let internbid (bid1 : BoundID.t) (pty2 : poly_type) : bool = match BoundIDHashTable.find_opt bidht bid1 with | None -> BoundIDHashTable.add bidht bid1 pty2; true | Some(pty) -> poly_type_equal pty pty2 in let internbrid (brid1 : BoundRowID.t) (nomrow2 : normalized_poly_row) : bool = match BoundRowIDHashTable.find_opt bridht brid1 with | None -> BoundRowIDHashTable.add bridht brid1 nomrow2; true | Some(nomrow) -> normalized_poly_row_equal nomrow nomrow2 in subtype_poly_type_impl internbid internbrid pty1 pty2 (* Checks that `prow1` and `prow2` are exactly the same up to reordering. Here, `Mono` and `MonoRow` are not supposed to occur in `prow1` nor `prow2`. *) and poly_row_equal (prow1 : poly_row) (prow2 : poly_row) : bool = normalized_poly_row_equal (TypeConv.normalize_poly_row prow1) (TypeConv.normalize_poly_row prow2) and normalized_poly_row_equal (nomrow1 : normalized_poly_row) (nomrow2 : normalized_poly_row) : bool = let NormalizedRow(plabmap1, rowvar1_opt) = nomrow1 in let NormalizedRow(plabmap2, rowvar2_opt) = nomrow2 in let bmap = LabelAssoc.merge (fun _ ptyopt1 ptyopt2 -> match (ptyopt1, ptyopt2) with | (None, None) -> None | (Some(pty1), Some(pty2)) -> Some(poly_type_equal pty1 pty2) | _ -> Some(false) ) plabmap1 plabmap2 |> LabelAssoc.for_all (fun _ b -> b) in if bmap then match (rowvar1_opt, rowvar2_opt) with | (None, None) -> true | (Some(BoundRow(brid1)), Some(BoundRow(brid2))) -> BoundRowID.equal brid1 brid2 | _ -> false else false (* Checks that `pty1` and `pty2` is exactly equal (up to reordering of records, etc.). Here, `Mono` and `MonoRow` are not supposed to occur in `pty1` nor `pty2`. *) and poly_type_equal (pty1 : poly_type) (pty2 : poly_type) : bool = let rec aux (pty1 : poly_type) (pty2 : poly_type) : bool = let (_, ptymain1) = pty1 in let (_, ptymain2) = pty2 in match (ptymain1, ptymain2) with | (BaseType(bty1), BaseType(bty2)) -> bty1 = bty2 | (FuncType(pdomain1, pty1cod), FuncType(pdomain2, pty2cod)) -> let bdom = aux_domain pdomain1 pdomain2 in bdom && aux pty1cod pty2cod | (EffType(pdomain1, peff1, ptysub1), EffType(pdomain2, peff2, ptysub2)) -> let bdom = aux_domain pdomain1 pdomain2 in bdom && aux_effect peff1 peff2 && aux ptysub1 ptysub2 | (PidType(ppidty1), PidType(ppidty2)) -> aux_pid_type ppidty1 ppidty2 | (ProductType(ptys1), ProductType(ptys2)) -> aux_list (ptys1 |> TupleList.to_list) (ptys2 |> TupleList.to_list) | (RecordType(prow1), RecordType(prow2)) -> poly_row_equal prow1 prow2 | (PackType(absmodsig1), PackType(absmodsig2)) -> begin try subtype_abstract_with_abstract ~cause:(Range.dummy "poly_type_equal1") ~address:Address.root absmodsig1 absmodsig2; subtype_abstract_with_abstract ~cause:(Range.dummy "poly_type_equal2") ~address:Address.root absmodsig2 absmodsig1; true with | _ -> false end | (TypeApp(vid1, ptyargs1), TypeApp(vid2, ptyargs2)) -> TypeID.equal vid1 vid2 && aux_list ptyargs1 ptyargs2 | (TypeVar(Bound(bid1)), TypeVar(Bound(bid2))) -> BoundID.equal bid1 bid2 | (TypeVar(Mono(_)), _) | (_, TypeVar(Mono(_))) -> assert false | _ -> false and aux_list tys1 tys2 = try List.fold_left2 (fun b ty1 ty2 -> b && aux ty1 ty2) true tys1 tys2 with | Invalid_argument(_) -> false and aux_domain pdomain1 pdomain2 = let {ordered = pty1doms; mandatory = pmndlabmap1; optional = poptrow1} = pdomain1 in let {ordered = pty2doms; mandatory = pmndlabmap2; optional = poptrow2} = pdomain2 in aux_list pty1doms pty2doms && poly_label_assoc_equal pmndlabmap1 pmndlabmap2 && poly_row_equal poptrow1 poptrow2 and aux_effect (Effect(pty1)) (Effect(pty2)) = aux pty1 pty2 and aux_pid_type (Pid(pty1)) (Pid(pty2)) = aux pty1 pty2 in aux pty1 pty2 and poly_label_assoc_equal plabmap1 plabmap2 = let merged = LabelAssoc.merge (fun _ ptyopt1 ptyopt2 -> match (ptyopt1, ptyopt2) with | (None, None) -> None | (None, Some(_)) -> Some(false) | (Some(_), None) -> Some(false) | (Some(pty1), Some(pty2)) -> Some(poly_type_equal pty1 pty2) ) plabmap1 plabmap2 in merged |> LabelAssoc.for_all (fun _ b -> b) and subtype_base_kind (bkd1 : base_kind) (bkd2 : base_kind) = match (bkd1, bkd2) with | (TypeKind, TypeKind) -> true | (RowKind(labset1), RowKind(labset2)) -> LabelSet.subset labset2 labset1 | _ -> false and subtype_type_scheme (tyscheme1 : type_scheme) (tyscheme2 : type_scheme) : bool * BoundID.t BoundIDMap.t = let (bids1, pty_body1) = tyscheme1 in let (bids2, pty_body2) = tyscheme2 in match List.combine bids1 bids2 with | exception Invalid_argument(_) -> (false, BoundIDMap.empty) | zipped -> let bidmap = zipped |> List.fold_left (fun bidmap (bid1, bid2) -> bidmap |> BoundIDMap.add bid1 bid2 ) BoundIDMap.empty in let internbid = internbidf bidmap in let internbrid = internbridf bidmap in let b = subtype_poly_type_impl internbid internbrid pty_body1 pty_body2 in (b, bidmap) and lookup_type_entry (tynm : type_name) (tentry1 : type_entry) (tentry2 : type_entry) : substitution option = let Kind(pbkds1, _) = tentry1.type_kind in let Kind(pbkds2, _) = tentry2.type_kind in if List.length pbkds1 = List.length pbkds2 then let subst = match TypeConv.get_opaque_type tentry2.type_scheme with | None -> SubstMap.empty | Some(tyid2) -> SubstMap.empty |> SubstMap.add tyid2 tentry1.type_scheme in Some(subst) else None and lookup_record (rng : Range.t) (modsig1 : module_signature) (modsig2 : module_signature) : substitution = let take_left = (fun _tyid to1 _to2 -> Some(to1)) in match (modsig1, modsig2) with | ((_, ConcStructure(sigr1)), (_, ConcStructure(sigr2))) -> sigr2 |> SigRecord.fold ~v:(fun _x2 _ventry2 subst -> subst ) ~c:(fun ctornm2 _centry2 subst -> subst ) ~f:(fun tynm2 _pty2 subst -> subst ) ~t:(fun tynm2 tentry2 subst -> match sigr1 |> SigRecord.find_type tynm2 with | None -> raise_error (MissingRequiredTypeName(rng, tynm2, tentry2)) | Some(tentry1) -> begin match lookup_type_entry tynm2 tentry1 tentry2 with | None -> raise_error (NotASubtypeTypeDefinition(rng, tynm2, tentry1, tentry2)) | Some(subst0) -> SubstMap.union take_left subst0 subst end ) ~m:(fun modnm2 mentry2 subst -> let modsig2 = mentry2.mod_signature in match sigr1 |> SigRecord.find_module modnm2 with | None -> raise_error (MissingRequiredModuleName(rng, modnm2, modsig2)) | Some(mentry1) -> let modsig1 = mentry1.mod_signature in let subst0 = lookup_record rng modsig1 modsig2 in SubstMap.union take_left subst0 subst ) ~s:(fun _ _ subst -> subst ) SubstMap.empty | _ -> SubstMap.empty and subtype_abstract_with_abstract ~(cause : Range.t) ~(address : Address.t) (absmodsig1 : module_signature abstracted) (absmodsig2 : module_signature abstracted) : unit = let (_, modsig1) = absmodsig1 in let _ = subtype_concrete_with_abstract ~cause ~address modsig1 absmodsig2 in () (* `subtype_concrete_with_concrete address rng modsig1 modsig2` asserts that `modsig1 <= modsig2` holds. *) and subtype_concrete_with_concrete ~(cause : Range.t) ~(address : Address.t) (modsig1 : module_signature) (modsig2 : module_signature) : unit = match (modsig1, modsig2) with | ((_, ConcFunctor(sigftor1)), (_, ConcFunctor(sigftor2))) -> let (quant1, Domain(isig1, sigr1), absmodsigcod1) = (sigftor1.opaques, sigftor1.domain, sigftor1.codomain) in let (quant2, Domain(isig2, sigr2), absmodsigcod2) = (sigftor2.opaques, sigftor2.domain, sigftor2.codomain) in let subst = let modsigdom1 = (isig1, ConcStructure(sigr1)) in let modsigdom2 = (isig2, ConcStructure(sigr2)) in subtype_concrete_with_abstract ~cause ~address modsigdom2 (quant1, modsigdom1) in let absmodsigcod1 = absmodsigcod1 |> substitute_abstract ~cause subst in subtype_abstract_with_abstract ~cause ~address absmodsigcod1 absmodsigcod2 | ((_, ConcStructure(sigr1)), (_, ConcStructure(sigr2))) -> sigr2 |> SigRecord.fold ~v:(fun x2 ventry2 () -> let pty2 = ventry2.val_type in match sigr1 |> SigRecord.find_value x2 with | None -> raise_error (MissingRequiredValName(cause, x2, pty2)) | Some(ventry1) -> let pty1 = ventry1.val_type in if subtype_poly_type pty1 pty2 then () else raise_error (PolymorphicContradiction(cause, x2, pty1, pty2)) ) ~c:(fun ctornm2 centry2 () -> match sigr1 |> SigRecord.find_constructor ctornm2 with | None -> raise_error (MissingRequiredConstructorName(cause, ctornm2, centry2)) | Some(centry1) -> let tyscheme1 = make_type_scheme_from_constructor_entry centry1 in let tyscheme2 = make_type_scheme_from_constructor_entry centry2 in let (b, _) = subtype_type_scheme tyscheme1 tyscheme2 in if b then () else raise_error (NotASubtypeConstructorDefinition(cause, ctornm2, centry1, centry2)) ) ~f:(fun tynm2 pty2 () -> match sigr1 |> SigRecord.find_dummy_fold tynm2 with | None -> begin match sigr2 |> SigRecord.find_type tynm2 with | None -> assert false | Some(tentry2) -> raise_error (MissingRequiredTypeName(cause, tynm2, tentry2)) end | Some(pty1) -> if subtype_poly_type pty1 pty2 then () else begin match (sigr1 |> SigRecord.find_type tynm2, sigr2 |> SigRecord.find_type tynm2) with | (Some(tentry1), Some(tentry2)) -> raise_error (NotASubtypeTypeDefinition(cause, tynm2, tentry1, tentry2)) | _ -> assert false end ) ~t:(fun tynm2 tentry2 () -> match sigr1 |> SigRecord.find_type tynm2 with | None -> raise_error (MissingRequiredTypeName(cause, tynm2, tentry2)) | Some(tentry1) -> let tyscheme1 = let (bids1, pty_body1, _) = tentry1.type_scheme in (bids1, pty_body1) in let tyscheme2 = let (bids2, pty_body2, _) = tentry2.type_scheme in (bids2, pty_body2) in let (b1, bidmap1) = subtype_type_scheme tyscheme1 tyscheme2 in let (b2, _) = subtype_type_scheme tyscheme2 tyscheme1 in let Kind(_, bkdcod1) = tentry1.type_kind in let Kind(_, bkdcod2) = tentry2.type_kind in let b0 = subtype_base_kind bkdcod1 bkdcod2 in if b1 && b2 && b0 then () else raise_error (NotASubtypeTypeDefinition(cause, tynm2, tentry1, tentry2)) ) ~m:(fun modnm2 mentry2 () -> let modsig2 = mentry2.mod_signature in match sigr1 |> SigRecord.find_module modnm2 with | None -> raise_error (MissingRequiredModuleName(cause, modnm2, modsig2)) | Some(mentry1) -> let modsig1 = mentry1.mod_signature in subtype_concrete_with_concrete ~cause ~address modsig1 modsig2 ) ~s:(fun signm2 sentry2 () -> let absmodsig2 = sentry2.sig_signature in match sigr1 |> SigRecord.find_signature signm2 with | None -> raise_error (MissingRequiredSignatureName(cause, signm2, absmodsig2)) | Some(sentry1) -> let absmodsig1 = sentry1.sig_signature in subtype_abstract_with_abstract ~cause ~address absmodsig1 absmodsig2; subtype_abstract_with_abstract ~cause ~address absmodsig2 absmodsig1; () ) () | _ -> raise_error (NotASubtype(cause, modsig1, modsig2)) and subtype_concrete_with_abstract ~(cause : Range.t) ~(address : Address.t) (modsig1 : module_signature) (absmodsig2 : module_signature abstracted) : substitution = let (quant2, modsig2) = absmodsig2 in let subst = lookup_record cause modsig1 modsig2 in let modsig2 = modsig2 |> substitute_concrete ~cause subst in subtype_concrete_with_concrete ~cause ~address modsig1 modsig2; subst and subtype_signature ~(cause : Range.t) ~(address : Address.t) (modsig1 : module_signature) (absmodsig2 : module_signature abstracted) = subtype_concrete_with_abstract ~cause ~address modsig1 absmodsig2 and substitute_signature_source (subst : substitution) (isig : signature_source) : signature_source = isig (* TODO *) and substitute_concrete ~(cause : Range.t) (subst : substitution) (modsig : module_signature) : module_signature = match modsig with | (isig, ConcFunctor(sigftor)) -> let (quant, Domain(isigdom, sigr), absmodsigcod) = (sigftor.opaques, sigftor.domain, sigftor.codomain) in let sigr = sigr |> substitute_structure ~cause subst in let absmodsigcod = absmodsigcod |> substitute_abstract ~cause subst in let sigftor = { sigftor with opaques = quant; domain = Domain(isigdom |> substitute_signature_source subst, sigr); codomain = absmodsigcod; } in (isig |> substitute_signature_source subst, ConcFunctor(sigftor)) (* Strictly speaking, we should assert that `quant` and the domain of `subst` be disjoint. *) | (isig, ConcStructure(sigr)) -> let sigr = sigr |> substitute_structure ~cause subst in (isig |> substitute_signature_source subst, ConcStructure(sigr)) (* Given `modsig1` and `modsig2` which are already known to satisfy `modsig1 <= modsig2`, `copy_closure` copies every closure and every global name occurred in `modsig1` into the corresponding occurrence in `modsig2`. *) and copy_closure (modsig1 : module_signature) (modsig2 : module_signature) : module_signature = match (modsig1, modsig2) with | ((_isig1, ConcStructure(sigr1)), (isig2, ConcStructure(sigr2))) -> let sigr2new = copy_closure_in_structure sigr1 sigr2 in (isig2, ConcStructure(sigr2new)) | ((_isig1, ConcFunctor(sigftor1)), (isig2, ConcFunctor(sigftor2))) -> let Domain(_isigdom1, sigrdom1) = sigftor1.domain in let Domain(isigdom2, sigrdom2) = sigftor2.domain in let sigrdom2new = copy_closure_in_structure sigrdom1 sigrdom2 in let (_, modsig1) = sigftor1.codomain in let (quant2, modsig2) = sigftor2.codomain in let modsig2new = copy_closure modsig1 modsig2 in (isig2, ConcFunctor({ sigftor2 with domain = Domain(isigdom2, sigrdom2new); codomain = (quant2, modsig2new); closure = sigftor1.closure; })) | _ -> assert false and copy_closure_in_structure (sigr1 : SigRecord.t) (sigr2 : SigRecord.t) : SigRecord.t = sigr2 |> SigRecord.map ~v:(fun x ventry2 -> match sigr1 |> SigRecord.find_value x with | None -> assert false | Some(ventry1) -> { ventry2 with val_global = ventry1.val_global } ) ~c:(fun _ctornm centry2 -> centry2) ~f:(fun _tynm pty2 -> pty2) ~t:(fun _tynm tentry2 -> tentry2) ~m:(fun modnm mentry2 -> match sigr1 |> SigRecord.find_module modnm with | None -> assert false | Some(mentry1) -> let modsig2 = copy_closure mentry1.mod_signature mentry2.mod_signature in { mod_signature = modsig2; mod_name = mentry1.mod_name; mod_doc = mentry2.mod_doc; (* Should use `mentry2`, not `mentry1` for doc comments. *) } ) ~s:(fun signm sentry2 -> match sigr1 |> SigRecord.find_signature signm with | None -> assert false | Some(sentry1) -> { sig_signature = sentry2.sig_signature; sig_doc = sentry2.sig_doc; sig_address = sentry1.sig_address; } ) and substitute_type_id (subst : substitution) (tyid_from : TypeID.t) : TypeID.t = match subst |> SubstMap.find_opt tyid_from with | None -> tyid_from | Some(tyscheme) -> begin match TypeConv.get_opaque_type tyscheme with | None -> assert false | Some(tyid_to) -> tyid_to end and update_subsignature (modnms : module_name list) (updater : module_signature -> module_signature) (modsig : module_signature) : module_signature = match modnms with | [] -> updater modsig | modnm0 :: modnms -> begin match modsig with | (_, ConcFunctor(_)) -> modsig | (isig, ConcStructure(sigr)) -> begin let sigr = sigr |> SigRecord.map ~v:(fun _x ventry -> ventry) ~c:(fun _ctornm centry -> centry) ~f:(fun _tynm pty -> pty) ~t:(fun _tynm tentry -> tentry) ~m:(fun modnm mentry -> if String.equal modnm modnm0 then let modsig = mentry.mod_signature |> update_subsignature modnms updater in { mentry with mod_signature = modsig } else mentry ) ~s:(fun _signm absmodsig -> absmodsig) in (isig, ConcStructure(sigr)) end end and substitute_type_entity ~(cause : Range.t) (bids_source : BoundID.t list) (subst : substitution) (tyentity : type_entity) : type_entity = match tyentity with | Opaque(tyid_from) -> begin match subst |> SubstMap.find_opt tyid_from with | None -> Opaque(tyid_from) | Some((bids_target, _, tyentity_target)) -> begin match tyentity_target with | Opaque(tyid_to) -> Opaque(tyid_to) | Synonym -> Synonym | Variant(ctormap_target) -> let bidmap = match List.combine bids_target bids_source with | exception Invalid_argument(_) -> assert false | zipped -> zipped |> List.fold_left (fun bidmap (bid_from, bid_to) -> let pty_to = (Range.dummy "substitute_type_entity", TypeVar(Bound(bid_to))) in bidmap |> BoundIDMap.add bid_from pty_to ) BoundIDMap.empty in let ctormap = ctormap_target |> ConstructorMap.map (fun (ctorid, ptys) -> (ctorid, ptys |> List.map (fun pty -> TypeConv.substitute_poly_type bidmap pty) ) ) in Variant(ctormap) end end | Synonym -> Synonym | Variant(ctormap) -> let ctormap = ctormap |> ConstructorMap.map (fun (ctorid, ptys) -> (ctorid, ptys |> List.map (substitute_poly_type ~cause subst)) ) in Variant(ctormap) and substitute_structure ~(cause : Range.t) (subst : substitution) (sigr : SigRecord.t) : SigRecord.t = sigr |> SigRecord.map ~v:(fun _x ventry -> { ventry with val_type = ventry.val_type |> substitute_poly_type ~cause subst } ) ~c:(fun _ctornm centry -> { centry with belongs = centry.belongs |> substitute_type_id subst; parameter_types = centry.parameter_types |> List.map (substitute_poly_type ~cause subst); } ) ~f:(fun _tynm pty -> pty |> substitute_poly_type ~cause subst ) ~t:(fun _tynm tentry -> let (bids, pty_body, tyentity) = tentry.type_scheme in let pty_body = pty_body |> substitute_poly_type ~cause subst in let tyentity = tyentity |> substitute_type_entity ~cause bids subst in { type_scheme = (bids, pty_body, tyentity); type_kind = tentry.type_kind; type_doc = tentry.type_doc; } ) ~m:(fun _ mentry -> { mentry with mod_signature = mentry.mod_signature |> substitute_concrete ~cause subst } ) ~s:(fun _ sentry -> let absmodsig = sentry.sig_signature |> substitute_abstract ~cause subst in { sentry with sig_signature = absmodsig } ) and substitute_abstract ~(cause : Range.t) (subst : substitution) (absmodsig : module_signature abstracted) : module_signature abstracted = let (quant, modsig) = absmodsig in let modsig = substitute_concrete ~cause subst modsig in (quant, modsig) (* Strictly speaking, we should assert that `quant` and the domain of `subst` be disjoint. *) (* Applies the subtitution `subst` to `pty`. Here, `MonoRow` are not supposed to occur in `pty`. *) and substitute_poly_type ~(cause : Range.t) (subst : substitution) (pty : poly_type) : poly_type = let rec aux (rng, ptymain) = let ptymain = match ptymain with | BaseType(_) -> ptymain | PidType(ppid) -> PidType(aux_pid ppid) | TypeVar(_) -> ptymain | ProductType(ptys) -> ProductType(ptys |> TupleList.map aux) | EffType(pdomain, peff, ptysub) -> EffType(aux_domain pdomain, aux_effect peff, aux ptysub) | FuncType(pdomain, ptycod) -> FuncType(aux_domain pdomain, aux ptycod) | RecordType(prow) -> RecordType(aux_row prow) | TypeApp(tyid_from, ptyargs) -> begin match subst |> SubstMap.find_opt tyid_from with | None -> TypeApp(tyid_from, ptyargs |> List.map aux) | Some((bids, pty_body, _)) -> let tyscheme = (bids, pty_body) in begin match TypeConv.apply_type_scheme_poly tyscheme (ptyargs |> List.map aux) with | None -> assert false (* Arity mismatch; this cannot happen. *) | Some((_, ptymain)) -> ptymain end end | PackType(absmodsig) -> let absmodsig = substitute_abstract ~cause subst absmodsig in PackType(absmodsig) in (rng, ptymain) and aux_domain pdomain = let {ordered = ptydoms; mandatory = pmndlabmap; optional = poptrow} = pdomain in { ordered = ptydoms |> List.map aux; mandatory = pmndlabmap |> LabelAssoc.map aux; optional = aux_row poptrow; } and aux_pid = function | Pid(pty) -> Pid(aux pty) and aux_effect = function | Effect(pty) -> Effect(aux pty) and aux_row (prow : poly_row) = match prow with | RowCons(rlabel, ty, prow) -> RowCons(rlabel, aux ty, aux_row prow) | RowVar(_) -> prow (* Assumes that `MonoRow` does not occur in rows. *) | RowEmpty -> RowEmpty in aux pty and typecheck_declaration ~(address : Address.t) (tyenv : Typeenv.t) (utdecl : untyped_declaration) : SigRecord.t abstracted = let (attrs, utdeclmain) = utdecl in match utdeclmain with | DeclVal((_, x), typarams, rowparams, mty, attrs) -> let (declattr, warnings) = DeclarationAttribute.decode attrs in warnings |> List.iter Logging.warn_invalid_attribute; let pre = let pre_init = { level = 0; tyenv = tyenv; local_type_parameters = TypeParameterMap.empty; local_row_parameters = RowParameterMap.empty; } in let (pre, _) = make_type_parameter_assoc pre_init typarams in { pre with level = 1 } |> add_local_row_parameter rowparams in let ty = decode_manual_type pre mty in let pty = TypeConv.generalize 0 ty in let gname = OutputIdentifier.fresh_global_dummy () in let ventry = { val_type = pty; val_global = gname; val_doc = declattr.doc; } in let sigr = SigRecord.empty |> SigRecord.add_value x ventry in (OpaqueIDMap.empty, sigr) | DeclTypeOpaque(tyident, kdannot, attrs) -> let (declattr, warnings) = DeclarationAttribute.decode attrs in warnings |> List.iter Logging.warn_invalid_attribute; let (_, tynm) = tyident in let pre_init = { level = 0; tyenv = tyenv; local_type_parameters = TypeParameterMap.empty; local_row_parameters = RowParameterMap.empty; } in let kd = match kdannot with | None -> Kind([], TypeKind) | Some(mnkd) -> decode_manual_kind pre_init mnkd in let oid = TypeID.fresh address tynm in let Kind(bkds, _) = kd in let tentry = let (bids, pty_body) = TypeConv.make_opaque_type_scheme_from_base_kinds bkds oid in { type_scheme = (bids, pty_body, Opaque(oid)); type_kind = kd; type_doc = declattr.doc; } in let sigr = SigRecord.empty |> SigRecord.add_type tynm tentry in (OpaqueIDMap.singleton oid kd, sigr) | DeclModule(modident, utsig, attrs) -> let (declattr, warnings) = DeclarationAttribute.decode attrs in warnings |> List.iter Logging.warn_invalid_attribute; let (rngm, m) = modident in let absmodsig = typecheck_signature ~address:(address |> Address.append_member m) tyenv utsig in let (quant, modsig) = absmodsig in let sname = get_space_name rngm m in let mentry = { mod_signature = modsig; mod_name = sname; mod_doc = declattr.doc; } in let sigr = SigRecord.empty |> SigRecord.add_module m mentry in (quant, sigr) | DeclSig(sigident, utsig, attrs) -> let (declattr, warnings) = DeclarationAttribute.decode attrs in warnings |> List.iter Logging.warn_invalid_attribute; let (_, signm) = sigident in let absmodsig = typecheck_signature ~address:Address.root tyenv utsig in let sigr = let sentry = { sig_signature = absmodsig; sig_doc = declattr.doc; sig_address = address; } in SigRecord.empty |> SigRecord.add_signature signm sentry in (OpaqueIDMap.empty, sigr) | DeclInclude(utsig) -> let absmodsig = typecheck_signature ~address tyenv utsig in let (quant, modsig) = absmodsig in begin match modsig with | (_, ConcFunctor(_)) -> let (rng, _) = utsig in raise_error (NotAStructureSignature(rng, modsig)) | (isig, ConcStructure(sigr)) -> (quant, sigr) end and typecheck_declaration_list ~(address : Address.t) (tyenv : Typeenv.t) (utdecls : untyped_declaration list) : SigRecord.t abstracted = let (quantacc, sigracc, _) = utdecls |> List.fold_left (fun (quantacc, sigracc, tyenv) ((rng, _) as utdecl) -> let (quant, sigr) = typecheck_declaration ~address tyenv utdecl in let quantacc = merge_quantifier quantacc quant in let sigracc = match SigRecord.disjoint_union sigracc sigr with | Ok(sigr) -> sigr | Error(s) -> raise_error (ConflictInSignature(rng, s)) in let tyenv = tyenv |> update_type_environment_by_signature_record sigr in (quantacc, sigracc, tyenv) ) (OpaqueIDMap.empty, SigRecord.empty, tyenv) in (quantacc, sigracc) and copy_abstract_signature ~(cause : Range.t) ~(address_to : Address.t) (absmodsig_from : module_signature abstracted) : module_signature abstracted = let (quant_from, modsig_from) = absmodsig_from in let (quant_to, subst) = OpaqueIDMap.fold (fun oid_from pkd (quant_to, subst) -> let oid_to = let s = TypeID.name oid_from in TypeID.fresh address_to s in let quant_to = quant_to |> OpaqueIDMap.add oid_to pkd in let Kind(pbkds, _) = pkd in let (bids, pty_body) = TypeConv.make_opaque_type_scheme_from_base_kinds pbkds oid_to in let subst = subst |> SubstMap.add oid_from (bids, pty_body, Opaque(oid_to)) in (quant_to, subst) ) quant_from (OpaqueIDMap.empty, SubstMap.empty) in let modsig_to = modsig_from |> substitute_concrete ~cause subst in (quant_to, modsig_to) and typecheck_signature ~(address : Address.t) (tyenv : Typeenv.t) (utsig : untyped_signature) : module_signature abstracted = let (rng, utsigmain) = utsig in match utsigmain with | SigVar(signm) -> begin match tyenv |> Typeenv.find_signature signm with | None -> raise_error (UnboundSignatureName(rng, signm)) | Some(sentry_from) -> let absmodsig_from = sentry_from.sig_signature in let address_sigvar = sentry_from.sig_address in let absmodsig_to = copy_abstract_signature ~cause:rng ~address_to:address absmodsig_from in let (quant, (_, modsigmain)) = absmodsig_to in (quant, (ISigVar(address_sigvar, signm), modsigmain)) (* We need to rename opaque IDs here, since otherwise we would mistakenly make the following program pass: ``` signature S = sig type t :: 0 end module F = fun(X : S) -> fun(Y : S) -> struct type f(x : X.t) : Y.t = x end ``` This issue was reported by `@elpinal`: https://twitter.com/elpin1al/status/1269198048967589889?s=20 *) end | SigPath(utmod1, sigident2) -> let (absmodsig1, _) = typecheck_module ~address:Address.root tyenv utmod1 in let (quant1, modsig1) = absmodsig1 in begin match modsig1 with | (_, ConcFunctor(_)) -> let (rng1, _) = utmod1 in raise_error (NotOfStructureType(rng1, modsig1)) | (_, ConcStructure(sigr1)) -> let (rng2, signm2) = sigident2 in begin match sigr1 |> SigRecord.find_signature signm2 with | None -> raise_error (UnboundSignatureName(rng2, signm2)) | Some(sentry2) -> let absmodsig2 = sentry2.sig_signature in let (_, modsig2) = absmodsig2 in if opaque_occurs quant1 modsig2 then raise_error (OpaqueIDExtrudesScopeViaSignature(rng, absmodsig2)) else absmodsig2 (* Combining typing rules (P-Mod) and (S-Path) in the original paper "F-ing modules" [Rossberg, Russo & Dreyer 2014], we can ignore `quant1` here. However, we CANNOT SIMPLY ignore `quant1`; according to the second premise “Γ ⊢ Σ : Ω” of (P-Mod), we must assert `absmodsig2` do not contain every type variable in `quant1`. (we have again realized this thanks to `@elpinal`.) https://twitter.com/elpin1al/status/1272110415435010048?s=20 *) end end | SigDecls(openspecs, utdecls) -> let tyenv = tyenv |> add_open_specs_to_type_environment openspecs in let (quant, sigr) = typecheck_declaration_list ~address tyenv utdecls in (quant, (ISigDecls(sigr), ConcStructure(sigr))) | SigFunctor(modident, utsigdom, utsigcod) -> let (rngm, m) = modident in let (quant, sigdom) = let address = Address.root |> Address.append_member m in typecheck_signature ~address tyenv utsigdom in let abssigcod = let sname = get_space_name rngm m in let mentry = { mod_signature = sigdom; mod_name = sname; mod_doc = None; } in let tyenv = tyenv |> Typeenv.add_module m mentry in let address = address |> Address.append_functor_body ~arg:m in typecheck_signature ~address tyenv utsigcod in begin match sigdom with | (isigdom, ConcStructure(sigr)) -> let sigftor = { opaques = quant; domain = Domain(isigdom, sigr); codomain = abssigcod; closure = None; } in let (_, (isigcod, _)) = abssigcod in (OpaqueIDMap.empty, (ISigFunctor(m, isigdom, isigcod), ConcFunctor(sigftor))) | _ -> raise_error (SupportOnlyFirstOrderFunctor(rng)) end | SigWith(utsig0, modidents, tybinds) -> let (rng0, _) = utsig0 in let absmodsig0 = typecheck_signature ~address tyenv utsig0 in let (quant0, modsig0) = absmodsig0 in let sigr_last = let (rng_last, modsig_last) = modidents |> List.fold_left (fun (rngpre, modsig) (rng, modnm) -> match modsig with | (_, ConcFunctor(_)) -> raise_error (NotAStructureSignature(rngpre, modsig)) | (_, ConcStructure(sigr)) -> begin match sigr |> SigRecord.find_module modnm with | None -> raise_error (UnboundModuleName(rng, modnm)) | Some(mentry) -> (rng, mentry.mod_signature) end ) (rng0, modsig0) in match modsig_last with | (_, ConcFunctor(_)) -> raise_error (NotAStructureSignature(rng_last, modsig_last)) | (_, ConcStructure(sigr_last)) -> sigr_last in let (tydefs, ctordefs) = bind_types ~address tyenv tybinds in let (subst, quant) = tydefs |> List.fold_left (fun (subst, quant) (tynm1, tentry1) -> let (tyid0, pkd_expected) = match sigr_last |> SigRecord.find_type tynm1 with | None -> raise_error (UndefinedTypeName(rng, tynm1)) | Some(tentry0) -> begin match TypeConv.get_opaque_type tentry0.type_scheme with | Some(tyid0) -> assert (quant0 |> OpaqueIDMap.mem tyid0); (tyid0, tentry0.type_kind) | None -> raise_error (CannotRestrictTransparentType(rng, tynm1, tentry1)) end in let pkd_actual = tentry1.type_kind in unify_kind rng tynm1 ~actual:pkd_actual ~expected:pkd_expected; let subst = subst |> SubstMap.add tyid0 tentry1.type_scheme in let quant = quant |> OpaqueIDMap.remove tyid0 in (subst, quant) ) (SubstMap.empty, quant0) in let modsig_ret = modsig0 |> substitute_concrete ~cause:rng subst in let modsig_ret = modsig_ret |> update_subsignature (modidents |> List.map snd) (fun modsig_last -> match modsig_last with | (_, ConcFunctor(_)) -> assert false | (_, ConcStructure(sigr_last)) -> let sigr_last = sigr_last |> add_constructor_definitions ctordefs in let (_, (isig0, _)) = absmodsig0 in (ISigWith(isig0, tydefs), ConcStructure(sigr_last)) ) in (quant, modsig_ret) (* Checks that `kd1` and `kd2` are the same. *) and unify_kind (rng : Range.t) (tynm : type_name) ~actual:(kd1 : kind) ~expected:(kd2 : kind) : unit = let Kind(bkdsdom1, bkdcod1) = kd1 in let Kind(bkdsdom2, bkdcod2) = kd2 in match List.combine bkdsdom1 bkdsdom2 with | exception Invalid_argument(_) -> let arity_actual = List.length bkdsdom1 in let arity_expected = List.length bkdsdom2 in raise_error (InvalidNumberOfTypeArguments(rng, tynm, arity_expected, arity_actual)) | bkddomzips -> let bdom = bkddomzips |> List.for_all (fun (bkd1, bkd2) -> base_kind_equal bkd1 bkd2) in if bdom && base_kind_equal bkdcod1 bkdcod2 then () else raise_error (KindContradiction(rng, tynm, kd1, kd2)) and base_kind_equal (bkd1 : base_kind) (bkd2 : base_kind) : bool = match (bkd1, bkd2) with | (TypeKind, TypeKind) -> true | (RowKind(labset1), RowKind(labset2)) -> LabelSet.equal labset1 labset2 | _ -> false and typecheck_binding ~(address : Address.t) (tyenv : Typeenv.t) (utbind : untyped_binding) : SigRecord.t abstracted * (ModuleAttribute.t * binding list) = let (_, utbindmain) = utbind in match utbindmain with | BindVal(attrs, External(extbind)) -> let (valattr, warnings) = ValueAttribute.decode attrs in warnings |> List.iter Logging.warn_invalid_attribute; let mty = extbind.ext_type_annot in let (rngv, x) = extbind.ext_identifier in let arity = extbind.ext_arity in let pty = let pre = let pre_init = { level = 0; tyenv = tyenv; local_type_parameters = TypeParameterMap.empty; local_row_parameters = RowParameterMap.empty; } in let (pre, _) = make_type_parameter_assoc pre_init extbind.ext_type_params in { pre with level = 1 } |> add_local_row_parameter extbind.ext_row_params in let ty = decode_manual_type pre mty in TypeConv.generalize 0 ty in let has_option = extbind.ext_has_option in let gname = let is_test_suite = valattr.is_test_suite in generate_global_name ~is_test_suite ~arity:arity ~has_option:has_option rngv x in let sigr = let ventry = { val_type = pty; val_global = gname; val_doc = None; } in SigRecord.empty |> SigRecord.add_value x ventry in let ibinds = [ IBindVal(IExternal(gname, extbind.ext_code)) ] in ((OpaqueIDMap.empty, sigr), (ModuleAttribute.empty, ibinds)) | BindVal(attrs, Internal(rec_or_nonrec)) -> let (valattr, warnings) = ValueAttribute.decode attrs in warnings |> List.iter Logging.warn_invalid_attribute; let is_test_suite = valattr.is_test_suite in let pre_init = { level = 0; tyenv = tyenv; local_type_parameters = TypeParameterMap.empty; local_row_parameters = RowParameterMap.empty; } in let (sigr, i_rec_or_nonrec) = match rec_or_nonrec with | Rec([]) -> assert false | Rec(valbinds) -> let proj gname = OutputIdentifier.Global(gname) in let recbinds = typecheck_letrec_mutual (global_name_scheme is_test_suite) proj pre_init valbinds in let (sigr, irecbindacc) = recbinds |> List.fold_left (fun (sigr, irecbindacc) (x, pty, gname_outer, _, e) -> let ventry = { val_type = pty; val_global = gname_outer; val_doc = None; } in let sigr = sigr |> SigRecord.add_value x ventry in let irecbindacc = Alist.extend irecbindacc (x, gname_outer, pty, e) in (sigr, irecbindacc) ) (SigRecord.empty, Alist.empty) in (sigr, IRec(Alist.to_list irecbindacc)) | NonRec(valbind) -> let (pty, gname, e) = let arity = List.length valbind.vb_parameters + List.length valbind.vb_mandatories in let has_option = (List.length valbind.vb_optionals > 0) in let gnamef = generate_global_name ~is_test_suite ~arity:arity ~has_option:has_option in typecheck_let gnamef pre_init valbind in let (_, x) = valbind.vb_identifier in let sigr = let ventry = { val_type = pty; val_global = gname; val_doc = None; } in SigRecord.empty |> SigRecord.add_value x ventry in (sigr, INonRec(x, gname, pty, e)) in let ibinds = [ IBindVal(i_rec_or_nonrec) ] in ((OpaqueIDMap.empty, sigr), (ModuleAttribute.empty, ibinds)) | BindType([]) -> assert false | BindType((_ :: _) as tybinds) -> let (tydefs, ctordefs) = bind_types ~address tyenv tybinds in let sigr = tydefs |> List.fold_left (fun sigr (tynm, tentry) -> sigr |> SigRecord.add_type tynm tentry ) SigRecord.empty in let sigr = sigr |> add_constructor_definitions ctordefs in ((OpaqueIDMap.empty, sigr), (ModuleAttribute.empty, [])) | BindModule(modident, utsigopt2, utmod1) -> let (rngm, m) = modident in let (absmodsig1, (modattrsub, ibindssub)) = let address = address |> Address.append_member m in typecheck_module ~address tyenv utmod1 in let (quant, modsig) = match utsigopt2 with | None -> absmodsig1 | Some(utsig2) -> let (_, modsig1) = absmodsig1 in let absmodsig2 = typecheck_signature ~address:(address |> Address.append_member m) tyenv utsig2 in coerce_signature ~cause:rngm ~address modsig1 absmodsig2 in let sname = get_space_name rngm m in let mentry = { mod_signature = modsig; mod_name = sname; mod_doc = None; } in let sigr = SigRecord.empty |> SigRecord.add_module m mentry in let ibinds = match ibindssub with | [] -> [] | _ :: _ -> [IBindModule(sname, modattrsub, ibindssub)] in ((quant, sigr), (ModuleAttribute.empty, ibinds)) | BindInclude(utmod) -> let (absmodsig, (attrs, ibinds)) = typecheck_module ~address tyenv utmod in let (quant, modsig) = absmodsig in begin match modsig with | (_, ConcFunctor(_)) -> let (rng, _) = utmod in raise_error (NotOfStructureType(rng, modsig)) | (_, ConcStructure(sigr)) -> ((quant, sigr), (attrs, ibinds)) end | BindSig(sigident, sigbind) -> let (_, signm) = sigident in let absmodsig = typecheck_signature ~address:Address.root tyenv sigbind in let sigr = let sentry = { sig_signature = absmodsig; sig_doc = None; sig_address = address; } in SigRecord.empty |> SigRecord.add_signature signm sentry in ((OpaqueIDMap.empty, sigr), (ModuleAttribute.empty, [])) and bind_types ~(address : Address.t) (tyenv : Typeenv.t) (tybinds : type_binding list) : (type_name * type_entry) list * variant_definition list = let pre_init = { level = 0; tyenv = tyenv; local_type_parameters = TypeParameterMap.empty; local_row_parameters = RowParameterMap.empty; } in (* Add the arity of each variant type to the type environment, Construct the graph for checking dependency among synonym types. *) let (synacc, vntacc, vertices, graph, tyenv) = tybinds |> List.fold_left (fun (synacc, vntacc, vertices, graph, tyenv) (tyident, tyvars, syn_or_vnt) -> let (rng, tynm) = tyident in let kd = let bkddoms = tyvars |> List.map (fun (_, kdannot) -> match kdannot with | None -> TypeKind | Some(mnbkd) -> decode_manual_base_kind pre_init mnbkd ) in Kind(bkddoms, TypeKind) in match syn_or_vnt with | BindSynonym(synbind) -> let syndata = DependencyGraph.{ position = rng; type_variables = tyvars; definition_body = synbind; kind = kd; } in let graph = graph |> DependencyGraph.add_vertex tynm syndata in let synacc = Alist.extend synacc (tyident, synbind) in let vertices = vertices |> SynonymNameSet.add tynm in (synacc, vntacc, vertices, graph, tyenv) | BindVariant(vntbind) -> let Kind(bkds, _) = kd in let tyid = TypeID.fresh address tynm in let tentry = let (bids_temp, pty_body_temp) = TypeConv.make_opaque_type_scheme_from_base_kinds bkds tyid in { type_scheme = (bids_temp, pty_body_temp, Opaque(tyid)); type_kind = kd; type_doc = None; } (* `type_scheme` will be changed to `(_, _, Variant(_))` afterwards. *) in let tyenv = tyenv |> Typeenv.add_type tynm tentry in let vntacc = Alist.extend vntacc (tyident, tyvars, vntbind, tyid, kd, tentry) in (synacc, vntacc, vertices, graph, tyenv) ) (Alist.empty, Alist.empty, SynonymNameSet.empty, DependencyGraph.empty, tyenv) in let pre = { pre_init with tyenv = tyenv } in (* Traverse the definition of each synonym type in order to add to the graph the edges that stand for dependencies between synonym types. *) let graph = synacc |> Alist.to_list |> List.fold_left (fun graph syn -> let (tyident, mtyreal) = syn in let (_, tynm) = tyident in let dependencies = get_dependency_on_synonym_types vertices pre mtyreal in graph |> SynonymNameSet.fold (fun tynm_dep graph -> graph |> DependencyGraph.add_edge ~depended:tynm_dep ~depending:tynm ) dependencies ) graph in (* Check that no cyclic dependency exists among synonym types and make the signature to be returned from the type definitions. *) let syns = match DependencyGraph.topological_sort graph with | Error(cycle) -> raise_error (CyclicSynonymTypeDefinition(cycle)) | Ok(syns) -> syns in (* Add the definition of the synonym types to the type environment. *) let (tyenv, tydefacc) = syns |> List.fold_left (fun (tyenv, tydefacc) syn -> let pre = { pre with tyenv = tyenv } in let (tynm, syndata) = syn in let DependencyGraph.{ type_variables = tyvars; definition_body = mtyreal; kind = pkd; _ } = syndata in let (pre, typaramassoc) = make_type_parameter_assoc pre tyvars in let bids = typaramassoc |> TypeParameterAssoc.values |> List.map MustBeBoundID.to_bound in let ty_body = decode_manual_type pre mtyreal in let pty_body = TypeConv.generalize 0 ty_body in let tentry = { type_scheme = (bids, pty_body, Synonym); type_kind = pkd; type_doc = None; } in let tyenv = tyenv |> Typeenv.add_type tynm tentry in let tydefacc = Alist.extend tydefacc (tynm, tentry) in (tyenv, tydefacc) ) (tyenv, Alist.empty) in let pre = { pre with tyenv } in (* Traverse the definition of each variant type. *) let (tydefacc, ctordefacc) = vntacc |> Alist.to_list |> List.fold_left (fun (tydefacc, ctordefacc) vnt -> let (tyident, tyvars, ctorbrs, tyid, pkd, tentry) = vnt in let (_, tynm) = tyident in let (pre, typaramassoc) = make_type_parameter_assoc pre tyvars in let bids = typaramassoc |> TypeParameterAssoc.values |> List.map MustBeBoundID.to_bound in let ctormap = make_constructor_branch_map pre ctorbrs in let tentry = let (bids_temp, pty_body_temp, _) = tentry.type_scheme in let bidmap = match List.combine bids_temp bids with | exception Invalid_argument(_) -> assert false | zipped -> zipped |> List.fold_left (fun bidmap (bid_from, bid_to) -> let pty_to = (Range.dummy "substitute_type_entity", TypeVar(Bound(bid_to))) in bidmap |> BoundIDMap.add bid_from pty_to ) BoundIDMap.empty in let pty_body = TypeConv.substitute_poly_type bidmap pty_body_temp in { tentry with type_scheme = (bids, pty_body, Variant(ctormap)) } in let tydefacc = Alist.extend tydefacc (tynm, tentry) in let ctordefacc = Alist.extend ctordefacc (tynm, tyid, bids, ctormap) in (tydefacc, ctordefacc) ) (tydefacc, Alist.empty) in (Alist.to_list tydefacc, Alist.to_list ctordefacc) and typecheck_module ~(address : Address.t) (tyenv : Typeenv.t) (utmod : untyped_module) : module_signature abstracted * (ModuleAttribute.t * binding list) = let (rng, utmodmain) = utmod in match utmodmain with | ModVar(m) -> let mentry = find_module tyenv (rng, m) in let modsig = mentry.mod_signature in let absmodsig = (OpaqueIDMap.empty, modsig) in (absmodsig, (ModuleAttribute.empty, [])) | ModBinds(attrs, openspecs, utbinds) -> let (modattr, warnings) = ModuleAttribute.decode attrs in warnings |> List.iter Logging.warn_invalid_attribute; let tyenv = tyenv |> add_open_specs_to_type_environment openspecs in let (abssigr, (modattr_included, ibinds)) = typecheck_binding_list ~address tyenv utbinds in let (quant, sigr) = abssigr in let isig = ISigDecls(sigr) in let absmodsig = (quant, (isig, ConcStructure(sigr))) in (absmodsig, (ModuleAttribute.merge modattr modattr_included, ibinds)) | ModProjMod(utmod, modident) -> let (absmodsig, imod) = typecheck_module ~address tyenv utmod in let (quant, modsig) = absmodsig in begin match modsig with | (_, ConcFunctor(_)) -> let (rng, _) = utmod in raise_error (NotOfStructureType(rng, modsig)) | (_, ConcStructure(sigr)) -> let (rng, m) = modident in begin match sigr |> SigRecord.find_module m with | None -> raise_error (UnboundModuleName(rng, m)) | Some(mentry) -> let absmodsigp = (quant, mentry.mod_signature) in (absmodsigp, imod) end end | ModFunctor(modident, utsigdom, utmod0) -> let (rngm, m) = modident in let absmodsigdom = let address = Address.root |> Address.append_member m in typecheck_signature ~address tyenv utsigdom in let (quant, modsigdom) = absmodsigdom in let (absmodsigcod, _) = let sname = get_space_name rngm m in (* Printf.printf "MOD-FUNCTOR %s\n" m; (* for debug *) display_signature 0 modsigdom; (* for debug *) *) let mentry = { mod_signature = modsigdom; mod_name = sname; mod_doc = None; } in let tyenv = tyenv |> Typeenv.add_module m mentry in let address = address |> Address.append_functor_body ~arg:m in typecheck_module ~address tyenv utmod0 in let absmodsig = begin match modsigdom with | (isigdom, ConcStructure(sigrdom)) -> let sigftor = { opaques = quant; domain = Domain(isigdom, sigrdom); codomain = absmodsigcod; closure = Some(modident, utmod0, tyenv); } in let (_, (isigcod, _)) = absmodsigcod in let isig = ISigFunctor(m, isigdom, isigcod) in (OpaqueIDMap.empty, (isig, ConcFunctor(sigftor))) | _ -> raise_error (SupportOnlyFirstOrderFunctor(rng)) end in (absmodsig, (ModuleAttribute.empty, [])) | ModApply(modidentchain1, modidentchain2) -> let mentry1 = find_module_from_chain tyenv modidentchain1 in let modsig1 = mentry1.mod_signature in let mentry2 = find_module_from_chain tyenv modidentchain2 in let modsig2 = mentry2.mod_signature in let sname2 = mentry2.mod_name in begin match modsig1 with | (_, ConcStructure(_)) -> let rng1 = get_module_name_chain_position modidentchain1 in raise_error (NotOfFunctorType(rng1, modsig1)) | (_, ConcFunctor(sigftor1)) -> let { opaques = quant; domain = Domain(_, sigrdom1); codomain = absmodsigcod1; _ } = sigftor1 in begin match sigftor1.closure with | None -> assert false | Some(modident0, utmodC, tyenv0) -> (* Check the subtype relation between the signature `modsig2` of the argument module and the domain `modsigdom1` of the applied functor. *) let subst = let ((rng2, _), _) = modidentchain2 in let isig = ISigDecls(sigrdom1) in let modsigdom1 = (isig, ConcStructure(sigrdom1)) in subtype_signature ~cause:rng2 ~address modsig2 (quant, modsigdom1) in let ((_, modsig0), ibinds) = let tyenv0 = let (_, m0) = modident0 in let mentry = { mod_signature = modsig2; mod_name = sname2; mod_doc = None; } in tyenv0 |> Typeenv.add_module m0 mentry in typecheck_module ~address tyenv0 utmodC in let (quant1subst, modsigcod1subst) = absmodsigcod1 |> substitute_abstract ~cause:rng subst in let absmodsig = (quant1subst, copy_closure modsig0 modsigcod1subst) in (absmodsig, ibinds) end end | ModCoerce(modident1, utsig2) -> let mentry1 = find_module tyenv modident1 in let modsig1 = mentry1.mod_signature in let (rng1, _) = modident1 in let absmodsig2 = typecheck_signature ~address tyenv utsig2 in let absmodsig = coerce_signature ~cause:rng1 ~address modsig1 absmodsig2 in (absmodsig, (ModuleAttribute.empty, [])) and typecheck_binding_list ~(address : Address.t) (tyenv : Typeenv.t) (utbinds : untyped_binding list) : SigRecord.t abstracted * (ModuleAttribute.t * binding list) = let (_tyenv, quantacc, sigracc, (modattracc, ibindacc)) = utbinds |> List.fold_left (fun (tyenv, quantacc, sigracc, (modattracc, ibindacc)) utbind -> let (abssigr, (modattr, ibinds)) = typecheck_binding ~address tyenv utbind in let (quant, sigr) = abssigr in let tyenv = tyenv |> update_type_environment_by_signature_record sigr in let quantacc = merge_quantifier quantacc quant in let sigracc = match SigRecord.disjoint_union sigracc sigr with | Ok(sigr) -> sigr | Error(s) -> let (rng, _) = utbind in raise_error (ConflictInSignature(rng, s)) (* In the original paper "F-ing modules" [Rossberg, Russo & Dreyer 2014], this operation is not disjoint union, but union with right-hand side precedence. For the sake of clarity, however, we adopt disjoint union here, at least for now. *) in let modattracc = ModuleAttribute.merge modattracc modattr in let ibindacc = Alist.append ibindacc ibinds in (tyenv, quantacc, sigracc, (modattracc, ibindacc)) ) (tyenv, OpaqueIDMap.empty, SigRecord.empty, (ModuleAttribute.empty, Alist.empty)) in ((quantacc, sigracc), (modattracc, Alist.to_list ibindacc)) and coerce_signature ~(cause : Range.t) ~(address : Address.t) (modsig1 : module_signature) (absmodsig2 : module_signature abstracted) = let _subst = subtype_signature ~cause ~address modsig1 absmodsig2 in let (quant2, modsig2) = absmodsig2 in (quant2, copy_closure modsig1 modsig2) let 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) = let (rng, modnm) = modident in let address = Address.root |> Address.append_member modnm in let (absmodsig1, imod) = typecheck_module ~address tyenv utmod1 in let sname = get_space_name rng modnm in let (quant, modsig) = match absmodsigopt2 with | None -> absmodsig1 | Some(absmodsig2) -> let (_, modsig1) = absmodsig1 in coerce_signature ~cause:rng ~address modsig1 absmodsig2 in match modsig with | (_, ConcFunctor(_)) -> let (rng, _) = utmod1 in raise_error (RootModuleMustBeStructure(rng)) | (isig, ConcStructure(sigr)) -> let mentry = { mod_signature = modsig; mod_name = sname; mod_doc = None; (* TODO: add doc comments *) } in let tyenv = tyenv |> Typeenv.add_module modnm mentry in (tyenv, (quant, (isig, sigr)), sname, imod) ================================================ FILE: src/typechecker.mli ================================================ open Syntax open IntermediateSyntax open Env open Errors exception TypeError of type_error val typecheck_signature : address:Address.t -> Typeenv.t -> untyped_signature -> module_signature abstracted val 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) ================================================ FILE: src/valueAttribute.ml ================================================ open MyUtil open Syntax type t = { is_test_suite : bool; } let default = { is_test_suite = false; } let decode (attrs : attribute list) : t * attribute_warning list = let (r, warn_acc) = attrs |> List.fold_left (fun (r, warn_acc) attr -> let Attribute((rng, attr_main)) = attr in match attr_main with | ("test", utast_opt) -> let warn_acc = match utast_opt with | None -> warn_acc | Some(_) -> let warn = { position = rng; tag = "test"; message = "argument is ignored"; } in Alist.extend warn_acc warn in ({ is_test_suite = true }, warn_acc) | (tag, _) -> let warn = { position = rng; tag = tag; message = "unsupported attribute"; } in (r, Alist.extend warn_acc warn) ) (default, Alist.empty) in (r, Alist.to_list warn_acc) ================================================ FILE: src/yamlDecoder.ml ================================================ open MyUtil type error = | FieldNotFound of string | NotAFloat | NotAString | NotABool | NotAnArray | NotAnObject | OtherMessage of string let pp_error (ppf : Format.formatter) = let p = Format.fprintf in function | FieldNotFound(field) -> p ppf "field '%s' not found" field | NotAFloat -> p ppf "not a float value" | NotAString -> p ppf "not a string value" | NotABool -> p ppf "not a Boolean value" | NotAnArray -> p ppf "not an array" | NotAnObject -> p ppf "not an object" | OtherMessage(msg) -> p ppf "%s" msg type 'a t = Yaml.value -> ('a, error) result let run (d : 'a t) (s : string) : ('a, error) result = let open ResultMonad in match Yaml.of_string s with | Ok(yval) -> d yval | Error(`Msg(s)) -> err (OtherMessage(s)) let succeed (a : 'a) : 'a t = fun _ -> Ok(a) let failure (msg : string) : 'a t = fun _ -> Error(OtherMessage(msg)) let bind (d : 'a t) (df : 'a -> 'b t) : 'b t = fun yval -> match d yval with | Ok(a) -> df a yval | Error(_) as e -> e let ( >>= ) = bind let get_scheme (field : string) (d : 'a t) (k : unit -> ('a, error) result) : 'a t = let open ResultMonad in function | `O(keyvals) -> begin match List.find_map (fun (k, v) -> if String.equal k field then Some(v) else None) keyvals with | None -> k () | Some(v) -> d v end | _ -> err NotAnObject let get (field : string) (d : 'a t) : 'a t = let open ResultMonad in get_scheme field d (fun () -> err (FieldNotFound(field))) let get_opt (field : string) (d : 'a t) : ('a option) t = let d_some = d >>= fun v -> succeed (Some(v)) in let open ResultMonad in get_scheme field d_some (fun () -> return None) let get_or_else (field : string) (d : 'a t) (default : 'a) : 'a t = let open ResultMonad in get_scheme field d (fun () -> return default) let number : float t = let open ResultMonad in function | `Float(x) -> return x | _ -> err NotAFloat let string : string t = let open ResultMonad in function | `String(x) -> return x | _ -> err NotAString let bool : bool t = let open ResultMonad in function | `Bool(x) -> return x | _ -> err NotABool let list (d : 'a t) : ('a list) t = let open ResultMonad in function | `A(yvals) -> yvals |> List.fold_left (fun res yval -> res >>= fun acc -> d yval >>= fun a -> return (Alist.extend acc a) ) (return Alist.empty) >>= fun acc -> return (Alist.to_list acc) | _ -> err NotAnArray type 'a branch = string * 'a t let branch (field : string) (branches : ('a branch) list) ~on_error:(errorf : string -> string) : 'a t = get field string >>= fun tag_gotten -> match branches |> List.find_map (fun (tag_candidate, d) -> if String.equal tag_gotten tag_candidate then Some(d) else None ) with | None -> failure (errorf tag_gotten) | Some(d) -> d let ( ==> ) (label : string) (d : 'a t) : 'a branch = (label, d) let map (f : 'a -> 'b) (d : 'a t) : 'b t = let open ResultMonad in fun yval -> d yval >>= fun a -> return (f a) let map2 (f : 'a1 -> 'a2 -> 'b) (d1 : 'a1 t) (d2 : 'a2 t) : 'b t = let open ResultMonad in fun yval -> d1 yval >>= fun a1 -> d2 yval >>= fun a2 -> return (f a1 a2) let map3 (f : 'a1 -> 'a2 -> 'a3 -> 'b) (d1 : 'a1 t) (d2 : 'a2 t) (d3 : 'a3 t) : 'b t = let open ResultMonad in fun yval -> d1 yval >>= fun a1 -> d2 yval >>= fun a2 -> d3 yval >>= fun a3 -> return (f a1 a2 a3) ================================================ FILE: src/yamlDecoder.mli ================================================ type error val pp_error : Format.formatter -> error -> unit type 'a t val run : 'a t -> string -> ('a, error) result val succeed : 'a -> 'a t val failure : string -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t val get : string -> 'a t -> 'a t val get_opt : string -> 'a t -> ('a option) t val get_or_else : string -> 'a t -> 'a -> 'a t val number : float t val string : string t val bool : bool t val list : 'a t -> ('a list) t type 'a branch val branch : string -> ('a branch) list -> on_error:(string -> string) -> 'a t val ( ==> ) : string -> 'a t -> 'a branch val map : ('a -> 'b) -> 'a t -> 'b t val map2 : ('a1 -> 'a2 -> 'b) -> 'a1 t -> 'a2 t -> 'b t val map3 : ('a1 -> 'a2 -> 'a3 -> 'b) -> 'a1 t -> 'a2 t -> 'a3 t -> 'b t ================================================ FILE: test/concept/cell.sest ================================================ /* The current type checker does NOT accept this module. */ module Cell :> sig type t :: (o) -> o val start<$a, $content> : fun($content) -> [$a]t<$content> val set<$a, $content> : fun(t<$content>, $content) -> [$a]unit val get<$a, $content> : fun(t<$content>) -> [$a]$content val stop<$a, $content> : fun(t<$content>) -> [$a]unit end = struct type request<$a, $content> = | Get(pid<$a>) | Set(pid<$a>, $content) | Stop type response<$content> = | Content($content) | Done type t<$content> = pid, $content>> val rec loop(v) = receive | Get(from) -> do send(from, Content(v)) in loop(v) | Set(from, v_new) -> do send(from, Done) in loop(v_new) | Stop -> return({}) end val start(v) = spawn(loop(v)) val get(cell) = do me <- self in do send(cell, Get(me)) in receive | Content(v) -> return(v) end val set(cell, v) = do me <- self in do send(cell, Set(me, v)) in receive | Done -> return({}) end val stop(cell) = send(cell, Stop) end ================================================ FILE: test/concept/counter.sest ================================================ /* This is just a conceptual example and cannot be compiled. */ type option<$a> = None | Some($a) type result<$a, $b> = Ok($a) | Error($b) module Counter = struct /* Abstract types for associating responses with requests. */ type get_number type get_name /* `GenServer.Make` is a functor of the following signature: ``` (forall state :: 0, init_arg :: 0, init_error :: 0, cast_message :: 0, request :: 1, response :: 1, stop_reason :: 0 ) (fun(sig type state :: 0 type init_arg :: 0 type init_error :: 0 val init : fun(init_arg) -> result type cast_message :: 0 type request :: 1 type response :: 1 val handle_cast : fun(cast_message, state) -> result val handle_call<$a> : fun(request<$a>, GenServer.session<$a>, state) -> result<(state, response<$a>), stop_reason> end) -> (exists proc :: 0) (sig type proc :: 0 val start_link<$s> : fun(init_arg) -> [$s]result val cast<$s> : fun(proc, cast_message) -> [$s]unit val call<$s, $a> : fun(proc, request<$a>, time) -> [$s]result, error> end)) ``` - `init`, `handle_cast`, and `handle_call`: callback functions required by `gen_server`. - `proc`: The type for abstracted PIDs of processes generated by `gen_server` callback modules. - `cast`: `cast(proc, msg)` corresponds to `gen_server:cast(?MODULE, proc, msg)`. - `call`: `call(proc, msg, timeout)` corresponds to `gen_server:call(?MODULE, proc, msg, timeout)`. */ include GenServer.Make(struct type state = { number : int, name : string } type init_arg = string let init(name : init_arg) = Ok({ number = 0, name = name }) type cast_message = | Increment | Decrement | ResetNumber(int) /* A GADT for request messages. */ type request :: 1 = | GetNumber : request | GetName : request /* A GADT for response messages. */ type response :: 1 = | Number(int) : response | Name(string) : response let handle_cast(msg : cast_message, state : state) : result = case msg of | Increment -> Ok({ state with number = state.number + 1 }) | Decrement -> Ok({ state with number = state.number - 1 }) | ResetNumber(m) -> Ok({ state with number = m }) end let handle_call<$a>(msg : request<$a>, ses : GenServer.session<$a>, state : state) = case msg of | GetNumber -> Ok((state, Number(state.number))) | GetName -> Ok((state, Number(state.name))) end end) let increment(pid : proc) : [_]unit = cast(pid, Increment) let decrement(pid : proc) : [_]unit = cast(pid, Decrement) let reset(pid : proc, m : int) : [_]unit = cast(pid, Reset(m)) let get_number(pid : proc, ?timeout = 5000s : time) : [_]result = do r : result, GenServer.error> <- call(pid, GetNumber, timeout) in let v = r |> Result.bind(fun(res) -> case res of Number(n) -> Ok(n) end end) in return(v) let get_name(pid : proc) : [_]result = do r <- call(pid, GetName) in let v = r |> Result.bind(fun(res) -> case res of Name(name) -> Ok(name) end end) in return(v) end :> sig type proc :: 0 val start_link<$s> : fun(int) -> [$s]result val increment<$s> : fun(proc) -> [$s]unit val decrement<$s> : fun(proc) -> [$s]unit val get_number<$s> : fun(proc) -> [$s]result val get_name<$s> : fun(proc) -> [$s]result end ================================================ FILE: test/dune ================================================ (tests (names testRange testLanguageVersion testIdentifierScheme) (libraries alcotest ocamlgraph semver2 core)) (copy_files ../src/*.ml) ================================================ FILE: test/fail/error01.sest ================================================ module Error01 = struct val main() = let x = /* here is /* a comment */ 1 in x end ================================================ FILE: test/fail/error_arity.sest ================================================ module ErrorArity = struct val add(x, y) = x + y val main() = add(42) end ================================================ FILE: test/fail/error_coercion.sest ================================================ module ErrorCoercion = struct module Sub = struct module Impl = struct val rec aux(acc, n, x) = if n <= 0 then acc else aux(x * acc, n - 1, x) val power(n, x) = aux(1, n, x) end include (Impl :> sig val power : fun(int, int) -> int end) end val main() = Sub.aux(1, 4, 3) end ================================================ FILE: test/fail/error_coercion2.sest ================================================ module ErrorCoercion2 :> sig val f<$a> : fun($a) -> $a end = struct val f(n) = n + 1 end ================================================ FILE: test/fail/error_coercion3.sest ================================================ module ErrorCoercion3 = struct module Impl = struct val f(n) = n + 1 end module Api = Impl :> sig val f<$a> : fun($a) -> $a end end ================================================ FILE: test/fail/error_coercion4.sest ================================================ module ErrorCoercion4 = struct module Sub :> sig val power : fun(int, int) -> int end = struct val rec aux(acc, n, x) = if n <= 0 then acc else aux(x * acc, n - 1, x) val power(n, x) = aux(1, n, x) end val main() = Sub.aux(1, 4, 3) end ================================================ FILE: test/fail/error_coercion5.sest ================================================ module ErrorCoercion5 = struct module Impl = struct type t = int val make(x) = x end module Sub = Impl :> sig type t :: o val make : fun(int) -> t end val main() = Sub.make(5) + 1 end ================================================ FILE: test/fail/error_coercion6.sest ================================================ module ErrorCoercion6 = struct module Sub :> sig type t :: o val make : fun(int) -> t end = struct type t = int val make(x) = x end val main() = Sub.make(5) + 1 end ================================================ FILE: test/fail/error_contradiction.sest ================================================ module ErrorContradiction = struct val add(x, y) = x + y val main() = add("foo", 42) end ================================================ FILE: test/fail/error_cyclic/error_cyclic.sest ================================================ import ErrorCyclicFoo import ErrorCyclicBar module ErrorCyclic = struct val main() = {ErrorCyclicFoo.main(), ErrorCyclicBar.main()} end ================================================ FILE: test/fail/error_cyclic/error_cyclic_bar.sest ================================================ import ErrorCyclicFoo module ErrorCyclicBar = struct val main() = {} end ================================================ FILE: test/fail/error_cyclic/error_cyclic_foo.sest ================================================ import ErrorCyclicBar module ErrorCyclicFoo = struct val main() = {} end ================================================ FILE: test/fail/error_cyclic/sesterl.yaml ================================================ package: test_fail_error_cyclic source_directories: - "./" main_module: "ErrorCyclic" ================================================ FILE: test/fail/error_first_class_module.sest ================================================ module ErrorFirstClassModule :> sig val f : fun(pack sig end) -> int end = struct val f(x : pack sig val n : int end) = 3 end /* Unsoundness reported by `@elpinal` https://twitter.com/elpin1al/status/1389366123246673921?s=20 */ ================================================ FILE: test/fail/error_freeze.sest ================================================ module ErrorFreeze = struct val g() = let f(x) = x in freeze f(42) end ================================================ FILE: test/fail/error_functor.sest ================================================ module ErrorFunctor = struct signature S = sig type t :: o end module F = fun(X : S) -> fun(Y : S) -> struct val f(x : X.t) : Y.t = x end end ================================================ FILE: test/fail/error_inference.sest ================================================ module ErrorInference = struct val f(x) = x.foo val main(_) = f(42) end ================================================ FILE: test/fail/error_kind.sest ================================================ module ErrorKind = struct module Impl = struct type t = binary val v() = "Hello" end include Impl :> sig type t :: {foo : int} val v : fun() -> t end end ================================================ FILE: test/fail/error_kind2.sest ================================================ module ErrorKind2 = struct val f(n : int, b : bool) : { foo : int, bar : bool, ?$r } = { foo = n, bar = b } end ================================================ FILE: test/fail/error_kind3.sest ================================================ module ErrorKind3 = struct val f(r : { foo : int, bar : bool, ?$r }, n : int, b : bool) : { foo : int, bar : bool, ?$r } = { r | foo = n, bar = b } end ================================================ FILE: test/fail/error_kinded_parameter.sest ================================================ module ErrorKindedParameter = struct type t<$a :: {foo : int}> = | HasFoo($a) val f(x) = case x of | HasFoo(r) -> r end val g(b, x, y) = case x of | HasFoo(r) -> if b then r else { y | bar = x } end end ================================================ FILE: test/fail/error_mandatory_parameter.sest ================================================ module ErrorMandatoryParameter = struct val get_or_else(x, -default d) = case x of | Some(v) -> v | None -> d end val main() = get_or_else(Some(42)) end ================================================ FILE: test/fail/error_mandatory_parameter2.sest ================================================ module ErrorMandatoryParameter2 = struct val get_or_else(x, -default d) = case x of | Some(v) -> v | None -> d end val main() = get_or_else(Some(42), -or 57) end ================================================ FILE: test/fail/error_mutrec.sest ================================================ module ErrorMutrec = struct type foo = {int, bar} and baz<$a> = | Baz(foo, bar) and bar = {bool, baz} end ================================================ FILE: test/fail/error_optional_parameter.sest ================================================ module ErrorOptionalParameter = struct module Impl = struct val f(g) = {g(42), g(42, ?foo 57)} end include Impl :> sig val f<$a> : fun(fun(int) -> $a) -> {$a, $a} end end ================================================ FILE: test/fail/error_optional_parameter_unify.sest ================================================ module ErrorOptionalParameterUnify = struct val f1(g) = g(?foo 42) val f2(g) = g(?foo 42, ?bar true) val f(flag, g) = if flag then f1(g) else f2(g) val main(_) = let h(?foo nopt) = case nopt of | None -> 0 | Some(n) -> n end in let res = f(true, h) in print_debug(res) end ================================================ FILE: test/fail/error_optional_parameter_unify2.sest ================================================ module ErrorOptionalParameterUnify2 = struct val g1(?foo nopt) = {nopt, None} val g2(?foo nopt, ?bar bopt) = {nopt, bopt} val g(flag) = if flag then g1 else g2 end ================================================ FILE: test/fail/error_recursive_type_parameter.sest ================================================ module ErrorRecursiveTypeParameter = struct val f(x) = { x | foo = x } end ================================================ FILE: test/fail/error_recursive_type_parameter2.sest ================================================ module ErrorRecursiveTypeParameter2 = struct val f(x, y) = {{ x | foo = y }, { y | bar = x }} end ================================================ FILE: test/fail/error_type_cyclic.sest ================================================ module ErrorTypeCyclic = struct type t_x = t_y and t_y = t_x end ================================================ FILE: test/fail/error_variant.sest ================================================ module ErrorVariant :> sig type t = | Foo(int) end = struct type t = | Foo(int) | Bar end ================================================ FILE: test/fail/error_with.sest ================================================ module ErrorWith = struct module Impl = struct type t = int end module Api = Impl :> (sig type t end with type t = bool) end ================================================ FILE: test/fail/recursive.sest ================================================ module Recursive = struct signature E = sig end signature X = sig signature A = sig end /* In OCaml one can declare “abstract” signatures by declarations of the form like `signature A`, and it causes the possibility of the non-termination during type checking. F-ing modules does not allow such declarations. */ signature F = fun(Dummy : sig signature A = A signature F = fun(Dummy : A) -> E end) -> E end signature Y = sig signature A = X signature F = fun(Dummy : A) -> E end module ForceSubtyping = fun(V : Y) -> V :> X end ================================================ FILE: test/pass/adt.sest ================================================ module Adt = struct val rec foldl(f, i, l) = case l of | [] -> i | x :: xs -> foldl(f, f(i, x), xs) end val reverse_map(f, xs) = foldl(fun(acc, x) -> f(x) :: acc end, [], xs) val sum(ns) = foldl(fun(m, n) -> m + n end, 0, ns) type tree<$a> = | Node($a, list>) val leaf(x) = Node(x, []) val rec tree_size(tr) = let Node(_, children) = tr in case children of | [] -> 1 | _ :: _ -> 1 + sum(reverse_map(tree_size, children)) end type oddlist<$a> = | OddCons($a, evenlist<$a>) and evenlist<$b> = | Nil | EvenCons($b, oddlist<$b>) val main(_) = let tr = Node(3, [ Node(1, [ leaf(4), Node(1, [ leaf(5), leaf(9), ]), leaf(2), ]) ]) in let size = tree_size(tr) in let t = OddCons(3, Nil()) in print_debug({size, t}) end ================================================ FILE: test/pass/arith.sest ================================================ module Arith = struct val main(_) = let 13 = 3 * 4 + 1 in let 13 = 1 + 3 * 4 in let 1 = 4 / 2 / 2 in let 8 = 8 * 2 / 2 in let 14 = 57 - 42 - 1 in let 16 = 57 - 42 + 1 in {} end ================================================ FILE: test/pass/coercion.sest ================================================ module Coercion = struct module Sub = struct module Impl = struct val rec aux(acc, n, x) = if n <= 0 then acc else aux(x * acc, n - 1, x) val power(n, x) = aux(1, n, x) end include (Impl :> sig val power : fun(int, int) -> int end) end val main(_) = print_debug(Sub.power(4, 3)) end ================================================ FILE: test/pass/coercion2.sest ================================================ module Coercion2 :> sig val apply<$a, $b> : fun(fun($a) -> $b, $a) -> $b val apply2 : fun(fun(int) -> bool, int) -> bool end = struct val apply(f, x) = f(x) val apply2(f, x) = apply(f, x) val succ(n) = n + 1 val main(_) = print_debug(apply(succ, 42)) end ================================================ FILE: test/pass/ctor.sest ================================================ module Ctor = struct module Sub = struct type t = | Foo | Bar(int) end val to_int(x) = case x of | Sub.Foo -> 0 | Sub.Bar(n) -> n end val is_foo_and_bar(xs) = case xs of | [Sub.Foo, Sub.Bar(_)] -> true | _ -> false end val main(_) = let _ = print_debug([ to_int(Sub.Bar(42)), to_int(Sub.Bar(0)), to_int(Sub.Foo), ]) in print_debug([ is_foo_and_bar([]), is_foo_and_bar([Sub.Foo, Sub.Bar(42)]), is_foo_and_bar([Sub.Foo]), ]) end ================================================ FILE: test/pass/ctor_attr.sest ================================================ module CtorAttr = struct type t = | #[atom("bar")] Foo(int) val f(n) = Foo(n) val main<$a> : $a = external 1 ``` main(_) -> case f(42) of {bar, 42} -> ok; Other -> erlang:error({unexpected, Other}) end. ``` end ================================================ FILE: test/pass/ffi.sest ================================================ module Ffi = struct type option<$a> = | None | Some($a) val assoc<$a> : fun(int, list<{int, $a}>) -> option<{$a, list<{int, $a}>}> = external 2 ``` assoc(Key, Xs) -> case lists:keytake(Key, 1, Xs) of false -> none; {value, {_, V}, Rest} -> {some, {V, Rest}} end. ``` val main(_) = let ans = assoc(1, [ {3, "Komaba"}, {1, "Hongo"}, {4, "Yayoi"}, {1, "Asano"}, {5, "Kashiwa"}, ]) in print_debug(ans) end ================================================ FILE: test/pass/first.sest ================================================ module First = struct val rec foldn(f, i, c) = if i <= 0 then c else foldn(f, i - 1, f(i, c)) val main(_) = let ans = foldn(fun(i, c) -> i + c end, 10, 0) in print_debug(ans) end ================================================ FILE: test/pass/functor.sest ================================================ module Functor = struct val n() = 42 signature S = sig type t :: o val zero : fun() -> t end module F = fun(X : S) -> fun(Y : S) -> struct val f(x : X.t) : X.t = x val g(y : Y.t) : Y.t = y val m() = n() val zeroes() = {X.zero(), Y.zero()} end module Int = struct type t = int val zero() = 0 end module Sub = struct module Bool = struct type t = bool val zero() = false end end module G = F(Int) module B = Sub.Bool module M = G(B) val main(_) = print_debug(M.zeroes()) end ================================================ FILE: test/pass/functor2.sest ================================================ module Functor2 = struct signature S = sig type t :: o val zero : fun() -> t end module F = fun(X : S) -> struct val f(x : X.t) : X.t = x val zeroes() = {X.zero(), X.zero()} end module Int = struct type t = int val zero() = 0 end module M = F(Int) val main(_) = print_debug(M.zeroes()) end ================================================ FILE: test/pass/functor3.sest ================================================ module Functor3 = struct signature S = sig type t :: o val zero : fun() -> t end signature T = sig module M : S module N : S end module F = fun(X : T) -> struct module P = X.M module Q = X.N val f(x : P.t,) : P.t = x /* inserting a comma is a temporary dirty hack for parsing */ val g(y : Q.t,) : Q.t = y val zeroes() = {P.zero(), Q.zero()} end module Int = struct type t = int val zero() = 0 end module Bool = struct type t = bool val zero() = false end module Pair = struct module M = Int module N = Bool end module M = F(Pair) end ================================================ FILE: test/pass/inference.sest ================================================ module Inference = struct val f(r : {foo : int, ?$a}, x) = {x.foo, if true then x else r} val main(_) = f({ foo = 42 }, { foo = 57 }) end ================================================ FILE: test/pass/kind.sest ================================================ module Kind = struct module Impl = struct type t = {foo : int, bar : bool} val v() = {foo = 42, bar = true} end include Impl :> sig type t :: o val v : fun() -> t end end ================================================ FILE: test/pass/kinded_parameter.sest ================================================ module KindedParameter = struct /* (not supported yet) type t = | HasFoo({foo : int, ?$r}) val f(x) = case x of | HasFoo(r) -> r end val g(b, x, y) = case x of | HasFoo(r) -> if b then r else { y | bar = b } end */ end ================================================ FILE: test/pass/mandatory_parameter.sest ================================================ module MandatoryParameter = struct module Impl = struct val rec foldl(-f f, -init init, -list xs) = case xs of | [] -> init | y :: ys -> foldl(-init f(init, y), -list ys, -f f) end end include Impl :> sig val foldl<$a, $b> : fun( -f fun($a, $b) -> $a, -init $a, -list list<$b>, ) -> $a end val main(_) = let res = foldl( -f fun(x, y) -> x + y end, -init 0, -list [3, 1, 4, 1, 5, 9, 2]) in print_debug(res) end ================================================ FILE: test/pass/mod.sest ================================================ module Mod = struct signature Ord = sig type s :: o val compare : fun(s, s) -> int end module Map = fun(Elem : Ord) -> struct type elem = Elem.s type t<$a> = list<{elem, $a}> val rec find<$b>(x : elem, assoc : t<$b>) : option<$b> = case assoc of | [] -> None | {k, v} :: tail -> if Elem.compare(k, x) == 0 then Some(v) else find(x, tail) end end module Int = struct type s = int val compare(x : int, y : int) = y - x end module IntMap = Map(Int) end ================================================ FILE: test/pass/mod2.sest ================================================ module Mod2 = struct module Counter = struct type t = int val initial() : t = 0 val increment(c : t) : t = c + 1 end val main(_) = let x = Counter.initial() in print_debug(Counter.increment(x) == 0) end ================================================ FILE: test/pass/mod3.sest ================================================ module Mod3 = struct module List = struct type t<$a> = list<$a> val empty<$b>() : t<$b> = [] val rec foldl(f, i, l) = case l of | [] -> i | x :: xs -> foldl(f, f(i, x), xs) end val reverse<$c>(xs : list<$c>) : list<$c> = foldl(fun(acc, x) -> x :: acc end, [], xs) end signature Eq = sig type t :: o val equal : fun(t, t) -> bool end end ================================================ FILE: test/pass/mod_seq.sest ================================================ module ModSeq = struct type option<$a> = | None | Some($a) signature Decomposable = sig type s :: (o) -> o val decompose<$a> : fun(s<$a>) -> option<{$a, s<$a>}> end module Seq = fun(D : Decomposable) -> struct type t<$a> = D.s<$a> val to_reversed_list<$a>(xs : t<$a>) : list<$a> = let rec aux(acc : list<$a>, xs : t<$a>) = case D.decompose(xs) of | None -> acc | Some({x, tail}) -> aux(x :: acc, tail) end in aux([], xs) end module ListD = struct type s<$a> = list<$a> val decompose(xs) = case xs of | [] -> None | x :: tail -> Some({x, tail}) end end module ListSeq = Seq(ListD) val main(_) = let ans = ListSeq.to_reversed_list([3, 1, 4]) in print_debug(ans) end ================================================ FILE: test/pass/mod_stack.sest ================================================ module ModStack = struct type option<$a> = | None | Some($a) module Stack = struct type t<$a> = list<$a> val empty() = [] val pop<$a>(s : t<$a>) : option<{$a, t<$a>}> = case s of | [] -> None | top :: rest -> Some({top, rest}) end val push(s, x) = x :: s end end ================================================ FILE: test/pass/mutrec.sest ================================================ module Mutrec = struct val main(_) = let rec odd(n) = let _ = print_debug(n) in even(n - 1) and even(n) = let _ = print_debug(n) in if n <= 0 then {} else odd(n - 1) in even(10) end ================================================ FILE: test/pass/mutrec2.sest ================================================ module Mutrec2 = struct val rec odd(n) = let _ = print_debug(n) in even(n - 1) and even(n) = let _ = print_debug(n) in if n <= 0 then {} else odd(n - 1) val main(_) = even(10) end ================================================ FILE: test/pass/optional_parameter.sest ================================================ module OptionalParameter = struct val pure_succ(n) = n + 1 val succ(n : int, ?diff dopt : option) = case dopt of | None -> pure_succ(n) | Some(d) -> n + d end val succ_concise(n : int, ?diff d : int = 1) = n + d val make_pair<$a>(x : $a, ?other y : $a = x) = {x, y} val f(g) = {g(36), g(36, ?diff 64)} val main(_) = let ans1 = {succ(42), succ(42, ?diff 15), f(succ)} in let ans2 = {succ_concise(42), succ_concise(42, ?diff 15), f(succ_concise)} in let ans3 = {make_pair("first"), make_pair("first", ?other "second")} in print_debug({ans1, ans2, ans3}) end ================================================ FILE: test/pass/optional_parameter2.sest ================================================ module OptionalParameter2 = struct module Impl = struct val f1(g) = {g(42), g(42, ?foo 57)} val f2(g) = f1(g) val f3(g) = f1(g) end include Impl :> sig val f1<$a, ?$r :: (foo, bar)> : fun(fun(int, ?foo int, ?bar binary, ?$r) -> $a) -> {$a, $a} val f2<$a, ?$r :: (foo)> : fun(fun(int, ?foo int, ?$r) -> $a) -> {$a, $a} val f3<$a> : fun(fun(int, ?foo int, ?baz bool) -> $a) -> {$a, $a} end val main(_) = let ans1 = f2(fun(n, ?foo topt) -> case topt of | None -> n * 2 | Some(t) -> n * t end end) in let ans2 = f2(fun(n, ?foo t = 2) -> n * t end) in print_debug({ans1, ans2}) end ================================================ FILE: test/pass/optional_parameter_unify.sest ================================================ module OptionalParameterUnify = struct val f1(g) = g(?foo 42) val f2(g) = g(?foo 42, ?bar true) val f(flag, g) = if flag then f1(g) else f2(g) val main(_) = let h(?foo nopt, ?bar binopt) = case {nopt, binopt} of | {None, _} -> false | {Some(n), None} -> n > 0 | {Some(n), Some(b)} -> n > 0 && b end in let res = f(true, h) in print_debug(res) end ================================================ FILE: test/pass/poly.sest ================================================ module Poly = struct val rec foldl(f, i, l) = case l of | [] -> i | x :: xs -> foldl(f, f(i, x), xs) end val sum(ns) = foldl(fun(m, n) -> m + n end, 0, ns) val count_true(bs) = foldl(fun(n, b) -> if b then n + 1 else n end, 0, bs) val main(_) = let ans = { sum([3, 1, 4, 1, 5, 9, 2]), count_true([true, false, true, true, false]) } in print_debug(ans) end ================================================ FILE: test/pass/record_test.sest ================================================ module RecordTest = struct val get_foo(x) = x.foo val update_bar(x) = { x | bar = false } val add_foo_and_bar(x) = x.foo + (if x.bar then 1 else 0) val record() = { foo = 42, bar = true } val default(b, x) = if b then record() else x val main(_) = let r = record() in print_debug({ original = r, projection = get_foo(r), update = update_bar(r), operation = add_foo_and_bar(r), }) end ================================================ FILE: test/pass/record_test2.sest ================================================ module RecordTest2 = struct module Impl = struct val record() = { foo = 42, bar = true } val get_foo(x) = x.foo val get_foo2(x) = get_foo(x) end module Api = Impl :> sig val record : fun() -> { foo : int, bar : bool } val get_foo<$a, ?$b :: (foo)> : fun({ foo : $a, ?$b }) -> $a val get_foo2 : fun({ foo : binary, bar : float }) -> binary end end ================================================ FILE: test/pass/sample_project/.gitignore ================================================ _build/ _doc/ rebar.config ================================================ FILE: test/pass/sample_project/sample_project.sest ================================================ module SampleProject = struct open Stdlib module Server :> sig type proc type error = GenServer.start_link_error val start_link<$a> : fun({number : int, name : binary}) -> [$a]result val stop<$a> : fun(proc) -> [$a]unit val set_number<$a> : fun(proc, int) -> [$a]unit val get_number<$a> : fun(proc, ?timeout int) -> [$a]int end = struct type error = GenServer.start_link_error module Callback = struct type request = | GetNumber | GetName type response = | Number(int) | Name(binary) type cast_message = | SetNumber(int) type state = { number : int, name : binary } type init_arg = state type global = unit type info = | InfoDummy val init(state) = act let _ = print_debug({"init", state}) in GenServer.init_ok(state) val handle_call(req, _, state) = act let _ = print_debug({"handle_call", req, state}) in case req of | GetNumber -> GenServer.reply(Number(state.number), state) | GetName -> GenServer.reply(Name(state.name), state) end val handle_cast(msg, state) = act let _ = print_debug({"handle_cast", msg, state}) in case msg of | SetNumber(m) -> GenServer.no_reply({ number = m, name = state.name }) end val handle_timeout(state) = act let _ = print_debug({"timeout", state}) in GenServer.no_reply(state) val handle_down(mref, pid, reason, state) = act let _ = print_debug({"down", mref, pid, reason, state}) in GenServer.no_reply(state) val handle_info(info, state) = act let _ = print_debug({"info", info, state}) in GenServer.no_reply(state) val terminate(reason, state) = act let _ = print_debug({"terminate", reason, state}) in return({}) end include GenServer.Make(Callback) val set_number<$a>(pid : proc, m : int) : [$a]unit = act cast(pid, Callback.SetNumber(m)) val get_number<$a>(pid : proc, ?timeout t_opt) : [$a]int = act do res <- case t_opt of | None -> call(pid, Callback.GetNumber) | Some(t) -> call(pid, Callback.GetNumber, ?timeout t) end in case res of | Ok(Callback.Number(n)) -> return(n) end end module Main = struct val async_increment(pid) = act do n <- Server.get_number(pid) in do _ <- Server.set_number(pid, n + 1) in return(n + 1) val rec loop(t, pid) = act if t <= 0 then Server.stop(pid) else do n <- async_increment(pid) in let _ = print_debug({t, n}) in loop(t - 1, pid) val main() = act do res <- Server.start_link({number = 57, name = "Sample Store"}) in case res of | Error(reason) -> let _ = print_debug({"failed to start a process", reason}) in return({}) | Ok(pid) -> do x <- Server.get_number(pid, ?timeout 1000) in let _ = print_debug({"first get", x}) in do _ <- Server.set_number(pid, 42) in loop(10, pid) end end val main(_) = act Main.main() end ================================================ FILE: test/pass/sample_project/sesterl.yaml ================================================ package: sample_project source_directories: - "./" main_module: "SampleProject" document_outputs: - format: type: "html" output_directory: "./_doc" dependencies: - name: "stdlib" source: type: "local" directory: "../../../external/stdlib" test_dependencies: - name: "testing" source: type: "local" directory: "../../../external/testing" erlang: output_directory: "../../_generated" test_output_directory: "../../_generated_test" ================================================ FILE: test/pass/sample_sup_usage/sample_sup_usage.sest ================================================ module SampleSupUsage = struct open Stdlib module G = GenServer module S = Supervisor.Static module Sup :> sig type proc type error = S.start_link_error val start_link<$a> : fun(unit) -> [$a]result end = struct type error = S.start_link_error module Child1 = struct module Callback = struct type init_arg = int type request = | Get type response = | Got(int) type cast_message = | Set(int) type info = unit type global = unit type state = int val init(n) = act G.init_ok(n) val handle_call(request, _, n) = act case request of | Get -> G.reply(Got(n), n) end val handle_cast(msg, _) = act case msg of | Set(m) -> G.no_reply(m) end val handle_timeout(n) = act G.no_reply(n) val handle_down(_, _, _, n) = act G.no_reply(n) val handle_info(_, n) = act G.no_reply(n) val terminate(_, _) = act return({}) end include G.Make(Callback) end module SupCallback = struct type child_id = int type init_arg = unit type info = unit type global = unit val start_child1(n) = act S.make_child_proc(fun() -> act do res <- Child1.start_link(n) in return(Result.map(Child1.as_pid, res)) end) val init(_) = act let sup_flags = S.make_sup_flags( ?strategy S.OneForOne, ?intensity 1, ?period 5, ) in let child_specs = [ S.make_child_spec( -id 1, -start (freeze start_child1(42)), ) ] in S.init_ok(sup_flags, child_specs) end include S.Make(SupCallback) end val main(_) = act do res <- Sup.start_link({}) in case res of | Error(reason) -> let _ = print_debug({"did not start", reason}) in return({}) | Ok(_) -> let _ = print_debug("ok") in return({}) end end ================================================ FILE: test/pass/sample_sup_usage/sesterl.yaml ================================================ package: sample_sup_usage source_directories: - "./" main_module: "SampleSupUsage" dependencies: - name: "stdlib" source: type: "local" directory: "../../../external/stdlib" erlang: output_directory: "../../_generated" test_output_directory: "../../_generated_test" ================================================ FILE: test/pass/sample_test_dep/rebar.config ================================================ {plugins, [{rebar_sesterl, {git, "https://github.com/gfngfn/rebar_sesterl_plugin.git", {branch, "master"}}}]}. {src_dirs, ["_generated", "./src"]}. {deps, []}. {profiles, [{test, [{deps, [{sesterl_testing, {git, "https://github.com/gfngfn/sesterl_testing", {tag, "v0.0.2"}}}]}]}]}. {eunit_tests, [{dir, "_generated_test"}, {dir, "./test"}]}. {sesterl_opts, [{output_dir, "_generated"},{test_output_dir, "_generated_test"}]}. ================================================ FILE: test/pass/sample_test_dep/sesterl.yaml ================================================ package: "sesterl_stdlib" source_directories: - "./src" test_directories: - "./test" main_module: "Main" test_dependencies: - name: "sesterl_testing" source: type: "git" repository: "https://github.com/gfngfn/sesterl_testing" spec: type: "tag" value: "v0.0.2" ================================================ FILE: test/pass/sample_test_dep/src/Main.sest ================================================ module Main :> sig val f : fun() -> int end = struct val f() = 42 + 57 end ================================================ FILE: test/pass/sample_test_dep/test/MainTest.sest ================================================ import Main module MainTest = #[test] struct #[test] val f_test() = Testing.it("equal to 99", fun() -> assert Testing.equal( -expect 99, -got Main.f(), ) end) end ================================================ FILE: test/pass/send.sest ================================================ module Send = struct type bintree<$a> = | Node($a, bintree<$a>, bintree<$a>) | Empty val bintree_of_int(n : int) : bintree = let rec aux(top, n) = if n <= 0 then Empty else let n1 = (n - 1) / 2 in let n2 = (n - 1) - n1 in let tr1 = aux(top + 1, n1) in let tr2 = aux(top + n1 + 1, n2) in Node(top, tr1, tr2) in aux(1, n) val reverse_list<$a>(xs : list<$a>) : list<$a> = let rec aux(rev : list<$a>, xs : list<$a>) = case xs of | [] -> rev | x :: tail -> aux(x :: rev, tail) end in aux([], xs) val rec wait_all<$b>(r : $b, n : int) = act if n <= 0 then let _ = print_debug("\"end!\"") in return(r) else receive | msg -> let _ = print_debug(msg) in wait_all(r, n - 1) end val rec spawn_all<$m>(acc, n : int) : [{pid<$m>, bintree}]list> = act if n <= 0 then return(reverse_list(acc)) else do parent <- self() in do pid : pid<$m> <- spawn(fun() -> act do me <- self() in send(parent, {me, bintree_of_int(n)}) end) in spawn_all(pid :: acc, n - 1) val main(_) = act let m = 10 in do pids <- spawn_all([], m) in let _ = print_debug(pids) in wait_all({}, m) end ================================================ FILE: test/pass/send2.sest ================================================ module Send2 = struct val some_heavy_calculation(n) = n val rec wait_all(msgacc, n) = act if n <= 0 then return(msgacc) else receive | {pid, msg} -> let _ = print_debug(format(f'message ~p received from: ~p~n', {msg, pid})) in wait_all(msg :: msgacc, n - 1) end val rec spawn_all(pidacc, n) = act if n <= 0 then return(pidacc) else do parent <- self() in do pid <- spawn(fun() -> act do me <- self() in let msg = some_heavy_calculation(n) in send(parent, {me, msg}) end) in spawn_all(pid :: pidacc, n - 1) val main(_) = act let n = 10 in do pids <- spawn_all([], n) in let _ = print_debug(format(f'spawned: ~p~n', {pids})) in do msgs <- wait_all([], n) in let _ = print_debug(msgs) in return({}) end ================================================ FILE: test/pass/test_after.sest ================================================ module TestAfter = struct module Sub :> sig val wait<$a> : fun(int) -> [$a]bool end = struct val wait(timeout) = act receive | _ -> return(true) after timeout -> return(false) end end val main(_) = act receive | 42 -> let _ = print_debug("Forty two") in return({}) after (64 + 36) -> let _ = print_debug("Hey") in return({}) end end ================================================ FILE: test/pass/test_binary.sest ================================================ module TestBinary = struct val check : fun({binary, binary, binary, binary, binary}) -> {binary, binary, binary, binary, binary} = external 1 ``` check({A, B, C, D, E}) -> <<240,159,145,169,226,128,141,240,159,148,172>> = A, <<"👩‍🔬"/utf8>> = A, <<10,13,9,34,39,92>> = B, <<"\n\r\t\"\'\\"/utf8>> = B, <<39>> = C, <<"\'"/utf8>> = C, <<33,34,39,96,92,92>> = D, <<"!\"\'`\\\\"/utf8>> = D, <<111,110,101,10,116,119,111>> = E, <<"one\ntwo"/utf8>> = E, {A, B, C, D, E}. ``` val main(_) = let woman_scientist = "👩‍🔬" in let escape_sequences = "\n\r\t\"\'\\" in let single_quote = "'" in let raw = ``!"'`\\`` in let multiline = ``` one two``` in let examples = {woman_scientist, escape_sequences, single_quote, raw, multiline} in print_debug(check(examples)) end ================================================ FILE: test/pass/test_binary_pattern.sest ================================================ module TestBinaryPattern = struct val check(s) = case s of | "one" -> Some(1) | "two" -> Some(2) | _ -> None end val main(_) = print_debug({check("one"), check("two"), check("other")}) end ================================================ FILE: test/pass/test_first_class_module.sest ================================================ module TestFirstClassModule = struct module Sub = struct type t = int val compare(n1, n2) = n2 - n1 end signature Ord = sig type t val compare : fun(t, t) -> int end val f(x : pack Ord) = x val main(_) = print_debug(f(pack Sub : Ord)) end ================================================ FILE: test/pass/test_first_class_module2.sest ================================================ module TestFirstClassModule2 :> sig signature Ord = sig type t val compare : fun(t, t) -> int end end = struct signature Ord = sig type t val compare : fun(t, t) -> int end end ================================================ FILE: test/pass/test_float.sest ================================================ module TestFloat = struct val add(x, y) = x +. y val main(_) = print_debug(add(42.57, 1.)) end ================================================ FILE: test/pass/test_format.sest ================================================ module TestFormat = struct val f1() = f'Hello, ~s!' val f2() = f'~~ Hello, ~p and ~p! ~~' val f3() = f'repeat: ~10c, bound: ~20s' val f4() = f'\"Hello, ~10.3f!\"' val f5() = f'Hello.' val main(_) = let res1 = format(f1(), {"World"}) in let res2 = format(f2(), {42, true}) in let res3 = format(f3(), {$'*', "The quick brown fox jumps over the lazy dog."}) in let res4 = format(f4(), {3.14159265}) in let res5 = format(f5(), {}) in print_debug({res1, res2, res3, res4, res5}) end ================================================ FILE: test/pass/test_freeze.sest ================================================ module TestFreeze = struct module Sub = struct val add_pure(x, y) = x + y val add(x, y) = act return(add_pure(x, y)) val rec foldl_pure(f, i, l) = case l of | [] -> i | x :: xs -> foldl_pure(f, f(i, x), xs) end val foldl(f, i, l) = act return(foldl_pure(f, i, l)) end type info = unit val negate(n) = act return(0 - n) val partial(x) : frozen<{int}, info, int> = freeze Sub.add(x, _) val full(y) : frozen = let p = partial(42) in freeze (p) with (y) val partial1() : frozen<{int, list}, info, int> = freeze Sub.foldl(Sub.add_pure, _, _) val partial2() : frozen<{list}, info, int> = freeze (partial1()) with (0, _) val impl() : list> = [ freeze Sub.add(42, 57), freeze negate(100), freeze (partial2()) with ([3, 1, 4, 5, 9, 2]), ] val main<$a> : fun($a) -> unit = external 1 ``` main(_) -> List = impl(), lists:foreach( fun({M, F, Args}) -> Result = apply(M, F, Args), io:format("~p~n", [Result]) end, List). ``` end ================================================ FILE: test/pass/test_import/import_depended.sest ================================================ module ImportDepended = struct val hello() = "Hello" end ================================================ FILE: test/pass/test_import/import_depending.sest ================================================ import ImportDepended module ImportDepending = struct val main(_) = print_debug(ImportDepended.hello()) end ================================================ FILE: test/pass/test_import/sesterl.yaml ================================================ package: test_import source_directories: - "./" main_module: "ImportDepending" ================================================ FILE: test/pass/test_poly_rec.sest ================================================ module TestPolyRec = struct val rec pair<$a>(x : $a) : {$a, $a} = {x, x} and trues() = pair(true) and ones() = pair(1) end ================================================ FILE: test/pass/test_public_type.sest ================================================ module TestPublicType = struct /* signature S = sig type t type u = t end */ signature T = sig type u type t = u end /* module F = fun(X : S) -> X :> T */ end /* This test case was given by @elpinal. See: https://twitter.com/elpin1al/status/1317752613052452864?s=20 */ ================================================ FILE: test/pass/test_result.sest ================================================ module TestResult = struct val f(res) = case res of | Ok(n) -> n | Error({a, b}) -> a + b end val main(_) = print_debug([ f(Ok(4423)), f(Error({42, 57})), ]) end ================================================ FILE: test/pass/test_string.sest ================================================ module TestString = struct val phrase() = 'Hello World!' val chop_first(s) = case s of | [] -> None | ch :: tail -> Some({ch, tail}) end val starts_with_h(s) = case s of | $'H' :: _ -> true | _ -> false end val main(_) = let s = phrase() in let ans1 = chop_first(s) in let ans2 = $'F' :: 'oo' in let ans3 = starts_with_h(s) in print_debug({s, ans1, ans2, ans3}) end ================================================ FILE: test/pass/test_testing.sest ================================================ module TestTesting = #[test] struct val sub(x, y) = x == y #[test] val main() = sub(42, 42) end ================================================ FILE: test/pass/test_type.sest ================================================ module TestType = struct type t_a = t_b and t_b = t_c and t_c = int type position<$num> = { x : $num, y : $num } and geometry = | Circle(circle_info) | Rectangle(rectangle_info) and circle_info<$cnum, $rnum> = { center : position<$cnum>, radius : $rnum } and rectangle_info<$num> = { lower_right : position<$num>, upper_left : position<$num> } and rational = { denominator : int, numerator : int } end ================================================ FILE: test/pass/test_with.sest ================================================ module TestWith = struct module Impl1 = struct type t = int end module Api1 = Impl1 :> (sig type t end with type t = int) module Impl2 = struct module M = struct type t = int end end module Api2 = Impl2 :> (sig module M : sig type t end end with M type t = int) module Impl3 = struct type t = | Foo(int) | Bar(binary) end module Api3 = Impl3 :> (sig type t :: o end with type t = | Foo(int) | Bar(binary) ) module Api4 = Impl3 :> sig type t = | Foo(int) | Bar(binary) end val main(_) = let res = Api3.Foo(1) in print_debug(res) end ================================================ FILE: test/pass/variant.sest ================================================ module Variant :> sig type foo<$a> = | Foo(int) | Bar($a) end = struct type foo<$a> = | Foo(int) | Bar($a) end ================================================ FILE: test/rebar_test/.gitignore ================================================ _build/ _generated/ _gen/ ================================================ FILE: test/rebar_test/README.md ================================================ ## How to compile First, generate `rebar.config`: ```console $ sesterl config ./ ``` Then, run rebar3 with a plugin for Sesterl compiler: ```console $ rebar3 sesterl compile ``` ================================================ FILE: test/rebar_test/rebar.config ================================================ {plugins, [{rebar_sesterl, {git, "https://github.com/gfngfn/rebar_sesterl_plugin.git", {branch, "master"}}}]}. {src_dirs, ["_gen", "./src"]}. {deps, [{jsone, {git, "https://github.com/sile/jsone.git", {branch, "master"}}}]}. {sesterl_opts, [{output_dir, "_gen"}]}. ================================================ FILE: test/rebar_test/sesterl.yaml ================================================ package: "foo_rebar_test" source_directories: - "./src" dependencies: [] main_module: "Foo" erlang: output_directory: "_gen" erlang_dependencies: - name: "jsone" source: type: "git" repository: "https://github.com/sile/jsone.git" spec: type: "branch" value: "master" ================================================ FILE: test/rebar_test/src/foo.app.src ================================================ {application, foo, [ {description, "foo for rebar3 plugin test"}, {vsn, "0.0.1"}, {applications, [ kernel, stdlib ]} ]}. ================================================ FILE: test/rebar_test/src/foo.sest ================================================ module Foo = struct val fact(n) = let rec aux(acc, n) = if n <= 0 then acc else aux(n * acc, n - 1) in aux(1, n) val main() = let _ = print_debug(fact(10)) in {} end ================================================ FILE: test/testIdentifierScheme.ml ================================================ module SnakeCase = struct type t = { message : string; input : string; expects : (string list) option; } let test (r : t) () = let actual = IdentifierScheme.from_snake_case r.input |> Option.map (fun x -> x.IdentifierScheme.fragments) in Alcotest.(check (option (list string))) r.message r.expects actual end module CamelCase = struct type t = { message : string; input : string; expects : (string list) option; } let test (r : t) () = let actual = IdentifierScheme.from_upper_camel_case r.input |> Option.map (fun x -> x.IdentifierScheme.fragments) in Alcotest.(check (option (list string))) r.message r.expects actual end let () = let open Alcotest in run "IdentifierScheme" [ ("from_snake_case", List.map (fun tuple -> test_case "equal" `Quick (SnakeCase.test tuple)) SnakeCase.[ { message = "single"; input = "foo"; expects = Some["foo"]; }; { message = "double"; input = "foo_bar"; expects = Some["foo"; "bar"]; }; { message = "triple"; input = "foo_bar_baz"; expects = Some["foo"; "bar"; "baz"]; }; { message = "allow words to start with a digit"; input = "x86_64"; expects = Some["x86"; "64"]; }; { message = "cannot use the empty string"; input = ""; expects = None; }; { message = "cannot include adjacent underscores"; input = "foo__bar"; expects = None; }; { message = "cannot begin with an underscore"; input = "_foo"; expects = None; }; { message = "cannot end with an underscore"; input = "foo_"; expects = None; }; { message = "cannot include uppercase letters (1)"; input = "Foo"; expects = None; }; { message = "cannot include uppercase letters (2)"; input = "fOo"; expects = None; }; { message = "cannot include uppercase letters (1)"; input = "foo_Bar"; expects = None; }; { message = "cannot include uppercase letters (2)"; input = "foo_bAr"; expects = None; }; ]); ("from_upper_camel_case", List.map (fun tuple -> test_case "equal" `Quick (CamelCase.test tuple)) CamelCase.[ { message = "single"; input = "Foo"; expects = Some["foo"]; }; { message = "double"; input = "FooBar"; expects = Some["foo"; "bar"]; }; { message = "triple"; input = "FooBarBaz"; expects = Some["foo"; "bar"; "baz"]; }; { message = "includes number (1)"; input = "Foo3Bar"; expects = Some["foo3"; "bar"]; }; { message = "includes number (2)"; input = "Fo3oBar"; expects = Some["fo3o"; "bar"]; }; { message = "includes number (3)"; input = "F3ooBar"; expects = Some["f3oo"; "bar"]; }; { message = "includes number (4)"; input = "Fo42oBar"; expects = Some["fo42o"; "bar"]; }; { message = "includes number (5)"; input = "Foo42Bar"; expects = Some["foo42"; "bar"]; }; { message = "includes number (6)"; input = "FooBar3"; expects = Some["foo"; "bar3"]; }; { message = "includes number (7)"; input = "FooB3ar"; expects = Some["foo"; "b3ar"]; }; { message = "underscore + digit"; input = "X86_64"; expects = Some["x86"; "64"]; }; { message = "cannot include underscores that are not followed by digits"; input = "Foo_Bar"; expects = None; }; { message = "cannot use double underscore"; input = "X86__64"; expects = None; }; { message = "cannot end with underscores"; input = "Foo_"; expects = None; }; ]); ] ================================================ FILE: test/testLanguageVersion.ml ================================================ type test_case = { before : string; after : string; expects : bool; } let test_is_compatible (r : test_case) () = match (LanguageVersion.parse r.before, LanguageVersion.parse r.after) with | (Some(before), Some(after)) -> let message = Printf.sprintf "(%s, %s)" r.before r.after in Alcotest.(check bool) message r.expects (LanguageVersion.is_compatible ~before ~after) | _ -> Alcotest.fail "parse failed" let () = let open Alcotest in run "LanguageVersion" [ ("is_compatible", List.map (fun r -> test_case "check" `Quick (test_is_compatible r)) [ { before = "v0.1.3"; after = "v0.1.4"; expects = true; }; { before = "v0.1.4"; after = "v0.1.4"; expects = true; }; { before = "v0.1.5"; after = "v0.1.4"; expects = false; }; { before = "v0.1.3"; after = "v0.2.4"; expects = false; }; { before = "v0.1.5"; after = "v0.2.4"; expects = false; }; { before = "v0.1.3"; after = "v1.2.4"; expects = false; }; { before = "v1.1.5"; after = "v1.2.4"; expects = true; }; ] ); ] ================================================ FILE: test/testRange.ml ================================================ let test_pp_dummy () = let rng = Range.dummy "foo" in Alcotest.(check string) "same string" "(foo)" (Format.asprintf "%a" Range.pp rng) let () = let open Alcotest in run "Range" [ ("dummy", [ test_case "pp dummy" `Quick test_pp_dummy; ]); ] ================================================ FILE: test/testTypechecker.ml ================================================ open Syntax module rec MonoTypeVarUpdatable : sig type t = mono_type_var_updatable val pp : Format.formatter -> t -> unit val equal : t -> t -> bool end = struct type t = mono_type_var_updatable let pp ppf mtv = Format.fprintf ppf "%s" (show_mono_type_var_updatable mtv) let equal (mtvu1 : t) (mtvu2 : t) : bool = match (mtvu1, mtvu2) with | (Link(ty1), Link(ty2)) -> MonoType.equal ty1 ty2 | (Free(fid1), Free(fid2)) -> FreeID.equal fid1 fid2 | _ -> false end and MonoType : sig type t = mono_type val pp : Format.formatter -> t -> unit val equal : t -> t -> bool end = struct type t = mono_type let pp = pp_mono_type let equal (ty1 : t) (ty2 : t) : bool = let rec aux ((_, tymain1) : t) ((_, tymain2) : t) : bool = match (tymain1, tymain2) with | (BaseType(bt1), BaseType(bt2)) -> bt1 = bt2 | (FuncType(tydoms1, tycod1), FuncType(tydoms2, tycod2)) -> aux_list tydoms1 tydoms2 && aux tycod1 tycod2 | (PidType(pidty1), PidType(pidty2)) -> aux_pid pidty1 pidty2 | (EffType(effty1, ty1), EffType(effty2, ty2)) -> aux_effect effty1 effty2 && aux ty1 ty2 | (TypeVar(MustBeBound(mbbid1)), TypeVar(MustBeBound(mbbid2))) -> MustBeBoundID.equal mbbid1 mbbid2 | (TypeVar(Updatable(r1)), TypeVar(Updatable(r2))) -> MonoTypeVarUpdatable.equal !r1 !r2 | (ProductType(tys1), ProductType(tys2)) -> aux_list (TupleList.to_list tys1) (TupleList.to_list tys2) | (ListType(ty1), ListType(ty2)) -> aux ty1 ty2 | (DataType(tyid1, tys1), DataType(tyid2, tys2)) -> TypeID.equal tyid1 tyid2 && aux_list tys1 tys2 | _ -> false and aux_list (tys1 : t list) (tys2 : t list) : bool = match List.combine tys1 tys2 with | exception Invalid_argument(_) -> false | typairs -> typairs |> List.for_all (fun (ty1, ty2) -> aux ty1 ty2) and aux_pid (Pid(ty1)) (Pid(ty2)) = aux ty1 ty2 and aux_effect (Effect(ty1)) (Effect(ty2)) = aux ty1 ty2 in aux ty1 ty2 end let mono_type_var_updatable_witness : mono_type_var_updatable Alcotest.testable = (module MonoTypeVarUpdatable : Alcotest.TESTABLE with type t = mono_type_var_updatable) let test_unify (ty1, ty2, assoc) () = Typechecker.unify ty1 ty2; assoc |> List.iter (fun (fid, mtvu_nonref) -> Alcotest.check mono_type_var_updatable_witness "free variable" !fid mtvu_nonref ) let dr = Range.dummy "test" let () = let open Alcotest in run "Typechecker" [ ("unify", List.map (fun tuple -> test_case "unify" `Quick (test_unify tuple) ) [ begin let fid = FreeID.fresh 0 in let mtvu = ref (Free(fid)) in let ty1 = (dr, TypeVar(Updatable(mtvu))) in let ty2 = (dr, BaseType(IntType)) in (ty1, ty2, [ (mtvu, Link(ty2)) ]) end ]); ]