CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-20 00:41:05 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into jemsab_4b

Browse Source
This commit is contained in:
Denis Merigoux 2021-09-28 11:52:09 +02:00
commit caf42f3445
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
515 changed files with 48502 additions and 12416 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored Normal file
View File

@ -0,0 +1,6 @@
*.catala* linguist-language=Markdown
french_law/js/french_law.js binary
french_law/ocaml/law_source/allocations_familiales.ml binary
french_law/ocaml/law_source/unit_tests/tests_allocations_famiales.ml binary
french_law/python/src/allocations_familiales.py binary
compiler/surface/lexer*.cppo.ml text encoding=latin-1

78
.github/workflows/build.yml vendored
View File

@ -6,9 +6,9 @@ name: CI
# events but only for the master branch
on:
push:
branches: [ master ]
branches: [master]
pull_request:
branches: [ master ]
branches: [master]
# A workflow run is made up of one or more jobs that can run sequentially or in parallel
jobs:
@ -19,47 +19,41 @@ jobs:
# Steps represent a sequence of tasks that will be executed as part of the job
steps:
# Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it
- uses: actions/checkout@v2
# Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it
- uses: actions/checkout@v2
- name: Opam modules cache
uses: actions/cache@v1
env:
cache-name: cache-opam-modules
with:
# OCaml cache files are stored in `~/.opam` on Linux/macOS
path: ~/.opam
key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('catala.opam', 'legifrance_catala.opam') }}
restore-keys: |
${{ runner.os }}-build-${{ env.cache-name }}-
${{ runner.os }}-build-
${{ runner.os }}-
- name: Opam modules cache
uses: actions/cache@v1
env:
cache-name: cache-opam-modules
with:
# OCaml cache files are stored in `~/.opam` on Linux/macOS
path: ~/.opam
key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('catala.opam', 'Makefile') }}
restore-keys: |
${{ runner.os }}-build-${{ env.cache-name }}-
${{ runner.os }}-build-
${{ runner.os }}-
- name: Set up OCaml
uses: avsm/setup-ocaml@v1.1.3
with:
# Version of the OCaml compiler to initialise
ocaml-version: 4.09.1
- name: Set up OCaml
uses: avsm/setup-ocaml@v1
with:
# Version of the OCaml compiler to initialise
ocaml-version: 4.11.0
- name: Install dependencies
run: |
eval $(opam env)
make dependencies
sudo apt update
sudo apt install python3-dev python3-setuptools man2html rsync colordiff
sudo python3 -m pip install --upgrade pip
sudo python3 -m pip install virtualenv
- name: Install dependencies
run: |
eval $(opam env)
make dependencies
sudo apt update
sudo apt install python3-dev python3-setuptools man2html rsync colordiff libmpc-dev
sudo python3 -m pip install --upgrade pip
sudo python3 -m pip install virtualenv
sudo make pygments
./french_law/python/setup_env.sh
- name: Make compiler
run: |
eval $(opam env)
make build
- name: Run tests
run: |
eval $(opam env)
make tests
- name: Make assets and documentation
run: |
eval $(opam env)
make website-assets doc
- name: Make all
run: |
eval $(opam env)
export OCAMLRUNPARAM=b
make all

3
.gitignore vendored
View File

@ -1,6 +1,7 @@
_build/
_opam/
*.install
src/**/.merlin
compiler/**/.merlin
legifrance_oauth*
*.html
.vscode/

17
.gitmodules vendored
View File

@ -1,17 +0,0 @@
[submodule "syntax_highlighting/fr/pygments/pygments"]
path = syntax_highlighting/fr/pygments/pygments
url = https://github.com/pygments/pygments.git
branch = master
ignore = dirty
[submodule "syntax_highlighting/en/pygments/pygments"]
path = syntax_highlighting/en/pygments/pygments
url = https://github.com/pygments/pygments.git
branch = master
ignore = dirty
[submodule "syntax_highlighting/nv/pygments/pygments"]
path = syntax_highlighting/nv/pygments/pygments
url = https://github.com/pygments/pygments.git
branch = master
ignore = dirty

1
.ocamlformat
View File

@ -3,3 +3,4 @@ margin = 100
exp-grouping = preserve
wrap-comments
parse-docstrings
version=0.19.0

151
CONTRIBUTING.md
View File

@ -1,106 +1,163 @@
# Contributing to Catala
The project is open to external contributions, in the spirit of open source.
The project is open to external contributions, in the spirit of open source.
If you want to open a pull request, please follow the instructions below.
To ask a question to the Catala team, please open an issue on this repository.
You can also join the [Zulip chat](https://zulip.catala-lang.org/) to ask
To ask a question to the Catala team, please open an issue on this repository.
You can also join the [Zulip chat](https://zulip.catala-lang.org/) to ask
any questions about the project.
If you want to contribute to the project on a longer-term basis, or if you have
specific competences as a socio-fiscal lawyer or a programming language specialist,
If you want to contribute to the project on a longer-term basis, or if you have
specific competences as a socio-fiscal lawyer or a programming language specialist,
please [contact the authors](mailto:contact@catala-lang.org).
The Catala team meets over visioconference once every two weeks.
Please note that the copyright of this code is owned by Inria;
by contributing, you disclaim all copyright interests in favor of Inria.
Both the code for the compiler and the examples in this repository are
by contributing, you disclaim all copyright interests in favor of Inria.
Both the code for the compiler and the examples in this repository are
distributed under the Apache2 license.
### Writing Catala code
Before writing Catala code, please read the
[tutorial](https://catala-lang.org/en/examples/tutorial). You can run the
programs of the tutorial yourself by following the instruction in the
[README of the `examples` directory](examples/README.md). Then, it is suggested
that you create a new example directory again according to the instructions of
Before writing Catala code, please read the
[tutorial](https://catala-lang.org/en/examples/tutorial). You can run the
programs of the tutorial yourself by following the instruction in the
[README of the `examples` directory](examples/README.md). Then, it is suggested
that you create a new example directory again according to the instructions of
this README.
Let us now present the typical Catala workflow. First, you need to locate
the legislative text that you want to use as a reference. Then, simply
the legislative text that you want to use as a reference. Then, simply
copy-paste the text into your source file.
First you will have to format the copy-pasted text using Catala headings
First you will have to format the copy-pasted text using Catala headings
and articles markers:
```
@@Heading@@
```markdown
## Heading
@@Sub-heading (the more +, the less important)@@++
### Sub-heading (the more '#', the less important)
@Legislative atom@
#### Legislative atom
```
Please look at the code of other examples to see how to format things properly.
While formatting the text, don't forget regularly to try and parse your example
Please look at the code of other examples to see how to format things properly.
While formatting the text, don't forget regularly to try and parse your example
using for instance
```
make -C examples/foo foo.tex
```
to see if you've made any syntax errors. Once the text formatting is done, you
can start to annotate each legislative atom (article, provision, etc.) with
to see if you've made any syntax errors. Once the text formatting is done, you
can start to annotate each legislative atom (article, provision, etc.) with
some Catala code. To open up a code section in Catala, simply use
```
/*
````markdown
```catala
# In code sections, comments start with #
scope Foo:
<your code goes here>
*/
```
````
While all the code sections are equivalent in terms of execution, you can
mark some as "metadata" so that they are printed differently on lawyer-facing
While all the code sections are equivalent in terms of execution, you can
mark some as "metadata" so that they are printed differently on lawyer-facing
documents. Here's how it works:
```
@@Begin metadata@@ # @@Début métadonnées@@ en français
/*
````markdown
> Begin metadata # > Début métadonnées en français
```catala
declaration structure FooBar:
data foo content boolean
data bar content money
<your structure/enumeration/scope declarations goes here>
*/
@@End metadata@@ # @@Fin métadonnées@@ en français
```
Again, make sure to regularly check that your example is parsing correctly. The error message from the compiler should help you debug the syntax if need be. You can also
> End metadata # > Fin métadonnées en français
````
Again, make sure to regularly check that your example is parsing correctly. The error message from the compiler should help you debug the syntax if need be. You can also
live-test the programs you wrote by feeding them to the interpreter
(see the [README of the `examples` directory](examples/README.md)); this will
(see the [README of the `examples` directory](examples/README.md)); this will
also type-check the programs, which is useful for debugging them.
## Working on the compiler
The Catala compiler is a standard dune-managed OCaml project.
You can look at the
[online OCaml documentation](https://catala-lang.org/ocaml_docs/) for the
The Catala compiler is a standard dune-managed OCaml project.
You can look at the
[online OCaml documentation](https://catala-lang.org/ocaml_docs/) for the
different modules' interfaces as well as high-level architecture documentation.
Please note that the `ocamlformat` version this project uses is `0.18.0`.
Using another version may cause spurious diffs to appear in your pull requests.
### Example: adding a builtin function
The language provides a limited number of builtin functions, which are sometimes
needed for things that can't easily be expressed in Catala itself; in case you
need more, here is how one can be added:
- Choose a name wisely. Be ready to patch any code that already used the name
for scope parameters, variables or structure fields, since it won't compile
anymore.
- Add an element to the `builtin_expression` type in `surface/ast.ml(i)`
- Add your builtin in the `builtins` list in `surface/lexer.cppo.ml`, and with
proper translations in all of the language-specific modules
`surface/lexer_en.cppo.ml`, `surface/lexer_fr.cppo.ml`, etc. Don't forget the
macro at the beginning of `lexer.cppo.ml`.
- The rest can all be done by following the type errors downstream:
- Add a corresponding element to the lower-level AST in `dcalc/ast.ml(i)`, type `unop`
- Extend the translation accordingly in `surface/desugaring.ml`
- Extend the printer (`dcalc/print.ml`) and the typer with correct type
information (`dcalc/typing.ml`)
- Finally, provide the implementations:
- in `lcalc/to_ocaml.ml`, function `format_unop`
- in `dcalc/interpreter.ml`, function `evaluate_operator`
- Update the syntax guide in `doc/syntax/syntax.tex` with your new builtin
## Internationalization
The Catala language should be adapted to any legislative text that follows a
general-to-specifics statutes order. Therefore, there exists multiple versions
The Catala language should be adapted to any legislative text that follows a
general-to-specifics statutes order. Therefore, there exists multiple versions
of the Catala surface syntax, adapted to the language of the legislative text.
Currently, Catala supports English and French legislative text via the
`--language=en` or `--language=fr` option.
Currently, Catala supports English, French and Polish legislative text via the
`--language=en`, `--language=fr` or `--language=pl` options.
Technically, support for new languages can be added via a new lexer. If you want
to add a new language, you can start from
[existing lexer examples](src/catala/catala_surface/lexer_fr.ml), tweak and open
a pull request. If you don't feel familiar enough with OCaml to do so, please
leave an issue on this repository.
To add support for a new language:
- the basic syntax localisation is defined in
`compiler/surface/lexer_xx.cppo.ml` where `xx` is the language code (`en`,
`fr`...)
- copy the files from another language, e.g.
[english](compiler/surface/lexer_en.cppo.ml), then replace the strings with your
translations. Be careful with the following:
- The file must be encoded in latin-1
- For a given token `FOO`, define `MS_FOO` to be the string version of the
keyword. Due to the encoding, use `\xNN` [escape
sequences](https://ocaml.org/manual/lex.html#escape-sequence) for utf8
characters.
- If the string contains spaces or non-latin1 characters, you need to define
`MR_FOO` as well with a regular expression in [sedlex
format](https://github.com/ocaml-community/sedlex#lexer-specifications).
Replace spaces with `", space_plus, "`, and unicode characters with `",
0xNNNN, "` where `NNNN` is the hexadecimal unicode codepoint.
**Hint:** You may get syntax errors with unhelpful locations because of
`sedlex`. In that case the command `ocamlc
_build/default/compiler/surface/lexer_xx.ml` may point you to the source of the
error.
- add your translation to the compilation rules:
- in `compiler/surface/dune`, copying another `parser_xx.cppo.ml` rule
- in the `extensions` list in `compiler/driver.ml`
- add a corresponding variant to `compiler/utils/cli.ml` `backend_lang`, try
to run `make build` and follow all type errors and `match non exhaustive`
warnings to be sure it is well handled everywhere.
- you may want to add syntax highlighting support, see `syntax_highlighting/`
and the rules in `Makefile`
- add examples and documentation!
Feel free to open a pull request for discussion even if you couldn't go through
all these steps, the `lexer_xx.cppo.ml` file is the important part.

13
Dockerfile Normal file
View File

@ -0,0 +1,13 @@
FROM ocaml/opam:ubuntu-lts-ocaml-4.12
RUN sudo apt-get update && sudo apt-get install -y \
man2html \
colordiff \
latexmk \
python3 \
python3-pip \
libgmp-dev \
npm \
nodejs
RUN sudo pip3 install virtualenv

75
INSTALL.md
View File

@ -2,25 +2,44 @@
## Requirements
### With Docker
The Catala compiler is written using OCaml. The repository provides a `Dockerfile`
to build a Docker image with all the dependencies required to build the Catala compiler.
Start by installing Docker: https://docs.docker.com/get-docker/
Then build the Docker image:
docker build . -t catala
Finally, start a `bash` shell inside a new container created from the newly built image:
docker run -it -v $PWD:$PWD -w $PWD --name catala catala bash
### Without Docker
The Catala compiler is written using OCaml. First, you have to install `opam`,
OCaml's distribution and package manager. Follow the [instructions on the `opam`
website](https://opam.ocaml.org/doc/Install.html).
website](https://opam.ocaml.org/doc/Install.html).
Next, you will need to use the correct version of OCaml. Catala has been tested
with OCaml compiler versions that are at least 4.09.1. To switch to OCaml 4.09.1.,
Next, you will need to use the correct version of OCaml. Catala has been tested
with OCaml compiler versions that are at least 4.12.0. To switch to OCaml 4.12.0.,
just use:
opam switch 4.09.1
opam switch 4.12.0
If you get a `No switch 4.09.1 is currently installed` error message, follow
the hint and enter `opam switch create 4.09.1`.
If you get a `No switch 4.12.0 is currently installed` error message, follow
the hint and enter `opam switch create 4.12.0`.
Next, install all the OCaml packages that Catala depend on, as well as some
## Dependencies
Next, install all the OCaml packages that Catala depend on, as well as some
git submodules, with
make dependencies
This should ensure everything is set up for developping on the Catala compiler!
This should ensure everything is set up for developing on the Catala compiler!
Other features for generation of files and literate programming also require
the following executables to be present
@ -49,24 +68,24 @@ builds the compiler from its OCaml sources.
## Install
The installation of the Catala compiler is handled through `opam`. Since the
Catala compiler is not yet published to the `opam` repository, you can install
a local version from this Git repository by using
The installation of the Catala compiler is handled through `opam`. Since the
Catala compiler is not yet published to the `opam` repository, you can install
a local version from this Git repository by using
opam install ./
To uninstall, use
To uninstall, use
opam unpin catala
### Generating website assets
The Catala website features assets generated by the Catala compiler. They are
needed to build the website. To produce them, simply run
needed to build the website. To produce them, simply run
make website-assets
Then, use a helper script to copy them over to the `assets` directory of the
Then, use a helper script to copy them over to the `assets` directory of the
Catala website.
./generate_website_assets.sh <path-to-catala-website>/assets
@ -90,6 +109,7 @@ To get Catala syntax highlighting in Atom, simply enter from
the root of the repository, depending on the language you want to use :
make atom_fr
or
make atom_en
@ -102,38 +122,25 @@ To get Catala syntax highlighting in VSCode, simply enter from
the root of the repository, depending on the language you want to use :
make vscode_fr
or
make vscode_en
You can now reload VSCode and check that you have syntax highlighting on any `.catala` file.
### Pygments
Pygments is a Python-based versatile lexer for various
programming languages. To use a version of Pygments
augmented with the Catala plugin, simply enter
make pygments
sudo make pygments
This will execute the
script `syntax_highlighting/fr/pygments/set_up_pygments.sh` and
script `syntax_highlighting/fr/pygments/set_up_pygments.sh`,
`syntax_highlighting/pl/pygments/set_up_pygments.sh` and
`syntax_highlighting/en/pygments/set_up_pygments.sh`.
The scripts set up a virtual environement in
`syntax_highlighting/fr/pygments/pygments/env` or
`syntax_highlighting/en/pygments/pygments/env`, which will
contain the modified version of Pygments that has Catala
support. If you want to hack something, it is possible to use this virtual
environnement directly with
source syntax_highlighting/fr/pygments/pygments/env/bin/activate
or
source syntax_highlighting/en/pygments/pygments/env/bin/activate
The `pigmentize` executable, used for instance by the `minted` LaTeX package,
will now point to the Catala-enabled version inside the virtual environment.
This `source` setup is not necessary if you use the rules in the `Makefile`.
The scripts patch your `pigmentize` executable, used for instance by the `minted` LaTeX package.
It will now point to the Catala-enabled version with the appropriate `catala_*` lexer.

214
Makefile
View File

@ -1,42 +1,59 @@
default: build
help : Makefile
@sed -n 's/^#> //p' $<
ROOT_DIR:=$(shell dirname $(realpath $(firstword $(MAKEFILE_LIST))))
# Export all variables to sub-make
export
##########################################
# Dependencies
##########################################
EXECUTABLES = man2html virtualenv python3 colordiff
EXECUTABLES = man2html virtualenv python3 colordiff node
K := $(foreach exec,$(EXECUTABLES),\
$(if $(shell which $(exec)),some string,$(warning [WARNING] No "$(exec)" executable found. \
Please install this executable for everything to work smoothly)))
# The Zarith dependency is fixed because of https://github.com/janestreet/zarith_stubs_js/pull/8
dependencies-ocaml:
opam install \
ocamlformat ANSITerminal sedlex menhir menhirLib dune cmdliner obelisk \
re obelisk unionfind bindlib zarith zarith_stubs_js ocamlgraph \
js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx calendar camomile
re obelisk unionfind bindlib zarith.1.11 zarith_stubs_js.v0.14.0 ocamlgraph \
js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx calendar camomile \
visitors benchmark cppo odoc
dependencies-js:
$(MAKE) -C $(FRENCH_LAW_JS_LIB_DIR) dependencies
init-submodules:
git submodule update --init
dependencies: dependencies-ocaml init-submodules
#> dependencies : Install the Catala OCaml, JS and Git dependencies
dependencies: dependencies-ocaml dependencies-js init-submodules
##########################################
# Catala compiler rules
##########################################
COMPILER_DIR=compiler
format:
dune build @fmt --auto-promote | true
dune build @fmt --auto-promote 2> /dev/null | true
#> build : Builds the Catala compiler
build:
@$(MAKE) --no-print-directory -C src/catala/catala_surface parser_errors.ml
dune build @update-parser-messages --auto-promote | true
@$(MAKE) --no-print-directory format
dune build src/catala.exe
dune build $(COMPILER_DIR)/catala.exe
#> js_build : Builds the Web-compatible JS version of the Catala compiler
js_build:
dune build src/catala_web/catala_web.bc.js --profile release
dune build $(COMPILER_DIR)/catala_web.bc.js --profile release
doc:
#> doc : Generates the HTML OCaml documentation
doc:
dune build @doc
ln -sf $(PWD)/_build/default/_doc/_html/index.html doc/odoc.html
@ -48,21 +65,23 @@ install:
##########################################
SYNTAX_HIGHLIGHTING_FR=${CURDIR}/syntax_highlighting/fr
PYGMENTS_DIR_FR=$(SYNTAX_HIGHLIGHTING_FR)/pygments
PYGMENTIZE_FR=$(PYGMENTS_DIR_FR)/pygments/env/bin/pygmentize
SYNTAX_HIGHLIGHTING_EN=${CURDIR}/syntax_highlighting/en
PYGMENTS_DIR_EN=$(SYNTAX_HIGHLIGHTING_EN)/pygments
PYGMENTIZE_EN=$(PYGMENTS_DIR_EN)/pygments/env/bin/pygmentize
SYNTAX_HIGHLIGHTING_PL=${CURDIR}/syntax_highlighting/pl
$(PYGMENTIZE_FR): $(SYNTAX_HIGHLIGHTING_FR)/set_up_pygments.sh $(PYGMENTS_DIR_FR)/catala_fr.py
pygmentize_fr: $(SYNTAX_HIGHLIGHTING_FR)/set_up_pygments.sh
chmod +x $<
$<
sudo $<
$(PYGMENTIZE_EN): $(SYNTAX_HIGHLIGHTING_EN)/set_up_pygments.sh $(PYGMENTS_DIR_EN)/catala_en.py
pygmentize_en: $(SYNTAX_HIGHLIGHTING_EN)/set_up_pygments.sh
chmod +x $<
$<
sudo $<
pygments: $(PYGMENTIZE_FR) $(PYGMENTIZE_EN)
pygmentize_pl: $(SYNTAX_HIGHLIGHTING_PL)/set_up_pygments.sh
chmod +x $<
sudo $<
#> pygments : Extends your pygmentize executable with Catala lexers
pygments: pygmentize_fr pygmentize_en pygmentize_pl
atom_fr: ${CURDIR}/syntax_highlighting/fr/setup_atom.sh
chmod +x $<
@ -72,11 +91,12 @@ atom_en: ${CURDIR}/syntax_highlighting/en/setup_atom.sh
chmod +x $<
$<
atom_nv: ${CURDIR}/syntax_highlighting/nv/setup_atom.sh
atom_pl: ${CURDIR}/syntax_highlighting/pl/setup_atom.sh
chmod +x $<
$<
atom: atom_fr atom_en atom_nv
#> atom : Installs Catala syntax highlighting for Atom
atom: atom_fr atom_en atom_pl
vscode_fr: ${CURDIR}/syntax_highlighting/fr/setup_vscode.sh
chmod +x $<
@ -86,14 +106,16 @@ vscode_en: ${CURDIR}/syntax_highlighting/en/setup_vscode.sh
chmod +x $<
$<
vscode_nv: ${CURDIR}/syntax_highlighting/nv/setup_vscode.sh
chmod +x $<
$<
# TODO
# vscode_pl: ${CURDIR}/syntax_highlighting/pl/setup_vscode.sh
# chmod +x $<
# $<
vscode: vscode_fr vscode_en vscode_nv
#> vscode : Installs Catala syntax highlighting for VSCode
vscode: vscode_fr vscode_en
##########################################
# Examples-related rules
# Literate programming and examples
##########################################
EXAMPLES_DIR=examples
@ -102,33 +124,113 @@ CODE_GENERAL_IMPOTS_DIR=$(EXAMPLES_DIR)/code_general_impots
US_TAX_CODE_DIR=$(EXAMPLES_DIR)/us_tax_code
TUTORIAL_EN_DIR=$(EXAMPLES_DIR)/tutorial_en
TUTORIEL_FR_DIR=$(EXAMPLES_DIR)/tutoriel_fr
POLISH_TAXES_DIR=$(EXAMPLES_DIR)/polish_taxes
literate_allocations_familiales: pygments build
literate_allocations_familiales: build
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.tex
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.html
literate_code_general_impots: pygments build
literate_code_general_impots: build
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) code_general_impots.tex
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) code_general_impots.html
literate_us_tax_code: pygments build
literate_us_tax_code: build
$(MAKE) -C $(US_TAX_CODE_DIR) us_tax_code.tex
$(MAKE) -C $(US_TAX_CODE_DIR) us_tax_code.html
literate_tutorial_en: pygments build
literate_tutorial_en: build
$(MAKE) -C $(TUTORIAL_EN_DIR) tutorial_en.tex
$(MAKE) -C $(TUTORIAL_EN_DIR) tutorial_en.html
literate_tutoriel_fr: pygments build
literate_tutoriel_fr: build
$(MAKE) -C $(TUTORIEL_FR_DIR) tutoriel_fr.tex
$(MAKE) -C $(TUTORIEL_FR_DIR) tutoriel_fr.html
literate_polish_taxes: build
$(MAKE) -C $(POLISH_TAXES_DIR) polish_taxes.tex
$(MAKE) -C $(POLISH_TAXES_DIR) polish_taxes.html
#> literate_examples : Builds the .tex and .html versions of the examples code. Needs pygments to be installed and patched with Catala.
literate_examples: literate_allocations_familiales literate_code_general_impots \
literate_us_tax_code literate_tutorial_en literate_tutoriel_fr
literate_us_tax_code literate_tutorial_en literate_tutoriel_fr literate_polish_taxes
##########################################
# Execute test suite
# French law library
##########################################
#-----------------------------------------
# OCaml
#-----------------------------------------
FRENCH_LAW_OCAML_LIB_DIR=french_law/ocaml
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/allocations_familiales.ml: .FORCE
CATALA_OPTS="$(CATALA_OPTS) -O -t" $(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.ml
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/allocations_familiales.ml $@
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/unit_tests/tests_allocations_familiales.ml: .FORCE
CATALA_OPTS="$(CATALA_OPTS) -O -t" $(MAKE) -s -C $(ALLOCATIONS_FAMILIALES_DIR) tests/tests_allocations_familiales.ml
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/tests/tests_allocations_familiales.ml $@
#> generate_french_law_library_ocaml : Generates the French law library OCaml sources from Catala
generate_french_law_library_ocaml:\
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/allocations_familiales.ml \
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/unit_tests/tests_allocations_familiales.ml
$(MAKE) format
#> build_french_law_library_ocaml : Builds the OCaml French law library
build_french_law_library_ocaml: generate_french_law_library_ocaml format
dune build $(FRENCH_LAW_OCAML_LIB_DIR)/api.a
run_french_law_library_benchmark_ocaml: generate_french_law_library_ocaml
dune exec --profile release $(FRENCH_LAW_OCAML_LIB_DIR)/bench.exe
run_french_law_library_ocaml_tests: build_french_law_library_ocaml
dune exec $(FRENCH_LAW_OCAML_LIB_DIR)/law_source/unit_tests/run_tests.exe
#-----------------------------------------
# JS
#-----------------------------------------
FRENCH_LAW_JS_LIB_DIR=french_law/js
run_french_law_library_benchmark_js: build_french_law_library_js
$(MAKE) -C $(FRENCH_LAW_JS_LIB_DIR) bench
#> build_french_law_library_js : Builds the JS version of the OCaml French law library
build_french_law_library_js: generate_french_law_library_ocaml format
dune build --profile release $(FRENCH_LAW_OCAML_LIB_DIR)/api_web.bc.js
cp -f $(ROOT_DIR)/_build/default/$(FRENCH_LAW_OCAML_LIB_DIR)/api_web.bc.js $(FRENCH_LAW_JS_LIB_DIR)/french_law.js
#-----------------------------------------
# Python
#-----------------------------------------
FRENCH_LAW_PYTHON_LIB_DIR=french_law/python
$(FRENCH_LAW_PYTHON_LIB_DIR)/src/allocations_familiales.py: .FORCE
CATALA_OPTS="$(CATALA_OPTS) -O -t" $(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.py
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/allocations_familiales.py $@
#> generate_french_law_library_python : Generates the French law library Python sources from Catala
generate_french_law_library_python:\
$(FRENCH_LAW_PYTHON_LIB_DIR)/src/allocations_familiales.py
. $(FRENCH_LAW_PYTHON_LIB_DIR)/env/bin/activate ;\
$(MAKE) -C $(FRENCH_LAW_PYTHON_LIB_DIR) format
#> type_french_law_library_python : Types the French law library Python sources with mypy
type_french_law_library_python: generate_french_law_library_python
. $(FRENCH_LAW_PYTHON_LIB_DIR)/env/bin/activate ;\
$(MAKE) -C $(FRENCH_LAW_PYTHON_LIB_DIR) type
run_french_law_library_benchmark_python: type_french_law_library_python
. $(FRENCH_LAW_PYTHON_LIB_DIR)/env/bin/activate ;\
$(MAKE) -C $(FRENCH_LAW_PYTHON_LIB_DIR) bench
##########################################
# High-level test and benchmarks commands
##########################################
.FORCE:
@ -136,44 +238,72 @@ literate_examples: literate_allocations_familiales literate_code_general_impots
test_suite: .FORCE
@$(MAKE) --no-print-directory -C tests pass_tests
test_examples: .FORCE
test_examples: .FORCE
@$(MAKE) --no-print-directory -C examples tests
#> tests : Run interpreter tests
tests: test_suite test_examples
#> tests_ocaml : Run OCaml unit tests for the Catala-generated code
tests_ocaml: run_french_law_library_ocaml_tests
#> bench_ocaml : Run OCaml benchmarks for the Catala-generated code
bench_ocaml: run_french_law_library_benchmark_ocaml
#> bench_js : Run JS benchmarks for the Catala-generated code
bench_js: run_french_law_library_benchmark_js
#> bench_python : Run Python benchmarks for the Catala-generated code
bench_python: run_french_law_library_benchmark_python
##########################################
# Website assets
##########################################
grammar.html: src/catala/catala_surface/parser.mly
grammar.html: $(COMPILER_DIR)/surface/parser.mly
obelisk html -o $@ $<
catala.html: src/catala/utils/cli.ml
dune exec src/catala.exe -- --help=groff | man2html | sed -e '1,8d' \
catala.html: $(COMPILER_DIR)/utils/cli.ml
dune exec $(COMPILER_DIR)/catala.exe -- --help=groff | man2html | sed -e '1,8d' \
| tac | sed "1,20d" | tac > $@
website-assets: doc literate_examples grammar.html catala.html js_build
#> website-assets : Builds all the assets necessary for the Catala website
website-assets: doc literate_examples grammar.html catala.html js_build build_french_law_library_js
##########################################
# Misceallenous
##########################################
all: dependencies build doc tests literate_examples website-assets
#> all : Run all make commands
all: \
dependencies build doc website-assets\
tests \
generate_french_law_library_ocaml build_french_law_library_ocaml \
tests_ocaml bench_ocaml \
build_french_law_library_js \
bench_js \
generate_french_law_library_python type_french_law_library_python\
bench_python
#> clean : Clean build artifacts
clean:
dune clean
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) clean
$(MAKE) -C $(US_TAX_CODE_DIR) clean
$(MAKE) -C $(TUTORIEL_FR_DIR) clean
$(MAKE) -C $(TUTORIAL_EN_DIR) clean
$(MAKE) -C $(POLISH_TAXES_DIR) clean
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) clean
inspect:
gitinspector -f ml,mli,mly,iro,tex,catala,catala_en,catala_fr,md,fst,mld --grading
gitinspector -f ml,mli,mly,iro,tex,catala,catala_en,catala_pl,catala_fr,md,fst,mld --grading
##########################################
# Special targets
##########################################
.PHONY: inspect clean all literate_examples english allocations_familiales pygments \
install build doc format dependencies dependencies-ocaml \
catala.html
catala.html help

99
README.md
View File

@ -1,32 +1,30 @@
<center>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/images/logo.png" alt="Catala logo" width="100"/>
</center>
# Catala
# Catala [![Catala chat][chat-image]][chat-link] ![CI][ci-link] ![Opam][opam-link] ![Licence][licence-link] ![Tag][tag-link] ![LoC][loc-link] ![Language][language-link] ![Issues][issues-link] ![Contributors][contributors-link] ![Activity][activity-link]
Catala is a domain-specific language for deriving
faithful-by-construction algorithms from legislative texts. To learn quickly
about the language and its features, you can jump right to the official
about the language and its features, you can jump right to the official
[Catala tutorial](https://catala-lang.org/en/examples/tutorial).
Join the Catala community on Zulip: https://zulip.catala-lang.org/!
You can join the Catala community on [Zulip][chat-link]!
## Concepts
Catala is a programming language adapted for socio-fiscal legislative literate
programming. By annotating each line of the legislative text with its meaning
in terms of code, one can derive an implementation of complex socio-fiscal
mechanisms that enjoys a high level of assurance regarding the code-law
in terms of code, one can derive an implementation of complex socio-fiscal
mechanisms that enjoys a high level of assurance regarding the code-law
faithfulness.
Concretely, you have to first gather all the laws, executive orders, previous
cases, etc. that contain information about the socio-fiscal mechanism that
you want to implement. Then, you can proceed to annotate the text article by
Concretely, you have to first gather all the laws, executive orders, previous
cases, etc. that contain information about the socio-fiscal mechanism that
you want to implement. Then, you can proceed to annotate the text article by
article, in your favorite text editor :
<center>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/images/ScreenShotVSCode.png" alt="Screenshot" height="500"/>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/images/ScreenShotVSCode.png" alt="Screenshot" height="450"/>
</center>
Once your code is complete and tested, you can use the Catala
@ -37,63 +35,92 @@ can be reviewed and certified correct by the domain experts, which
are in this case lawyers and not programmers.
<center>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/images/CatalaScreenShot.png" alt="Screenshot" height="500"/>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/images/CatalaScreenShot.png" alt="Screenshot" height="400"/>
</center>
The Catala language is special because its logical structure mimics
the logical structure of the law. Indeed, the core concept of
"definition-under-conditions" that builds on default logic has been formalized
by Professor of Law Sarah Lawsky in her article
[A Logic for Statutes](https://papers.ssrn.com/sol3/papers.cfm?abstract_id=3088206).
The Catala language is the only programming language to our knowledge that
embeds default logic as a first-class feature, which is why it is the only
"definition-under-conditions" that builds on default logic has been formalized
by Professor Sarah Lawsky in her article
[A Logic for Statutes](https://papers.ssrn.com/sol3/papers.cfm?abstract_id=3088206).
The Catala language is the only programming language to our knowledge that
embeds default logic as a first-class feature, which is why it is the only
language perfectly adapted to literate legislative programming.
## Building and installation
See [the dedicated readme](INSTALL.md).
Catala is available as an [opam package](https://opam.ocaml.org/packages/catala/)!
If opam is installed on your machine, simply execute:
opam install catala
To get the cutting-edge, latest version of Catala, you
can also do
opam pin add catala --dev-repo
However, if you wish to get the latest developments of the compiler, you probably
want to compile it from the sources of this repository. For that, see
[the dedicated readme](INSTALL.md).
## Usage
Use `catala --help` to get more information about the command line
Use `catala --help` to get more information about the command line
options available.
The top-level `Makefile` contains a lot of useful targets to run. To display
them, use
make help
## Examples
See [the dedicated readme](examples/README.md).
To explore the different programs written in Catala, see
[the dedicated readme](examples/README.md).
## API
To know how to use the code generated by the Catala compiler in your favorite
programming language, head to the [readme of the French law library](french_law/README.md)
## Contributing
See [the dedicated readme](CONTRIBUTING.md).
To know how you can contribute to the project, see
[the dedicated readme](CONTRIBUTING.md).
## Test suite
See [the dedicated readme](tests/README.md).
To know how to run or improve the Catala reference test suite,
see [the dedicated readme](tests/README.md).
## Documentation
### Formal semantics
### Formal semantics
See [the dedicated readme](doc/formalization/README.md).
To audit the formal proof of the partial certification of the Catala compiler,
see [the dedicated readme](doc/formalization/README.md).
### Compiler documentation
The compiler documentation is auto-generated from its source code using
`dune` and `odoc`. Use
The compiler documentation is auto-generated from its source code using
`dune` and `odoc`. Use
make doc
to generate the documentation, then open the `doc/odoc.html` file in any browser.
The documentation is also accessible [online](https://catala-lang.org/ocaml_docs/).
## License
The library is released under the [Apache license (version 2)](LICENSE.txt).
The compiler and all the code contained in this repository is released under
the [Apache license (version 2)](LICENSE.txt) unless another license is explicited
for a sub-directory.
## Limitations and disclaimer
Catala is a research project from Inria, the French National
Research Institute for Computer Science. The compiler is yet
unstable and lacks some of its features.
Research Institute for Computer Science. The compiler is yet
unstable and lacks some of its features.
## Pierre Catala
@ -105,3 +132,15 @@ has also influenced the creation by state conselor Lucien Mehl of the
Centre de recherches et développement en informatique juridique (CENIJ),
which eventually transformed into the entity managing the LegiFrance website,
acting as the public service of legislative documentation.
[chat-image]: https://img.shields.io/badge/zulip-join_chat-blue.svg?style=social&logo=zulip&color=5c75a2
[chat-link]: https://zulip.catala-lang.org/
[ci-link]: https://github.com/catalalang/catala/actions/workflows/build.yml/badge.svg
[licence-link]: https://img.shields.io/github/license/catalalang/catala
[tag-link]: https://img.shields.io/github/v/tag/catalalang/catala
[loc-link]: https://img.shields.io/tokei/lines/github/catalalang/catala
[issues-link]: https://img.shields.io/github/issues/catalalang/catala
[opam-link]: https://img.shields.io/badge/Package-opam-orange?logo=OCaml&link=https://opam.ocaml.org/packages/catala/
[language-link]: https://img.shields.io/github/languages/top/catalalang/catala
[contributors-link]: https://img.shields.io/github/contributors/catalalang/catala
[activity-link]: https://img.shields.io/github/commit-activity/m/catalalang/catala

25
catala.opam
View File

@ -1,17 +1,19 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "0.2.0"
synopsis: "Low-level language for tax code specification"
version: "0.4.0"
synopsis:
"Compiler and library for the literate programming language for tax code specification"
description: """
The Catala language is designed to be a low-level target for
higher-level specification languages for fiscal legislation.
Catala is a domain-specific language for deriving faithful-by-construction
algorithms from legislative texts. See https://catala-lang.org for more information
"""
maintainer: ["contact@catala-lang.org"]
authors: ["Denis Merigoux"]
authors: ["Denis Merigoux, Nicolas Chataing"]
license: "Apache-2.0"
homepage: "https://github.com/CatalaLang/catala"
bug-reports: "https://github.com/CatalaLang/catala/issues"
depends: [
"dune" {>= "2.8"}
"ocaml" {>= "4.08.0"}
"ANSITerminal" {>= "0.8.2"}
"sedlex" {>= "2.1"}
@ -21,14 +23,19 @@ depends: [
"bindlib" {>= "5.0.1"}
"cmdliner" {>= "1.0.4"}
"re" {>= "1.9.0"}
"zarith" {>= "1.10"}
"zarith_stubs_js" {>= "0.14.0"}
"dune" {>= "2.2"}
"zarith" {= "1.11"}
"zarith_stubs_js" {= "v0.14.0"}
"ocamlgraph" {>= "1.8.8"}
"calendar" {>= "2.04"}
"visitors" {>= "20200210"}
"benchmark" {>= "1.6"}
"js_of_ocaml-ppx" {>= "3.8.0"}
"camomile" {>= "1.0.2"}
"cppo" {>= "1"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {pinned}
["dune" "subst"] {dev}
[
"dune"
"build"

2
src/catala.ml → compiler/catala.ml
View File

@ -12,4 +12,4 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
let _ = Catala.Driver.main ()
let _ = Driver.main ()

6
src/catala_web/catala_web.ml → compiler/catala_web.ml
View File

@ -1,4 +1,4 @@
open Catala.Driver
open Driver
open Js_of_ocaml
let _ =
@ -8,9 +8,9 @@ let _ =
(language : Js.js_string Js.t) (trace : bool) =
driver
(Contents (Js.to_string contents))
false false false None "Interpret"
false false false "Interpret"
(Some (Js.to_string language))
None trace
None trace false
(Some (Js.to_string scope))
None
end)

89
src/catala/default_calculus/ast.ml → compiler/dcalc/ast.ml
View File

@ -12,8 +12,11 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
module Pos = Utils.Pos
module Uid = Utils.Uid
[@@@ocaml.warning "-7-34"]
open Utils
module ScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
module StructName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
@ -29,46 +32,48 @@ module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info =
module EnumMap : Map.S with type key = EnumName.t = Map.Make (EnumName)
(** Abstract syntax tree for the default calculus *)
(** {1 Abstract syntax tree} *)
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type struct_name = StructName.t
type enum_name = EnumName.t
type typ =
| TLit of typ_lit
| TTuple of typ Pos.marked list * StructName.t option
| TEnum of typ Pos.marked list * EnumName.t
| TTuple of typ Pos.marked list * struct_name option
| TEnum of typ Pos.marked list * enum_name
| TArrow of typ Pos.marked * typ Pos.marked
| TArray of typ Pos.marked
| TAny
type date = CalendarLib.Date.t
type date = Runtime.date
type duration = CalendarLib.Date.Period.t
type duration = Runtime.duration
type integer = Runtime.integer
type decimal = Runtime.decimal
type money = Runtime.money
type lit =
| LBool of bool
| LEmptyError
| LInt of Z.t
| LRat of Q.t
| LMoney of Z.t
| LInt of integer
| LRat of decimal
| LMoney of money
| LUnit
| LDate of date
| LDuration of duration
type op_kind =
| KInt
| KRat
| KMoney
| KDate
| KDuration (** All ops don't have a Kdate and KDuration *)
type op_kind = KInt | KRat | KMoney | KDate | KDuration
type ternop = Fold
type binop =
| And
| Or
| Xor
| Add of op_kind
| Sub of op_kind
| Mult of op_kind
@ -80,15 +85,15 @@ type binop =
| Eq
| Neq
| Map
| Concat
| Filter
type log_entry = VarDef | BeginCall | EndCall
type log_entry = VarDef of typ | BeginCall | EndCall | PosRecordIfTrueBool
type unop =
| Not
| Minus of op_kind
| ErrorOnEmpty
| Log of log_entry * Utils.Uid.MarkedString.info list
| Log of log_entry * (Utils.Uid.MarkedString.info list[@opaque])
| Length
| IntToRat
| GetDay
@ -97,35 +102,28 @@ type unop =
type operator = Ternop of ternop | Binop of binop | Unop of unop
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on
higher-order abstract syntax*)
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of expr Pos.marked list * StructName.t option
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of expr Pos.marked * int * StructName.t option * typ Pos.marked list
(** The [MarkedString.info] is the former struct field name *)
| EInj of expr Pos.marked * int * EnumName.t * typ Pos.marked list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of expr Pos.marked * expr Pos.marked list * EnumName.t
(** The [MarkedString.info] is the former enum case name *)
| EVar of (expr Bindlib.var[@opaque]) Pos.marked
| ETuple of expr Pos.marked list * struct_name option
| ETupleAccess of expr Pos.marked * int * struct_name option * typ Pos.marked list
| EInj of expr Pos.marked * int * enum_name * typ Pos.marked list
| EMatch of expr Pos.marked * expr Pos.marked list * enum_name
| EArray of expr Pos.marked list
| ELit of lit
| EAbs of Pos.t * (expr, expr Pos.marked) Bindlib.mbinder * typ Pos.marked list
| EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAssert of expr Pos.marked
| EOp of operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| ErrorOnEmpty of expr Pos.marked
type struct_ctx = StructFieldName.t list StructMap.t
type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t
type enum_ctx = EnumConstructor.t list EnumMap.t
type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
(** {1 Variable helpers} *)
module Var = struct
type t = expr Bindlib.var
@ -146,7 +144,7 @@ let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box =
let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t)
(taus : typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun b -> (EAbs (pos_binder, b, taus), pos)) (Bindlib.bind_mvar xs e)
Bindlib.box_apply (fun b -> (EAbs ((b, pos_binder), taus), pos)) (Bindlib.bind_mvar xs e)
let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t)
: expr Pos.marked Bindlib.box =
@ -164,4 +162,17 @@ let make_let_in (x : Var.t) (tau : typ Pos.marked) (e1 : expr Pos.marked Bindlib
(Pos.get_position (Bindlib.unbox e2)))
(Bindlib.box_list [ e1 ])
let make_multiple_let_in (xs : Var.t array) (taus : typ Pos.marked list)
(e1 : expr Pos.marked list Bindlib.box) (e2 : expr Pos.marked Bindlib.box) :
expr Pos.marked Bindlib.box =
Bindlib.box_apply2
(fun e u -> (EApp (e, u), Pos.get_position (Bindlib.unbox e2)))
(make_abs xs e2
(Pos.get_position (Bindlib.unbox e2))
taus
(Pos.get_position (Bindlib.unbox e2)))
e1
type binder = (expr, expr Pos.marked) Bindlib.binder
type program = { decl_ctx : decl_ctx; scopes : (ScopeName.t * Var.t * expr Pos.marked) list }

180
compiler/dcalc/ast.mli Normal file
View File

@ -0,0 +1,180 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
module ScopeName : Uid.Id with type info = Uid.MarkedString.info
module StructName : Uid.Id with type info = Uid.MarkedString.info
module StructFieldName : Uid.Id with type info = Uid.MarkedString.info
module StructMap : Map.S with type key = StructName.t
module EnumName : Uid.Id with type info = Uid.MarkedString.info
module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info
module EnumMap : Map.S with type key = EnumName.t
(** Abstract syntax tree for the default calculus *)
(** {1 Abstract syntax tree} *)
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type typ =
| TLit of typ_lit
| TTuple of typ Pos.marked list * StructName.t option
| TEnum of typ Pos.marked list * EnumName.t
| TArrow of typ Pos.marked * typ Pos.marked
| TArray of typ Pos.marked
| TAny
type date = Runtime.date
type duration = Runtime.duration
type lit =
| LBool of bool
| LEmptyError
| LInt of Runtime.integer
| LRat of Runtime.decimal
| LMoney of Runtime.money
| LUnit
| LDate of date
| LDuration of duration
type op_kind =
| KInt
| KRat
| KMoney
| KDate
| KDuration (** All ops don't have a KDate and KDuration. *)
type ternop = Fold
type binop =
| And
| Or
| Xor
| Add of op_kind
| Sub of op_kind
| Mult of op_kind
| Div of op_kind
| Lt of op_kind
| Lte of op_kind
| Gt of op_kind
| Gte of op_kind
| Eq
| Neq
| Map
| Concat
| Filter
type log_entry =
| VarDef of typ
(** During code generation, we need to know the type of the variable being logged for
embedding *)
| BeginCall
| EndCall
| PosRecordIfTrueBool
type unop =
| Not
| Minus of op_kind
| Log of log_entry * Utils.Uid.MarkedString.info list
| Length
| IntToRat
| GetDay
| GetMonth
| GetYear
type operator = Ternop of ternop | Binop of binop | Unop of unop
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on
higher-order abstract syntax*)
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of expr Pos.marked list * StructName.t option
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of expr Pos.marked * int * StructName.t option * typ Pos.marked list
(** The [MarkedString.info] is the former struct field name *)
| EInj of expr Pos.marked * int * EnumName.t * typ Pos.marked list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of expr Pos.marked * expr Pos.marked list * EnumName.t
(** The [MarkedString.info] is the former enum case name *)
| EArray of expr Pos.marked list
| ELit of lit
| EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAssert of expr Pos.marked
| EOp of operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| ErrorOnEmpty of expr Pos.marked
type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
(** {1 Variable helpers} *)
module Var : sig
type t = expr Bindlib.var
val make : string Pos.marked -> t
val compare : t -> t -> int
end
module VarMap : Map.S with type key = Var.t
type vars = expr Bindlib.mvar
val make_var : Var.t Pos.marked -> expr Pos.marked Bindlib.box
val make_abs :
vars ->
expr Pos.marked Bindlib.box ->
Pos.t ->
typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
val make_app :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
val make_let_in :
Var.t ->
typ Pos.marked ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box
val make_multiple_let_in :
Var.t array ->
typ Pos.marked list ->
expr Pos.marked list Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box
type binder = (expr, expr Pos.marked) Bindlib.binder
type program = { decl_ctx : decl_ctx; scopes : (ScopeName.t * Var.t * expr Pos.marked) list }

18
src/catala/default_calculus/dcalc.mld → compiler/dcalc/dcalc.mld
View File

@ -1,10 +1,11 @@
{0 Default calculus}
This representation is the fourth in the compilation chain
(see {{: index.html#architecture} Architecture}). Its main difference
with the previous {{: desugared.html} desugared representation} is that scopes
This representation is the fourth in the compilation chain
(see {{: index.html#architecture} Architecture}). Its main difference
with the previous {{: desugared.html} desugared representation} is that scopes
have been lowered into regular functions, and enums and structs have been
lowered to sum and product types.
lowered to sum and product types. The default calculus can be later compiled
to a {{: lcalc.html} lambda calculus}.
The module describing the abstract syntax tree is:
@ -12,9 +13,8 @@ The module describing the abstract syntax tree is:
Printing helpers can be found in {!module: Dcalc.Print}.
This intermediate representation corresponds to the default calculus
presented in the {{: https://github.com/CatalaLang/catala/raw/master/doc/formalization/formalization.pdf}
Catala formalization}.
This intermediate representation corresponds to the default calculus
presented in the {{: https://arxiv.org/abs/2103.03198} Catala formalization}.
{1 Typing }
@ -34,7 +34,7 @@ Related modules:
Since this representation is currently the last of the compilation chain,
an {!module: Dcalc.Interpreter} module is provided to match the execution
semantics of the default calculus.
semantics of the default calculus.
Later, translations to a regular lambda calculus and/or a simple imperative
Later, translations to a regular lambda calculus and/or a simple imperative
language are bound to be added.

10
compiler/dcalc/dune Normal file
View File

@ -0,0 +1,10 @@
(library
(name dcalc)
(public_name catala.dcalc)
(libraries bindlib unionFind utils re camomile runtime)
(preprocess
(pps visitors.ppx)))
(documentation
(package catala)
(mld_files dcalc))

421
src/catala/default_calculus/interpreter.ml → compiler/dcalc/interpreter.ml
View File

@ -1,6 +1,6 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
@ -14,9 +14,7 @@
(** Reference interpreter for the default calculus *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
open Utils
module A = Ast
(** {1 Helpers} *)
@ -34,36 +32,37 @@ let empty_thunked_term : Ast.expr Pos.marked =
[ (Ast.TLit Ast.TUnit, Pos.no_pos) ]
Pos.no_pos)
let rec type_eq (t1 : A.typ Pos.marked) (t2 : A.typ Pos.marked) : bool =
match (Pos.unmark t1, Pos.unmark t2) with
| A.TLit tl1, A.TLit tl2 -> tl1 = tl2
| A.TTuple (ts1, s1), A.TTuple (ts2, s2) -> (
try s1 == s2 && List.for_all2 type_eq ts1 ts2 with Invalid_argument _ -> false )
| A.TEnum (ts1, e1), A.TEnum (ts2, e2) -> (
try e1 == e2 && List.for_all2 type_eq ts1 ts2 with Invalid_argument _ -> false )
| A.TArray t1, A.TArray t2 -> type_eq t1 t2
| A.TArrow (t11, t12), A.TArrow (t21, t22) -> type_eq t11 t12 && type_eq t21 t22
| _, _ -> false
let log_indent = ref 0
(** {1 Evaluation} *)
let compare_periods (p1 : CalendarLib.Date.Period.t Pos.marked)
(p2 : CalendarLib.Date.Period.t Pos.marked) : int =
try
let p1_days = CalendarLib.Date.Period.nb_days (Pos.unmark p1) in
let p2_days = CalendarLib.Date.Period.nb_days (Pos.unmark p2) in
compare p1_days p2_days
with CalendarLib.Date.Period.Not_computable ->
Errors.raise_multispanned_error
"Cannot compare together durations that cannot be converted to a precise number of days"
[ (None, Pos.get_position p1); (None, Pos.get_position p2) ]
let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked)
(args : A.expr Pos.marked list) : A.expr Pos.marked =
(* Try to apply [div] and if a [Division_by_zero] exceptions is catched, use [op] to raise
multispanned errors. *)
let apply_div_or_raise_err (div : unit -> A.expr) (op : A.operator Pos.marked) : A.expr =
try div ()
with Division_by_zero ->
Errors.raise_multispanned_error "division by zero at runtime"
[
(Some "The division operator:", Pos.get_position op);
(Some "The null denominator:", Pos.get_position (List.nth args 1));
]
in
let get_binop_args_pos (args : (A.expr * Pos.t) list) : (string option * Pos.t) list =
[ (None, Pos.get_position (List.nth args 0)); (None, Pos.get_position (List.nth args 1)) ]
in
(* Try to apply [cmp] and if a [UncomparableDurations] exceptions is catched, use [args] to raise
multispanned errors. *)
let apply_cmp_or_raise_err (cmp : unit -> A.expr) (args : (A.expr * Pos.t) list) : A.expr =
try cmp ()
with Runtime.UncomparableDurations ->
Errors.raise_multispanned_error
"Cannot compare together durations that cannot be converted to a precise number of days"
(get_binop_args_pos args)
in
Pos.same_pos_as
( match (Pos.unmark op, List.map Pos.unmark args) with
(match (Pos.unmark op, List.map Pos.unmark args) with
| A.Ternop A.Fold, [ _f; _init; EArray es ] ->
Pos.unmark
(List.fold_left
@ -72,153 +71,124 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked)
(List.nth args 1) es)
| A.Binop A.And, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 && b2))
| A.Binop A.Or, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 || b2))
| A.Binop (A.Add KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Z.add i1 i2))
| A.Binop (A.Sub KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Z.sub i1 i2))
| A.Binop (A.Mult KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Z.mul i1 i2))
| A.Binop A.Xor, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 <> b2))
| A.Binop (A.Add KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt Runtime.(i1 +! i2))
| A.Binop (A.Sub KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt Runtime.(i1 -! i2))
| A.Binop (A.Mult KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt Runtime.(i1 *! i2))
| A.Binop (A.Div KInt), [ ELit (LInt i1); ELit (LInt i2) ] ->
if i2 <> Z.zero then A.ELit (LInt (Z.div i1 i2))
else
Errors.raise_multispanned_error "division by zero at runtime"
[
(Some "The division operator:", Pos.get_position op);
(Some "The null denominator:", Pos.get_position (List.nth args 2));
]
| A.Binop (A.Add KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat (Q.add i1 i2))
| A.Binop (A.Sub KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat (Q.sub i1 i2))
| A.Binop (A.Mult KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat (Q.mul i1 i2))
apply_div_or_raise_err (fun _ -> A.ELit (LInt Runtime.(i1 /! i2))) op
| A.Binop (A.Add KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat Runtime.(i1 +& i2))
| A.Binop (A.Sub KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat Runtime.(i1 -& i2))
| A.Binop (A.Mult KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat Runtime.(i1 *& i2))
| A.Binop (A.Div KRat), [ ELit (LRat i1); ELit (LRat i2) ] ->
if i2 <> Q.zero then A.ELit (LRat (Q.div i1 i2))
else
Errors.raise_multispanned_error "division by zero at runtime"
[
(Some "The division operator:", Pos.get_position op);
(Some "The null denominator:", Pos.get_position (List.nth args 2));
]
| A.Binop (A.Add KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] ->
A.ELit (LMoney (Z.add i1 i2))
| A.Binop (A.Sub KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] ->
A.ELit (LMoney (Z.sub i1 i2))
| A.Binop (A.Mult KMoney), [ ELit (LMoney i1); ELit (LRat i2) ] ->
let rat_result = Q.mul (Q.of_bigint i1) i2 in
let res, remainder = Z.div_rem (Q.num rat_result) (Q.den rat_result) in
(* we perform nearest rounding when multiplying an amount of money by a decimal !*)
let out =
if Z.(of_int 2 * remainder >= Q.den rat_result) then Z.add res (Z.of_int 1) else res
in
A.ELit (LMoney out)
| A.Binop (A.Div KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] ->
if i2 <> Z.zero then A.ELit (LRat (Q.div (Q.of_bigint i1) (Q.of_bigint i2)))
else
Errors.raise_multispanned_error "division by zero at runtime"
[
(Some "The division operator:", Pos.get_position op);
(Some "The null denominator:", Pos.get_position (List.nth args 2));
]
| A.Binop (A.Add KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit (LDuration (CalendarLib.Date.Period.add i1 i2))
| A.Binop (A.Sub KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit (LDuration (CalendarLib.Date.Period.sub i1 i2))
| A.Binop (A.Sub KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LDuration (CalendarLib.Date.sub i1 i2))
| A.Binop (A.Add KDate), [ ELit (LDate i1); ELit (LDuration i2) ] ->
A.ELit (LDate (CalendarLib.Date.add i1 i2))
| A.Binop (A.Lt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 < i2))
| A.Binop (A.Lte KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 <= i2))
| A.Binop (A.Gt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 > i2))
| A.Binop (A.Gte KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 >= i2))
| A.Binop (A.Lt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 < i2))
| A.Binop (A.Lte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 <= i2))
| A.Binop (A.Gt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 > i2))
| A.Binop (A.Gte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 >= i2))
| A.Binop (A.Lt KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] -> A.ELit (LBool (i1 < i2))
| A.Binop (A.Lte KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] -> A.ELit (LBool (i1 <= i2))
| A.Binop (A.Gt KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] -> A.ELit (LBool (i1 > i2))
| A.Binop (A.Gte KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] -> A.ELit (LBool (i1 >= i2))
| A.Binop (A.Lt KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit
(LBool
( compare_periods
(Pos.same_pos_as i1 (List.nth args 0))
(Pos.same_pos_as i2 (List.nth args 1))
< 0 ))
| A.Binop (A.Lte KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit
(LBool
( compare_periods
(Pos.same_pos_as i1 (List.nth args 0))
(Pos.same_pos_as i2 (List.nth args 1))
<= 0 ))
| A.Binop (A.Gt KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit
(LBool
( compare_periods
(Pos.same_pos_as i1 (List.nth args 0))
(Pos.same_pos_as i2 (List.nth args 1))
> 0 ))
| A.Binop (A.Gte KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit
(LBool
( compare_periods
(Pos.same_pos_as i1 (List.nth args 0))
(Pos.same_pos_as i2 (List.nth args 1))
>= 0 ))
| A.Binop (A.Lt KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (CalendarLib.Date.compare i1 i2 < 0))
| A.Binop (A.Lte KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (CalendarLib.Date.compare i1 i2 <= 0))
| A.Binop (A.Gt KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (CalendarLib.Date.compare i1 i2 > 0))
| A.Binop (A.Gte KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (CalendarLib.Date.compare i1 i2 >= 0))
apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(i1 /& i2))) op
| A.Binop (A.Add KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] ->
A.ELit (LMoney Runtime.(m1 +$ m2))
| A.Binop (A.Sub KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] ->
A.ELit (LMoney Runtime.(m1 -$ m2))
| A.Binop (A.Mult KMoney), [ ELit (LMoney m1); ELit (LRat m2) ] ->
A.ELit (LMoney Runtime.(m1 *$ m2))
| A.Binop (A.Div KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] ->
apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(m1 /$ m2))) op
| A.Binop (A.Add KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] ->
A.ELit (LDuration Runtime.(d1 +^ d2))
| A.Binop (A.Sub KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] ->
A.ELit (LDuration Runtime.(d1 -^ d2))
| A.Binop (A.Sub KDate), [ ELit (LDate d1); ELit (LDate d2) ] ->
A.ELit (LDuration Runtime.(d1 -@ d2))
| A.Binop (A.Add KDate), [ ELit (LDate d1); ELit (LDuration d2) ] ->
A.ELit (LDate Runtime.(d1 +@ d2))
| A.Binop (A.Div KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] ->
apply_div_or_raise_err
(fun _ ->
try A.ELit (LRat Runtime.(d1 /^ d2))
with Runtime.IndivisableDurations ->
Errors.raise_multispanned_error
"Cannot divide durations that cannot be converted to a precise number of days"
(get_binop_args_pos args))
op
| A.Binop (A.Lt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 <! i2))
| A.Binop (A.Lte KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 <=! i2))
| A.Binop (A.Gt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 >! i2))
| A.Binop (A.Gte KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 >=! i2))
| A.Binop (A.Lt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 <& i2))
| A.Binop (A.Lte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 <=& i2))
| A.Binop (A.Gt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 >& i2))
| A.Binop (A.Gte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 >=& i2))
| A.Binop (A.Lt KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] ->
A.ELit (LBool Runtime.(m1 <$ m2))
| A.Binop (A.Lte KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] ->
A.ELit (LBool Runtime.(m1 <=$ m2))
| A.Binop (A.Gt KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] ->
A.ELit (LBool Runtime.(m1 >$ m2))
| A.Binop (A.Gte KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] ->
A.ELit (LBool Runtime.(m1 >=$ m2))
| A.Binop (A.Lt KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <^ d2))) args
| A.Binop (A.Lte KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <=^ d2))) args
| A.Binop (A.Gt KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >^ d2))) args
| A.Binop (A.Gte KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >=^ d2))) args
| A.Binop (A.Lt KDate), [ ELit (LDate d1); ELit (LDate d2) ] ->
A.ELit (LBool Runtime.(d1 <@ d2))
| A.Binop (A.Lte KDate), [ ELit (LDate d1); ELit (LDate d2) ] ->
A.ELit (LBool Runtime.(d1 <=@ d2))
| A.Binop (A.Gt KDate), [ ELit (LDate d1); ELit (LDate d2) ] ->
A.ELit (LBool Runtime.(d1 >@ d2))
| A.Binop (A.Gte KDate), [ ELit (LDate d1); ELit (LDate d2) ] ->
A.ELit (LBool Runtime.(d1 >=@ d2))
| A.Binop A.Eq, [ ELit LUnit; ELit LUnit ] -> A.ELit (LBool true)
| A.Binop A.Eq, [ ELit (LDuration i1); ELit (LDuration i2) ] -> A.ELit (LBool (i1 = i2))
| A.Binop A.Eq, [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (CalendarLib.Date.compare i1 i2 = 0))
| A.Binop A.Eq, [ ELit (LMoney i1); ELit (LMoney i2) ] -> A.ELit (LBool (i1 = i2))
| A.Binop A.Eq, [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 = i2))
| A.Binop A.Eq, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 = i2))
| A.Binop A.Eq, [ ELit (LDuration d1); ELit (LDuration d2) ] ->
A.ELit (LBool Runtime.(d1 =^ d2))
| A.Binop A.Eq, [ ELit (LDate d1); ELit (LDate d2) ] -> A.ELit (LBool Runtime.(d1 =@ d2))
| A.Binop A.Eq, [ ELit (LMoney m1); ELit (LMoney m2) ] -> A.ELit (LBool Runtime.(m1 =$ m2))
| A.Binop A.Eq, [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 =& i2))
| A.Binop A.Eq, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 =! i2))
| A.Binop A.Eq, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 = b2))
| A.Binop A.Eq, [ EArray es1; EArray es2 ] ->
A.ELit
(LBool
( try
List.for_all2
(fun e1 e2 ->
match Pos.unmark (evaluate_operator ctx op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false ))
(try
List.for_all2
(fun e1 e2 ->
match Pos.unmark (evaluate_operator ctx op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| A.Binop A.Eq, [ ETuple (es1, s1); ETuple (es2, s2) ] ->
A.ELit
(LBool
( try
s1 = s2
&& List.for_all2
(fun e1 e2 ->
match Pos.unmark (evaluate_operator ctx op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false ))
| A.Binop A.Eq, [ EInj (e1, i1, en1, ts1); EInj (e2, i2, en2, ts2) ] ->
(try
s1 = s2
&& List.for_all2
(fun e1 e2 ->
match Pos.unmark (evaluate_operator ctx op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| A.Binop A.Eq, [ EInj (e1, i1, en1, _ts1); EInj (e2, i2, en2, _ts2) ] ->
A.ELit
(LBool
( try
en1 = en2 && List.for_all2 type_eq ts1 ts2 && i1 = i2
&&
match Pos.unmark (evaluate_operator ctx op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *)
with Invalid_argument _ -> false ))
(try
en1 = en2 && i1 = i2
&&
match Pos.unmark (evaluate_operator ctx op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *)
with Invalid_argument _ -> false))
| A.Binop A.Eq, [ _; _ ] -> A.ELit (LBool false) (* comparing anything else return false *)
| A.Binop A.Neq, [ _; _ ] -> (
match Pos.unmark (evaluate_operator ctx (Pos.same_pos_as (A.Binop A.Eq) op) args) with
| A.ELit (A.LBool b) -> A.ELit (A.LBool (not b))
| _ -> assert false (*should not happen *) )
| _ -> assert false (*should not happen *))
| A.Binop A.Concat, [ A.EArray es1; A.EArray es2 ] -> A.EArray (es1 @ es2)
| A.Binop A.Map, [ _; A.EArray es ] ->
A.EArray
(List.map
@ -237,34 +207,25 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked)
(Pos.get_position (List.nth args 0)))
es)
| A.Binop _, ([ ELit LEmptyError; _ ] | [ _; ELit LEmptyError ]) -> A.ELit LEmptyError
| A.Unop (A.Minus KInt), [ ELit (LInt i) ] -> A.ELit (LInt (Z.sub Z.zero i))
| A.Unop (A.Minus KRat), [ ELit (LRat i) ] -> A.ELit (LRat (Q.sub Q.zero i))
| A.Unop (A.Minus KMoney), [ ELit (LMoney i) ] -> A.ELit (LMoney (Z.sub Z.zero i))
| A.Unop (A.Minus KDuration), [ ELit (LDuration i) ] ->
A.ELit (LDuration (CalendarLib.Date.Period.opp i))
| A.Unop (A.Minus KInt), [ ELit (LInt i) ] -> A.ELit (LInt Runtime.(integer_of_int 0 -! i))
| A.Unop (A.Minus KRat), [ ELit (LRat i) ] -> A.ELit (LRat Runtime.(decimal_of_string "0" -& i))
| A.Unop (A.Minus KMoney), [ ELit (LMoney i) ] ->
A.ELit (LMoney Runtime.(money_of_units_int 0 -$ i))
| A.Unop (A.Minus KDuration), [ ELit (LDuration i) ] -> A.ELit (LDuration Runtime.(~-^i))
| A.Unop A.Not, [ ELit (LBool b) ] -> A.ELit (LBool (not b))
| A.Unop A.Length, [ EArray es ] -> A.ELit (LInt (Z.of_int (List.length es)))
| A.Unop A.GetDay, [ ELit (LDate d) ] ->
A.ELit (LInt (Z.of_int (CalendarLib.Date.day_of_month d)))
| A.Unop A.GetMonth, [ ELit (LDate d) ] ->
A.ELit (LInt (Z.of_int (CalendarLib.Date.int_of_month (CalendarLib.Date.month d))))
| A.Unop A.GetYear, [ ELit (LDate d) ] -> A.ELit (LInt (Z.of_int (CalendarLib.Date.year d)))
| A.Unop A.IntToRat, [ ELit (LInt i) ] -> A.ELit (LRat (Q.of_bigint i))
| A.Unop A.ErrorOnEmpty, [ e' ] ->
if e' = A.ELit LEmptyError then
Errors.raise_spanned_error
"This variable evaluated to an empty term (no rule that defined it applied in this \
situation)"
(Pos.get_position op)
else e'
| A.Unop A.Length, [ EArray es ] -> A.ELit (LInt (Runtime.integer_of_int (List.length es)))
| A.Unop A.GetDay, [ ELit (LDate d) ] -> A.ELit (LInt Runtime.(day_of_month_of_date d))
| A.Unop A.GetMonth, [ ELit (LDate d) ] -> A.ELit (LInt Runtime.(month_number_of_date d))
| A.Unop A.GetYear, [ ELit (LDate d) ] -> A.ELit (LInt Runtime.(year_of_date d))
| A.Unop A.IntToRat, [ ELit (LInt i) ] -> A.ELit (LRat Runtime.(decimal_of_integer i))
| A.Unop (A.Log (entry, infos)), [ e' ] ->
if !Cli.trace_flag then (
match entry with
| VarDef ->
| VarDef _ ->
Cli.log_print
(Format.asprintf "%*s%a %a: %s" (!log_indent * 2) "" Print.format_log_entry entry
Print.format_uid_list infos
( match e' with
(match e' with
| Ast.EAbs _ -> Cli.print_with_style [ ANSITerminal.green ] "<function>"
| _ ->
let expr_str =
@ -275,7 +236,18 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked)
~subst:(fun _ -> " ")
expr_str
in
Cli.print_with_style [ ANSITerminal.green ] "%s" expr_str ))
Cli.print_with_style [ ANSITerminal.green ] "%s" expr_str))
| PosRecordIfTrueBool -> (
let pos = Pos.get_position op in
match (pos <> Pos.no_pos, e') with
| true, ELit (LBool true) ->
Cli.log_print
(Format.asprintf "%*s%a%s:\n%s" (!log_indent * 2) "" Print.format_log_entry
entry
(Cli.print_with_style [ ANSITerminal.green ] "Definition applied")
(Cli.add_prefix_to_each_line (Pos.retrieve_loc_text pos) (fun _ ->
Format.asprintf "%*s" (!log_indent * 2) "")))
| _ -> ())
| BeginCall ->
Cli.log_print
(Format.asprintf "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry entry
@ -285,20 +257,20 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked)
log_indent := !log_indent - 1;
Cli.log_print
(Format.asprintf "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry entry
Print.format_uid_list infos) )
Print.format_uid_list infos))
else ();
e'
| A.Unop _, [ ELit LEmptyError ] -> A.ELit LEmptyError
| _ ->
Errors.raise_multispanned_error
"Operator applied to the wrong arguments\n(should nothappen if the term was well-typed)"
( [ (Some "Operator:", Pos.get_position op) ]
([ (Some "Operator:", Pos.get_position op) ]
@ List.mapi
(fun i arg ->
( Some
(Format.asprintf "Argument n°%d, value %a" (i + 1) (Print.format_expr ctx) arg),
Pos.get_position arg ))
args ) )
args))
op
and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.marked =
@ -311,7 +283,7 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark
let e1 = evaluate_expr ctx e1 in
let args = List.map (evaluate_expr ctx) args in
match Pos.unmark e1 with
| EAbs (_, binder, _) ->
| EAbs ((binder, _), _) ->
if Bindlib.mbinder_arity binder = List.length args then
evaluate_expr ctx (Bindlib.msubst binder (Array.of_list (List.map Pos.unmark args)))
else
@ -326,40 +298,45 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark
Errors.raise_spanned_error
"function has not been reduced to a lambda at evaluation (should not happen if the \
term was well-typed"
(Pos.get_position e) )
(Pos.get_position e))
| EAbs _ | ELit _ | EOp _ -> e (* thse are values *)
| ETuple (es, s) -> Pos.same_pos_as (A.ETuple (List.map (evaluate_expr ctx) es, s)) e
| ETuple (es, s) ->
let new_es = List.map (evaluate_expr ctx) es in
if List.exists is_empty_error new_es then Pos.same_pos_as (A.ELit LEmptyError) e
else Pos.same_pos_as (A.ETuple (new_es, s)) e
| ETupleAccess (e1, n, s, _) -> (
let e1 = evaluate_expr ctx e1 in
match Pos.unmark e1 with
| ETuple (es, s') -> (
( match (s, s') with
(match (s, s') with
| None, None -> ()
| Some s, Some s' when s = s' -> ()
| _ ->
Errors.raise_multispanned_error
"Error during tuple access: not the same structs (should not happen if the term \
was well-typed)"
[ (None, Pos.get_position e); (None, Pos.get_position e1) ] );
[ (None, Pos.get_position e); (None, Pos.get_position e1) ]);
match List.nth_opt es n with
| Some e' -> e'
| None ->
Errors.raise_spanned_error
(Format.asprintf
"the tuple has %d components but the %i-th element was requested (should not \
"The tuple has %d components but the %i-th element was requested (should not \
happen if the term was well-type)"
(List.length es) n)
(Pos.get_position e1) )
(Pos.get_position e1))
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error
(Format.asprintf
"the expression should be a tuple with %d components but is not (should not happen \
if the term was well-typed)"
n)
(Pos.get_position e1) )
"The expression %a should be a tuple with %d components but is not (should not \
happen if the term was well-typed)"
(Print.format_expr ctx) e n)
(Pos.get_position e1))
| EInj (e1, n, en, ts) ->
let e1' = evaluate_expr ctx e1 in
Pos.same_pos_as (A.EInj (e1', n, en, ts)) e
if is_empty_error e1' then Pos.same_pos_as (A.ELit LEmptyError) e
else Pos.same_pos_as (A.EInj (e1', n, en, ts)) e
| EMatch (e1, es, e_name) -> (
let e1 = evaluate_expr ctx e1 in
match Pos.unmark e1 with
@ -384,7 +361,7 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark
Errors.raise_spanned_error
"Expected a term having a sum type as an argument to a match (should not happend if \
the term was well-typed"
(Pos.get_position e1) )
(Pos.get_position e1))
| EDefault (exceptions, just, cons) -> (
let exceptions_orig = exceptions in
let exceptions = List.map (evaluate_expr ctx) exceptions in
@ -400,7 +377,7 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark
Errors.raise_spanned_error
"Default justification has not been reduced to a boolean at evaluation (should not \
happen if the term was well-typed"
(Pos.get_position e) )
(Pos.get_position e))
| 1 -> List.find (fun sub -> not (is_empty_error sub)) exceptions
| _ ->
Errors.raise_multispanned_error
@ -409,17 +386,29 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark
(fun (_, except) -> (Some "This justification is true:", Pos.get_position except))
(List.filter
(fun (sub, _) -> not (is_empty_error sub))
(List.map2 (fun x y -> (x, y)) exceptions exceptions_orig))) )
(List.map2 (fun x y -> (x, y)) exceptions exceptions_orig))))
| EIfThenElse (cond, et, ef) -> (
match Pos.unmark (evaluate_expr ctx cond) with
| ELit (LBool true) -> evaluate_expr ctx et
| ELit (LBool false) -> evaluate_expr ctx ef
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error
"Expected a boolean literal for the result of this condition (should not happen if the \
term was well-typed)"
(Pos.get_position cond) )
| EArray es -> Pos.same_pos_as (A.EArray (List.map (evaluate_expr ctx) es)) e
(Pos.get_position cond))
| EArray es ->
let new_es = List.map (evaluate_expr ctx) es in
if List.exists is_empty_error new_es then Pos.same_pos_as (A.ELit LEmptyError) e
else Pos.same_pos_as (A.EArray new_es) e
| ErrorOnEmpty e' ->
let e' = evaluate_expr ctx e' in
if Pos.unmark e' = A.ELit LEmptyError then
Errors.raise_spanned_error
"This variable evaluated to an empty term (no rule that defined it applied in this \
situation)"
(Pos.get_position e)
else e'
| EAssert e' -> (
match Pos.unmark (evaluate_expr ctx e') with
| ELit (LBool true) -> Pos.same_pos_as (Ast.ELit LUnit) e'
@ -431,31 +420,37 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark
Print.format_binop (op, pos_op) (Print.format_expr ctx) e2)
(Pos.get_position e')
| _ ->
Errors.raise_spanned_error (Format.asprintf "Assertion failed") (Pos.get_position e')
)
Errors.raise_spanned_error (Format.asprintf "Assertion failed") (Pos.get_position e'))
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error
"Expected a boolean literal for the result of this assertion (should not happen if the \
term was well-typed)"
(Pos.get_position e') )
(Pos.get_position e'))
(** {1 API} *)
(** Interpret a program. This function expects an expression typed as a function whose argument are
all thunked. The function is executed by providing for each argument a thunked empty default. *)
let interpret_program (ctx : Ast.decl_ctx) (e : Ast.expr Pos.marked) :
(Ast.Var.t * Ast.expr Pos.marked) list =
(Uid.MarkedString.info * Ast.expr Pos.marked) list =
match Pos.unmark (evaluate_expr ctx e) with
| Ast.EAbs (_, binder, taus) -> (
| Ast.EAbs (_, [ (Ast.TTuple (taus, Some s_in), _) ]) -> (
let application_term = List.map (fun _ -> empty_thunked_term) taus in
let to_interpret = (Ast.EApp (e, application_term), Pos.no_pos) in
let to_interpret =
(Ast.EApp (e, [ (Ast.ETuple (application_term, Some s_in), Pos.no_pos) ]), Pos.no_pos)
in
match Pos.unmark (evaluate_expr ctx to_interpret) with
| Ast.ETuple (args, None) ->
let vars, _ = Bindlib.unmbind binder in
List.map2 (fun arg var -> (var, arg)) args (Array.to_list vars)
| Ast.ETuple (args, Some s_out) ->
let s_out_fields =
List.map
(fun (f, _) -> Ast.StructFieldName.get_info f)
(Ast.StructMap.find s_out ctx.ctx_structs)
in
List.map2 (fun arg var -> (var, arg)) args s_out_fields
| _ ->
Errors.raise_spanned_error "The interpretation of a program should always yield a tuple"
(Pos.get_position e) )
Errors.raise_spanned_error
"The interpretation of a program should always yield a struct corresponding to the \
scope variables"
(Pos.get_position e))
| _ ->
Errors.raise_spanned_error
"The interpreter can only interpret terms starting with functions having thunked arguments"

24
compiler/dcalc/interpreter.mli Normal file
View File

@ -0,0 +1,24 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Reference interpreter for the default calculus *)
open Utils
val empty_thunked_term : Ast.expr Pos.marked
val interpret_program :
Ast.decl_ctx -> Ast.expr Pos.marked -> (Uid.MarkedString.info * Ast.expr Pos.marked) list
(** Interpret a program. This function expects an expression typed as a function whose argument are
all thunked. The function is executed by providing for each argument a thunked empty default. *)

74
compiler/dcalc/optimizations.ml Normal file
View File

@ -0,0 +1,74 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Ast
let rec peephole_expr (e : expr Pos.marked) : expr Pos.marked Bindlib.box =
match Pos.unmark e with
| EVar (v, pos) -> Bindlib.box_apply (fun v -> (v, pos)) (Bindlib.box_var v)
| ETuple (args, n) ->
Bindlib.box_apply
(fun args -> (ETuple (args, n), Pos.get_position e))
(Bindlib.box_list (List.map peephole_expr args))
| ETupleAccess (e1, i, n, ts) ->
Bindlib.box_apply
(fun e1 -> (ETupleAccess (e1, i, n, ts), Pos.get_position e))
(peephole_expr e1)
| EInj (e1, i, n, ts) ->
Bindlib.box_apply (fun e1 -> (EInj (e1, i, n, ts), Pos.get_position e)) (peephole_expr e1)
| EMatch (arg, cases, n) ->
Bindlib.box_apply2
(fun arg cases -> (EMatch (arg, cases, n), Pos.get_position e))
(peephole_expr arg)
(Bindlib.box_list (List.map peephole_expr cases))
| EArray args ->
Bindlib.box_apply
(fun args -> (EArray args, Pos.get_position e))
(Bindlib.box_list (List.map peephole_expr args))
| EAbs ((binder, pos_binder), ts) ->
let vars, body = Bindlib.unmbind binder in
let body = peephole_expr body in
Bindlib.box_apply
(fun binder -> (EAbs ((binder, pos_binder), ts), Pos.get_position e))
(Bindlib.bind_mvar vars body)
| EApp (e1, args) ->
Bindlib.box_apply2
(fun e1 args -> (EApp (e1, args), Pos.get_position e))
(peephole_expr e1)
(Bindlib.box_list (List.map peephole_expr args))
| ErrorOnEmpty e1 ->
Bindlib.box_apply (fun e1 -> (ErrorOnEmpty e1, Pos.get_position e)) (peephole_expr e1)
| EAssert e1 -> Bindlib.box_apply (fun e1 -> (EAssert e1, Pos.get_position e)) (peephole_expr e1)
| EIfThenElse (e1, e2, e3) ->
Bindlib.box_apply3
(fun e1 e2 e3 -> (EIfThenElse (e1, e2, e3), Pos.get_position e))
(peephole_expr e1) (peephole_expr e2) (peephole_expr e3)
| EDefault (exceptions, just, cons) ->
Bindlib.box_apply3
(fun exceptions just cons ->
( (match exceptions with
| [] -> EIfThenElse (just, cons, (ELit LEmptyError, Pos.get_position e))
| _ -> EDefault (exceptions, just, cons)),
Pos.get_position e ))
(Bindlib.box_list (List.map peephole_expr exceptions))
(peephole_expr just) (peephole_expr cons)
| ELit _ | EOp _ -> Bindlib.box e
let peephole_optimizations (p : program) : program =
{
p with
scopes = List.map (fun (name, var, e) -> (name, var, Bindlib.unbox (peephole_expr e))) p.scopes;
}
let optimize_program (p : program) : program = peephole_optimizations p

17
compiler/dcalc/optimizations.mli Normal file
View File

@ -0,0 +1,17 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Ast
val optimize_program : program -> program

274
compiler/dcalc/print.ml Normal file
View File

@ -0,0 +1,274 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Ast
let typ_needs_parens (e : typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false
let is_uppercase (x : CamomileLibraryDefault.Camomile.UChar.t) : bool =
try
match CamomileLibraryDefault.Camomile.UCharInfo.general_category x with
| `Ll -> false
| `Lu -> true
| _ -> false
with _ -> true
let begins_with_uppercase (s : string) : bool =
let first_letter = CamomileLibraryDefault.Camomile.UTF8.get s 0 in
is_uppercase first_letter
let format_uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) : unit =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info ->
Format.fprintf fmt "%s"
(Utils.Cli.print_with_style
(if begins_with_uppercase (Pos.unmark info) then [ ANSITerminal.red ] else [])
"%s"
(Format.asprintf "%a" Utils.Uid.MarkedString.format_info info))))
infos
let format_keyword (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.red ] "%s" s)
let format_base_type (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" s)
let format_punctuation (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.cyan ] "%s" s)
let format_operator (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.green ] "%s" s)
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
format_base_type fmt
(match l with
| TUnit -> "unit"
| TBool -> "bool"
| TInt -> "integer"
| TRat -> "decimal"
| TMoney -> "money"
| TDuration -> "duration"
| TDate -> "date")
let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter) (typ : typ Pos.marked) : unit =
let format_typ = format_typ ctx in
let format_typ_with_parens (fmt : Format.formatter) (t : typ Pos.marked) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Pos.unmark typ with
| TLit l -> Format.fprintf fmt "%a" format_tlit l
| TTuple (ts, None) ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
(fun fmt t -> Format.fprintf fmt "%a" format_typ t))
ts
| TTuple (_, Some s) -> Format.fprintf fmt "%a" Ast.StructName.format_t s
| TEnum (_, e) -> Format.fprintf fmt "%a" Ast.EnumName.format_t e
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_typ_with_parens t1 format_punctuation "→"
format_typ t2
| TArray t1 -> Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_base_type "array" format_typ t1
| TAny -> Format.fprintf fmt "any"
(* (EmileRolley) NOTE: seems to be factorizable with Lcalc.Print.format_lit. *)
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
match Pos.unmark l with
| LBool b -> Format.fprintf fmt "%b" b
| LInt i -> Format.fprintf fmt "%s" (Runtime.integer_to_string i)
| LEmptyError -> Format.fprintf fmt "∅ "
| LUnit -> Format.fprintf fmt "()"
| LRat i ->
Format.fprintf fmt "%s"
(Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i)
| LMoney e -> (
match !Utils.Cli.locale_lang with
| En -> Format.fprintf fmt "$%s" (Runtime.money_to_string e)
| Fr -> Format.fprintf fmt "%s €" (Runtime.money_to_string e)
| Pl -> Format.fprintf fmt "%s PLN" (Runtime.money_to_string e))
| LDate d -> Format.fprintf fmt "%s" (Runtime.date_to_string d)
| LDuration d -> Format.fprintf fmt "%s" (Runtime.duration_to_string d)
let format_op_kind (fmt : Format.formatter) (k : op_kind) =
Format.fprintf fmt "%s"
(match k with KInt -> "" | KRat -> "." | KMoney -> "$" | KDate -> "@" | KDuration -> "^")
let format_binop (fmt : Format.formatter) (op : binop Pos.marked) : unit =
format_operator fmt
(match Pos.unmark op with
| Add k -> Format.asprintf "+%a" format_op_kind k
| Sub k -> Format.asprintf "-%a" format_op_kind k
| Mult k -> Format.asprintf "*%a" format_op_kind k
| Div k -> Format.asprintf "/%a" format_op_kind k
| And -> "&&"
| Or -> "||"
| Xor -> "xor"
| Eq -> "="
| Neq -> "!="
| Lt k -> Format.asprintf "%s%a" "<" format_op_kind k
| Lte k -> Format.asprintf "%s%a" "<=" format_op_kind k
| Gt k -> Format.asprintf "%s%a" ">" format_op_kind k
| Gte k -> Format.asprintf "%s%a" ">=" format_op_kind k
| Concat -> "++"
| Map -> "map"
| Filter -> "filter")
let format_ternop (fmt : Format.formatter) (op : ternop Pos.marked) : unit =
match Pos.unmark op with Fold -> format_keyword fmt "fold"
let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Format.fprintf fmt "%s"
(match entry with
| VarDef _ -> Utils.Cli.print_with_style [ ANSITerminal.blue ] "≔ "
| BeginCall -> Utils.Cli.print_with_style [ ANSITerminal.yellow ] "→ "
| EndCall -> Utils.Cli.print_with_style [ ANSITerminal.yellow ] "← "
| PosRecordIfTrueBool -> Utils.Cli.print_with_style [ ANSITerminal.green ] "☛ ")
let format_unop (fmt : Format.formatter) (op : unop Pos.marked) : unit =
Format.fprintf fmt "%s"
(match Pos.unmark op with
| Minus _ -> "-"
| Not -> "~"
| Log (entry, infos) ->
Format.asprintf "log@[<hov 2>[%a|%a]@]" format_log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
infos
| Length -> "length"
| IntToRat -> "int_to_rat"
| GetDay -> "get_day"
| GetMonth -> "get_month"
| GetYear -> "get_year")
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
Format.fprintf fmt "%s" (Bindlib.name_of v)
let rec format_expr (ctx : Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked) : unit =
let format_expr = format_expr ctx in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
if needs_parens e then
Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e format_punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Pos.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation ")"
| ETuple (es, Some s) ->
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a%a%a@]@]" Ast.StructName.format_t s
format_punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a%a%a%a %a" format_punctuation "\"" Ast.StructFieldName.format_t
struct_field format_punctuation "\"" format_punctuation ":" format_expr e))
(List.combine es (List.map fst (Ast.StructMap.find s ctx.ctx_structs)))
format_punctuation "}"
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation "]"
| ETupleAccess (e1, n, s, _ts) -> (
match s with
| None -> Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n
| Some s ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_punctuation "." format_punctuation
"\"" Ast.StructFieldName.format_t
(fst (List.nth (Ast.StructMap.find s ctx.ctx_structs) n))
format_punctuation "\"")
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Ast.EnumConstructor.format_t
(fst (List.nth (Ast.EnumMap.find en ctx.ctx_enums) n))
format_expr e
| EMatch (e, es, e_name) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ @[<hov 2>%a@]@]" format_keyword "match" format_expr e
format_keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n| ")
(fun fmt (e, c) ->
Format.fprintf fmt "@[<hov 2>%a%a@ %a@]" Ast.EnumConstructor.format_t c
format_punctuation ":" format_expr e))
(List.combine es (List.map fst (Ast.EnumMap.find e_name ctx.ctx_enums)))
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
| EApp ((EAbs ((binder, _), taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in
Format.fprintf fmt "%a%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
(fun fmt (x, tau, arg) ->
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a@ %a@ %a@]@ %a@ %a@]@ %a@\n" format_keyword
"let" format_var x format_punctuation ":" (format_typ ctx) tau format_punctuation "="
format_expr arg format_keyword "in"))
xs_tau_arg format_expr body
| EAbs ((binder, _), taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>%a @[<hov 2>%a@] %a@ %a@]" format_punctuation "λ"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau) ->
Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var x format_punctuation
":" (format_typ ctx) tau format_punctuation ")"))
xs_tau format_punctuation "→" format_expr body
| EApp ((EOp (Binop ((Ast.Map | Ast.Filter) as op)), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop (op, Pos.no_pos) format_with_parens
arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
(op, Pos.no_pos) format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if" format_expr e1
format_keyword "then" format_expr e2 format_keyword "else" format_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
| EDefault (exceptions, just, cons) ->
if List.length exceptions = 0 then
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a@,%a@]" format_punctuation "⟨" format_expr just
format_punctuation "⊢" format_expr cons format_punctuation "⟩"
else
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a@ %a@ %a@,%a@]" format_punctuation "⟨"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " format_punctuation ",")
format_expr)
exceptions format_punctuation "|" format_expr just format_punctuation "⊢" format_expr cons
format_punctuation "⟩"
| ErrorOnEmpty e' -> Format.fprintf fmt "error_empty@ %a" format_with_parens e'
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" format_keyword "assert" format_punctuation "("
format_expr e' format_punctuation ")"

45
compiler/dcalc/print.mli Normal file
View File

@ -0,0 +1,45 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
(** {1 Helpers} *)
val is_uppercase : CamomileLibraryDefault.Camomile.UChar.t -> bool
val begins_with_uppercase : string -> bool
(** {1 Formatters} *)
val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val format_tlit : Format.formatter -> Ast.typ_lit -> unit
val format_typ : Ast.decl_ctx -> Format.formatter -> Ast.typ Pos.marked -> unit
val format_lit : Format.formatter -> Ast.lit Pos.marked -> unit
val format_op_kind : Format.formatter -> Ast.op_kind -> unit
val format_binop : Format.formatter -> Ast.binop Pos.marked -> unit
val format_ternop : Format.formatter -> Ast.ternop Pos.marked -> unit
val format_log_entry : Format.formatter -> Ast.log_entry -> unit
val format_unop : Format.formatter -> Ast.unop Pos.marked -> unit
val format_var : Format.formatter -> Ast.Var.t -> unit
val format_expr : Ast.decl_ctx -> Format.formatter -> Ast.expr Pos.marked -> unit

66
src/catala/default_calculus/typing.ml → compiler/dcalc/typing.ml
View File

@ -15,10 +15,8 @@
(** Typing for the default calculus. Because of the error terms, we perform type inference using the
classical W algorithm with union-find unification. *)
module Pos = Utils.Pos
module Errors = Utils.Errors
open Utils
module A = Ast
module Cli = Utils.Cli
(** {1 Types and unification} *)
@ -61,20 +59,8 @@ let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter)
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
(fun fmt t -> Format.fprintf fmt "%a" format_typ t))
ts
| TTuple (ts, Some s) ->
Format.fprintf fmt "%a @[<hov 2>{@ %a@ }@]" Ast.StructName.format_t s
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt (t, f) ->
Format.fprintf fmt "%a:@ %a" Ast.StructFieldName.format_t f format_typ t))
(List.combine ts (Ast.StructMap.find s ctx.ctx_structs))
| TEnum (ts, e) ->
Format.fprintf fmt "%a [@[<hov 2>%a@]]" Ast.EnumName.format_t e
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ |@ ")
(fun fmt (t, f) ->
Format.fprintf fmt "%a:@ %a" Ast.EnumConstructor.format_t f format_typ t))
(List.combine ts (Ast.EnumMap.find e ctx.ctx_enums))
| TTuple (_ts, Some s) -> Format.fprintf fmt "%a" Ast.StructName.format_t s
| TEnum (_ts, e) -> Format.fprintf fmt "%a" Ast.EnumName.format_t e
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a →@ %a@]" format_typ_with_parens t1 format_typ t2
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ t1
@ -84,21 +70,24 @@ let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter)
let rec unify (ctx : Ast.decl_ctx) (t1 : typ Pos.marked UnionFind.elem)
(t2 : typ Pos.marked UnionFind.elem) : unit =
let unify = unify ctx in
(* Cli.debug_print (Format.asprintf "Unifying %a and %a" format_typ t1 format_typ t2); *)
(* Cli.debug_print (Format.asprintf "Unifying %a and %a" (format_typ ctx) t1 (format_typ ctx)
t2); *)
let t1_repr = UnionFind.get (UnionFind.find t1) in
let t2_repr = UnionFind.get (UnionFind.find t2) in
let raise_type_error (t1_pos : Pos.t) (t2_pos : Pos.t) : 'a =
(* TODO: if we get weird error messages, then it means that we should use the persistent version
of the union-find data structure. *)
let t1_s =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*")
~subst:(fun _ -> " ")
(Format.asprintf "%a" (format_typ ctx) t1)
Cli.print_with_style [ ANSITerminal.yellow ] "%s"
(Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*")
~subst:(fun _ -> " ")
(Format.asprintf "%a" (format_typ ctx) t1))
in
let t2_s =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*")
~subst:(fun _ -> " ")
(Format.asprintf "%a" (format_typ ctx) t2)
Cli.print_with_style [ ANSITerminal.yellow ] "%s"
(Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*")
~subst:(fun _ -> " ")
(Format.asprintf "%a" (format_typ ctx) t2))
in
Errors.raise_multispanned_error
(Format.asprintf "Error during typechecking, incompatible types:\n%s %s\n%s %s"
@ -158,13 +147,14 @@ let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem =
let arr x y = UnionFind.make (TArrow (x, y), pos) in
match Pos.unmark op with
| A.Ternop A.Fold -> arr (arr any2 (arr any any2)) (arr any2 (arr array_any any2))
| A.Binop (A.And | A.Or) -> arr bt (arr bt bt)
| A.Binop (A.And | A.Or | A.Xor) -> arr bt (arr bt bt)
| A.Binop (A.Add KInt | A.Sub KInt | A.Mult KInt | A.Div KInt) -> arr it (arr it it)
| A.Binop (A.Add KRat | A.Sub KRat | A.Mult KRat | A.Div KRat) -> arr rt (arr rt rt)
| A.Binop (A.Add KMoney | A.Sub KMoney) -> arr mt (arr mt mt)
| A.Binop (A.Add KDuration | A.Sub KDuration) -> arr dut (arr dut dut)
| A.Binop (A.Sub KDate) -> arr dat (arr dat dut)
| A.Binop (A.Add KDate) -> arr dat (arr dut dat)
| A.Binop (A.Div KDuration) -> arr dut (arr dut rt)
| A.Binop (A.Div KMoney) -> arr mt (arr mt rt)
| A.Binop (A.Mult KMoney) -> arr mt (arr rt mt)
| A.Binop (A.Lt KInt | A.Lte KInt | A.Gt KInt | A.Gte KInt) -> arr it (arr it bt)
@ -176,19 +166,20 @@ let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem =
| A.Binop (A.Eq | A.Neq) -> arr any (arr any bt)
| A.Binop A.Map -> arr (arr any any2) (arr array_any array_any2)
| A.Binop A.Filter -> arr (arr any bt) (arr array_any array_any)
| A.Binop A.Concat -> arr array_any (arr array_any array_any)
| A.Unop (A.Minus KInt) -> arr it it
| A.Unop (A.Minus KRat) -> arr rt rt
| A.Unop (A.Minus KMoney) -> arr mt mt
| A.Unop (A.Minus KDuration) -> arr dut dut
| A.Unop A.Not -> arr bt bt
| A.Unop A.ErrorOnEmpty -> arr any any
| A.Unop (A.Log (A.PosRecordIfTrueBool, _)) -> arr bt bt
| A.Unop (A.Log _) -> arr any any
| A.Unop A.Length -> arr array_any it
| A.Unop A.GetDay -> arr dat it
| A.Unop A.GetMonth -> arr dat it
| A.Unop A.GetYear -> arr dat it
| A.Unop A.IntToRat -> arr it rt
| Binop (Mult (KDate | KDuration)) | Binop (Div (KDate | KDuration)) | Unop (Minus KDate) ->
| Binop (Mult (KDate | KDuration)) | Binop (Div KDate) | Unop (Minus KDate) ->
Errors.raise_spanned_error "This operator is not available!" pos
let rec ast_to_typ (ty : A.typ) : typ =
@ -224,6 +215,7 @@ type env = typ Pos.marked UnionFind.elem A.VarMap.t
(** Infers the most permissive type from an expression *)
let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.marked) :
typ Pos.marked UnionFind.elem =
(* Cli.debug_print (Format.asprintf "Looking for type of %a" (Print.format_expr ctx) e); *)
try
let out =
match Pos.unmark e with
@ -232,7 +224,7 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po
| Some t -> t
| None ->
Errors.raise_spanned_error "Variable not found in the current context"
(Pos.get_position e) )
(Pos.get_position e))
| ELit (LBool _) -> UnionFind.make (Pos.same_pos_as (TLit TBool) e)
| ELit (LInt _) -> UnionFind.make (Pos.same_pos_as (TLit TInt) e)
| ELit (LRat _) -> UnionFind.make (Pos.same_pos_as (TLit TRat) e)
@ -256,7 +248,7 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po
(Format.asprintf
"Expression should have a tuple type with at least %d elements but only has %d" n
(List.length typs))
(Pos.get_position e1) )
(Pos.get_position e1))
| EInj (e1, n, e_name, ts) ->
let ts = List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts in
let ts_n =
@ -285,7 +277,7 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po
typecheck_expr_top_down ctx env es' t_es')
es;
t_ret
| EAbs (pos_binder, binder, taus) ->
| EAbs ((binder, pos_binder), taus) ->
let xs, body = Bindlib.unmbind binder in
if Array.length xs = List.length taus then
let xstaus =
@ -329,6 +321,7 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po
| EAssert e' ->
typecheck_expr_top_down ctx env e' (UnionFind.make (Pos.same_pos_as (TLit TBool) e'));
UnionFind.make (Pos.same_pos_as (TLit TUnit) e')
| ErrorOnEmpty e' -> typecheck_expr_bottom_up ctx env e'
| EArray es ->
let cell_type = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in
List.iter
@ -338,7 +331,8 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po
es;
UnionFind.make (Pos.same_pos_as (TArray cell_type) e)
in
(* Cli.debug_print (Format.asprintf "Found type of %a: %a" Print.format_expr e format_typ out); *)
(* Cli.debug_print (Format.asprintf "Found type of %a: %a" (Print.format_expr ctx) e (format_typ
ctx) out); *)
out
with Errors.StructuredError (msg, err_pos) when List.length err_pos = 2 ->
raise
@ -350,7 +344,8 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po
(** Checks whether the expression can be typed with the provided type *)
and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.marked)
(tau : typ Pos.marked UnionFind.elem) : unit =
(* Cli.debug_print (Format.asprintf "Typechecking %a : %a" Print.format_expr e format_typ tau); *)
(* Cli.debug_print (Format.asprintf "Typechecking %a : %a" (Print.format_expr ctx) e (format_typ
ctx) tau); *)
try
match Pos.unmark e with
| EVar v -> (
@ -358,7 +353,7 @@ and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.mar
| Some tau' -> ignore (unify ctx tau tau')
| None ->
Errors.raise_spanned_error "Variable not found in the current context"
(Pos.get_position e) )
(Pos.get_position e))
| ELit (LBool _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TBool) e))
| ELit (LInt _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TInt) e))
| ELit (LRat _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TRat) e))
@ -383,7 +378,7 @@ and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.mar
(Format.asprintf
"Expression should have a tuple type with at least %d elements but only has %d" n
(List.length typs))
(Pos.get_position e1) )
(Pos.get_position e1))
| EInj (e1, n, e_name, ts) ->
let ts = List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts in
let ts_n =
@ -412,7 +407,7 @@ and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.mar
typecheck_expr_top_down ctx env es' t_es')
es;
unify ctx tau t_ret
| EAbs (pos_binder, binder, t_args) ->
| EAbs ((binder, pos_binder), t_args) ->
let xs, body = Bindlib.unmbind binder in
if Array.length xs = List.length t_args then
let xstaus =
@ -456,6 +451,7 @@ and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.mar
| EAssert e' ->
typecheck_expr_top_down ctx env e' (UnionFind.make (Pos.same_pos_as (TLit TBool) e'));
unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TUnit) e'))
| ErrorOnEmpty e' -> typecheck_expr_top_down ctx env e' tau
| EArray es ->
let cell_type = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in
List.iter

20
compiler/dcalc/typing.mli Normal file
View File

@ -0,0 +1,20 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Typing for the default calculus. Because of the error terms, we perform type inference using the
classical W algorithm with union-find unification. *)
val infer_type : Ast.decl_ctx -> Ast.expr Utils.Pos.marked -> Ast.typ Utils.Pos.marked
val check_type : Ast.decl_ctx -> Ast.expr Utils.Pos.marked -> Ast.typ Utils.Pos.marked -> unit

17
src/catala/desugared/ast.ml → compiler/desugared/ast.ml
View File

@ -14,8 +14,7 @@
(** Abstract syntax tree of the desugared representation *)
module Pos = Utils.Pos
module Uid = Utils.Uid
open Utils
(** {1 Names, Maps and Keys} *)
@ -79,9 +78,9 @@ let empty_rule (pos : Pos.t) (have_parameter : Scopelang.Ast.typ Pos.marked opti
just = Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool false), pos);
cons = Bindlib.box (Scopelang.Ast.ELit Dcalc.Ast.LEmptyError, pos);
parameter =
( match have_parameter with
(match have_parameter with
| Some typ -> Some (Scopelang.Ast.Var.make ("dummy", pos), typ)
| None -> None );
| None -> None);
exception_to_rule = None;
}
@ -90,9 +89,9 @@ let always_false_rule (pos : Pos.t) (have_parameter : Scopelang.Ast.typ Pos.mark
just = Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool true), pos);
cons = Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool false), pos);
parameter =
( match have_parameter with
(match have_parameter with
| Some typ -> Some (Scopelang.Ast.Var.make ("dummy", pos), typ)
| None -> None );
| None -> None);
exception_to_rule = None;
}
@ -122,18 +121,16 @@ type program = {
program_structs : Scopelang.Ast.struct_ctx;
}
(** {1 Helpers} *)
let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
let add_locs (acc : Pos.t ScopeDefMap.t) (locs : Scopelang.Ast.LocationSet.t) :
Pos.t ScopeDefMap.t =
Scopelang.Ast.LocationSet.fold
(fun (loc, loc_pos) acc ->
ScopeDefMap.add
( match loc with
(match loc with
| Scopelang.Ast.ScopeVar v -> ScopeDef.Var (Pos.unmark v)
| Scopelang.Ast.SubScopeVar (_, sub_index, sub_var) ->
ScopeDef.SubScopeVar (Pos.unmark sub_index, Pos.unmark sub_var) )
ScopeDef.SubScopeVar (Pos.unmark sub_index, Pos.unmark sub_var))
loc_pos acc)
locs acc
in

89
compiler/desugared/ast.mli Normal file
View File

@ -0,0 +1,89 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Abstract syntax tree of the desugared representation *)
open Utils
(** {1 Names, Maps and Keys} *)
module IdentMap : Map.S with type key = String.t
module RuleName : Uid.Id with type info = Uid.MarkedString.info
module RuleMap : Map.S with type key = RuleName.t
module RuleSet : Set.S with type elt = RuleName.t
(** Inside a scope, a definition can refer either to a scope def, or a subscope def *)
module ScopeDef : sig
type t =
| Var of Scopelang.Ast.ScopeVar.t
| SubScopeVar of Scopelang.Ast.SubScopeName.t * Scopelang.Ast.ScopeVar.t
val compare : t -> t -> int
val get_position : t -> Pos.t
val format_t : Format.formatter -> t -> unit
val hash : t -> int
end
module ScopeDefMap : Map.S with type key = ScopeDef.t
module ScopeDefSet : Set.S with type elt = ScopeDef.t
(** {1 AST} *)
type rule = {
just : Scopelang.Ast.expr Pos.marked Bindlib.box;
cons : Scopelang.Ast.expr Pos.marked Bindlib.box;
parameter : (Scopelang.Ast.Var.t * Scopelang.Ast.typ Pos.marked) option;
exception_to_rule : RuleName.t Pos.marked option;
}
val empty_rule : Pos.t -> Scopelang.Ast.typ Pos.marked option -> rule
val always_false_rule : Pos.t -> Scopelang.Ast.typ Pos.marked option -> rule
type assertion = Scopelang.Ast.expr Pos.marked Bindlib.box
type variation_typ = Increasing | Decreasing
type reference_typ = Decree | Law
type meta_assertion =
| FixedBy of reference_typ Pos.marked
| VariesWith of unit * variation_typ Pos.marked option
type scope = {
scope_vars : Scopelang.Ast.ScopeVarSet.t;
scope_sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
scope_uid : Scopelang.Ast.ScopeName.t;
scope_defs :
(rule RuleMap.t * Scopelang.Ast.typ Pos.marked * bool) (* is it a condition? *) ScopeDefMap.t;
scope_assertions : assertion list;
scope_meta_assertions : meta_assertion list;
}
type program = {
program_scopes : scope Scopelang.Ast.ScopeMap.t;
program_enums : Scopelang.Ast.enum_ctx;
program_structs : Scopelang.Ast.struct_ctx;
}
(** {1 Helpers} *)
val free_variables : rule RuleMap.t -> Pos.t ScopeDefMap.t

3
src/catala/desugared/dependency.ml → compiler/desugared/dependency.ml
View File

@ -14,8 +14,7 @@
(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/} OCamlgraph} *)
module Pos = Utils.Pos
module Errors = Utils.Errors
open Utils
(** {1 Scope variables dependency graph} *)

68
compiler/desugared/dependency.mli Normal file
View File

@ -0,0 +1,68 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/} OCamlgraph} *)
open Utils
(** {1 Scope variables dependency graph} *)
(** {2 Graph declaration} *)
(** Vertices: scope variables or subscopes.
The vertices of the scope dependency graph are either :
- the variables of the scope ;
- the subscopes of the scope.
Indeed, during interpretation, subscopes are executed atomically. *)
module Vertex : sig
type t = Var of Scopelang.Ast.ScopeVar.t | SubScope of Scopelang.Ast.SubScopeName.t
val format_t : Format.formatter -> t -> unit
include Graph.Sig.COMPARABLE with type t := t
end
module Edge : Graph.Sig.ORDERED_TYPE_DFT with type t = Pos.t
(** On the edges, the label is the position of the expression responsible for the use of the
variable. In the graph, [x -> y] if [x] is used in the definition of [y].*)
(** Module of the graph, provided by OCamlGraph *)
module ScopeDependencies : Graph.Sig.P with type V.t = Vertex.t and type E.label = Edge.t
(** {2 Graph computations} *)
(** Returns an ordering of the scope variables and subscope compatible with the dependencies of the
computation *)
val correct_computation_ordering : ScopeDependencies.t -> Vertex.t list
(** Returns an ordering of the scope variables and subscope compatible with the dependencies of the
computation *)
val check_for_cycle : Ast.scope -> ScopeDependencies.t -> unit
(** Outputs an error in case of cycles. *)
val build_scope_dependencies : Ast.scope -> ScopeDependencies.t
(** Builds the dependency graph of a particular scope *)
(** {1 Exceptions dependency graph} *)
module ExceptionsDependencies : Graph.Sig.P with type V.t = Ast.RuleName.t and type E.label = Edge.t
val build_exceptions_graph : Ast.rule Ast.RuleMap.t -> Ast.ScopeDef.t -> ExceptionsDependencies.t
val check_for_exception_cycle : ExceptionsDependencies.t -> unit

0
src/catala/desugared/desugared.mld → compiler/desugared/desugared.mld
View File

24
src/catala/desugared/desugared_to_scope.ml → compiler/desugared/desugared_to_scope.ml
View File

@ -14,9 +14,7 @@
(** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
open Utils
(** {1 Rule tree construction} *)
@ -86,9 +84,7 @@ let rec rule_tree_to_expr ~(toplevel : bool) (def_pos : Pos.t)
let default =
Bindlib.box_apply
(fun (default : Scopelang.Ast.expr * Pos.t) ->
( Scopelang.Ast.EApp
((Scopelang.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.ErrorOnEmpty), def_pos), [ default ]),
def_pos ))
(Scopelang.Ast.ErrorOnEmpty default, def_pos))
default
in
Scopelang.Ast.make_abs (Array.of_list [ new_param ]) default def_pos [ typ ] def_pos
@ -119,15 +115,15 @@ let translate_def (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.RuleMap.t)
else
Errors.raise_multispanned_error
"some definitions of the same variable are functions while others aren't"
( List.map
(fun (_, r) ->
(Some "This definition is a function:", Pos.get_position (Bindlib.unbox r.Ast.cons)))
(Ast.RuleMap.bindings (Ast.RuleMap.filter is_func def))
(List.map
(fun (_, r) ->
(Some "This definition is a function:", Pos.get_position (Bindlib.unbox r.Ast.cons)))
(Ast.RuleMap.bindings (Ast.RuleMap.filter is_func def))
@ List.map
(fun (_, r) ->
( Some "This definition is not a function:",
Pos.get_position (Bindlib.unbox r.Ast.cons) ))
(Ast.RuleMap.bindings (Ast.RuleMap.filter (fun n r -> not (is_func n r)) def)) )
(Ast.RuleMap.bindings (Ast.RuleMap.filter (fun n r -> not (is_func n r)) def)))
in
let top_list = def_map_to_tree def_info def in
let top_value =
@ -136,12 +132,12 @@ let translate_def (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.RuleMap.t)
Bindlib.unbox
(rule_tree_to_expr ~toplevel:true
(Ast.ScopeDef.get_position def_info)
(Option.map (fun _ -> Scopelang.Ast.Var.make ("ρ", Pos.no_pos)) is_def_func)
( match top_list with
(Option.map (fun _ -> Scopelang.Ast.Var.make ("param", Pos.no_pos)) is_def_func)
(match top_list with
| [] ->
(* In this case, there are no rules to define the expression *)
Leaf top_value
| _ -> Node (top_list, top_value) ))
| _ -> Node (top_list, top_value)))
(** Translates a scope *)
let translate_scope (scope : Ast.scope) : Scopelang.Ast.scope_decl =

17
compiler/desugared/desugared_to_scope.mli Normal file
View File

@ -0,0 +1,17 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *)
val translate_program : Ast.program -> Scopelang.Ast.program

0
src/catala/desugared/dune → compiler/desugared/dune
View File

295
compiler/driver.ml Normal file
View File

@ -0,0 +1,295 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
module Cli = Utils.Cli
module Errors = Utils.Errors
module Pos = Utils.Pos
(** Associates a {!type: Cli.backend_lang} with its string represtation. *)
let languages = [ ("en", Cli.En); ("fr", Cli.Fr); ("pl", Cli.Pl) ]
(** Associates a file extension with its corresponding {!type: Cli.frontend_lang} string
representation. *)
let extensions = [ (".catala_fr", "fr"); (".catala_en", "en"); (".catala_pl", "pl") ]
(** Entry function for the executable. Returns a negative number in case of error. Usage:
[driver source_file debug dcalc unstyled wrap_weaved_output backend language max_prec_digits trace optimize scope_to_execute output_file]*)
let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
(wrap_weaved_output : bool) (backend : string) (language : string option)
(max_prec_digits : int option) (trace : bool) (optimize : bool) (ex_scope : string option)
(output_file : string option) : int =
try
Cli.debug_flag := debug;
Cli.style_flag := not unstyled;
Cli.trace_flag := trace;
Cli.optimize_flag := optimize;
Cli.debug_print "Reading files...";
let filename = ref "" in
(match source_file with FileName f -> filename := f | Contents c -> Cli.contents := c);
(match max_prec_digits with None -> () | Some i -> Cli.max_prec_digits := i);
let l =
match language with
| Some l -> l
| None -> (
(* Try to infer the language from the intput file extension. *)
let ext = Filename.extension !filename in
if ext = "" then
Errors.raise_error
(Printf.sprintf
"No file extension found for the file '%s'. (Try to add one or to specify the -l \
flag)"
!filename);
try List.assoc ext extensions with Not_found -> ext)
in
let language =
try List.assoc l languages
with Not_found ->
Errors.raise_error
(Printf.sprintf "The selected language (%s) is not supported by Catala" l)
in
Cli.locale_lang := language;
let backend =
let backend = String.lowercase_ascii backend in
if backend = "makefile" then Cli.Makefile
else if backend = "latex" then Cli.Latex
else if backend = "html" then Cli.Html
else if backend = "interpret" then Cli.Run
else if backend = "ocaml" then Cli.OCaml
else if backend = "dcalc" then Cli.Dcalc
else if backend = "scopelang" then Cli.Scopelang
else if backend = "python" then Cli.Python
else
Errors.raise_error
(Printf.sprintf "The selected backend (%s) is not supported by Catala" backend)
in
let prgm = Surface.Parser_driver.parse_top_level_file source_file language in
let prgm = Surface.Fill_positions.fill_pos_with_legislative_info prgm in
match backend with
| Cli.Makefile ->
let backend_extensions_list = [ ".tex" ] in
let source_file =
match source_file with
| FileName f -> f
| Contents _ ->
Errors.raise_error "The Makefile backend does not work if the input is not a file"
in
let output_file =
match output_file with
| Some f -> f
| None -> Filename.remove_extension source_file ^ ".d"
in
Cli.debug_print (Format.asprintf "Writing list of dependencies to %s..." output_file);
let oc = open_out output_file in
Printf.fprintf oc "%s:\\\n%s\n%s:"
(String.concat "\\\n"
(output_file
:: List.map
(fun ext -> Filename.remove_extension source_file ^ ext)
backend_extensions_list))
(String.concat "\\\n" prgm.program_source_files)
(String.concat "\\\n" prgm.program_source_files);
0
| Cli.Latex | Cli.Html ->
let source_file =
match source_file with
| FileName f -> f
| Contents _ ->
Errors.raise_error
"The literate programming backends do not work if the input is not a file"
in
Cli.debug_print
(Printf.sprintf "Weaving literate program into %s"
(match backend with
| Cli.Latex -> "LaTeX"
| Cli.Html -> "HTML"
| _ -> assert false (* should not happen *)));
let output_file =
match output_file with
| Some f -> f
| None -> (
Filename.remove_extension source_file
^
match backend with Cli.Latex -> ".tex" | Cli.Html -> ".html" | _ -> assert false
(* should not happen *))
in
let oc = open_out output_file in
let weave_output =
match backend with
| Cli.Latex -> Literate.Latex.ast_to_latex language
| Cli.Html -> Literate.Html.ast_to_html language
| _ -> assert false
(* should not happen *)
in
Cli.debug_print (Printf.sprintf "Writing to %s" output_file);
let fmt = Format.formatter_of_out_channel oc in
if wrap_weaved_output then
match backend with
| Cli.Latex ->
Literate.Latex.wrap_latex prgm.Surface.Ast.program_source_files language fmt
(fun fmt -> weave_output fmt prgm)
| Cli.Html ->
Literate.Html.wrap_html prgm.Surface.Ast.program_source_files language fmt (fun fmt ->
weave_output fmt prgm)
| _ -> assert false (* should not happen *)
else weave_output fmt prgm;
close_out oc;
0
| _ -> (
Cli.debug_print "Name resolution...";
let ctxt = Surface.Name_resolution.form_context prgm in
let scope_uid =
match (ex_scope, backend) with
| None, Cli.Run -> Errors.raise_error "No scope was provided for execution."
| None, _ ->
snd
(try Desugared.Ast.IdentMap.choose ctxt.scope_idmap
with Not_found ->
Errors.raise_error (Printf.sprintf "There isn't any scope inside the program."))
| Some name, _ -> (
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| None ->
Errors.raise_error
(Printf.sprintf "There is no scope \"%s\" inside the program." name)
| Some uid -> uid)
in
Cli.debug_print "Desugaring...";
let prgm = Surface.Desugaring.desugar_program ctxt prgm in
Cli.debug_print "Collecting rules...";
let prgm = Desugared.Desugared_to_scope.translate_program prgm in
if backend = Cli.Scopelang then begin
let fmt, at_end =
match output_file with
| Some f ->
let oc = open_out f in
(Format.formatter_of_out_channel oc, fun _ -> close_out oc)
| None -> (Format.std_formatter, fun _ -> ())
in
if Option.is_some ex_scope then
Format.fprintf fmt "%a\n" Scopelang.Print.format_scope
(scope_uid, Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes)
else Format.fprintf fmt "%a\n" Scopelang.Print.format_program prgm;
at_end ();
exit 0
end;
Cli.debug_print "Translating to default calculus...";
let prgm, prgm_expr, type_ordering =
Scopelang.Scope_to_dcalc.translate_program prgm scope_uid
in
let prgm =
if optimize then begin
Cli.debug_print "Optimizing default calculus...";
Dcalc.Optimizations.optimize_program prgm
end
else prgm
in
if backend = Cli.Dcalc then begin
let fmt, at_end =
match output_file with
| Some f ->
let oc = open_out f in
(Format.formatter_of_out_channel oc, fun _ -> close_out oc)
| None -> (Format.std_formatter, fun _ -> ())
in
if Option.is_some ex_scope then
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_expr prgm.decl_ctx)
(let _, _, e = List.find (fun (name, _, _) -> name = scope_uid) prgm.scopes in
e)
else Format.fprintf fmt "%a\n" (Dcalc.Print.format_expr prgm.decl_ctx) prgm_expr;
at_end ();
exit 0
end;
Cli.debug_print "Typechecking...";
let _typ = Dcalc.Typing.infer_type prgm.decl_ctx prgm_expr in
(* Cli.debug_print (Format.asprintf "Typechecking results :@\n%a" Dcalc.Print.format_typ
typ); *)
match backend with
| Cli.Run ->
Cli.debug_print "Starting interpretation...";
let results = Dcalc.Interpreter.interpret_program prgm.decl_ctx prgm_expr in
let out_regex = Re.Pcre.regexp "\\_out$" in
let results =
List.map
(fun ((v1, v1_pos), e1) ->
let v1 = Re.Pcre.substitute ~rex:out_regex ~subst:(fun _ -> "") v1 in
((v1, v1_pos), e1))
results
in
let results =
List.sort (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) results
in
Cli.debug_print "End of interpretation";
Cli.result_print
(Format.asprintf "Computation successful!%s"
(if List.length results > 0 then " Results:" else ""));
List.iter
(fun ((var, _), result) ->
Cli.result_print
(Format.asprintf "@[<hov 2>%s@ =@ %a@]" var
(Dcalc.Print.format_expr prgm.decl_ctx)
result))
results;
0
| Cli.OCaml | Cli.Python ->
Cli.debug_print "Compiling program into lambda calculus...";
let prgm = Lcalc.Compile_with_exceptions.translate_program prgm in
let prgm =
if optimize then begin
Cli.debug_print "Optimizing lambda calculus...";
Lcalc.Optimizations.optimize_program prgm
end
else prgm
in
let source_file =
match source_file with
| FileName f -> f
| Contents _ ->
Errors.raise_error "This backend does not work if the input is not a file"
in
let output_file (extension : string) : string =
match output_file with
| Some f -> f
| None -> Filename.remove_extension source_file ^ extension
in
(match backend with
| Cli.OCaml ->
let output_file = output_file ".ml" in
Cli.debug_print (Printf.sprintf "Writing to %s..." output_file);
let oc = open_out output_file in
let fmt = Format.formatter_of_out_channel oc in
Cli.debug_print "Compiling program into OCaml...";
Lcalc.To_ocaml.format_program fmt prgm type_ordering;
close_out oc
| Cli.Python ->
let prgm = Scalc.Compile_from_lambda.translate_program prgm in
let output_file = output_file ".py" in
Cli.debug_print "Compiling program into Python...";
Cli.debug_print (Printf.sprintf "Writing to %s..." output_file);
let oc = open_out output_file in
let fmt = Format.formatter_of_out_channel oc in
Scalc.To_python.format_program fmt prgm type_ordering;
close_out oc
| _ -> assert false (* should not happen *));
0
| _ -> assert false
(* should not happen *))
with Errors.StructuredError (msg, pos) ->
Cli.error_print (Errors.print_structured_error msg pos);
-1
let main () =
let return_code = Cmdliner.Term.eval (Cli.catala_t (fun f -> driver (FileName f)), Cli.info) in
match return_code with
| `Ok 0 -> Cmdliner.Term.exit (`Ok 0)
| _ -> Cmdliner.Term.exit (`Error `Term)

33
compiler/dune Normal file
View File

@ -0,0 +1,33 @@
(library
(name driver)
(public_name catala.driver)
(libraries utils surface desugared literate dcalc lcalc scalc runtime)
(modules driver))
(library
(name runtime)
(public_name catala.runtime)
(libraries calendar zarith zarith_stubs_js)
(modules runtime))
(executable
(name catala_web)
(modes byte js)
(package catala)
(public_name catala_web)
(modules catala_web)
(preprocess
(pps js_of_ocaml-ppx))
(libraries catala.driver js_of_ocaml))
(executable
(name catala)
(modes native)
(package catala)
(modules catala)
(public_name catala)
(libraries catala.driver))
(documentation
(package catala)
(mld_files index))

89
compiler/index.mld Normal file
View File

@ -0,0 +1,89 @@
{0 The Catala compiler}
{1 Architecture}
The architecture of the Catala compiler is inspired by
{{: https://compcert.org/} CompCert} or the {{: https://nanopass.org/} Nanopass}
framework, and is structured around many intermediate representations connected
by successive translations passes.
Here is the recap picture of the different intermediate representations of the
Catala compiler (made with an {{: https://textik.com/#c1c1fecda5209492} ASCII diagram tool}):
{v
+---------------+
| |
| Surface AST |
| |
+---------------+
|
|
* Separate code from legislation |
* Remove syntactic sugars |
v
+---------------+
| |
| Desugared AST |
| |
+---------------+
|
|
* Build rule trees for each definition |
* Order variable computations inside scope |
v
+--------------------+
| |
| Scope language AST |
| |
+--------------------+
|
|
* Convert scopes into functions |
* Thunking of subscope arguments |
|
v
+----------------------+
| |
| Default calculus AST |
| |
+----------------------+
|
|
|
* Compile the default term |
|
v
+----------------------+
| |
| Lambda calculus AST |
| |
+----------------------+
v}
{1 List of top-level modules }
Each of those intermediate representation is bundled into its own `dune` bundle
module. Click on the items below if you want to dive straight into the signatures.
{!modules: Surface Desugared Scopelang Dcalc Lcalc }
More documentation can be found on each intermediate representations here.
{ul
{li {{: surface.html} The surface representation}}
{li {{: desugared.html} The desugared representation}}
{li {{: scopelang.html} The scope language }}
{li {{: dcalc.html} The default calculus}}
{li {{: lcalc.html} The lambda calculus}}
}
The main compilation chain is defined in:
{!modules: Driver}
Last, two more modules contain additional features for the compiler:
{ul
{li {{: literate.html} Literate programming}}
{li {{: utils.html} Compiler utilities}}
}

91
compiler/lcalc/ast.ml Normal file
View File

@ -0,0 +1,91 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
module D = Dcalc.Ast
type lit =
| LBool of bool
| LInt of Runtime.integer
| LRat of Runtime.decimal
| LMoney of Runtime.money
| LUnit
| LDate of Runtime.date
| LDuration of Runtime.duration
type except = ConflictError | EmptyError | NoValueProvided | Crash
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of expr Pos.marked list * D.StructName.t option
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of expr Pos.marked * int * D.StructName.t option * D.typ Pos.marked list
(** The [MarkedString.info] is the former struct field name *)
| EInj of expr Pos.marked * int * D.EnumName.t * D.typ Pos.marked list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of expr Pos.marked * expr Pos.marked list * D.EnumName.t
(** The [MarkedString.info] is the former enum case name *)
| EArray of expr Pos.marked list
| ELit of lit
| EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * D.typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAssert of expr Pos.marked
| EOp of D.operator
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| ERaise of except
| ECatch of expr Pos.marked * except * expr Pos.marked
module Var = struct
type t = expr Bindlib.var
let make (s : string Pos.marked) : t =
Bindlib.new_var
(fun (x : expr Bindlib.var) : expr -> EVar (x, Pos.get_position s))
(Pos.unmark s)
let compare x y = Bindlib.compare_vars x y
end
module VarMap = Map.Make (Var)
type vars = expr Bindlib.mvar
let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun x -> (x, pos)) (Bindlib.box_var x)
let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t)
(taus : D.typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun b -> (EAbs ((b, pos_binder), taus), pos)) (Bindlib.bind_mvar xs e)
let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t)
: expr Pos.marked Bindlib.box =
Bindlib.box_apply2 (fun e u -> (EApp (e, u), pos)) e (Bindlib.box_list u)
let make_let_in (x : Var.t) (tau : D.typ Pos.marked) (e1 : expr Pos.marked Bindlib.box)
(e2 : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box =
Bindlib.box_apply2
(fun e u -> (EApp (e, u), Pos.get_position (Bindlib.unbox e2)))
(make_abs
(Array.of_list [ x ])
e2
(Pos.get_position (Bindlib.unbox e2))
[ tau ]
(Pos.get_position (Bindlib.unbox e2)))
(Bindlib.box_list [ e1 ])
let handle_default = Var.make ("handle_default", Pos.no_pos)
type binder = (expr, expr Pos.marked) Bindlib.binder
type program = { decl_ctx : D.decl_ctx; scopes : (Var.t * expr Pos.marked) list }

97
compiler/lcalc/ast.mli Normal file
View File

@ -0,0 +1,97 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
(** Abstract syntax tree for the lambda calculus *)
(** {1 Abstract syntax tree} *)
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on
higher-order abstract syntax*)
type lit =
| LBool of bool
| LInt of Runtime.integer
| LRat of Runtime.decimal
| LMoney of Runtime.money
| LUnit
| LDate of Runtime.date
| LDuration of Runtime.duration
type except = ConflictError | EmptyError | NoValueProvided | Crash
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of expr Pos.marked list * Dcalc.Ast.StructName.t option
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of
expr Pos.marked * int * Dcalc.Ast.StructName.t option * Dcalc.Ast.typ Pos.marked list
(** The [MarkedString.info] is the former struct field name *)
| EInj of expr Pos.marked * int * Dcalc.Ast.EnumName.t * Dcalc.Ast.typ Pos.marked list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of expr Pos.marked * expr Pos.marked list * Dcalc.Ast.EnumName.t
(** The [MarkedString.info] is the former enum case name *)
| EArray of expr Pos.marked list
| ELit of lit
| EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * Dcalc.Ast.typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAssert of expr Pos.marked
| EOp of Dcalc.Ast.operator
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| ERaise of except
| ECatch of expr Pos.marked * except * expr Pos.marked
(** {1 Variable helpers} *)
module Var : sig
type t = expr Bindlib.var
val make : string Pos.marked -> t
val compare : t -> t -> int
end
module VarMap : Map.S with type key = Var.t
type vars = expr Bindlib.mvar
val make_var : Var.t Pos.marked -> expr Pos.marked Bindlib.box
val make_abs :
vars ->
expr Pos.marked Bindlib.box ->
Pos.t ->
Dcalc.Ast.typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
val make_app :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
val make_let_in :
Var.t ->
Dcalc.Ast.typ Pos.marked ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box
val handle_default : Var.t
type binder = (expr, expr Pos.marked) Bindlib.binder
type program = { decl_ctx : Dcalc.Ast.decl_ctx; scopes : (Var.t * expr Pos.marked) list }

73
compiler/lcalc/backends.ml Normal file
View File

@ -0,0 +1,73 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
let to_ascii (s : string) : string =
let out = ref "" in
CamomileLibraryDefault.Camomile.UTF8.iter
(fun c ->
let code = CamomileLibraryDefault.Camomile.UChar.uint_code c in
out :=
!out
^
match code with
| 0xc7 -> "C"
| 0xe7 -> "c"
| c when c >= 0xc0 && c <= 0xc6 -> "A"
| c when c >= 0xe0 && c <= 0xe6 -> "a"
| c when c >= 0xc8 && c <= 0xcb -> "E"
| c when c >= 0xe8 && c <= 0xeb -> "e"
| c when c >= 0xcc && c <= 0xcf -> "I"
| c when c >= 0xec && c <= 0xef -> "i"
| c when c >= 0xd2 && c <= 0xd6 -> "O"
| c when c >= 0xf2 && c <= 0xf6 -> "o"
| c when c >= 0xd9 && c <= 0xdc -> "U"
| c when c >= 0xf9 && c <= 0xfc -> "u"
| _ ->
if code > 128 then "_"
else String.make 1 (CamomileLibraryDefault.Camomile.UChar.char_of c))
s;
!out
let to_lowercase (s : string) : string =
let is_first = ref true in
let out = ref "" in
CamomileLibraryDefault.Camomile.UTF8.iter
(fun c ->
let is_uppercase = Dcalc.Print.is_uppercase c in
out :=
!out
^ (if is_uppercase && not !is_first then "_" else "")
^ String.lowercase_ascii (String.make 1 (CamomileLibraryDefault.Camomile.UChar.char_of c));
is_first := false)
s;
!out
let to_uppercase (s : string) : string =
let last_was_underscore = ref false in
let is_first = ref true in
let out = ref "" in
CamomileLibraryDefault.Camomile.UTF8.iter
(fun c ->
let is_underscore = c = CamomileLibraryDefault.Camomile.UChar.of_char '_' in
let c_string = String.make 1 (CamomileLibraryDefault.Camomile.UChar.char_of c) in
out :=
!out
^
if is_underscore then ""
else if !last_was_underscore || !is_first then String.uppercase_ascii c_string
else c_string;
last_was_underscore := is_underscore;
is_first := false)
s;
!out

23
compiler/lcalc/backends.mli Normal file
View File

@ -0,0 +1,23 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
val to_ascii : string -> string
(** Removes all non-ASCII diacritics from a string by converting them to their base letter in the
Latin alphabet *)
val to_lowercase : string -> string
(** Converts CamlCase into snake_case *)
val to_uppercase : string -> string
(** Convertes snake_case into CamlCase *)

150
compiler/lcalc/compile_with_exceptions.ml Normal file
View File

@ -0,0 +1,150 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
module D = Dcalc.Ast
module A = Ast
type ctx = A.expr Pos.marked Bindlib.box D.VarMap.t
let translate_lit (l : D.lit) : A.expr =
match l with
| D.LBool l -> A.ELit (A.LBool l)
| D.LInt i -> A.ELit (A.LInt i)
| D.LRat r -> A.ELit (A.LRat r)
| D.LMoney m -> A.ELit (A.LMoney m)
| D.LUnit -> A.ELit A.LUnit
| D.LDate d -> A.ELit (A.LDate d)
| D.LDuration d -> A.ELit (A.LDuration d)
| D.LEmptyError -> A.ERaise A.EmptyError
let thunk_expr (e : A.expr Pos.marked Bindlib.box) (pos : Pos.t) : A.expr Pos.marked Bindlib.box =
let dummy_var = A.Var.make ("_", pos) in
A.make_abs [| dummy_var |] e pos [ (D.TAny, pos) ] pos
let rec translate_default (ctx : ctx) (exceptions : D.expr Pos.marked list)
(just : D.expr Pos.marked) (cons : D.expr Pos.marked) (pos_default : Pos.t) :
A.expr Pos.marked Bindlib.box =
let exceptions =
List.map (fun except -> thunk_expr (translate_expr ctx except) pos_default) exceptions
in
let exceptions =
A.make_app
(A.make_var (A.handle_default, pos_default))
[
Bindlib.box_apply
(fun exceptions -> (A.EArray exceptions, pos_default))
(Bindlib.box_list exceptions);
thunk_expr (translate_expr ctx just) pos_default;
thunk_expr (translate_expr ctx cons) pos_default;
]
pos_default
in
exceptions
and translate_expr (ctx : ctx) (e : D.expr Pos.marked) : A.expr Pos.marked Bindlib.box =
match Pos.unmark e with
| D.EVar v -> D.VarMap.find (Pos.unmark v) ctx
| D.ETuple (args, s) ->
Bindlib.box_apply
(fun args -> Pos.same_pos_as (A.ETuple (args, s)) e)
(Bindlib.box_list (List.map (translate_expr ctx) args))
| D.ETupleAccess (e1, i, s, ts) ->
Bindlib.box_apply
(fun e1 -> Pos.same_pos_as (A.ETupleAccess (e1, i, s, ts)) e)
(translate_expr ctx e1)
| D.EInj (e1, i, en, ts) ->
Bindlib.box_apply
(fun e1 -> Pos.same_pos_as (A.EInj (e1, i, en, ts)) e)
(translate_expr ctx e1)
| D.EMatch (e1, cases, en) ->
Bindlib.box_apply2
(fun e1 cases -> Pos.same_pos_as (A.EMatch (e1, cases, en)) e)
(translate_expr ctx e1)
(Bindlib.box_list (List.map (translate_expr ctx) cases))
| D.EArray es ->
Bindlib.box_apply
(fun es -> Pos.same_pos_as (A.EArray es) e)
(Bindlib.box_list (List.map (translate_expr ctx) es))
| D.ELit l -> Bindlib.box (Pos.same_pos_as (translate_lit l) e)
| D.EOp op -> Bindlib.box (Pos.same_pos_as (A.EOp op) e)
| D.EIfThenElse (e1, e2, e3) ->
Bindlib.box_apply3
(fun e1 e2 e3 -> Pos.same_pos_as (A.EIfThenElse (e1, e2, e3)) e)
(translate_expr ctx e1) (translate_expr ctx e2) (translate_expr ctx e3)
| D.EAssert e1 ->
Bindlib.box_apply (fun e1 -> Pos.same_pos_as (A.EAssert e1) e) (translate_expr ctx e1)
| D.ErrorOnEmpty arg ->
Bindlib.box_apply
(fun arg ->
Pos.same_pos_as
(A.ECatch (arg, A.EmptyError, Pos.same_pos_as (A.ERaise A.NoValueProvided) e))
e)
(translate_expr ctx arg)
| D.EApp (e1, args) ->
Bindlib.box_apply2
(fun e1 args -> Pos.same_pos_as (A.EApp (e1, args)) e)
(translate_expr ctx e1)
(Bindlib.box_list (List.map (translate_expr ctx) args))
| D.EAbs ((binder, pos_binder), ts) ->
let vars, body = Bindlib.unmbind binder in
let ctx, lc_vars =
Array.fold_right
(fun var (ctx, lc_vars) ->
let lc_var = A.Var.make (Bindlib.name_of var, pos_binder) in
let lc_var_expr = A.make_var (lc_var, pos_binder) in
(D.VarMap.add var lc_var_expr ctx, lc_var :: lc_vars))
vars (ctx, [])
in
let lc_vars = Array.of_list lc_vars in
let new_body = translate_expr ctx body in
let new_binder = Bindlib.bind_mvar lc_vars new_body in
Bindlib.box_apply
(fun new_binder -> Pos.same_pos_as (A.EAbs ((new_binder, pos_binder), ts)) e)
new_binder
| D.EDefault ([ exn ], just, cons) when !Cli.optimize_flag ->
Bindlib.box_apply3
(fun exn just cons ->
Pos.same_pos_as
(A.ECatch
( exn,
A.EmptyError,
Pos.same_pos_as
(A.EIfThenElse (just, cons, Pos.same_pos_as (A.ERaise A.EmptyError) e))
e ))
e)
(translate_expr ctx exn) (translate_expr ctx just) (translate_expr ctx cons)
| D.EDefault (exceptions, just, cons) ->
translate_default ctx exceptions just cons (Pos.get_position e)
let translate_program (prgm : D.program) : A.program =
{
scopes =
(let acc, _ =
List.fold_left
(fun ((acc, ctx) : 'a * A.Var.t D.VarMap.t) (_, n, e) ->
let new_n = A.Var.make (Bindlib.name_of n, Pos.no_pos) in
let new_acc =
( new_n,
Bindlib.unbox
(translate_expr (D.VarMap.map (fun v -> A.make_var (v, Pos.no_pos)) ctx) e) )
:: acc
in
let new_ctx = D.VarMap.add n new_n ctx in
(new_acc, new_ctx))
([], D.VarMap.empty) prgm.scopes
in
List.rev acc);
decl_ctx = prgm.decl_ctx;
}

17
compiler/lcalc/compile_with_exceptions.mli Normal file
View File

@ -0,0 +1,17 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Translation from the default calculus to the lambda calculus *)
val translate_program : Dcalc.Ast.program -> Ast.program

8
compiler/lcalc/dune Normal file
View File

@ -0,0 +1,8 @@
(library
(name lcalc)
(public_name catala.lcalc)
(libraries bindlib dcalc scopelang runtime))
(documentation
(package catala)
(mld_files lcalc))

33
compiler/lcalc/lcalc.mld Normal file
View File

@ -0,0 +1,33 @@
{0 Lambda calculus}
This representation is the fifth in the compilation chain
(see {{: index.html#architecture} Architecture}). Its main difference
with the previous {{: Dcalc.html} default calculus} is the absence of the
default term, which has been eliminated through diverse compilation schemes.
The module describing the abstract syntax tree is:
{!modules: Lcalc.Ast}
This intermediate representation corresponds to the lambda calculus
presented in the {{: https://arxiv.org/abs/2103.03198} Catala formalization}.
{1 Compilation from default calculus }
Related modules:
{!modules: Lcalc.Compile_with_exceptions}
{!module: Lcalc.Compile_with_exceptions} compiles the default term of the
default calculus using catchable exceptions. This compilation scheme has been
certified.
{1 Backends}
Related modules:
{!modules: Lcalc.To_ocaml Lcalc.To_python Lcalc.Backends}
The OCaml backend of the lambda calculus is merely a syntactic formatting,
since the core of the OCaml value language is effectively a lambda calculus.

72
compiler/lcalc/optimizations.ml Normal file
View File

@ -0,0 +1,72 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Ast
let rec peephole_expr (e : expr Pos.marked) : expr Pos.marked Bindlib.box =
match Pos.unmark e with
| EVar (v, pos) -> Bindlib.box_apply (fun v -> (v, pos)) (Bindlib.box_var v)
| ETuple (args, n) ->
Bindlib.box_apply
(fun args -> (ETuple (args, n), Pos.get_position e))
(Bindlib.box_list (List.map peephole_expr args))
| ETupleAccess (e1, i, n, ts) ->
Bindlib.box_apply
(fun e1 -> (ETupleAccess (e1, i, n, ts), Pos.get_position e))
(peephole_expr e1)
| EInj (e1, i, n, ts) ->
Bindlib.box_apply (fun e1 -> (EInj (e1, i, n, ts), Pos.get_position e)) (peephole_expr e1)
| EMatch (arg, cases, n) ->
Bindlib.box_apply2
(fun arg cases -> (EMatch (arg, cases, n), Pos.get_position e))
(peephole_expr arg)
(Bindlib.box_list (List.map peephole_expr cases))
| EArray args ->
Bindlib.box_apply
(fun args -> (EArray args, Pos.get_position e))
(Bindlib.box_list (List.map peephole_expr args))
| EAbs ((binder, pos_binder), ts) ->
let vars, body = Bindlib.unmbind binder in
let body = peephole_expr body in
Bindlib.box_apply
(fun binder -> (EAbs ((binder, pos_binder), ts), Pos.get_position e))
(Bindlib.bind_mvar vars body)
| EApp (e1, args) ->
Bindlib.box_apply2
(fun e1 args -> (EApp (e1, args), Pos.get_position e))
(peephole_expr e1)
(Bindlib.box_list (List.map peephole_expr args))
| EAssert e1 -> Bindlib.box_apply (fun e1 -> (EAssert e1, Pos.get_position e)) (peephole_expr e1)
| EIfThenElse (e1, e2, e3) ->
Bindlib.box_apply3
(fun e1 e2 e3 ->
match Pos.unmark e1 with
| ELit (LBool true) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool true), _) ]) -> e2
| ELit (LBool false) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool false), _) ]) -> e3
| _ -> (EIfThenElse (e1, e2, e3), Pos.get_position e))
(peephole_expr e1) (peephole_expr e2) (peephole_expr e3)
| ECatch (e1, exn, e2) ->
Bindlib.box_apply2
(fun e1 e2 ->
( (match Pos.unmark e2 with
| ERaise exn2 when exn2 = exn -> Pos.unmark e1
| _ -> ECatch (e1, exn, e2)),
Pos.get_position e ))
(peephole_expr e1) (peephole_expr e2)
| ERaise _ | ELit _ | EOp _ -> Bindlib.box e
let peephole_optimizations (p : program) : program =
{ p with scopes = List.map (fun (var, e) -> (var, Bindlib.unbox (peephole_expr e))) p.scopes }
let optimize_program (p : program) : program = peephole_optimizations p

17
compiler/lcalc/optimizations.mli Normal file
View File

@ -0,0 +1,17 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Ast
val optimize_program : program -> program

182
compiler/lcalc/print.ml Normal file
View File

@ -0,0 +1,182 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Ast
let is_uppercase (x : CamomileLibraryDefault.Camomile.UChar.t) : bool =
try
match CamomileLibraryDefault.Camomile.UCharInfo.general_category x with
| `Ll -> false
| `Lu -> true
| _ -> false
with _ -> true
let begins_with_uppercase (s : string) : bool =
let first_letter = CamomileLibraryDefault.Camomile.UTF8.get s 0 in
is_uppercase first_letter
(** @note: (EmileRolley) seems to be factorizable with Dcalc.Print.format_lit. *)
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
match Pos.unmark l with
| LBool b -> Format.fprintf fmt "%b" b
| LInt i -> Format.fprintf fmt "%s" (Runtime.integer_to_string i)
| LUnit -> Format.fprintf fmt "()"
| LRat i ->
Format.fprintf fmt "%s"
(Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i)
| LMoney e -> (
match !Utils.Cli.locale_lang with
| En -> Format.fprintf fmt "$%s" (Runtime.money_to_string e)
| Fr -> Format.fprintf fmt "%s €" (Runtime.money_to_string e)
| Pl -> Format.fprintf fmt "%s PLN" (Runtime.money_to_string e))
| LDate d -> Format.fprintf fmt "%s" (Runtime.date_to_string d)
| LDuration d -> Format.fprintf fmt "%s" (Runtime.duration_to_string d)
let format_uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) : unit =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info ->
Format.fprintf fmt "%s"
(Utils.Cli.print_with_style
(if begins_with_uppercase (Pos.unmark info) then [ ANSITerminal.red ] else [])
"%s"
(Format.asprintf "%a" Utils.Uid.MarkedString.format_info info))))
infos
let format_exception (fmt : Format.formatter) (exn : except) : unit =
Format.fprintf fmt
(match exn with
| EmptyError -> "EmptyError"
| ConflictError -> "ConflictError"
| Crash -> "Crash"
| NoValueProvided -> "NoValueProvided")
let format_keyword (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.red ] "%s" s)
let format_punctuation (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.cyan ] "%s" s)
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
Format.fprintf fmt "%s" (Bindlib.name_of v)
let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked) : unit
=
let format_expr = format_expr ctx in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
if needs_parens e then
Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e format_punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Pos.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation ")"
| ETuple (es, Some s) ->
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a%a%a@]@]" Dcalc.Ast.StructName.format_t s
format_punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a%a%a%a %a" format_punctuation "\""
Dcalc.Ast.StructFieldName.format_t struct_field format_punctuation "\""
format_punctuation ":" format_expr e))
(List.combine es (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs)))
format_punctuation "}"
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation "]"
| ETupleAccess (e1, n, s, _ts) -> (
match s with
| None -> Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n
| Some s ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_punctuation "." format_punctuation
"\"" Dcalc.Ast.StructFieldName.format_t
(fst (List.nth (Dcalc.Ast.StructMap.find s ctx.ctx_structs) n))
format_punctuation "\"")
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Ast.EnumConstructor.format_t
(fst (List.nth (Dcalc.Ast.EnumMap.find en ctx.ctx_enums) n))
format_expr e
| EMatch (e, es, e_name) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ @[<hov 2>%a@]@]" format_keyword "match" format_expr e
format_keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n| ")
(fun fmt (e, c) ->
Format.fprintf fmt "@[<hov 2>%a%a@ %a@]" Dcalc.Ast.EnumConstructor.format_t c
format_punctuation ":" format_expr e))
(List.combine es (List.map fst (Dcalc.Ast.EnumMap.find e_name ctx.ctx_enums)))
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
| EApp ((EAbs ((binder, _), taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in
Format.fprintf fmt "%a%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
(fun fmt (x, tau, arg) ->
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a@ %a@ %a@]@ %a@ %a@]@ %a@\n" format_keyword
"let" format_var x format_punctuation ":" (Dcalc.Print.format_typ ctx) tau
format_punctuation "=" format_expr arg format_keyword "in"))
xs_tau_arg format_expr body
| EAbs ((binder, _), taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>%a @[<hov 2>%a@] %a@ %a@]" format_punctuation "λ"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau) ->
Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var x format_punctuation
":" (Dcalc.Print.format_typ ctx) tau format_punctuation ")"))
xs_tau format_punctuation "→" format_expr body
| EApp ((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" Dcalc.Print.format_binop (op, Pos.no_pos)
format_with_parens arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 Dcalc.Print.format_binop
(op, Pos.no_pos) format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_unop (op, Pos.no_pos)
format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if" format_expr e1
format_keyword "then" format_expr e2 format_keyword "else" format_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos)
| ECatch (e1, exn, e2) ->
Format.fprintf fmt "@[<hov 2>try@ %a@ with@ %a ->@ %a@]" format_with_parens e1
format_exception exn format_with_parens e2
| ERaise exn -> Format.fprintf fmt "raise@ %a" format_exception exn
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" format_keyword "assert" format_punctuation "("
format_expr e' format_punctuation ")"

31
compiler/lcalc/print.mli Normal file
View File

@ -0,0 +1,31 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
(** {1 Helpers} *)
val is_uppercase : CamomileLibraryDefault.Camomile.UChar.t -> bool
val begins_with_uppercase : string -> bool
(** {1 Formatters} *)
val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val format_lit : Format.formatter -> Ast.lit Pos.marked -> unit
val format_var : Format.formatter -> Ast.Var.t -> unit
val format_expr : Dcalc.Ast.decl_ctx -> Format.formatter -> Ast.expr Pos.marked -> unit

438
compiler/lcalc/to_ocaml.ml Normal file
View File

@ -0,0 +1,438 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Ast
open Backends
module D = Dcalc.Ast
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
match Pos.unmark l with
| LBool b -> Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LBool b) l)
| LInt i -> Format.fprintf fmt "integer_of_string@ \"%s\"" (Runtime.integer_to_string i)
| LUnit -> Dcalc.Print.format_lit fmt (Pos.same_pos_as Dcalc.Ast.LUnit l)
| LRat i ->
Format.fprintf fmt "decimal_of_string \"%a\"" Dcalc.Print.format_lit
(Pos.same_pos_as (Dcalc.Ast.LRat i) l)
| LMoney e ->
Format.fprintf fmt "money_of_cents_string@ \"%s\""
(Runtime.integer_to_string (Runtime.money_to_cents e))
| LDate d ->
Format.fprintf fmt "date_of_numbers %d %d %d"
(Runtime.integer_to_int (Runtime.year_of_date d))
(Runtime.integer_to_int (Runtime.month_number_of_date d))
(Runtime.integer_to_int (Runtime.day_of_month_of_date d))
| LDuration d ->
let years, months, days = Runtime.duration_to_years_months_days d in
Format.fprintf fmt "duration_of_numbers %d %d %d" years months days
let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) =
Format.fprintf fmt "%s"
(match k with KInt -> "!" | KRat -> "&" | KMoney -> "$" | KDate -> "@" | KDuration -> "^")
let format_log_entry (fmt : Format.formatter) (entry : Dcalc.Ast.log_entry) : unit =
Format.fprintf fmt "%s"
(match entry with
| VarDef _ -> ":="
| BeginCall -> "→ "
| EndCall -> "← "
| PosRecordIfTrueBool -> "☛ ")
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : unit =
match Pos.unmark op with
| Add k -> Format.fprintf fmt "+%a" format_op_kind k
| Sub k -> Format.fprintf fmt "-%a" format_op_kind k
| Mult k -> Format.fprintf fmt "*%a" format_op_kind k
| Div k -> Format.fprintf fmt "/%a" format_op_kind k
| And -> Format.fprintf fmt "%s" "&&"
| Or -> Format.fprintf fmt "%s" "||"
| Eq -> Format.fprintf fmt "%s" "="
| Neq | Xor -> Format.fprintf fmt "%s" "<>"
| Lt k -> Format.fprintf fmt "%s%a" "<" format_op_kind k
| Lte k -> Format.fprintf fmt "%s%a" "<=" format_op_kind k
| Gt k -> Format.fprintf fmt "%s%a" ">" format_op_kind k
| Gte k -> Format.fprintf fmt "%s%a" ">=" format_op_kind k
| Concat -> Format.fprintf fmt "@"
| Map -> Format.fprintf fmt "Array.map"
| Filter -> Format.fprintf fmt "array_filter"
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : unit =
match Pos.unmark op with Fold -> Format.fprintf fmt "Array.fold_left"
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) : unit =
Format.fprintf fmt "@[<hov 2>[%a]@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt info -> Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info))
uids
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
Format.fprintf fmt "@[<hov 2>[%a]@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt info -> Format.fprintf fmt "\"%s\"" info))
uids
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit =
match Pos.unmark op with
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
| Not -> Format.fprintf fmt "%s" "not"
| Log (entry, infos) ->
Format.fprintf fmt "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry format_uid_list
infos
| Length -> Format.fprintf fmt "%s" "array_length"
| IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer"
| GetDay -> Format.fprintf fmt "%s" "day_of_month_of_date"
| GetMonth -> Format.fprintf fmt "%s" "month_number_of_date"
| GetYear -> Format.fprintf fmt "%s" "year_of_date"
let avoid_keywords (s : string) : string =
if
match s with
(* list taken from http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#sss:keywords *)
| "and" | "as" | "assert" | "asr" | "begin" | "class" | "constraint" | "do" | "done" | "downto"
| "else" | "end" | "exception" | "external" | "false" | "for" | "fun" | "function" | "functor"
| "if" | "in" | "include" | "inherit" | "initializer" | "land" | "lazy" | "let" | "lor" | "lsl"
| "lsr" | "lxor" | "match" | "method" | "mod" | "module" | "mutable" | "new" | "nonrec"
| "object" | "of" | "open" | "or" | "private" | "rec" | "sig" | "struct" | "then" | "to"
| "true" | "try" | "type" | "val" | "virtual" | "when" | "while" | "with" ->
true
| _ -> false
then s ^ "_"
else s
let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_lowercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v))))
let format_struct_field_name (fmt : Format.formatter) (v : Dcalc.Ast.StructFieldName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v)))
let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords (to_lowercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v))))
let format_enum_cons_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumConstructor.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v)))
let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Pos.marked) : unit =
match Pos.unmark ty with
| D.TLit D.TUnit -> Format.fprintf fmt "embed_unit"
| D.TLit D.TBool -> Format.fprintf fmt "embed_bool"
| D.TLit D.TInt -> Format.fprintf fmt "embed_integer"
| D.TLit D.TRat -> Format.fprintf fmt "embed_decimal"
| D.TLit D.TMoney -> Format.fprintf fmt "embed_money"
| D.TLit D.TDate -> Format.fprintf fmt "embed_date"
| D.TLit D.TDuration -> Format.fprintf fmt "embed_duration"
| D.TTuple (_, Some s_name) -> Format.fprintf fmt "embed_%a" format_struct_name s_name
| D.TEnum (_, e_name) -> Format.fprintf fmt "embed_%a" format_enum_name e_name
| D.TArray ty -> Format.fprintf fmt "embed_array (%a)" typ_embedding_name ty
| _ -> Format.fprintf fmt "unembeddable"
let typ_needs_parens (e : Dcalc.Ast.typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : unit =
let format_typ = format_typ in
let format_typ_with_parens (fmt : Format.formatter) (t : Dcalc.Ast.typ Pos.marked) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Pos.unmark typ with
| TLit l -> Format.fprintf fmt "%a" Dcalc.Print.format_tlit l
| TTuple (ts, None) ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
(fun fmt t -> Format.fprintf fmt "%a" format_typ_with_parens t))
ts
| TTuple (_, Some s) -> Format.fprintf fmt "%a" format_struct_name s
| TEnum (_, e) -> Format.fprintf fmt "%a" format_enum_name e
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a ->@ %a@]" format_typ_with_parens t1 format_typ_with_parens t2
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "_"
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
let lowercase_name = to_lowercase (to_ascii (Bindlib.name_of v)) in
let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_") lowercase_name
in
let lowercase_name = avoid_keywords (to_ascii lowercase_name) in
if lowercase_name = "handle_default" || Dcalc.Print.begins_with_uppercase (Bindlib.name_of v) then
Format.fprintf fmt "%s" lowercase_name
else if lowercase_name = "_" then Format.fprintf fmt "%s" lowercase_name
else Format.fprintf fmt "%s_" lowercase_name
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with
| EApp ((EAbs (_, _), _), _) | ELit (LBool _ | LUnit) | EVar _ | ETuple _ | EOp _ -> false
| _ -> true
let format_exception (fmt : Format.formatter) (exc : except Pos.marked) : unit =
match Pos.unmark exc with
| ConflictError -> Format.fprintf fmt "ConflictError"
| EmptyError -> Format.fprintf fmt "EmptyError"
| Crash -> Format.fprintf fmt "Crash"
| NoValueProvided ->
let pos = Pos.get_position exc in
Format.fprintf fmt
"(NoValueProvided@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ \
end_line=%d; end_column=%d;@ law_headings=%a}@])"
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos)
let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked) : unit
=
let format_expr = format_expr ctx in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
if needs_parens e then Format.fprintf fmt "(%a)" format_expr e
else Format.fprintf fmt "%a" format_expr e
in
match Pos.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
es
| ETuple (es, Some s) ->
if List.length es = 0 then Format.fprintf fmt "()"
else
Format.fprintf fmt "{@[<hov 2>%a@]}"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "@[<hov 2>%a =@ %a@]" format_struct_field_name struct_field
format_with_parens e))
(List.combine es (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs)))
| EArray es ->
Format.fprintf fmt "@[<hov 2>[|%a|]@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
es
| ETupleAccess (e1, n, s, ts) -> (
match s with
| None ->
Format.fprintf fmt "let@ %a@ = %a@ in@ x"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt i -> Format.fprintf fmt "%s" (if i = n then "x" else "_")))
(List.mapi (fun i _ -> i) ts)
format_with_parens e1
| Some s ->
Format.fprintf fmt "%a.%a" format_with_parens e1 format_struct_field_name
(fst (List.nth (Dcalc.Ast.StructMap.find s ctx.ctx_structs) n)))
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_enum_cons_name
(fst (List.nth (Dcalc.Ast.EnumMap.find en ctx.ctx_enums) n))
format_with_parens e
| EMatch (e, es, e_name) ->
Format.fprintf fmt "@[<hov 2>match@ %a@]@ with@\n%a" format_with_parens e
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n| ")
(fun fmt (e, c) ->
Format.fprintf fmt "%a %a" format_enum_cons_name c
(fun fmt e ->
match Pos.unmark e with
| EAbs ((binder, _), _) ->
let xs, body = Bindlib.unmbind binder in
Format.fprintf fmt "%a ->@[<hov 2>@ %a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,")
(fun fmt x -> Format.fprintf fmt "%a" format_var x))
(Array.to_list xs) format_with_parens body
| _ -> assert false
(* should not happen *))
e))
(List.combine es (List.map fst (Dcalc.Ast.EnumMap.find e_name ctx.ctx_enums)))
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
| EApp ((EAbs ((binder, _), taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in
Format.fprintf fmt "%a%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
(fun fmt (x, tau, arg) ->
Format.fprintf fmt "@[<hov 2>let@ %a@ :@ %a@ =@ %a@]@ in@\n" format_var x format_typ
tau format_with_parens arg))
xs_tau_arg format_with_parens body
| EAbs ((binder, _), taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>fun@ %a ->@ %a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau) ->
Format.fprintf fmt "@[<hov 2>(%a:@ %a)@]" format_var x format_typ tau))
xs_tau format_expr body
| EApp ((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop (op, Pos.no_pos) format_with_parens
arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
(op, Pos.no_pos) format_with_parens arg2
| EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ])
when !Cli.trace_flag ->
Format.fprintf fmt "(log_begin_call@ %a@ %a@ %a)" format_uid_list info format_with_parens f
format_with_parens arg
| EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [ arg1 ]) when !Cli.trace_flag ->
Format.fprintf fmt "(log_variable_definition@ %a@ (%a)@ %a)" format_uid_list info
typ_embedding_name (tau, Pos.no_pos) format_with_parens arg1
| EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) when !Cli.trace_flag ->
Format.fprintf fmt
"(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ \
end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a)"
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos)
format_with_parens arg1
| EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) when !Cli.trace_flag ->
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info format_with_parens arg1
| EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "@[<hov 2> if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@]"
format_with_parens e1 format_with_parens e2 format_with_parens e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>if @ %a@ then@ ()@ else@ raise AssertionFailed@]"
format_with_parens e'
| ERaise exc -> Format.fprintf fmt "raise@ %a" format_exception (exc, Pos.get_position e)
| ECatch (e1, exc, e2) ->
Format.fprintf fmt "@[<hov 2>try@ %a@ with@ %a@ ->@ %a@]" format_with_parens e1
format_exception
(exc, Pos.get_position e)
format_with_parens e2
let format_struct_embedding (fmt : Format.formatter)
((struct_name, struct_fields) : D.StructName.t * (D.StructFieldName.t * D.typ Pos.marked) list)
=
if List.length struct_fields = 0 then
Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n" format_struct_name
struct_name format_struct_name struct_name
else
Format.fprintf fmt
"@[<hov 2>let embed_%a (x: %a) : runtime_value =@ Struct([\"%a\"],@ @[<hov 2>[%a]@])@]@\n@\n"
format_struct_name struct_name format_struct_name struct_name D.StructName.format_t
struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" D.StructFieldName.format_t struct_field
typ_embedding_name struct_field_type format_struct_field_name struct_field))
struct_fields
let format_enum_embedding (fmt : Format.formatter)
((enum_name, enum_cases) : D.EnumName.t * (D.EnumConstructor.t * D.typ Pos.marked) list) =
if List.length enum_cases = 0 then
Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n" format_enum_name
enum_name format_enum_name enum_name
else
Format.fprintf fmt
"@[<hov 2>let embed_%a (x: %a) : runtime_value =@ Enum([\"%a\"],@ @[<hov 2>match x with@ \
%a@])@]@\n\
@\n"
format_enum_name enum_name format_enum_name enum_name D.EnumName.format_t enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "@[<hov 2>| %a x ->@ (\"%a\", %a x)@]" format_enum_cons_name enum_cons
D.EnumConstructor.format_t enum_cons typ_embedding_name enum_cons_type))
enum_cases
let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Format.formatter)
(ctx : D.decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
if List.length struct_fields = 0 then
Format.fprintf fmt "type %a = unit@\n@\n" format_struct_name struct_name
else
Format.fprintf fmt "type %a = {@\n@[<hov 2> %a@]@\n}@\n@\n" format_struct_name struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ
struct_field_type))
struct_fields;
if !Cli.trace_flag then format_struct_embedding fmt (struct_name, struct_fields)
in
let format_enum_decl fmt (enum_name, enum_cons) =
if List.length enum_cons = 0 then
Format.fprintf fmt "type %a = unit@\n@\n" format_enum_name enum_name
else
Format.fprintf fmt "type %a =@\n@[<hov 2> %a@]@\n@\n" format_enum_name enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ
enum_cons_type))
enum_cons;
if !Cli.trace_flag then format_enum_embedding fmt (enum_name, enum_cons)
in
let is_in_type_ordering s =
List.exists
(fun struct_or_enum ->
match struct_or_enum with
| Scopelang.Dependency.TVertex.Enum _ -> false
| Scopelang.Dependency.TVertex.Struct s' -> s = s')
type_ordering
in
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(Dcalc.Ast.StructMap.bindings
(Dcalc.Ast.StructMap.filter (fun s _ -> not (is_in_type_ordering s)) ctx.ctx_structs))
in
List.iter
(fun struct_or_enum ->
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
Format.fprintf fmt "%a@\n@\n" format_struct_decl
(s, Dcalc.Ast.StructMap.find s ctx.Dcalc.Ast.ctx_structs)
| Scopelang.Dependency.TVertex.Enum e ->
Format.fprintf fmt "%a@\n@\n" format_enum_decl
(e, Dcalc.Ast.EnumMap.find e ctx.Dcalc.Ast.ctx_enums))
(type_ordering @ scope_structs)
let format_program (fmt : Format.formatter) (p : Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
Cli.style_flag := false;
Format.fprintf fmt
"(** This file has been generated by the Catala compiler, do not edit! *)@\n\
@\n\
open Runtime@\n\
@\n\
[@@@@@@ocaml.warning \"-4-26-27-32-41-42\"]@\n\
@\n\
%a@\n\
@\n\
%a@?"
(format_ctx type_ordering) p.decl_ctx
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n")
(fun fmt (name, e) ->
Format.fprintf fmt "@[<hov 2>let@ %a@ =@ %a@]" format_var name (format_expr p.decl_ctx) e))
p.scopes

18
compiler/lcalc/to_ocaml.mli Normal file
View File

@ -0,0 +1,18 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Formats a lambda calculus program into a valid OCaml program *)
val format_program : Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit
(** Usage [format_program fmt p type_dependencies_ordering] *)

0
src/catala/literate_programming/dune → compiler/literate/dune
View File

133
src/catala/literate_programming/html.ml → compiler/literate/html.ml
View File

@ -1,6 +1,6 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
@ -15,9 +15,8 @@
(** This modules weaves the source code and the legislative text together into a document that law
professionals can understand. *)
module Pos = Utils.Pos
module Cli = Utils.Cli
module Errors = Utils.Errors
open Utils
open Literate_common
module A = Surface.Ast
module P = Printf
module R = Re.Pcre
@ -38,13 +37,34 @@ let raise_failed_pygments (command : string) (error_code : int) : 'a =
(Printf.sprintf "Weaving to HTML failed: pygmentize command \"%s\" returned with error code %d"
command error_code)
(** Partial application allowing to remove first code lines of [<td class="code">] and
[<td class="linenos">] generated HTML. Basically, remove all code block first lines. *)
let remove_cb_first_lines : string -> string =
R.substitute ~rex:(R.regexp "<pre>.*\n") ~subst:(function _ -> "<pre>\n")
(** Partial application allowing to remove last code lines of [<td class="code">] and
[<td class="linenos">] generated HTML. Basically, remove all code block last lines. *)
let remove_cb_last_lines : string -> string =
R.substitute ~rex:(R.regexp "<.*\n*</pre>") ~subst:(function _ -> "</pre>")
(** Partial application allowing to substitute operators by their unicode representation. *)
let substitute_arithmetics_op : string -> string =
R.substitute ~rex:(R.regexp "!=|<=|>=|--|->|\\*|\\/") ~subst:(function
| "!=" -> "≠"
| "<=" -> "≤"
| ">=" -> "≥"
| "--" -> "—"
| "->" -> "→"
| "*" -> "×"
| "/" -> "÷"
| s -> s)
(** Usage: [wrap_html source_files custom_pygments language fmt wrapped]
Prints an HTML complete page structure around the [wrapped] content. *)
let wrap_html (source_files : string list) (custom_pygments : string option)
(language : Cli.backend_lang) (fmt : Format.formatter) (wrapped : Format.formatter -> unit) :
unit =
let pygments = match custom_pygments with Some p -> p | None -> "pygmentize" in
let wrap_html (source_files : string list) (language : Cli.backend_lang) (fmt : Format.formatter)
(wrapped : Format.formatter -> unit) : unit =
let pygments = "pygmentize" in
let css_file = Filename.temp_file "catala_css_pygments" "" in
let pygments_args = [| "-f"; "html"; "-S"; "colorful"; "-a"; ".catala-code" |] in
let cmd =
@ -71,15 +91,8 @@ let wrap_html (source_files : string list) (custom_pygments : string option)
<ul>\n\
%s\n\
</ul>\n"
css_as_string
( match language with
| `Fr -> "Implémentation de texte législatif"
| `En -> "Legislative text implementation" )
(match language with `Fr -> "Document généré par" | `En -> "Document generated by")
Utils.Cli.version
( match language with
| `Fr -> "Fichiers sources tissés dans ce document"
| `En -> "Source files weaved in this document" )
css_as_string (literal_title language) (literal_generated_by language) Utils.Cli.version
(literal_source_files language)
(String.concat "\n"
(List.map
(fun filename ->
@ -91,22 +104,21 @@ let wrap_html (source_files : string list) (custom_pygments : string option)
in
Printf.sprintf "<li><tt>%s</tt>, %s %s</li>"
(pre_html (Filename.basename filename))
(match language with `Fr -> "dernière modification le" | `En -> "last modification")
(literal_last_modification language)
ftime)
source_files));
wrapped fmt
(** Performs syntax highlighting on a piece of code by using Pygments and the special Catala lexer. *)
let pygmentize_code (c : string Pos.marked) (language : C.backend_lang)
(custom_pygments : string option) : string =
let pygmentize_code (c : string Pos.marked) (language : C.backend_lang) : string =
C.debug_print (Printf.sprintf "Pygmenting the code chunk %s" (Pos.to_string (Pos.get_position c)));
let temp_file_in = Filename.temp_file "catala_html_pygments" "in" in
let temp_file_out = Filename.temp_file "catala_html_pygments" "out" in
let oc = open_out temp_file_in in
Printf.fprintf oc "%s" (Pos.unmark c);
close_out oc;
let pygments = match custom_pygments with Some p -> p | None -> "pygmentize" in
let pygments_lexer = match language with `Fr -> "catala_fr" | `En -> "catala_en" in
let pygments = "pygmentize" in
let pygments_lexer = get_language_extension language in
let pygments_args =
[|
"-l";
@ -129,77 +141,42 @@ let pygmentize_code (c : string Pos.marked) (language : C.backend_lang)
let oc = open_in temp_file_out in
let output = really_input_string oc (in_channel_length oc) in
close_in oc;
output
(* Remove code blocks delimiters needed by [Pygments]. *)
output |> remove_cb_first_lines |> remove_cb_last_lines
(** {1 Weaving} *)
let law_article_item_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (i : A.law_article_item) : unit =
let rec law_structure_to_html (language : C.backend_lang) (fmt : Format.formatter)
(i : A.law_structure) : unit =
match i with
| A.LawText t ->
let t = pre_html t in
if t = "" then () else Format.fprintf fmt "<p class='law-text'>%s</p>" t
| A.CodeBlock (_, c) ->
let date = "\\d\\d/\\d\\d/\\d\\d\\d\\d" in
let syms = R.regexp (date ^ "|!=|<=|>=|--|->|\\*|\\/") in
let syms_subst = function
| "!=" -> "≠"
| "<=" -> "≤"
| ">=" -> "≥"
| "--" -> "—"
| "->" -> "→"
| "*" -> "×"
| "/" -> "÷"
| s -> s
in
let pprinted_c = R.substitute ~rex:syms ~subst:syms_subst (Pos.unmark c) in
Format.fprintf fmt "<div class='code-wrapper'>\n<div class='filename'>%s</div>\n%s\n</div>"
| A.CodeBlock (_, c, metadata) ->
let pprinted_c = substitute_arithmetics_op (Pos.unmark c) in
Format.fprintf fmt "<div class='code-wrapper%s'>\n<div class='filename'>%s</div>\n%s\n</div>"
(if metadata then " code-metadata" else "")
(Pos.get_file (Pos.get_position c))
(pygmentize_code (Pos.same_pos_as ("/*" ^ pprinted_c ^ "*/") c) language custom_pygments)
let rec law_structure_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (i : A.law_structure) : unit =
match i with
(pygmentize_code (Pos.same_pos_as ("```catala" ^ pprinted_c ^ "```") c) language)
| A.LawHeading (heading, children) ->
let h_number = heading.law_heading_precedence + 2 in
Format.fprintf fmt "<h%d class='law-heading'>%s</h%d>\n" h_number
(pre_html heading.law_heading_name)
h_number;
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(law_structure_to_html custom_pygments language)
fmt children
| A.LawInclude _ -> ()
| A.LawArticle (a, children) ->
Format.fprintf fmt
"<div class='article-container'>\n\n<div class='article-title'><a href='%s'>%s</a></div>\n"
( match (a.law_article_id, language) with
| Some id, `Fr ->
let h_number = heading.law_heading_precedence + 1 in
Format.fprintf fmt "<h%d class='law-heading'><a href='%s'>%s</a></h%d>\n" h_number
(match (heading.law_heading_id, language) with
| Some id, Fr ->
let ltime = Unix.localtime (Unix.time ()) in
P.sprintf "https://legifrance.gouv.fr/codes/id/%s/%d-%02d-%02d" id
(1900 + ltime.Unix.tm_year) (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday
| _ -> "#" )
(pre_html (Pos.unmark a.law_article_name));
| _ -> "#")
(pre_html (Pos.unmark heading.law_heading_name))
h_number;
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(law_article_item_to_html custom_pygments language)
fmt children;
Format.fprintf fmt "\n</div>"
| A.MetadataBlock (b, c) ->
law_article_item_to_html custom_pygments language fmt (A.CodeBlock (b, c))
| A.IntermediateText t ->
let t = pre_html t in
if t = "" then () else Format.fprintf fmt "<p class='law-text'>%s</p>" t
let program_item_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (i : A.program_item) : unit =
match i with A.LawStructure s -> law_structure_to_html custom_pygments language fmt s
(law_structure_to_html language) fmt children
| A.LawInclude _ -> ()
(** {1 API} *)
let ast_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (program : A.program) : unit =
let ast_to_html (language : C.backend_lang) (fmt : Format.formatter) (program : A.program) : unit =
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(program_item_to_html custom_pygments language)
fmt program.program_items
(law_structure_to_html language) fmt program.program_items

30
compiler/literate/html.mli Normal file
View File

@ -0,0 +1,30 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** This modules weaves the source code and the legislative text together into a document that law
professionals can understand. *)
open Utils
(** {1 Helpers} *)
val wrap_html :
string list -> Cli.backend_lang -> Format.formatter -> (Format.formatter -> unit) -> unit
(** Usage: [wrap_html source_files language fmt wrapped]
Prints an HTML complete page structure around the [wrapped] content. *)
(** {1 API} *)
val ast_to_html : Cli.backend_lang -> Format.formatter -> Surface.Ast.program -> unit

99
src/catala/literate_programming/latex.ml → compiler/literate/latex.ml
View File

@ -1,6 +1,6 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
@ -15,9 +15,8 @@
(** This modules weaves the source code and the legislative text together into a document that law
professionals can understand. *)
module Pos = Utils.Pos
module Cli = Utils.Cli
module Errors = Utils.Errors
open Utils
open Literate_common
module A = Surface.Ast
module R = Re.Pcre
module C = Cli
@ -39,18 +38,17 @@ let pre_latexify (s : string) =
(** Usage: [wrap_latex source_files custom_pygments language fmt wrapped]
Prints an LaTeX complete documùent structure around the [wrapped] content. *)
let wrap_latex (source_files : string list) (custom_pygments : string option)
(language : C.backend_lang) (fmt : Format.formatter) (wrapped : Format.formatter -> unit) =
let wrap_latex (source_files : string list) (language : C.backend_lang) (fmt : Format.formatter)
(wrapped : Format.formatter -> unit) =
Format.fprintf fmt
"\\documentclass[11pt, a4paper]{article}\n\n\
\\usepackage[T1]{fontenc}\n\
\\usepackage[utf8]{inputenc}\n\
\\usepackage{amssymb}\n\
\\usepackage[%s]{babel}\n\
\\usepackage{lmodern}\n\
\\usepackage{minted}\n\
\\usepackage{amssymb}\n\
\\usepackage{newunicodechar}\n\
%s\n\
\\usepackage{textcomp}\n\
\\usepackage[hidelinks]{hyperref}\n\
\\usepackage[dvipsnames]{xcolor}\n\
@ -62,6 +60,8 @@ let wrap_latex (source_files : string list) (custom_pygments : string option)
\\newunicodechar{≥}{$\\geqslant$}\n\
\\newunicodechar{→}{$\\rightarrow$}\n\
\\newunicodechar{≠}{$\\neq$}\n\n\
\\newcommand*\\FancyVerbStartString{```catala}\n\
\\newcommand*\\FancyVerbStopString{```}\n\n\
\\fvset{\n\
numbers=left,\n\
frame=lines,\n\
@ -81,18 +81,9 @@ let wrap_latex (source_files : string list) (custom_pygments : string option)
%s : \n\
\\begin{itemize}%s\\end{itemize}\n\n\
\\[\\star\\star\\star\\]\\\\\n"
(match language with `Fr -> "french" | `En -> "english")
( match custom_pygments with
| None -> ""
| Some p -> Printf.sprintf "\\renewcommand{\\MintedPygmentize}{%s}" p )
( match language with
| `Fr -> "Implémentation de texte législatif"
| `En -> "Legislative text implementation" )
(match language with `Fr -> "Document généré par" | `En -> "Document generated by")
Utils.Cli.version
( match language with
| `Fr -> "Fichiers sources tissés dans ce document"
| `En -> "Source files weaved in this document" )
(match language with Fr -> "french" | En -> "english" | Pl -> "polish")
(literal_title language) (literal_generated_by language) Utils.Cli.version
(literal_source_files language)
(String.concat ","
(List.map
(fun filename ->
@ -104,7 +95,7 @@ let wrap_latex (source_files : string list) (custom_pygments : string option)
in
Printf.sprintf "\\item\\texttt{%s}, %s %s"
(pre_latexify (Filename.basename filename))
(match language with `Fr -> "dernière modification le" | `En -> "last modification")
(literal_last_modification language)
ftime)
source_files));
wrapped fmt;
@ -128,32 +119,19 @@ let math_syms_replace (c : string) : string =
(** {1 Weaving} *)
let law_article_item_to_latex (language : C.backend_lang) (fmt : Format.formatter)
(i : A.law_article_item) : unit =
match i with
| A.LawText t -> Format.fprintf fmt "%s" (pre_latexify t)
| A.CodeBlock (_, c) ->
Format.fprintf fmt
"\\begin{minted}[label={\\hspace*{\\fill}\\texttt{%s}},firstnumber=%d]{%s}\n\
/*%s*/\n\
\\end{minted}"
(pre_latexify (Filename.basename (Pos.get_file (Pos.get_position c))))
(Pos.get_start_line (Pos.get_position c) - 1)
(match language with `Fr -> "catala_fr" | `En -> "catala_en")
(math_syms_replace (Pos.unmark c))
let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatter)
(i : A.law_structure) : unit =
match i with
| A.LawHeading (heading, children) ->
Format.fprintf fmt "\\%ssection*{%s}\n\n"
( match heading.law_heading_precedence with
| 0 -> ""
| 1 -> ""
| 2 -> "sub"
| 3 -> "sub"
| _ -> "subsub" )
(pre_latexify heading.law_heading_name);
Format.fprintf fmt "\\%s*{%s}\n\n"
(match heading.law_heading_precedence with
| 0 -> "chapter"
| 1 -> "section"
| 2 -> "subsection"
| 4 -> "subsubsection"
| 5 -> "paragraph"
| _ -> "subparagraph")
(pre_latexify (Pos.unmark heading.law_heading_name));
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_latex language) fmt children
@ -166,36 +144,37 @@ let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatt
(match page with None -> "" | Some p -> Format.sprintf "page=%d," p)
file label
| A.LawInclude (A.CatalaFile _ | A.LegislativeText _) -> ()
| A.LawArticle (article, children) ->
Format.fprintf fmt "\\paragraph{%s}\n\n" (pre_latexify (Pos.unmark article.law_article_name));
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(law_article_item_to_latex language)
fmt children
| A.MetadataBlock (_, c) ->
let metadata_title = match language with `Fr -> "Métadonnées" | `En -> "Metadata" in
| A.LawText t -> Format.fprintf fmt "%s" (pre_latexify t)
| A.CodeBlock (_, c, false) ->
Format.fprintf fmt
"\\begin{minted}[label={\\hspace*{\\fill}\\texttt{%s}},firstnumber=%d]{%s}\n\
```catala%s```\n\
\\end{minted}"
(pre_latexify (Filename.basename (Pos.get_file (Pos.get_position c))))
(Pos.get_start_line (Pos.get_position c) - 1)
(get_language_extension language)
(math_syms_replace (Pos.unmark c))
| A.CodeBlock (_, c, true) ->
let metadata_title =
match language with Fr -> "Métadonnées" | En -> "Metadata" | Pl -> "Metadane"
in
Format.fprintf fmt
"\\begin{tcolorbox}[colframe=OliveGreen, breakable, \
title=\\textcolor{black}{\\texttt{%s}},title after \
break=\\textcolor{black}{\\texttt{%s}},before skip=1em, after skip=1em]\n\
\\begin{minted}[numbersep=9mm, firstnumber=%d, label={\\hspace*{\\fill}\\texttt{%s}}]{%s}\n\
/*%s*/\n\
```catala%s```\n\
\\end{minted}\n\
\\end{tcolorbox}"
metadata_title metadata_title
(Pos.get_start_line (Pos.get_position c) - 1)
(pre_latexify (Filename.basename (Pos.get_file (Pos.get_position c))))
(match language with `Fr -> "catala_fr" | `En -> "catala_en")
(get_language_extension language)
(math_syms_replace (Pos.unmark c))
| A.IntermediateText t -> Format.fprintf fmt "%s" (pre_latexify t)
let program_item_to_latex (language : C.backend_lang) (fmt : Format.formatter) (i : A.program_item)
: unit =
match i with A.LawStructure law_s -> law_structure_to_latex language fmt law_s
(** {1 API} *)
let ast_to_latex (language : C.backend_lang) (fmt : Format.formatter) (program : A.program) : unit =
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(program_item_to_latex language) fmt program.program_items
(law_structure_to_latex language) fmt program.program_items

30
compiler/literate/latex.mli Normal file
View File

@ -0,0 +1,30 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** This modules weaves the source code and the legislative text together into a document that law
professionals can understand. *)
open Utils
(** {1 Helpers} *)
val wrap_latex :
string list -> Cli.backend_lang -> Format.formatter -> (Format.formatter -> unit) -> unit
(** Usage: [wrap_latex source_files language fmt wrapped]
Prints an LaTeX complete documùent structure around the [wrapped] content. *)
(** {1 API} *)
val ast_to_latex : Cli.backend_lang -> Format.formatter -> Surface.Ast.program -> unit

0
src/catala/literate_programming/literate.mld → compiler/literate/literate.mld
View File

37
compiler/literate/literate_common.ml Normal file
View File

@ -0,0 +1,37 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Cli
let literal_title = function
| En -> "Legislative text implementation"
| Fr -> "Implémentation de texte législatif"
| Pl -> "Implementacja tekstów legislacyjnych"
let literal_generated_by = function
| En -> "Document generated by"
| Fr -> "Document généré par"
| Pl -> "Dokument wygenerowany przez"
let literal_source_files = function
| En -> "Source files weaved in this document"
| Fr -> "Fichiers sources tissés dans ce document"
| Pl -> "Pliki źródłowe w tym dokumencie"
let literal_last_modification = function
| En -> "last modification"
| Fr -> "dernière modification le"
| Pl -> "ostatnia modyfikacja"
let get_language_extension = function Fr -> "catala_fr" | En -> "catala_en" | Pl -> "catala_pl"

29
compiler/literate/literate_common.mli Normal file
View File

@ -0,0 +1,29 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
val literal_title : Cli.backend_lang -> string
(** Return the title traduction according the given {!type: Utils.Cli.backend_lang}. *)
val literal_generated_by : Cli.backend_lang -> string
(** Return the 'generated by' traduction according the given {!type: Utils.Cli.backend_lang}. *)
val literal_source_files : Cli.backend_lang -> string
(** Return the 'source files weaved' traduction according the given {!type: Utils.Cli.backend_lang}. *)
val literal_last_modification : Cli.backend_lang -> string
(** Return the 'last modification' traduction according the given {!type: Utils.Cli.backend_lang}. *)
val get_language_extension : Cli.backend_lang -> string
(** Return the file extension corresponding to the given {!type: Utils.Cli.backend_lang}. *)

335
compiler/runtime.ml Normal file
View File

@ -0,0 +1,335 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
type money = Z.t
type integer = Z.t
type decimal = Q.t
type date = CalendarLib.Date.t
type duration = CalendarLib.Date.Period.t
type source_position = {
filename : string;
start_line : int;
start_column : int;
end_line : int;
end_column : int;
law_headings : string list;
}
exception EmptyError
exception AssertionFailed
exception ConflictError
exception UncomparableDurations
exception IndivisableDurations
exception ImpossibleDate
exception NoValueProvided of source_position
type runtime_value =
| Unit
| Bool of bool
| Money of money
| Integer of integer
| Decimal of decimal
| Date of date
| Duration of duration
| Enum of string list * (string * runtime_value)
| Struct of string list * (string * runtime_value) list
| Array of runtime_value Array.t
| Unembeddable
let unembeddable _ = Unembeddable
let embed_unit () = Unit
let embed_bool x = Bool x
let embed_money x = Money x
let embed_integer x = Integer x
let embed_decimal x = Decimal x
let embed_date x = Date x
let embed_duration x = Duration x
let embed_array f x = Array (Array.map f x)
type event =
| BeginCall of string list
| EndCall of string list
| VariableDefinition of string list * runtime_value
| DecisionTaken of source_position
let log_ref : event list ref = ref []
let reset_log () = log_ref := []
let retrieve_log () = List.rev !log_ref
let log_begin_call info f x =
log_ref := BeginCall info :: !log_ref;
f x
let log_end_call info x =
log_ref := EndCall info :: !log_ref;
x
let log_variable_definition (info : string list) embed (x : 'a) =
log_ref := VariableDefinition (info, embed x) :: !log_ref;
x
let log_decision_taken pos x =
if x then log_ref := DecisionTaken pos :: !log_ref;
x
let money_of_cents_string (cents : string) : money = Z.of_string cents
let money_of_units_int (units : int) : money = Z.(of_int units * of_int 100)
let money_of_cents_integer (cents : integer) : money = cents
let money_to_float (m : money) : float = Z.to_float m /. 100.
let money_to_string (m : money) : string =
Format.asprintf "%.2f" Q.(to_float (of_bigint m / of_int 100))
let money_to_cents m = m
let decimal_of_string (d : string) : decimal = Q.of_string d
let decimal_to_float (d : decimal) : float = Q.to_float d
let decimal_of_float (d : float) : decimal = Q.of_float d
let decimal_of_integer (d : integer) : decimal = Q.of_bigint d
let decimal_to_string ~(max_prec_digits : int) (i : decimal) : string =
let sign = Q.sign i in
let n = Z.abs (Q.num i) in
let d = Z.abs (Q.den i) in
let int_part = Z.ediv n d in
let n = ref (Z.erem n d) in
let digits = ref [] in
let leading_zeroes (digits : Z.t list) : int =
match
List.fold_right
(fun digit num_leading_zeroes ->
match num_leading_zeroes with
| `End _ -> num_leading_zeroes
| `Begin i -> if Z.(digit = zero) then `Begin (i + 1) else `End i)
digits (`Begin 0)
with
| `End i -> i
| `Begin i -> i
in
while !n <> Z.zero && List.length !digits - leading_zeroes !digits < max_prec_digits do
n := Z.mul !n (Z.of_int 10);
digits := Z.ediv !n d :: !digits;
n := Z.erem !n d
done;
Format.asprintf "%s%a.%a%s"
(if sign < 0 then "-" else "")
Z.pp_print int_part
(Format.pp_print_list
~pp_sep:(fun _fmt () -> ())
(fun fmt digit -> Format.fprintf fmt "%a" Z.pp_print digit))
(List.rev !digits)
(if List.length !digits - leading_zeroes !digits = max_prec_digits then "…" else "")
let integer_of_string (s : string) : integer = Z.of_string s
let integer_to_string (i : integer) : string = Z.to_string i
let integer_to_int (i : integer) : int = Z.to_int i
let integer_of_int (i : int) : integer = Z.of_int i
let integer_exponentiation (i : integer) (e : int) : integer = Z.pow i e
let integer_log2 = Z.log2
let year_of_date (d : date) : integer = Z.of_int (CalendarLib.Date.year d)
let month_number_of_date (d : date) : integer =
Z.of_int (CalendarLib.Date.int_of_month (CalendarLib.Date.month d))
let day_of_month_of_date (d : date) : integer = Z.of_int (CalendarLib.Date.day_of_month d)
let date_of_numbers (year : int) (month : int) (day : int) : date =
try CalendarLib.Date.make year month day with _ -> raise ImpossibleDate
let date_to_string (d : date) : string = CalendarLib.Printer.Date.to_string d
let duration_of_numbers (year : int) (month : int) (day : int) : duration =
CalendarLib.Date.Period.make year month day
let duration_to_string (d : duration) : string =
let x, y, z = CalendarLib.Date.Period.ymd d in
let to_print = List.filter (fun (a, _) -> a <> 0) [ (x, "years"); (y, "months"); (z, "days") ] in
match to_print with
| [] -> "empty duration"
| _ ->
Format.asprintf "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (d, l) -> Format.fprintf fmt "%d %s" d l))
to_print
let duration_to_years_months_days (d : duration) : int * int * int = CalendarLib.Date.Period.ymd d
let handle_default : 'a. (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> 'a =
fun exceptions just cons ->
let except =
Array.fold_left
(fun acc except ->
let new_val = try Some (except ()) with EmptyError -> None in
match (acc, new_val) with
| None, _ -> new_val
| Some _, None -> acc
| Some _, Some _ -> raise ConflictError)
None exceptions
in
match except with Some x -> x | None -> if just () then cons () else raise EmptyError
let no_input : unit -> 'a = fun _ -> raise EmptyError
let ( *$ ) (i1 : money) (i2 : decimal) : money =
let rat_result = Q.mul (Q.of_bigint i1) i2 in
let res, remainder = Z.div_rem (Q.num rat_result) (Q.den rat_result) in
(* we perform nearest rounding when multiplying an amount of money by a decimal !*)
if Z.(of_int 2 * remainder >= Q.den rat_result) then Z.add res (Z.of_int 1) else res
let ( /$ ) (m1 : money) (m2 : money) : decimal =
if Z.zero = m2 then raise Division_by_zero else Q.div (Q.of_bigint m1) (Q.of_bigint m2)
let ( +$ ) (m1 : money) (m2 : money) : money = Z.add m1 m2
let ( -$ ) (m1 : money) (m2 : money) : money = Z.sub m1 m2
let ( ~-$ ) (m1 : money) : money = Z.sub Z.zero m1
let ( +! ) (i1 : integer) (i2 : integer) : integer = Z.add i1 i2
let ( -! ) (i1 : integer) (i2 : integer) : integer = Z.sub i1 i2
let ( ~-! ) (i1 : integer) : integer = Z.sub Z.zero i1
let ( *! ) (i1 : integer) (i2 : integer) : integer = Z.mul i1 i2
let ( /! ) (i1 : integer) (i2 : integer) : integer =
if Z.zero = i2 then raise Division_by_zero else Z.div i1 i2
let ( +& ) (i1 : decimal) (i2 : decimal) : decimal = Q.add i1 i2
let ( -& ) (i1 : decimal) (i2 : decimal) : decimal = Q.sub i1 i2
let ( ~-& ) (i1 : decimal) : decimal = Q.sub Q.zero i1
let ( *& ) (i1 : decimal) (i2 : decimal) : decimal = Q.mul i1 i2
let ( /& ) (i1 : decimal) (i2 : decimal) : decimal =
if Q.zero = i2 then raise Division_by_zero else Q.div i1 i2
let ( +@ ) (d1 : date) (d2 : duration) : date = CalendarLib.Date.add d1 d2
let ( -@ ) (d1 : date) (d2 : date) : duration = CalendarLib.Date.sub d1 d2
let ( +^ ) (d1 : duration) (d2 : duration) : duration = CalendarLib.Date.Period.add d1 d2
let ( -^ ) (d1 : duration) (d2 : duration) : duration = CalendarLib.Date.Period.sub d1 d2
(* (EmileRolley) NOTE: {!CalendarLib.Date.Period.nb_days} is deprecated,
{!CalendarLib.Date.Period.safe_nb_days} should be used. But the current {!duration} is greater
that the supported polymorphic variants.*)
let ( /^ ) (d1 : duration) (d2 : duration) : decimal =
try
let nb_day1 = CalendarLib.Date.Period.nb_days d1 in
let nb_day2 = CalendarLib.Date.Period.nb_days d2 in
if 0 = nb_day2 then raise Division_by_zero else Q.(nb_day1 // nb_day2)
with CalendarLib.Date.Period.Not_computable -> raise IndivisableDurations
let ( <=$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 <= 0
let ( >=$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 >= 0
let ( <$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 < 0
let ( >$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 > 0
let ( =$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 = 0
let ( >=! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 >= 0
let ( <=! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 <= 0
let ( >! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 > 0
let ( <! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 < 0
let ( =! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 = 0
let ( >=& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 >= 0
let ( <=& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 <= 0
let ( >& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 > 0
let ( <& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 < 0
let ( =& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 = 0
let ( >=@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 >= 0
let ( <=@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 <= 0
let ( >@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 > 0
let ( <@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 < 0
let ( =@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 = 0
let compare_periods (p1 : CalendarLib.Date.Period.t) (p2 : CalendarLib.Date.Period.t) : int =
try
let p1_days = CalendarLib.Date.Period.nb_days p1 in
let p2_days = CalendarLib.Date.Period.nb_days p2 in
compare p1_days p2_days
with CalendarLib.Date.Period.Not_computable -> raise UncomparableDurations
let ( >=^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 >= 0
let ( <=^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 <= 0
let ( >^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 > 0
let ( <^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 < 0
let ( =^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 = 0
let ( ~-^ ) (d1 : duration) : duration = CalendarLib.Date.Period.opp d1
let array_filter (f : 'a -> bool) (a : 'a array) : 'a array =
Array.of_list (List.filter f (Array.to_list a))
let array_length (a : 'a array) : integer = Z.of_int (Array.length a)

295
compiler/runtime.mli Normal file
View File

@ -0,0 +1,295 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** {1 Types} *)
type money
type integer
type decimal
type date
type duration
type source_position = {
filename : string;
start_line : int;
start_column : int;
end_line : int;
end_column : int;
law_headings : string list;
}
(** {1 Exceptions} *)
exception EmptyError
exception AssertionFailed
exception ConflictError
exception UncomparableDurations
exception IndivisableDurations
exception ImpossibleDate
exception NoValueProvided of source_position
(** {1 Value Embedding} *)
type runtime_value =
| Unit
| Bool of bool
| Money of money
| Integer of integer
| Decimal of decimal
| Date of date
| Duration of duration
| Enum of string list * (string * runtime_value)
| Struct of string list * (string * runtime_value) list
| Array of runtime_value Array.t
| Unembeddable
val unembeddable : 'a -> runtime_value
val embed_unit : unit -> runtime_value
val embed_bool : bool -> runtime_value
val embed_money : money -> runtime_value
val embed_integer : integer -> runtime_value
val embed_decimal : decimal -> runtime_value
val embed_date : date -> runtime_value
val embed_duration : duration -> runtime_value
val embed_array : ('a -> runtime_value) -> 'a Array.t -> runtime_value
(** {1 Logging} *)
type event =
| BeginCall of string list
| EndCall of string list
| VariableDefinition of string list * runtime_value
| DecisionTaken of source_position
val reset_log : unit -> unit
val retrieve_log : unit -> event list
val log_begin_call : string list -> ('a -> 'b) -> 'a -> 'b
val log_end_call : string list -> 'a -> 'a
val log_variable_definition : string list -> ('a -> runtime_value) -> 'a -> 'a
val log_decision_taken : source_position -> bool -> bool
(**{1 Constructors and conversions} *)
(**{2 Money}*)
val money_of_cents_string : string -> money
val money_of_units_int : int -> money
val money_of_cents_integer : integer -> money
val money_to_float : money -> float
val money_to_string : money -> string
val money_to_cents : money -> integer
(** {2 Decimals} *)
val decimal_of_string : string -> decimal
val decimal_to_string : max_prec_digits:int -> decimal -> string
val decimal_of_integer : integer -> decimal
val decimal_of_float : float -> decimal
val decimal_to_float : decimal -> float
(**{2 Integers} *)
val integer_of_string : string -> integer
val integer_to_string : integer -> string
val integer_to_int : integer -> int
val integer_of_int : int -> integer
val integer_log2 : integer -> int
val integer_exponentiation : integer -> int -> integer
(**{2 Dates} *)
val day_of_month_of_date : date -> integer
val month_number_of_date : date -> integer
val year_of_date : date -> integer
val date_to_string : date -> string
val date_of_numbers : int -> int -> int -> date
(** Usage: [date_of_numbers year month day]
@raise ImpossibleDate *)
(**{2 Durations} *)
val duration_of_numbers : int -> int -> int -> duration
val duration_to_years_months_days : duration -> int * int * int
val duration_to_string : duration -> string
(**{1 Defaults} *)
val handle_default : (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> 'a
(** @raise EmptyError
@raise ConflictError *)
val no_input : unit -> 'a
(**{1 Operators} *)
(**{2 Money} *)
val ( *$ ) : money -> decimal -> money
val ( /$ ) : money -> money -> decimal
(** @raise Division_by_zero *)
val ( +$ ) : money -> money -> money
val ( -$ ) : money -> money -> money
val ( ~-$ ) : money -> money
val ( =$ ) : money -> money -> bool
val ( <=$ ) : money -> money -> bool
val ( >=$ ) : money -> money -> bool
val ( <$ ) : money -> money -> bool
val ( >$ ) : money -> money -> bool
(**{2 Integers} *)
val ( +! ) : integer -> integer -> integer
val ( -! ) : integer -> integer -> integer
val ( ~-! ) : integer -> integer
val ( *! ) : integer -> integer -> integer
val ( /! ) : integer -> integer -> integer
(** @raise Division_by_zero *)
val ( =! ) : integer -> integer -> bool
val ( >=! ) : integer -> integer -> bool
val ( <=! ) : integer -> integer -> bool
val ( >! ) : integer -> integer -> bool
val ( <! ) : integer -> integer -> bool
(** {2 Decimals} *)
val ( +& ) : decimal -> decimal -> decimal
val ( -& ) : decimal -> decimal -> decimal
val ( ~-& ) : decimal -> decimal
val ( *& ) : decimal -> decimal -> decimal
val ( /& ) : decimal -> decimal -> decimal
(** @raise Division_by_zero *)
val ( =& ) : decimal -> decimal -> bool
val ( >=& ) : decimal -> decimal -> bool
val ( <=& ) : decimal -> decimal -> bool
val ( >& ) : decimal -> decimal -> bool
val ( <& ) : decimal -> decimal -> bool
(** {2 Dates} *)
val ( +@ ) : date -> duration -> date
val ( -@ ) : date -> date -> duration
val ( =@ ) : date -> date -> bool
val ( >=@ ) : date -> date -> bool
val ( <=@ ) : date -> date -> bool
val ( >@ ) : date -> date -> bool
val ( <@ ) : date -> date -> bool
(** {2 Durations} *)
val ( +^ ) : duration -> duration -> duration
val ( -^ ) : duration -> duration -> duration
val ( /^ ) : duration -> duration -> decimal
(** @raise Division_by_zero
@raise IndivisableDurations *)
val ( ~-^ ) : duration -> duration
val ( =^ ) : duration -> duration -> bool
val ( >=^ ) : duration -> duration -> bool
(** @raise UncomparableDurations *)
val ( <=^ ) : duration -> duration -> bool
(** @raise UncomparableDurations *)
val ( >^ ) : duration -> duration -> bool
(** @raise UncomparableDurations *)
val ( <^ ) : duration -> duration -> bool
(** @raise UncomparableDurations *)
(** {2 Arrays} *)
val array_filter : ('a -> bool) -> 'a array -> 'a array
val array_length : 'a array -> integer

54
compiler/scalc/ast.ml Normal file
View File

@ -0,0 +1,54 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
module D = Dcalc.Ast
module L = Lcalc.Ast
module TopLevelName = Uid.Make (Uid.MarkedString) ()
module LocalName = Uid.Make (Uid.MarkedString) ()
type expr =
| EVar of LocalName.t
| EFunc of TopLevelName.t
| EStruct of expr Pos.marked list * D.StructName.t
| EStructFieldAccess of expr Pos.marked * D.StructFieldName.t * D.StructName.t
| EInj of expr Pos.marked * D.EnumConstructor.t * D.EnumName.t
| EArray of expr Pos.marked list
| ELit of L.lit
| EApp of expr Pos.marked * expr Pos.marked list
| EOp of Dcalc.Ast.operator
type stmt =
| SInnerFuncDef of LocalName.t Pos.marked * func
| SLocalDecl of LocalName.t Pos.marked * D.typ Pos.marked
| SLocalDef of LocalName.t Pos.marked * expr Pos.marked
| STryExcept of block * L.except * block
| SRaise of L.except
| SIfThenElse of expr Pos.marked * block * block
| SSwitch of
expr Pos.marked
* D.EnumName.t
* (block (* Statements corresponding to arm closure body*)
* (* Variable instantiated with enum payload *) LocalName.t)
list (** Each block corresponds to one case of the enum *)
| SReturn of expr
| SAssert of expr
and block = stmt Pos.marked list
and func = { func_params : (LocalName.t Pos.marked * D.typ Pos.marked) list; func_body : block }
type program = { decl_ctx : D.decl_ctx; scopes : (TopLevelName.t * func) list }

255
compiler/scalc/compile_from_lambda.ml Normal file
View File

@ -0,0 +1,255 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
module A = Ast
module L = Lcalc.Ast
module D = Dcalc.Ast
type ctxt = {
func_dict : A.TopLevelName.t L.VarMap.t;
decl_ctx : D.decl_ctx;
var_dict : A.LocalName.t L.VarMap.t;
inside_definition_of : A.LocalName.t option;
}
(* Expressions can spill out side effect, hence this function also returns a list of statements to
be prepended before the expression is evaluated *)
let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) : A.block * A.expr Pos.marked =
match Pos.unmark expr with
| L.EVar v ->
let local_var =
try A.EVar (L.VarMap.find (Pos.unmark v) ctxt.var_dict)
with Not_found -> A.EFunc (L.VarMap.find (Pos.unmark v) ctxt.func_dict)
in
([], (local_var, Pos.get_position v))
| L.ETuple (args, Some s_name) ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
(arg_stmts @ args_stmts, new_arg :: new_args))
([], []) args
in
let new_args = List.rev new_args in
let args_stmts = List.rev args_stmts in
(args_stmts, (A.EStruct (new_args, s_name), Pos.get_position expr))
| L.ETuple (_, None) -> failwith "Non-struct tuples cannot be compiled to scalc"
| L.ETupleAccess (e1, num_field, Some s_name, _) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let field_name =
fst (List.nth (D.StructMap.find s_name ctxt.decl_ctx.ctx_structs) num_field)
in
(e1_stmts, (A.EStructFieldAccess (new_e1, field_name, s_name), Pos.get_position expr))
| L.ETupleAccess (_, _, None, _) -> failwith "Non-struct tuples cannot be compiled to scalc"
| L.EInj (e1, num_cons, e_name, _) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let cons_name = fst (List.nth (D.EnumMap.find e_name ctxt.decl_ctx.ctx_enums) num_cons) in
(e1_stmts, (A.EInj (new_e1, cons_name, e_name), Pos.get_position expr))
| L.EApp (f, args) ->
let f_stmts, new_f = translate_expr ctxt f in
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
(arg_stmts @ args_stmts, new_arg :: new_args))
([], []) args
in
let new_args = List.rev new_args in
let args_stmts = List.rev args_stmts in
(f_stmts @ args_stmts, (A.EApp (new_f, new_args), Pos.get_position expr))
| L.EArray args ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
(arg_stmts @ args_stmts, new_arg :: new_args))
([], []) args
in
let new_args = List.rev new_args in
let args_stmts = List.rev args_stmts in
(args_stmts, (A.EArray new_args, Pos.get_position expr))
| L.EOp op -> ([], (A.EOp op, Pos.get_position expr))
| L.ELit l -> ([], (A.ELit l, Pos.get_position expr))
| _ ->
let tmp_var = A.LocalName.fresh ("local_var", Pos.get_position expr) in
let ctxt = { ctxt with inside_definition_of = Some tmp_var } in
let tmp_stmts = translate_statements ctxt expr in
( ( A.SLocalDecl ((tmp_var, Pos.get_position expr), (D.TAny, Pos.get_position expr)),
Pos.get_position expr )
:: tmp_stmts,
(A.EVar tmp_var, Pos.get_position expr) )
and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.block =
match Pos.unmark block_expr with
| L.EApp ((L.EAbs ((binder, _), [ (D.TLit D.TUnit, _) ]), _), [ (L.EAssert e, _) ]) ->
(* Assertions are always encapsulated in a unit-typed let binding *)
let _, body = Bindlib.unmbind binder in
let e_stmts, new_e = translate_expr ctxt e in
e_stmts
@ (A.SAssert (Pos.unmark new_e), Pos.get_position block_expr)
:: translate_statements ctxt body
| L.EApp ((L.EAbs ((binder, binder_pos), taus), eabs_pos), args) ->
(* This defines multiple local variables at the time *)
let vars, body = Bindlib.unmbind binder in
let vars_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list vars) taus in
let ctxt =
{
ctxt with
var_dict =
List.fold_left
(fun var_dict (x, _) ->
L.VarMap.add x (A.LocalName.fresh (Bindlib.name_of x, binder_pos)) var_dict)
ctxt.var_dict vars_tau;
}
in
let local_decls =
List.map
(fun (x, tau) ->
(A.SLocalDecl ((L.VarMap.find x ctxt.var_dict, binder_pos), tau), eabs_pos))
vars_tau
in
let vars_args =
List.map2
(fun (x, tau) arg -> ((L.VarMap.find x ctxt.var_dict, binder_pos), tau, arg))
vars_tau args
in
let def_blocks =
List.map
(fun (x, _tau, arg) ->
let ctxt = { ctxt with inside_definition_of = Some (Pos.unmark x) } in
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ [ (A.SLocalDef (x, new_arg), binder_pos) ])
vars_args
in
let rest_of_block = translate_statements ctxt body in
local_decls @ List.flatten def_blocks @ rest_of_block
| L.EAbs ((binder, binder_pos), taus) ->
let vars, body = Bindlib.unmbind binder in
let vars_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list vars) taus in
let closure_name =
match ctxt.inside_definition_of with
| None -> A.LocalName.fresh ("closure", Pos.get_position block_expr)
| Some x -> x
in
let ctxt =
{
ctxt with
var_dict =
List.fold_left
(fun var_dict (x, _) ->
L.VarMap.add x (A.LocalName.fresh (Bindlib.name_of x, binder_pos)) var_dict)
ctxt.var_dict vars_tau;
inside_definition_of = None;
}
in
let new_body = translate_statements ctxt body in
[
( A.SInnerFuncDef
( (closure_name, binder_pos),
{
func_params =
List.map
(fun (var, tau) -> ((L.VarMap.find var ctxt.var_dict, binder_pos), tau))
vars_tau;
func_body = new_body;
} ),
binder_pos );
]
| L.EMatch (e1, args, e_name) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let new_args =
List.fold_left
(fun new_args arg ->
match Pos.unmark arg with
| L.EAbs ((binder, pos_binder), _) ->
let vars, body = Bindlib.unmbind binder in
assert (Array.length vars = 1);
let var = vars.(0) in
let scalc_var = A.LocalName.fresh (Bindlib.name_of var, pos_binder) in
let ctxt = { ctxt with var_dict = L.VarMap.add var scalc_var ctxt.var_dict } in
let new_arg = translate_statements ctxt body in
(new_arg, scalc_var) :: new_args
| _ -> assert false
(* should not happen *))
[] args
in
let new_args = List.rev new_args in
e1_stmts @ [ (A.SSwitch (new_e1, e_name, new_args), Pos.get_position block_expr) ]
| L.EIfThenElse (cond, e_true, e_false) ->
let cond_stmts, s_cond = translate_expr ctxt cond in
let s_e_true = translate_statements ctxt e_true in
let s_e_false = translate_statements ctxt e_false in
cond_stmts @ [ (A.SIfThenElse (s_cond, s_e_true, s_e_false), Pos.get_position block_expr) ]
| L.ECatch (e_try, except, e_catch) ->
let s_e_try = translate_statements ctxt e_try in
let s_e_catch = translate_statements ctxt e_catch in
[ (A.STryExcept (s_e_try, except, s_e_catch), Pos.get_position block_expr) ]
| L.ERaise except -> [ (A.SRaise except, Pos.get_position block_expr) ]
| _ ->
let e_stmts, new_e = translate_expr ctxt block_expr in
e_stmts
@ [
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Pos.unmark new_e)
| Some x -> A.SLocalDef (Pos.same_pos_as x new_e, new_e)),
Pos.get_position block_expr );
]
let translate_scope (decl_ctx : D.decl_ctx) (func_dict : A.TopLevelName.t L.VarMap.t)
(scope_expr : L.expr Pos.marked) : (A.LocalName.t Pos.marked * D.typ Pos.marked) list * A.block
=
match Pos.unmark scope_expr with
| L.EAbs ((binder, binder_pos), typs) ->
let vars, body = Bindlib.unmbind binder in
let var_dict =
Array.fold_left
(fun var_dict var ->
L.VarMap.add var (A.LocalName.fresh (Bindlib.name_of var, binder_pos)) var_dict)
L.VarMap.empty vars
in
let param_list =
List.map2
(fun var typ -> ((L.VarMap.find var var_dict, binder_pos), typ))
(Array.to_list vars) typs
in
let new_body =
translate_statements { decl_ctx; func_dict; var_dict; inside_definition_of = None } body
in
(param_list, new_body)
| _ -> assert false
(* should not happen *)
let translate_program (p : L.program) : A.program =
{
decl_ctx = p.L.decl_ctx;
scopes =
(let _, new_scopes =
List.fold_left
(fun (func_dict, new_scopes) (scope_name, scope_expr) ->
let new_scope_params, new_scope_body =
translate_scope p.decl_ctx func_dict scope_expr
in
let func_id = A.TopLevelName.fresh (Bindlib.name_of scope_name, Pos.no_pos) in
let func_dict = L.VarMap.add scope_name func_id func_dict in
( func_dict,
(func_id, { A.func_params = new_scope_params; A.func_body = new_scope_body })
:: new_scopes ))
( L.VarMap.singleton L.handle_default
(A.TopLevelName.fresh ("handle_default", Pos.no_pos)),
[] )
p.L.scopes
in
List.rev new_scopes);
}

8
compiler/scalc/dune Normal file
View File

@ -0,0 +1,8 @@
(library
(name scalc)
(public_name catala.scalc)
(libraries bindlib lcalc runtime))
(documentation
(package catala)
(mld_files scalc))

29
compiler/scalc/scalc.mld Normal file
View File

@ -0,0 +1,29 @@
{0 Statement calculus}
This representation is the sixth in the compilation chain
(see {{: index.html#architecture} Architecture}). Its main difference
with the previous {{: Lcalc.html} default calculus} is the switch to a
statement-based language. This representation does not assume any scoping
rules in the language, every local variable has a unique id.
The module describing the abstract syntax tree is:
{!modules: Dcalc.Ast}
{1 Compilation from lambda calculus }
Related modules:
{!modules: Scalc.Compile_from_lambda}
{!module: Scalc.Compile_from_lambda} Performs the classical translation
from an expression-based language to a statement-based language. Union types
are eliminated in favor of tagged unions.
{1 Backends}
Related modules:
{!modules: Lcalc.To_python}

430
compiler/scalc/to_python.ml Normal file
View File

@ -0,0 +1,430 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
[@@@warning "-32-27"]
open Utils
open Ast
open Lcalc.Backends
module D = Dcalc.Ast
module L = Lcalc.Ast
let format_lit (fmt : Format.formatter) (l : L.lit Pos.marked) : unit =
match Pos.unmark l with
| LBool true -> Format.fprintf fmt "True"
| LBool false -> Format.fprintf fmt "False"
| LInt i -> Format.fprintf fmt "integer_of_string(\"%s\")" (Runtime.integer_to_string i)
| LUnit -> Format.fprintf fmt "Unit()"
| LRat i ->
Format.fprintf fmt "decimal_of_string(\"%a\")" Dcalc.Print.format_lit
(Pos.same_pos_as (Dcalc.Ast.LRat i) l)
| LMoney e ->
Format.fprintf fmt "money_of_cents_string(\"%s\")"
(Runtime.integer_to_string (Runtime.money_to_cents e))
| LDate d ->
Format.fprintf fmt "date_of_numbers(%d,%d,%d)"
(Runtime.integer_to_int (Runtime.year_of_date d))
(Runtime.integer_to_int (Runtime.month_number_of_date d))
(Runtime.integer_to_int (Runtime.day_of_month_of_date d))
| LDuration d ->
let years, months, days = Runtime.duration_to_years_months_days d in
Format.fprintf fmt "duration_of_numbers(%d,%d,%d)" years months days
let format_log_entry (fmt : Format.formatter) (entry : Dcalc.Ast.log_entry) : unit =
match entry with
| VarDef _ -> Format.fprintf fmt ":="
| BeginCall -> Format.fprintf fmt "→ "
| EndCall -> Format.fprintf fmt "%s" "← "
| PosRecordIfTrueBool -> Format.fprintf fmt "☛ "
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : unit =
match Pos.unmark op with
| Add _ | Concat -> Format.fprintf fmt "+"
| Sub _ -> Format.fprintf fmt "-"
| Mult _ -> Format.fprintf fmt "*"
| Div D.KInt -> Format.fprintf fmt "//"
| Div _ -> Format.fprintf fmt "/"
| And -> Format.fprintf fmt "and"
| Or -> Format.fprintf fmt "or"
| Eq -> Format.fprintf fmt "=="
| Neq | Xor -> Format.fprintf fmt "!="
| Lt _ -> Format.fprintf fmt "<"
| Lte _ -> Format.fprintf fmt "<="
| Gt _ -> Format.fprintf fmt ">"
| Gte _ -> Format.fprintf fmt ">="
| Map -> Format.fprintf fmt "list_map"
| Filter -> Format.fprintf fmt "list_filter"
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : unit =
match Pos.unmark op with Fold -> Format.fprintf fmt "list_fold_left"
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) : unit =
Format.fprintf fmt "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt info -> Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info))
uids
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
Format.fprintf fmt "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt info -> Format.fprintf fmt "\"%s\"" info))
uids
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit =
match Pos.unmark op with
| Minus _ -> Format.fprintf fmt "-"
| Not -> Format.fprintf fmt "not"
| Log (entry, infos) -> assert false (* should not happen *)
| Length -> Format.fprintf fmt "%s" "list_length"
| IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer"
| GetDay -> Format.fprintf fmt "%s" "day_of_month_of_date"
| GetMonth -> Format.fprintf fmt "%s" "month_number_of_date"
| GetYear -> Format.fprintf fmt "%s" "year_of_date"
let avoid_keywords (s : string) : string =
if
match s with
(* list taken from https://www.programiz.com/python-programming/keyword-list *)
| "False" | "None" | "True" | "and" | "as" | "assert" | "async" | "await" | "break" | "class"
| "continue" | "def" | "del" | "elif" | "else" | "except" | "finally" | "for" | "from"
| "global" | "if" | "import" | "in" | "is" | "lambda" | "nonlocal" | "not" | "or" | "pass"
| "raise" | "return" | "try" | "while" | "with" | "yield" ->
true
| _ -> false
then s ^ "_"
else s
let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_uppercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v))))
let format_struct_field_name (fmt : Format.formatter) (v : Dcalc.Ast.StructFieldName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v)))
let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords (to_uppercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v))))
let format_enum_cons_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumConstructor.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v)))
let typ_needs_parens (e : Dcalc.Ast.typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : unit =
let format_typ = format_typ in
let format_typ_with_parens (fmt : Format.formatter) (t : Dcalc.Ast.typ Pos.marked) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Pos.unmark typ with
| TLit TUnit -> Format.fprintf fmt "Unit"
| TLit TMoney -> Format.fprintf fmt "Money"
| TLit TInt -> Format.fprintf fmt "Integer"
| TLit TRat -> Format.fprintf fmt "Decimal"
| TLit TDate -> Format.fprintf fmt "Date"
| TLit TDuration -> Format.fprintf fmt "Duration"
| TLit TBool -> Format.fprintf fmt "bool"
| TTuple (ts, None) ->
Format.fprintf fmt "Tuple[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt t -> Format.fprintf fmt "%a" format_typ_with_parens t))
ts
| TTuple (_, Some s) -> Format.fprintf fmt "%a" format_struct_name s
| TEnum (_, e) -> Format.fprintf fmt "%a" format_enum_name e
| TArrow (t1, t2) ->
Format.fprintf fmt "Callable[[%a], %a]" format_typ_with_parens t1 format_typ_with_parens t2
| TArray t1 -> Format.fprintf fmt "List[%a]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "Any"
let format_name_cleaned (fmt : Format.formatter) (s : string) : unit =
let lowercase_name = to_lowercase (to_ascii s) in
let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_") lowercase_name
in
let lowercase_name = avoid_keywords (to_ascii lowercase_name) in
Format.fprintf fmt "%s" lowercase_name
let format_var (fmt : Format.formatter) (v : LocalName.t) : unit =
let v_str = Pos.unmark (LocalName.get_info v) in
if v_str = "_" then Format.fprintf fmt "_"
else Format.fprintf fmt "%a_%d" format_name_cleaned v_str (LocalName.hash v)
let format_toplevel_name (fmt : Format.formatter) (v : TopLevelName.t) : unit =
let v_str = Pos.unmark (TopLevelName.get_info v) in
format_name_cleaned fmt v_str
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with ELit (LBool _ | LUnit) | EVar _ | EOp _ -> false | _ -> true
let format_exception (fmt : Format.formatter) (exc : L.except Pos.marked) : unit =
match Pos.unmark exc with
| ConflictError -> Format.fprintf fmt "ConflictError"
| EmptyError -> Format.fprintf fmt "EmptyError"
| Crash -> Format.fprintf fmt "Crash"
| NoValueProvided ->
let pos = Pos.get_position exc in
Format.fprintf fmt
"NoValueProvided(SourcePosition(filename=\"%s\",@ start_line=%d,@ start_column=%d,@ \
end_line=%d,@ end_column=%d,@ law_headings=%a))"
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos)
let rec format_expression (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked)
: unit =
match Pos.unmark e with
| EVar v -> format_var fmt v
| EFunc f -> format_toplevel_name fmt f
| EStruct (es, s) ->
if List.length es = 0 then failwith "should not happen"
else
Format.fprintf fmt "%a(%a)" format_struct_name s
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a = %a" format_struct_field_name struct_field
(format_expression ctx) e))
(List.combine es (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs)))
| EStructFieldAccess (e1, field, _) ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1 format_struct_field_name field
| EInj (e, cons, enum_name) ->
Format.fprintf fmt "%a(%a_Code.%a,@ %a)" format_enum_name enum_name format_enum_name enum_name
format_enum_cons_name cons (format_expression ctx) e
| EArray es ->
Format.fprintf fmt "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
es
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
| EApp ((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "%a(%a,@ %a)" format_binop (op, Pos.no_pos) (format_expression ctx) arg1
(format_expression ctx) arg2
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_binop (op, Pos.no_pos)
(format_expression ctx) arg2
| EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ])
when !Cli.trace_flag ->
Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info (format_expression ctx)
f (format_expression ctx) arg
| EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [ arg1 ]) when !Cli.trace_flag ->
Format.fprintf fmt "log_variable_definition(%a,@ %a)" format_uid_list info
(format_expression ctx) arg1
| EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) when !Cli.trace_flag ->
Format.fprintf fmt
"log_decision_taken(SourcePosition(filename=\"%s\",@ start_line=%d,@ start_column=%d,@ \
end_line=%d, end_column=%d,@ law_headings=%a), %a)"
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos)
(format_expression ctx) arg1
| EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) when !Cli.trace_flag ->
Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info (format_expression ctx) arg1
| EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) ->
Format.fprintf fmt "%a" (format_expression ctx) arg1
| EApp ((EOp (Unop ((Minus _ | Not) as op)), _), [ arg1 ]) ->
Format.fprintf fmt "%a %a" format_unop (op, Pos.no_pos) (format_expression ctx) arg1
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
Format.fprintf fmt "%a(%a)" format_unop (op, Pos.no_pos) (format_expression ctx) arg1
| EApp (f, args) ->
Format.fprintf fmt "%a(%a)" (format_expression ctx) f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
let rec format_statement (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (s : stmt Pos.marked) :
unit =
match Pos.unmark s with
| SInnerFuncDef (name, { func_params; func_body }) ->
Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]" format_var (Pos.unmark name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Pos.unmark var) format_typ typ))
func_params (format_block ctx) func_body
| SLocalDecl _ -> assert false (* We don't need to declare variables in Python *)
| SLocalDef (v, e) ->
Format.fprintf fmt "@[<hov 4>%a = %a@]" format_var (Pos.unmark v) (format_expression ctx) e
| STryExcept (try_b, except, catch_b) ->
Format.fprintf fmt "@[<hov 4>try:@\n%a@]@\n@[<hov 4>except %a:@\n%a@]" (format_block ctx)
try_b format_exception (except, Pos.no_pos) (format_block ctx) catch_b
| SRaise except ->
Format.fprintf fmt "@[<hov 4>raise %a@]" format_exception (except, Pos.get_position s)
| SIfThenElse (cond, b1, b2) ->
Format.fprintf fmt "@[<hov 4>if %a:@\n%a@]@\n@[<hov 4>else:@\n%a@]" (format_expression ctx)
cond (format_block ctx) b1 (format_block ctx) b2
| SSwitch (e1, e_name, cases) ->
let cases =
List.map2 (fun (x, y) (cons, _) -> (x, y, cons)) cases (D.EnumMap.find e_name ctx.ctx_enums)
in
let tmp_var = LocalName.fresh ("match_arg", Pos.no_pos) in
Format.fprintf fmt "%a = %a@\n@[<hov 4>if %a@]" format_var tmp_var (format_expression ctx) e1
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@]@\n@[<hov 4>elif ")
(fun fmt (case_block, payload_var, cons_name) ->
Format.fprintf fmt "%a.code == %a_Code.%a:@\n%a = %a.value@\n%a" format_var tmp_var
format_enum_name e_name format_enum_cons_name cons_name format_var payload_var
format_var tmp_var (format_block ctx) case_block))
cases
| SReturn e1 ->
Format.fprintf fmt "@[<hov 4>return %a@]" (format_expression ctx) (e1, Pos.get_position s)
| SAssert e1 ->
Format.fprintf fmt "@[<hov 4>assert %a@]" (format_expression ctx) (e1, Pos.get_position s)
and format_block (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (b : block) : unit =
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(format_statement ctx) fmt
(List.filter (fun s -> match Pos.unmark s with SLocalDecl _ -> false | _ -> true) b)
let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Format.formatter)
(ctx : D.decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
if List.length struct_fields = 0 then failwith "no fields in the struct"
else
Format.fprintf fmt
"class %a:@\n\
\tdef __init__(self, %a) -> None:@\n\
%a@\n\
@\n\
\tdef __eq__(self, other: object) -> bool:@\n\
\t\tif isinstance(other, %a):@\n\
\t\t\treturn @[<hov>(%a)@]@\n\
\t\telse:@\n\
\t\t\treturn False@\n\
@\n\
\tdef __ne__(self, other: object) -> bool:@\n\
\t\treturn not (self == other)@\n\
@\n\
\tdef __str__(self) -> str:@\n\
\t\t@[<hov 4>return \"%a(%a)\".format(%a)@]" format_struct_name struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "%a: %a" format_struct_field_name struct_field format_typ
struct_field_type))
struct_fields
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (struct_field, _) ->
Format.fprintf fmt "\t\tself.%a = %a" format_struct_field_name struct_field
format_struct_field_name struct_field))
struct_fields format_struct_name struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " and@ ")
(fun _fmt (struct_field, _) ->
Format.fprintf fmt "self.%a == other.%a" format_struct_field_name struct_field
format_struct_field_name struct_field))
struct_fields format_struct_name struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
(fun _fmt (struct_field, _) ->
Format.fprintf fmt "%a={}" format_struct_field_name struct_field))
struct_fields
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun _fmt (struct_field, _) ->
Format.fprintf fmt "self.%a" format_struct_field_name struct_field))
struct_fields
in
let format_enum_decl fmt (enum_name, enum_cons) =
if List.length enum_cons = 0 then failwith "no constructors in the enum"
else
Format.fprintf fmt
"@[<hov 4>class %a_Code(Enum):@\n\
%a@]@\n\
@\n\
class %a:@\n\
\tdef __init__(self, code: %a_Code, value: Any) -> None:@\n\
\t\tself.code = code@\n\
\t\tself.value = value@\n\
@\n\
@\n\
\tdef __eq__(self, other: object) -> bool:@\n\
\t\tif isinstance(other, %a):@\n\
\t\t\treturn self.code == other.code and self.value == other.value@\n\
\t\telse:@\n\
\t\t\treturn False@\n\
@\n\
@\n\
\tdef __ne__(self, other: object) -> bool:@\n\
\t\treturn not (self == other)@\n\
@\n\
\tdef __str__(self) -> str:@\n\
\t\t@[<hov 4>return \"{}({})\".format(self.code, self.value)@]" format_enum_name enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (i, enum_cons, enum_cons_type) ->
Format.fprintf fmt "%a = %d" format_enum_cons_name enum_cons i))
(List.mapi (fun i (x, y) -> (i, x, y)) enum_cons)
format_enum_name enum_name format_enum_name enum_name format_enum_name enum_name
in
let is_in_type_ordering s =
List.exists
(fun struct_or_enum ->
match struct_or_enum with
| Scopelang.Dependency.TVertex.Enum _ -> false
| Scopelang.Dependency.TVertex.Struct s' -> s = s')
type_ordering
in
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(Dcalc.Ast.StructMap.bindings
(Dcalc.Ast.StructMap.filter (fun s _ -> not (is_in_type_ordering s)) ctx.ctx_structs))
in
List.iter
(fun struct_or_enum ->
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
Format.fprintf fmt "%a@\n@\n" format_struct_decl
(s, Dcalc.Ast.StructMap.find s ctx.Dcalc.Ast.ctx_structs)
| Scopelang.Dependency.TVertex.Enum e ->
Format.fprintf fmt "%a@\n@\n" format_enum_decl
(e, Dcalc.Ast.EnumMap.find e ctx.Dcalc.Ast.ctx_enums))
(type_ordering @ scope_structs)
let format_program (fmt : Format.formatter) (p : Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
Cli.style_flag := false;
Format.fprintf fmt
"# This file has been generated by the Catala compiler, do not edit!\n\
@\n\
from .catala import *@\n\
from typing import Any, List, Callable, Tuple\n\
from enum import Enum\n\
@\n\
%a@\n\
@\n\
%a@?"
(format_ctx type_ordering) p.decl_ctx
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n")
(fun fmt (name, { Ast.func_params; Ast.func_body }) ->
Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]" format_toplevel_name name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Pos.unmark var) format_typ typ))
func_params (format_block p.decl_ctx) func_body))
p.scopes

18
compiler/scalc/to_python.mli Normal file
View File

@ -0,0 +1,18 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Formats a lambda calculus program into a valid Python program *)
val format_program : Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit
(** Usage [format_program fmt p type_dependencies_ordering] *)

24
src/catala/scope_language/ast.ml → compiler/scopelang/ast.ml
View File

@ -12,14 +12,8 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Abstract syntax tree of the scope language *)
module Pos = Utils.Pos
module Uid = Utils.Uid
(** {1 Identifiers} *)
module ScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
open Utils
module ScopeName = Dcalc.Ast.ScopeName
module ScopeNameSet : Set.S with type elt = ScopeName.t = Set.Make (ScopeName)
@ -67,8 +61,6 @@ module LocationSet : Set.S with type elt = location Pos.marked = Set.Make (struc
| SubScopeVar _, ScopeVar _ -> 1
end)
(** {1 Abstract syntax tree} *)
type typ =
| TLit of Dcalc.Ast.typ_lit
| TStruct of StructName.t
@ -77,8 +69,6 @@ type typ =
| TArray of typ
| TAny
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on
higher-order abstract syntax*)
type expr =
| ELocation of location
| EVar of expr Bindlib.var Pos.marked
@ -87,18 +77,19 @@ type expr =
| EEnumInj of expr Pos.marked * EnumConstructor.t * EnumName.t
| EMatch of expr Pos.marked * EnumName.t * expr Pos.marked EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of Pos.t * (expr, expr Pos.marked) Bindlib.mbinder * typ Pos.marked list
| EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EOp of Dcalc.Ast.operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EArray of expr Pos.marked list
| ErrorOnEmpty of expr Pos.marked
let rec locations_used (e : expr Pos.marked) : LocationSet.t =
match Pos.unmark e with
| ELocation l -> LocationSet.singleton (l, Pos.get_position e)
| EVar _ | ELit _ | EOp _ -> LocationSet.empty
| EAbs (_, binder, _) ->
| EAbs ((binder, _), _) ->
let _, body = Bindlib.unmbind binder in
locations_used body
| EStruct (_, es) ->
@ -125,6 +116,7 @@ let rec locations_used (e : expr Pos.marked) : LocationSet.t =
excepts
| EArray es ->
List.fold_left (fun acc e' -> LocationSet.union acc (locations_used e')) LocationSet.empty es
| ErrorOnEmpty e' -> locations_used e'
type rule =
| Definition of location Pos.marked * typ Pos.marked * expr Pos.marked
@ -147,8 +139,6 @@ type program = {
program_structs : struct_ctx;
}
(** {1 Variable helpers} *)
module Var = struct
type t = expr Bindlib.var
@ -167,7 +157,7 @@ let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box =
let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t)
(taus : typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun b -> (EAbs (pos_binder, b, taus), pos)) (Bindlib.bind_mvar xs e)
Bindlib.box_apply (fun b -> (EAbs ((b, pos_binder), taus), pos)) (Bindlib.bind_mvar xs e)
let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t)
: expr Pos.marked Bindlib.box =

143
compiler/scopelang/ast.mli Normal file
View File

@ -0,0 +1,143 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Abstract syntax tree of the scope language *)
open Utils
(** {1 Identifiers} *)
module ScopeName = Dcalc.Ast.ScopeName
module ScopeNameSet : Set.S with type elt = ScopeName.t
module ScopeMap : Map.S with type key = ScopeName.t
module SubScopeName : Uid.Id with type info = Uid.MarkedString.info
module SubScopeNameSet : Set.S with type elt = SubScopeName.t
module SubScopeMap : Map.S with type key = SubScopeName.t
module ScopeVar : Uid.Id with type info = Uid.MarkedString.info
module ScopeVarSet : Set.S with type elt = ScopeVar.t
module ScopeVarMap : Map.S with type key = ScopeVar.t
module StructName = Dcalc.Ast.StructName
module StructMap = Dcalc.Ast.StructMap
module StructFieldName = Dcalc.Ast.StructFieldName
module StructFieldMap : Map.S with type key = StructFieldName.t
module EnumName = Dcalc.Ast.EnumName
module EnumMap = Dcalc.Ast.EnumMap
module EnumConstructor = Dcalc.Ast.EnumConstructor
module EnumConstructorMap : Map.S with type key = EnumConstructor.t
type location =
| ScopeVar of ScopeVar.t Pos.marked
| SubScopeVar of ScopeName.t * SubScopeName.t Pos.marked * ScopeVar.t Pos.marked
module LocationSet : Set.S with type elt = location Pos.marked
(** {1 Abstract syntax tree} *)
type typ =
| TLit of Dcalc.Ast.typ_lit
| TStruct of StructName.t
| TEnum of EnumName.t
| TArrow of typ Pos.marked * typ Pos.marked
| TArray of typ
| TAny
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on
higher-order abstract syntax*)
type expr =
| ELocation of location
| EVar of expr Bindlib.var Pos.marked
| EStruct of StructName.t * expr Pos.marked StructFieldMap.t
| EStructAccess of expr Pos.marked * StructFieldName.t * StructName.t
| EEnumInj of expr Pos.marked * EnumConstructor.t * EnumName.t
| EMatch of expr Pos.marked * EnumName.t * expr Pos.marked EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EOp of Dcalc.Ast.operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EArray of expr Pos.marked list
| ErrorOnEmpty of expr Pos.marked
val locations_used : expr Pos.marked -> LocationSet.t
type rule =
| Definition of location Pos.marked * typ Pos.marked * expr Pos.marked
| Assertion of expr Pos.marked
| Call of ScopeName.t * SubScopeName.t
type scope_decl = {
scope_decl_name : ScopeName.t;
scope_sig : typ Pos.marked ScopeVarMap.t;
scope_decl_rules : rule list;
}
type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t
type program = {
program_scopes : scope_decl ScopeMap.t;
program_enums : enum_ctx;
program_structs : struct_ctx;
}
(** {1 Variable helpers} *)
module Var : sig
type t = expr Bindlib.var
val make : string Pos.marked -> t
val compare : t -> t -> int
end
module VarMap : Map.S with type key = Var.t
type vars = expr Bindlib.mvar
val make_var : Var.t Pos.marked -> expr Pos.marked Bindlib.box
val make_abs :
vars ->
expr Pos.marked Bindlib.box ->
Pos.t ->
typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
val make_app :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
val make_let_in :
Var.t ->
typ Pos.marked ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box

44
src/catala/scope_language/dependency.ml → compiler/scopelang/dependency.ml
View File

@ -15,8 +15,7 @@
(** Graph representation of the dependencies between scopes in the Catala program. Vertices are
functions, x -> y if x is used in the definition of y. *)
module Pos = Utils.Pos
module Errors = Utils.Errors
open Utils
module SVertex = struct
type t = Ast.ScopeName.t
@ -26,8 +25,6 @@ module SVertex = struct
let compare = Ast.ScopeName.compare
let equal x y = Ast.ScopeName.compare x y = 0
let format_t (fmt : Format.formatter) (x : t) : unit = Ast.ScopeName.format_t fmt x
end
(** On the edges, the label is the expression responsible for the use of the function *)
@ -204,25 +201,26 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TDepend
in
g
let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : unit =
let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TVertex.t list =
let g = build_type_graph structs enums in
(* if there is a cycle, there will be an strongly connected component of cardinality > 1 *)
let sccs = TSCC.scc_list g in
if List.length sccs < TDependencies.nb_vertex g then
let scc = List.find (fun scc -> List.length scc > 1) sccs in
Errors.raise_multispanned_error "Cyclic dependency detected between types!"
(List.flatten
(List.map
(fun v ->
let var_str, var_info =
(Format.asprintf "%a" TVertex.format_t v, TVertex.get_info v)
in
let succs = TDependencies.succ_e g v in
let _, edge_pos, succ = List.find (fun (_, _, succ) -> List.mem succ scc) succs in
let succ_str = Format.asprintf "%a" TVertex.format_t succ in
[
(Some ("Cycle type " ^ var_str ^ ", declared:"), Pos.get_position var_info);
( Some ("Used here in the definition of another cycle type " ^ succ_str ^ ":"),
edge_pos );
])
scc))
(if List.length sccs < TDependencies.nb_vertex g then
let scc = List.find (fun scc -> List.length scc > 1) sccs in
Errors.raise_multispanned_error "Cyclic dependency detected between types!"
(List.flatten
(List.map
(fun v ->
let var_str, var_info =
(Format.asprintf "%a" TVertex.format_t v, TVertex.get_info v)
in
let succs = TDependencies.succ_e g v in
let _, edge_pos, succ = List.find (fun (_, _, succ) -> List.mem succ scc) succs in
let succ_str = Format.asprintf "%a" TVertex.format_t succ in
[
(Some ("Cycle type " ^ var_str ^ ", declared:"), Pos.get_position var_info);
( Some ("Used here in the definition of another cycle type " ^ succ_str ^ ":"),
edge_pos );
])
scc)));
List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])

52
compiler/scopelang/dependency.mli Normal file
View File

@ -0,0 +1,52 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Graph representation of the dependencies between scopes in the Catala program. Vertices are
functions, x -> y if x is used in the definition of y. *)
open Utils
(** {1 Scope dependencies} *)
(** On the edges, the label is the expression responsible for the use of the function *)
module SDependencies : Graph.Sig.P with type V.t = Ast.ScopeName.t and type E.label = Pos.t
val build_program_dep_graph : Ast.program -> SDependencies.t
val check_for_cycle_in_scope : SDependencies.t -> unit
val get_scope_ordering : SDependencies.t -> Ast.ScopeName.t list
(** {1 Type dependencies} *)
module TVertex : sig
type t = Struct of Ast.StructName.t | Enum of Ast.EnumName.t
val format_t : Format.formatter -> t -> unit
val get_info : t -> Ast.StructName.info
include Graph.Sig.COMPARABLE with type t := t
end
module TVertexSet : Set.S with type elt = TVertex.t
(** On the edges, the label is the expression responsible for the use of the function *)
module TDependencies : Graph.Sig.P with type V.t = TVertex.t and type E.label = Pos.t
val get_structs_or_enums_in_type : Ast.typ Pos.marked -> TVertexSet.t
val build_type_graph : Ast.struct_ctx -> Ast.enum_ctx -> TDependencies.t
val check_type_cycles : Ast.struct_ctx -> Ast.enum_ctx -> TVertex.t list

0
src/catala/scope_language/dune → compiler/scopelang/dune
View File

60
src/catala/scope_language/print.ml → compiler/scopelang/print.ml
View File

@ -12,7 +12,7 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
module Pos = Utils.Pos
open Utils
open Ast
let needs_parens (e : expr Pos.marked) : bool =
@ -74,7 +74,7 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
Format.fprintf fmt "@[<hov 2>%a@ →@ %a@]" Ast.EnumConstructor.format_t cons_name
format_expr case_expr))
(Ast.EnumConstructorMap.bindings cases)
| EApp ((EAbs (_, binder, taus), _), args) ->
| EApp ((EAbs ((binder, _), taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in
@ -85,7 +85,7 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
Format.fprintf fmt "@[@[<hov 2>let@ %a@ :@ %a@ =@ %a@]@ in@\n@]" format_var x
format_typ tau format_expr arg))
xs_tau_arg format_expr body
| EAbs (_, binder, taus) ->
| EAbs ((binder, _), taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>λ@ %a@ →@ %a@]"
@ -116,9 +116,63 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
Format.fprintf fmt "@[<hov 2>⟨%a@ |@ %a ⊢ %a⟩@]"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_expr)
excepts format_expr just format_expr cons
| ErrorOnEmpty e' -> Format.fprintf fmt "error_empty@ %a" format_with_parens e'
| EArray es ->
Format.fprintf fmt "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";")
(fun fmt e -> Format.fprintf fmt "@[%a@]" format_expr e))
es
let format_struct (fmt : Format.formatter)
((name, fields) : StructName.t * (StructFieldName.t * typ Pos.marked) list) : unit =
Format.fprintf fmt "type %a = {@\n@[<hov 2> %a@]@\n}" StructName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "%a: %a" StructFieldName.format_t field_name format_typ typ))
fields
let format_enum (fmt : Format.formatter)
((name, cases) : EnumName.t * (EnumConstructor.t * typ Pos.marked) list) : unit =
Format.fprintf fmt "type %a = @\n@[<hov 2> %a@]" EnumName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "| %a: %a" EnumConstructor.format_t field_name format_typ typ))
cases
let format_scope (fmt : Format.formatter) ((name, decl) : ScopeName.t * scope_decl) : unit =
Format.fprintf fmt "@[<hov 2>let scope %a@ %a@ =@]@\n@[<hov 2> %a@\nend scope@]"
ScopeName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (scope_var, typ) ->
Format.fprintf fmt "(%a: %a)" ScopeVar.format_t scope_var format_typ typ))
(ScopeVarMap.bindings decl.scope_sig)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun fmt rule ->
match rule with
| Definition (loc, typ, e) ->
Format.fprintf fmt "@[<hov 2>let %a : %a =@ @[<hov 2>%a@]@ in@]" format_location
(Pos.unmark loc) format_typ typ
(fun fmt e ->
match Pos.unmark loc with
| SubScopeVar _ -> format_expr fmt e
| ScopeVar _ -> Format.fprintf fmt "reentrant or by default@ %a" format_expr e)
e
| Assertion e -> Format.fprintf fmt "assert (%a)" format_expr e
| Call (scope_name, subscope_name) ->
Format.fprintf fmt "call %a[%a]" ScopeName.format_t scope_name SubScopeName.format_t
subscope_name))
decl.scope_decl_rules
let format_program (fmt : Format.formatter) (p : program) : unit =
Format.fprintf fmt "%a@\n@\n%a@\n@\n%a"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") format_struct)
(StructMap.bindings p.program_structs)
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") format_enum)
(EnumMap.bindings p.program_enums)
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") format_scope)
(ScopeMap.bindings p.program_scopes)

27
compiler/scopelang/print.mli Normal file
View File

@ -0,0 +1,27 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
val format_var : Format.formatter -> Ast.Var.t -> unit
val format_location : Format.formatter -> Ast.location -> unit
val format_typ : Format.formatter -> Ast.typ Pos.marked -> unit
val format_expr : Format.formatter -> Ast.expr Pos.marked -> unit
val format_scope : Format.formatter -> Ast.ScopeName.t * Ast.scope_decl -> unit
val format_program : Format.formatter -> Ast.program -> unit

457
src/catala/scope_language/scope_to_dcalc.ml → compiler/scopelang/scope_to_dcalc.ml
View File

@ -12,11 +12,16 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
open Utils
type scope_sigs_ctx = ((Ast.ScopeVar.t * Dcalc.Ast.typ) list * Dcalc.Ast.Var.t) Ast.ScopeMap.t
type scope_sigs_ctx =
(* list of scope variables with their types *)
((Ast.ScopeVar.t * Dcalc.Ast.typ) list
* (* var representing the scope *) Dcalc.Ast.Var.t
* (* var representing the scope input inside the scope func *) Dcalc.Ast.Var.t
* (* scope input *) Ast.StructName.t
* (* scope output *) Ast.StructName.t)
Ast.ScopeMap.t
type ctx = {
structs : Ast.struct_ctx;
@ -40,13 +45,9 @@ let empty_ctx (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) (scopes_ct
local_vars = Ast.VarMap.empty;
}
type scope_ctx = Dcalc.Ast.Var.t Ast.ScopeMap.t
let hole_var : Dcalc.Ast.Var.t = Dcalc.Ast.Var.make ("·", Pos.no_pos)
let rec translate_typ (ctx : ctx) (t : Ast.typ Pos.marked) : Dcalc.Ast.typ Pos.marked =
Pos.same_pos_as
( match Pos.unmark t with
(match Pos.unmark t with
| Ast.TLit l -> Dcalc.Ast.TLit l
| Ast.TArrow (t1, t2) -> Dcalc.Ast.TArrow (translate_typ ctx t1, translate_typ ctx t2)
| Ast.TStruct s_uid ->
@ -56,7 +57,7 @@ let rec translate_typ (ctx : ctx) (t : Ast.typ Pos.marked) : Dcalc.Ast.typ Pos.m
let e_cases = Ast.EnumMap.find e_uid ctx.enums in
Dcalc.Ast.TEnum (List.map (fun (_, t) -> translate_typ ctx t) e_cases, e_uid)
| Ast.TArray t1 -> Dcalc.Ast.TArray (translate_typ ctx (Pos.same_pos_as t1 t))
| Ast.TAny -> Dcalc.Ast.TAny )
| Ast.TAny -> Dcalc.Ast.TAny)
t
let merge_defaults (caller : Dcalc.Ast.expr Pos.marked Bindlib.box)
@ -76,11 +77,20 @@ let merge_defaults (caller : Dcalc.Ast.expr Pos.marked Bindlib.box)
in
body
let tag_with_log_entry (e : Dcalc.Ast.expr Pos.marked Bindlib.box) (l : Dcalc.Ast.log_entry)
(markings : Utils.Uid.MarkedString.info list) : Dcalc.Ast.expr Pos.marked Bindlib.box =
Bindlib.box_apply
(fun e ->
( Dcalc.Ast.EApp
((Dcalc.Ast.EOp (Dcalc.Ast.Unop (Dcalc.Ast.Log (l, markings))), Pos.get_position e), [ e ]),
Pos.get_position e ))
e
let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Pos.marked Bindlib.box
=
Bindlib.box_apply
(fun (x : Dcalc.Ast.expr) -> Pos.same_pos_as x e)
( match Pos.unmark e with
(match Pos.unmark e with
| EVar v -> Bindlib.box_var (Ast.VarMap.find (Pos.unmark v) ctx.local_vars)
| ELit l -> Bindlib.box (Dcalc.Ast.ELit l)
| EStruct (struct_name, e_fields) ->
@ -88,14 +98,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
let d_fields, remaining_e_fields =
List.fold_right
(fun (field_name, _) (d_fields, e_fields) ->
let field_e =
try Ast.StructFieldMap.find field_name e_fields
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Missing field for structure %a: \"%a\""
Ast.StructName.format_t struct_name Ast.StructFieldName.format_t field_name)
(Pos.get_position e)
in
let field_e = Ast.StructFieldMap.find field_name e_fields in
let field_d = translate_expr ctx field_e in
(field_d :: d_fields, Ast.StructFieldMap.remove field_name e_fields))
struct_sig ([], e_fields)
@ -186,11 +189,46 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
(fun d_fields e1 -> Dcalc.Ast.EMatch (e1, d_fields, enum_name))
(Bindlib.box_list d_cases) e1
| EApp (e1, args) ->
Bindlib.box_apply2
(fun e u -> Dcalc.Ast.EApp (e, u))
(translate_expr ctx e1)
(Bindlib.box_list (List.map (translate_expr ctx) args))
| EAbs (pos_binder, binder, typ) ->
(* We insert various log calls to record arguments and outputs of user-defined functions
belonging to scopes *)
let e1_func = translate_expr ctx e1 in
let markings l =
match l with
| Ast.ScopeVar (v, _) ->
[ Ast.ScopeName.get_info ctx.scope_name; Ast.ScopeVar.get_info v ]
| Ast.SubScopeVar (s, _, (v, _)) -> [ Ast.ScopeName.get_info s; Ast.ScopeVar.get_info v ]
in
let e1_func =
match Pos.unmark e1 with
| ELocation l -> tag_with_log_entry e1_func Dcalc.Ast.BeginCall (markings l)
| _ -> e1_func
in
let new_args = List.map (translate_expr ctx) args in
let new_args =
match (Pos.unmark e1, new_args) with
| ELocation l, [ new_arg ] ->
[
tag_with_log_entry new_arg (Dcalc.Ast.VarDef Dcalc.Ast.TAny)
(markings l @ [ Pos.same_pos_as "input" e ]);
]
| _ -> new_args
in
let new_e =
Bindlib.box_apply2
(fun e' u -> (Dcalc.Ast.EApp (e', u), Pos.get_position e))
e1_func (Bindlib.box_list new_args)
in
let new_e =
match Pos.unmark e1 with
| ELocation l ->
tag_with_log_entry
(tag_with_log_entry new_e (Dcalc.Ast.VarDef Dcalc.Ast.TAny)
(markings l @ [ Pos.same_pos_as "output" e ]))
Dcalc.Ast.EndCall (markings l)
| _ -> new_e
in
Bindlib.box_apply Pos.unmark new_e
| EAbs ((binder, pos_binder), typ) ->
let xs, body = Bindlib.unmbind binder in
let new_xs = Array.map (fun x -> Dcalc.Ast.Var.make (Bindlib.name_of x, Pos.no_pos)) xs in
let both_xs = Array.map2 (fun x new_x -> (x, new_x)) xs new_xs in
@ -207,13 +245,14 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
in
let binder = Bindlib.bind_mvar new_xs body in
Bindlib.box_apply
(fun b -> Dcalc.Ast.EAbs (pos_binder, b, List.map (translate_typ ctx) typ))
(fun b -> Dcalc.Ast.EAbs ((b, pos_binder), List.map (translate_typ ctx) typ))
binder
| EDefault (excepts, just, cons) ->
let just = tag_with_log_entry (translate_expr ctx just) Dcalc.Ast.PosRecordIfTrueBool [] in
Bindlib.box_apply3
(fun e j c -> Dcalc.Ast.EDefault (e, j, c))
(Bindlib.box_list (List.map (translate_expr ctx) excepts))
(translate_expr ctx just) (translate_expr ctx cons)
just (translate_expr ctx cons)
| ELocation (ScopeVar a) ->
Bindlib.box_var (fst (Ast.ScopeVarMap.find (Pos.unmark a) ctx.scope_vars))
| ELocation (SubScopeVar (_, s, a)) -> (
@ -229,20 +268,22 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
as subscope %a's results will not have been computed yet" Ast.SubScopeName.format_t
(Pos.unmark s) Ast.ScopeVar.format_t (Pos.unmark a) Ast.SubScopeName.format_t
(Pos.unmark s))
(Pos.get_position e) )
(Pos.get_position e))
| EIfThenElse (cond, et, ef) ->
Bindlib.box_apply3
(fun c t f -> Dcalc.Ast.EIfThenElse (c, t, f))
(translate_expr ctx cond) (translate_expr ctx et) (translate_expr ctx ef)
| EOp op -> Bindlib.box (Dcalc.Ast.EOp op)
| ErrorOnEmpty e' ->
Bindlib.box_apply (fun e' -> Dcalc.Ast.ErrorOnEmpty e') (translate_expr ctx e')
| EArray es ->
Bindlib.box_apply
(fun es -> Dcalc.Ast.EArray es)
(Bindlib.box_list (List.map (translate_expr ctx) es)) )
(Bindlib.box_list (List.map (translate_expr ctx) es)))
let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info) :
Dcalc.Ast.expr Pos.marked Bindlib.box * ctx =
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info)
(sigma_return_struct_name : Ast.StructName.t) : Dcalc.Ast.expr Pos.marked Bindlib.box * ctx =
match rule with
| Definition ((ScopeVar a, var_def_pos), tau, e) ->
let a_name = Ast.ScopeVar.get_info (Pos.unmark a) in
@ -254,31 +295,22 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
scope_vars = Ast.ScopeVarMap.add (Pos.unmark a) (a_var, Pos.unmark tau) ctx.scope_vars;
}
in
let next_e, new_ctx = translate_rules new_ctx rest (sigma_name, pos_sigma) in
let next_e, new_ctx =
translate_rules new_ctx rest (sigma_name, pos_sigma) sigma_return_struct_name
in
let new_e = translate_expr ctx e in
let a_expr = Dcalc.Ast.make_var (a_var, var_def_pos) in
let merged_expr = merge_defaults a_expr new_e in
let merged_expr =
Bindlib.box_apply
(fun merged_expr ->
( Dcalc.Ast.EApp
( (Dcalc.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.ErrorOnEmpty), Pos.get_position a_name),
[ merged_expr ] ),
Pos.get_position merged_expr ))
merged_expr
(fun merged_expr -> (Dcalc.Ast.ErrorOnEmpty merged_expr, Pos.get_position a_name))
(merge_defaults a_expr new_e)
in
let merged_expr =
Bindlib.box_apply
(fun merged_expr ->
( Dcalc.Ast.EApp
( ( Dcalc.Ast.EOp
(Dcalc.Ast.Unop
(Dcalc.Ast.Log (Dcalc.Ast.VarDef, [ (sigma_name, pos_sigma); a_name ]))),
Pos.get_position a_name ),
[ merged_expr ] ),
Pos.get_position merged_expr ))
merged_expr
tag_with_log_entry merged_expr
(Dcalc.Ast.VarDef (Pos.unmark tau))
[ (sigma_name, pos_sigma); a_name ]
in
let next_e = Dcalc.Ast.make_let_in a_var tau merged_expr next_e in
(next_e, new_ctx)
| Definition ((SubScopeVar (_subs_name, subs_index, subs_var), var_def_pos), tau, e) ->
@ -308,7 +340,9 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
ctx.subscope_vars;
}
in
let next_e, new_ctx = translate_rules new_ctx rest (sigma_name, pos_sigma) in
let next_e, new_ctx =
translate_rules new_ctx rest (sigma_name, pos_sigma) sigma_return_struct_name
in
let intermediate_e =
Dcalc.Ast.make_abs
(Array.of_list [ Pos.unmark a_var ])
@ -316,18 +350,10 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
[ (Dcalc.Ast.TArrow ((TLit TUnit, var_def_pos), tau), var_def_pos) ]
(Pos.get_position e)
in
let new_e = translate_expr ctx e in
let new_e =
Bindlib.box_apply
(fun new_e ->
( Dcalc.Ast.EApp
( ( Dcalc.Ast.EOp
(Dcalc.Ast.Unop
(Dcalc.Ast.Log (Dcalc.Ast.VarDef, [ (sigma_name, pos_sigma); a_name ]))),
Pos.get_position a_name ),
[ new_e ] ),
Pos.get_position new_e ))
new_e
tag_with_log_entry (translate_expr ctx e)
(Dcalc.Ast.VarDef (Pos.unmark tau))
[ (sigma_name, pos_sigma); a_name ]
in
let silent_var = Dcalc.Ast.Var.make ("_", Pos.no_pos) in
let thunked_new_e =
@ -340,7 +366,13 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
let out_e = Dcalc.Ast.make_app intermediate_e [ thunked_new_e ] (Pos.get_position e) in
(out_e, new_ctx)
| Call (subname, subindex) ->
let all_subscope_vars, scope_dcalc_var = Ast.ScopeMap.find subname ctx.scopes_parameters in
let ( all_subscope_vars,
scope_dcalc_var,
_,
called_scope_input_struct,
called_scope_return_struct ) =
Ast.ScopeMap.find subname ctx.scopes_parameters
in
let subscope_vars_defined =
try Ast.SubScopeMap.find subindex ctx.subscope_vars
with Not_found -> Ast.ScopeVarMap.empty
@ -348,6 +380,7 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
let subscope_var_not_yet_defined subvar =
not (Ast.ScopeVarMap.mem subvar subscope_vars_defined)
in
let pos_call = Pos.get_position (Ast.SubScopeName.get_info subindex) in
let subscope_args =
List.map
(fun (subvar, _) ->
@ -355,9 +388,15 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
Bindlib.box Dcalc.Interpreter.empty_thunked_term
else
let a_var, _ = Ast.ScopeVarMap.find subvar subscope_vars_defined in
Dcalc.Ast.make_var (a_var, Pos.get_position (Ast.SubScopeName.get_info subindex)))
Dcalc.Ast.make_var (a_var, pos_call))
all_subscope_vars
in
let subscope_struct_arg =
Bindlib.box_apply
(fun subscope_args ->
(Dcalc.Ast.ETuple (subscope_args, Some called_scope_input_struct), pos_call))
(Bindlib.box_list subscope_args)
in
let all_subscope_vars_dcalc =
List.map
(fun (subvar, tau) ->
@ -382,78 +421,62 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
}
in
let subscope_func =
Dcalc.Ast.make_var (scope_dcalc_var, Pos.get_position (Ast.SubScopeName.get_info subindex))
in
let subscope_func =
Bindlib.box_apply
(fun subscope_func ->
( Dcalc.Ast.EApp
( ( Dcalc.Ast.EOp
(Dcalc.Ast.Unop
(Dcalc.Ast.Log
( Dcalc.Ast.BeginCall,
[
(sigma_name, pos_sigma);
Ast.SubScopeName.get_info subindex;
Ast.ScopeName.get_info subname;
] ))),
Pos.get_position subscope_func ),
[ subscope_func ] ),
Pos.get_position subscope_func ))
subscope_func
tag_with_log_entry
(Dcalc.Ast.make_var
(scope_dcalc_var, Pos.get_position (Ast.SubScopeName.get_info subindex)))
Dcalc.Ast.BeginCall
[
(sigma_name, pos_sigma);
Ast.SubScopeName.get_info subindex;
Ast.ScopeName.get_info subname;
]
in
let call_expr =
Bindlib.box_apply2
(fun e u -> (Dcalc.Ast.EApp (e, u), Pos.no_pos))
subscope_func (Bindlib.box_list subscope_args)
in
let call_expr =
Bindlib.box_apply
(fun call_expr ->
( Dcalc.Ast.EApp
( ( Dcalc.Ast.EOp
(Dcalc.Ast.Unop
(Dcalc.Ast.Log
( Dcalc.Ast.EndCall,
[
(sigma_name, pos_sigma);
Ast.SubScopeName.get_info subindex;
Ast.ScopeName.get_info subname;
] ))),
Pos.get_position call_expr ),
[ call_expr ] ),
Pos.get_position call_expr ))
call_expr
tag_with_log_entry
(Bindlib.box_apply2
(fun e u -> (Dcalc.Ast.EApp (e, [ u ]), Pos.no_pos))
subscope_func subscope_struct_arg)
Dcalc.Ast.EndCall
[
(sigma_name, pos_sigma);
Ast.SubScopeName.get_info subindex;
Ast.ScopeName.get_info subname;
]
in
let result_tuple_var = Dcalc.Ast.Var.make ("result", Pos.no_pos) in
let next_e, new_ctx = translate_rules new_ctx rest (sigma_name, pos_sigma) in
let results_bindings, _ =
List.fold_right
(fun (_, tau, dvar) (acc, i) ->
let result_access =
let next_e, new_ctx =
translate_rules new_ctx rest (sigma_name, pos_sigma) sigma_return_struct_name
in
let results_bindings =
let xs = Array.of_list (List.map (fun (_, _, v) -> v) all_subscope_vars_dcalc) in
let taus = List.map (fun (_, tau, _) -> (tau, pos_sigma)) all_subscope_vars_dcalc in
let e1s =
List.mapi
(fun i _ ->
Bindlib.box_apply
(fun r ->
( Dcalc.Ast.ETupleAccess
( r,
i,
None,
Some called_scope_return_struct,
List.map (fun (_, t, _) -> (t, pos_sigma)) all_subscope_vars_dcalc ),
pos_sigma ))
(Dcalc.Ast.make_var (result_tuple_var, pos_sigma))
in
(Dcalc.Ast.make_let_in dvar (tau, pos_sigma) result_access acc, i - 1))
all_subscope_vars_dcalc
(next_e, List.length all_subscope_vars_dcalc - 1)
(Dcalc.Ast.make_var (result_tuple_var, pos_sigma)))
all_subscope_vars_dcalc
in
Dcalc.Ast.make_multiple_let_in xs taus (Bindlib.box_list e1s) next_e
in
let result_tuple_typ =
( Dcalc.Ast.TTuple
(List.map (fun (_, tau, _) -> (tau, pos_sigma)) all_subscope_vars_dcalc, None),
( List.map (fun (_, tau, _) -> (tau, pos_sigma)) all_subscope_vars_dcalc,
Some called_scope_return_struct ),
pos_sigma )
in
(Dcalc.Ast.make_let_in result_tuple_var result_tuple_typ call_expr results_bindings, new_ctx)
| Assertion e ->
let next_e, new_ctx = translate_rules ctx rest (sigma_name, pos_sigma) in
let next_e, new_ctx =
translate_rules ctx rest (sigma_name, pos_sigma) sigma_return_struct_name
in
let new_e = translate_expr ctx e in
( Dcalc.Ast.make_let_in
(Dcalc.Ast.Var.make ("_", Pos.no_pos))
@ -463,29 +486,32 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
new_ctx )
and translate_rules (ctx : ctx) (rules : Ast.rule list)
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info) :
Dcalc.Ast.expr Pos.marked Bindlib.box * ctx =
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info)
(sigma_return_struct_name : Ast.StructName.t) : Dcalc.Ast.expr Pos.marked Bindlib.box * ctx =
match rules with
| [] ->
let scope_variables = Ast.ScopeVarMap.bindings ctx.scope_vars in
let return_exp =
Bindlib.box_apply
(fun args -> (Dcalc.Ast.ETuple (args, None), pos_sigma))
(fun args -> (Dcalc.Ast.ETuple (args, Some sigma_return_struct_name), pos_sigma))
(Bindlib.box_list
(List.map
(fun (_, (dcalc_var, _)) -> Dcalc.Ast.make_var (dcalc_var, pos_sigma))
scope_variables))
in
(return_exp, ctx)
| hd :: tl -> translate_rule ctx hd tl (sigma_name, pos_sigma)
| hd :: tl -> translate_rule ctx hd tl (sigma_name, pos_sigma) sigma_return_struct_name
let translate_scope_decl (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx)
(sctx : scope_sigs_ctx) (scope_name : Ast.ScopeName.t) (sigma : Ast.scope_decl) :
Dcalc.Ast.expr Pos.marked Bindlib.box =
Dcalc.Ast.expr Pos.marked Bindlib.box * Dcalc.Ast.struct_ctx =
let ctx = empty_ctx struct_ctx enum_ctx sctx scope_name in
let sigma_info = Ast.ScopeName.get_info sigma.scope_decl_name in
let rules, ctx = translate_rules ctx sigma.scope_decl_rules sigma_info in
let scope_variables, _ = Ast.ScopeMap.find sigma.scope_decl_name sctx in
let scope_variables, _, scope_input_var, scope_input_struct_name, scope_return_struct_name =
Ast.ScopeMap.find sigma.scope_decl_name sctx
in
let pos_sigma = Pos.get_position sigma_info in
let rules, ctx = translate_rules ctx sigma.scope_decl_rules sigma_info scope_return_struct_name in
let scope_variables =
List.map
(fun (x, tau) ->
@ -493,70 +519,173 @@ let translate_scope_decl (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx)
(x, tau, dcalc_x))
scope_variables
in
let pos_sigma = Pos.get_position sigma_info in
Dcalc.Ast.make_abs
(Array.of_list (List.map (fun (_, _, x) -> x) scope_variables))
rules pos_sigma
(List.map
(fun (_, tau, _) ->
(Dcalc.Ast.TArrow ((Dcalc.Ast.TLit TUnit, pos_sigma), (tau, pos_sigma)), pos_sigma))
scope_variables)
pos_sigma
let build_scope_typ_from_sig (scope_sig : (Ast.ScopeVar.t * Dcalc.Ast.typ) list) (pos : Pos.t) :
Dcalc.Ast.typ Pos.marked =
let result_typ =
(Dcalc.Ast.TTuple (List.map (fun (_, tau) -> (tau, pos)) scope_sig, None), pos)
(* first we create variables from the fields of the input struct *)
let rules =
let xs = Array.of_list (List.map (fun (_, _, v) -> v) scope_variables) in
let taus =
List.map
(fun (_, tau, _) ->
(Dcalc.Ast.TArrow ((Dcalc.Ast.TLit TUnit, pos_sigma), (tau, pos_sigma)), pos_sigma))
scope_variables
in
let e1s =
List.mapi
(fun i _ ->
Bindlib.box_apply
(fun r ->
( Dcalc.Ast.ETupleAccess
( r,
i,
Some scope_input_struct_name,
List.map
(fun (_, t, _) ->
( Dcalc.Ast.TArrow ((Dcalc.Ast.TLit TUnit, pos_sigma), (t, pos_sigma)),
pos_sigma ))
scope_variables ),
pos_sigma ))
(Dcalc.Ast.make_var (scope_input_var, pos_sigma)))
scope_variables
in
Dcalc.Ast.make_multiple_let_in xs taus (Bindlib.box_list e1s) rules
in
List.fold_right
(fun (_, arg_t) acc ->
(Dcalc.Ast.TArrow ((Dcalc.Ast.TArrow ((TLit TUnit, pos), (arg_t, pos)), pos), acc), pos))
scope_sig result_typ
let scope_return_struct_fields =
List.map
(fun (_, tau, dvar) ->
let struct_field_name =
Ast.StructFieldName.fresh (Bindlib.name_of dvar ^ "_out", pos_sigma)
in
(struct_field_name, (tau, pos_sigma)))
scope_variables
in
let scope_input_struct_fields =
List.map
(fun (_, tau, dvar) ->
let struct_field_name =
Ast.StructFieldName.fresh (Bindlib.name_of dvar ^ "_in", pos_sigma)
in
( struct_field_name,
(Dcalc.Ast.TArrow ((Dcalc.Ast.TLit TUnit, pos_sigma), (tau, pos_sigma)), pos_sigma) ))
scope_variables
in
let new_struct_ctx =
Ast.StructMap.add scope_input_struct_name scope_input_struct_fields
(Ast.StructMap.singleton scope_return_struct_name scope_return_struct_fields)
in
( Dcalc.Ast.make_abs [| scope_input_var |] rules pos_sigma
[
( Dcalc.Ast.TTuple (List.map snd scope_input_struct_fields, Some scope_input_struct_name),
pos_sigma );
]
pos_sigma,
new_struct_ctx )
let build_scope_typ_from_sig (scope_sig : (Ast.ScopeVar.t * Dcalc.Ast.typ) list)
(scope_input_struct_name : Ast.StructName.t) (scope_return_struct_name : Ast.StructName.t)
(pos : Pos.t) : Dcalc.Ast.typ Pos.marked =
let result_typ =
( Dcalc.Ast.TTuple
(List.map (fun (_, tau) -> (tau, pos)) scope_sig, Some scope_return_struct_name),
pos )
in
let input_typ =
( Dcalc.Ast.TTuple
( List.map
(fun (_, tau) -> (Dcalc.Ast.TArrow ((TLit TUnit, pos), (tau, pos)), pos))
scope_sig,
Some scope_input_struct_name ),
pos )
in
(Dcalc.Ast.TArrow (input_typ, result_typ), pos)
let translate_program (prgm : Ast.program) (top_level_scope_name : Ast.ScopeName.t) :
Dcalc.Ast.expr Pos.marked * Dcalc.Ast.decl_ctx =
Dcalc.Ast.program * Dcalc.Ast.expr Pos.marked * Dependency.TVertex.t list =
let scope_dependencies = Dependency.build_program_dep_graph prgm in
Dependency.check_for_cycle_in_scope scope_dependencies;
Dependency.check_type_cycles prgm.program_structs prgm.program_enums;
let types_ordering = Dependency.check_type_cycles prgm.program_structs prgm.program_enums in
let scope_ordering = Dependency.get_scope_ordering scope_dependencies in
let struct_ctx = prgm.program_structs in
let enum_ctx = prgm.program_enums in
let ctx_for_typ_translation scope_name =
empty_ctx struct_ctx enum_ctx Ast.ScopeMap.empty scope_name
in
let dummy_scope = Ast.ScopeName.fresh ("dummy", Pos.no_pos) in
let decl_ctx =
{
Dcalc.Ast.ctx_structs = Ast.StructMap.map (List.map fst) struct_ctx;
Dcalc.Ast.ctx_enums = Ast.EnumMap.map (List.map fst) enum_ctx;
Dcalc.Ast.ctx_structs =
Ast.StructMap.map
(List.map (fun (x, y) -> (x, translate_typ (ctx_for_typ_translation dummy_scope) y)))
struct_ctx;
Dcalc.Ast.ctx_enums =
Ast.EnumMap.map
(List.map (fun (x, y) -> (x, (translate_typ (ctx_for_typ_translation dummy_scope)) y)))
enum_ctx;
}
in
let sctx : scope_sigs_ctx =
Ast.ScopeMap.mapi
(fun scope_name scope ->
let scope_dvar = Dcalc.Ast.Var.make (Ast.ScopeName.get_info scope.Ast.scope_decl_name) in
let scope_return_struct_name =
Ast.StructName.fresh
(Pos.map_under_mark (fun s -> s ^ "_out") (Ast.ScopeName.get_info scope_name))
in
let scope_input_var =
Dcalc.Ast.Var.make
(Pos.map_under_mark (fun s -> s ^ "_in") (Ast.ScopeName.get_info scope_name))
in
let scope_input_struct_name =
Ast.StructName.fresh
(Pos.map_under_mark (fun s -> s ^ "_in") (Ast.ScopeName.get_info scope_name))
in
( List.map
(fun (scope_var, tau) ->
let tau =
translate_typ (empty_ctx struct_ctx enum_ctx Ast.ScopeMap.empty scope_name) tau
in
let tau = translate_typ (ctx_for_typ_translation scope_name) tau in
(scope_var, Pos.unmark tau))
(Ast.ScopeVarMap.bindings scope.scope_sig),
scope_dvar ))
scope_dvar,
scope_input_var,
scope_input_struct_name,
scope_return_struct_name ))
prgm.program_scopes
in
(* the final expression on which we build on is the variable of the top-level scope that we are
returning *)
let acc = Dcalc.Ast.make_var (snd (Ast.ScopeMap.find top_level_scope_name sctx), Pos.no_pos) in
let acc =
Dcalc.Ast.make_var
(let _, x, _, _, _ = Ast.ScopeMap.find top_level_scope_name sctx in
(x, Pos.no_pos))
in
(* the resulting expression is the list of definitions of all the scopes, ending with the
top-level scope. *)
( Bindlib.unbox
(let acc =
List.fold_right
(fun scope_name (acc : Dcalc.Ast.expr Pos.marked Bindlib.box) ->
let scope = Ast.ScopeMap.find scope_name prgm.program_scopes in
let pos_scope = Pos.get_position (Ast.ScopeName.get_info scope.scope_decl_name) in
let scope_expr = translate_scope_decl struct_ctx enum_ctx sctx scope_name scope in
let scope_sig, dvar = Ast.ScopeMap.find scope_name sctx in
let scope_typ = build_scope_typ_from_sig scope_sig pos_scope in
Dcalc.Ast.make_let_in dvar scope_typ scope_expr acc)
scope_ordering acc
in
acc),
decl_ctx )
let whole_program_expr, scopes, decl_ctx =
List.fold_right
(fun scope_name (acc, scopes, decl_ctx) ->
let scope = Ast.ScopeMap.find scope_name prgm.program_scopes in
let pos_scope = Pos.get_position (Ast.ScopeName.get_info scope.scope_decl_name) in
let scope_expr, scope_out_struct =
translate_scope_decl struct_ctx enum_ctx sctx scope_name scope
in
let scope_sig, dvar, _, scope_input_struct_name, scope_return_struct_name =
Ast.ScopeMap.find scope_name sctx
in
let scope_typ =
build_scope_typ_from_sig scope_sig scope_input_struct_name scope_return_struct_name
pos_scope
in
let decl_ctx =
{
decl_ctx with
Dcalc.Ast.ctx_structs =
Ast.StructMap.union
(fun _ _ -> assert false (* should not happen *))
decl_ctx.Dcalc.Ast.ctx_structs scope_out_struct;
}
in
( Dcalc.Ast.make_let_in dvar scope_typ scope_expr acc,
(scope_name, dvar, Bindlib.unbox scope_expr) :: scopes,
decl_ctx ))
scope_ordering (acc, [], decl_ctx)
in
({ scopes; decl_ctx }, Bindlib.unbox whole_program_expr, types_ordering)

25
compiler/scopelang/scope_to_dcalc.mli Normal file
View File

@ -0,0 +1,25 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
val translate_program :
Ast.program ->
Ast.ScopeName.t ->
Dcalc.Ast.program * Dcalc.Ast.expr Pos.marked * Dependency.TVertex.t list
(** Usage [translate_program p scope_name] returns a tuple [(new_program, new_expr, types_list)]
where [new_program] is the map of translated scopes, [new_expr] is the expression that bundles
the whole program and whose entry point is the function corresponding to [scope_name]. Finally,
[types_list] is a list of all types (structs and enums) used in the program, correctly ordered
with respect to inter-types dependency. *)

0
src/catala/scope_language/scopelang.mld → compiler/scopelang/scopelang.mld
View File

569
compiler/surface/ast.ml Normal file
View File

@ -0,0 +1,569 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Abstract syntax tree built by the Catala parser *)
[@@@ocaml.warning "-7"]
open Utils
(** {1 Visitor classes for programs} *)
(** To allow for quick traversal and/or modification of this AST structure, we provide a
{{:https://en.wikipedia.org/wiki/Visitor_pattern} visitor design pattern}. This feature is
implemented via {{:https://gitlab.inria.fr/fpottier/visitors} François Pottier's OCaml visitors
library}. *)
(** {1 Type definitions} *)
type constructor = (string[@opaque])
[@@deriving
visitors { variety = "map"; name = "constructor_map"; nude = true },
visitors { variety = "iter"; name = "constructor_iter"; nude = true }]
(** Constructors are CamelCase *)
type ident = (string[@opaque])
[@@deriving
visitors { variety = "map"; name = "ident_map"; nude = true },
visitors { variety = "iter"; name = "ident_iter"; nude = true }]
(** Idents are snake_case *)
type qident = ident Pos.marked list
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map"; "ident_map" ]; name = "qident_map" },
visitors
{ variety = "iter"; ancestors = [ "Pos.marked_iter"; "ident_iter" ]; name = "qident_iter" }]
type primitive_typ =
| Integer
| Decimal
| Boolean
| Money
| Duration
| Text
| Date
| Named of constructor
[@@deriving
visitors { variety = "map"; ancestors = [ "constructor_map" ]; name = "primitive_typ_map" },
visitors { variety = "iter"; ancestors = [ "constructor_iter" ]; name = "primitive_typ_iter" }]
type base_typ_data = Primitive of primitive_typ | Collection of base_typ_data Pos.marked
[@@deriving
visitors
{
variety = "map";
ancestors = [ "Pos.marked_map"; "primitive_typ_map" ];
name = "base_typ_data_map";
},
visitors
{
variety = "iter";
ancestors = [ "Pos.marked_iter"; "primitive_typ_iter" ];
name = "base_typ_data_iter";
}]
type base_typ = Condition | Data of base_typ_data
[@@deriving
visitors
{ variety = "map"; ancestors = [ "base_typ_data_map" ]; name = "base_typ_map"; nude = true },
visitors
{
variety = "iter";
ancestors = [ "base_typ_data_iter" ];
name = "base_typ_iter";
nude = true;
}]
type func_typ = { arg_typ : base_typ Pos.marked; return_typ : base_typ Pos.marked }
[@@deriving
visitors { variety = "map"; ancestors = [ "base_typ_map" ]; name = "func_typ_map"; nude = true },
visitors
{ variety = "iter"; ancestors = [ "base_typ_iter" ]; name = "func_typ_iter"; nude = true }]
type typ = Base of base_typ | Func of func_typ
[@@deriving
visitors { variety = "map"; ancestors = [ "func_typ_map" ]; name = "typ_map"; nude = true },
visitors { variety = "iter"; ancestors = [ "func_typ_iter" ]; name = "typ_iter"; nude = true }]
type struct_decl_field = {
struct_decl_field_name : ident Pos.marked;
struct_decl_field_typ : typ Pos.marked;
}
[@@deriving
visitors
{ variety = "map"; ancestors = [ "typ_map"; "ident_map" ]; name = "struct_decl_field_map" },
visitors
{
variety = "iter";
ancestors = [ "typ_iter"; "ident_iter" ];
name = "struct_decl_field_iter";
}]
type struct_decl = {
struct_decl_name : constructor Pos.marked;
struct_decl_fields : struct_decl_field Pos.marked list;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "struct_decl_field_map" ]; name = "struct_decl_map" },
visitors
{ variety = "iter"; ancestors = [ "struct_decl_field_iter" ]; name = "struct_decl_iter" }]
type enum_decl_case = {
enum_decl_case_name : constructor Pos.marked;
enum_decl_case_typ : typ Pos.marked option;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "typ_map" ]; name = "enum_decl_case_map"; nude = true },
visitors
{ variety = "iter"; ancestors = [ "typ_iter" ]; name = "enum_decl_case_iter"; nude = true }]
type enum_decl = {
enum_decl_name : constructor Pos.marked;
enum_decl_cases : enum_decl_case Pos.marked list;
}
[@@deriving
visitors
{ variety = "map"; ancestors = [ "enum_decl_case_map" ]; name = "enum_decl_map"; nude = true },
visitors
{
variety = "iter";
ancestors = [ "enum_decl_case_iter" ];
name = "enum_decl_iter";
nude = true;
}]
type match_case_pattern =
(constructor Pos.marked option * constructor Pos.marked) list * ident Pos.marked option
[@@deriving
visitors
{
variety = "map";
ancestors = [ "ident_map"; "constructor_map"; "Pos.marked_map" ];
name = "match_case_pattern_map";
},
visitors
{
variety = "iter";
ancestors = [ "ident_iter"; "constructor_iter"; "Pos.marked_iter" ];
name = "match_case_pattern_iter";
}]
type op_kind = KInt | KDec | KMoney | KDate | KDuration
[@@deriving
visitors { variety = "map"; name = "op_kind_map"; nude = true },
visitors { variety = "iter"; name = "op_kind_iter"; nude = true }]
type binop =
| And
| Or
| Xor
| Add of op_kind
| Sub of op_kind
| Mult of op_kind
| Div of op_kind
| Lt of op_kind
| Lte of op_kind
| Gt of op_kind
| Gte of op_kind
| Eq
| Neq
| Concat
[@@deriving
visitors { variety = "map"; ancestors = [ "op_kind_map" ]; name = "binop_map"; nude = true },
visitors { variety = "iter"; ancestors = [ "op_kind_iter" ]; name = "binop_iter"; nude = true }]
type unop = Not | Minus of op_kind
[@@deriving
visitors { variety = "map"; ancestors = [ "op_kind_map" ]; name = "unop_map"; nude = true },
visitors { variety = "iter"; ancestors = [ "op_kind_iter" ]; name = "unop_iter"; nude = true }]
type builtin_expression = Cardinal | IntToDec | GetDay | GetMonth | GetYear
[@@deriving
visitors { variety = "map"; name = "builtin_expression_map"; nude = true },
visitors { variety = "iter"; name = "builtin_expression_iter"; nude = true }]
type literal_date = {
literal_date_day : (int[@opaque]) Pos.marked;
literal_date_month : (int[@opaque]) Pos.marked;
literal_date_year : (int[@opaque]) Pos.marked;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "literal_date_map" },
visitors { variety = "iter"; ancestors = [ "Pos.marked_iter" ]; name = "literal_date_iter" }]
type literal_number =
| Int of (Runtime.integer[@opaque])
| Dec of (Runtime.integer[@opaque]) * (Runtime.integer[@opaque])
[@@deriving
visitors { variety = "map"; name = "literal_number_map"; nude = true },
visitors { variety = "iter"; name = "literal_number_iter"; nude = true }]
type literal_unit = Percent | Year | Month | Day
[@@deriving
visitors { variety = "map"; name = "literal_unit_map"; nude = true },
visitors { variety = "iter"; name = "literal_unit_iter"; nude = true }]
type money_amount = {
money_amount_units : (Runtime.integer[@opaque]);
money_amount_cents : (Runtime.integer[@opaque]);
}
[@@deriving
visitors { variety = "map"; name = "money_amount_map"; nude = true },
visitors { variety = "iter"; name = "money_amount_iter"; nude = true }]
type literal =
| LNumber of literal_number Pos.marked * literal_unit Pos.marked option
| LBool of bool
| LMoneyAmount of money_amount
| LDate of literal_date
[@@deriving
visitors
{
variety = "map";
ancestors =
[ "literal_number_map"; "money_amount_map"; "literal_date_map"; "literal_unit_map" ];
name = "literal_map";
},
visitors
{
variety = "iter";
ancestors =
[ "literal_number_iter"; "money_amount_iter"; "literal_date_iter"; "literal_unit_iter" ];
name = "literal_iter";
}]
type aggregate_func =
| AggregateSum of primitive_typ
| AggregateCount
| AggregateExtremum of bool * primitive_typ * expression Pos.marked
| AggregateArgExtremum of bool * primitive_typ * expression Pos.marked
and collection_op = Exists | Forall | Aggregate of aggregate_func | Map | Filter
and explicit_match_case = {
match_case_pattern : match_case_pattern Pos.marked;
match_case_expr : expression Pos.marked;
}
and match_case = WildCard of expression Pos.marked | MatchCase of explicit_match_case
and match_cases = match_case Pos.marked list
and expression =
| MatchWith of expression Pos.marked * match_cases Pos.marked
| IfThenElse of expression Pos.marked * expression Pos.marked * expression Pos.marked
| Binop of binop Pos.marked * expression Pos.marked * expression Pos.marked
| Unop of unop Pos.marked * expression Pos.marked
| CollectionOp of
collection_op Pos.marked * ident Pos.marked * expression Pos.marked * expression Pos.marked
| MemCollection of expression Pos.marked * expression Pos.marked
| TestMatchCase of expression Pos.marked * match_case_pattern Pos.marked
| FunCall of expression Pos.marked * expression Pos.marked
| Builtin of builtin_expression
| Literal of literal
| EnumInject of
constructor Pos.marked option * constructor Pos.marked * expression Pos.marked option
| StructLit of constructor Pos.marked * (ident Pos.marked * expression Pos.marked) list
| ArrayLit of expression Pos.marked list
| Ident of ident
| Dotted of expression Pos.marked * constructor Pos.marked option * ident Pos.marked
(** Dotted is for both struct field projection and sub-scope variables *)
[@@deriving
visitors
{
variety = "map";
ancestors =
[
"primitive_typ_map";
"match_case_pattern_map";
"literal_map";
"binop_map";
"unop_map";
"builtin_expression_map";
];
name = "expression_map";
},
visitors
{
variety = "iter";
ancestors =
[
"primitive_typ_iter";
"match_case_pattern_iter";
"literal_iter";
"binop_iter";
"unop_iter";
"builtin_expression_iter";
];
name = "expression_iter";
}]
type exception_to = NotAnException | UnlabeledException | ExceptionToLabel of ident Pos.marked
[@@deriving
visitors
{ variety = "map"; ancestors = [ "ident_map"; "Pos.marked_map" ]; name = "exception_to_map" },
visitors
{
variety = "iter";
ancestors = [ "ident_iter"; "Pos.marked_iter" ];
name = "exception_to_iter";
}]
type rule = {
rule_label : ident Pos.marked option;
rule_exception_to : exception_to;
rule_parameter : ident Pos.marked option;
rule_condition : expression Pos.marked option;
rule_name : qident Pos.marked;
rule_consequence : (bool[@opaque]) Pos.marked;
}
[@@deriving
visitors
{
variety = "map";
ancestors = [ "expression_map"; "qident_map"; "exception_to_map" ];
name = "rule_map";
},
visitors
{
variety = "iter";
ancestors = [ "expression_iter"; "qident_iter"; "exception_to_iter" ];
name = "rule_iter";
}]
type definition = {
definition_label : ident Pos.marked option;
definition_exception_to : exception_to;
definition_name : qident Pos.marked;
definition_parameter : ident Pos.marked option;
definition_condition : expression Pos.marked option;
definition_expr : expression Pos.marked;
}
[@@deriving
visitors
{
variety = "map";
ancestors = [ "expression_map"; "qident_map"; "exception_to_map" ];
name = "definition_map";
},
visitors
{
variety = "iter";
ancestors = [ "expression_iter"; "qident_iter"; "exception_to_iter" ];
name = "definition_iter";
}]
type variation_typ = Increasing | Decreasing
[@@deriving
visitors { variety = "map"; name = "variation_typ_map" },
visitors { variety = "iter"; name = "variation_typ_iter" }]
type meta_assertion =
| FixedBy of qident Pos.marked * ident Pos.marked
| VariesWith of qident Pos.marked * expression Pos.marked * variation_typ Pos.marked option
[@@deriving
visitors
{
variety = "map";
ancestors = [ "variation_typ_map"; "qident_map"; "expression_map" ];
name = "meta_assertion_map";
},
visitors
{
variety = "iter";
ancestors = [ "variation_typ_iter"; "qident_iter"; "expression_iter" ];
name = "meta_assertion_iter";
}]
type assertion = {
assertion_condition : expression Pos.marked option;
assertion_content : expression Pos.marked;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "expression_map" ]; name = "assertion_map" },
visitors { variety = "iter"; ancestors = [ "expression_iter" ]; name = "assertion_iter" }]
type scope_use_item =
| Rule of rule
| Definition of definition
| Assertion of assertion
| MetaAssertion of meta_assertion
[@@deriving
visitors
{
variety = "map";
ancestors = [ "meta_assertion_map"; "definition_map"; "assertion_map"; "rule_map" ];
name = "scope_use_item_map";
},
visitors
{
variety = "iter";
ancestors = [ "meta_assertion_iter"; "definition_iter"; "assertion_iter"; "rule_iter" ];
name = "scope_use_item_iter";
}]
type scope_use = {
scope_use_condition : expression Pos.marked option;
scope_use_name : constructor Pos.marked;
scope_use_items : scope_use_item Pos.marked list;
}
[@@deriving
visitors
{
variety = "map";
ancestors = [ "expression_map"; "scope_use_item_map" ];
name = "scope_use_map";
},
visitors
{
variety = "iter";
ancestors = [ "expression_iter"; "scope_use_item_iter" ];
name = "scope_use_iter";
}]
type scope_decl_context_scope = {
scope_decl_context_scope_name : ident Pos.marked;
scope_decl_context_scope_sub_scope : constructor Pos.marked;
}
[@@deriving
visitors
{
variety = "map";
ancestors = [ "ident_map"; "constructor_map"; "Pos.marked_map" ];
name = "scope_decl_context_scope_map";
},
visitors
{
variety = "iter";
ancestors = [ "ident_iter"; "constructor_iter"; "Pos.marked_iter" ];
name = "scope_decl_context_scope_iter";
}]
type scope_decl_context_data = {
scope_decl_context_item_name : ident Pos.marked;
scope_decl_context_item_typ : typ Pos.marked;
}
[@@deriving
visitors
{
variety = "map";
ancestors = [ "typ_map"; "ident_map" ];
name = "scope_decl_context_data_map";
},
visitors
{
variety = "iter";
ancestors = [ "typ_iter"; "ident_iter" ];
name = "scope_decl_context_data_iter";
}]
type scope_decl_context_item =
| ContextData of scope_decl_context_data
| ContextScope of scope_decl_context_scope
[@@deriving
visitors
{
variety = "map";
ancestors = [ "scope_decl_context_data_map"; "scope_decl_context_scope_map" ];
name = "scope_decl_context_item_map";
},
visitors
{
variety = "iter";
ancestors = [ "scope_decl_context_data_iter"; "scope_decl_context_scope_iter" ];
name = "scope_decl_context_item_iter";
}]
type scope_decl = {
scope_decl_name : constructor Pos.marked;
scope_decl_context : scope_decl_context_item Pos.marked list;
}
[@@deriving
visitors
{ variety = "map"; ancestors = [ "scope_decl_context_item_map" ]; name = "scope_decl_map" },
visitors
{ variety = "iter"; ancestors = [ "scope_decl_context_item_iter" ]; name = "scope_decl_iter" }]
type code_item =
| ScopeUse of scope_use
| ScopeDecl of scope_decl
| StructDecl of struct_decl
| EnumDecl of enum_decl
[@@deriving
visitors
{
variety = "map";
ancestors = [ "scope_decl_map"; "enum_decl_map"; "struct_decl_map"; "scope_use_map" ];
name = "code_item_map";
},
visitors
{
variety = "iter";
ancestors = [ "scope_decl_iter"; "enum_decl_iter"; "struct_decl_iter"; "scope_use_iter" ];
name = "code_item_iter";
}]
type code_block = code_item Pos.marked list
[@@deriving
visitors { variety = "map"; ancestors = [ "code_item_map" ]; name = "code_block_map" },
visitors { variety = "iter"; ancestors = [ "code_item_iter" ]; name = "code_block_iter" }]
type source_repr = (string[@opaque]) Pos.marked
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "source_repr_map" },
visitors { variety = "iter"; ancestors = [ "Pos.marked_iter" ]; name = "source_repr_iter" }]
type law_heading = {
law_heading_name : (string[@opaque]) Pos.marked;
law_heading_id : (string[@opaque]) option;
law_heading_expiration_date : (string[@opaque]) option;
law_heading_precedence : (int[@opaque]);
}
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "law_heading_map" },
visitors { variety = "iter"; ancestors = [ "Pos.marked_iter" ]; name = "law_heading_iter" }]
type law_include =
| PdfFile of (string[@opaque]) Pos.marked * (int[@opaque]) option
| CatalaFile of (string[@opaque]) Pos.marked
| LegislativeText of (string[@opaque]) Pos.marked
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "law_include_map" },
visitors { variety = "iter"; ancestors = [ "Pos.marked_iter" ]; name = "law_include_iter" }]
type law_structure =
| LawInclude of law_include
| LawHeading of law_heading * law_structure list
| LawText of (string[@opaque])
| CodeBlock of code_block * source_repr * bool (* Metadata if true *)
[@@deriving
visitors
{
variety = "map";
ancestors = [ "law_include_map"; "code_block_map"; "source_repr_map"; "law_heading_map" ];
name = "law_structure_map";
},
visitors
{
variety = "iter";
ancestors =
[ "law_include_iter"; "code_block_iter"; "source_repr_iter"; "law_heading_iter" ];
name = "law_structure_iter";
}]
type program = { program_items : law_structure list; program_source_files : (string[@opaque]) list }
[@@deriving
visitors { variety = "map"; ancestors = [ "law_structure_map" ]; name = "program_map" },
visitors { variety = "iter"; ancestors = [ "law_structure_iter" ]; name = "program_iter" }]
type source_file = law_structure list

600
src/catala/catala_surface/desugaring.ml → compiler/surface/desugaring.ml
View File

@ -17,9 +17,7 @@
- Removes syntactic sugars
- Separate code from legislation *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
open Utils
(** {1 Translating expressions} *)
@ -35,6 +33,7 @@ let translate_binop (op : Ast.binop) : Dcalc.Ast.binop =
match op with
| And -> And
| Or -> Or
| Xor -> Xor
| Add l -> Add (translate_op_kind l)
| Sub l -> Sub (translate_op_kind l)
| Mult l -> Mult (translate_op_kind l)
@ -45,6 +44,7 @@ let translate_binop (op : Ast.binop) : Dcalc.Ast.binop =
| Gte l -> Gte (translate_op_kind l)
| Eq -> Eq
| Neq -> Neq
| Concat -> Concat
let translate_unop (op : Ast.unop) : Dcalc.Ast.unop =
match op with Not -> Not | Minus l -> Minus (translate_op_kind l)
@ -57,9 +57,10 @@ let translate_unop (op : Ast.unop) : Dcalc.Ast.unop =
module LiftStructFieldMap = Bindlib.Lift (Scopelang.Ast.StructFieldMap)
module LiftEnumConstructorMap = Bindlib.Lift (Scopelang.Ast.EnumConstructorMap)
let disambiguate_constructor (ctxt : Name_resolution.context) (constructor : string Pos.marked list)
(pos : Pos.t) : Scopelang.Ast.EnumName.t * Scopelang.Ast.EnumConstructor.t =
let constructor =
let disambiguate_constructor (ctxt : Name_resolution.context)
(constructor : (string Pos.marked option * string Pos.marked) list) (pos : Pos.t) :
Scopelang.Ast.EnumName.t * Scopelang.Ast.EnumConstructor.t =
let enum, constructor =
match constructor with
| [ c ] -> c
| _ ->
@ -73,17 +74,36 @@ let disambiguate_constructor (ctxt : Name_resolution.context) (constructor : str
"The name of this constructor has not been defined before, maybe it is a typo?"
(Pos.get_position constructor)
in
if Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1 then
Errors.raise_spanned_error
(Format.asprintf
"This constuctor name is ambiguous, it can belong to %a. Desambiguate it by prefixing it \
with the enum name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) -> Format.fprintf fmt "%a" Scopelang.Ast.EnumName.format_t s_name))
(Scopelang.Ast.EnumMap.bindings possible_c_uids))
(Pos.get_position constructor);
Scopelang.Ast.EnumMap.choose possible_c_uids
match enum with
| None ->
if Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1 then
Errors.raise_spanned_error
(Format.asprintf
"This constructor name is ambiguous, it can belong to %a. Disambiguate it by \
prefixing it with the enum name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" Scopelang.Ast.EnumName.format_t s_name))
(Scopelang.Ast.EnumMap.bindings possible_c_uids))
(Pos.get_position constructor);
Scopelang.Ast.EnumMap.choose possible_c_uids
| Some enum -> (
try
(* The path is fully qualified *)
let e_uid = Desugared.Ast.IdentMap.find (Pos.unmark enum) ctxt.enum_idmap in
try
let c_uid = Scopelang.Ast.EnumMap.find e_uid possible_c_uids in
(e_uid, c_uid)
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Enum %s does not contain case %s" (Pos.unmark enum)
(Pos.unmark constructor))
pos
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Enum %s has not been defined before" (Pos.unmark enum))
(Pos.get_position enum))
(** Usage: [translate_expr scope ctxt expr]
@ -138,61 +158,67 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
| Literal l ->
let untyped_term =
match l with
| Number ((Int i, _), None) -> Scopelang.Ast.ELit (Dcalc.Ast.LInt i)
| Number ((Int i, _), Some (Percent, _)) ->
Scopelang.Ast.ELit (Dcalc.Ast.LRat (Q.div (Q.of_bigint i) (Q.of_int 100)))
| Number ((Dec (i, f), _), None) ->
| LNumber ((Int i, _), None) -> Scopelang.Ast.ELit (Dcalc.Ast.LInt i)
| LNumber ((Int i, _), Some (Percent, _)) ->
Scopelang.Ast.ELit
(Dcalc.Ast.LRat Runtime.(decimal_of_integer i /& decimal_of_string "100"))
| LNumber ((Dec (i, f), _), None) ->
let digits_f =
try int_of_float (ceil (float_of_int (Z.log2 f) *. log 2.0 /. log 10.0))
try int_of_float (ceil (float_of_int (Runtime.integer_log2 f) *. log 2.0 /. log 10.0))
with Invalid_argument _ -> 0
in
Scopelang.Ast.ELit
(Dcalc.Ast.LRat
Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f))))
| Number ((Dec (i, f), _), Some (Percent, _)) ->
Runtime.(
decimal_of_integer i
+& decimal_of_integer f
/& decimal_of_integer (integer_exponentiation (integer_of_int 10) digits_f)))
| LNumber ((Dec (i, f), _), Some (Percent, _)) ->
let digits_f =
try int_of_float (ceil (float_of_int (Z.log2 f) *. log 2.0 /. log 10.0))
try int_of_float (ceil (float_of_int (Runtime.integer_log2 f) *. log 2.0 /. log 10.0))
with Invalid_argument _ -> 0
in
Scopelang.Ast.ELit
(Dcalc.Ast.LRat
(Q.div
Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f)))
(Q.of_int 100)))
| Bool b -> Scopelang.Ast.ELit (Dcalc.Ast.LBool b)
| MoneyAmount i ->
Runtime.(
(decimal_of_integer i
+& decimal_of_integer f
/& decimal_of_integer (integer_exponentiation (integer_of_int 10) digits_f))
/& decimal_of_string "100"))
| LBool b -> Scopelang.Ast.ELit (Dcalc.Ast.LBool b)
| LMoneyAmount i ->
Scopelang.Ast.ELit
(Dcalc.Ast.LMoney Z.((i.money_amount_units * of_int 100) + i.money_amount_cents))
| Number ((Int i, _), Some (Year, _)) ->
(Dcalc.Ast.LMoney
Runtime.(
money_of_cents_integer
((i.money_amount_units *! integer_of_int 100) +! i.money_amount_cents)))
| LNumber ((Int i, _), Some (Year, _)) ->
Scopelang.Ast.ELit
(Dcalc.Ast.LDuration (CalendarLib.Date.Period.lmake ~year:(Z.to_int i) ()))
| Number ((Int i, _), Some (Month, _)) ->
(Dcalc.Ast.LDuration (Runtime.duration_of_numbers (Runtime.integer_to_int i) 0 0))
| LNumber ((Int i, _), Some (Month, _)) ->
Scopelang.Ast.ELit
(Dcalc.Ast.LDuration (CalendarLib.Date.Period.lmake ~month:(Z.to_int i) ()))
| Number ((Int i, _), Some (Day, _)) ->
(Dcalc.Ast.LDuration (Runtime.duration_of_numbers 0 (Runtime.integer_to_int i) 0))
| LNumber ((Int i, _), Some (Day, _)) ->
Scopelang.Ast.ELit
(Dcalc.Ast.LDuration (CalendarLib.Date.Period.lmake ~day:(Z.to_int i) ()))
| Number ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
(Dcalc.Ast.LDuration (Runtime.duration_of_numbers 0 0 (Runtime.integer_to_int i)))
| LNumber ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
Errors.raise_spanned_error
"Impossible to specify decimal amounts of days, months or years" pos
| Date date ->
| LDate date ->
if Pos.unmark date.literal_date_month > 12 then
Errors.raise_spanned_error "Month number bigger than 12"
(Pos.get_position date.literal_date_month);
if Pos.unmark date.literal_date_day > 31 then
Errors.raise_spanned_error "Month number bigger than 31"
(Pos.get_position date.literal_date_day);
let date =
try
CalendarLib.Date.lmake
~year:(Pos.unmark date.literal_date_year)
~day:(Pos.unmark date.literal_date_day)
~month:(Pos.unmark date.literal_date_month)
()
with CalendarLib.Date.Out_of_bounds | CalendarLib.Date.Undefined ->
Errors.raise_spanned_error "Invalid date" pos
in
Scopelang.Ast.ELit (Dcalc.Ast.LDate date)
Scopelang.Ast.ELit
(Dcalc.Ast.LDate
(try
Runtime.date_of_numbers
(Pos.unmark date.literal_date_year)
(Pos.unmark date.literal_date_month)
(Pos.unmark date.literal_date_day)
with Runtime.ImpossibleDate -> Errors.raise_spanned_error "Invalid date" pos))
in
Bindlib.box (untyped_term, pos)
| Ident x -> (
@ -207,7 +233,7 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
| Some uid ->
Scopelang.Ast.make_var (uid, pos) (* the whole box thing is to accomodate for this case *)
)
| Dotted (e, x) -> (
| Dotted (e, c, x) -> (
match Pos.unmark e with
| Ident y when Name_resolution.is_subscope_uid scope ctxt y ->
(* In this case, y.x is a subscope variable *)
@ -222,29 +248,49 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
( Scopelang.Ast.ELocation
(SubScopeVar (subscope_real_uid, (subscope_uid, pos), (subscope_var_uid, pos))),
pos )
| _ ->
| _ -> (
(* In this case e.x is the struct field x access of expression e *)
let e = translate_expr scope ctxt e in
let x_possible_structs =
try Desugared.Ast.IdentMap.find (Pos.unmark x) ctxt.field_idmap
with Not_found ->
Errors.raise_spanned_error "This identifier should refer to a struct field"
Errors.raise_spanned_error "Unknown subscope or struct field name"
(Pos.get_position x)
in
if Scopelang.Ast.StructMap.cardinal x_possible_structs > 1 then
Errors.raise_spanned_error
(Format.asprintf
"This struct field name is ambiguous, it can belong to %a. Desambiguate it by \
prefixing it with the struct name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" Scopelang.Ast.StructName.format_t s_name))
(Scopelang.Ast.StructMap.bindings x_possible_structs))
(Pos.get_position x)
else
let s_uid, f_uid = Scopelang.Ast.StructMap.choose x_possible_structs in
Bindlib.box_apply (fun e -> (Scopelang.Ast.EStructAccess (e, f_uid, s_uid), pos)) e )
match c with
| None ->
(* No constructor name was specified *)
if Scopelang.Ast.StructMap.cardinal x_possible_structs > 1 then
Errors.raise_spanned_error
(Format.asprintf
"This struct field name is ambiguous, it can belong to %a. Disambiguate it by \
prefixing it with the struct name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" Scopelang.Ast.StructName.format_t s_name))
(Scopelang.Ast.StructMap.bindings x_possible_structs))
(Pos.get_position x)
else
let s_uid, f_uid = Scopelang.Ast.StructMap.choose x_possible_structs in
Bindlib.box_apply (fun e -> (Scopelang.Ast.EStructAccess (e, f_uid, s_uid), pos)) e
| Some c_name -> (
try
let c_uid = Desugared.Ast.IdentMap.find (Pos.unmark c_name) ctxt.struct_idmap in
try
let f_uid = Scopelang.Ast.StructMap.find c_uid x_possible_structs in
Bindlib.box_apply
(fun e -> (Scopelang.Ast.EStructAccess (e, f_uid, c_uid), pos))
e
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Struct %s does not contain field %s" (Pos.unmark c_name)
(Pos.unmark x))
pos
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Struct %s has not been defined before" (Pos.unmark c_name))
(Pos.get_position c_name))))
| FunCall (f, arg) ->
Bindlib.box_apply2
(fun f arg -> (Scopelang.Ast.EApp (f, [ arg ]), pos))
@ -269,22 +315,32 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
(Pos.unmark s_name))
(Pos.get_position f_name)
in
( match Scopelang.Ast.StructFieldMap.find_opt f_uid s_fields with
(match Scopelang.Ast.StructFieldMap.find_opt f_uid s_fields with
| None -> ()
| Some e_field ->
Errors.raise_multispanned_error
(Format.asprintf "The field %a has been defined twice:"
Scopelang.Ast.StructFieldName.format_t f_uid)
[ (None, Pos.get_position f_e); (None, Pos.get_position (Bindlib.unbox e_field)) ]
);
[ (None, Pos.get_position f_e); (None, Pos.get_position (Bindlib.unbox e_field)) ]);
let f_e = translate_expr scope ctxt f_e in
Scopelang.Ast.StructFieldMap.add f_uid f_e s_fields)
Scopelang.Ast.StructFieldMap.empty fields
in
let expected_s_fields = Scopelang.Ast.StructMap.find s_uid ctxt.structs in
Scopelang.Ast.StructFieldMap.iter
(fun expected_f _ ->
if not (Scopelang.Ast.StructFieldMap.mem expected_f s_fields) then
Errors.raise_spanned_error
(Format.asprintf "Missing field for structure %a: \"%a\""
Scopelang.Ast.StructName.format_t s_uid Scopelang.Ast.StructFieldName.format_t
expected_f)
pos)
expected_s_fields;
Bindlib.box_apply
(fun s_fields -> (Scopelang.Ast.EStruct (s_uid, s_fields), pos))
(LiftStructFieldMap.lift_box s_fields)
| EnumInject (constructor, payload) ->
| EnumInject (enum, constructor, payload) -> (
let possible_c_uids =
try Desugared.Ast.IdentMap.find (Pos.unmark constructor) ctxt.constructor_idmap
with Not_found ->
@ -292,30 +348,61 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
"The name of this constructor has not been defined before, maybe it is a typo?"
(Pos.get_position constructor)
in
if Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1 then
Errors.raise_spanned_error
(Format.asprintf
"This constuctor name is ambiguous, it can belong to %a. Desambiguate it by prefixing \
it with the enum name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" Scopelang.Ast.EnumName.format_t s_name))
(Scopelang.Ast.EnumMap.bindings possible_c_uids))
(Pos.get_position constructor)
else
let e_uid, c_uid = Scopelang.Ast.EnumMap.choose possible_c_uids in
let payload = Option.map (translate_expr scope ctxt) payload in
Bindlib.box_apply
(fun payload ->
( Scopelang.Ast.EEnumInj
( ( match payload with
| Some e' -> e'
| None -> (Scopelang.Ast.ELit Dcalc.Ast.LUnit, Pos.get_position constructor) ),
c_uid,
e_uid ),
pos ))
(Bindlib.box_opt payload)
match enum with
| None ->
if
(* No constructor name was specified *)
Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1
then
Errors.raise_spanned_error
(Format.asprintf
"This constructor name is ambiguous, it can belong to %a. Desambiguate it by \
prefixing it with the enum name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" Scopelang.Ast.EnumName.format_t s_name))
(Scopelang.Ast.EnumMap.bindings possible_c_uids))
(Pos.get_position constructor)
else
let e_uid, c_uid = Scopelang.Ast.EnumMap.choose possible_c_uids in
let payload = Option.map (translate_expr scope ctxt) payload in
Bindlib.box_apply
(fun payload ->
( Scopelang.Ast.EEnumInj
( (match payload with
| Some e' -> e'
| None -> (Scopelang.Ast.ELit Dcalc.Ast.LUnit, Pos.get_position constructor)),
c_uid,
e_uid ),
pos ))
(Bindlib.box_opt payload)
| Some enum -> (
try
(* The path has been fully qualified *)
let e_uid = Desugared.Ast.IdentMap.find (Pos.unmark enum) ctxt.enum_idmap in
try
let c_uid = Scopelang.Ast.EnumMap.find e_uid possible_c_uids in
let payload = Option.map (translate_expr scope ctxt) payload in
Bindlib.box_apply
(fun payload ->
( Scopelang.Ast.EEnumInj
( (match payload with
| Some e' -> e'
| None -> (Scopelang.Ast.ELit Dcalc.Ast.LUnit, Pos.get_position constructor)),
c_uid,
e_uid ),
pos ))
(Bindlib.box_opt payload)
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Enum %s does not contain case %s" (Pos.unmark enum)
(Pos.unmark constructor))
pos
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Enum %s has not been defined before" (Pos.unmark enum))
(Pos.get_position enum)))
| MatchWith (e1, (cases, _cases_pos)) ->
let e1 = translate_expr scope ctxt e1 in
let cases_d, e_uid = disambiguate_match_and_build_expression scope ctxt cases in
@ -324,12 +411,12 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
e1
(LiftEnumConstructorMap.lift_box cases_d)
| TestMatchCase (e1, pattern) ->
( match snd (Pos.unmark pattern) with
(match snd (Pos.unmark pattern) with
| None -> ()
| Some binding ->
Errors.print_spanned_warning
"This binding will be ignored (remove it to suppress warning)"
(Pos.get_position binding) );
(Pos.get_position binding));
let enum_uid, c_uid =
disambiguate_constructor ctxt (fst (Pos.unmark pattern)) (Pos.get_position pattern)
in
@ -365,10 +452,10 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
(fun f_pred collection ->
( Scopelang.Ast.EApp
( ( Scopelang.Ast.EOp
( match op' with
(match op' with
| Ast.Map -> Dcalc.Ast.Binop Dcalc.Ast.Map
| Ast.Filter -> Dcalc.Ast.Binop Dcalc.Ast.Filter
| _ -> assert false (* should not happen *) ),
| _ -> assert false (* should not happen *)),
pos ),
[ f_pred; collection ] ),
pos ))
@ -451,14 +538,20 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool false), Pos.get_position op')
| Ast.Forall -> Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool true), Pos.get_position op')
| Ast.Aggregate (Ast.AggregateSum Ast.Integer) ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LInt Z.zero), Pos.get_position op')
Bindlib.box
(Scopelang.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 0)), Pos.get_position op')
| Ast.Aggregate (Ast.AggregateSum Ast.Decimal) ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LRat Q.zero), Pos.get_position op')
Bindlib.box
( Scopelang.Ast.ELit (Dcalc.Ast.LRat (Runtime.decimal_of_string "0")),
Pos.get_position op' )
| Ast.Aggregate (Ast.AggregateSum Ast.Money) ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LMoney Z.zero), Pos.get_position op')
Bindlib.box
( Scopelang.Ast.ELit
(Dcalc.Ast.LMoney (Runtime.money_of_cents_integer (Runtime.integer_of_int 0))),
Pos.get_position op' )
| Ast.Aggregate (Ast.AggregateSum Ast.Duration) ->
Bindlib.box
( Scopelang.Ast.ELit (Dcalc.Ast.LDuration CalendarLib.Date.Period.empty),
( Scopelang.Ast.ELit (Dcalc.Ast.LDuration (Runtime.duration_of_numbers 0 0 0)),
Pos.get_position op' )
| Ast.Aggregate (Ast.AggregateSum t) ->
Errors.raise_spanned_error
@ -467,7 +560,8 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
pos
| Ast.Aggregate (Ast.AggregateExtremum (_, _, init)) -> rec_helper init
| Ast.Aggregate Ast.AggregateCount ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LInt Z.zero), Pos.get_position op')
Bindlib.box
(Scopelang.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 0)), Pos.get_position op')
in
let acc_var = Scopelang.Ast.Var.make ("acc", Pos.get_position param') in
let acc = Scopelang.Ast.make_var (acc_var, Pos.get_position param') in
@ -537,7 +631,8 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
Pos.get_position op' ),
[
acc;
(Scopelang.Ast.ELit (Dcalc.Ast.LInt Z.one), Pos.get_position predicate);
( Scopelang.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 1)),
Pos.get_position predicate );
] ),
pos ),
acc ),
@ -550,8 +645,7 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
Bindlib.box_apply
(fun binder ->
( Scopelang.Ast.EAbs
( pos,
binder,
( (binder, pos),
[
(Scopelang.Ast.TLit t, Pos.get_position op');
(Scopelang.Ast.TAny, pos)
@ -614,8 +708,7 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
Bindlib.box_apply
(fun binder ->
( Scopelang.Ast.EAbs
( pos,
binder,
( (binder, pos),
[ (Scopelang.Ast.TLit Dcalc.Ast.TBool, pos); (Scopelang.Ast.TAny, pos) ] ),
pos ))
(Bindlib.bind_mvar [| acc_var; param_var |] f_body)
@ -631,16 +724,36 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
| Builtin GetDay -> Bindlib.box (Scopelang.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetDay), pos)
| Builtin GetMonth -> Bindlib.box (Scopelang.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetMonth), pos)
| Builtin GetYear -> Bindlib.box (Scopelang.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetYear), pos)
| _ ->
Name_resolution.raise_unsupported_feature "desugaring not implemented for this expression" pos
and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t)
(ctxt : Name_resolution.context) (cases : Ast.match_case Pos.marked list) :
Scopelang.Ast.expr Pos.marked Bindlib.box Scopelang.Ast.EnumConstructorMap.t
* Scopelang.Ast.EnumName.t =
let expr, e_name =
List.fold_left
(fun (cases_d, e_uid) (case, _pos_case) ->
let create_var = function
| None -> (ctxt, (Scopelang.Ast.Var.make ("_", Pos.no_pos), Pos.no_pos))
| Some param ->
let ctxt, param_var = Name_resolution.add_def_local_var ctxt param in
(ctxt, (param_var, Pos.get_position param))
in
let bind_case_body (c_uid : Dcalc.Ast.EnumConstructor.t) (e_uid : Dcalc.Ast.EnumName.t)
(ctxt : Name_resolution.context) (param_pos : Pos.t) (case_body : ('a * Pos.t) Bindlib.box)
(e_binder : (Scopelang.Ast.expr, Scopelang.Ast.expr * Pos.t) Bindlib.mbinder Bindlib.box) :
'c Bindlib.box =
Bindlib.box_apply2
(fun e_binder case_body ->
Pos.same_pos_as
(Scopelang.Ast.EAbs
( (e_binder, param_pos),
[
Scopelang.Ast.EnumConstructorMap.find c_uid
(Scopelang.Ast.EnumMap.find e_uid ctxt.Name_resolution.enums);
] ))
case_body)
e_binder case_body
in
let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) =
match case with
| Ast.MatchCase case ->
let constructor, binding = Pos.unmark case.Ast.match_case_pattern in
let e_uid', c_uid =
disambiguate_constructor ctxt constructor (Pos.get_position case.Ast.match_case_pattern)
@ -658,7 +771,7 @@ and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t)
Scopelang.Ast.EnumName.format_t e_uid Scopelang.Ast.EnumName.format_t e_uid')
(Pos.get_position case.Ast.match_case_pattern)
in
( match Scopelang.Ast.EnumConstructorMap.find_opt c_uid cases_d with
(match Scopelang.Ast.EnumConstructorMap.find_opt c_uid cases_d with
| None -> ()
| Some e_case ->
Errors.raise_multispanned_error
@ -667,33 +780,81 @@ and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t)
[
(None, Pos.get_position case.match_case_expr);
(None, Pos.get_position (Bindlib.unbox e_case));
] );
let ctxt, (param_var, param_pos) =
match binding with
| None -> (ctxt, (Scopelang.Ast.Var.make ("_", Pos.no_pos), Pos.no_pos))
| Some param ->
let ctxt, param_var = Name_resolution.add_def_local_var ctxt param in
(ctxt, (param_var, Pos.get_position param))
in
]);
let ctxt, (param_var, param_pos) = create_var binding in
let case_body = translate_expr scope ctxt case.Ast.match_case_expr in
let e_binder = Bindlib.bind_mvar (Array.of_list [ param_var ]) case_body in
let case_expr =
Bindlib.box_apply2
(fun e_binder case_body ->
Pos.same_pos_as
(Scopelang.Ast.EAbs
( param_pos,
e_binder,
[
Scopelang.Ast.EnumConstructorMap.find c_uid
(Scopelang.Ast.EnumMap.find e_uid ctxt.Name_resolution.enums);
] ))
case_body)
e_binder case_body
let case_expr = bind_case_body c_uid e_uid ctxt param_pos case_body e_binder in
(Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d, Some e_uid, curr_index + 1)
| Ast.WildCard match_case_expr -> (
let nb_cases = List.length cases in
let raise_wildcard_not_last_case_err () =
Errors.raise_multispanned_error "Wildcard must be the last match case"
[
(Some "Not ending wildcard:", case_pos);
(Some "Next reachable case:", curr_index + 1 |> List.nth cases |> Pos.get_position);
]
in
(Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d, Some e_uid))
(Scopelang.Ast.EnumConstructorMap.empty, None)
cases
match e_uid with
| None ->
if 1 = nb_cases then
Errors.raise_spanned_error
"Couldn't infer the enumeration name from lonely wildcard (wildcard cannot be used \
as single match case)"
case_pos
else raise_wildcard_not_last_case_err ()
| Some e_uid -> (
if curr_index < nb_cases - 1 then raise_wildcard_not_last_case_err ();
let missing_constructors =
Scopelang.Ast.EnumMap.find e_uid ctxt.Name_resolution.enums
|> Scopelang.Ast.EnumConstructorMap.filter_map (fun c_uid _ ->
match Scopelang.Ast.EnumConstructorMap.find_opt c_uid cases_d with
| Some _ -> None
| None -> Some c_uid)
in
if Scopelang.Ast.EnumConstructorMap.is_empty missing_constructors then
Errors.print_spanned_warning
(Format.asprintf
"Unreachable match case, all constructors of the enumeration %a are already \
specified"
Scopelang.Ast.EnumName.format_t e_uid)
case_pos;
(* The current used strategy is to replace the wildcard branch:
match foo with
| Case1 x -> x
| _ -> 1
with:
let wildcard_payload = 1 in
match foo with
| Case1 x -> x
| Case2 -> wildcard_payload
...
| CaseN -> wildcard_payload *)
(* Creates the wildcard payload *)
let ctxt, (payload_var, var_pos) = create_var None in
let case_body = translate_expr scope ctxt match_case_expr in
let e_binder = Bindlib.bind_mvar (Array.of_list [ payload_var ]) case_body in
(* For each missing cases, binds the wildcard payload. *)
Scopelang.Ast.EnumConstructorMap.fold
(fun c_uid _ (cases_d, e_uid_opt, curr_index) ->
let case_expr = bind_case_body c_uid e_uid ctxt var_pos case_body e_binder in
( Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d,
e_uid_opt,
curr_index + 1 ))
missing_constructors (cases_d, Some e_uid, curr_index)))[@ocamlformat "disable"]
in
let expr, e_name, _ =
List.fold_left bind_match_cases (Scopelang.Ast.EnumConstructorMap.empty, None, 0) cases
in
(expr, Option.get e_name)
@ -753,22 +914,9 @@ let process_def (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
(prgm : Desugared.Ast.program) (def : Ast.definition) : Desugared.Ast.program =
let scope : Desugared.Ast.scope = Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes in
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
let default_pos = Pos.get_position def.definition_expr in
let def_key =
match Pos.unmark def.definition_name with
| [ x ] ->
let x_uid = Name_resolution.get_var_uid scope_uid ctxt x in
Desugared.Ast.ScopeDef.Var x_uid
| [ y; x ] ->
let subscope_uid : Scopelang.Ast.SubScopeName.t =
Name_resolution.get_subscope_uid scope_uid ctxt y
in
let subscope_real_uid : Scopelang.Ast.ScopeName.t =
Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
in
let x_uid = Name_resolution.get_var_uid subscope_real_uid ctxt x in
Desugared.Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid)
| _ -> Errors.raise_spanned_error "Structs are not handled yet" default_pos
Name_resolution.get_def_key (Pos.unmark def.definition_name) scope_uid ctxt
(Pos.get_position def.definition_expr)
in
(* We add to the name resolution context the name of the parameter variable *)
let param_uid, new_ctxt =
@ -797,26 +945,44 @@ let process_def (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
| Some x -> x
| None ->
Desugared.Ast.RuleName.fresh
( match def.definition_label with
(match def.definition_label with
| None ->
Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
def.definition_name
| Some label -> label )
| Some label -> label)
in
let is_exception (def : Ast.definition) =
match def.Ast.definition_exception_to with NotAnException -> false | _ -> true
in
(* If we had previously defined a rulename for this default definition during the elaboration of
default exceptions, this trumps the newly generated name. *)
let rule_name =
if is_exception def then rule_name
else
match Desugared.Ast.ScopeDefMap.find_opt def_key scope_ctxt.default_rulemap with
| None | Some (Name_resolution.Ambiguous _) -> rule_name
| Some (Name_resolution.Unique x) -> x
in
let parent_rule =
match def.Ast.definition_exception_to with
| None -> None
| Some label ->
| NotAnException -> None
| UnlabeledException ->
Some
( try
Pos.same_pos_as
(Desugared.Ast.IdentMap.find (Pos.unmark label) scope_ctxt.label_idmap)
label
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Unknown label: \"%s\"" (Pos.unmark label))
(Pos.get_position label) )
(match Desugared.Ast.ScopeDefMap.find_opt def_key scope_ctxt.default_rulemap with
(* This should have been caught previously by check_unlabeled_exception *)
| None | Some (Name_resolution.Ambiguous _) -> assert false
| Some (Name_resolution.Unique name) -> Pos.same_pos_as name def.Ast.definition_name)
| ExceptionToLabel label ->
Some
(try
Pos.same_pos_as
(Desugared.Ast.IdentMap.find (Pos.unmark label) scope_ctxt.label_idmap)
label
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Unknown label: \"%s\"" (Pos.unmark label))
(Pos.get_position label))
in
let x_def =
Desugared.Ast.RuleMap.add rule_name
@ -835,21 +1001,23 @@ let process_def (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
program_scopes = Scopelang.Ast.ScopeMap.add scope_uid scope_updated prgm.program_scopes;
}
(** Translates a {!type: Surface.Ast.rule} into the corresponding {!type: Surface.Ast.definition} *)
let rule_to_def (rule : Ast.rule) : Ast.definition =
let consequence_expr = Ast.Literal (Ast.LBool (Pos.unmark rule.rule_consequence)) in
{
Ast.definition_label = rule.rule_label;
Ast.definition_exception_to = rule.rule_exception_to;
Ast.definition_name = rule.rule_name;
Ast.definition_parameter = rule.rule_parameter;
Ast.definition_condition = rule.rule_condition;
Ast.definition_expr = (consequence_expr, Pos.get_position rule.rule_consequence);
}
(** Translates a {!type: Surface.Ast.rule} from the surface language *)
let process_rule (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
(scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program) (rule : Ast.rule) : Desugared.Ast.program =
let consequence_expr = Ast.Literal (Ast.Bool (Pos.unmark rule.rule_consequence)) in
let def =
{
Ast.definition_label = rule.rule_label;
Ast.definition_exception_to = rule.rule_exception_to;
Ast.definition_name = rule.rule_name;
Ast.definition_parameter = rule.rule_parameter;
Ast.definition_condition = rule.rule_condition;
Ast.definition_expr = (consequence_expr, Pos.get_position rule.rule_consequence);
}
in
let def = rule_to_def rule in
process_def precond scope ctxt prgm def
(** Translates assertions *)
@ -859,12 +1027,12 @@ let process_assert (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
let scope : Desugared.Ast.scope = Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes in
let ass =
translate_expr scope_uid ctxt
( match ass.Ast.assertion_condition with
(match ass.Ast.assertion_condition with
| None -> ass.Ast.assertion_content
| Some cond ->
( Ast.IfThenElse
(cond, ass.Ast.assertion_content, Pos.same_pos_as (Ast.Literal (Ast.Bool true)) cond),
Pos.get_position cond ) )
(cond, ass.Ast.assertion_content, Pos.same_pos_as (Ast.Literal (Ast.LBool true)) cond),
Pos.get_position cond ))
in
let ass =
match precond with
@ -893,6 +1061,51 @@ let process_scope_use_item (precond : Ast.expression Pos.marked option)
(** {1 Translating top-level items} *)
(* If this is an unlabeled exception, ensures that it has a unique default definition *)
let check_unlabeled_exception (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
(item : Ast.scope_use_item Pos.marked) : unit =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
match Pos.unmark item with
| Ast.Rule rule -> (
match rule.rule_exception_to with
| Ast.NotAnException | Ast.ExceptionToLabel _ -> ()
(* If this is an unlabeled exception, we check that it has a unique default definition *)
| Ast.UnlabeledException -> (
let def_key =
Name_resolution.get_def_key (Pos.unmark rule.rule_name) scope ctxt
(Pos.get_position rule.rule_consequence)
in
match Desugared.Ast.ScopeDefMap.find_opt def_key scope_ctxt.default_rulemap with
| None ->
Errors.raise_spanned_error "This exception does not have a corresponding definition"
(Pos.get_position item)
| Some (Ambiguous pos) ->
Errors.raise_multispanned_error
"This exception can refer to several definitions. Try using labels to disambiguate"
([ (Some "Ambiguous exception", Pos.get_position item) ]
@ List.map (fun p -> (Some "Candidate definition", p)) pos)
| Some (Unique _) -> ()))
| Ast.Definition def -> (
match def.definition_exception_to with
| Ast.NotAnException | Ast.ExceptionToLabel _ -> ()
(* If this is an unlabeled exception, we check that it has a unique default definition *)
| Ast.UnlabeledException -> (
let def_key =
Name_resolution.get_def_key (Pos.unmark def.definition_name) scope ctxt
(Pos.get_position def.definition_expr)
in
match Desugared.Ast.ScopeDefMap.find_opt def_key scope_ctxt.default_rulemap with
| None ->
Errors.raise_spanned_error "This exception does not have a corresponding definition"
(Pos.get_position item)
| Some (Ambiguous pos) ->
Errors.raise_multispanned_error
"This exception can refer to several definitions. Try using labels to disambiguate"
([ (Some "Ambiguous exception", Pos.get_position item) ]
@ List.map (fun p -> (Some "Candidate definition", p)) pos)
| Some (Unique _) -> ()))
| _ -> ()
(** Translates a surface scope use, which is a bunch of definitions *)
let process_scope_use (ctxt : Name_resolution.context) (prgm : Desugared.Ast.program)
(use : Ast.scope_use) : Desugared.Ast.program =
@ -906,6 +1119,7 @@ let process_scope_use (ctxt : Name_resolution.context) (prgm : Desugared.Ast.pro
(* should not happen *)
in
let precond = use.scope_use_condition in
List.iter (check_unlabeled_exception scope_uid ctxt) use.scope_use_items;
List.fold_left (process_scope_use_item precond scope_uid ctxt) prgm use.scope_use_items
(** Main function of this module *)
@ -942,32 +1156,18 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desu
ctxt.Name_resolution.scopes;
}
in
let processer_article_item (prgm : Desugared.Ast.program) (item : Ast.law_article_item) :
let rec processer_structure (prgm : Desugared.Ast.program) (item : Ast.law_structure) :
Desugared.Ast.program =
match item with
| CodeBlock (block, _) ->
| LawHeading (_, children) ->
List.fold_left (fun prgm child -> processer_structure prgm child) prgm children
| CodeBlock (block, _, _) ->
List.fold_left
(fun prgm item ->
match Pos.unmark item with
| Ast.ScopeUse use -> process_scope_use ctxt prgm use
| _ -> prgm)
prgm block
| _ -> prgm
| LawInclude _ | LawText _ -> prgm
in
let rec processer_structure (prgm : Desugared.Ast.program) (item : Ast.law_structure) :
Desugared.Ast.program =
match item with
| LawHeading (_, children) ->
List.fold_left (fun prgm child -> processer_structure prgm child) prgm children
| LawArticle (_, children) ->
List.fold_left (fun prgm child -> processer_article_item prgm child) prgm children
| MetadataBlock (b, c) -> processer_article_item prgm (CodeBlock (b, c))
| IntermediateText _ | LawInclude _ -> prgm
in
let processer_item (prgm : Desugared.Ast.program) (item : Ast.program_item) :
Desugared.Ast.program =
match item with LawStructure s -> processer_structure prgm s
in
List.fold_left processer_item empty_prgm prgm.program_items
List.fold_left processer_structure empty_prgm prgm.program_items

21
compiler/surface/desugaring.mli Normal file
View File

@ -0,0 +1,21 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing
<nicolas.chataing@ens.fr> Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Translation from {!module: Surface.Ast} to {!module: Desugaring.Ast}.
- Removes syntactic sugars
- Separate code from legislation *)
val desugar_program : Name_resolution.context -> Ast.program -> Desugared.Ast.program
(** Main function of this module *)

90
compiler/surface/dune Normal file
View File

@ -0,0 +1,90 @@
(library
(name surface)
(public_name catala.surface)
(libraries
utils
menhirLib
sedlex
re
desugared
scopelang
zarith
zarith_stubs_js
calendar)
(preprocess
(pps sedlex.ppx visitors.ppx)))
(rule
(with-stdout-to
lexer_en.ml
(run %{bin:cppo} %{dep:lexer_en.cppo.ml} %{dep:lexer.cppo.ml})))
(rule
(with-stdout-to
lexer_fr.ml
(run %{bin:cppo} %{dep:lexer_fr.cppo.ml} %{dep:lexer.cppo.ml})))
(rule
(with-stdout-to
lexer_pl.ml
(run %{bin:cppo} %{dep:lexer_pl.cppo.ml} %{dep:lexer.cppo.ml})))
(menhir
(modules tokens)
(flags --only-tokens))
(menhir
(modules tokens parser)
(merge_into parser)
(flags --external-tokens Tokens --table --explain))
(documentation
(package catala)
(mld_files surface))
;; No built-in support for Menhir's parser messages yet
(rule
(with-stdout-to
parser.messages.new
(run
menhir
%{dep:tokens.mly}
%{dep:parser.mly}
--base
parser
--list-errors)))
(rule
(with-stdout-to
parser_errors.ml
(run
menhir
%{dep:tokens.mly}
%{dep:parser.mly}
--base
parser
--compile-errors
%{dep:parser.messages})))
(rule
(with-stdout-to
parser.messages.updated
(run
menhir
%{dep:tokens.mly}
%{dep:parser.mly}
--base
parser
--update-errors
%{dep:parser.messages})))
(rule
(alias update-parser-messages)
(action
(diff parser.messages parser.messages.updated)))
(rule
(alias create-parser-messages)
(action
(diff parser.messages parser.messages.new)))

0
src/catala/catala_surface/fill_error_tokens.py → compiler/surface/fill_error_tokens.py
View File

33
compiler/surface/fill_positions.ml Normal file
View File

@ -0,0 +1,33 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Utils
let fill_pos_with_legislative_info (p : Ast.program) : Ast.program =
let visitor =
object
inherit [_] Ast.program_map as super
method! visit_marked f env x =
(f env (Pos.unmark x), Pos.overwrite_law_info (Pos.get_position x) env)
method! visit_LawHeading (env : string list) (heading : Ast.law_heading)
(children : Ast.law_structure list) =
let env = Pos.unmark heading.law_heading_name :: env in
Ast.LawHeading
( super#visit_law_heading env heading,
List.map (fun child -> super#visit_law_structure env child) children )
end
in
visitor#visit_program [] p

18
compiler/surface/fill_positions.mli Normal file
View File

@ -0,0 +1,18 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Fills the position tags in the AST with info about the legislative article this position belongs
to. *)
val fill_pos_with_legislative_info : Ast.program -> Ast.program

787
compiler/surface/lexer.cppo.ml Normal file
View File

@ -0,0 +1,787 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Tokens
open Sedlexing
open Utils
module L = Lexer_common
module R = Re.Pcre
(* The localised strings and regexps for the tokens and specific parsing rules
are defined as CPPO macros in the `lexer_XX.cppo.ml` files.
- `MS_*` macros define token strings
- `MR_*` are sedlex regexps matching the token (inferred from the strings if absent,
but should be present for any token containing spacing, and for any non-latin1
character)
- `MX_*` are full matching rules of the form `sedlex regexp -> ocaml expression`
*)
(* Avoid the need for defining the regexps when they are simple strings *)
#ifndef MR_SCOPE
#define MR_SCOPE MS_SCOPE
#endif
#ifndef MR_CONSEQUENCE
#define MR_CONSEQUENCE MS_CONSEQUENCE
#endif
#ifndef MR_DATA
#define MR_DATA MS_DATA
#endif
#ifndef MR_DEPENDS
#define MR_DEPENDS MS_DEPENDS
#endif
#ifndef MR_DECLARATION
#define MR_DECLARATION MS_DECLARATION
#endif
#ifndef MR_CONTEXT
#define MR_CONTEXT MS_CONTEXT
#endif
#ifndef MR_DECREASING
#define MR_DECREASING MS_DECREASING
#endif
#ifndef MR_INCREASING
#define MR_INCREASING MS_INCREASING
#endif
#ifndef MR_OF
#define MR_OF MS_OF
#endif
#ifndef MR_COLLECTION
#define MR_COLLECTION MS_COLLECTION
#endif
#ifndef MR_ENUM
#define MR_ENUM MS_ENUM
#endif
#ifndef MR_INTEGER
#define MR_INTEGER MS_INTEGER
#endif
#ifndef MR_MONEY
#define MR_MONEY MS_MONEY
#endif
#ifndef MR_TEXT
#define MR_TEXT MS_TEXT
#endif
#ifndef MR_DECIMAL
#define MR_DECIMAL MS_DECIMAL
#endif
#ifndef MR_DATE
#define MR_DATE MS_DATE
#endif
#ifndef MR_DURATION
#define MR_DURATION MS_DURATION
#endif
#ifndef MR_BOOLEAN
#define MR_BOOLEAN MS_BOOLEAN
#endif
#ifndef MR_SUM
#define MR_SUM MS_SUM
#endif
#ifndef MR_FILLED
#define MR_FILLED MS_FILLED
#endif
#ifndef MR_DEFINITION
#define MR_DEFINITION MS_DEFINITION
#endif
#ifndef MR_LABEL
#define MR_LABEL MS_LABEL
#endif
#ifndef MR_EXCEPTION
#define MR_EXCEPTION MS_EXCEPTION
#endif
#ifndef MR_DEFINED_AS
#define MR_DEFINED_AS MS_DEFINED_AS
#endif
#ifndef MR_MATCH
#define MR_MATCH MS_MATCH
#endif
#ifndef MR_WILDCARD
#define MR_WILDCARD MS_WILDCARD
#endif
#ifndef MR_WITH
#define MR_WITH MS_WITH
#endif
#ifndef MR_UNDER_CONDITION
#define MR_UNDER_CONDITION MS_UNDER_CONDITION
#endif
#ifndef MR_IF
#define MR_IF MS_IF
#endif
#ifndef MR_THEN
#define MR_THEN MS_THEN
#endif
#ifndef MR_ELSE
#define MR_ELSE MS_ELSE
#endif
#ifndef MR_CONDITION
#define MR_CONDITION MS_CONDITION
#endif
#ifndef MR_CONTENT
#define MR_CONTENT MS_CONTENT
#endif
#ifndef MR_STRUCT
#define MR_STRUCT MS_STRUCT
#endif
#ifndef MR_ASSERTION
#define MR_ASSERTION MS_ASSERTION
#endif
#ifndef MR_VARIES
#define MR_VARIES MS_VARIES
#endif
#ifndef MR_WITH_V
#define MR_WITH_V MS_WITH_V
#endif
#ifndef MR_FOR
#define MR_FOR MS_FOR
#endif
#ifndef MR_ALL
#define MR_ALL MS_ALL
#endif
#ifndef MR_WE_HAVE
#define MR_WE_HAVE MS_WE_HAVE
#endif
#ifndef MR_FIXED
#define MR_FIXED MS_FIXED
#endif
#ifndef MR_BY
#define MR_BY MS_BY
#endif
#ifndef MR_RULE
#define MR_RULE MS_RULE
#endif
#ifndef MR_EXISTS
#define MR_EXISTS MS_EXISTS
#endif
#ifndef MR_IN
#define MR_IN MS_IN
#endif
#ifndef MR_SUCH
#define MR_SUCH MS_SUCH
#endif
#ifndef MR_THAT
#define MR_THAT MS_THAT
#endif
#ifndef MR_AND
#define MR_AND MS_AND
#endif
#ifndef MR_OR
#define MR_OR MS_OR
#endif
#ifndef MR_XOR
#define MR_XOR MS_XOR
#endif
#ifndef MR_NOT
#define MR_NOT MS_NOT
#endif
#ifndef MR_MAXIMUM
#define MR_MAXIMUM MS_MAXIMUM
#endif
#ifndef MR_MINIMUM
#define MR_MINIMUM MS_MINIMUM
#endif
#ifndef MR_FILTER
#define MR_FILTER MS_FILTER
#endif
#ifndef MR_MAP
#define MR_MAP MS_MAP
#endif
#ifndef MR_INIT
#define MR_INIT MS_INIT
#endif
#ifndef MR_CARDINAL
#define MR_CARDINAL MS_CARDINAL
#endif
#ifndef MR_YEAR
#define MR_YEAR MS_YEAR
#endif
#ifndef MR_MONTH
#define MR_MONTH MS_MONTH
#endif
#ifndef MR_DAY
#define MR_DAY MS_DAY
#endif
#ifndef MR_TRUE
#define MR_TRUE MS_TRUE
#endif
#ifndef MR_FALSE
#define MR_FALSE MS_FALSE
#endif
#ifndef MR_IntToDec
#define MR_IntToDec MS_IntToDec
#endif
#ifndef MR_GetDay
#define MR_GetDay MS_GetDay
#endif
#ifndef MR_GetMonth
#define MR_GetMonth MS_GetMonth
#endif
#ifndef MR_GetYear
#define MR_GetYear MS_GetYear
#endif
let token_list : (string * token) list =
[
(MS_SCOPE, SCOPE);
(MS_CONSEQUENCE, CONSEQUENCE);
(MS_DATA, DATA);
(MS_DEPENDS, DEPENDS);
(MS_DECLARATION, DECLARATION);
(MS_CONTEXT, CONTEXT);
(MS_DECREASING, DECREASING);
(MS_INCREASING, INCREASING);
(MS_OF, OF);
(MS_COLLECTION, COLLECTION);
(MS_ENUM, ENUM);
(MS_INTEGER, INTEGER);
(MS_MONEY, MONEY);
(MS_TEXT, TEXT);
(MS_DECIMAL, DECIMAL);
(MS_DATE, DATE);
(MS_DURATION, DURATION);
(MS_BOOLEAN, BOOLEAN);
(MS_SUM, SUM);
(MS_FILLED, FILLED);
(MS_DEFINITION, DEFINITION);
(MS_LABEL, LABEL);
(MS_EXCEPTION, EXCEPTION);
(MS_DEFINED_AS, DEFINED_AS);
(MS_MATCH, MATCH);
(MS_WILDCARD, WILDCARD);
(MS_WITH, WITH);
(MS_UNDER_CONDITION, UNDER_CONDITION);
(MS_IF, IF);
(MS_THEN, THEN);
(MS_ELSE, ELSE);
(MS_CONDITION, CONDITION);
(MS_CONTENT, CONTENT);
(MS_STRUCT, STRUCT);
(MS_ASSERTION, ASSERTION);
(MS_VARIES, VARIES);
(MS_WITH_V, WITH_V);
(MS_FOR, FOR);
(MS_ALL, ALL);
(MS_WE_HAVE, WE_HAVE);
(MS_FIXED, FIXED);
(MS_BY, BY);
(MS_RULE, RULE);
(MS_EXISTS, EXISTS);
(MS_IN, IN);
(MS_SUCH, SUCH);
(MS_THAT, THAT);
(MS_AND, AND);
(MS_OR, OR);
(MS_XOR, XOR);
(MS_NOT, NOT);
(MS_MAXIMUM, MAXIMUM);
(MS_MINIMUM, MINIMUM);
(MS_FILTER, FILTER);
(MS_MAP, MAP);
(MS_INIT, INIT);
(MS_CARDINAL, CARDINAL);
(MS_YEAR, YEAR);
(MS_MONTH, MONTH);
(MS_DAY, DAY);
(MS_TRUE, TRUE);
(MS_FALSE, FALSE);
]
@ L.token_list_language_agnostic
(** Localised builtin functions *)
let lex_builtin (s : string) : Ast.builtin_expression option =
let lexbuf = Utf8.from_string s in
match%sedlex lexbuf with
| MR_IntToDec, eof -> Some IntToDec
| MR_GetDay, eof -> Some GetDay
| MR_GetMonth, eof -> Some GetMonth
| MR_GetYear, eof -> Some GetYear
| _ -> None
(** Regexp matching any digit character.
@note can not be used outside the current module (@see <
https://github.com/ocaml-community/sedlex#lexer-specifications >). *)
let digit = [%sedlex.regexp? '0' .. '9']
(** Regexp matching at least one space. *)
let space_plus = [%sedlex.regexp? Plus white_space]
(** Regexp matching white space but not newlines *)
let hspace = [%sedlex.regexp? Sub (white_space, Chars "\n\r")]
(** Main lexing function used in code blocks *)
let rec lex_code (lexbuf : lexbuf) : token =
let prev_lexeme = Utf8.lexeme lexbuf in
let prev_pos = lexing_positions lexbuf in
match%sedlex lexbuf with
| white_space ->
(* Whitespaces *)
L.update_acc lexbuf;
lex_code lexbuf
| '#', Star (Compl '\n'), '\n' ->
(* Comments *)
L.update_acc lexbuf;
lex_code lexbuf
| "```" ->
(* End of code section *)
L.context := Law;
END_CODE (Buffer.contents L.code_buffer)
| MR_SCOPE ->
L.update_acc lexbuf;
SCOPE
| MR_DATA ->
L.update_acc lexbuf;
DATA
| MR_DEPENDS ->
L.update_acc lexbuf;
DEPENDS
| MR_DECLARATION ->
L.update_acc lexbuf;
DECLARATION
| MR_CONTEXT ->
L.update_acc lexbuf;
CONTEXT
| MR_DECREASING ->
L.update_acc lexbuf;
DECREASING
| MR_INCREASING ->
L.update_acc lexbuf;
INCREASING
| MR_OF ->
L.update_acc lexbuf;
OF
| MR_COLLECTION ->
L.update_acc lexbuf;
COLLECTION
| MR_ENUM ->
L.update_acc lexbuf;
ENUM
| MR_INTEGER ->
L.update_acc lexbuf;
INTEGER
| MR_MONEY ->
L.update_acc lexbuf;
MONEY
| MR_TEXT ->
L.update_acc lexbuf;
TEXT
| MR_DECIMAL ->
L.update_acc lexbuf;
DECIMAL
| MR_DATE ->
L.update_acc lexbuf;
DATE
| MR_DURATION ->
L.update_acc lexbuf;
DURATION
| MR_BOOLEAN ->
L.update_acc lexbuf;
BOOLEAN
| MR_SUM ->
L.update_acc lexbuf;
SUM
| MR_FILLED ->
L.update_acc lexbuf;
FILLED
| MR_DEFINITION ->
L.update_acc lexbuf;
DEFINITION
| MR_LABEL ->
L.update_acc lexbuf;
LABEL
| MR_EXCEPTION ->
L.update_acc lexbuf;
EXCEPTION
| MR_DEFINED_AS ->
L.update_acc lexbuf;
DEFINED_AS
| MR_MATCH ->
L.update_acc lexbuf;
MATCH
| MR_WITH ->
L.update_acc lexbuf;
WITH
| MR_WILDCARD ->
L.update_acc lexbuf;
WILDCARD
| MR_UNDER_CONDITION ->
L.update_acc lexbuf;
UNDER_CONDITION
| MR_IF ->
L.update_acc lexbuf;
IF
| MR_CONSEQUENCE ->
L.update_acc lexbuf;
CONSEQUENCE
| MR_THEN ->
L.update_acc lexbuf;
THEN
| MR_ELSE ->
L.update_acc lexbuf;
ELSE
| MR_CONDITION ->
L.update_acc lexbuf;
CONDITION
| MR_CONTENT ->
L.update_acc lexbuf;
CONTENT
| MR_STRUCT ->
L.update_acc lexbuf;
STRUCT
| MR_ASSERTION ->
L.update_acc lexbuf;
ASSERTION
| MR_VARIES ->
L.update_acc lexbuf;
VARIES
| MR_WITH_V ->
L.update_acc lexbuf;
WITH_V
| MR_FOR ->
L.update_acc lexbuf;
FOR
| MR_ALL ->
L.update_acc lexbuf;
ALL
| MR_WE_HAVE ->
L.update_acc lexbuf;
WE_HAVE
| MR_FIXED ->
L.update_acc lexbuf;
FIXED
| MR_BY ->
L.update_acc lexbuf;
BY
| MR_RULE ->
L.update_acc lexbuf;
L.update_acc lexbuf;
RULE
| MR_EXISTS ->
L.update_acc lexbuf;
EXISTS
| MR_IN ->
L.update_acc lexbuf;
IN
| MR_SUCH ->
L.update_acc lexbuf;
SUCH
| MR_THAT ->
L.update_acc lexbuf;
THAT
| MR_AND ->
L.update_acc lexbuf;
AND
| MR_OR ->
L.update_acc lexbuf;
OR
| MR_XOR ->
L.update_acc lexbuf;
XOR
| MR_NOT ->
L.update_acc lexbuf;
NOT
| MR_MAXIMUM ->
L.update_acc lexbuf;
MAXIMUM
| MR_MINIMUM ->
L.update_acc lexbuf;
MINIMUM
| MR_FILTER ->
L.update_acc lexbuf;
FILTER
| MR_MAP ->
L.update_acc lexbuf;
MAP
| MR_INIT ->
L.update_acc lexbuf;
INIT
| MR_CARDINAL ->
L.update_acc lexbuf;
CARDINAL
| MR_TRUE ->
L.update_acc lexbuf;
TRUE
| MR_FALSE ->
L.update_acc lexbuf;
FALSE
| MR_YEAR ->
L.update_acc lexbuf;
YEAR
| MR_MONTH ->
L.update_acc lexbuf;
MONTH
| MR_DAY ->
L.update_acc lexbuf;
DAY
| MR_MONEY_PREFIX, digit, Opt (Star (digit | MR_MONEY_DELIM), digit), Opt (MC_DECIMAL_SEPARATOR, Rep (digit, 0 .. 2)), MR_MONEY_SUFFIX ->
let s = Utf8.lexeme lexbuf in
let units = Buffer.create (String.length s) in
let cents = Buffer.create 2 in
let buf = ref units in
for i = 0 to String.length s - 1 do
match s.[i] with
| '0'..'9' as c -> Buffer.add_char !buf c
| MC_DECIMAL_SEPARATOR -> buf := cents
| _ -> ()
done;
L.update_acc lexbuf;
MONEY_AMOUNT (Runtime.integer_of_string (Buffer.contents units), Runtime.integer_of_string (Buffer.contents cents))
| Plus digit, MC_DECIMAL_SEPARATOR, Star digit ->
let rex =
Re.(compile @@ whole_string @@ seq [
group (rep1 digit);
char MC_DECIMAL_SEPARATOR;
group (rep digit)
]) in
let dec_parts = R.get_substring (R.exec ~rex (Utf8.lexeme lexbuf)) in
L.update_acc lexbuf;
DECIMAL_LITERAL
(Runtime.integer_of_string (dec_parts 1), Runtime.integer_of_string (dec_parts 2))
| "<=@" ->
L.update_acc lexbuf;
LESSER_EQUAL_DATE
| "<@" ->
L.update_acc lexbuf;
LESSER_DATE
| ">=@" ->
L.update_acc lexbuf;
GREATER_EQUAL_DATE
| ">@" ->
L.update_acc lexbuf;
GREATER_DATE
| "-@" ->
L.update_acc lexbuf;
MINUSDATE
| "+@" ->
L.update_acc lexbuf;
PLUSDATE
| "<=^" ->
L.update_acc lexbuf;
LESSER_EQUAL_DURATION
| "<^" ->
L.update_acc lexbuf;
LESSER_DURATION
| ">=^" ->
L.update_acc lexbuf;
GREATER_EQUAL_DURATION
| ">^" ->
L.update_acc lexbuf;
GREATER_DURATION
| "+^" ->
L.update_acc lexbuf;
PLUSDURATION
| "-^" ->
L.update_acc lexbuf;
MINUSDURATION
| "/^" ->
L.update_acc lexbuf;
DIVDURATION
| "<=", MR_MONEY_OP_SUFFIX ->
L.update_acc lexbuf;
LESSER_EQUAL_MONEY
| '<', MR_MONEY_OP_SUFFIX ->
L.update_acc lexbuf;
LESSER_MONEY
| ">=", MR_MONEY_OP_SUFFIX ->
L.update_acc lexbuf;
GREATER_EQUAL_MONEY
| '>', MR_MONEY_OP_SUFFIX ->
L.update_acc lexbuf;
GREATER_MONEY
| '+', MR_MONEY_OP_SUFFIX ->
L.update_acc lexbuf;
PLUSMONEY
| '-', MR_MONEY_OP_SUFFIX ->
L.update_acc lexbuf;
MINUSMONEY
| '*', MR_MONEY_OP_SUFFIX ->
L.update_acc lexbuf;
MULTMONEY
| '/', MR_MONEY_OP_SUFFIX ->
L.update_acc lexbuf;
DIVMONEY
| "<=." ->
L.update_acc lexbuf;
LESSER_EQUAL_DEC
| "<." ->
L.update_acc lexbuf;
LESSER_DEC
| ">=." ->
L.update_acc lexbuf;
GREATER_EQUAL_DEC
| ">." ->
L.update_acc lexbuf;
GREATER_DEC
| "+." ->
L.update_acc lexbuf;
PLUSDEC
| "-." ->
L.update_acc lexbuf;
MINUSDEC
| "*." ->
L.update_acc lexbuf;
MULTDEC
| "/." ->
L.update_acc lexbuf;
DIVDEC
| "<=" ->
L.update_acc lexbuf;
LESSER_EQUAL
| '<' ->
L.update_acc lexbuf;
LESSER
| ">=" ->
L.update_acc lexbuf;
GREATER_EQUAL
| '>' ->
L.update_acc lexbuf;
GREATER
| '+' ->
L.update_acc lexbuf;
PLUS
| '-' ->
L.update_acc lexbuf;
MINUS
| '*' ->
L.update_acc lexbuf;
MULT
| '/' ->
L.update_acc lexbuf;
DIV
| "!=" ->
L.update_acc lexbuf;
NOT_EQUAL
| '=' ->
L.update_acc lexbuf;
EQUAL
| '%' ->
L.update_acc lexbuf;
PERCENT
| '(' ->
L.update_acc lexbuf;
LPAREN
| ')' ->
L.update_acc lexbuf;
RPAREN
| '{' ->
L.update_acc lexbuf;
LBRACKET
| '}' ->
L.update_acc lexbuf;
RBRACKET
| '[' ->
L.update_acc lexbuf;
LSQUARE
| ']' ->
L.update_acc lexbuf;
RSQUARE
| '|' ->
L.update_acc lexbuf;
VERTICAL
| ':' ->
L.update_acc lexbuf;
COLON
| ';' ->
L.update_acc lexbuf;
SEMICOLON
| "--" ->
L.update_acc lexbuf;
ALT
| "++" ->
L.update_acc lexbuf;
PLUSPLUS
| '.' ->
L.update_acc lexbuf;
DOT
| uppercase, Star (uppercase | lowercase | digit | '_' | '\'') ->
(* Name of constructor *)
L.update_acc lexbuf;
CONSTRUCTOR (Utf8.lexeme lexbuf)
| lowercase, Star (lowercase | uppercase | digit | '_' | '\'') ->
(* Name of variable *)
L.update_acc lexbuf;
IDENT (Utf8.lexeme lexbuf)
| Plus digit ->
(* Integer literal*)
L.update_acc lexbuf;
INT_LITERAL (Runtime.integer_of_string (Utf8.lexeme lexbuf))
| _ -> L.raise_lexer_error (Pos.from_lpos prev_pos) prev_lexeme
let rec lex_directive_args (lexbuf : lexbuf) : token =
let prev_lexeme = Utf8.lexeme lexbuf in
let prev_pos = lexing_positions lexbuf in
match%sedlex lexbuf with
| '@', Star hspace, "p.", Star hspace, Plus digit ->
let s = Utf8.lexeme lexbuf in
let i = String.index s '.' in
AT_PAGE (int_of_string (String.trim (String.sub s i (String.length s - i))))
| Plus (Compl white_space) -> DIRECTIVE_ARG (Utf8.lexeme lexbuf)
| Plus hspace -> lex_directive_args lexbuf
| '\n' | eof ->
L.context := Law;
END_DIRECTIVE
| _ -> L.raise_lexer_error (Pos.from_lpos prev_pos) prev_lexeme
let rec lex_directive (lexbuf : lexbuf) : token =
let prev_lexeme = Utf8.lexeme lexbuf in
let prev_pos = lexing_positions lexbuf in
match%sedlex lexbuf with
| Plus hspace -> lex_directive lexbuf
| MR_BEGIN_METADATA -> BEGIN_METADATA
| MR_END_METADATA -> END_METADATA
| MR_LAW_INCLUDE -> LAW_INCLUDE
| ":" ->
L.context := Directive_args;
COLON
| '\n' | eof ->
L.context := Law;
END_DIRECTIVE
| _ -> L.raise_lexer_error (Pos.from_lpos prev_pos) prev_lexeme
(** Main lexing function used outside code blocks *)
let lex_law (lexbuf : lexbuf) : token =
let prev_lexeme = Utf8.lexeme lexbuf in
let ((_, start_pos) as prev_pos) = lexing_positions lexbuf in
let at_bol = Lexing.(start_pos.pos_bol = start_pos.pos_cnum) in
if at_bol then
match%sedlex lexbuf with
| eof -> EOF
| "```catala", Plus white_space ->
L.context := Code;
Buffer.clear L.code_buffer;
BEGIN_CODE
| '>' ->
L.context := Directive;
BEGIN_DIRECTIVE
| Plus '#', Star hspace, Plus (Compl '\n'), Star hspace, ('\n' | eof) ->
L.get_law_heading lexbuf
| _ -> (
(* Nested match for lower priority; `_` matches length 0 so we effectively retry the
sub-match at the same point *)
let lexbuf = lexbuf in
(* workaround sedlex bug, see https://github.com/ocaml-community/sedlex/issues/12 *)
match%sedlex lexbuf with
| Star (Compl '\n'), ('\n' | eof) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> L.raise_lexer_error (Pos.from_lpos prev_pos) prev_lexeme)
else
match%sedlex lexbuf with
| eof -> EOF
| Star (Compl '\n'), ('\n' | eof) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> L.raise_lexer_error (Pos.from_lpos prev_pos) prev_lexeme
(** Entry point of the lexer, distributes to {!val: lex_code} or {!val: lex_law} depending of {!val:
Surface.Lexer_common.is_code}. *)
let lexer (lexbuf : lexbuf) : token =
match !L.context with
| Law -> lex_law lexbuf
| Code -> lex_code lexbuf
| Directive -> lex_directive lexbuf
| Directive_args -> lex_directive_args lexbuf

101
compiler/surface/lexer_common.ml Normal file
View File

@ -0,0 +1,101 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Tokens
open Sedlexing
open Utils
module R = Re.Pcre
(* Calculates the precedence according a {!val: matched_regex} of the form : '[#]+'.
@note -2 because [LAW_HEADING] start with at least "#" and the number of '#' remaining
corresponds to the precedence. *)
let calc_precedence (matched_regex : string) : int = String.length matched_regex - 1
(* Gets the [LAW_HEADING] token from the current {!val: lexbuf} *)
let get_law_heading (lexbuf : lexbuf) : token =
let extract_article_title =
R.regexp "([#]+)\\s*([^\\|]+)(\\|([^\\|]+)|)(\\|\\s*([0-9]{4}\\-[0-9]{2}\\-[0-9]{2})|)"
in
let get_substring = R.get_substring (R.exec ~rex:extract_article_title (Utf8.lexeme lexbuf)) in
let title = String.trim (get_substring 2) in
let article_id = try Some (String.trim (get_substring 4)) with Not_found -> None in
let article_expiration_date = try Some (String.trim (get_substring 6)) with Not_found -> None in
let precedence = calc_precedence (String.trim (get_substring 1)) in
LAW_HEADING (title, article_id, article_expiration_date, precedence)
type lexing_context = Law | Code | Directive | Directive_args
(** Boolean reference, used by the lexer as the mutable state to distinguish whether it is lexing
code or law. *)
let context : lexing_context ref = ref Law
(** Mutable string reference that accumulates the string representation of the body of code being
lexed. This string representation is used in the literate programming backends to faithfully
capture the spacing pattern of the original program *)
let code_buffer : Buffer.t = Buffer.create 4000
(** Updates {!val:code_buffer} with the current lexeme *)
let update_acc (lexbuf : lexbuf) : unit = Buffer.add_string code_buffer (Utf8.lexeme lexbuf)
(** Error-generating helper *)
let raise_lexer_error (loc : Pos.t) (token : string) =
Errors.raise_spanned_error
(Printf.sprintf "Parsing error after token \"%s\": what comes after is unknown" token)
loc
(** Associative list matching each punctuation string part of the Catala syntax with its {!module:
Surface.Parser} token. Same for all the input languages (English, French, etc.) *)
let token_list_language_agnostic : (string * token) list =
[
(".", DOT);
("<=", LESSER_EQUAL);
(">=", GREATER_EQUAL);
(">", GREATER);
("!=", NOT_EQUAL);
("=", EQUAL);
("(", LPAREN);
(")", RPAREN);
("{", LBRACKET);
("}", RBRACKET);
("{", LSQUARE);
("}", RSQUARE);
("+", PLUS);
("-", MINUS);
("*", MULT);
("/", DIV);
("|", VERTICAL);
(":", COLON);
(";", SEMICOLON);
("--", ALT);
("++", PLUSPLUS);
]
module type LocalisedLexer = sig
val token_list : (string * Tokens.token) list
(** Same as {!val: token_list_language_agnostic}, but with tokens specialized to a given language. *)
val lex_builtin : string -> Ast.builtin_expression option
(** Simple lexer for builtins *)
val lex_code : Sedlexing.lexbuf -> Tokens.token
(** Main lexing function used in code blocks *)
val lex_law : Sedlexing.lexbuf -> Tokens.token
(** Main lexing function used outside code blocks *)
val lexer : Sedlexing.lexbuf -> Tokens.token
(** Entry point of the lexer, distributes to {!val: lex_code} or {!val: lex_law} depending of
{!val: Surface.Lexer_common.is_code}. *)
end

61
compiler/surface/lexer_common.mli Normal file
View File

@ -0,0 +1,61 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Auxiliary functions used by all lexers. *)
type lexing_context = Law | Code | Directive | Directive_args
val context : lexing_context ref
(** Reference, used by the lexer as the mutable state to distinguish whether it is lexing code or
law. *)
val code_buffer : Buffer.t
(** Buffer that accumulates the string representation of the body of code being lexed. This string
representation is used in the literate programming backends to faithfully capture the spacing
pattern of the original program *)
val update_acc : Sedlexing.lexbuf -> unit
(** Updates {!val:code_buffer} with the current lexeme *)
val raise_lexer_error : Utils.Pos.t -> string -> 'a
(** Error-generating helper *)
val token_list_language_agnostic : (string * Tokens.token) list
(** Associative list matching each punctuation string part of the Catala syntax with its {!module:
Surface.Parser} token. Same for all the input languages (English, French, etc.) *)
val calc_precedence : string -> int
(** Calculates the precedence according a matched regex of the form : '[#]+' *)
val get_law_heading : Sedlexing.lexbuf -> Tokens.token
(** Gets the [LAW_HEADING] token from the current [lexbuf] *)
module type LocalisedLexer = sig
val token_list : (string * Tokens.token) list
(** Same as {!val: token_list_language_agnostic}, but with tokens whose string varies with the
input language. *)
val lex_builtin : string -> Ast.builtin_expression option
(** Simple lexer for builtins *)
val lex_code : Sedlexing.lexbuf -> Tokens.token
(** Main lexing function used in a code block *)
val lex_law : Sedlexing.lexbuf -> Tokens.token
(** Main lexing function used outside code blocks *)
val lexer : Sedlexing.lexbuf -> Tokens.token
(** Entry point of the lexer, distributes to {!val: lex_code} or {!val: lex_law} depending of
{!val: is_code}. *)
end

112
compiler/surface/lexer_en.cppo.ml Normal file
View File

@ -0,0 +1,112 @@
(* -*- coding: iso-latin-1 -*- *)
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(* Defining the lexer macros for English *)
(* Tokens and their corresponding sedlex regexps *)
#define MS_SCOPE "scope"
#define MS_CONSEQUENCE "consequence"
#define MS_DATA "data"
#define MS_DEPENDS "depends on"
#define MR_DEPENDS "depends", space_plus, "on"
#define MS_DECLARATION "declaration"
#define MS_CONTEXT "context"
#define MS_DECREASING "decreasing"
#define MS_INCREASING "increasing"
#define MS_OF "of"
#define MS_COLLECTION "collection"
#define MS_ENUM "enumeration"
#define MS_INTEGER "integer"
#define MS_MONEY "money"
#define MS_TEXT "text"
#define MS_DECIMAL "decimal"
#define MS_DATE "date"
#define MS_DURATION "duration"
#define MS_BOOLEAN "boolean"
#define MS_SUM "sum"
#define MS_FILLED "fulfilled"
#define MS_DEFINITION "definition"
#define MS_LABEL "label"
#define MS_EXCEPTION "exception"
#define MS_DEFINED_AS "equals"
#define MS_MATCH "match"
#define MS_WILDCARD "anything"
#define MS_WITH "with pattern"
#define MR_WITH "with", space_plus, "pattern"
#define MS_UNDER_CONDITION "under condition"
#define MR_UNDER_CONDITION "under", space_plus, "condition"
#define MS_IF "if"
#define MS_THEN "then"
#define MS_ELSE "else"
#define MS_CONDITION "condition"
#define MS_CONTENT "content"
#define MS_STRUCT "structure"
#define MS_ASSERTION "assertion"
#define MS_VARIES "varies"
#define MS_WITH_V "with"
#define MS_FOR "for"
#define MS_ALL "all"
#define MS_WE_HAVE "we have"
#define MR_WE_HAVE "we", space_plus, "have"
#define MS_FIXED "fixed"
#define MS_BY "by"
#define MS_RULE "rule"
#define MS_EXISTS "exists"
#define MS_IN "in"
#define MS_SUCH "such"
#define MS_THAT "that"
#define MS_AND "and"
#define MS_OR "or"
#define MS_XOR "xor"
#define MS_NOT "not"
#define MS_MAXIMUM "maximum"
#define MS_MINIMUM "minimum"
#define MS_FILTER "filter"
#define MS_MAP "map"
#define MS_INIT "initial"
#define MS_CARDINAL "number"
#define MS_YEAR "year"
#define MS_MONTH "month"
#define MS_DAY "day"
#define MS_TRUE "true"
#define MS_FALSE "false"
(* Specific delimiters *)
#define MR_MONEY_OP_SUFFIX '$'
#define MC_DECIMAL_SEPARATOR '.'
#define MR_MONEY_PREFIX '$', Star hspace
#define MR_MONEY_DELIM ','
#define MR_MONEY_SUFFIX ""
(* Builtins *)
#define MS_IntToDec "integer_to_decimal"
#define MS_GetDay "get_day"
#define MS_GetMonth "get_month"
#define MS_GetYear "get_year"
(* Directives *)
#define MR_BEGIN_METADATA "Begin", Plus hspace, "metadata"
#define MR_END_METADATA "End", Plus hspace, "metadata"
#define MR_LAW_INCLUDE "Include"
#define MX_AT_PAGE \
'@', Star hspace, "p.", Star hspace, Plus digit -> \
let s = Utf8.lexeme lexbuf in \
let i = String.index s '.' in \
AT_PAGE (int_of_string (String.trim (String.sub s i (String.length s - i))))

15
compiler/surface/lexer_en.mli Normal file
View File

@ -0,0 +1,15 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
include Lexer_common.LocalisedLexer

119
compiler/surface/lexer_fr.cppo.ml Normal file
View File

@ -0,0 +1,119 @@
(* -*- coding: iso-latin-1 -*- *)
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(* WARNING: this file must be saved as Latin-1 and not utf8, sedlex requires it *)
(* Defining the lexer macros for French *)
(* Tokens and their corresponding sedlex regexps *)
#define MS_SCOPE "champ d'application"
#define MR_SCOPE "champ", space_plus, "d'application"
#define MS_CONSEQUENCE "conséquence"
#define MS_DATA "donnée"
#define MS_DEPENDS "dépend de"
#define MR_DEPENDS "dépend", space_plus, "de"
#define MS_DECLARATION "déclaration"
#define MS_CONTEXT "contexte"
#define MS_DECREASING "décroissant"
#define MS_INCREASING "croissant"
#define MS_OF "de"
#define MS_COLLECTION "collection"
#define MS_ENUM "énumération"
#define MS_INTEGER "entier"
#define MS_MONEY "argent"
#define MS_TEXT "texte"
#define MS_DECIMAL "décimal"
#define MS_DATE "date"
#define MS_DURATION "durée"
#define MS_BOOLEAN "booléen"
#define MS_SUM "somme"
#define MS_FILLED "rempli"
#define MS_DEFINITION "définition"
#define MS_LABEL "étiquette"
#define MS_EXCEPTION "exception"
#define MS_DEFINED_AS "égal à"
#define MR_DEFINED_AS "égal", space_plus, "à"
#define MS_MATCH "selon"
#define MS_WILDCARD "n'importe quel"
#define MR_WILDCARD "n'importe", space_plus, "quel"
#define MS_WITH "sous forme"
#define MR_WITH "sous", space_plus, "forme"
#define MS_UNDER_CONDITION "sous condition"
#define MR_UNDER_CONDITION "sous", space_plus, "condition"
#define MS_IF "si"
#define MS_THEN "alors"
#define MS_ELSE "sinon"
#define MS_CONDITION "condition"
#define MS_CONTENT "contenu"
#define MS_STRUCT "structure"
#define MS_ASSERTION "assertion"
#define MS_VARIES "varie"
#define MS_WITH_V "avec"
#define MS_FOR "pour"
#define MS_ALL "tout"
#define MS_WE_HAVE "on a"
#define MR_WE_HAVE "on", space_plus, "a"
#define MS_FIXED "fixé"
#define MS_BY "par"
#define MS_RULE "règle"
#define MS_EXISTS "existe"
#define MS_IN "dans"
#define MS_SUCH "tel"
#define MS_THAT "que"
#define MS_AND "et"
#define MS_OR "ou"
#define MS_XOR "ou bien"
#define MR_XOR "ou", space_plus, "bien"
#define MS_NOT "non"
#define MS_MAXIMUM "maximum"
#define MS_MINIMUM "minimum"
#define MS_FILTER "filtre"
#define MS_MAP "application"
#define MS_INIT "initial"
#define MS_CARDINAL "nombre"
#define MS_YEAR "an"
#define MS_MONTH "mois"
#define MS_DAY "jour"
#define MS_TRUE "vrai"
#define MS_FALSE "faux"
(* Specific delimiters *)
#define MR_MONEY_OP_SUFFIX 0x20AC (* The euro sign *)
#define MC_DECIMAL_SEPARATOR ','
#define MR_MONEY_PREFIX ""
#define MR_MONEY_DELIM ' '
#define MR_MONEY_SUFFIX Star hspace, 0x20AC
(* Builtins *)
#define MS_IntToDec "entier_vers_décimal"
#define MS_GetDay "accès_jour"
#define MS_GetMonth "accès_mois"
#define MS_GetYear "accès_année"
(* Directives *)
#define MR_BEGIN_METADATA "Début", Plus hspace, "métadonnées"
#define MR_END_METADATA "Fin", Plus hspace, "métadonnées"
#define MR_LAW_INCLUDE "Inclusion"
#define MX_AT_PAGE \
'@', Star hspace, "p.", Star hspace, Plus digit -> \
let s = Utf8.lexeme lexbuf in \
let i = String.index s '.' in \
AT_PAGE (int_of_string (String.trim (String.sub s i (String.length s - i))))

15
compiler/surface/lexer_fr.mli Normal file
View File

@ -0,0 +1,15 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
include Lexer_common.LocalisedLexer

117
compiler/surface/lexer_pl.cppo.ml Normal file
View File

@ -0,0 +1,117 @@
(* -*- coding: iso-latin-1 -*- *)
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(* Defining the lexer macros for Polish *)
(* Tokens and their corresponding sedlex regexps *)
#define MS_SCOPE "zakres"
#define MS_CONSEQUENCE "konsekwencja"
#define MS_DATA "data"
#define MS_DEPENDS "zalezy od"
#define MR_DEPENDS "zalezy", space_plus, "od"
#define MS_DECLARATION "deklaracja"
#define MS_CONTEXT "kontekst"
#define MS_DECREASING "malejacy"
#define MS_INCREASING "rosnacy"
#define MS_OF "z"
#define MS_COLLECTION "kolekcja"
#define MS_ENUM "enumeracja"
#define MS_INTEGER "calkowita"
#define MS_MONEY "pieni\x01\x05dze"
#define MR_MONEY "pieni", 0x0105, "dze"
#define MS_TEXT "tekst"
#define MS_DECIMAL "dziesi\x01\x19tny"
#define MR_DECIMAL "dziesi", 0x0119, "tny"
#define MS_DATE "czas"
#define MS_DURATION "czas trwania"
#define MR_DURATION "czas", space_plus, "trwania"
#define MS_BOOLEAN "zerojedynkowy"
#define MS_SUM "suma"
#define MS_FILLED "spelnione"
#define MS_DEFINITION "definicja"
#define MS_LABEL "etykieta"
#define MS_EXCEPTION "wyj\x01\x05tek"
#define MR_EXCEPTION "wyj", 0x0105, "tek"
#define MS_DEFINED_AS "wynosi"
#define MS_MATCH "pasuje"
#define MS_WILDCARD "cokolwiek"
#define MS_WITH "ze wzorem"
#define MR_WITH "ze", space_plus, "wzorem"
#define MS_UNDER_CONDITION "pod warunkiem"
#define MR_UNDER_CONDITION "pod", space_plus, "warunkiem"
#define MS_IF "jezeli"
#define MS_THEN "wtedy"
#define MS_ELSE "inaczej"
#define MS_CONDITION "warunek"
#define MS_CONTENT "typu"
#define MS_STRUCT "struktura"
#define MS_ASSERTION "asercja"
#define MS_VARIES "rozna"
#define MS_WITH_V "wraz z"
#define MR_WITH_V "wraz", space_plus, "z"
#define MS_FOR "dla"
#define MS_ALL "wszystkie"
#define MS_WE_HAVE "mamy"
#define MS_FIXED "staloprzecinkowa"
#define MS_BY "przez"
#define MS_RULE "zasada"
#define MS_EXISTS "istnieje"
#define MS_IN "in"
#define MS_SUCH "takie ze"
#define MR_SUCH "takie", space_plus, "ze"
#define MS_THAT "to"
#define MS_AND "i"
#define MS_OR "lub"
#define MS_XOR "xor"
#define MS_NOT "nie"
#define MS_MAXIMUM "maximum"
#define MS_MINIMUM "minimum"
#define MS_FILTER "filtr"
#define MS_MAP "mapuj"
#define MS_INIT "poczatkowy"
#define MS_CARDINAL "liczba"
#define MS_YEAR "rok"
#define MS_MONTH "miesiac"
#define MS_DAY "dzien"
#define MS_TRUE "prawda"
#define MS_FALSE "falsz"
(* Specific delimiters *)
#define MR_MONEY_OP_SUFFIX '$'
#define MC_DECIMAL_SEPARATOR '.'
#define MR_MONEY_PREFIX ""
#define MR_MONEY_DELIM ','
#define MR_MONEY_SUFFIX Star hspace, "PLN"
(* Builtins *)
#define MS_IntToDec "integer_to_decimal"
#define MS_GetDay "get_day"
#define MS_GetMonth "get_month"
#define MS_GetYear "get_year"
(* Directives *)
#define MR_BEGIN_METADATA "Poczatek", Plus hspace, "metadanych"
#define MR_END_METADATA "Koniec", Plus hspace, "metadanych"
#define MR_LAW_INCLUDE "Include"
#define MX_AT_PAGE \
'@', Star hspace, "p.", Star hspace, Plus digit -> \
let s = Utf8.lexeme lexbuf in \
let i = String.index s '.' in \
AT_PAGE (int_of_string (String.trim (String.sub s i (String.length s - i))))

15
compiler/surface/lexer_pl.mli Normal file
View File

@ -0,0 +1,15 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
include Lexer_common.LocalisedLexer

376
src/catala/catala_surface/name_resolution.ml → compiler/surface/name_resolution.ml
View File

@ -15,8 +15,7 @@
(** Builds a context that allows for mapping each name to a precise uid, taking lexical scopes into
account *)
module Pos = Utils.Pos
module Errors = Utils.Errors
open Utils
(** {1 Name resolution context} *)
@ -24,9 +23,13 @@ type ident = string
type typ = Scopelang.Ast.typ
type unique_rulename = Ambiguous of Pos.t list | Unique of Desugared.Ast.RuleName.t
type scope_context = {
var_idmap : Scopelang.Ast.ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *)
label_idmap : Desugared.Ast.RuleName.t Desugared.Ast.IdentMap.t;
default_rulemap : unique_rulename Desugared.Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Desugared.Ast.IdentMap.t;
(** Sub-scopes variables *)
sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
@ -72,7 +75,9 @@ let raise_unsupported_feature (msg : string) (pos : Pos.t) =
previously *)
let raise_unknown_identifier (msg : string) (ident : ident Pos.marked) =
Errors.raise_spanned_error
(Printf.sprintf "\"%s\": unknown identifier %s" (Pos.unmark ident) msg)
(Printf.sprintf "\"%s\": unknown identifier %s"
(Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" (Pos.unmark ident))
msg)
(Pos.get_position ident)
(** Gets the type associated to an uid *)
@ -141,7 +146,9 @@ let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap with
| Some use ->
Errors.raise_multispanned_error "Subscope name already used"
Errors.raise_multispanned_error
(Format.asprintf "Subscope name \"%s\" already used"
(Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" subscope))
[
(Some "first use", Pos.get_position (Scopelang.Ast.SubScopeName.get_info use));
(Some "second use", s_pos);
@ -195,7 +202,9 @@ let rec process_base_typ (ctxt : context) ((typ, typ_pos) : Ast.base_typ Pos.mar
| Some e_uid -> (Scopelang.Ast.TEnum e_uid, typ_pos)
| None ->
Errors.raise_spanned_error
"Unknown type, not a struct or enum previously declared" typ_pos ) ) )
(Format.asprintf "Unknown type \"%s\", not a struct or enum previously declared"
(Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" ident))
typ_pos)))
(** Process a type (function or not) *)
let process_type (ctxt : context) ((typ, typ_pos) : Ast.typ Pos.marked) :
@ -216,7 +225,9 @@ let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt name scope_ctxt.var_idmap with
| Some use ->
Errors.raise_multispanned_error "var name already used"
Errors.raise_multispanned_error
(Format.asprintf "var name \"%s\" already used"
(Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" name))
[
(Some "first use", Pos.get_position (Scopelang.Ast.ScopeVar.get_info use));
(Some "second use", pos);
@ -253,46 +264,15 @@ let add_def_local_var (ctxt : context) (name : ident Pos.marked) : context * Sco
(** Process a scope declaration *)
let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
let name, pos = decl.scope_decl_name in
(* Checks if the name is already used *)
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| Some use ->
Errors.raise_multispanned_error "scope name already used"
[
(Some "first use", Pos.get_position (Scopelang.Ast.ScopeName.get_info use));
(Some "second use", pos);
]
| None ->
let scope_uid = Scopelang.Ast.ScopeName.fresh (name, pos) in
let ctxt =
{
ctxt with
scope_idmap = Desugared.Ast.IdentMap.add name scope_uid ctxt.scope_idmap;
scopes =
Scopelang.Ast.ScopeMap.add scope_uid
{
var_idmap = Desugared.Ast.IdentMap.empty;
label_idmap = Desugared.Ast.IdentMap.empty;
sub_scopes_idmap = Desugared.Ast.IdentMap.empty;
sub_scopes = Scopelang.Ast.SubScopeMap.empty;
}
ctxt.scopes;
}
in
List.fold_left
(fun ctxt item -> process_item_decl scope_uid ctxt (Pos.unmark item))
ctxt decl.scope_decl_context
let name, _ = decl.scope_decl_name in
let scope_uid = Desugared.Ast.IdentMap.find name ctxt.scope_idmap in
List.fold_left
(fun ctxt item -> process_item_decl scope_uid ctxt (Pos.unmark item))
ctxt decl.scope_decl_context
(** Process a struct declaration *)
let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context =
let s_uid = Scopelang.Ast.StructName.fresh sdecl.struct_decl_name in
let ctxt =
{
ctxt with
struct_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark sdecl.struct_decl_name) s_uid ctxt.struct_idmap;
}
in
let s_uid = Desugared.Ast.IdentMap.find (fst sdecl.struct_decl_name) ctxt.struct_idmap in
List.fold_left
(fun ctxt (fdecl, _) ->
let f_uid = Scopelang.Ast.StructFieldName.fresh fdecl.Ast.struct_decl_field_name in
@ -330,14 +310,7 @@ let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context =
(** Process an enum declaration *)
let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
let e_uid = Scopelang.Ast.EnumName.fresh edecl.enum_decl_name in
let ctxt =
{
ctxt with
enum_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark edecl.enum_decl_name) e_uid ctxt.enum_idmap;
}
in
let e_uid = Desugared.Ast.IdentMap.find (fst edecl.enum_decl_name) ctxt.enum_idmap in
List.fold_left
(fun ctxt (cdecl, cdecl_pos) ->
let c_uid = Scopelang.Ast.EnumConstructor.fresh cdecl.Ast.enum_decl_case_name in
@ -371,6 +344,64 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
})
ctxt edecl.enum_decl_cases
(** Process the names of all declaration items *)
let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) : context =
let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
Errors.raise_multispanned_error
(Format.asprintf "%s name \"%s\" already defined" msg
(Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" name))
[ (Some "first definition", Pos.get_position use); (Some "second definition", pos) ]
in
match Pos.unmark item with
| ScopeDecl decl -> (
let name, pos = decl.scope_decl_name in
(* Checks if the name is already used *)
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| Some use ->
raise_already_defined_error (Scopelang.Ast.ScopeName.get_info use) name pos "scope"
| None ->
let scope_uid = Scopelang.Ast.ScopeName.fresh (name, pos) in
{
ctxt with
scope_idmap = Desugared.Ast.IdentMap.add name scope_uid ctxt.scope_idmap;
scopes =
Scopelang.Ast.ScopeMap.add scope_uid
{
var_idmap = Desugared.Ast.IdentMap.empty;
label_idmap = Desugared.Ast.IdentMap.empty;
default_rulemap = Desugared.Ast.ScopeDefMap.empty;
sub_scopes_idmap = Desugared.Ast.IdentMap.empty;
sub_scopes = Scopelang.Ast.SubScopeMap.empty;
}
ctxt.scopes;
})
| StructDecl sdecl -> (
let name, pos = sdecl.struct_decl_name in
match Desugared.Ast.IdentMap.find_opt name ctxt.struct_idmap with
| Some use ->
raise_already_defined_error (Scopelang.Ast.StructName.get_info use) name pos "struct"
| None ->
let s_uid = Scopelang.Ast.StructName.fresh sdecl.struct_decl_name in
{
ctxt with
struct_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark sdecl.struct_decl_name) s_uid ctxt.struct_idmap;
})
| EnumDecl edecl -> (
let name, pos = edecl.enum_decl_name in
match Desugared.Ast.IdentMap.find_opt name ctxt.enum_idmap with
| Some use ->
raise_already_defined_error (Scopelang.Ast.EnumName.get_info use) name pos "enum"
| None ->
let e_uid = Scopelang.Ast.EnumName.fresh edecl.enum_decl_name in
{
ctxt with
enum_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark edecl.enum_decl_name) e_uid ctxt.enum_idmap;
})
| ScopeUse _ -> ctxt
(** Process a code item that is a declaration *)
let process_decl_item (ctxt : context) (item : Ast.code_item Pos.marked) : context =
match Pos.unmark item with
@ -384,92 +415,179 @@ let process_code_block (ctxt : context) (block : Ast.code_block)
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block
(** Process a law article item, only considering the code blocks *)
let process_law_article_item (ctxt : context) (item : Ast.law_article_item)
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
match item with CodeBlock (block, _) -> process_code_block ctxt block process_item | _ -> ctxt
(** Process a law structure, only considering the code blocks *)
let rec process_law_structure (ctxt : context) (s : Ast.law_structure)
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
match s with
| Ast.LawHeading (_, children) ->
List.fold_left (fun ctxt child -> process_law_structure ctxt child process_item) ctxt children
| Ast.LawArticle (_, children) ->
List.fold_left
(fun ctxt child -> process_law_article_item ctxt child process_item)
ctxt children
| Ast.MetadataBlock (b, c) -> process_law_article_item ctxt (Ast.CodeBlock (b, c)) process_item
| Ast.IntermediateText _ | Ast.LawInclude _ -> ctxt
(** Process a program item, only considering the code blocks *)
let process_program_item (ctxt : context) (item : Ast.program_item)
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
match item with Ast.LawStructure s -> process_law_structure ctxt s process_item
| Ast.CodeBlock (block, _, _) -> process_code_block ctxt block process_item
| Ast.LawInclude _ | Ast.LawText _ -> ctxt
(** {1 Scope uses pass} *)
let process_rule (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (r : Ast.rule) : context =
match r.Ast.rule_label with
| None -> ctxt
| Some label ->
let rule_name =
Desugared.Ast.RuleName.fresh
( match r.rule_label with
| None ->
Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
r.rule_name
| Some label -> label )
let get_def_key (name : Ast.qident) (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
(default_pos : Pos.t) : Desugared.Ast.ScopeDef.t =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match name with
| [ x ] ->
let x_uid = get_var_uid scope_uid ctxt x in
Desugared.Ast.ScopeDef.Var x_uid
| [ y; x ] ->
let subscope_uid : Scopelang.Ast.SubScopeName.t = get_subscope_uid scope_uid ctxt y in
let subscope_real_uid : Scopelang.Ast.ScopeName.t =
Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
in
{
ctxt with
scopes =
Scopelang.Ast.ScopeMap.update s_name
(fun s_ctxt ->
match s_ctxt with
| None -> assert false (* should not happen *)
| Some s_ctxt ->
Some
{
s_ctxt with
label_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark label) rule_name s_ctxt.label_idmap;
})
ctxt.scopes;
}
let x_uid = get_var_uid subscope_real_uid ctxt x in
Desugared.Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid)
| _ -> Errors.raise_spanned_error "Structs are not handled yet" default_pos
let process_rule (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (r : Ast.rule) : context =
(* Process the label map first *)
let ctxt =
match r.Ast.rule_label with
| None -> ctxt
| Some label ->
let rule_name =
Desugared.Ast.RuleName.fresh
(match r.rule_label with
| None ->
Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
r.rule_name
| Some label -> label)
in
{
ctxt with
scopes =
Scopelang.Ast.ScopeMap.update s_name
(fun s_ctxt ->
match s_ctxt with
| None -> assert false (* should not happen *)
| Some s_ctxt ->
Some
{
s_ctxt with
label_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark label) rule_name s_ctxt.label_idmap;
})
ctxt.scopes;
}
in
(* And update the map of default rulenames for unlabeled exceptions *)
match r.Ast.rule_exception_to with
(* If this definition is an exception, it cannot be a default definition *)
| UnlabeledException | ExceptionToLabel _ -> ctxt
(* If it is not an exception, we need to distinguish between several cases *)
| NotAnException ->
let def_key =
get_def_key (Pos.unmark r.rule_name) s_name ctxt (Pos.get_position r.rule_consequence)
in
let scope_ctxt = Scopelang.Ast.ScopeMap.find s_name ctxt.scopes in
let rulemap =
match Desugared.Ast.ScopeDefMap.find_opt def_key scope_ctxt.default_rulemap with
(* There was already a default definition for this key. If we need it, it is ambiguous *)
| Some old ->
Desugared.Ast.ScopeDefMap.add def_key
(Ambiguous
([ Pos.get_position r.rule_name ]
@
match old with
| Ambiguous old -> old
| Unique n -> [ Pos.get_position (Desugared.Ast.RuleName.get_info n) ]))
scope_ctxt.default_rulemap
(* No definition has been set yet for this key *)
| None -> (
match r.Ast.rule_label with
(* This default definition has a label. This is not allowed for unlabeled exceptions *)
| Some _ ->
Desugared.Ast.ScopeDefMap.add def_key
(Ambiguous [ Pos.get_position r.rule_name ])
scope_ctxt.default_rulemap
(* This is a possible default definition for this key. We create and store a fresh
rulename *)
| None ->
Desugared.Ast.ScopeDefMap.add def_key
(Unique (Desugared.Ast.RuleName.fresh (Pos.same_pos_as "default" r.rule_name)))
scope_ctxt.default_rulemap)
in
let new_scope_ctxt = { scope_ctxt with default_rulemap = rulemap } in
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add s_name new_scope_ctxt ctxt.scopes }
let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d : Ast.definition) :
context =
match d.Ast.definition_label with
| None -> ctxt
| Some label ->
let definition_name =
Desugared.Ast.RuleName.fresh
( match d.definition_label with
| None ->
Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
d.definition_name
| Some label -> label )
(* Process the label map first *)
let ctxt =
match d.Ast.definition_label with
| None -> ctxt
| Some label ->
let definition_name =
Desugared.Ast.RuleName.fresh
(match d.definition_label with
| None ->
Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
d.definition_name
| Some label -> label)
in
{
ctxt with
scopes =
Scopelang.Ast.ScopeMap.update s_name
(fun s_ctxt ->
match s_ctxt with
| None -> assert false (* should not happen *)
| Some s_ctxt ->
Some
{
s_ctxt with
label_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark label) definition_name
s_ctxt.label_idmap;
})
ctxt.scopes;
}
in
(* And update the map of default rulenames for unlabeled exceptions *)
match d.Ast.definition_exception_to with
(* If this definition is an exception, it cannot be a default definition *)
| UnlabeledException | ExceptionToLabel _ -> ctxt
(* If it is not an exception, we need to distinguish between several cases *)
| NotAnException ->
let def_key =
get_def_key (Pos.unmark d.definition_name) s_name ctxt (Pos.get_position d.definition_expr)
in
{
ctxt with
scopes =
Scopelang.Ast.ScopeMap.update s_name
(fun s_ctxt ->
match s_ctxt with
| None -> assert false (* should not happen *)
| Some s_ctxt ->
Some
{
s_ctxt with
label_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark label) definition_name
s_ctxt.label_idmap;
})
ctxt.scopes;
}
let scope_ctxt = Scopelang.Ast.ScopeMap.find s_name ctxt.scopes in
let rulemap =
match Desugared.Ast.ScopeDefMap.find_opt def_key scope_ctxt.default_rulemap with
(* There was already a default definition for this key. If we need it, it is ambiguous *)
| Some old ->
Desugared.Ast.ScopeDefMap.add def_key
(Ambiguous
([ Pos.get_position d.definition_name ]
@
match old with
| Ambiguous old -> old
| Unique n -> [ Pos.get_position (Desugared.Ast.RuleName.get_info n) ]))
scope_ctxt.default_rulemap
(* No definition has been set yet for this key *)
| None -> (
match d.Ast.definition_label with
(* This default definition has a label. This is not allowed for unlabeled exceptions *)
| Some _ ->
Desugared.Ast.ScopeDefMap.add def_key
(Ambiguous [ Pos.get_position d.definition_name ])
scope_ctxt.default_rulemap
(* This is a possible default definition for this key. We create and store a fresh
rulename *)
| None ->
Desugared.Ast.ScopeDefMap.add def_key
(Unique
(Desugared.Ast.RuleName.fresh (Pos.same_pos_as "default" d.definition_name)))
scope_ctxt.default_rulemap)
in
let new_scope_ctxt = { scope_ctxt with default_rulemap = rulemap } in
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add s_name new_scope_ctxt ctxt.scopes }
let process_scope_use_item (s_name : Scopelang.Ast.ScopeName.t) (ctxt : context)
(sitem : Ast.scope_use_item Pos.marked) : context =
@ -484,7 +602,8 @@ let process_scope_use (ctxt : context) (suse : Ast.scope_use) : context =
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "\"%s\": this scope has not been declared anywhere, is it a typo?"
(Pos.unmark suse.Ast.scope_use_name))
(Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s"
(Pos.unmark suse.Ast.scope_use_name)))
(Pos.get_position suse.Ast.scope_use_name)
in
List.fold_left (process_scope_use_item s_name) ctxt suse.Ast.scope_use_items
@ -514,12 +633,17 @@ let form_context (prgm : Ast.program) : context =
in
let ctxt =
List.fold_left
(fun ctxt item -> process_program_item ctxt item process_decl_item)
(fun ctxt item -> process_law_structure ctxt item process_name_item)
empty_ctxt prgm.program_items
in
let ctxt =
List.fold_left
(fun ctxt item -> process_program_item ctxt item process_use_item)
(fun ctxt item -> process_law_structure ctxt item process_decl_item)
ctxt prgm.program_items
in
let ctxt =
List.fold_left
(fun ctxt item -> process_law_structure ctxt item process_use_item)
ctxt prgm.program_items
in
ctxt

112
compiler/surface/name_resolution.mli Normal file
View File

@ -0,0 +1,112 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing
<nicolas.chataing@ens.fr> Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Builds a context that allows for mapping each name to a precise uid, taking lexical scopes into
account *)
open Utils
(** {1 Name resolution context} *)
type ident = string
type typ = Scopelang.Ast.typ
type unique_rulename = Ambiguous of Pos.t list | Unique of Desugared.Ast.RuleName.t
type scope_context = {
var_idmap : Scopelang.Ast.ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *)
label_idmap : Desugared.Ast.RuleName.t Desugared.Ast.IdentMap.t;
default_rulemap : unique_rulename Desugared.Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Desugared.Ast.IdentMap.t;
(** Sub-scopes variables *)
sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
(** To what scope sub-scopes refer to? *)
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
type struct_context = typ Pos.marked Scopelang.Ast.StructFieldMap.t
(** Types of the fields of a struct *)
type enum_context = typ Pos.marked Scopelang.Ast.EnumConstructorMap.t
(** Types of the payloads of the cases of an enum *)
type context = {
local_var_idmap : Scopelang.Ast.Var.t Desugared.Ast.IdentMap.t;
(** Inside a definition, local variables can be introduced by functions arguments or pattern
matching *)
scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t; (** The names of the scopes *)
struct_idmap : Scopelang.Ast.StructName.t Desugared.Ast.IdentMap.t;
(** The names of the structs *)
field_idmap : Scopelang.Ast.StructFieldName.t Scopelang.Ast.StructMap.t Desugared.Ast.IdentMap.t;
(** The names of the struct fields. Names of fields can be shared between different structs *)
enum_idmap : Scopelang.Ast.EnumName.t Desugared.Ast.IdentMap.t; (** The names of the enums *)
constructor_idmap :
Scopelang.Ast.EnumConstructor.t Scopelang.Ast.EnumMap.t Desugared.Ast.IdentMap.t;
(** The names of the enum constructors. Constructor names can be shared between different
enums *)
scopes : scope_context Scopelang.Ast.ScopeMap.t; (** For each scope, its context *)
structs : struct_context Scopelang.Ast.StructMap.t; (** For each struct, its context *)
enums : enum_context Scopelang.Ast.EnumMap.t; (** For each enum, its context *)
var_typs : (typ Pos.marked * bool) (* is it a condition? *) Scopelang.Ast.ScopeVarMap.t;
(** The types of each scope variable declared *)
}
(** Main context used throughout {!module: Surface.Desugaring} *)
(** {1 Helpers} *)
val raise_unsupported_feature : string -> Pos.t -> 'a
(** Temporary function raising an error message saying that a feature is not supported yet *)
val raise_unknown_identifier : string -> ident Pos.marked -> 'a
(** Function to call whenever an identifier used somewhere has not been declared in the program
previously *)
val get_var_typ : context -> Scopelang.Ast.ScopeVar.t -> typ Pos.marked
(** Gets the type associated to an uid *)
val is_var_cond : context -> Scopelang.Ast.ScopeVar.t -> bool
val get_var_uid :
Scopelang.Ast.ScopeName.t -> context -> ident Pos.marked -> Scopelang.Ast.ScopeVar.t
(** Get the variable uid inside the scope given in argument *)
val get_subscope_uid :
Scopelang.Ast.ScopeName.t -> context -> ident Pos.marked -> Scopelang.Ast.SubScopeName.t
(** Get the subscope uid inside the scope given in argument *)
val is_subscope_uid : Scopelang.Ast.ScopeName.t -> context -> ident -> bool
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the subscopes of [scope_uid]. *)
val belongs_to : context -> Scopelang.Ast.ScopeVar.t -> Scopelang.Ast.ScopeName.t -> bool
(** Checks if the var_uid belongs to the scope scope_uid *)
val get_def_typ : context -> Desugared.Ast.ScopeDef.t -> typ Pos.marked
(** Retrieves the type of a scope definition from the context *)
val is_def_cond : context -> Desugared.Ast.ScopeDef.t -> bool
val is_type_cond : Ast.typ Pos.marked -> bool
val add_def_local_var : context -> ident Pos.marked -> context * Scopelang.Ast.Var.t
(** Adds a binding to the context *)
val get_def_key :
Ast.qident -> Scopelang.Ast.ScopeName.t -> context -> Pos.t -> Desugared.Ast.ScopeDef.t
(** {1 API} *)
val form_context : Ast.program -> context
(** Derive the context from metadata, in one pass over the declarations *)

0
src/catala/catala_surface/parse_utils.ml → compiler/surface/parse_utils.ml
View File

17
compiler/surface/parse_utils.mli Normal file
View File

@ -0,0 +1,17 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Helpers for parsing *)
val current_file : string ref

2074
compiler/surface/parser.messages Normal file
View File

File diff suppressed because it is too large Load Diff

608
compiler/surface/parser.mly Normal file
View File

@ -0,0 +1,608 @@
(*
This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules.
Copyright (C) 2020 Inria, contributors: Denis Merigoux <denis.merigoux@inria.fr>,
Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
%{
open Utils
%}
%parameter<Localisation: sig
val lex_builtin: string -> Ast.builtin_expression option
end>
%type <Ast.source_file> source_file
%start source_file
(* The token is returned for every line of law text, make them right-associative
so that we concat them efficiently as much as possible. *)
%right LAW_TEXT
%%
typ_base:
| INTEGER { (Integer, Pos.from_lpos $sloc) }
| BOOLEAN { (Boolean, Pos.from_lpos $sloc) }
| MONEY { (Money, Pos.from_lpos $sloc) }
| DURATION { (Duration, Pos.from_lpos $sloc) }
| TEXT { (Text, Pos.from_lpos $sloc) }
| DECIMAL { (Decimal, Pos.from_lpos $sloc) }
| DATE { (Date, Pos.from_lpos $sloc) }
| c = constructor {
let (s, _) = c in
(Named s, Pos.from_lpos $sloc)
}
collection_marked:
| COLLECTION { Pos.from_lpos $sloc }
typ:
| t = typ_base {
let t, loc = t in
(Primitive t, loc)
}
| collection_marked t = typ {
(Collection t, Pos.from_lpos $sloc)
}
qident:
| b = separated_nonempty_list(DOT, ident) {
( b, Pos.from_lpos $sloc)
}
atomic_expression:
| q = IDENT {
(match Localisation.lex_builtin q with
| Some b -> Builtin b
| None -> Ident q),
Pos.from_lpos $sloc }
| l = literal { let (l, l_pos) = l in (Literal l, l_pos) }
| LPAREN e = expression RPAREN { e }
small_expression:
| e = atomic_expression { e }
| e = small_expression DOT c = option(terminated(constructor,DOT)) i = ident {
(Dotted (e, c, i), Pos.from_lpos $sloc)
}
struct_content_field:
| field = ident COLON e = logical_expression {
(field, e)
}
enum_inject_content:
| CONTENT e = small_expression { e }
struct_inject_content:
| LBRACKET ALT fields = separated_nonempty_list(ALT, struct_content_field) RBRACKET { fields }
struct_or_enum_inject:
| enum = constructor c = option(preceded(DOT, constructor)) data = option(enum_inject_content) {
(* The fully qualified enum is actually the optional part, but it leads to shift/reduce conflicts.
We flip it here *)
match c with
| None -> (EnumInject(None, enum, data), Pos.from_lpos $sloc)
| Some c -> (EnumInject(Some enum, c, data), Pos.from_lpos $sloc)
}
| c = constructor fields = struct_inject_content { (StructLit(c, fields), Pos.from_lpos $sloc) }
primitive_expression:
| e = small_expression { e }
| CARDINAL {
(Builtin Cardinal, Pos.from_lpos $sloc)
}
| e = struct_or_enum_inject {
e
}
| LSQUARE l = separated_list(SEMICOLON, expression) RSQUARE {
(ArrayLit l, Pos.from_lpos $sloc)
}
num_literal:
| d = INT_LITERAL { (Int d, Pos.from_lpos $sloc) }
| d = DECIMAL_LITERAL {
let (d1, d2) = d in
(Dec (d1, d2), Pos.from_lpos $sloc)
}
unit_literal:
| PERCENT { (Percent, Pos.from_lpos $sloc) }
| YEAR { (Year, Pos.from_lpos $sloc)}
| MONTH { (Month, Pos.from_lpos $sloc) }
| DAY { (Day, Pos.from_lpos $sloc) }
date_int:
| d = INT_LITERAL { (Runtime.integer_to_int d, Pos.from_lpos $sloc) }
literal:
| l = num_literal u = option(unit_literal) {
(LNumber (l, u), Pos.from_lpos $sloc)
}
| money = MONEY_AMOUNT {
let (units, cents) = money in
(LMoneyAmount {
money_amount_units = units;
money_amount_cents = cents;
}, Pos.from_lpos $sloc)
}
| VERTICAL y = date_int MINUS m = date_int MINUS d = date_int VERTICAL {
(LDate {
literal_date_year = y;
literal_date_month = m;
literal_date_day = d;
}, Pos.from_lpos $sloc)
}
| TRUE { (LBool true, Pos.from_lpos $sloc) }
| FALSE { (LBool false, Pos.from_lpos $sloc) }
compare_op:
| LESSER { (Lt KInt, Pos.from_lpos $sloc) }
| LESSER_EQUAL { (Lte KInt, Pos.from_lpos $sloc) }
| GREATER { (Gt KInt, Pos.from_lpos $sloc) }
| GREATER_EQUAL { (Gte KInt, Pos.from_lpos $sloc) }
| LESSER_DEC { (Lt KDec, Pos.from_lpos $sloc) }
| LESSER_EQUAL_DEC { (Lte KDec, Pos.from_lpos $sloc) }
| GREATER_DEC { (Gt KDec, Pos.from_lpos $sloc) }
| GREATER_EQUAL_DEC { (Gte KDec, Pos.from_lpos $sloc) }
| LESSER_MONEY { (Lt KMoney, Pos.from_lpos $sloc) }
| LESSER_EQUAL_MONEY { (Lte KMoney, Pos.from_lpos $sloc) }
| GREATER_MONEY { (Gt KMoney, Pos.from_lpos $sloc) }
| GREATER_EQUAL_MONEY { (Gte KMoney, Pos.from_lpos $sloc) }
| LESSER_DATE { (Lt KDate, Pos.from_lpos $sloc) }
| LESSER_EQUAL_DATE { (Lte KDate, Pos.from_lpos $sloc) }
| GREATER_DATE { (Gt KDate, Pos.from_lpos $sloc) }
| GREATER_EQUAL_DATE { (Gte KDate, Pos.from_lpos $sloc) }
| LESSER_DURATION { (Lt KDuration, Pos.from_lpos $sloc) }
| LESSER_EQUAL_DURATION { (Lte KDuration, Pos.from_lpos $sloc) }
| GREATER_DURATION { (Gt KDuration, Pos.from_lpos $sloc) }
| GREATER_EQUAL_DURATION { (Gte KDuration, Pos.from_lpos $sloc) }
| EQUAL { (Eq, Pos.from_lpos $sloc) }
| NOT_EQUAL { (Neq, Pos.from_lpos $sloc) }
aggregate_func:
| CONTENT MAXIMUM t = typ_base INIT init = primitive_expression {
(Aggregate (AggregateArgExtremum (true, Pos.unmark t, init)), Pos.from_lpos $sloc)
}
| CONTENT MINIMUM t = typ_base INIT init = primitive_expression {
(Aggregate (AggregateArgExtremum (false, Pos.unmark t, init)), Pos.from_lpos $sloc)
}
| MAXIMUM t = typ_base INIT init = primitive_expression {
(Aggregate (AggregateExtremum (true, Pos.unmark t, init)), Pos.from_lpos $sloc)
}
| MINIMUM t = typ_base INIT init = primitive_expression {
(Aggregate (AggregateExtremum (false, Pos.unmark t, init)), Pos.from_lpos $sloc)
}
| SUM t = typ_base { (Aggregate (AggregateSum (Pos.unmark t)), Pos.from_lpos $sloc) }
| CARDINAL { (Aggregate AggregateCount, Pos.from_lpos $sloc) }
| FILTER { (Filter, Pos.from_lpos $sloc ) }
| MAP { (Map, Pos.from_lpos $sloc) }
aggregate:
| func = aggregate_func FOR i = ident IN e1 = primitive_expression
OF e2 = base_expression {
(CollectionOp (func, i, e1, e2), Pos.from_lpos $sloc)
}
base_expression:
| e = primitive_expression { e }
| ag = aggregate { ag }
| e1 = primitive_expression OF e2 = base_expression {
(FunCall (e1, e2), Pos.from_lpos $sloc)
}
| e = primitive_expression WITH c = constructor_binding {
(TestMatchCase (e, (c, Pos.from_lpos $sloc)), Pos.from_lpos $sloc)
}
| e1 = primitive_expression IN e2 = base_expression {
(MemCollection (e1, e2), Pos.from_lpos $sloc)
}
mult_op:
| MULT { (Mult KInt, Pos.from_lpos $sloc) }
| DIV { (Div KInt, Pos.from_lpos $sloc) }
| MULTDEC { (Mult KDec, Pos.from_lpos $sloc) }
| DIVDEC { (Div KDec, Pos.from_lpos $sloc) }
| MULTMONEY { (Mult KMoney, Pos.from_lpos $sloc) }
| DIVMONEY { (Div KMoney, Pos.from_lpos $sloc) }
| DIVDURATION { (Div KDuration, Pos.from_lpos $sloc) }
mult_expression:
| e = base_expression { e }
| e1 = base_expression binop = mult_op e2 = mult_expression {
(Binop (binop, e1, e2), Pos.from_lpos $sloc)
}
sum_op:
| PLUSDURATION { (Add KDuration, Pos.from_lpos $sloc) }
| MINUSDURATION { (Sub KDuration, Pos.from_lpos $sloc) }
| PLUSDATE { (Add KDate, Pos.from_lpos $sloc) }
| MINUSDATE { (Sub KDate, Pos.from_lpos $sloc) }
| PLUSMONEY { (Add KMoney, Pos.from_lpos $sloc) }
| MINUSMONEY { (Sub KMoney, Pos.from_lpos $sloc) }
| PLUSDEC { (Add KDec, Pos.from_lpos $sloc) }
| MINUSDEC { (Sub KDec, Pos.from_lpos $sloc) }
| PLUS { (Add KInt, Pos.from_lpos $sloc) }
| MINUS { (Sub KInt, Pos.from_lpos $sloc) }
| PLUSPLUS { (Concat, Pos.from_lpos $sloc) }
sum_unop:
| MINUS { (Minus KInt, Pos.from_lpos $sloc) }
| MINUSDEC { (Minus KDec, Pos.from_lpos $sloc) }
| MINUSMONEY { (Minus KMoney, Pos.from_lpos $sloc) }
| MINUSDURATION { (Minus KDuration, Pos.from_lpos $sloc) }
sum_expression:
| e = mult_expression { e }
| e1 = mult_expression binop = sum_op e2 = sum_expression {
(Binop (binop, e1, e2), Pos.from_lpos $sloc)
}
| unop = sum_unop e = sum_expression { (Unop (unop, e), Pos.from_lpos $sloc) }
logical_op:
| AND { (And, Pos.from_lpos $sloc) }
| OR { (Or, Pos.from_lpos $sloc) }
| XOR { (Xor, Pos.from_lpos $sloc) }
logical_unop:
| NOT { (Not, Pos.from_lpos $sloc) }
compare_expression:
| e = sum_expression { e }
| e1 = sum_expression binop = compare_op e2 = compare_expression {
(Binop (binop, e1, e2), Pos.from_lpos $sloc)
}
logical_expression:
| e = compare_expression { e }
| unop = logical_unop e = compare_expression { (Unop (unop, e), Pos.from_lpos $sloc) }
| e1 = compare_expression binop = logical_op e2 = logical_expression {
(Binop (binop, e1, e2), Pos.from_lpos $sloc)
}
maybe_qualified_constructor:
| c_or_path = constructor c = option(preceded(DOT, constructor)) {
match c with
| None -> (None, c_or_path)
| Some c -> (Some c_or_path, c)
}
optional_binding:
| { ([], None)}
| OF i = ident {([], Some i)}
| OF c = maybe_qualified_constructor cs_and_i = constructor_binding {
let (cs, i) = cs_and_i in
(c::cs, i)
}
constructor_binding:
| c = maybe_qualified_constructor cs_and_i = optional_binding {
let (cs, i) = cs_and_i in
(c::cs, i)
}
match_arm:
| WILDCARD COLON e = logical_expression { (WildCard (e), Pos.from_lpos $sloc) }
| pat = constructor_binding COLON e = logical_expression {
(MatchCase ({
(* DM 14/04/2020 : I can't have the $sloc in constructor_binding... *)
match_case_pattern = (pat, Pos.from_lpos $sloc);
match_case_expr = e;
}), Pos.from_lpos $sloc)
}
match_arms:
| ALT a = match_arm arms = match_arms {
let (arms, _) = arms in
(a::arms, Pos.from_lpos $sloc)
}
| { ([], Pos.from_lpos $sloc)}
for_all_marked:
| FOR ALL { Pos.from_lpos $sloc }
exists_marked:
| EXISTS { Pos.from_lpos $sloc }
forall_prefix:
| pos = for_all_marked i = ident IN e = primitive_expression WE_HAVE {
(pos, i, e)
}
exists_prefix:
| pos = exists_marked i = ident IN e = primitive_expression SUCH THAT {
(pos, i, e)
}
expression:
| i_in_e1 = exists_prefix e2 = expression {
let (pos, i,e1) = i_in_e1 in
(CollectionOp ((Exists, pos), i, e1, e2), Pos.from_lpos $sloc)
}
| i_in_e1 = forall_prefix e2 = expression {
let (pos, i,e1) = i_in_e1 in
(CollectionOp ((Forall, pos), i, e1, e2), Pos.from_lpos $sloc)
}
| MATCH e = primitive_expression WITH arms = match_arms {
(MatchWith (e, arms), Pos.from_lpos $sloc)
}
| IF e1 = expression THEN e2 = expression ELSE e3 = base_expression {
(IfThenElse (e1, e2, e3), Pos.from_lpos $sloc)
}
| e = logical_expression { e }
condition:
| UNDER_CONDITION e = expression { e }
condition_consequence:
| cond = condition CONSEQUENCE { cond }
rule_expr:
| i = qident p = option(definition_parameters) { (i, p) }
rule_consequence:
| flag = option(NOT) FILLED {
let b = match flag with Some _ -> false | None -> true in
(b, Pos.from_lpos $sloc)
}
rule:
| label = option(label)
except = option(exception_to)
RULE
name_and_param = rule_expr cond = option(condition_consequence)
consequence = rule_consequence {
let (name, param_applied) = name_and_param in
let cons : bool Pos.marked = consequence in
let rule_exception = match except with | None -> NotAnException | Some x -> x in
({
rule_label = label;
rule_exception_to = rule_exception;
rule_parameter = param_applied;
rule_condition = cond;
rule_name = name;
rule_consequence = cons;
}, $sloc)
}
definition_parameters:
| OF i = ident { i }
label:
| LABEL i = ident { i }
exception_to:
| EXCEPTION i = option(ident) {
match i with | None -> UnlabeledException | Some x -> ExceptionToLabel x
}
definition:
| label = option(label)
except = option(exception_to)
DEFINITION
name = qident param = option(definition_parameters)
cond = option(condition_consequence) DEFINED_AS e = expression {
let def_exception = match except with | None -> NotAnException | Some x -> x in
({
definition_label = label;
definition_exception_to = def_exception;
definition_name = name;
definition_parameter = param;
definition_condition = cond;
definition_expr = e;
}, $sloc)
}
variation_type:
| INCREASING { (Increasing, Pos.from_lpos $sloc) }
| DECREASING { (Decreasing, Pos.from_lpos $sloc) }
assertion_base:
| e = expression { let (e, _) = e in (e, Pos.from_lpos $sloc) }
assertion:
| cond = option(condition_consequence) base = assertion_base {
(Assertion {
assertion_condition = cond;
assertion_content = base;
})
}
| FIXED q = qident BY i = ident { MetaAssertion (FixedBy (q, i)) }
| VARIES q = qident WITH_V e = base_expression t = option(variation_type) {
MetaAssertion (VariesWith (q, e, t))
}
scope_item:
| r = rule {
let (r, _) = r in (Rule r, Pos.from_lpos $sloc)
}
| d = definition {
let (d, _) = d in (Definition d, Pos.from_lpos $sloc)
}
| ASSERTION contents = assertion {
(contents, Pos.from_lpos $sloc)
}
ident:
| i = IDENT {
match Localisation.lex_builtin i with
| Some _ ->
Errors.raise_spanned_error
(Printf.sprintf "Reserved builtin name")
(Pos.from_lpos $sloc)
| None ->
(i, Pos.from_lpos $sloc)
}
condition_pos:
| CONDITION { Pos.from_lpos $sloc }
struct_scope_base:
| DATA i= ident CONTENT t = typ {
let t, pos = t in
(i, (Data t, pos))
}
| pos = condition_pos i = ident {
(i, (Condition, pos))
}
struct_scope_func:
| DEPENDS t = typ { t }
struct_scope:
| name_and_typ = struct_scope_base func_typ = option(struct_scope_func) {
let (name, typ) = name_and_typ in
let (typ, typ_pos) = typ in
({
struct_decl_field_name = name;
struct_decl_field_typ = match func_typ with
| None -> (Base typ, typ_pos)
| Some (arg_typ, arg_pos) -> (Func {
arg_typ = (Data arg_typ, arg_pos);
return_typ = (typ, typ_pos);
}, Pos.from_lpos $sloc) ;
}, Pos.from_lpos $sloc)
}
scope_decl_item:
| CONTEXT i = ident CONTENT t = typ func_typ = option(struct_scope_func) { (ContextData ({
scope_decl_context_item_name = i;
scope_decl_context_item_typ =
let (typ, typ_pos) = t in
match func_typ with
| None -> (Base (Data typ), typ_pos)
| Some (arg_typ, arg_pos) -> (Func {
arg_typ = (Data arg_typ, arg_pos);
return_typ = (Data typ, typ_pos);
}, Pos.from_lpos $sloc);
}), Pos.from_lpos $sloc)
}
| CONTEXT i = ident SCOPE c = constructor {
(ContextScope({
scope_decl_context_scope_name = i;
scope_decl_context_scope_sub_scope = c;
}), Pos.from_lpos $sloc)
}
| CONTEXT i = ident _condition = CONDITION func_typ = option(struct_scope_func) {
(ContextData ({
scope_decl_context_item_name = i;
scope_decl_context_item_typ =
match func_typ with
| None -> (Base (Condition), Pos.from_lpos $loc(_condition))
| Some (arg_typ, arg_pos) -> (Func {
arg_typ = (Data arg_typ, arg_pos);
return_typ = (Condition, Pos.from_lpos $loc(_condition));
}, Pos.from_lpos $sloc);
}), Pos.from_lpos $sloc
)
}
enum_decl_line_payload:
| CONTENT t = typ { let (t, t_pos) = t in (Base (Data t), t_pos) }
enum_decl_line:
| ALT c = constructor t = option(enum_decl_line_payload) {
({
enum_decl_case_name = c;
enum_decl_case_typ = t;
}, Pos.from_lpos $sloc)
}
constructor:
| c = CONSTRUCTOR { (c, Pos.from_lpos $sloc) }
scope_use_condition:
| UNDER_CONDITION e = expression { e }
code_item:
| SCOPE c = constructor e = option(scope_use_condition) COLON items = nonempty_list(scope_item) {
(ScopeUse {
scope_use_name = c;
scope_use_condition = e;
scope_use_items = items;
}, Pos.from_lpos $sloc)
}
| DECLARATION STRUCT c = constructor COLON scopes = list(struct_scope) {
(StructDecl {
struct_decl_name = c;
struct_decl_fields = scopes;
}, Pos.from_lpos $sloc)
}
| DECLARATION SCOPE c = constructor COLON context = nonempty_list(scope_decl_item) {
(ScopeDecl {
scope_decl_name = c;
scope_decl_context = context;
}, Pos.from_lpos $sloc)
}
| DECLARATION ENUM c = constructor COLON cases = nonempty_list(enum_decl_line) {
(EnumDecl {
enum_decl_name = c;
enum_decl_cases = cases;
}, Pos.from_lpos $sloc)
}
code:
| code = list(code_item) { (code, Pos.from_lpos $sloc) }
metadata_block:
| BEGIN_DIRECTIVE BEGIN_METADATA END_DIRECTIVE option(law_text) BEGIN_CODE code_and_pos = code text = END_CODE option(law_text) BEGIN_DIRECTIVE END_METADATA END_DIRECTIVE {
let (code, pos) = code_and_pos in
(code, (text, pos))
}
law_heading:
| title = LAW_HEADING {
let (title, id, exp_date, precedence) = title in {
law_heading_name = (title, Pos.from_lpos $sloc);
law_heading_id = id;
law_heading_expiration_date = exp_date;
law_heading_precedence = precedence;
}
}
law_text:
| lines = nonempty_list(LAW_TEXT) { String.trim (String.concat "" lines) }
source_file_item:
| text = law_text { LawText text }
| BEGIN_CODE code_and_pos = code text = END_CODE {
let (code, pos) = code_and_pos in
CodeBlock (code, (text, pos), false)
}
| heading = law_heading {
LawHeading (heading, [])
}
| code = metadata_block {
let (code, source_repr) = code in
CodeBlock (code, source_repr, true)
}
| BEGIN_DIRECTIVE LAW_INCLUDE COLON args = nonempty_list(DIRECTIVE_ARG) page = option(AT_PAGE) END_DIRECTIVE {
let filename = String.trim (String.concat "" args) in
let pos = Pos.from_lpos $sloc in
let jorftext = Re.Pcre.regexp "JORFTEXT\\d{12}" in
if Re.Pcre.pmatch ~rex:jorftext filename && page = None then
LawInclude (Ast.LegislativeText (filename, pos))
else if Filename.extension filename = ".pdf" || page <> None then
LawInclude (Ast.PdfFile ((filename, pos), page))
else
LawInclude (Ast.CatalaFile (filename, pos))
}
source_file:
| hd = source_file_item tl = source_file { hd:: tl }
| EOF { [] }

293
compiler/surface/parser_driver.ml Normal file
View File

@ -0,0 +1,293 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux
<denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Wrapping module around parser and lexer that offers the {!val: parse_source_file} API *)
open Sedlexing
open Utils
(** {1 Internal functions} *)
(** Three-way minimum *)
let minimum a b c = min a (min b c)
(** Computes the levenshtein distance between two strings, used to provide error messages
suggestions *)
let levenshtein_distance (s : string) (t : string) : int =
let m = String.length s and n = String.length t in
(* for all i and j, d.(i).(j) will hold the Levenshtein distance between the first i characters of
s and the first j characters of t *)
let d = Array.make_matrix (m + 1) (n + 1) 0 in
for i = 0 to m do
d.(i).(0) <- i (* the distance of any first string to an empty second string *)
done;
for j = 0 to n do
d.(0).(j) <- j (* the distance of any second string to an empty first string *)
done;
for j = 1 to n do
for i = 1 to m do
if s.[i - 1] = t.[j - 1] then d.(i).(j) <- d.(i - 1).(j - 1) (* no operation required *)
else
d.(i).(j) <-
minimum
(d.(i - 1).(j) + 1) (* a deletion *)
(d.(i).(j - 1) + 1) (* an insertion *)
(d.(i - 1).(j - 1) + 1) (* a substitution *)
done
done;
d.(m).(n)
(** After parsing, heading structure is completely flat because of the [source_file_item] rule. We
need to tree-i-fy the flat structure, by looking at the precedence of the law headings. *)
let rec law_struct_list_to_tree (f : Ast.law_structure list) : Ast.law_structure list =
match f with
| [] -> []
| [ item ] -> [ item ]
| first_item :: rest -> (
let rest_tree = law_struct_list_to_tree rest in
match rest_tree with
| [] -> assert false (* there should be at least one rest element *)
| rest_head :: rest_tail -> (
match first_item with
| CodeBlock _ | LawText _ | LawInclude _ ->
(* if an article or an include is just before a new heading , then we don't merge it
with what comes next *)
first_item :: rest_head :: rest_tail
| LawHeading (heading, _) ->
(* here we have encountered a heading, which is going to "gobble" everything in the
[rest_tree] until it finds a heading of at least the same precedence *)
let rec split_rest_tree (rest_tree : Ast.law_structure list) :
Ast.law_structure list * Ast.law_structure list =
match rest_tree with
| [] -> ([], [])
| LawHeading (new_heading, _) :: _
when new_heading.law_heading_precedence <= heading.law_heading_precedence ->
(* we stop gobbling *)
([], rest_tree)
| first :: after ->
(* we continue gobbling *)
let after_gobbled, after_out = split_rest_tree after in
(first :: after_gobbled, after_out)
in
let gobbled, rest_out = split_rest_tree rest_tree in
LawHeading (heading, gobbled) :: rest_out))
(** Style with which to display syntax hints in the terminal output *)
let syntax_hints_style = [ ANSITerminal.yellow ]
(** Usage: [raise_parser_error error_loc last_good_loc token msg]
Raises an error message featuring the [error_loc] position where the parser has failed, the
[token] on which the parser has failed, and the error message [msg]. If available, displays
[last_good_loc] the location of the last token correctly parsed. *)
let raise_parser_error (error_loc : Pos.t) (last_good_loc : Pos.t option) (token : string)
(msg : string) : 'a =
Errors.raise_multispanned_error
(Printf.sprintf "Syntax error at token %s\n%s"
(Cli.print_with_style syntax_hints_style "\"%s\"" token)
msg)
((Some "Error token:", error_loc)
::
(match last_good_loc with
| None -> []
| Some last_good_loc -> [ (Some "Last good token:", last_good_loc) ]))
module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct
include Parser.Make (LocalisedLexer)
module I = MenhirInterpreter
(** Returns the state number from the Menhir environment *)
let state (env : 'semantic_value I.env) : int =
match Lazy.force (I.stack env) with
| MenhirLib.General.Nil -> 0
| MenhirLib.General.Cons (Element (s, _, _, _), _) -> I.number s
(** Usage: [fail lexbuf env token_list last_input_needed]
Raises an error with meaningful hints about what the parsing error was. [lexbuf] is the lexing
buffer state at the failure point, [env] is the Menhir environment and [last_input_needed] is
the last checkpoint of a valid Menhir state before the parsing error. [token_list] is provided
by things like {!val: Surface.Lexer_common.token_list_language_agnostic} and is used to
provide suggestions of the tokens acceptable at the failure point *)
let fail (lexbuf : lexbuf) (env : 'semantic_value I.env)
(token_list : (string * Tokens.token) list) (last_input_needed : 'semantic_value I.env option)
: 'a =
let wrong_token = Utf8.lexeme lexbuf in
let acceptable_tokens, last_positions =
match last_input_needed with
| Some last_input_needed ->
( List.filter
(fun (_, t) ->
I.acceptable (I.input_needed last_input_needed) t (fst (lexing_positions lexbuf)))
token_list,
Some (I.positions last_input_needed) )
| None -> (token_list, None)
in
let similar_acceptable_tokens =
List.sort
(fun (x, _) (y, _) ->
let truncated_x =
if String.length wrong_token <= String.length x then
String.sub x 0 (String.length wrong_token)
else x
in
let truncated_y =
if String.length wrong_token <= String.length y then
String.sub y 0 (String.length wrong_token)
else y
in
let levx = levenshtein_distance truncated_x wrong_token in
let levy = levenshtein_distance truncated_y wrong_token in
if levx = levy then String.length x - String.length y else levx - levy)
acceptable_tokens
in
let similar_token_msg =
if List.length similar_acceptable_tokens = 0 then None
else
Some
(Printf.sprintf "did you mean %s?"
(String.concat ", or maybe "
(List.map
(fun (ts, _) -> Cli.print_with_style syntax_hints_style "\"%s\"" ts)
similar_acceptable_tokens)))
in
(* The parser has suspended itself because of a syntax error. Stop. *)
let custom_menhir_message =
match Parser_errors.message (state env) with
| exception Not_found ->
"Message: " ^ Cli.print_with_style syntax_hints_style "%s" "unexpected token"
| msg ->
"Message: "
^ Cli.print_with_style syntax_hints_style "%s"
(String.trim (String.uncapitalize_ascii msg))
in
let msg =
match similar_token_msg with
| None -> custom_menhir_message
| Some similar_token_msg ->
Printf.sprintf "%s\nAutosuggestion: %s" custom_menhir_message similar_token_msg
in
raise_parser_error
(Pos.from_lpos (lexing_positions lexbuf))
(Option.map Pos.from_lpos last_positions)
(Utf8.lexeme lexbuf) msg
(** Main parsing loop *)
let rec loop (next_token : unit -> Tokens.token * Lexing.position * Lexing.position)
(token_list : (string * Tokens.token) list) (lexbuf : lexbuf)
(last_input_needed : 'semantic_value I.env option) (checkpoint : 'semantic_value I.checkpoint)
: Ast.source_file =
match checkpoint with
| I.InputNeeded env ->
let token = next_token () in
let checkpoint = I.offer checkpoint token in
loop next_token token_list lexbuf (Some env) checkpoint
| I.Shifting _ | I.AboutToReduce _ ->
let checkpoint = I.resume checkpoint in
loop next_token token_list lexbuf last_input_needed checkpoint
| I.HandlingError env -> fail lexbuf env token_list last_input_needed
| I.Accepted v -> v
| I.Rejected ->
(* Cannot happen as we stop at syntax error immediatly *)
assert false
(** Stub that wraps the parsing main loop and handles the Menhir/Sedlex type difference for
[lexbuf]. *)
let sedlex_with_menhir (lexer' : lexbuf -> Tokens.token)
(token_list : (string * Tokens.token) list)
(target_rule : Lexing.position -> 'semantic_value I.checkpoint) (lexbuf : lexbuf) :
Ast.source_file =
let lexer : unit -> Tokens.token * Lexing.position * Lexing.position =
with_tokenizer lexer' lexbuf
in
try loop lexer token_list lexbuf None (target_rule (fst @@ Sedlexing.lexing_positions lexbuf))
with Sedlexing.MalFormed | Sedlexing.InvalidCodepoint _ ->
Lexer_common.raise_lexer_error (Pos.from_lpos (lexing_positions lexbuf)) (Utf8.lexeme lexbuf)
let commands_or_includes (lexbuf : lexbuf) : Ast.source_file =
sedlex_with_menhir LocalisedLexer.lexer LocalisedLexer.token_list Incremental.source_file lexbuf
end
module Parser_En = ParserAux (Lexer_en)
module Parser_Fr = ParserAux (Lexer_fr)
module Parser_Pl = ParserAux (Lexer_pl)
let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function
| En -> Parser_En.commands_or_includes
| Fr -> Parser_Fr.commands_or_includes
| Pl -> Parser_Pl.commands_or_includes
(** {1 Parsing multiple files} *)
(** Parses a single source file *)
let rec parse_source_file (source_file : Pos.input_file) (language : Cli.backend_lang) : Ast.program
=
Cli.debug_print
(Printf.sprintf "Parsing %s" (match source_file with FileName s | Contents s -> s));
let lexbuf, input =
match source_file with
| FileName source_file -> (
try
let input = open_in source_file in
(Sedlexing.Utf8.from_channel input, Some input)
with Sys_error msg -> Errors.raise_error msg)
| Contents contents -> (Sedlexing.Utf8.from_gen (Gen.of_string contents), None)
in
let source_file_name = match source_file with FileName s -> s | Contents _ -> "stdin" in
Sedlexing.set_filename lexbuf source_file_name;
Parse_utils.current_file := source_file_name;
let commands = localised_parser language lexbuf in
(match input with Some input -> close_in input | None -> ());
let program = expand_includes source_file_name commands language in
{
program_items = program.Ast.program_items;
program_source_files = source_file_name :: program.Ast.program_source_files;
}
(** Expands the include directives in a parsing result, thus parsing new source files *)
and expand_includes (source_file : string) (commands : Ast.law_structure list)
(language : Cli.backend_lang) : Ast.program =
List.fold_left
(fun acc command ->
match command with
| Ast.LawInclude (Ast.CatalaFile sub_source) ->
let source_dir = Filename.dirname source_file in
let sub_source = Filename.concat source_dir (Pos.unmark sub_source) in
let includ_program = parse_source_file (FileName sub_source) language in
{
Ast.program_source_files =
acc.Ast.program_source_files @ includ_program.program_source_files;
Ast.program_items = acc.Ast.program_items @ includ_program.program_items;
}
| Ast.LawHeading (heading, commands') ->
let { Ast.program_items = commands'; Ast.program_source_files = new_sources } =
expand_includes source_file commands' language
in
{
Ast.program_source_files = acc.Ast.program_source_files @ new_sources;
Ast.program_items = acc.Ast.program_items @ [ Ast.LawHeading (heading, commands') ];
}
| i -> { acc with Ast.program_items = acc.Ast.program_items @ [ i ] })
{ Ast.program_source_files = []; Ast.program_items = [] }
commands
(** {1 API} *)
let parse_top_level_file (source_file : Pos.input_file) (language : Cli.backend_lang) : Ast.program
=
let program = parse_source_file source_file language in
{ program with Ast.program_items = law_struct_list_to_tree program.Ast.program_items }

19
compiler/surface/parser_driver.mli Normal file
View File

@ -0,0 +1,19 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Wrapping module around parser and lexer that offers the {!val: parse_source_file} API *)
open Utils
val parse_top_level_file : Pos.input_file -> Cli.backend_lang -> Ast.program

Some files were not shown because too many files have changed in this diff Show More