Showing preview only (566K chars total). Download the full file or copy to clipboard to get everything.
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<char>` 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 <input>` for generating `rebar.config`.
### Changed
- Change the command line spec from `sesterl <input> -o <output>` to `sesterl build <input> -o <output>`.
- 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 <source-file> -o <output-dir>
```
where `<source-file>` is the path to the source file you want to build (e.g. `trial/hello_world.sest`), and `<output-dir>` 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<pid<$q>>, int) -> [$p]list<pid<$q>>`
* `wait_all<$q> : fun(list<answer>, list<pid<$q>>) -> [{pid<$q>, answer}]list<answer>`
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 `'<M_1>.<M_2>. ... .<M_n>'` where each `<M_i>` 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<state>
val handle_call<$a> : fun(request, pid<$a>, state) -> [info]reply<info, response, state>
val handle_cast : fun(cast_message, state) -> [info]no_reply<state>
val handle_info : fun(info, state) -> [info]no_reply<state>
val handle_timeout : fun(state) -> [info]no_reply<state>
val handle_down<$a> : fun(MonitorRef.t, pid<$a>, StopReason.t, state) -> [info]no_reply<state>
val terminate : fun(StopReason.t, state) -> [info]unit
end
module Make : fun(Callback : Behaviour) -> sig
type proc :: o
val as_pid : fun(proc) -> pid<Callback.info>
val from_pid : fun(pid<Callback.info>) -> proc
val call<$a> : fun(proc, Callback.request, ?timeout int) -> [$a]result<Callback.response, call_error>
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<proc, start_link_error>
val start_link_name<$a> : fun(Callback.init_arg, -name name<Callback.global>) -> [$a]result<proc, start_link_error>
val where_is_local<$a> : fun(binary) -> [$a]option<proc>
val where_is_global<$a> : fun(Callback.global) -> [$a]option<proc>
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<int>) =
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<String>
# 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<String>
# 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<Dependency>
# This field is optional. Default: []
test_dependencies: Array<Dependency>
# This field is optional. Default: []
erlang: ErlangConfig
# This field is optional. Default: {}
document_outputs: Array<DocumentOutput>
# 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<ErlangDependency>
# 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<String>
}
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 "<code>%s</code>" s_typarams ]
| Synonym ->
[ Format.asprintf "<code>%s = %a</code>" 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 "<li><code>| %s%s</code></li>" ctornm s_param
)
in
List.concat [
[ Printf.sprintf "<code>%s =</code><ul>" s_typarams ];
ss_elems;
[ "</ul>" ];
]
in
[ Printf.sprintf "<li><code>%s %s</code>%s%s</li>"
(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 "<div class=\"doc-area\">%s</div>" 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 "<li><code>%s %s%s : %s</code>%s</li>" (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 "<li><code>%s %s</code>%s<code> : </code>" (spec.token "module") modnm s_doc ];
ss;
[ "</li>" ];
]
| DocSig(signm, docsig) ->
let ss = docsig |> (stringify_document_signature ~seen_from) in
List.concat [
[ Printf.sprintf "<li><code>%s %s</code>%s<code> = </code>" (spec.token "signature") signm s_doc ];
ss;
[ "</li>" ];
]
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 "<code>%s%s</code>" (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 "<code>(</code>" ];
ss1;
[ Printf.sprintf "<code>%s</code>" (spec.token "with") ];
ss2;
[ Printf.sprintf "<code>)</code>" ];
]
| DocSigDecls(docelems) ->
List.concat [
[
Printf.sprintf "<code>%s</code>" (spec.token "sig");
"<ul>";
];
docelems |> List.map (stringify_document_element ~seen_from) |> List.concat;
[
"</ul>";
Printf.sprintf "<code>%s</code>" (spec.token "end");
];
]
| DocSigFunctor(m, docsig1, docsig2) ->
List.concat [
[ Printf.sprintf "<code>%s(%s : </code>" (spec.token "fun") m ];
stringify_document_signature ~seen_from docsig1;
[ Printf.sprintf "<code>) -> </code>" ];
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 [
[
"<!DOCTYPE html>";
"<html>";
"<head>";
Printf.sprintf "<title>%s</title>" out.module_name;
"<style>";
".keyword { color: #0000AA; }";
".doc-area { background-color: #EEEEEE; padding: 2px 6px 2px 6px; margin: 0px 0px 0px 0px; }";
"</style>";
"</head>";
"<body><ul>";
];
stringify_document_element ~seen_from:Address.root docelem;
[
"</ul></body>";
"</html>";
];
]
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 "<constructor_map>")]
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 "<values>")]
constructors : constructor_entry ConstructorMap.t;
[@printer (fun ppf _ -> Format.fprintf ppf "<constructors>")]
types : type_entry TypeNameMap.t;
[@printer (fun ppf _ -> Format.fprintf ppf "<types>")]
opaques : kind OpaqueIDMap.t;
[@printer (fun ppf _ -> Format.fprintf ppf "<opaques>")]
modules : module_entry ModuleNameMap.t;
[@printer (fun ppf _ -> Format.fprintf ppf "<modules>")]
signatures : signature_entry SignatureNameMap.t;
[@printer (fun ppf _ -> Format.fprintf ppf "<signatures>")]
}
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 "<SRVal>")]
| SRCtor of constructor_name * constructor_entry
[@printer (fun ppf _ -> Format.fprintf ppf "<SRCtor>")]
| SRFold of type_name * poly_type
| SRType of type_name * type_entry
[@printer (fun ppf _ -> Format.fprintf ppf "<SRType>")]
| SRModule of module_name * module_entry
| SRSig of signature_name * signature_entry
[@printer (fun ppf _ -> Format.fprintf ppf "<SRSig>")]
[@@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 [<lower-or-digit> <lower>* ('_' <lower>+)*].
{[
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 =@[<hov>@ %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 = @[<v2>{%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}) ->@[<hov2>@ %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@[<hov2>(%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 =@[<hov2>@ %a@]@ in@ %a)"
OutputIdentifier.pp_local lname
pp_ast e1
pp_ast e2
| ICase(e0, ibrs) ->
Format.fprintf ppf "(case@[<hov2>@ %a@]@ of@[<hov2>@ %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 ->@[<hov2>@ %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.sp
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
Condensed preview — 193 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (565K chars).
[
{
"path": ".github/workflows/ci.yml",
"chars": 1370,
"preview": "name: CI\n\non:\n - pull_request\n - push\n\njobs:\n build:\n name: Build\n\n strategy:\n fail-fast: false\n matr"
},
{
"path": ".gitignore",
"chars": 83,
"preview": "_opam/\n_build/\n*~\n.merlin\n.DS_Store\nsesterl\n_generated/\n*.install\n_generated_test/\n"
},
{
"path": ".gitmodules",
"chars": 207,
"preview": "[submodule \"external/stdlib\"]\n\tpath = external/stdlib\n\turl = https://github.com/gfngfn/sesterl_stdlib\n[submodule \"extern"
},
{
"path": "CHANGELOG.md",
"chars": 5960,
"preview": "# Changelog\n\nAll notable changes to this project will be documented in this file.\n\nThe format is based on [Keep a Change"
},
{
"path": "Makefile",
"chars": 661,
"preview": ".PHONY: all\nall:\n\tdune build -p sesterl\n\tcp _build/default/src/main.exe ./sesterl\n\n.PHONY: test\ntest: test-blackbox-posi"
},
{
"path": "README.md",
"chars": 40268,
"preview": "# Sesterl: A Session-Typed Erlang\n\n## Summary\n\n*Sesterl* (pronounced as /səsˈtɚːl/) is an ML-like statically-typed funct"
},
{
"path": "dune-project",
"chars": 646,
"preview": "(lang dune 2.5)\n(name sesterl)\n(version 0.2.1)\n\n(using menhir 2.0)\n(generate_opam_files true)\n\n(source (github gfngfn/Se"
},
{
"path": "examples/echo_server/README.md",
"chars": 616,
"preview": "\n## How to Compile and Run\n\n```console\n# Generate `rebar.config`\n$ sesterl config ./\n\n# Compile sources\n$ rebar3 sesterl"
},
{
"path": "examples/echo_server/rebar.config",
"chars": 709,
"preview": "{plugins, [{rebar_sesterl, {git, \"https://github.com/gfngfn/rebar_sesterl_plugin.git\", {branch, \"master\"}}}]}.\n{src_dirs"
},
{
"path": "examples/echo_server/sesterl.yaml",
"chars": 1031,
"preview": "package: \"echo_server\"\nlanguage: \"v0.2.0\"\n\nsource_directories:\n - \"./src\"\n\ntest_directories:\n - \"./test\"\n\nmain_module:"
},
{
"path": "examples/echo_server/src/echo_server.app.src",
"chars": 326,
"preview": "{application, echo_server, [\n {description, \"An example echo server written in Sesterl\"},\n {vsn, \"0.1.0\"},\n {re"
},
{
"path": "examples/echo_server/src/echo_server.sest",
"chars": 712,
"preview": "import Sup\nimport Handler\n\nmodule App = struct\n\n val start(start_type, start_args) = act\n let error = fun(x) -> Erro"
},
{
"path": "examples/echo_server/src/handler.sest",
"chars": 793,
"preview": "module Handler = struct\n open Stdlib\n\n val status_code() =\n 200\n\n val init(req, state) = act\n let bs = Cowboy.b"
},
{
"path": "examples/echo_server/src/sup.sest",
"chars": 370,
"preview": "module Sup = struct\n open Stdlib\n\n module S = Supervisor.Static\n\n module Callback = struct\n type child_id = unit\n\n"
},
{
"path": "examples/echo_server/test/handler_tests.sest",
"chars": 235,
"preview": "import Handler\n\nmodule HandlerTests = #[test] struct\n\n #[test]\n val status_code_test() =\n Testing.it(\"status code t"
},
{
"path": "examples/hello_world/README.md",
"chars": 948,
"preview": "\n```console\n# Generate/update `rebar.config`\n$ sesterl config ./\n output written on '/path/to/repo/examples/hello_world"
},
{
"path": "examples/hello_world/rebar.config",
"chars": 322,
"preview": "{plugins, [{rebar_sesterl, {git, \"https://github.com/gfngfn/rebar_sesterl_plugin.git\", {branch, \"master\"}}}]}.\n{src_dirs"
},
{
"path": "examples/hello_world/sesterl.yaml",
"chars": 94,
"preview": "package: \"hello_world\"\nlanguage: \"v0.2.0\"\nmain_module: \"Main\"\nsource_directories:\n - \"./src\"\n"
},
{
"path": "examples/hello_world/src/Main.sest",
"chars": 74,
"preview": "module Main = struct\n\n val show() =\n print_debug(\"Hello World!\")\n\nend\n"
},
{
"path": "examples/hello_world/src/hello_world.app.src",
"chars": 251,
"preview": "{application, hello_world, [\n {description, \"A Hello World Program\"},\n {vsn, \"0.0.1\"},\n {registered, []},\n {"
},
{
"path": "run-negative-blackbox-tests.sh",
"chars": 703,
"preview": "#!/bin/bash\n\nBIN=\"./sesterl\"\nSOURCE_DIR=\"test/fail\"\nTARGET_DIR=\"test/_generated\"\n\nmkdir -p \"$TARGET_DIR\"\n\nNO_ERRORS=()\n\n"
},
{
"path": "run-positive-blackbox-tests.sh",
"chars": 1870,
"preview": "#!/bin/bash\n\nCURDIR=$(pwd)\n\ncommand -v gsed\nSTATUS=$?\nif [ $STATUS -eq 0 ]; then\n GNU_SED=\"gsed\"\nelse\n command -v "
},
{
"path": "sesterl.opam",
"chars": 909,
"preview": "# This file is generated by dune, edit dune-project instead\nopam-version: \"2.0\"\nversion: \"0.2.1\"\nsynopsis: \"Sesterl: A S"
},
{
"path": "src/address.ml",
"chars": 1844,
"preview": "\nopen MyUtil\n\n\ntype element =\n | Member of string\n | FunctorBody of { arg : string }\n[@@deriving show { with_path"
},
{
"path": "src/address.mli",
"chars": 322,
"preview": "\ntype element =\n | Member of string\n | FunctorBody of { arg : string }\n\ntype t\n\nval root : t\n\nval append_member :"
},
{
"path": "src/assocList.ml",
"chars": 1123,
"preview": "\n\nmodule type EQ = sig\n type t\n val equal : t -> t -> bool\nend\n\n\nmodule Make(Key : EQ) : sig\n type elem\n type 'v t\n "
},
{
"path": "src/boundID.ml",
"chars": 325,
"preview": "\ntype t = {\n id : int;\n}\n\n\nlet equal bid1 bid2 =\n bid1.id = bid2.id\n\n\nlet hash bid =\n bid.id\n\n\nlet compare bid1 bid2 "
},
{
"path": "src/boundID.mli",
"chars": 180,
"preview": "\ntype t\n\nval initialize : unit -> unit\n\nval fresh : unit -> t\n\nval equal : t -> t -> bool\n\nval hash : t -> int\n\nval comp"
},
{
"path": "src/configLoader.ml",
"chars": 7614,
"preview": "\nopen MyUtil\nopen Errors\nopen Syntax\n\n\ntype git_spec =\n | Tag of string\n | Ref of string\n | Branch of string\n\nt"
},
{
"path": "src/constants.ml",
"chars": 336,
"preview": "\n\nlet semantic_version =\n \"v0.2.1\"\n\n\nlet config_file_name =\n \"sesterl.yaml\"\n\n\nlet default_output_directory =\n \"_gener"
},
{
"path": "src/constructorAttribute.ml",
"chars": 1165,
"preview": "\nopen MyUtil\nopen Syntax\n\n\ntype t = {\n target_atom : (string ranged) option;\n}\n\n\nlet default =\n { target_atom = None }"
},
{
"path": "src/constructorID.ml",
"chars": 382,
"preview": "\ntype t = IdentifierScheme.t\n\n\nlet from_upper_camel_case : string -> t option =\n IdentifierScheme.from_upper_camel_case"
},
{
"path": "src/constructorID.mli",
"chars": 164,
"preview": "\ntype t\n\nval from_upper_camel_case : string -> t option\n\nval from_snake_case : string -> t option\n\nval pp : Format.forma"
},
{
"path": "src/declarationAttribute.ml",
"chars": 1287,
"preview": "\nopen MyUtil\nopen Syntax\n\n\ntype t = {\n doc : string option;\n}\n\n\nlet default =\n {\n doc = None;\n }\n\n\nlet decode (att"
},
{
"path": "src/dependencyGraph.ml",
"chars": 2750,
"preview": "\nopen MyUtil\nopen Syntax\nopen Env\n\nmodule IDMap = Map.Make(String)\n\nmodule GraphImpl = Graph.Persistent.Digraph.Abstract"
},
{
"path": "src/dependencyGraph.mli",
"chars": 399,
"preview": "\nopen Syntax\nopen Env\n\ntype t\n\ntype data = {\n position : Range.t;\n type_variables : type_variable_binder list;"
},
{
"path": "src/displayMap.ml",
"chars": 4007,
"preview": "\nopen Syntax\n\n\nmodule FreeIDMap = Map.Make(FreeID)\nmodule FreeRowIDMap = Map.Make(FreeRowID)\nmodule BoundIDMap = Map.Mak"
},
{
"path": "src/displayMap.mli",
"chars": 1010,
"preview": "\nopen Syntax\n\ntype t\n\nval empty : t\n\nval add_free_id : FreeID.t -> t -> t\n\nval add_free_row_id : FreeRowID.t -> LabelSet"
},
{
"path": "src/documentGenerator.ml",
"chars": 9500,
"preview": "\nopen MyUtil\nopen Syntax\nopen Env\nopen IntermediateSyntax\n\n\ntype document_tree_element_main =\n | DocVal of identifie"
},
{
"path": "src/dune",
"chars": 346,
"preview": "(executable\n (public_name sesterl)\n (package sesterl)\n (name main)\n (flags (-w -3 -bin-annot -thread))\n (libraries\n"
},
{
"path": "src/env.ml",
"chars": 20119,
"preview": "\nopen MyUtil\nopen Syntax\n\ntype ('a, 'b) typ =\n (('a, 'b) typ_main) ranged\n\nand ('a, 'b) typ_main =\n | BaseType of b"
},
{
"path": "src/env.mli",
"chars": 7324,
"preview": "\nopen Syntax\n\ntype environment\n\ntype record_signature\n\ntype ('a, 'b) typ =\n (('a, 'b) typ_main) ranged\n\nand ('a, 'b) ty"
},
{
"path": "src/errors.ml",
"chars": 5079,
"preview": "\nopen MyUtil\nopen Syntax\nopen Env\n\ntype config_error =\n | CyclicFileDependencyFound of absolute_path cycle\n | ConfigFi"
},
{
"path": "src/fileDependencyGraph.ml",
"chars": 2088,
"preview": "\nopen MyUtil\nopen Syntax\n\nmodule GraphImpl = Graph.Persistent.Digraph.Abstract(String)\n\nmodule ComponentImpl = Graph.Com"
},
{
"path": "src/fileDependencyGraph.mli",
"chars": 531,
"preview": "\nopen MyUtil\nopen Syntax\n\ntype vertex\n\ntype t\n\nval empty : t\n\nval find_vertex : absolute_path -> t -> vertex option\n\nval"
},
{
"path": "src/freeID.ml",
"chars": 609,
"preview": "\ntype level = int\n\ntype t = {\n id : int;\n mutable level : level;\n}\n\n\nlet pp ppf fid =\n Format.fprintf ppf "
},
{
"path": "src/freeID.mli",
"chars": 284,
"preview": "\ntype level = int\n\ntype t\n\nval equal : t -> t -> bool\n\nval compare : t -> t -> int\n\nval hash : t -> int\n\nval initialize "
},
{
"path": "src/identifierScheme.ml",
"chars": 3122,
"preview": "(**\n Every fragment should be a non-empty string consisting only of lowercase letters and digits.\n\n `to_upper_came"
},
{
"path": "src/identifierScheme.mli",
"chars": 1121,
"preview": "(** `IdentifierScheme` is a module that abstracts identifiers\n for equating the snake case and the upper camel case.\n"
},
{
"path": "src/intermediateSyntax.ml",
"chars": 4745,
"preview": "\nopen MyUtil\nopen Syntax\nopen Env\n\n\ntype pattern =\n | IPUnit\n | IPBool of bool\n | IPInt of int\n | IPB"
},
{
"path": "src/kindStore.ml",
"chars": 875,
"preview": "\nopen Syntax\nopen Env\n\n\nmodule FreeRowHashTable = Hashtbl.Make(FreeRowID)\n\nmodule BoundRowHashTable = Hashtbl.Make(Bound"
},
{
"path": "src/kindStore.mli",
"chars": 236,
"preview": "\nopen Syntax\nopen Env\n\nval register_free_row : FreeRowID.t -> LabelSet.t -> unit\n\nval get_free_row : FreeRowID.t -> Labe"
},
{
"path": "src/languageVersion.ml",
"chars": 814,
"preview": "\ntype t = Semver.t\n\n\nlet parse (s : string) : t option =\n Option.bind (Core.String.chop_prefix s ~prefix:\"v\") Semver.of"
},
{
"path": "src/lexer.mll",
"chars": 10845,
"preview": "{\n open MyUtil\n open Syntax\n open Parser\n open Errors\n\n\n exception Error of lexer_error\n\n\n let raise_error e =\n "
},
{
"path": "src/list1.ml",
"chars": 682,
"preview": "\nopen MyUtil\n\n\ntype 'a t = 'a * 'a list\n\n\nlet make x1 xs =\n (x1, xs)\n\n\nlet map f (x1, xs) =\n let y1 = f x1 in\n (y1, x"
},
{
"path": "src/list1.mli",
"chars": 473,
"preview": "\ntype 'a t\n(** ['a t] is the type for lists (of values of type ['a]) the length of which is more than or equal to 1. *)\n"
},
{
"path": "src/list2.ml",
"chars": 819,
"preview": "\nopen MyUtil\n\n\ntype 'a t = 'a * 'a * 'a list\n\n\nlet make x1 x2 xs =\n (x1, x2, xs)\n\n\nlet map f (x1, x2, xs) =\n let y1 = "
},
{
"path": "src/list2.mli",
"chars": 531,
"preview": "\ntype 'a t\n(** ['a t] is the type for lists (of values of type ['a]) the length of which is more than or equal to 2. *)\n"
},
{
"path": "src/logging.ml",
"chars": 19012,
"preview": "\nopen MyUtil\nopen Syntax\nopen Env\nopen Errors\n\n\nlet warn_val_not_used (rng : Range.t) (x : identifier) =\n Format.printf"
},
{
"path": "src/main.ml",
"chars": 7379,
"preview": "\nopen MyUtil\nopen Syntax\nopen Errors\nopen Env\n\n\nexception InvalidExternalSpec of string\n\n\nlet catch_error (k : unit -> u"
},
{
"path": "src/moduleAttribute.ml",
"chars": 2258,
"preview": "\nopen MyUtil\nopen Syntax\n\n\ntype accumulator = {\n acc_behaviours : StringSet.t;\n acc_for_test : bool;\n}\n\ntype t = {\n "
},
{
"path": "src/mustBeBoundID.ml",
"chars": 597,
"preview": "\ntype t = {\n main : BoundID.t;\n name : string;\n level : int;\n}\n\n\nlet fresh (name : string) (lev : int) : t =\n let "
},
{
"path": "src/myUtil.ml",
"chars": 3029,
"preview": "\nmodule StringSet = Set.Make(String)\n\n\nmodule Alist : sig\n type 'a t\n val empty : 'a t\n val extend : 'a t -> 'a -> 'a"
},
{
"path": "src/outputErlangCode.ml",
"chars": 22556,
"preview": "\nopen MyUtil\nopen Syntax\nopen Env\nopen IntermediateSyntax\n\n\nlet fresh_local_symbol () =\n OutputIdentifier.output_local "
},
{
"path": "src/outputErlangCode.mli",
"chars": 640,
"preview": "\nopen MyUtil\nopen Syntax\nopen IntermediateSyntax\n\n\nval main : output_spec -> string -> name_map -> package_name:(space_n"
},
{
"path": "src/outputIdentifier.ml",
"chars": 4569,
"preview": "\ntype space =\n | ReprSpace of {\n number : int;\n main : IdentifierScheme.t;\n }\n\ntype local =\n | ReprLoca"
},
{
"path": "src/outputIdentifier.mli",
"chars": 1340,
"preview": "\ntype space\n(** The type for abstracting module names in outputs. *)\n\ntype local\n\ntype global\n\ntype operator\n\ntype t =\n "
},
{
"path": "src/outputRebarConfig.ml",
"chars": 5230,
"preview": "\nopen MyUtil\n\n\ntype value =\n | Int of int\n | String of string\n | Atom of string\n | Bool of bool\n | List of"
},
{
"path": "src/packageChecker.ml",
"chars": 4223,
"preview": "\nopen MyUtil\nopen Syntax\nopen IntermediateSyntax\nopen Env\nopen Errors\n\n\nmodule SigRecordMap = Map.Make(String)\n\ntype sig"
},
{
"path": "src/packageLoader.ml",
"chars": 4489,
"preview": "\nopen MyUtil\nopen Syntax\nopen Errors\n\n\nexception PackageError of package_error\n\n\nlet load_config absdir_in =\n let abspa"
},
{
"path": "src/packageLoader.mli",
"chars": 747,
"preview": "\nopen MyUtil\nopen Syntax\nopen Errors\n\nexception PackageError of package_error\n\nval load_config : absolute_dir -> ConfigL"
},
{
"path": "src/parser.mly",
"chars": 32128,
"preview": "%{\n open Syntax\n open MyUtil\n\n type 'a range_spec =\n | Token of Range.t\n | Ranged of (Range.t * 'a)\n\n let make"
},
{
"path": "src/parserInterface.ml",
"chars": 753,
"preview": "\nopen Syntax\nopen Errors\n\nmodule I = Parser.MenhirInterpreter\n\n\nlet k_success x =\n Ok(x)\n\n\nlet k_fail chkpt =\n match c"
},
{
"path": "src/parserInterface.mli",
"chars": 187,
"preview": "\nopen Syntax\nopen Errors\n\nval process : fname:string -> Lexing.lexbuf -> ((module_name ranged) list * module_name ranged"
},
{
"path": "src/primitives.ml",
"chars": 10157,
"preview": "\nopen MyUtil\nopen Syntax\nopen IntermediateSyntax\nopen Env\n\n\nlet primitive_module_name =\n \"sesterl_internal_prim\"\n\n\nlet "
},
{
"path": "src/primitives.mli",
"chars": 887,
"preview": "\nopen Syntax\nopen IntermediateSyntax\nopen Env\n\nval primitive_module_name : string\n\nval decode_option_function : string\n\n"
},
{
"path": "src/range.ml",
"chars": 1764,
"preview": "\ntype real = {\n file_name : string;\n start_line : int;\n start_column : int;\n last_line : int;\n last_column "
},
{
"path": "src/range.mli",
"chars": 261,
"preview": "\ntype t\n\nval pp : Format.formatter -> t -> unit\n\nval from_lexbuf : Lexing.lexbuf -> t\n\nval from_positions : Lexing.posit"
},
{
"path": "src/sourceLoader.ml",
"chars": 7955,
"preview": "\nopen MyUtil\nopen Syntax\nopen Errors\n\nexception SyntaxError of syntax_error\n\n\ntype loaded_module = {\n source_path "
},
{
"path": "src/sourceLoader.mli",
"chars": 1279,
"preview": "\nopen MyUtil\nopen Syntax\nopen Errors\n\nexception SyntaxError of syntax_error\n\ntype loaded_module = {\n source_path "
},
{
"path": "src/syntax.ml",
"chars": 13230,
"preview": "\nopen MyUtil\n\nmodule TupleList = List1\n\ntype module_name_output_spec =\n | SingleSnake\n | DottedCamels\n\ntype output_spe"
},
{
"path": "src/typeConv.ml",
"chars": 30471,
"preview": "\nopen MyUtil\nopen Syntax\nopen Env\n\n\nlet collect_ids_scheme (fidht : unit FreeIDHashTable.t) (fridht : LabelSet.t FreeRow"
},
{
"path": "src/typeID.ml",
"chars": 814,
"preview": "\ntype t = {\n number : int;\n address : Address.t;\n name : string;\n}\n\n\nlet fresh =\n let current_max = ref 0 in\n ("
},
{
"path": "src/typeID.mli",
"chars": 286,
"preview": "\ntype t\n\nval fresh : Address.t -> string -> t\n\nval hash : t -> int\n\nval compare : t -> t -> int\n\nval equal : t -> t -> b"
},
{
"path": "src/typechecker.ml",
"chars": 149891,
"preview": "\nopen MyUtil\nopen Syntax\nopen IntermediateSyntax\nopen Env\nopen Errors\n\n\nexception TypeError of type_error\n\n\nmodule Bindi"
},
{
"path": "src/typechecker.mli",
"chars": 414,
"preview": "\nopen Syntax\nopen IntermediateSyntax\nopen Env\nopen Errors\n\nexception TypeError of type_error\n\nval typecheck_signature : "
},
{
"path": "src/valueAttribute.ml",
"chars": 1116,
"preview": "\nopen MyUtil\nopen Syntax\n\n\ntype t = {\n is_test_suite : bool;\n}\n\n\nlet default =\n {\n is_test_suite = false;\n }\n\n\nlet"
},
{
"path": "src/yamlDecoder.ml",
"chars": 3647,
"preview": "\nopen MyUtil\n\n\ntype error =\n | FieldNotFound of string\n | NotAFloat\n | NotAString\n | NotABool\n | NotAnArray\n | Not"
},
{
"path": "src/yamlDecoder.mli",
"chars": 794,
"preview": "\ntype error\n\nval pp_error : Format.formatter -> error -> unit\n\ntype 'a t\n\nval run : 'a t -> string -> ('a, error) result"
},
{
"path": "test/concept/cell.sest",
"chars": 1139,
"preview": "/* The current type checker does NOT accept this module. */\nmodule Cell :> sig\n type t :: (o) -> o\n val start<$a, $con"
},
{
"path": "test/concept/counter.sest",
"chars": 3817,
"preview": "/* This is just a conceptual example and cannot be compiled. */\n\ntype option<$a> = None | Some($a)\ntype result<$a, $b> ="
},
{
"path": "test/dune",
"chars": 170,
"preview": "(tests\n (names\n testRange\n testLanguageVersion\n testIdentifierScheme)\n (libraries\n alcotest\n ocamlgraph"
},
{
"path": "test/fail/error01.sest",
"chars": 94,
"preview": "module Error01 = struct\n val main() =\n let x = /* here is /* a comment */ 1 in\n x\nend\n"
},
{
"path": "test/fail/error_arity.sest",
"chars": 81,
"preview": "module ErrorArity = struct\n\n val add(x, y) = x + y\n\n val main() = add(42)\n\nend\n"
},
{
"path": "test/fail/error_coercion.sest",
"chars": 349,
"preview": "module ErrorCoercion = struct\n module Sub = struct\n module Impl = struct\n val rec aux(acc, n, x) =\n if n"
},
{
"path": "test/fail/error_coercion2.sest",
"chars": 93,
"preview": "module ErrorCoercion2 :> sig\n val f<$a> : fun($a) -> $a\nend = struct\n val f(n) = n + 1\nend\n"
},
{
"path": "test/fail/error_coercion3.sest",
"chars": 148,
"preview": "module ErrorCoercion3 = struct\n module Impl = struct\n val f(n) = n + 1\n end\n module Api = Impl :> sig\n val f<$a"
},
{
"path": "test/fail/error_coercion4.sest",
"chars": 283,
"preview": "module ErrorCoercion4 = struct\n module Sub :> sig\n val power : fun(int, int) -> int\n end = struct\n val rec aux(a"
},
{
"path": "test/fail/error_coercion5.sest",
"chars": 216,
"preview": "module ErrorCoercion5 = struct\n module Impl = struct\n type t = int\n val make(x) = x\n end\n\n module Sub = Impl :>"
},
{
"path": "test/fail/error_coercion6.sest",
"chars": 194,
"preview": "module ErrorCoercion6 = struct\n module Sub :> sig\n type t :: o\n val make : fun(int) -> t\n end = struct\n type "
},
{
"path": "test/fail/error_contradiction.sest",
"chars": 96,
"preview": "module ErrorContradiction = struct\n\n val add(x, y) = x + y\n\n val main() = add(\"foo\", 42)\n\nend\n"
},
{
"path": "test/fail/error_cyclic/error_cyclic.sest",
"chars": 143,
"preview": "import ErrorCyclicFoo\nimport ErrorCyclicBar\n\nmodule ErrorCyclic = struct\n val main() =\n {ErrorCyclicFoo.main(), Erro"
},
{
"path": "test/fail/error_cyclic/error_cyclic_bar.sest",
"chars": 76,
"preview": "import ErrorCyclicFoo\n\nmodule ErrorCyclicBar = struct\n val main() = {}\nend\n"
},
{
"path": "test/fail/error_cyclic/error_cyclic_foo.sest",
"chars": 76,
"preview": "import ErrorCyclicBar\n\nmodule ErrorCyclicFoo = struct\n val main() = {}\nend\n"
},
{
"path": "test/fail/error_cyclic/sesterl.yaml",
"chars": 90,
"preview": "package: test_fail_error_cyclic\n\nsource_directories:\n - \"./\"\n\nmain_module: \"ErrorCyclic\"\n"
},
{
"path": "test/fail/error_first_class_module.sest",
"chars": 232,
"preview": "module ErrorFirstClassModule :> sig\n val f : fun(pack sig end) -> int\nend = struct\n val f(x : pack sig val n : int end"
},
{
"path": "test/fail/error_freeze.sest",
"chars": 83,
"preview": "module ErrorFreeze = struct\n\n val g() =\n let f(x) = x in\n freeze f(42)\n\nend\n"
},
{
"path": "test/fail/error_functor.sest",
"chars": 161,
"preview": "module ErrorFunctor = struct\n\n signature S = sig\n type t :: o\n end\n\n module F = fun(X : S) -> fun(Y : S) -> struct"
},
{
"path": "test/fail/error_inference.sest",
"chars": 87,
"preview": "module ErrorInference = struct\n\n val f(x) =\n x.foo\n\n val main(_) =\n f(42)\n\nend\n"
},
{
"path": "test/fail/error_kind.sest",
"chars": 181,
"preview": "module ErrorKind = struct\n\n module Impl = struct\n type t = binary\n val v() = \"Hello\"\n end\n\n include Impl :> sig"
},
{
"path": "test/fail/error_kind2.sest",
"chars": 134,
"preview": "module ErrorKind2 = struct\n\n val f<?$r :: (foo)>(n : int, b : bool) : { foo : int, bar : bool, ?$r } =\n { foo = n, b"
},
{
"path": "test/fail/error_kind3.sest",
"chars": 174,
"preview": "module ErrorKind3 = struct\n\n val f<?$r :: (foo)>(r : { foo : int, bar : bool, ?$r }, n : int, b : bool) : { foo : int, "
},
{
"path": "test/fail/error_kinded_parameter.sest",
"chars": 249,
"preview": "module ErrorKindedParameter = struct\n\n type t<$a :: {foo : int}> =\n | HasFoo($a)\n\n val f(x) =\n case x of\n | H"
},
{
"path": "test/fail/error_mandatory_parameter.sest",
"chars": 183,
"preview": "module ErrorMandatoryParameter = struct\n\n val get_or_else(x, -default d) =\n case x of\n | Some(v) -> v\n | None "
},
{
"path": "test/fail/error_mandatory_parameter2.sest",
"chars": 192,
"preview": "module ErrorMandatoryParameter2 = struct\n\n val get_or_else(x, -default d) =\n case x of\n | Some(v) -> v\n | None"
},
{
"path": "test/fail/error_mutrec.sest",
"chars": 133,
"preview": "module ErrorMutrec = struct\n\n type foo =\n {int, bar}\n\n and baz<$a> =\n | Baz(foo, bar)\n\n and bar =\n {bool, ba"
},
{
"path": "test/fail/error_optional_parameter.sest",
"chars": 196,
"preview": "module ErrorOptionalParameter = struct\n\n module Impl = struct\n val f(g) =\n {g(42), g(42, ?foo 57)}\n end\n\n inc"
},
{
"path": "test/fail/error_optional_parameter_unify.sest",
"chars": 329,
"preview": "module ErrorOptionalParameterUnify = struct\n\n val f1(g) = g(?foo 42)\n\n val f2(g) = g(?foo 42, ?bar true)\n\n val f(flag"
},
{
"path": "test/fail/error_optional_parameter_unify2.sest",
"chars": 174,
"preview": "module ErrorOptionalParameterUnify2 = struct\n\n val g1(?foo nopt) = {nopt, None}\n\n val g2(?foo nopt, ?bar bopt) = {nopt"
},
{
"path": "test/fail/error_recursive_type_parameter.sest",
"chars": 79,
"preview": "module ErrorRecursiveTypeParameter = struct\n\n val f(x) = { x | foo = x }\n\nend\n"
},
{
"path": "test/fail/error_recursive_type_parameter2.sest",
"chars": 102,
"preview": "module ErrorRecursiveTypeParameter2 = struct\n\n val f(x, y) = {{ x | foo = y }, { y | bar = x }}\n\nend\n"
},
{
"path": "test/fail/error_type_cyclic.sest",
"chars": 80,
"preview": "module ErrorTypeCyclic = struct\n\n type t_x =\n t_y\n\n and t_y =\n t_x\n\nend\n"
},
{
"path": "test/fail/error_variant.sest",
"chars": 106,
"preview": "module ErrorVariant :> sig\n type t =\n | Foo(int)\nend = struct\n type t =\n | Foo(int)\n | Bar\nend\n"
},
{
"path": "test/fail/error_with.sest",
"chars": 144,
"preview": "module ErrorWith = struct\n\n module Impl = struct\n type t = int\n end\n\n module Api = Impl :> (sig\n type t\n end w"
},
{
"path": "test/fail/recursive.sest",
"chars": 631,
"preview": "module Recursive = struct\n\n signature E = sig end\n\n signature X = sig\n signature A = sig end\n /* In OCaml one "
},
{
"path": "test/pass/adt.sest",
"chars": 933,
"preview": "module Adt = struct\n\n val rec foldl(f, i, l) =\n case l of\n | [] -> i\n | x :: xs -> foldl(f, f(i, x), xs)\n"
},
{
"path": "test/pass/arith.sest",
"chars": 209,
"preview": "module Arith = struct\n\n val main(_) =\n let 13 = 3 * 4 + 1 in\n let 13 = 1 + 3 * 4 in\n let 1 = 4 / 2 / 2 in\n "
},
{
"path": "test/pass/coercion.sest",
"chars": 357,
"preview": "module Coercion = struct\n module Sub = struct\n module Impl = struct\n val rec aux(acc, n, x) =\n if n <= 0"
},
{
"path": "test/pass/coercion2.sest",
"chars": 267,
"preview": "module Coercion2 :> sig\n val apply<$a, $b> : fun(fun($a) -> $b, $a) -> $b\n val apply2 : fun(fun(int) -> bool, int) -> "
},
{
"path": "test/pass/ctor.sest",
"chars": 583,
"preview": "module Ctor = struct\n\n module Sub = struct\n type t =\n | Foo\n | Bar(int)\n end\n\n val to_int(x) =\n case "
},
{
"path": "test/pass/ctor_attr.sest",
"chars": 275,
"preview": "module CtorAttr = struct\n\n type t =\n | #[atom(\"bar\")] Foo(int)\n\n val f(n) =\n Foo(n)\n\n val main<$a> : $a = exter"
},
{
"path": "test/pass/ffi.sest",
"chars": 525,
"preview": "module Ffi = struct\n\n type option<$a> =\n | None\n | Some($a)\n\n val assoc<$a> : fun(int, list<{int, $a}>) -> optio"
},
{
"path": "test/pass/first.sest",
"chars": 204,
"preview": "module First = struct\n\n val rec foldn(f, i, c) =\n if i <= 0 then c else\n foldn(f, i - 1, f(i, c))\n\n val main(_"
},
{
"path": "test/pass/functor.sest",
"chars": 563,
"preview": "module Functor = struct\n\n val n() = 42\n\n signature S = sig\n type t :: o\n val zero : fun() -> t\n end\n\n module F"
},
{
"path": "test/pass/functor2.sest",
"chars": 340,
"preview": "module Functor2 = struct\n\n signature S = sig\n type t :: o\n val zero : fun() -> t\n end\n\n module F = fun(X : S) -"
},
{
"path": "test/pass/functor3.sest",
"chars": 629,
"preview": "module Functor3 = struct\n\n signature S = sig\n type t :: o\n val zero : fun() -> t\n end\n\n signature T = sig\n m"
},
{
"path": "test/pass/inference.sest",
"chars": 167,
"preview": "module Inference = struct\n\n val f<?$a :: (foo)>(r : {foo : int, ?$a}, x) =\n {x.foo, if true then x else r}\n\n val ma"
},
{
"path": "test/pass/kind.sest",
"chars": 198,
"preview": "module Kind = struct\n\n module Impl = struct\n type t = {foo : int, bar : bool}\n val v() = {foo = 42, bar = true}\n "
},
{
"path": "test/pass/kinded_parameter.sest",
"chars": 277,
"preview": "module KindedParameter = struct\n/* (not supported yet)\n type t<?$r :: (foo)> =\n | HasFoo({foo : int, ?$r})\n\n val f("
},
{
"path": "test/pass/mandatory_parameter.sest",
"chars": 545,
"preview": "module MandatoryParameter = struct\n\n module Impl = struct\n val rec foldl(-f f, -init init, -list xs) =\n case xs"
},
{
"path": "test/pass/mod.sest",
"chars": 606,
"preview": "module Mod = struct\n\n signature Ord = sig\n type s :: o\n val compare : fun(s, s) -> int\n end\n\n module Map = fun("
},
{
"path": "test/pass/mod2.sest",
"chars": 238,
"preview": "module Mod2 = struct\n\n module Counter = struct\n type t = int\n val initial() : t = 0\n val increment(c : t) : t "
},
{
"path": "test/pass/mod3.sest",
"chars": 416,
"preview": "module Mod3 = struct\n\n module List = struct\n type t<$a> = list<$a>\n\n val empty<$b>() : t<$b> =\n []\n\n val "
},
{
"path": "test/pass/mod_seq.sest",
"chars": 845,
"preview": "module ModSeq = struct\n\n type option<$a> =\n | None\n | Some($a)\n\n signature Decomposable = sig\n type s :: (o) "
},
{
"path": "test/pass/mod_stack.sest",
"chars": 334,
"preview": "module ModStack = struct\n\n type option<$a> =\n | None\n | Some($a)\n\n module Stack = struct\n\n type t<$a> = list<"
},
{
"path": "test/pass/mutrec.sest",
"chars": 271,
"preview": "module Mutrec = struct\n\n val main(_) =\n let\n rec odd(n) =\n let _ = print_debug(n) in\n even(n - 1)"
},
{
"path": "test/pass/mutrec2.sest",
"chars": 226,
"preview": "module Mutrec2 = struct\n\n val rec odd(n) =\n let _ = print_debug(n) in\n even(n - 1)\n\n and even(n) =\n let _ = p"
},
{
"path": "test/pass/optional_parameter.sest",
"chars": 627,
"preview": "module OptionalParameter = struct\n\n val pure_succ(n) = n + 1\n\n val succ(n : int, ?diff dopt : option<int>) =\n case "
},
{
"path": "test/pass/optional_parameter2.sest",
"chars": 702,
"preview": "module OptionalParameter2 = struct\n\n module Impl = struct\n val f1(g) = {g(42), g(42, ?foo 57)}\n val f2(g) = f1(g)"
},
{
"path": "test/pass/optional_parameter_unify.sest",
"chars": 418,
"preview": "module OptionalParameterUnify = struct\n\n val f1(g) = g(?foo 42)\n\n val f2(g) = g(?foo 42, ?bar true)\n\n val f(flag, g) "
},
{
"path": "test/pass/poly.sest",
"chars": 438,
"preview": "module Poly = struct\n\n val rec foldl(f, i, l) =\n case l of\n | [] -> i\n | x :: xs -> foldl(f, f(i, x), xs)"
},
{
"path": "test/pass/record_test.sest",
"chars": 454,
"preview": "module RecordTest = struct\n\n val get_foo(x) = x.foo\n\n val update_bar(x) = { x | bar = false }\n\n val add_foo_and_bar(x"
},
{
"path": "test/pass/record_test2.sest",
"chars": 382,
"preview": "module RecordTest2 = struct\n\n module Impl = struct\n val record() = { foo = 42, bar = true }\n val get_foo(x) = x.f"
},
{
"path": "test/pass/sample_project/.gitignore",
"chars": 27,
"preview": "_build/\n_doc/\nrebar.config\n"
},
{
"path": "test/pass/sample_project/sample_project.sest",
"chars": 3225,
"preview": "module SampleProject = struct\n open Stdlib\n\n module Server :> sig\n type proc\n type error = GenServer.start_link_"
},
{
"path": "test/pass/sample_project/sesterl.yaml",
"chars": 488,
"preview": "package: sample_project\nsource_directories:\n - \"./\"\n\nmain_module: \"SampleProject\"\n\ndocument_outputs:\n - format:\n "
},
{
"path": "test/pass/sample_sup_usage/sample_sup_usage.sest",
"chars": 2189,
"preview": "module SampleSupUsage = struct\n open Stdlib\n\n module G = GenServer\n module S = Supervisor.Static\n\n module Sup :> sig"
},
{
"path": "test/pass/sample_sup_usage/sesterl.yaml",
"chars": 293,
"preview": "package: sample_sup_usage\nsource_directories:\n - \"./\"\n\nmain_module: \"SampleSupUsage\"\n\ndependencies:\n - name: \"stdlib\"\n"
},
{
"path": "test/pass/sample_test_dep/rebar.config",
"chars": 425,
"preview": "{plugins, [{rebar_sesterl, {git, \"https://github.com/gfngfn/rebar_sesterl_plugin.git\", {branch, \"master\"}}}]}.\n{src_dirs"
},
{
"path": "test/pass/sample_test_dep/sesterl.yaml",
"chars": 308,
"preview": "package: \"sesterl_stdlib\"\n\nsource_directories:\n - \"./src\"\n\ntest_directories:\n - \"./test\"\n\nmain_module: \"Main\"\n\ntest_de"
},
{
"path": "test/pass/sample_test_dep/src/Main.sest",
"chars": 85,
"preview": "module Main :> sig\n val f : fun() -> int\nend = struct\n\n val f() =\n 42 + 57\n\nend\n"
},
{
"path": "test/pass/sample_test_dep/test/MainTest.sest",
"chars": 209,
"preview": "import Main\n\nmodule MainTest = #[test] struct\n\n #[test]\n val f_test() =\n Testing.it(\"equal to 99\", fun() ->\n a"
},
{
"path": "test/pass/send.sest",
"chars": 1360,
"preview": "module Send = struct\n\n type bintree<$a> =\n | Node($a, bintree<$a>, bintree<$a>)\n | Empty\n\n val bintree_of_int(n "
},
{
"path": "test/pass/send2.sest",
"chars": 877,
"preview": "module Send2 = struct\n\n val some_heavy_calculation(n) =\n n\n\n val rec wait_all(msgacc, n) = act\n if n <= 0 then\n "
},
{
"path": "test/pass/test_after.sest",
"chars": 444,
"preview": "module TestAfter = struct\n\n module Sub :> sig\n val wait<$a> : fun(int) -> [$a]bool\n end = struct\n\n val wait(time"
},
{
"path": "test/pass/test_binary.sest",
"chars": 867,
"preview": "module TestBinary = struct\n\n val check : fun({binary, binary, binary, binary, binary}) -> {binary, binary, binary, bina"
},
{
"path": "test/pass/test_binary_pattern.sest",
"chars": 224,
"preview": "module TestBinaryPattern = struct\n\n val check(s) =\n case s of\n | \"one\" -> Some(1)\n | \"two\" -> Some(2)\n | _ "
},
{
"path": "test/pass/test_first_class_module.sest",
"chars": 279,
"preview": "module TestFirstClassModule = struct\n module Sub = struct\n type t = int\n val compare(n1, n2) = n2 - n1\n end\n\n s"
},
{
"path": "test/pass/test_first_class_module2.sest",
"chars": 201,
"preview": "module TestFirstClassModule2 :> sig\n signature Ord = sig\n type t\n val compare : fun(t, t) -> int\n end\nend = stru"
},
{
"path": "test/pass/test_float.sest",
"chars": 106,
"preview": "module TestFloat = struct\n\n val add(x, y) = x +. y\n\n val main(_) =\n print_debug(add(42.57, 1.))\n\nend\n"
},
{
"path": "test/pass/test_format.sest",
"chars": 517,
"preview": "module TestFormat = struct\n\n val f1() = f'Hello, ~s!'\n val f2() = f'~~ Hello, ~p and ~p! ~~'\n val f3() = f'repeat: ~1"
},
{
"path": "test/pass/test_freeze.sest",
"chars": 1170,
"preview": "module TestFreeze = struct\n\n module Sub = struct\n val add_pure(x, y) =\n x + y\n\n val add(x, y) = act\n re"
},
{
"path": "test/pass/test_import/import_depended.sest",
"chars": 65,
"preview": "module ImportDepended = struct\n\n val hello() =\n \"Hello\"\n\nend\n"
},
{
"path": "test/pass/test_import/import_depending.sest",
"chars": 117,
"preview": "import ImportDepended\n\nmodule ImportDepending = struct\n\n val main(_) =\n print_debug(ImportDepended.hello())\n\nend\n"
},
{
"path": "test/pass/test_import/sesterl.yaml",
"chars": 82,
"preview": "package: test_import\nsource_directories:\n - \"./\"\n\nmain_module: \"ImportDepending\"\n"
},
{
"path": "test/pass/test_poly_rec.sest",
"chars": 145,
"preview": "module TestPolyRec = struct\n\n val rec pair<$a>(x : $a) : {$a, $a} =\n {x, x}\n\n and trues() =\n pair(true)\n\n and o"
},
{
"path": "test/pass/test_public_type.sest",
"chars": 298,
"preview": "module TestPublicType = struct\n/*\n signature S = sig\n type t\n type u = t\n end\n*/\n signature T = sig\n type u\n"
},
{
"path": "test/pass/test_result.sest",
"chars": 213,
"preview": "module TestResult = struct\n\n val f(res) =\n case res of\n | Ok(n) -> n\n | Error({a, b}) -> a + b\n end"
},
{
"path": "test/pass/test_string.sest",
"chars": 451,
"preview": "module TestString = struct\n\n val phrase() =\n 'Hello World!'\n\n val chop_first(s) =\n case s of\n | [] ->"
},
{
"path": "test/pass/test_testing.sest",
"chars": 113,
"preview": "module TestTesting = #[test] struct\n\n val sub(x, y) =\n x == y\n\n #[test]\n val main() =\n sub(42, 42)\n\nend\n"
},
{
"path": "test/pass/test_type.sest",
"chars": 483,
"preview": "module TestType = struct\n\n type t_a =\n t_b\n\n and t_b =\n t_c\n\n and t_c =\n int\n\n type position<$num> =\n { "
},
{
"path": "test/pass/test_with.sest",
"chars": 669,
"preview": "module TestWith = struct\n\n module Impl1 = struct\n type t = int\n end\n\n module Api1 = Impl1 :> (sig\n type t\n end"
},
{
"path": "test/pass/variant.sest",
"chars": 135,
"preview": "module Variant :> sig\n\n type foo<$a> =\n | Foo(int)\n | Bar($a)\n\nend = struct\n\n type foo<$a> =\n | Foo(int)\n "
},
{
"path": "test/rebar_test/.gitignore",
"chars": 26,
"preview": "_build/\n_generated/\n_gen/\n"
},
{
"path": "test/rebar_test/README.md",
"chars": 183,
"preview": "\n## How to compile\n\nFirst, generate `rebar.config`:\n\n```console\n$ sesterl config ./\n```\n\nThen, run rebar3 with a plugin "
},
{
"path": "test/rebar_test/rebar.config",
"chars": 265,
"preview": "{plugins, [{rebar_sesterl, {git, \"https://github.com/gfngfn/rebar_sesterl_plugin.git\", {branch, \"master\"}}}]}.\n{src_dirs"
},
{
"path": "test/rebar_test/sesterl.yaml",
"chars": 330,
"preview": "package: \"foo_rebar_test\"\nsource_directories:\n - \"./src\"\n\ndependencies: []\n\nmain_module: \"Foo\"\n\nerlang:\n output_direct"
},
{
"path": "test/rebar_test/src/foo.app.src",
"chars": 137,
"preview": "{application, foo, [\n {description, \"foo for rebar3 plugin test\"},\n {vsn, \"0.0.1\"},\n {applications, [\n kernel,\n "
},
{
"path": "test/rebar_test/src/foo.sest",
"chars": 199,
"preview": "module Foo = struct\n\n val fact(n) =\n let rec aux(acc, n) =\n if n <= 0 then acc else aux(n * acc, n - 1)\n in\n"
},
{
"path": "test/testIdentifierScheme.ml",
"chars": 4222,
"preview": "\nmodule SnakeCase = struct\n\n type t = {\n message : string;\n input : string;\n expects : (string list) option;"
},
{
"path": "test/testLanguageVersion.ml",
"chars": 1308,
"preview": "\ntype test_case = {\n before : string;\n after : string;\n expects : bool;\n}\n\n\nlet test_is_compatible (r : test_case)"
},
{
"path": "test/testRange.ml",
"chars": 268,
"preview": "\nlet test_pp_dummy () =\n let rng = Range.dummy \"foo\" in\n Alcotest.(check string) \"same string\" \"(foo)\" (Format.asprint"
},
{
"path": "test/testTypechecker.ml",
"chars": 2987,
"preview": "\nopen Syntax\n\n\nmodule rec MonoTypeVarUpdatable : sig\n type t = mono_type_var_updatable\n val pp : Format.formatter -> t"
}
]
About this extraction
This page contains the full source code of the gfngfn/Sesterl GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 193 files (520.6 KB), approximately 158.0k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.