CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #34 from CatalaLang/dev

Browse Source 
Ongoing Catala development
This commit is contained in:
Denis Merigoux 2020-12-21 16:22:16 +01:00 committed by GitHub
commit c87b7e958a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
155 changed files with 5176 additions and 2002 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -59,11 +59,6 @@ jobs:
eval $(opam env)
make tests
- name: Make examples
run: |
eval $(opam env)
make all_examples
- name: Make assets and documentation
run: |
eval $(opam env)

108
CONTRIBUTING.md
View File

@ -1,59 +1,34 @@
# Contributing to Catala
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.
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. 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 email the authors at denis.merigoux@inria.fr. The Catala team meets over visioconference once in a week.
To ask a question to the Catala team, please open an issue on this repository.
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 distributed under the Apache2 license.
## Writing Catala examples
### Setting up the machinery
This section describes what to do to setup a working directory for a new Catala example, as well as the development cycle. Let us suppose that you want to create a new example named `foo`.
First, follow the instructions of [the installation readme](INSTALL.md) to get the compiler up and working up to `make build`. You can also set up the syntax highlighting for your editor.
Then, create the directory `examples/foo`. In there, create a master source file `foo.catala` that will be the root of your Catala program. You can then start programming in `foo.catala`, or split up your example into multiple files. In the later case, `foo.catala` must only contain something like this:
```
@@Master file@@
@@Include: bar.catala@@
```
where `examples/bar.catala` is another source file containing code for your example. Make sure you start by including some content in the source files, like
```
Hello, world!
```
Now let's build the example, create a `Makefile` with the following contents:
```Makefile
CATALA_LANG=en # or fr if your source code is in French
SRC=foo.catala
include ../Makefile.common
```
The `include` creates automatically all the targets you will need for your example. For instance, after making sure the compiler is built, you can launch
```
make -C examples/foo foo.tex
```
from the repository root to create the LaTeX weaving output of your source program. `Hello, world!` should appear in there.
Finally, please add a rule for your example in the repository root `Makefile` in the section "Examples-related rules", following the pattern for other examples. This will ensure that
your example is built every time the compiler is modified; if a change in the compiler breaks your example, the authors will be notified and find a solution.
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
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 copy-paste the text into your source file.
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.
First you will have to format the copy-pasted text using Catala headings and articles markers:
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
copy-paste the text into your source file.
First you will have to format the copy-pasted text using Catala headings
and articles markers:
```
@@Heading@@
@ -63,14 +38,18 @@ First you will have to format the copy-pasted text using Catala headings and art
@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 using for instance
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 some Catala code. To open up a code section in Catala, simply use
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
```
/*
@ -80,22 +59,45 @@ scope Foo:
*/
```
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:
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
/*
declaration structure FooBar:
data foo content boolean
data bar content amount
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.
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
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 different modules' interfaces.
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.
## Internationalization
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.
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.

66
INSTALL.md
View File

@ -1,29 +1,26 @@
# Installing the Catala compiler
# Building and installing the Catala language
## Requirements
The Catala compiler is written using OCaml. To install OCaml on your machine and
if you're running Linux ou MacOS, open a terminal and enter :
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).
./install_opam.sh
This will install `opam`, the OCaml dependency manager and the
base OCaml compiler. If you're on Windows, the simplest solution
would be to use Cygwin or the Windows Subsystem for Linux. Catala has been tested
with OCaml version 4.09.1. You can switch to this version by typing :
opam switch create 4.09.1
or
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.,
just use:
opam switch 4.09.1
if this version of OCaml is already installed. Next, install all the build
dependencies with
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`.
Next, install all the OCaml packages that Catala depend on, as well as some
git submodules, with
make install-dependencies
This should ensure everything is set up for developping on the Catala compiler !
This should ensure everything is set up for developping on the Catala compiler!
Other features for generation of files and literate programming also require
the following executables to be present
@ -41,7 +38,7 @@ On ArchLinux :
sudo pacman -S python-virtualenv man2html rsync
## Installation
## Build
The project is distributed as a Dune artifact. Use standard dune commands to build
and install the library. Makefile aliases are here to help you: running
@ -50,12 +47,27 @@ and install the library. Makefile aliases are here to help you: running
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
opam install ./
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 from this repository's
root directory
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
Catala website.
./generate_website_assets.sh <path-to-catala-website>/assets
@ -63,19 +75,6 @@ You will need the `man2html` executable to generate the HTML versions of the man
pages, as well as the `rsync` executable to transfer files (preferred to `cp`)
because it also works with a remote server.
### Opam package
If you want to install the library as an opam
package, use the following command at the root of the repository:
opam install ./
You can then use the compiler with the `catala` command.
## Usage
Use `catala --help` to get more information about the command line options available.
## Syntax highlighting
The Catala language also comes with syntax highlighting to
@ -119,7 +118,8 @@ augmented with the Catala plugin, simply enter
make pygments
This will execute the
script `syntax_highlighting/fr/pygments/set_up_pygments.sh` and `syntax_highlighting/en/pygments/set_up_pygments.sh`.
script `syntax_highlighting/fr/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

58
Makefile
View File

@ -18,11 +18,14 @@ install-dependencies-ocaml:
menhirLib \
dune dune-build-info \
cmdliner obelisk \
re reason \
re \
obelisk \
unionfind \
bindlib \
ocamlgraph
zarith \
ocamlgraph \
js_of_ocaml-compiler \
odate
init-submodules:
git submodule update --init
@ -42,10 +45,11 @@ build:
$(MAKE) format
dune build
doc: build
doc:
dune build @doc
ln -sf $(PWD)/_build/default/_doc/_html/index.html doc/odoc.html
install: build
install:
dune build @install
##########################################
@ -107,23 +111,24 @@ CODE_GENERAL_IMPOTS_DIR=$(EXAMPLES_DIR)/code_general_impots
US_TAX_CODE_DIR=$(EXAMPLES_DIR)/us_tax_code
TUTORIAL_DIR=$(EXAMPLES_DIR)/tutorial
allocations_familiales: pygments build
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) $@.tex
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) $@.html
literate_allocations_familiales: pygments build
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.tex
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.html
code_general_impots: pygments build
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) $@.tex
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) $@.html
literate_code_general_impots: pygments build
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) code_general_impots.tex
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) code_general_impots.html
us_tax_code: pygments build
$(MAKE) -C $(US_TAX_CODE_DIR) $@.tex
$(MAKE) -C $(US_TAX_CODE_DIR) $@.html
literate_us_tax_code: pygments build
$(MAKE) -C $(US_TAX_CODE_DIR) us_tax_code.tex
$(MAKE) -C $(US_TAX_CODE_DIR) us_tax_code.html
tutorial_en: pygments build
$(MAKE) -C $(TUTORIAL_DIR) $@.tex
$(MAKE) -C $(TUTORIAL_DIR) $@.html
literate_tutorial_en: pygments build
$(MAKE) -C $(TUTORIAL_DIR) tutorial_en.tex
$(MAKE) -C $(TUTORIAL_DIR) tutorial_en.html
all_examples: allocations_familiales code_general_impots us_tax_code tutorial_en
literate_examples: literate_allocations_familiales literate_code_general_impots \
literate_us_tax_code literate_tutorial_en
##########################################
# Execute test suite
@ -131,8 +136,13 @@ all_examples: allocations_familiales code_general_impots us_tax_code tutorial_en
.FORCE:
tests: build .FORCE
$(MAKE) -C tests
test_suite: .FORCE
@$(MAKE) --no-print-directory -C tests pass_tests
test_examples: .FORCE
@$(MAKE) --no-print-directory -C examples tests
tests: test_suite test_examples
##########################################
# Website assets
@ -145,13 +155,13 @@ catala.html: src/catala/utils/cli.ml
dune exec src/catala.exe -- --help=groff | man2html | sed -e '1,8d' \
| tac | sed "1,20d" | tac > $@
website-assets: doc all_examples grammar.html catala.html
website-assets: doc literate_examples grammar.html catala.html
##########################################
# Misceallenous
##########################################
all: install-dependencies build doc tests all_examples website-assets
all: install-dependencies build doc tests literate_examples website-assets
clean:
dune clean
@ -166,6 +176,6 @@ inspect:
##########################################
# Special targets
##########################################
.PHONY: inspect clean all all_examples english allocations_familiales pygments \
install build format install-dependencies install-dependencies-ocaml \
catala.html
.PHONY: inspect clean all literate_examples english allocations_familiales pygments \
install build doc format install-dependencies install-dependencies-ocaml \
catala.html

116
README.md
View File

@ -1,27 +1,30 @@
<center>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/logo.png" alt="Catala logo" width="100"/>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/images/logo.png" alt="Catala logo" width="100"/>
</center>
# Catala
Catala is a domain-specific language for deriving
faithful-by-construction algorithms from legislative texts.
faithful-by-construction algorithms from legislative texts. To learn quickly
about the language and its features, you can jump right to the official
[Catala tutorial](https://catala-lang.org/en/examples/tutorial).
## 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 faithfulness.
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
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 article, in your favorite
text editor :
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/ScreenShotVSCode.png" alt="Screenshot" height="500"/>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/images/ScreenShotVSCode.png" alt="Screenshot" height="500"/>
</center>
Once your code is complete and tested, you can use the Catala
@ -32,72 +35,63 @@ 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/CatalaScreenShot.png" alt="Screenshot" height="500"/>
<img src="https://github.com/CatalaLang/catala/raw/master/doc/images/CatalaScreenShot.png" alt="Screenshot" height="500"/>
</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 language
perfectly adapted to literate legislative programming.
"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
language perfectly adapted to literate legislative programming.
## Catala motivating example : French "allocations familiales"
In the `example/allocations_familiales` folder, you will find the
`allocations_familiales.catala` file which contains the
algorithm computing French family benefits. The algorithm consists of annotations to the legislative
texts that define the family benetifs, using the literate programming paradigm. The Catala
compiler can extract from the `.catala` file a lawyer-readable version of the annotated text.
Currently, this lawyer-readable version comes in the form of a LaTeX document.
You will need to have a standard LaTeX distribution installed as well as the
`latexmk` build tool in order to enjoy the automated document generation process.
To get that lawyer-readable version (which is a LaTeX-created) PDF, simply use
make -C allocations_familiales allocations_familiales.pdf
from the repository root, once you have managed to install the
compiler using [the dedicated readme](INSTALL.md). You can then open `examples/allocations_familiales/allocations_familiales.pdf`
## Languages
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 lefislative text.
Currently, Catala supports English and French legislations via the `--language=en` or `--language=fr` option. Contact the authors
if you are interested in adding support for another language.
## Limitations and disclaimer
### Early stage project
Catala is a research project from Inria, the French National
Research Institute for Computer Science. The compiler is yet very
unstable and lacks most of its features. Currently, it only
parses the surface language to producde the lawyer-readable PDF,
no interpreter or compiler backend is provided.
However, the language is bound to have a complete formal semantics
in the near future. This semantics will guide the compiler
implementation.
## Installation
## Building and installation
See [the dedicated readme](INSTALL.md).
## Test suite
## Usage
See [the dedicated readme](tests/README.md).
Use `catala --help` to get more information about the command line
options available.
## Examples
See [the dedicated readme](examples/README.md).
## Contributing
See [the dedicated readme](CONTRIBUTING.md).
## Test suite
See [the dedicated readme](tests/README.md).
## Documentation
### Formal semantics
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
make doc
to generate the documentation, then open the `doc/odoc.html` file in any browser.
## License
The library is released under the Apache license (version 2).
The library is released under the [Apache license (version 2)](LICENSE.txt).
## 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.
## Pierre Catala

8
catala.opam
View File

@ -1,12 +1,12 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "0.1.1"
version: "0.2.0"
synopsis: "Low-level 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.
"""
maintainer: ["denis.merigoux@inria.fr"]
maintainer: ["contact@catala-lang.org"]
authors: ["Denis Merigoux"]
license: "Apache2"
homepage: "https://github.com/CatalaLang/catala"
@ -17,11 +17,15 @@ depends: [
"sedlex" {>= "2.1"}
"menhir" {>= "20200211"}
"menhirLib" {>= "20200211"}
"unionfind" {>= "20200320"}
"bindlib" {>= "5.0.1"}
"dune-build-info" {>= "2.0.1"}
"cmdliner" {>= "1.0.4"}
"re" {>= "1.9.0"}
"zarith" {>= "1.10"}
"dune" {build}
"ocamlgraph" {>= "1.8.8"}
"odate" {>= "0.6"}
]
build: [
["dune" "subst"] {pinned}

10
doc/formalization/README.md Normal file
View File

@ -0,0 +1,10 @@
# The Catala formalization
This folder contains the LaTeX sources of the document describing the
formalization the Catala programming language. To build the PDF output,
simply invoke:
make formalization
The directory also contains the F* sources of the proof of type soundness
of this formalization.

BIN
doc/formalization/formalization.pdf Normal file
View File

Binary file not shown.

225
doc/formalization/formalization.tex
View File

@ -175,7 +175,7 @@ lambda-calculus extensions (such as algebraic data types or $\Lambda$-polymorphi
&&\synalt&\synlambda\synlparen\synvar{x}\syntyped\synvar{\tau}\synrparen\syndot\synvar{e}\synalt\synvar{e}\;\synvar{e}&$\lambda$-calculus\\
&&\synalt&\synvar{d}&default term\\
&&&&\\
Default&\synvar{d}&\syndef&\synlangle\synvar{e}\synjust\synvar{e}\synmid $[\synvar{e}^*]$\synrangle&default term\\
Default&\synvar{d}&\syndef&\synlangle $[\synvar{e}^*] \synmid\synvar{e}\synjust\synvar{e}$\synrangle&default term\\
&&\synalt&\synerror&conflict error term\\
&&\synalt&\synemptydefault&empty error term\\
\end{tabular}
@ -183,7 +183,8 @@ lambda-calculus extensions (such as algebraic data types or $\Lambda$-polymorphi
Compared to the regular lambda calculus, we add a construction coming from
default logic. Particularly, we focus on a subset of default logic called
categorical, prioritized default logic \cite{Brewka2000}. In this setting, a default is a logical
categorical, prioritized default logic \cite{Brewka2000}.
In this setting, a default is a logical
rule of the form $A \synjust B$ where $A$ is the justification of the rule and
$B$ is the consequence. The rule can only be applied if $A$ is consistent with
the current knowledge $W$: from $A\wedge W$, one should not derive $\bot$.
@ -196,19 +197,18 @@ be an expression that can be evaluated to \syntrue{} or \synfalse{}, and $B$
the expression that the default should reduce to if $A$ is true. If $A$ is false,
then we look up for other rules of lesser priority to apply. This priority
is encoded trough a syntactic tree data structure\footnote{Thanks to Pierre-Évariste Dagand for this insight.}.
A node of the tree contains a default to consider first, and then a list of lower-priority
defaults that don't have a particular ordering between them. This structure is
A node of the tree contains a base case to consider, but first a list of higher-priority
exceptions that don't have a particular ordering between them. This structure is
sufficient to model the base case/exceptions structure or the law, and in particular
the fact that exceptions are not always prioritized in the legislative text.
In the term \synlangle\synvar{e_{\text{just}}}\synjust
\synvar{e_{\text{cons}}}\synmid \synvar{e_1}\synellipsis\synvar{e_n}\synrangle, \synvar{e_{\text{just}}}
In the term \synlangle\synvar{e_1}\synellipsis\synvar{e_n}\synmid\synvar{e_{\text{just}}}\synjust
\synvar{e_{\text{cons}}} \synrangle, \synvar{e_{\text{just}}}
is the justification $A$, \synvar{e_{\text{cons}}} is the consequence $B$ and
\synvar{e_1}\synellipsis\synvar{e_n} is the list of rules to be considered if \synvar{e_{\text{just}}}
evaluates to \synfalse{}.
\synvar{e_1}\synellipsis\synvar{e_n} are the list of exceptions to be considered first.
Of course, this evaluation scheme can fail if no more
rules can be applied, or if two or more rules of the same priority have their
rules can be applied, or if two or more exceptions of the same priority have their
justification evaluate to \syntrue{}. The error terms \synerror{} and \synemptydefault{}
encode these failure cases. Note that if a Catala program correctly derived from a legislative
source evaluates to \synerror{} or \synemptydefault{}, this could mean a flaw in the
@ -275,14 +275,15 @@ of the default should be typed.
\begin{mathpar}
\inferrule[T-Default]
{
\typctx{\Gamma}\typvdash\synvar{e_{\text{just}}}\typcolon\synbool\\
\typctx{\Gamma}\typvdash\synvar{e_{\text{cons}}}\typcolon\synvar{\tau}\\
\typctx{\Gamma}\typvdash\synvar{e_1}\typcolon{\tau}\\
\cdots\\
\typctx{\Gamma}\typvdash\synvar{e_n}\typcolon{\tau}
\typctx{\Gamma}\typvdash\synvar{e_n}\typcolon{\tau}\\
\typctx{\Gamma}\typvdash\synvar{e_{\text{just}}}\typcolon\synbool\\
\typctx{\Gamma}\typvdash\synvar{e_{\text{cons}}}\typcolon\synvar{\tau}
}
{\typctx{\Gamma}\typvdash\synlangle\synvar{e_{\text{just}}}\synjust\synvar{e_{\text{cons}}}\synmid
\synvar{e_1}\synellipsis\synvar{e_n}\synrangle\typcolon\synvar{\tau}}
{\typctx{\Gamma}\typvdash\synlangle
\synvar{e_1}\synellipsis\synvar{e_n}\synmid
\synvar{e_{\text{just}}}\synjust\synvar{e_{\text{cons}}}\synrangle\typcolon\synvar{\tau}}
\end{mathpar}
The situation becomes more complex in the presence of functions. Indeed, want
@ -307,11 +308,11 @@ currently being reduced.
&&\synalt&\syntrue\synalt\synfalse & booleans\\
&&\synalt&\synerror\synalt\synemptydefault&errors\\
Evaluation &\synvar{C_\lambda}&\syndef&\synhole\;\synvar{e}\synalt\synvar{v}\;\synhole&function application\\
contexts&&\synalt&\synlangle\synhole\synjust\synvar{e}\synmid $[\synvar{e}^*]$\synrangle&default justification evaluation\\
contexts&&\synalt&\synlangle$[\synvar{v}^*]$\syncomma\synhole\syncomma$[\synvar{e}^*]$\synmid
\synvar{e}\synjust\synvar{e}\synrangle&default exceptions evaluation\\
&\synvar{C}&\syndef&\synvar{C_\lambda}&regular contexts\\
&&\synalt&\synlangle\syntrue\synjust\synhole\synmid $[\synvar{e}^*]$\synrangle&default consequence evaluation\\
&&\synalt&\synlangle\synfalse\synjust\synvar{e}\synmid $[\synvar{v}^*]$%
\syncomma\synhole\syncomma$[\synvar{e}^*]$\synrangle&sub-default evaluation
&&\synalt&\synlangle$[\synvar{v}^*]$\synmid\synhole\synjust\synvar{e}\synrangle&default justification evaluation\\
&&\synalt&\synlangle$[\synvar{v}^*]$\synmid\syntrue\synjust\synhole \synrangle&default consequence evaluation\\
\end{tabular}
\end{center}
@ -331,70 +332,55 @@ later.
}
\end{mathpar}
Now we have to describe how the default terms reduce. Thanks to a the
\TirName{D-Context} rule, we can suppose that the justification of the default
is already reduced to a variable \synvar{v}. By applying the beta-reduction
rule \TirName{D-$\beta$}, we can further reduce to the case where \synvar{v} is a boolean.
This is where we encode our default logic evaluation semantics. If \synvar{v} is
\syntrue{}, then this rule applies and we reduce to the consequence. We don't
even have to consider rules of lower priority lower in the tree. This behavior
is similar to short-circuit reduction rules of boolean operators, that enable
a significant performance gain at execution.
\begin{mathpar}
\inferrule[D-DefaultTrueNoError]
{v\neq\synemptydefault}
{\synlangle \syntrue\synjust \synvar{v}\synmid \synvar{e_1}\synellipsis\synvar{e_n}\synrangle\exeval v}
\end{mathpar}
However, if the consequence of the first default evaluates to \synemptydefault,
then we fall back on the rules of lower priority, as if the justification had
evaluated to \synfalse. This behavior is useful when the consequence of the
first default is itself a \enquote{high-priority} default tree. In this case,
\synvar{e_1}\synellipsis\synvar{e_n} acts a the \enquote{low-priority} default
tree. The chaining
behavior from the high-priority tree to the low-priority tree
defined by \TirName{D-DefaultTrueError}, will be very useful in
\sref{scope:formalization}.
\begin{mathpar}
\inferrule[D-DefaultTrueError]
{}
{
\synlangle \syntrue\synjust \synemptydefault\synmid \synvar{e_1}\synellipsis\synvar{e_n}\synrangle\exeval
\synlangle \synfalse\synjust \synemptydefault\synmid \synvar{e_1}\synellipsis\synvar{e_n} \synrangle
}
\end{mathpar}
If the consequence of the default is \synfalse{}, then we have to consider rules of lower priority
\synvar{e_1}\synellipsis\synvar{e_n} that should be all evaluated (left to right),
Now we have to describe how the default terms reduce. First, we consider
the list of exceptions to the default,
\synvar{e_1}\synellipsis\synvar{e_n}, that should be all evaluated (left to right),
according to the sub-default evaluation context. Then, we consider all the
values yielded by the sub-default evaluation and define two functions over these
values yielded by the exception evaluation and define two functions over these
values. Let $\exeemptysubdefaults(\synvar{v_1}\synellipsis\synvar{v_n})$ returns
the number of empty error terms \synemptydefault{} among the values. We then case analyze on this count:
the number of empty error terms \synemptydefault{} among the exception values.
We then case analyze on this count:
\begin{itemize}
\item if $\exeemptysubdefaults(\synvar{v_1}\synellipsis\synvar{v_n}) =n$, then
none of the sub-defaults apply and we return \synemptydefault;
none of the exceptions apply and we evaluate the base case;
\item if $\exeemptysubdefaults(\synvar{v_1}\synellipsis\synvar{v_n}) =n - 1$,
then only only one of the sub-default apply and we return its corresponding value;
then only only one of the exceptions apply and we return its corresponding value;
\item if $\exeemptysubdefaults(\synvar{v_1}\synellipsis\synvar{v_n}) < n - 1$,
then two or more sub-default apply and we raise a conflict error \synerror.
then two or more exceptions apply and we raise a conflict error \synerror.
\end{itemize}
\begin{mathpar}
\inferrule[D-DefaultFalseNoSub]
\inferrule[D-DefaultFalseNoExceptions]
{}
{\synlangle \synfalse\synjust \synvar{e}\synmid \synemptydefault{}\synellipsis\synemptydefault{}\synrangle\exeval \synemptydefault{}}
{\synlangle \synemptydefault{}\synellipsis\synemptydefault{}\synmid\synfalse\synjust \synvar{e} \synrangle\exeval \synemptydefault{}}
\inferrule[D-DefaultFalseOneSub]
\inferrule[D-DefaultTrueNoExceptions]
{}
{\synlangle \synfalse\synjust \synvar{e}\synmid
\synemptydefault\synellipsis\synemptydefault\syncomma\synvar{v}\syncomma\synemptydefault\synellipsis\synemptydefault\synrangle\exeval \synvar{v}}
{\synlangle \synvar{e_1}\synellipsis\synvar{e_n}\synmid\syntrue\synjust \synvar{v}\synrangle\exeval v}
\inferrule[D-DefaultFalseSubConflict]
\inferrule[D-DefaultOneException]
{}
{\synlangle \synemptydefault\synellipsis\synemptydefault\syncomma\synvar{v}\syncomma\synemptydefault\synellipsis\synemptydefault
\synmid \synvar{e_1}\synjust \synvar{e_2}
\synrangle\exeval \synvar{v}}
\inferrule[D-DefaultExceptionsConflict]
{\exeemptysubdefaults(\synvar{v_1}\synellipsis\synvar{v_n}) <n - 1}
{\synlangle \synfalse\synjust \synvar{e}\synmid \synvar{v_1}\synellipsis\synvar{v_n}\synrangle\exeval \synerror{}}
{\synlangle \synvar{v_1}\synellipsis\synvar{v_n}\synmid
\synvar{e_1}\synjust \synvar{e_2}\synrangle\exeval \synerror{}}
\end{mathpar}
When none of the exceptions apply, we can suppose that the justification of the default
is already reduced to a variable \synvar{v}, which should be a boolean by virtue of
typing. If \synvar{v} is
\syntrue{}, then this rule applies and we reduce to the consequence. If it is
\synfalse{}, then the base case does not apply either and we throw an empty
default error.
Last, we need to define how our error terms propagate. Because the rules for
sub-default evaluation have to count the number of error terms in the list
of sub-defaults, we cannot always immediately propagate the error term \synemptydefault{} in
@ -468,8 +454,9 @@ sub-call and give them different names $\synvar{S'}_1$,
Expression&\synvar{e}&\syndef&\synvar{\ell}&location\\
&&\synalt&$\cdots$&default calculus expressions\\
&&&&\\
Rule&\synvar{r}&\syndef&\synrule\synvar{\ell}\syntyped\synvar{\tau}\synequal\synlangle\synvar{e}\synjust
\synvar{e}\synmid$[\synvar{e}^*]$\synrangle
Rule&\synvar{r}&\syndef&\synrule\synvar{\ell}\syntyped\synvar{\tau}\synequal\synlangle
$[\synvar{e}^*]$\synmid\synvar{e}\synjust
\synvar{e}\synrangle
&Location definition\\
&&\synalt&\syncall$\synvar{S}_\synvar{n}$&sub-scope call\\
Scope declaration&\synvar{\sigma}&\syndef&\synscope\synvar{S}\syntyped $[\synvar{r}^*]$&\\
@ -484,13 +471,13 @@ Let's illustrate how the scope language plays out with a simple program
that calls a sub-scope:
\begin{Verbatim}[frame=lines,label=Simple scope program, numbers=left, framesep=10pt, samepage=true]
scope X:
rule a = < true :- 0 | >
rule b = < true :- a + 1 | >
rule a = < true :- 0 >
rule b = < true :- a + 1 >
scope Y:
rule X_1[a] = < true :- 42 | >
rule X_1[a] = < true :- 42 >
call X_1
rule c = < X_1[b] == 1 :- false | >, < X_1[b] == 43 :- true | >
rule c = < X_1[b] != 43 :- false | X_1[b] == 43 :- true >
\end{Verbatim}
Considered alone, the execution \Verb+X+ is simple: \Verb+a+ and \Verb+b+ are defined by
@ -498,7 +485,7 @@ a single default whose justification is \Verb+true+. Hence, \Verb+a+ should eval
to \Verb+0+ and \Verb+b+ should evaluate to \Verb+1+.
Now, consider scope \Verb+Y+. It defines a single variable \Verb+c+ with two defaults
lines 8 and 9, but the justifications for these two defaults use the result of
line 8, but the justifications for these two defaults use the result of
the evaluation (line 7) of variable \Verb+b+ of the sub-scope \Verb+X_1+.
Line 6 shows an example of providing an \enquote{argument} to the subscope call.
The execution goes like this: at line 7 when calling the sub-scope,
@ -506,7 +493,9 @@ The execution goes like this: at line 7 when calling the sub-scope,
from line 6. Because the caller has priority over the callee, the default from line
6 wins and \Verb+X_1[a]+ evaluates to \Verb+42+. Consequently,
\Verb+X_1[b]+ evaluates to \Verb+43+.
This triggers the second default in the list of line 9 which evaluates \Verb+c+ to \Verb+true+.
This triggers the second default in the list of line 8: the exception
evaluates first, but does not apply. Then, the base case applies,
and evaluates \Verb+c+ to \Verb+true+.
The goal is to provide an encoding of the scope language
into the lambda calculus that is compatible with this intuitive description
@ -515,44 +504,39 @@ picture of the translation, we first show what the previous simple program will
to, using ML-like syntax for the target default calculus:
\begin{Verbatim}[frame=lines,label=Simple default program, numbers=left, framesep=10pt, samepage=true]
let X (a: unit -> int) (b: unit -> int) : (int * int) =
let a : unit -> int = a ++ (fun () -> < true :- 0 | >) in
let a : int = a () in
let b : unit -> int = b ++ (fun () -> < true :- a + 1 | >) in
let b : int = b () in
let a : int = < a () | < true :- 0 >> in
let b : int = < b () | < true :- a + 1 >> in
(a, b)
let Y (c: unit -> bool) : bool =
let X_1[a] : unit -> int = fun () -> < true :- 42 | > in
let X_1[a] : unit -> int = fun () -> < true :- 42 > in
let X_1[b] : unit -> int = fun () -> EmptyError in
let (X_1[a], X_1[b]) : int * int = X(X_1[a], X_1[b]) in
let c : unit -> bool = c ++ (fun () ->
< X_1[b] == 1 :- false>, < X_1[b] == 43 :- true >)
in
let c : bool = c () in
let c : bool = < c () | < X_1[b] != 43 :- false | X_1[b] == 43 :- true >> in
c
\end{Verbatim}
We start unravelling this translation with the scope \Verb+X+. \Verb+X+ has
been turned into a function whose arguments are all the local variables of the
scope. However, the arguments have type \Verb+unit -> <type>+. Indeed, we want the
arguments of \Verb+X+ (line 1 ) to be the default expression supplied by the caller of
\Verb+X+, which will later be merged with a higher priority (operator \Verb|++|) to the default
expression defining the local variables of \Verb+X+ (lines 2 and 4). But since defaults are not
values in our default calculus, we have to thunk them in the arguments of \Verb|X|
so that their evaluation is delayed. After the defaults have been merged, we apply
\Verb+()+ to the thunk (lines 3 and 5) to force evaluation and get back the value.
Finally, \Verb+X+ returns the tuple of all its local variables (line 6).
arguments of \Verb+X+ (line 1) to be the default expression supplied by the caller of
\Verb+X+, which are considered as exceptions to the base
expression defining the local variables of \Verb+X+ (lines 2 and 3).
After the merging of scope-local and
scope-arguments defaults, we apply
\Verb+()+ to the thunk to force evaluation and get back the value.
Finally, \Verb+X+ returns the tuple of all its local variables (line 4).
The translation of \Verb+Y+ exhibits the pattern for sub-scope calls.
Lines 9 translates the assignment of the sub-scope argument \Verb+X_1[a]+.
Before calling \Verb+X_1+ (line 11), the other argument \Verb+X_1[b]+ is
Lines 7 translates the assignment of the sub-scope argument \Verb+X_1[a]+.
Before calling \Verb+X_1+ (line 8), the other argument \Verb+X_1[b]+ is
initialized to the neutral \synemptydefault{} that will be ignored at execution
because \Verb+X+ provides more defaults for \Verb+b+.
The sub-scope call is translated to a regular
function call (line 11). The results of the call are then used in the two defaults
for \Verb+c+ (lines 13), which have been turned into a default tree taking into
account that no priority has been declared between the two defaults.
Finally, \Verb+c+ is evaluated (line 15).
function call (line 9). The results of the call are then used in the two defaults
for \Verb+c+ (line 10), which have been turned into a default tree taking into
account the possible input for \Verb+c+.
\subsection{Formalization of the translation}
\label{sec:scope:formalization}
@ -639,17 +623,21 @@ with the definitions of scope variables.
\begin{mathpar}
\inferrule[T-DefScopeVar]{
\synvar{a}\notin\redctx{\Delta}\\
\redctx{\Delta}\typvdash\synlangle\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synmid\synvar{e_1}\synellipsis\synvar{e_n}\synrangle\typcolon\synvar{\tau}
\redctx{\Delta}\typvdash
\synlangle\synvar{e_1}\synellipsis\synvar{e_n}\synmid
\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synrangle\typcolon\synvar{\tau}
}{
\synvar{P}\redsc\redctx{\Delta}\redturnstile{\synvar{S}}
\synrule\synvar{a}\syntyped\synvar{\tau}\synequal
\synlangle\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synmid\synvar{e_1}\synellipsis\synvar{e_n}\synrangle
\synlangle\synvar{e_1}\synellipsis\synvar{e_n}\synmid
\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synrangle
\reduces \\
\synlet a\syntyped\synvar{\tau}\synequal \synlparen\synvar{a} \synmerge
\synlambda \synlparen \synunit\syntyped\synunitt\synrparen\syndot
\synlangle\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synmid\synvar{e_1}\synellipsis\synvar{e_n}\synrangle
\synrparen\;\synunit\synin\synhole
\redproduce\synvar{a}\redcolon\synvar{\tau}\redcomma\redctx{\Delta}
\synlet a\syntyped\synvar{\tau}\synequal
\synlangle a\;\synunit\synmid
\synlangle\synvar{e_1}\synellipsis\synvar{e_n}\synmid
\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synrangle
\synrangle\synin\synhole
\redproduce\synvar{a}\redcolon\synvar{\tau}\redcomma\redctx{\Delta}
}
\end{mathpar}
@ -672,26 +660,12 @@ which seeds the typing judgment of \sref{defaultcalc:typing} with \redctx{\Delta
Since scope variables are also arguments of the scope, \TirName{T-DefScopeVar}
redefines \synvar{a} by merging the new default tree with the default expression
\synvar{a} of type \synunitt\synarrow\synvar{\tau} passed as an argument to \synvar{S}.
The merging operator,\synmerge, has the following definition :
\begin{align*}
\synlet \synlparen\synmerge\synrparen\;&
\synlparen\synvar{e_1}\syntyped\synunitt\synarrow\synvar{\tau}\synrparen\;
\synlparen\synvar{e_2}\syntyped\synunitt\synarrow\synvar{\tau}\synrparen\syntyped
\synunitt\synarrow\synvar{\tau}
\synequal\\
&\synlangle\synlambda\synlparen\synunit\syntyped\synunitt\synrparen\syndot\syntrue\synjust
\synvar{e_1}\synmid\synvar{e_2}\synrangle
\end{align*}
This merging is done by defining the incoming argument as an exception to the
scope-local expression. This translation scheme ensures that the caller always
has priority over the callee. The evaluation of the incoming arguments is forced by applying \synunit,
yielding a value of type \synvar{\tau} for \synvar{a}.
\synmerge is asymetric in terms of priority: in \synvar{e_1}\synmerge\synvar{e_2},
\synvar{e_1} will have the highest priority and it is only in the case where
none of the rules in \synvar{e_1} apply that \synvar{e_2} will be considered.
In \TirName{T-DefScopeVar}, the left-hand-side of \synmerge is coherent with
our objective of giving priority to the caller.
Finally, the evaluation of the merged default tree is forced by applying \synunit,
yielding a value of type \synvar{\tau} for \synvar{a} which will be available
for use in the rest of the translated program. Now that we have presented the
ow that we have presented the
translation scheme for rules defining scope variables, we can switch to the
translation of sub-scope variables definitions and calls. We will start by
the rules that define sub-scope variables, prior to calling the associated
@ -700,16 +674,19 @@ sub-scope.
\inferrule[T-DefSubScopeVar]{
S\neq S'\\
\synvar{S'}_\synvar{n}\synlsquare\synvar{a}\synrsquare\notin\redctx{\Delta}\\
\redctx{\Delta}\typvdash\synlangle\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synmid\synvar{e_1}\synellipsis\synvar{e_n}\synrangle
\redctx{\Delta}\typvdash\synlangle\synvar{e_1}\synellipsis\synvar{e_n}\synmid
\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synrangle
\typcolon\synvar{\tau}
}{
\synvar{P}\redsc\redctx{\Delta}\redturnstile{\synvar{S}}
\synrule\synvar{S'}_\synvar{n}\synlsquare\synvar{a}\synrsquare\syntyped\synvar{\tau}\synequal
\synlangle\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synmid\synvar{e_1}\synellipsis\synvar{e_n}\synrangle
\synlangle\synvar{e_1}\synellipsis\synvar{e_n}\synmid
\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synrangle
\reduces \\
\synlet \synvar{S'}_\synvar{n}\synlsquare\synvar{a}\synrsquare\syntyped\synunitt\synarrow\synvar{\tau}\synequal
\synlambda \synlparen\synunit\syntyped\synunitt\synrparen\syndot
\synlangle\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synmid\synvar{e_1}\synellipsis\synvar{e_n}\synrangle
\synlangle\synvar{e_1}\synellipsis\synvar{e_n}\synmid
\synvar{e_\mathrm{just}}\synjust\synvar{e_\mathrm{cons}}\synrangle
\synin\synhole\redproduce\\\synvar{S'}_\synvar{n}\synlsquare\synvar{a}\synrsquare\redcolon\synunitt\synarrow\synvar{\tau}\redcomma\redctx{\Delta}
}
\end{mathpar}

0
doc/CatalaScreenShot.png → doc/images/CatalaScreenShot.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 167 KiB

After

Width:  |  Height:  |  Size: 167 KiB

0
doc/ScreenShotVSCode.png → doc/images/ScreenShotVSCode.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 128 KiB

After

Width:  |  Height:  |  Size: 128 KiB

0
doc/logo.png → doc/images/logo.png
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 6.5 KiB

After

Width:  |  Height:  |  Size: 6.5 KiB

0
doc/logo.svg → doc/images/logo.svg
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 11 KiB

After

Width:  |  Height:  |  Size: 11 KiB

2
doc/enlish_token_list.md → doc/out_of_date/enlish_token_list.md
View File

@ -157,7 +157,7 @@ Current proposal : "amount".
The base data type for representing amounts of money.
```
data foo content amount
data foo content money
```
## TEXT

0
doc/motivation.tex → doc/out_of_date/motivation.tex
View File

0
doc/questionnaire.tex → doc/out_of_date/questionnaire.tex
View File

0
doc/questionnaire_for_lawyers.tex → doc/out_of_date/questionnaire_for_lawyers.tex
View File

0
doc/reading_guide.tex → doc/out_of_date/reading_guide.tex
View File

9
dune-project
View File

@ -1,6 +1,6 @@
(lang dune 2.2)
(name catala)
(version 0.1.1)
(version 0.2.0)
(generate_opam_files true)
(formatting)
@ -8,7 +8,7 @@
(homepage https://github.com/CatalaLang/catala)
(bug_reports https://github.com/CatalaLang/catala/issues)
(authors "Denis Merigoux")
(maintainers "denis.merigoux@inria.fr")
(maintainers "contact@catala-lang.org")
(license Apache2)
@ -24,13 +24,16 @@
(sedlex (>= 2.1))
(menhir (>= 20200211))
(menhirLib (>= 20200211))
(unionfind (>= 20200320))
(bindlib (>= 5.0.1))
(dune-build-info (>= 2.0.1))
(cmdliner (>= 1.0.4))
(re (>= 1.9.0))
(zarith (>= 1.10))
(dune (and :build ))
(ocamlgraph (>= 1.8.8))
(odate (>= 0.6))
)
)
(using menhir 2.1)

49
examples/Makefile Normal file
View File

@ -0,0 +1,49 @@
BLACK := $(shell tput -Txterm setaf 0)
RED := $(shell tput -Txterm setaf 1)
GREEN := $(shell tput -Txterm setaf 2)
YELLOW := $(shell tput -Txterm setaf 3)
LIGHTPURPLE := $(shell tput -Txterm setaf 4)
PURPLE := $(shell tput -Txterm setaf 5)
BLUE := $(shell tput -Txterm setaf 6)
WHITE := $(shell tput -Txterm setaf 7)
RESET := $(shell tput -Txterm sgr0)
################################
# Running legislation unit tests
################################
# Usage `make <name_of_example_folder>.<name_of_test_file>.<name_of_test_scope>`
# This Makefile rule assumes the following directory structure:
# foo_example
# tests/
# foo_test_file1.catala
# foo_test_file2.catala
# ...
# foo_implem.catala
# ...
%.run: .FORCE
@SCOPE="$(word 3,$(subst ., ,$*))" $(MAKE) --no-print-directory -C \
$(word 1,$(subst ., ,$*)) tests/$(word 2,$(subst ., ,$*)).run \
> /dev/null || { echo "[${RED}FAIL${RESET} ${PURPLE}$@${RESET}]"; exit 1; }
@echo "${GREEN}PASS${RESET} ${PURPLE}$@${RESET}"
TEST_FILES?=$(wildcard */tests/*.catala*)
TEST_FILES_SCOPES_EN=$(foreach TEST_FILE,$(TEST_FILES),\
$(foreach TEST_SCOPE,\
$(shell grep -Po "declaration scope [^:]*" $(TEST_FILE) | cut -d " " -f 3), \
$(word 1,$(subst /, ,$(TEST_FILE))).$(word 1,$(subst ., ,$(word 3,$(subst /, ,$(TEST_FILE))))).$(TEST_SCOPE).run \
) \
)
TEST_FILES_SCOPES_FR=$(foreach TEST_FILE,$(TEST_FILES),\
$(foreach TEST_SCOPE,\
$(shell grep -Po "déclaration champ d'application [^:]*" $(TEST_FILE) | cut -d " " -f 3), \
$(word 1,$(subst /, ,$(TEST_FILE))).$(word 1,$(subst ., ,$(word 3,$(subst /, ,$(TEST_FILE))))).$(TEST_SCOPE).run \
) \
)
tests: $(TEST_FILES_SCOPES_EN) $(TEST_FILES_SCOPES_FR)
.FORCE:

25
examples/Makefile.common → examples/Makefile.common.mk
View File

@ -7,15 +7,11 @@ LATEXMK=latexmk
PYGMENTIZE_FR=../../syntax_highlighting/fr/pygments/pygments/env/bin/pygmentize
PYGMENTIZE_EN=../../syntax_highlighting/en/pygments/pygments/env/bin/pygmentize
CATALA=dune exec --no-print-director ../../src/catala.exe -- --debug --language=$(CATALA_LANG)
CATALA=dune exec --no-print-director ../../src/catala.exe -- $(CATALA_OPTS) --language=$(CATALA_LANG)
LEGIFRANCE_CATALA=dune exec ../../src/legifrance_catala.exe --
CATALA_EXE=../../_build/default/src/catala.exe
LEGIFRANCE_CATALA_EXE=../../_build/default/src/legifrance_catala.exe
CLIENT_ID?=$(shell cat ../../legifrance_oauth_id.txt)
CLIENT_SECRET?=$(shell cat ../../legifrance_oauth_secret.txt)
ifeq ($(CATALA_LANG),fr)
PYGMENTIZE=$(PYGMENTIZE_FR)
@ -28,8 +24,15 @@ endif
# Targets
##########################################
%.run: %.catala_$(CATALA_LANG) $(CATALA_EXE)
@$(CATALA) Makefile $<
@$(CATALA) \
Interpret \
-s $(SCOPE) \
$<
%.tex: %.catala_$(CATALA_LANG) $(CATALA_EXE)
$(CATALA) Makefile $<
@$(CATALA) Makefile $<
$(CATALA) \
--wrap \
--pygmentize=$(PYGMENTIZE) \
@ -37,16 +40,13 @@ endif
$<
%.html: %.catala_$(CATALA_LANG) $(CATALA_EXE)
$(CATALA) Makefile $<
@$(CATALA) Makefile $<
$(CATALA) \
--wrap \
--pygmentize=$(PYGMENTIZE) \
HTML \
$<
%.expired: %.catala_$(CATALA_LANG) $(CATALA_EXE) $(LEGIFRANCE_CATALA_EXE)
$(LEGIFRANCE_CATALA) $< $(CLIENT_ID) $(CLIENT_SECRET)
%.pdf: %.tex
cd $(@D) && $(LATEXMK) -g -pdf -halt-on-error -shell-escape $(%F)
@ -56,7 +56,10 @@ endif
clean:
$(LATEXMK) -f -C $(SRC:.catala_$(CATALA_LANG)=.tex)
rm -rf $(SRC:.catala_$(CATALA_LANG)=.tex) $(SRC:.catala_$(CATALA_LANG)=.d) _minted-$(SRC:.catala_$(CATALA_LANG)=)
rm -rf $(SRC:.catala_$(CATALA_LANG)=.tex) \
$(SRC:.catala_$(CATALA_LANG)=.d) \
_minted-$(SRC:.catala_$(CATALA_LANG)=) \
$(SRC:.catala_$(CATALA_LANG)=.html)
include $(wildcard $(SRC:.catala_$(CATALA_LANG)=.d))

122
examples/README.md Normal file
View File

@ -0,0 +1,122 @@
# Catala examples
This directory contains examples of Catala programs. It is highly recommended
to locate your own Catala programs in this directory, since programs in this
directory will receive first-class support during the alpha and beta stage
of the Catala programming language development.
## List of examples
* `allocations_familiales/`: computation of the French family benefits, based
on the _Code de la sécurité sociale_. This case study is the biggest and
most ambitious for Catala so far.
* `code_general_impots/`: computation of the French income tax, based on the
_Code général des impôts_. Currently, there are only stubs of program.
* `tutorial/`: Catala language tutorial for developers of tech-savvy lawyers.
The tutorial is written like a piece of legislation that gets annotated by
Catala snippets.
* `us_tax_code/`: contains the Catala formalization of several sections of the
US Tax Code.
## Building and running examples
Building and running examples is done via Makefiles. Each example directory
contains its own Makefile, which includes `Makefile.common.mk`. This common
Makefiles defines a list of targets that call the Catala compiler with the
right options. Each of these targers can be called from the root of the
repository with:
make -C examples/<directory of example> <name of target>
The `<name of target>` can be replaced with the following (we assume an example
file `examples/foo/foo.catala_en`) list.
* `foo.tex`: builds the LaTeX literate programming output from the Catala program
* `foo.pdf`: compiles `foo.tex` using `latexmk`
* `foo.html`: builds the HTML literate programming output from the Catala program
* `foo.run`: interprets the Catala program contained in `foo.catala_en`. Note
that you have to pass in the scope that you want to interpret via the `SCOPE`
Makefile variable (`SCOPE=FooScope make -C examples/foo foo.run`).
When invoking any of these targets, additional options to the Catala compiler
can be passed using the `CATALA_OPTS` Makefile variable.
## Testing examples
Unit testing is important, and we encourage Catala developers to write lots
of tests for their programs. Again, the Makefile system provides a way to
collect tests into a regression test suite.
In order to enjoy the benefits of this system, you have to create a `tests/`
directory in your examples directory, for instance `examples/foo/tests`. Then,
create a test file `foo_tests.catala_en` inside that directory.
Inside `foo_tests.catala_en`, declare one ore more test scopes. It is assumed
that all these scopes should execute correctly. Include the program scope you
want to test and use assertions to provide the expected values of your test.
See existing tests in examples directory for more information.
Once your tests are written, then will automatically be added to the regression
suite executed using
make -C examples tests
You can isolate a part of the regression suite by invoking:
TEST_FILES=examples/tests/foo/foo_tests.catala_en make -C examples tests
## Adding an example
This section describes what to do to setup a working directory for a new Catala
example, as well as the development cycle. Let us suppose that you want to
create a new example named `foo`.
First, follow the instructions of [the installation readme](../INSTALL.md) to
get the compiler up and working up to `make build`. You can also set up the
syntax highlighting for your editor.
Then, create the directory `examples/foo`. In there, create a master source
file `foo.catala` that will be the root of your Catala program.
You can then start programming in `foo.catala`, or split up your example
into multiple files. In the later case, `foo.catala` must only contain
something like this:
```
@@Master file@@
@@Include: bar.catala@@
```
where `examples/bar.catala` is another source file containing code for your
example. Make sure you start by including some content in the source files,
like
```
Hello, world!
```
To build and run the example, create a `Makefile` in `foo/`
with the following contents:
```Makefile
CATALA_LANG=en # or fr if your source code is in French
SRC=foo.catala
include ../Makefile.common.mk
```
The `include` creates automatically all the targets you will need for your example. For instance, after making sure the compiler is built, you can launch
```
make -C examples/foo foo.tex
```
from the repository root to create the LaTeX weaving output of your source
program. `Hello, world!` should appear in `examples/foo/foo.tex`.
Finally, please add a rule for your example in the repository root
`Makefile` in the section "Examples-related rules", following the pattern
for other examples. This will ensure that your example is built every
time the compiler is modified; if a change in the compiler breaks your example,
the authors will be notified and find a solution.

2
examples/allocations_familiales/Makefile
View File

@ -1,4 +1,4 @@
CATALA_LANG=fr
SRC=allocations_familiales.catala_fr
include ../Makefile.common
include ../Makefile.common.mk

2
examples/allocations_familiales/decrets_divers.catala_fr
View File

@ -32,8 +32,6 @@ Ils indiquent les montants relatifs aux allocations familiales, à l’
Je vous demande de bien vouloir transmettre à la connaissance des organismes débiteurs les présentes instructions.
@@Inclusion: JORFTEXT000000227447@@
/*
# Cependant, le cas de Mayotte n'est pas traité dans la loi et ce sont donc
# les règles de cette annexe qui s'apppliquent.

50
examples/allocations_familiales/metadata.catala_fr
View File

@ -17,7 +17,7 @@ déclaration énumération PriseEnCharge :
déclaration structure Enfant :
donnée fin_obligation_scolaire contenu date
donnée âge contenu entier
donnée rémuneration_mensuelle contenu montant
donnée rémuneration_mensuelle contenu argent
donnée prise_en_charge contenu PriseEnCharge
condition confié_service_social
@ -99,8 +99,8 @@ déclaration énumération Prestation:
déclaration structure PrestationsFamiliales :
condition conditions_hors_âge dépend de Enfant
condition droits_ouverts dépend de Enfant
donnée base_mensuelle contenu montant
donnée base_mensuelle_dom contenu montant
donnée base_mensuelle contenu argent
donnée base_mensuelle_dom contenu argent
déclaration énumération ChargeAllocation :
-- Complète
@ -110,21 +110,21 @@ déclaration structure AllocationsFamiliales :
condition droits_ouverts
donnée date_ouverture_droits contenu date
condition conditions_hors_âge dépend de Enfant
donnée base contenu montant
donnée avec_garde_alternée contenu montant
donnée montant_versé contenu montant
donnée base contenu argent
donnée avec_garde_alternée contenu argent
donnée montant_versé contenu argent
donnée récipiendaire_par_enfant contenu Personne dépend de Enfant
donnée charge_par_enfant contenu ChargeAllocation dépend de Enfant
donnée rapport_enfants_total_moyen contenu décimal
donnée nombre_total_enfants contenu entier
donnée nombre_moyen_enfants contenu décimal
donnée montant_premier_enfant contenu montant
donnée montant_deuxieme_enfant contenu montant
donnée montant_troisième_enfant_et_plus contenu montant
donnée montant_premier_enfant contenu argent
donnée montant_deuxieme_enfant contenu argent
donnée montant_troisième_enfant_et_plus contenu argent
déclaration structure AllocationForfaitaire :
condition droits_ouverts dépend de Enfant
donnée montant_versé contenu montant
donnée montant_versé contenu argent
déclaration énumération ChoixParentAllocataire :
-- UnParent contenu Personne
@ -140,16 +140,16 @@ déclaration structure AllocationsGardeAlternée :
déclaration structure MajorationsAllocationsFamiliales :
condition droits_ouverts dépend de Enfant
donnée base_par_enfant contenu montant dépend de Enfant
donnée avec_garde_alternée contenu montant dépend de Enfant
donnée montant_versé contenu montant
donnée base_par_enfant contenu argent dépend de Enfant
donnée avec_garde_alternée contenu argent dépend de Enfant
donnée montant_versé contenu argent
déclaration structure ComplémentDégressif :
condition droits_ouverts dépend de montant
donnée dépassement contenu montant dépend de montant
donnée pour_allocation_forfaitaire contenu montant
donnée pour_allocations_familiales_et_majorations contenu montant
donnée montant_versé contenu montant
condition droits_ouverts dépend de argent
donnée dépassement contenu argent dépend de argent
donnée pour_allocation_forfaitaire contenu argent
donnée pour_allocations_familiales_et_majorations contenu argent
donnée montant_versé contenu argent
déclaration structure TitreI:
condition droits_ouverts_allocations_familiales dépend de Personne
@ -161,25 +161,25 @@ déclaration structure L512_3 :
donnée âge_limite_alinéa_2 contenu entier
donnée âge_limite_alinéa_2_alternatif contenu entier
condition âge_limite_alinéa_2_alternatif_utilisé
donnée plafond_rémunération_mensuelle_alinéa_2 contenu montant
donnée plafond_rémunération_mensuelle_alinéa_2 contenu argent
déclaration structure L521_1 :
donnée nombre_minimum_enfants contenu montant
donnée ressources_ménage contenu montant
donnée nombre_minimum_enfants contenu argent
donnée ressources_ménage contenu argent
déclaration structure L521_3 :
donnée âge_limite_alinéa_1 contenu entier dépend de Enfant
donnée minimum_alinéa_2 contenu montant
donnée minimum_alinéa_2 contenu argent
déclaration structure L751_1 :
condition régime_outre_mer
déclaration structure D521_3 :
donnée plafond_I contenu montant
donnée plafond_II contenu montant
donnée plafond_I contenu argent
donnée plafond_II contenu argent
déclaration structure SMIC :
donnée brut_horaire contenu montant dépend de Collectivité
donnée brut_horaire contenu argent dépend de Collectivité
déclaration champ d'application CalculPrestationsFamiliales :
# Les règles déclarées dans PrestationsFamiliales pourront utiliser

2
examples/code_general_impots/Makefile
View File

@ -1,4 +1,4 @@
CATALA_LANG=fr
SRC=code_general_impots.catala_fr
include ../Makefile.common
include ../Makefile.common.mk

18
examples/code_general_impots/Section_I_Dispositions_generales.catala_fr
View File

@ -36,15 +36,15 @@ total dont sont retranchées les charges énumérées à l'article 156.
/*
déclaration structure RevenuNetGlobal:
donnée revenus_fonciers contenu montant
donnée bénéfices_industriels_commerciaux contenu montant
donnée rémunérations_dirigeants contenu montant
donnée bénéfices_agricoles contenu montant
donnée traitements_salaires contenu montant
donnée bénéfices_non_commerciaux contenu montant
donnée revenus_capitaux_mobiliers contenu montant
donnée plus_values contenu montant
donnée total contenu montant
donnée revenus_fonciers contenu argent
donnée bénéfices_industriels_commerciaux contenu argent
donnée rémunérations_dirigeants contenu argent
donnée bénéfices_agricoles contenu argent
donnée traitements_salaires contenu argent
donnée bénéfices_non_commerciaux contenu argent
donnée revenus_capitaux_mobiliers contenu argent
donnée plus_values contenu argent
donnée total contenu argent
déclaration champ d'application CalculImpotSurLeRevenu :
contexte revenu_net_global contenu RevenuNetGlobal

2
examples/tutorial/Makefile
View File

@ -1,4 +1,4 @@
CATALA_LANG=en
SRC=tutorial_en.catala_en
include ../Makefile.common
include ../Makefile.common.mk

29
examples/tutorial/tests/test_tutorial.catala_en Normal file
View File

@ -0,0 +1,29 @@
@@Include: ../tutorial_en.catala_en@@
@Test@
/*
declaration scope UnitTest1:
context tax_computation scope NewIncomeTaxComputation
scope UnitTest1:
definition
tax_computation.individual
equals
Individual {
-- income: $230,000
-- number_of_children: 0
}
assertion tax_computation.income_tax = $72,000
declaration scope UnitTest2:
context tax_computation scope NewIncomeTaxComputationFixed
scope UnitTest2:
definition tax_computation.individual equals Individual {
-- income: $4,000
-- number_of_children: 0
}
assertion tax_computation.income_tax = $0.00
*/

330
examples/tutorial/tutorial_en.catala_en
View File

@ -3,38 +3,50 @@
Welcome to this tutorial, whose objective is to guide you through the features
of the Catala language and trach you how to annotate a legislative text using
the language. This document is addressed primarily to developers or people that
have a programming background. It will use terms and jargon that might be
unintelligible for lawyers in general.
have a programming background, though tech-savvy lawyers will probably figure
things out.
@@Literate programming@@+
To begin writing a Catala program, you must start from the text of the
legislative source that will justify the code that you will write. Concretely,
that means copy-pasting the text of the law into a Catala source file and
formatting it according so that Catala can understand it.
formatting it according so that Catala can understand it. Catala source files
have the ".catala_en" extension. If you were to write a Catala program for a
French law, you would use the ".catala_fr" extension.
You can write any kind of plain text in Catala, and it will be printed as is
in PDF or HTML output. Keep in mind however that one line in the source file
corresponds to a paragraph in the output. Catala allows you to declare section
or subsection headers as it is done here, but the fundamental division unit is
the article. Let's analyse a fictional example that defines an income tax.
in PDF or HTML output. You can split your text into short lines, those
will appear as a single paragraph in the output. If you want to create a
new paragrah, you have to leave a blank line in the source.
Catala allows you to declare section or subsection headers as it is done
here, with the "at" symbol repeated twice. You can define heading of lower
importance by adding increasing numbers of "+" after the title of the heading.
The fundamental division unit is the article, introduced by a single "at".
Let's analyse a fictional example that defines an income tax.
@Article 1@
The income tax for an individual is defined as a fixed percentage of the
individual's income over a year.
/*
# This is a placeholder comment, the code for that article should go here
# Welcome to the code mode of Catala. This is a comment, because the line is
# prefixed by #.
# We will soon learn what to write here in order to translate the meaning
# of the article into Catala code.
*/
We will now proceed to encode the algorithmic content of this article using
the Catala language. To do that, we will intertwine short snippets of code
between the sentences of the legislative text. Each snippet of code should
be as short as possible and as close as possible to the actual sentence that
justifies the code.
To do that, we will intertwine short snippets of code between the sentences of
the legislative text. Each snippet of code should be as short as possible and
as close as possible to the actual sentence that justifies the code. This style
is called litterate programming, a programming paradigm invented by the famous
computer scientist Donald Knuth in the 70s.
@@Defining a fictional income tax@@+
The content of article 1 uses a lot of implicit context : there exists an
The content of article 1 uses a lot of implicit context: there exists an
individual with an income, as well as an income tax that the individual has
to pay each year. Even if this implicit context is not verbatim in the law,
we have to explicit it for programming purposes. Concretely, we need a
@ -42,23 +54,28 @@ we have to explicit it for programming purposes. Concretely, we need a
inside the law.
Let's start our metadata section by declaring the type information for the
individual and the income tax computation:
@@Begin metadata@@
/*
declaration structure Individual:
data income content amount
individual:
declaration structure Article1:
data fixed_percentage content decimal
data income_tax content amount
@@Begin metadata@@
/*
declaration structure Individual:
# The name of the structure "Individual", must start with an
# uppercase letter: this is the CamlCase convention.
data income content money
# In this line, "income" is the name of the structure field and
# "money" is the type of what is stored in that field.
# Available types include: integer, decimal, money, date, duration,
# and any other structure or enumeration that you declare
data number_of_children content integer
# "income" and "number_of_children" start by a lowercase letter,
# they follow the snake_case convention
*/
@@End metadata@@
Each of this declaration is a structure, containing one or more data fields.
Structures are useful to group together data that goes together. Usually, you
This structre contains two data fields, "income" and "age". Structures are
useful to group together data that goes together. Usually, you
get one structure per concrete object on which the law applies (like the
individual), but also one structure for each article that defines quantities
(like the article 1). It is up to you to decide how to group the data together,
individual). It is up to you to decide how to group the data together,
but you should aim to optimize code readability.
Sometimes, the law gives an enumeration of different situations. These
@ -66,31 +83,41 @@ enumerations are modeled in Catala using an enumeration type, like:
@@Begin metadata@@
/*
declaration enumeration TaxCredit:
# The name "TaxCredit" is also written in CamlCase
-- NoTaxCredit
-- ChildrenTaxCredit content integer # the integer corresponds
# to the number of children
# This line says that "TaxCredit" can be a "NoTaxCredit" situation
-- ChildrenTaxCredit content integer
# This line says that alternatively, "TaxCredit" can be a
# "ChildrenTaxCredit" situation. This situation carries a content
# of type integer corresponding to the number of children concerned
# by the tax credit. This means that if you're in the "ChildrenTaxCredit"
# situation, you will also have access to this number of children
*/
@@End metadata@@
In computer science terms, such an enumeration is called a "sum type" or simply
an enum. The combination of structures and enumerations allow the Catala
programmer to declare all possible shapes of data, as they are equivalent to
the powerful notion of "algebraic datatypes".
We've defined and typed the data that the program will manipulate. Now we have
to define the logical context in which these data will evolve. This is done in
Catala using "scopes". Scopes also have to be declared in metadata, so here we
go:
Catala using "scopes". Scopes are close to functions in terms of traditional
programming. Scopes also have to be declared in metadata, so here we go:
@@Begin metadata@@
/*
declaration scope IncomeTaxComputation:
# Scope names use CamlCase
context individual content Individual
context article1 content Article1
# This line declares a context element of the scope, which is aking to
# a function parameter in computer science term. This is the piece of
# data on which the scope will operate
context fixed_percentage content decimal
context income_tax content money
*/
@@End metadata@@
This scope declaration says that whenever we're in the scope
"IncomeTaxComputation", then we have access to two elements in context,
namely the individual's data and the data defined by article 1. We will be
able to refer to the lowercase variables in our code, either to use them or to
define them or one of their part.
We now have everything to annotate the contents of article 1, which is copied
over below.
@ -99,28 +126,44 @@ The income tax for an individual is defined as a fixed percentage of the
individual's income over a year.
/*
scope IncomeTaxComputation:
definition article1.income_tax equals
invidual.income * article1.fixed_percentage
definition income_tax equals
individual.income *$ fixed_percentage
*/
In the code, we are defining inside our scope the amount of the income tax
according to the formula described in the article. When defining formulaes,
you have access to all the usual arithmetic operators. But what is the value
of that fixed percentage? Often, precise values are defined elsewhere in the
you have access to all the usual arithmetic operators: addition "+",
substraction "-", multiplication "*" and division (slash).
However, in the Catala code, you can see that we use "*$" to multiply the
individual income by the fixed percentage. The $ suffix indicates that we
are performing a multiplication on an amount of money. Indeed, in Catala,
you have to keep track of what you are dealing with: is it money ? Is it
an integer? Using just "+" or "*" can be ambiguous in terms of rounding,
since money is usually rounded at the cent. So to disambiguate, we suffix these
operations with something that indicates the type of what we manipulate.
The suffixes are "$" for money "." for decimals, "at" (like in email adresses)
for dates and the hat symbol for durations. If you forget the suffix, the Catala type
checker will display an error message that will help you put it where it
belongs.
But inside article 1, one question remains unknown: what is the value of
of the fixed percentage? Often, precise values are defined elsewhere in the
legislative source. Here, let's suppose we have:
@Article 2@
The fixed percentage mentionned at article 1 is equal to 20 %.
/*
scope IncomeTaxComputation:
definition article1.fixed_percentage equals 20 %
definition fixed_percentage equals 20 %
# Writing 20% is just an abbreviation for 0.20
*/
You can see here that Catala allows definitions to be scattered throughout
the annotation of the legislative text, so that each
definition is as close as possible to its location in the text.
@@Conditional definitions@@
@@Conditional definitions@@+
So far so good, but now the legislative text introduces some trickyness. Let us
suppose the third article says:
@ -128,19 +171,20 @@ suppose the third article says:
@Article 3@ If the individual is in charge of 2 or more children, then the fixed
percentage mentionned at article 1 is equal to 15 %.
/*
# How to redefine article1.fixed_percentage?
# How to redefine fixed_percentage?
*/
This article actually gives another definition for the fixed percentage, which
was already defined in article 2. However, article 3 defines the percentage
conditionnally to the individual having more than 2 children. Catala allows
you precisely to redefine a variable under a condition:
was already defined in article 2. However, article 3 defines the percentage
conditionnally to the individual having more than 2 children. Catala allows
you precisely to redefine a variable under a condition:
/*
scope IncomeTaxComputation:
definition article1.fixed_percentage under condition
definition fixed_percentage under condition
individual.number_of_children >= 2
consequence equals 15 %
# Writing 15% is just an abbreviation for 0.15
*/
When the Catala program will execute, the right definition will be dynamically
@ -150,7 +194,7 @@ However, if it is not the case, Catala will let you define a precedence on the
conditions, which has to be justified by the law.
@@Functions@@
@@Functions@@+
Catala lets you define functions anywhere in your data. Here's what it looks
like in the metadata definition when we want to define a two-brackets tax
@ -158,13 +202,13 @@ computation:
@@Begin metadata@@
/*
declaration structure TwoBrackets:
data breakpoint content amount
data breakpoint content money
data rate1 content decimal
data rate2 content decimal
declaration scope TwoBracketsTaxComputation :
context brackets content TwoBrackets
context tax_formula content amount depends on amount
context tax_formula content money depends on money
*/
@@End metadata@@
@ -175,62 +219,166 @@ of income in each bracket multiplied by the rate of each bracket.
/*
scope TwoBracketsTaxComputation :
definition tax of income equals
if income <= breakpoint then
income * rate1
definition tax_formula of income equals
if income <=$ brackets.breakpoint then
income *$ brackets.rate1
else (
breakpoint * rate1 + (income - breakpoint) * rate2
brackets.breakpoint *$ brackets.rate1 +$
(income -$ brackets.breakpoint) *$ brackets.rate2
)
*/
@@Scope inclusion@@
@@Scope inclusion@@+
Now that we've defined our helper scope for computing a two-brackets tax, we
want to use it in our main tax computation scope.
@Article 5@ For individuals whose income is greater than $100,000, the income
tax of article 1 is computed with a two-brackets system.
tax of article 1 is 40% of the income above $100,000. Below $100,000, the
income tax is 20% of the income.
/*
declaration scope IncomeTaxComputation:
# The scope inclusion has to be added in the scope declaration
context two_brackets_for_rich scope TwoBracketsTaxComputation
declaration scope NewIncomeTaxComputation:
context two_brackets scope TwoBracketsTaxComputation
# This line says that we add the item two_brackets_for_rich to the context.
# However, the "scope" keyword tells that this item is not a piece of data
# but rather a subscope that we can use to compute things.
context individual content Individual
context income_tax content money
scope IncomeTaxComputation :
definition article1.income_tax under condition
individual.income >= $100,000
consequence equals
two_brackets_for_rich.tax of individual.income
scope NewIncomeTaxComputation :
definition two_brackets.brackets equals TwoBrackets {
-- breakpoint: $100,000
-- rate1: 20%
-- rate2: 40%
}
definition income_tax equals two_brackets.tax_formula of individual.income
*/
Scope inclusion also comes with a syntactic sugar for quickly and conditionnaly
connecting context quantities :
@@Begin metadata@@
/*
declaration scope ExemptedOfTax:
context article1 content Article1
*/
@@End metadata@@
@Article 6@
Individuals earning less than $10,000 are exempted of the income tax mentionned
at article 1.
/*
scope ExemptedOfTax :
definition article1.income_tax equals $0
declaration scope IncomeTaxComputation:
# The scope inclusion has to be added in the scope declaration
context tax_exempt scope ExemptedOfTax
scope IncomeTaxComputation:
definition article1.income_tax under condition
individual.income <= $10,000
consequence equals
tax_exempt.article1.income_tax
scope NewIncomeTaxComputation:
definition income_tax under condition
individual.income <=$ $10,000
consequence equals $0
*/
This snippet of code actually brings the definition of article1.income_tax of
ExemptedOfTax into the IncomeTaxComputation scope, prefixing it with the
"income under $10,000" condition.
That's it! We've defined a two-brackets tax computation simply by annotating
legislative article by snippets of Catala code. However, attentive readers
may have caught something weird in articles 5 and 6. What happens when the
income of the individual is between $10,000 and $100,000 ?
The law leaves it unspecified ; our dummy articles are clearly badly drafted.
But Catala can help you find this sort of errors via simple testing or
even formal verification. Let's start with the testing.
@@Testing Catala programs@@+
Testing Catala programs can be done directly into Catala. Indeed, writing test
cases for each Catala scope that you define is a good practice called
"unit testing" in the software engineering community. A test case is defined
as another scope:
@Testing NewIncomeTaxComputation@
/*
declaration scope Test1:
context tax_computation scope NewIncomeTaxComputation
scope Test1:
definition
tax_computation.individual
# We define the argument to the subscope
equals
# The four lines below define a whole structure by giving a value to
# each of its fields
Individual {
-- income: $230,000
-- number_of_children: 0
}
# Next, we retrieve the income tax value compute it by the subscope and
# assert that it is equal to the expected value :
# ($230,000-$100,00)*40%+$100,000*20% = $72,000
assertion tax_computation.income_tax = $72,000
*/
This test should pass. Let us now consider a failing test case:
/*
declaration scope Test2:
context tax_computation scope NewIncomeTaxComputation
scope Test2:
definition tax_computation.individual equals Individual {
-- income: $4,000
-- number_of_children: 0
}
assertion tax_computation.income_tax = $0
*/
This test case should compute a $0 income tax because of Article 6. But instead,
execution will yield an error saying that there is a conflict between rules.
@@Defining exceptions to rules@@+
Indeed, the definition of the income tax in article 6 conflicts with the
definition of income tax in article 5. But actually, article 6 is just an
exception of article 5. In the law, it is implicit that if article 6 is
applicable, then it takes precedence over article 5.
@Fixing the computation@
This implicit precedence has to be explicitely declared in Catala. Here is a
fixed version of the NewIncomeTaxComputation scope:
/*
declaration scope NewIncomeTaxComputationFixed:
context two_brackets scope TwoBracketsTaxComputation
context individual content Individual
context income_tax content money
scope NewIncomeTaxComputationFixed :
definition two_brackets.brackets equals TwoBrackets {
-- breakpoint: $100,000
-- rate1: 20%
-- rate2: 40%
}
# To define an exception to a rule, you have to first label the rule that
# you want to attach to exception to. You can put any snake_case identifier
# for the label
label article_5
definition income_tax equals two_brackets.tax_formula of individual.income
# Then, you can declare the exception by referring back to the label
exception article_5
definition income_tax under condition
individual.income <=$ $10,000
consequence equals $0
*/
And the test that should now work:
/*
declaration scope Test3:
context tax_computation scope NewIncomeTaxComputationFixed
scope Test3:
definition tax_computation.individual equals Individual {
-- income: $4,000
-- number_of_children: 0
}
assertion tax_computation.income_tax = $0
*/
@@Conclusion@@+
This tutorial present the basic concepts and syntax of the Catala language
features. It is then up to you tu use them to annotate legislative texts
with their algorithmic translation.
There is no single way to write Catala programs, as the program style should be
adapted to the legislation it annotates. However, Catala is a functional
language at heart, so following standard functional programming design patterns
should help achieve concise and readable code.

2
examples/us_tax_code/Makefile
View File

@ -1,4 +1,4 @@
CATALA_LANG=en
SRC=us_tax_code.catala_en
include ../Makefile.common
include ../Makefile.common.mk

8
examples/us_tax_code/preamble.catala_en
View File

@ -1 +1,9 @@
@@The US Tax Code@@
@@Begin metadata@@
/*
declaration structure Person:
data id content integer
*/
@@End metadata@@

20
examples/us_tax_code/section_1015.catala_en
View File

@ -13,23 +13,23 @@ declaration structure Acquisition:
data no_sale_or_exchange_before content boolean
declaration structure Value:
data fair_market content amount depends on date
data last_acquisition content amount
data net_appreciation content amount
data fair_market content money depends on date
data last_acquisition content money
data net_appreciation content money
declaration structure Transferor:
data basis content amount
data basis_known content optional amount
data basis content money
data basis_known content optional money
data acquisition content Acquisition
data gain_or_loss content amount depends on date
data gain_or_loss content money depends on date
declaration scope BasisOfGift:
context acquisition content Acquisition
context basis_subsection_a content amount
context basis content amount
context basis_bonus_after_1976 content amount
context basis_subsection_a content money
context basis content money
context basis_bonus_after_1976 content money
context transferor content Transferor
context gift_tax_paid content amount
context gift_tax_paid content money
*/
@@End metadata@@

6
examples/us_tax_code/section_121.catala_en
View File

@ -13,14 +13,14 @@ declaration structure Property:
declaration structure SaleOrExchange:
data property content Property
data gain content amount
data gain content money
data date_of_sale_or_exchange content date
declaration scope Section121:
context taxpayer content Person
context applicable condition
context maximum_gain_excluded content amount
context gain_considered_for_exclusion content amount
context maximum_gain_excluded content money
context gain_considered_for_exclusion content money
context sale_or_exchange content SaleOrExchange
context included_in_gross_income condition
context ownage_considered_for_gain_inclusion condition

53
examples/us_tax_code/section_132.catala_en
View File

@ -8,13 +8,23 @@ declaration enumeration DiscountType:
-- Services
declaration scope QualifiedEmployeeDiscount:
context customer_price content amount
context employee_price content amount
context customer_price content money
context employee_price content money
context gross_profit_percentage content decimal
context qualified_employee_discount content amount
context employee_discount content amount
context aggregate_cost content amount
context qualified_employee_discount content money
context employee_discount content money
context aggregate_cost content money
context discount_type content DiscountType
context is_property content boolean
context is_services content boolean
scope QualifiedEmployeeDiscount:
definition is_property equals match discount_type with pattern
-- Property: true
-- Services: false
definition is_services equals match discount_type with pattern
-- Property: false
-- Services: true
*/
@@End metadata@@
@ -30,11 +40,11 @@ the property is being offered by the employer to customers, or
/*
scope QualifiedEmployeeDiscount :
definition qualified_employee_discount
under condition discount_type with pattern Property consequence
under condition is_property consequence
equals
if employee_discount >
customer_price * gross_profit_percentage
then customer_price * gross_profit_percentage
if employee_discount >$
customer_price *$ gross_profit_percentage
then customer_price *$ gross_profit_percentage
else employee_discount
*/
(B) in the case of services, 20 percent of the price at which the services are
@ -42,12 +52,18 @@ being offered by the employer to customers.
/*
scope QualifiedEmployeeDiscount :
definition qualified_employee_discount
under condition discount_type with pattern Services consequence
under condition is_services consequence
equals
if employee_discount >
customer_price * 20%
then customer_price * 20%
if employee_discount >$
customer_price *$ 20%
then customer_price *$ 20%
else employee_discount
scope QualifiedEmployeeDiscount under condition is_services:
# When selling a service, one does not need the aggregate cost.
# We provide a default value here so that the computations run smooth.
definition aggregate_cost equals $0
definition gross_profit_percentage equals 0%
*/
@@(2) Gross profit percentage@@++
@ -59,12 +75,11 @@ to customers over the aggregate cost of such property to the employer, is of
(ii) the aggregate sale price of such property.
/*
scope QualifiedEmployeeDiscount
under condition discount_type with pattern Property :
assertion customer_price >= aggregate_cost
scope QualifiedEmployeeDiscount under condition is_property:
assertion customer_price >=$ aggregate_cost
definition gross_profit_percentage equals
(customer_price - aggregate_cost) / customer_price
(customer_price -$ aggregate_cost) /$ customer_price
*/
@(B) Determination of gross profit percentage@
Gross profit percentage shall be determined on the basis of—
@ -88,10 +103,10 @@ an employee for use by such employee, is less than
employer to customers.
/*
scope QualifiedEmployeeDiscount:
assertion customer_price >= employee_price
assertion customer_price >=$ employee_price
definition employee_discount equals
employee_price - customer_price
customer_price -$ employee_price
*/
@(4) Qualified property or services@
The term “qualified property or services” means any property (other than real

42
examples/us_tax_code/tests/test_section_132.catala_en Normal file
View File

@ -0,0 +1,42 @@
@@Include: ../section_132.catala_en@@
@Test@
/*
declaration scope TestSection132_1:
context section_132 scope QualifiedEmployeeDiscount
scope TestSection132_1:
definition section_132.customer_price equals $1500
definition section_132.employee_price equals $1000
definition section_132.aggregate_cost equals $900
definition section_132.discount_type equals Property
assertion section_132.employee_discount = $500
assertion section_132.gross_profit_percentage = 0.4
assertion section_132.qualified_employee_discount = $500
*/
/*
declaration scope TestSection132_2:
context section_132 scope QualifiedEmployeeDiscount
scope TestSection132_2:
definition section_132.customer_price equals $1500
definition section_132.employee_price equals $1000
definition section_132.aggregate_cost equals $1200
definition section_132.discount_type equals Property
assertion section_132.employee_discount = $500
assertion section_132.gross_profit_percentage = 0.2
assertion section_132.qualified_employee_discount = $300.00
*/
/*
declaration scope TestSection132_3:
context section_132 scope QualifiedEmployeeDiscount
scope TestSection132_3:
definition section_132.customer_price equals $1500
definition section_132.employee_price equals $1000
definition section_132.discount_type equals Services
assertion section_132.employee_discount = $500
assertion section_132.qualified_employee_discount = $300
*/

3
install_opam.sh
View File

@ -1,3 +0,0 @@
#! /usr/bin/env bash
sh <(curl -sL https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh)

60
src/catala/catala_surface/ast.ml
View File

@ -12,15 +12,27 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Abstract syntax tree built by the Catala parser *)
module Pos = Utils.Pos
type constructor = string
(** Constructors are CamlCase *)
type ident = string
(** Idents are snake_case *)
type qident = ident Pos.marked list
type primitive_typ = Integer | Decimal | Boolean | Money | Text | Date | Named of constructor
type primitive_typ =
| Integer
| Decimal
| Boolean
| Money
| Duration
| Text
| Date
| Named of constructor
type base_typ_data =
| Primitive of primitive_typ
@ -55,9 +67,28 @@ type enum_decl = {
type match_case_pattern = constructor Pos.marked list * ident Pos.marked option
type binop = And | Or | Add | Sub | Mult | Div | Lt | Lte | Gt | Gte | Eq | Neq
type op_kind =
| KInt (** No suffix *)
| KDec (** Suffix: [.] *)
| KMoney (** Suffix: [$] *)
| KDate (** Suffix: [@] *)
| KDuration (** Suffix: [^] *)
type unop = Not | Minus
type binop =
| And
| Or
| 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
type unop = Not | Minus of op_kind
type builtin_expression = Cardinal | Now
@ -69,13 +100,13 @@ type literal_date = {
literal_date_year : int Pos.marked;
}
type literal_number = Int of Int64.t | Dec of Int64.t * Int64.t
type literal_number = Int of Z.t | Dec of Z.t * Z.t
type literal_unit = Percent | Year | Month | Day
type collection_op = Exists | Forall | Aggregate of aggregate_func
type money_amount = { money_amount_units : Int64.t; money_amount_cents : Int64.t }
type money_amount = { money_amount_units : Z.t; money_amount_cents : Z.t }
type literal =
| Number of literal_number Pos.marked * literal_unit Pos.marked option
@ -90,11 +121,6 @@ type match_case = {
and match_cases = match_case Pos.marked list
and struct_inject = {
struct_inject_name : constructor Pos.marked;
struct_inject_fields : (ident Pos.marked * expression 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
@ -109,12 +135,14 @@ and expression =
| Literal of literal
| EnumInject of constructor Pos.marked * expression Pos.marked option
| EnumProject of expression Pos.marked * constructor Pos.marked
| StructLit of constructor Pos.marked * (ident Pos.marked * expression Pos.marked) list
| Ident of ident
| Dotted of expression Pos.marked * ident Pos.marked
(* Dotted is for both struct field projection and sub-scope variables *)
| StructInject of struct_inject
(** Dotted is for both struct field projection and sub-scope variables *)
type rule = {
rule_label : ident Pos.marked option;
rule_exception_to : ident Pos.marked option;
rule_parameter : ident Pos.marked option;
rule_condition : expression Pos.marked option;
rule_name : qident Pos.marked;
@ -122,6 +150,8 @@ type rule = {
}
type definition = {
definition_label : ident Pos.marked option;
definition_exception_to : ident Pos.marked option;
definition_name : qident Pos.marked;
definition_parameter : ident Pos.marked option;
definition_condition : expression Pos.marked option;
@ -191,14 +221,12 @@ type law_include =
| CatalaFile of string Pos.marked
| LegislativeText of string Pos.marked
type law_article_item =
| LawText of string
| CodeBlock of code_block * source_repr
| LawInclude of law_include
type law_article_item = LawText of string | CodeBlock of code_block * source_repr
type law_heading = { law_heading_name : string; law_heading_precedence : int }
type law_structure =
| LawInclude of law_include
| LawHeading of law_heading * law_structure list
| LawArticle of law_article * law_article_item list
| MetadataBlock of code_block * source_repr

494
src/catala/catala_surface/desugaring.ml
View File

@ -12,35 +12,59 @@
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 *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
(** The optional argument subdef allows to choose between differents uids in case the expression is
a redefinition of a subvariable *)
(** {1 Translating expressions} *)
let translate_op_kind (k : Ast.op_kind) : Dcalc.Ast.op_kind =
match k with
| KInt -> KInt
| KDec -> KRat
| KMoney -> KMoney
| KDate -> KDate
| KDuration -> KDuration
let translate_binop (op : Ast.binop) : Dcalc.Ast.binop =
match op with
| And -> And
| Or -> Or
| Add -> Add
| Sub -> Sub
| Mult -> Mult
| Div -> Div
| Lt -> Lt
| Lte -> Lte
| Gt -> Gt
| Gte -> Gte
| Add l -> Add (translate_op_kind l)
| Sub l -> Sub (translate_op_kind l)
| Mult l -> Mult (translate_op_kind l)
| Div l -> Div (translate_op_kind l)
| Lt l -> Lt (translate_op_kind l)
| Lte l -> Lte (translate_op_kind l)
| Gt l -> Gt (translate_op_kind l)
| Gte l -> Gte (translate_op_kind l)
| Eq -> Eq
| Neq -> Neq
let translate_unop (op : Ast.unop) : Dcalc.Ast.unop = match op with Not -> Not | Minus -> Minus
let translate_unop (op : Ast.unop) : Dcalc.Ast.unop =
match op with Not -> Not | Minus l -> Minus (translate_op_kind l)
let rec translate_expr (scope : Scopelang.Ast.ScopeName.t)
(def_key : Desugared.Ast.ScopeDef.t option) (ctxt : Name_resolution.context)
(** The two modules below help performing operations on map with the {!type: Bindlib.box}. Indeed,
Catala uses the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library to represent bound
variables in the AST. In this translation, bound variables are used to represent function
parameters or pattern macthing bindings. *)
module LiftStructFieldMap = Bindlib.Lift (Scopelang.Ast.StructFieldMap)
module LiftEnumConstructorMap = Bindlib.Lift (Scopelang.Ast.EnumConstructorMap)
(** Usage: [translate_expr scope ctxt expr]
Translates [expr] into its desugared equivalent. [scope] is used to disambiguate the scope and
subscopes variables than occur in the expresion *)
let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
((expr, pos) : Ast.expression Pos.marked) : Scopelang.Ast.expr Pos.marked Bindlib.box =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
let rec_helper = translate_expr scope def_key ctxt in
let rec_helper = translate_expr scope ctxt in
match expr with
| IfThenElse (e_if, e_then, e_else) ->
Bindlib.box_apply3
@ -61,35 +85,67 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t)
| Literal l ->
let untyped_term =
match l with
| Number ((Int i, _), _) -> Scopelang.Ast.ELit (Dcalc.Ast.LInt i)
| Number ((Dec (_i, _f), _), _) -> Name_resolution.raise_unsupported_feature "decimal" pos
| 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) ->
let digits_f = int_of_float (ceil (float_of_int (Z.log2up f) *. log 2.0 /. log 10.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, _)) ->
let digits_f =
int_of_float (ceil (float_of_int (Z.log2up f) *. log 2.0 /. log 10.0)) + 2
(* because of % *)
in
Scopelang.Ast.ELit
(Dcalc.Ast.LRat
Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f))))
| Bool b -> Scopelang.Ast.ELit (Dcalc.Ast.LBool b)
| _ -> Name_resolution.raise_unsupported_feature "literal" pos
| MoneyAmount i ->
Scopelang.Ast.ELit
(Dcalc.Ast.LMoney Z.((i.money_amount_units * of_int 100) + i.money_amount_cents))
| Number ((Int i, _), Some (Year, _)) ->
Scopelang.Ast.ELit (Dcalc.Ast.LDuration Z.(of_int 365 * i))
| Number ((Int i, _), Some (Month, _)) ->
Scopelang.Ast.ELit (Dcalc.Ast.LDuration Z.(of_int 30 * i))
| Number ((Int i, _), Some (Day, _)) -> Scopelang.Ast.ELit (Dcalc.Ast.LDuration i)
| Number ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
Errors.raise_spanned_error
"Impossible to specify decimal amounts of days, months or years" pos
| Date date -> (
let date =
ODate.Unix.make
~year:(Pos.unmark date.literal_date_year)
~day:(Pos.unmark date.literal_date_day)
~month:
( try ODate.Month.of_int (Pos.unmark date.literal_date_month)
with Failure _ ->
Errors.raise_spanned_error "Invalid month (should be between 1 and 12)"
(Pos.get_position date.literal_date_month) )
()
in
match ODate.Unix.some_if_valid date with
| Some date -> Scopelang.Ast.ELit (Dcalc.Ast.LDate date)
| None -> Errors.raise_spanned_error "Invalid date" pos )
in
Bindlib.box (untyped_term, pos)
| Ident x -> (
(* first we check whether this is a local var, then we resort to scope-wide variables *)
match def_key with
| Some def_key -> (
let def_ctxt = Desugared.Ast.ScopeDefMap.find def_key scope_ctxt.definitions in
match Desugared.Ast.IdentMap.find_opt x def_ctxt.var_idmap with
| None -> (
match Desugared.Ast.IdentMap.find_opt x scope_ctxt.var_idmap with
| Some uid -> Bindlib.box (Scopelang.Ast.ELocation (ScopeVar (uid, pos)), pos)
| None ->
Name_resolution.raise_unknown_identifier "for a\n local or scope-wide variable"
(x, pos) )
| Some uid -> Scopelang.Ast.make_var (uid, pos)
(* the whole box thing is to accomodate for this case *) )
match Desugared.Ast.IdentMap.find_opt x ctxt.local_var_idmap with
| None -> (
match Desugared.Ast.IdentMap.find_opt x scope_ctxt.var_idmap with
| Some uid -> Bindlib.box (Scopelang.Ast.ELocation (ScopeVar (uid, pos)), pos)
| None -> Name_resolution.raise_unknown_identifier "for a scope-wide variable" (x, pos) )
| None ->
Name_resolution.raise_unknown_identifier "for a local or scope-wide variable" (x, pos)
)
| Some uid ->
Scopelang.Ast.make_var (uid, pos) (* the whole box thing is to accomodate for this case *)
)
| Dotted (e, x) -> (
(* For now we only accept dotted identifiers of the type y.x where y is a sub-scope *)
match Pos.unmark e with
| Ident y ->
| Ident y when Name_resolution.is_subscope_uid scope ctxt y ->
(* In this case, y.x is a subscope variable *)
let subscope_uid : Scopelang.Ast.SubScopeName.t =
Name_resolution.get_subscope_uid scope ctxt (Pos.same_pos_as y e)
in
@ -102,16 +158,192 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t)
(SubScopeVar (subscope_real_uid, (subscope_uid, pos), (subscope_var_uid, pos))),
pos )
| _ ->
Name_resolution.raise_unsupported_feature
"left hand side of a dotted expression should be an\n\n identifier" 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"
(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 )
| FunCall (f, arg) ->
Bindlib.box_apply2
(fun f arg -> (Scopelang.Ast.EApp (f, [ arg ]), pos))
(rec_helper f) (rec_helper arg)
| _ -> Name_resolution.raise_unsupported_feature "unsupported expression" pos
| StructLit (s_name, fields) ->
let s_uid =
try Desugared.Ast.IdentMap.find (Pos.unmark s_name) ctxt.struct_idmap
with Not_found ->
Errors.raise_spanned_error "This identifier should refer to a struct name"
(Pos.get_position s_name)
in
let s_fields =
List.fold_left
(fun s_fields (f_name, f_e) ->
let f_uid =
try
Scopelang.Ast.StructMap.find s_uid
(Desugared.Ast.IdentMap.find (Pos.unmark f_name) ctxt.field_idmap)
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "This identifier should refer to a field of struct %s"
(Pos.unmark s_name))
(Pos.get_position f_name)
in
( 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)) ]
);
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
Bindlib.box_apply
(fun s_fields -> (Scopelang.Ast.EStruct (s_uid, s_fields), pos))
(LiftStructFieldMap.lift_box s_fields)
| EnumInject (constructor, payload) ->
let possible_c_uids =
try Desugared.Ast.IdentMap.find (Pos.unmark constructor) ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error
"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)
| MatchWith (e1, (cases, _cases_pos)) ->
let e1 = translate_expr scope ctxt e1 in
let cases_d, e_uid =
List.fold_left
(fun (cases_d, e_uid) (case, pos_case) ->
match Pos.unmark case.Ast.match_case_pattern with
| [ constructor ], binding ->
let possible_c_uids =
try Desugared.Ast.IdentMap.find (Pos.unmark constructor) ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error
"The name of this constructor has not been defined before, maybe it is a \
typo?"
(Pos.get_position constructor)
in
if e_uid = None && 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 =
match e_uid with
| Some e_uid -> (
( e_uid,
try Scopelang.Ast.EnumMap.find e_uid possible_c_uids
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "This constructor is not part of the %a enumeration"
Scopelang.Ast.EnumName.format_t e_uid)
(Pos.get_position constructor) ) )
| None -> Scopelang.Ast.EnumMap.choose possible_c_uids
in
( match Scopelang.Ast.EnumConstructorMap.find_opt c_uid cases_d with
| None -> ()
| Some e_case ->
Errors.raise_multispanned_error
(Format.asprintf "The constructor %a has been matched twice:"
Scopelang.Ast.EnumConstructor.format_t c_uid)
[
(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 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
in
(Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d, Some e_uid)
| _ :: _, _ ->
Errors.raise_spanned_error
"The deep pattern matching syntactic sugar is not yet supported" pos_case
| [], _ -> assert false
(* should not happen *))
(Scopelang.Ast.EnumConstructorMap.empty, None)
cases
in
Bindlib.box_apply2
(fun e1 cases_d -> (Scopelang.Ast.EMatch (e1, Option.get e_uid, cases_d), pos))
e1
(LiftEnumConstructorMap.lift_box cases_d)
| _ ->
Name_resolution.raise_unsupported_feature "desugaring not implemented for this expression" pos
(* Translation from the parsed ast to the scope language *)
(** {1 Translating scope definitions} *)
(** A scope use can be annotated with a pervasive precondition, in which case this precondition has
to be appended to the justifications of each definition in the subscope use. This is what this
function does. *)
let merge_conditions (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
(cond : Scopelang.Ast.expr Pos.marked Bindlib.box option) (default_pos : Pos.t) :
Scopelang.Ast.expr Pos.marked Bindlib.box =
@ -127,26 +359,24 @@ let merge_conditions (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option
| Some cond, None | None, Some cond -> cond
| None, None -> Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool true), default_pos)
(** Translates a surface definition into condition into a desugared {!type: Desugared.Ast.rule} *)
let process_default (ctxt : Name_resolution.context) (scope : Scopelang.Ast.ScopeName.t)
(def_key : Desugared.Ast.ScopeDef.t) (param_uid : Scopelang.Ast.Var.t Pos.marked option)
(def_key : Desugared.Ast.ScopeDef.t Pos.marked)
(param_uid : Scopelang.Ast.Var.t Pos.marked option)
(precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
(just : Ast.expression Pos.marked option) (cons : Ast.expression Pos.marked) :
Desugared.Ast.rule =
let just =
match just with
| Some just -> Some (translate_expr scope (Some def_key) ctxt just)
| None -> None
in
let just = merge_conditions precond just (Pos.get_position cons) in
let cons = translate_expr scope (Some def_key) ctxt cons in
(exception_to_rule : Desugared.Ast.RuleName.t option) (just : Ast.expression Pos.marked option)
(cons : Ast.expression Pos.marked) : Desugared.Ast.rule =
let just = match just with Some just -> Some (translate_expr scope ctxt just) | None -> None in
let just = merge_conditions precond just (Pos.get_position def_key) in
let cons = translate_expr scope ctxt cons in
{
just;
cons;
parameter =
(let def_key_typ = Name_resolution.get_def_typ ctxt def_key in
(let def_key_typ = Name_resolution.get_def_typ ctxt (Pos.unmark def_key) in
match (Pos.unmark def_key_typ, param_uid) with
| Dcalc.Ast.TArrow (t_in, _), Some param_uid -> Some (Pos.unmark param_uid, t_in)
| Dcalc.Ast.TArrow _, None ->
| Scopelang.Ast.TArrow (t_in, _), Some param_uid -> Some (Pos.unmark param_uid, t_in)
| Scopelang.Ast.TArrow _, None ->
Errors.raise_spanned_error
"this definition has a function type but the parameter is missing"
(Pos.get_position (Bindlib.unbox cons))
@ -155,47 +385,14 @@ let process_default (ctxt : Name_resolution.context) (scope : Scopelang.Ast.Scop
"this definition has a parameter but its type is not a function"
(Pos.get_position (Bindlib.unbox cons))
| _ -> None);
parent_rule =
None (* for now we don't have a priority mechanism in the syntax but it will happen soon *);
exception_to_rule;
}
let add_var_to_def_idmap (ctxt : Name_resolution.context) (scope_uid : Scopelang.Ast.ScopeName.t)
(def_key : Desugared.Ast.ScopeDef.t) (name : string Pos.marked) (var : Scopelang.Ast.Var.t) :
Name_resolution.context =
{
ctxt with
scopes =
Scopelang.Ast.ScopeMap.update scope_uid
(fun scope_ctxt ->
match scope_ctxt with
| Some scope_ctxt ->
Some
{
scope_ctxt with
Name_resolution.definitions =
Desugared.Ast.ScopeDefMap.update def_key
(fun def_ctxt ->
match def_ctxt with
| None -> assert false (* should not happen *)
| Some (def_ctxt : Name_resolution.def_context) ->
Some
{
Name_resolution.var_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark name) var
def_ctxt.Name_resolution.var_idmap;
})
scope_ctxt.Name_resolution.definitions;
}
| None -> assert false
(* should not happen *))
ctxt.scopes;
}
(* Process a definition *)
(** Wrapper around {!val: process_default} that performs some name disambiguation *)
let process_def (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
(scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program) (def : Ast.definition) : Desugared.Ast.program =
let scope : Desugared.Ast.scope = Scopelang.Ast.ScopeMap.find scope_uid prgm in
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 =
@ -219,9 +416,8 @@ let process_def (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
match def.definition_parameter with
| None -> (None, ctxt)
| Some param ->
let param_var = Scopelang.Ast.Var.make param in
( Some (Pos.same_pos_as param_var param),
add_var_to_def_idmap ctxt scope_uid def_key param param_var )
let ctxt, param_var = Name_resolution.add_def_local_var ctxt param in
(Some (Pos.same_pos_as param_var param), ctxt)
in
let scope_updated =
let x_def, x_type =
@ -230,15 +426,29 @@ let process_def (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
| None -> (Desugared.Ast.RuleMap.empty, Name_resolution.get_def_typ ctxt def_key)
in
let rule_name =
Desugared.Ast.RuleName.fresh
(Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
def.definition_name)
match def.Ast.definition_label with
| None -> None
| Some label -> Some (Desugared.Ast.IdentMap.find (Pos.unmark label) scope_ctxt.label_idmap)
in
let rule_name =
match rule_name with
| Some x -> x
| None ->
Desugared.Ast.RuleName.fresh
(Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
def.definition_name)
in
let parent_rule =
match def.Ast.definition_exception_to with
| None -> None
| Some label -> Some (Desugared.Ast.IdentMap.find (Pos.unmark label) scope_ctxt.label_idmap)
in
let x_def =
Desugared.Ast.RuleMap.add rule_name
(process_default new_ctxt scope_uid def_key param_uid precond def.definition_condition
def.definition_expr)
(process_default new_ctxt scope_uid
(def_key, Pos.get_position def.definition_name)
param_uid precond parent_rule def.definition_condition def.definition_expr)
x_def
in
{
@ -246,15 +456,20 @@ let process_def (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
scope_defs = Desugared.Ast.ScopeDefMap.add def_key (x_def, x_type) scope.scope_defs;
}
in
Scopelang.Ast.ScopeMap.add scope_uid scope_updated prgm
{
prgm with
program_scopes = Scopelang.Ast.ScopeMap.add scope_uid scope_updated prgm.program_scopes;
}
(** Process a rule from the surface language *)
(** 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;
@ -263,41 +478,96 @@ let process_rule (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
in
process_def precond scope ctxt prgm def
(** Translates assertions *)
let process_assert (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
(scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program) (ass : Ast.assertion) : Desugared.Ast.program =
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
| 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 ) )
in
let ass =
match precond with
| Some precond ->
Bindlib.box_apply2
(fun precond ass ->
( Scopelang.Ast.EIfThenElse
(precond, ass, Pos.same_pos_as (Scopelang.Ast.ELit (Dcalc.Ast.LBool true)) precond),
Pos.get_position precond ))
precond ass
| None -> ass
in
let new_scope = { scope with scope_assertions = ass :: scope.scope_assertions } in
{ prgm with program_scopes = Scopelang.Ast.ScopeMap.add scope_uid new_scope prgm.program_scopes }
(** Translates a surface definition, rule or assertion *)
let process_scope_use_item (precond : Ast.expression Pos.marked option)
(scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program) (item : Ast.scope_use_item Pos.marked) : Desugared.Ast.program =
let precond = Option.map (translate_expr scope None ctxt) precond in
let precond = Option.map (translate_expr scope ctxt) precond in
match Pos.unmark item with
| Ast.Rule rule -> process_rule precond scope ctxt prgm rule
| Ast.Definition def -> process_def precond scope ctxt prgm def
| Ast.Assertion ass -> process_assert precond scope ctxt prgm ass
| _ -> prgm
(** {1 Translating top-level items} *)
(** 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 =
let name = fst use.scope_use_name in
let scope_uid = Desugared.Ast.IdentMap.find name ctxt.scope_idmap in
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
let scope_vars =
List.fold_left
(fun acc (_, var) -> Scopelang.Ast.ScopeVarSet.add var acc)
Scopelang.Ast.ScopeVarSet.empty
(Desugared.Ast.IdentMap.bindings scope_ctxt.var_idmap)
in
(* Make sure the scope exists *)
let prgm =
match Scopelang.Ast.ScopeMap.find_opt scope_uid prgm with
match Scopelang.Ast.ScopeMap.find_opt scope_uid prgm.program_scopes with
| Some _ -> prgm
| None ->
Scopelang.Ast.ScopeMap.add scope_uid
(Desugared.Ast.empty_scope scope_uid scope_vars scope_ctxt.sub_scopes)
prgm
| None -> assert false
(* should not happen *)
in
let precond = use.scope_use_condition in
List.fold_left (process_scope_use_item precond scope_uid ctxt) prgm use.scope_use_items
(** Scopes processing *)
(** Main function of this module *)
let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desugared.Ast.program =
let empty_prgm = Scopelang.Ast.ScopeMap.empty in
let empty_prgm =
{
Desugared.Ast.program_structs =
Scopelang.Ast.StructMap.map Scopelang.Ast.StructFieldMap.bindings
ctxt.Name_resolution.structs;
Desugared.Ast.program_enums =
Scopelang.Ast.EnumMap.map Scopelang.Ast.EnumConstructorMap.bindings
ctxt.Name_resolution.enums;
Desugared.Ast.program_scopes =
Scopelang.Ast.ScopeMap.mapi
(fun s_uid s_context ->
{
Desugared.Ast.scope_vars =
Desugared.Ast.IdentMap.fold
(fun _ v acc -> Scopelang.Ast.ScopeVarSet.add v acc)
s_context.Name_resolution.var_idmap Scopelang.Ast.ScopeVarSet.empty;
Desugared.Ast.scope_sub_scopes = s_context.Name_resolution.sub_scopes;
Desugared.Ast.scope_defs =
Desugared.Ast.IdentMap.fold
(fun _ v acc ->
Desugared.Ast.ScopeDefMap.add (Desugared.Ast.ScopeDef.Var v)
( Desugared.Ast.RuleMap.empty,
Scopelang.Ast.ScopeVarMap.find v ctxt.Name_resolution.var_typs )
acc)
s_context.Name_resolution.var_idmap Desugared.Ast.ScopeDefMap.empty;
Desugared.Ast.scope_assertions = [];
Desugared.Ast.scope_meta_assertions = [];
Desugared.Ast.scope_uid = s_uid;
})
ctxt.Name_resolution.scopes;
}
in
let processer_article_item (prgm : Desugared.Ast.program) (item : Ast.law_article_item) :
Desugared.Ast.program =
match item with
@ -318,7 +588,7 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desu
| 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 _ -> prgm
| IntermediateText _ | LawInclude _ -> prgm
in
let processer_item (prgm : Desugared.Ast.program) (item : Ast.program_item) :

5
src/catala/catala_surface/dune
View File

@ -1,6 +1,6 @@
(library
(name surface)
(libraries utils menhirLib sedlex re desugared scopelang)
(libraries utils menhirLib sedlex re desugared scopelang zarith odate)
(public_name catala.surface)
(preprocess
(pps sedlex.ppx)))
@ -10,4 +10,5 @@
(flags --table))
(documentation
(package catala))
(package catala)
(mld_files surface))

197
src/catala/catala_surface/lexer.ml
View File

@ -12,21 +12,34 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Concise syntax with English abbreviated keywords. *)
open Parser
open Sedlexing
module Pos = Utils.Pos
module Errors = Utils.Errors
module R = Re.Pcre
(** Boolean reference, used by the lexer as the mutable state to distinguish whether it is lexing
code or law. *)
let is_code : bool ref = ref false
(** 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_string_acc : string ref = ref ""
(** Updates {!val:code_string_acc} with the current lexeme *)
let update_acc (lexbuf : lexbuf) : unit = code_string_acc := !code_string_acc ^ Utf8.lexeme lexbuf
let raise_lexer_error (loc : Pos.t) (token : string) (msg : string) =
Errors.raise_spanned_error (Printf.sprintf "Parsing error on token \"%s\": %s" token msg) loc
(** 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 =
[
("->", ARROW);
@ -38,6 +51,8 @@ let token_list_language_agnostic : (string * token) list =
("=", EQUAL);
("(", LPAREN);
(")", RPAREN);
("{", LBRACKET);
("}", RBRACKET);
("+", PLUS);
("-", MINUS);
("*", MULT);
@ -47,6 +62,8 @@ let token_list_language_agnostic : (string * token) list =
("--", ALT);
]
(** Same as {!val: token_list_language_agnostic}, but with tokens whose string varies with the input
language. *)
let token_list : (string * token) list =
[
("scope", SCOPE);
@ -61,14 +78,17 @@ let token_list : (string * token) list =
("set", COLLECTION);
("enum", ENUM);
("int", INTEGER);
("amount", MONEY);
("money", MONEY);
("text", TEXT);
("decimal", DECIMAL);
("date", DATE);
("duration", DURATION);
("boolean", BOOLEAN);
("sum", SUM);
("ok", FILLED);
("def", DEFINITION);
("label", LABEL);
("exception", EXCEPTION);
("equals", DEFINED_AS);
("match", MATCH);
("with", WITH);
@ -76,7 +96,7 @@ let token_list : (string * token) list =
("if", IF);
("then", THEN);
("else", ELSE);
("type", CONTENT);
("content", CONTENT);
("struct", STRUCT);
("option", OPTIONAL);
("assert", ASSERTION);
@ -97,12 +117,17 @@ let token_list : (string * token) list =
("not", NOT);
("number", CARDINAL);
("year", YEAR);
("month", MONTH);
("day", DAY);
("true", TRUE);
("false", FALSE);
]
@ token_list_language_agnostic
(** Main lexing function used in a code block *)
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 *)
@ -149,7 +174,7 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "int" ->
update_acc lexbuf;
INTEGER
| "amount" ->
| "money" ->
update_acc lexbuf;
MONEY
| "text" ->
@ -161,6 +186,9 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "date" ->
update_acc lexbuf;
DATE
| "duration" ->
update_acc lexbuf;
DURATION
| "bool" ->
update_acc lexbuf;
BOOLEAN
@ -173,13 +201,19 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "def" ->
update_acc lexbuf;
DEFINITION
| "label" ->
update_acc lexbuf;
LABEL
| "exception" ->
update_acc lexbuf;
EXCEPTION
| ":=" ->
update_acc lexbuf;
DEFINED_AS
| "varies" ->
update_acc lexbuf;
VARIES
| "with" ->
| "withv" ->
update_acc lexbuf;
WITH_V
| "match" ->
@ -203,10 +237,10 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "condition" ->
update_acc lexbuf;
CONDITION
| "type" ->
| "content" ->
update_acc lexbuf;
CONTENT
| "structure" ->
| "struct" ->
update_acc lexbuf;
STRUCT
| "option" ->
@ -273,6 +307,12 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "year" ->
update_acc lexbuf;
YEAR
| "month" ->
update_acc lexbuf;
MONTH
| "day" ->
update_acc lexbuf;
DAY
| 0x24, Star white_space, '0' .. '9', Star ('0' .. '9' | ','), Opt ('.', Rep ('0' .. '9', 0 .. 2))
->
let extract_parts = R.regexp "([0-9]([0-9,]*[0-9]|))(.([0-9]{0,2})|)" in
@ -282,8 +322,8 @@ let rec lex_code (lexbuf : lexbuf) : token =
(* Integer literal*)
let units = parts 1 in
let remove_commas = R.regexp "," in
let units = Int64.of_string (R.substitute ~rex:remove_commas ~subst:(fun _ -> "") units) in
let cents = try Int64.of_string (parts 4) with Not_found -> Int64.zero in
let units = Z.of_string (R.substitute ~rex:remove_commas ~subst:(fun _ -> "") units) in
let cents = try Z.of_string (parts 4) with Not_found -> Z.zero in
update_acc lexbuf;
MONEY_AMOUNT (units, cents)
| Plus '0' .. '9', '.', Star '0' .. '9' ->
@ -291,13 +331,94 @@ let rec lex_code (lexbuf : lexbuf) : token =
let dec_parts = R.get_substring (R.exec ~rex:extract_code_title (Utf8.lexeme lexbuf)) in
(* Integer literal*)
update_acc lexbuf;
DECIMAL_LITERAL (Int64.of_string (dec_parts 1), Int64.of_string (dec_parts 2))
DECIMAL_LITERAL (Z.of_string (dec_parts 1), Z.of_string (dec_parts 2))
| "->" ->
update_acc lexbuf;
ARROW
| '.' ->
| "<=@" ->
update_acc lexbuf;
DOT
LESSER_EQUAL_DATE
| "<@" ->
update_acc lexbuf;
LESSER_DATE
| ">=@" ->
update_acc lexbuf;
GREATER_EQUAL_DATE
| ">@" ->
update_acc lexbuf;
GREATER_DATE
| "-@" ->
update_acc lexbuf;
MINUSDATE
| "+@" ->
update_acc lexbuf;
PLUSDATE
| "<=^" ->
update_acc lexbuf;
LESSER_EQUAL_DURATION
| "<^" ->
update_acc lexbuf;
LESSER_DURATION
| ">=^" ->
update_acc lexbuf;
GREATER_EQUAL_DURATION
| ">^" ->
update_acc lexbuf;
GREATER_DURATION
| "+^" ->
update_acc lexbuf;
PLUSDURATION
| "-^" ->
update_acc lexbuf;
MINUSDURATION
| "<=", 0x24 ->
update_acc lexbuf;
LESSER_EQUAL_MONEY
| '<', 0x24 ->
update_acc lexbuf;
LESSER_MONEY
| ">=", 0x24 ->
update_acc lexbuf;
GREATER_EQUAL_MONEY
| '>', 0x24 ->
update_acc lexbuf;
GREATER_MONEY
| '+', 0x24 ->
update_acc lexbuf;
PLUSMONEY
| '-', 0x24 ->
update_acc lexbuf;
MINUSMONEY
| '*', 0x24 ->
update_acc lexbuf;
MULTMONEY
| '/', 0x24 ->
update_acc lexbuf;
DIVMONEY
| "<=." ->
update_acc lexbuf;
LESSER_EQUAL_DEC
| "<." ->
update_acc lexbuf;
LESSER_DEC
| ">=." ->
update_acc lexbuf;
GREATER_EQUAL_DEC
| ">." ->
update_acc lexbuf;
GREATER_DEC
| "+." ->
update_acc lexbuf;
PLUSDEC
| "-." ->
update_acc lexbuf;
MINUSDEC
| "*." ->
update_acc lexbuf;
MULTDEC
| "/." ->
update_acc lexbuf;
DIVDEC
| "<=" ->
update_acc lexbuf;
LESSER_EQUAL
@ -310,18 +431,6 @@ let rec lex_code (lexbuf : lexbuf) : token =
| '>' ->
update_acc lexbuf;
GREATER
| "!=" ->
update_acc lexbuf;
NOT_EQUAL
| '=' ->
update_acc lexbuf;
EQUAL
| '(' ->
update_acc lexbuf;
LPAREN
| ')' ->
update_acc lexbuf;
RPAREN
| '+' ->
update_acc lexbuf;
PLUS
@ -331,12 +440,30 @@ let rec lex_code (lexbuf : lexbuf) : token =
| '*' ->
update_acc lexbuf;
MULT
| '%' ->
update_acc lexbuf;
PERCENT
| '/' ->
update_acc lexbuf;
DIV
| "!=" ->
update_acc lexbuf;
NOT_EQUAL
| '=' ->
update_acc lexbuf;
EQUAL
| '%' ->
update_acc lexbuf;
PERCENT
| '(' ->
update_acc lexbuf;
LPAREN
| ')' ->
update_acc lexbuf;
RPAREN
| '{' ->
update_acc lexbuf;
LBRACKET
| '}' ->
update_acc lexbuf;
RBRACKET
| '|' ->
update_acc lexbuf;
VERTICAL
@ -346,6 +473,9 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "--" ->
update_acc lexbuf;
ALT
| '.' ->
update_acc lexbuf;
DOT
| uppercase, Star (uppercase | lowercase | '0' .. '9' | '_' | '\'') ->
(* Name of constructor *)
update_acc lexbuf;
@ -357,10 +487,13 @@ let rec lex_code (lexbuf : lexbuf) : token =
| Plus '0' .. '9' ->
(* Integer literal*)
update_acc lexbuf;
INT_LITERAL (Int64.of_string (Utf8.lexeme lexbuf))
| _ -> raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
INT_LITERAL (Z.of_string (Utf8.lexeme lexbuf))
| _ -> raise_lexer_error 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 prev_pos = lexing_positions lexbuf in
match%sedlex lexbuf with
| "/*" ->
is_code := true;
@ -415,6 +548,8 @@ let lex_law (lexbuf : lexbuf) : token =
LAW_ARTICLE (title, None, None)
| Plus (Compl ('@' | '/')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
| _ -> raise_lexer_error prev_pos prev_lexeme
(** Entry point of the lexer, distributes to {!val: lex_code} or {!val: lex_law} depending of {!val:
is_code}. *)
let lexer lexbuf = if !is_code then lex_code lexbuf else lex_law lexbuf

168
src/catala/catala_surface/lexer_en.ml
View File

@ -19,6 +19,8 @@ module Errors = Utils.Errors
module L = Lexer
module R = Re.Pcre
(** Same as {!val: Surface.Lexer.token_list_language_agnostic}, but with tokens specialized to
English. *)
let token_list_en : (string * token) list =
[
("scope", SCOPE);
@ -33,14 +35,17 @@ let token_list_en : (string * token) list =
("collection", COLLECTION);
("enumeration", ENUM);
("integer", INTEGER);
("amount", MONEY);
("money", MONEY);
("text", TEXT);
("decimal", DECIMAL);
("date", DATE);
("duration", DURATION);
("boolean", BOOLEAN);
("sum", SUM);
("fulfilled", FILLED);
("definition", DEFINITION);
("label", LABEL);
("exception", EXCEPTION);
("equals", DEFINED_AS);
("match", MATCH);
("with pattern", WITH);
@ -69,12 +74,17 @@ let token_list_en : (string * token) list =
("not", NOT);
("number", CARDINAL);
("year", YEAR);
("month", MONTH);
("day", DAY);
("true", TRUE);
("false", FALSE);
]
@ L.token_list_language_agnostic
(** Main lexing function used in code blocks *)
let rec lex_code_en (lexbuf : lexbuf) : token =
let prev_lexeme = Utf8.lexeme lexbuf in
let prev_pos = lexing_positions lexbuf in
match%sedlex lexbuf with
| white_space ->
(* Whitespaces *)
@ -121,7 +131,7 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "integer" ->
L.update_acc lexbuf;
INTEGER
| "amount" ->
| "money" ->
L.update_acc lexbuf;
MONEY
| "text" ->
@ -133,6 +143,9 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "date" ->
L.update_acc lexbuf;
DATE
| "duration" ->
L.update_acc lexbuf;
DURATION
| "boolean" ->
L.update_acc lexbuf;
BOOLEAN
@ -145,6 +158,12 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "definition" ->
L.update_acc lexbuf;
DEFINITION
| "label" ->
L.update_acc lexbuf;
LABEL
| "exception" ->
L.update_acc lexbuf;
EXCEPTION
| "equals" ->
L.update_acc lexbuf;
DEFINED_AS
@ -245,6 +264,12 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "year" ->
L.update_acc lexbuf;
YEAR
| "month" ->
L.update_acc lexbuf;
MONTH
| "day" ->
L.update_acc lexbuf;
DAY
| 0x24, Star white_space, '0' .. '9', Star ('0' .. '9' | ','), Opt ('.', Rep ('0' .. '9', 0 .. 2))
->
let extract_parts = R.regexp "([0-9]([0-9,]*[0-9]|))(.([0-9]{0,2})|)" in
@ -254,8 +279,8 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
(* Integer literal*)
let units = parts 1 in
let remove_commas = R.regexp "," in
let units = Int64.of_string (R.substitute ~rex:remove_commas ~subst:(fun _ -> "") units) in
let cents = try Int64.of_string (parts 4) with Not_found -> Int64.zero in
let units = Z.of_string (R.substitute ~rex:remove_commas ~subst:(fun _ -> "") units) in
let cents = try Z.of_string (parts 4) with Not_found -> Z.zero in
L.update_acc lexbuf;
MONEY_AMOUNT (units, cents)
| Plus '0' .. '9', '.', Star '0' .. '9' ->
@ -263,13 +288,94 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
let dec_parts = R.get_substring (R.exec ~rex:extract_code_title (Utf8.lexeme lexbuf)) in
(* Integer literal*)
L.update_acc lexbuf;
DECIMAL_LITERAL (Int64.of_string (dec_parts 1), Int64.of_string (dec_parts 2))
DECIMAL_LITERAL (Z.of_string (dec_parts 1), Z.of_string (dec_parts 2))
| "->" ->
L.update_acc lexbuf;
ARROW
| '.' ->
| "<=@" ->
L.update_acc lexbuf;
DOT
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
| "<=", 0x24 ->
L.update_acc lexbuf;
LESSER_EQUAL_MONEY
| '<', 0x24 ->
L.update_acc lexbuf;
LESSER_MONEY
| ">=", 0x24 ->
L.update_acc lexbuf;
GREATER_EQUAL_MONEY
| '>', 0x24 ->
L.update_acc lexbuf;
GREATER_MONEY
| '+', 0x24 ->
L.update_acc lexbuf;
PLUSMONEY
| '-', 0x24 ->
L.update_acc lexbuf;
MINUSMONEY
| '*', 0x24 ->
L.update_acc lexbuf;
MULTMONEY
| '/', 0x24 ->
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
@ -282,18 +388,6 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| '>' ->
L.update_acc lexbuf;
GREATER
| "!=" ->
L.update_acc lexbuf;
NOT_EQUAL
| '=' ->
L.update_acc lexbuf;
EQUAL
| '(' ->
L.update_acc lexbuf;
LPAREN
| ')' ->
L.update_acc lexbuf;
RPAREN
| '+' ->
L.update_acc lexbuf;
PLUS
@ -303,12 +397,30 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| '*' ->
L.update_acc lexbuf;
MULT
| '%' ->
L.update_acc lexbuf;
PERCENT
| '/' ->
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;
VERTICAL
@ -318,6 +430,9 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "--" ->
L.update_acc lexbuf;
ALT
| '.' ->
L.update_acc lexbuf;
DOT
| uppercase, Star (uppercase | lowercase | '0' .. '9' | '_' | '\'') ->
(* Name of constructor *)
L.update_acc lexbuf;
@ -329,10 +444,13 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| Plus '0' .. '9' ->
(* Integer literal*)
L.update_acc lexbuf;
INT_LITERAL (Int64.of_string (Utf8.lexeme lexbuf))
| _ -> L.raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
INT_LITERAL (Z.of_string (Utf8.lexeme lexbuf))
| _ -> L.raise_lexer_error prev_pos prev_lexeme
(** Main lexing function used outside code blocks *)
let lex_law_en (lexbuf : lexbuf) : token =
let prev_lexeme = Utf8.lexeme lexbuf in
let prev_pos = lexing_positions lexbuf in
match%sedlex lexbuf with
| "/*" ->
L.is_code := true;
@ -387,6 +505,6 @@ let lex_law_en (lexbuf : lexbuf) : token =
LAW_ARTICLE (title, None, None)
| Plus (Compl ('@' | '/')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> L.raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
| _ -> L.raise_lexer_error prev_pos prev_lexeme
let lexer_en lexbuf = if !L.is_code then lex_code_en lexbuf else lex_law_en lexbuf

168
src/catala/catala_surface/lexer_fr.ml
View File

@ -19,6 +19,8 @@ module Errors = Utils.Errors
module L = Lexer
module R = Re.Pcre
(** Same as {!val: Surface.Lexer.token_list_language_agnostic}, but with tokens specialized to
French. *)
let token_list_fr : (string * token) list =
[
("champ d'application", SCOPE);
@ -33,10 +35,11 @@ let token_list_fr : (string * token) list =
("collection", COLLECTION);
("énumération", ENUM);
("entier", INTEGER);
("montant", MONEY);
("argent", MONEY);
("texte", TEXT);
("decimal", DECIMAL);
("date", DATE);
("durée", DURATION);
("booléen", BOOLEAN);
("somme", SUM);
("rempli", FILLED);
@ -69,12 +72,17 @@ let token_list_fr : (string * token) list =
("non", NOT);
("nombre", CARDINAL);
("an", YEAR);
("mois", MONTH);
("jour", DAY);
("vrai", TRUE);
("faux", FALSE);
]
@ L.token_list_language_agnostic
(** Main lexing function used in code blocks *)
let rec lex_code_fr (lexbuf : lexbuf) : token =
let prev_lexeme = Utf8.lexeme lexbuf in
let prev_pos = lexing_positions lexbuf in
match%sedlex lexbuf with
| white_space | '\n' ->
(* Whitespaces *)
@ -122,7 +130,7 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| "entier" ->
L.update_acc lexbuf;
INTEGER
| "montant" ->
| "argent" ->
L.update_acc lexbuf;
MONEY
| "texte" ->
@ -134,6 +142,9 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| "date" ->
L.update_acc lexbuf;
DATE
| "dur", 0xE9, "e" ->
L.update_acc lexbuf;
DURATION
| "bool", 0xE9, "en" ->
L.update_acc lexbuf;
BOOLEAN
@ -147,6 +158,12 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
(* 0xE9 is é *)
L.update_acc lexbuf;
DEFINITION
| 0xE9, "tiquette" ->
L.update_acc lexbuf;
LABEL
| "exception" ->
L.update_acc lexbuf;
EXCEPTION
| 0xE9, "gal ", 0x00E0 ->
(* 0xE9 is é *)
L.update_acc lexbuf;
@ -251,6 +268,12 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| "an" ->
L.update_acc lexbuf;
YEAR
| "mois" ->
L.update_acc lexbuf;
MONTH
| "jour" ->
L.update_acc lexbuf;
DAY
| ( '0' .. '9',
Star ('0' .. '9' | white_space),
Opt (',', Rep ('0' .. '9', 0 .. 2)),
@ -263,8 +286,8 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
(* Integer literal*)
let units = parts 1 in
let remove_spaces = R.regexp " " in
let units = Int64.of_string (R.substitute ~rex:remove_spaces ~subst:(fun _ -> "") units) in
let cents = try Int64.of_string (parts 4) with Not_found -> Int64.zero in
let units = Z.of_string (R.substitute ~rex:remove_spaces ~subst:(fun _ -> "") units) in
let cents = try Z.of_string (parts 4) with Not_found -> Z.zero in
L.update_acc lexbuf;
MONEY_AMOUNT (units, cents)
| Plus '0' .. '9', ',', Star '0' .. '9' ->
@ -272,13 +295,94 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
let dec_parts = R.get_substring (R.exec ~rex:extract_code_title (Utf8.lexeme lexbuf)) in
(* Integer literal*)
L.update_acc lexbuf;
DECIMAL_LITERAL (Int64.of_string (dec_parts 1), Int64.of_string (dec_parts 2))
DECIMAL_LITERAL (Z.of_string (dec_parts 1), Z.of_string (dec_parts 2))
| "->" ->
L.update_acc lexbuf;
ARROW
| '.' ->
| "<=@" ->
L.update_acc lexbuf;
DOT
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
| "<=", 0x20AC ->
L.update_acc lexbuf;
LESSER_EQUAL_MONEY
| '<', 0x20AC ->
L.update_acc lexbuf;
LESSER_MONEY
| ">=", 0x20AC ->
L.update_acc lexbuf;
GREATER_EQUAL_MONEY
| '>', 0x20AC ->
L.update_acc lexbuf;
GREATER_MONEY
| '+', 0x20AC ->
L.update_acc lexbuf;
PLUSMONEY
| '-', 0x20AC ->
L.update_acc lexbuf;
MINUSMONEY
| '*', 0x20AC ->
L.update_acc lexbuf;
MULTMONEY
| '/', 0x20AC ->
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
@ -291,18 +395,6 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| '>' ->
L.update_acc lexbuf;
GREATER
| "!=" ->
L.update_acc lexbuf;
NOT_EQUAL
| '=' ->
L.update_acc lexbuf;
EQUAL
| '(' ->
L.update_acc lexbuf;
LPAREN
| ')' ->
L.update_acc lexbuf;
RPAREN
| '+' ->
L.update_acc lexbuf;
PLUS
@ -312,12 +404,30 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| '*' ->
L.update_acc lexbuf;
MULT
| '%' ->
L.update_acc lexbuf;
PERCENT
| '/' ->
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;
VERTICAL
@ -327,6 +437,9 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| "--" ->
L.update_acc lexbuf;
ALT
| '.' ->
L.update_acc lexbuf;
DOT
| uppercase, Star (uppercase | lowercase | '0' .. '9' | '_' | '\'') ->
(* Name of constructor *)
L.update_acc lexbuf;
@ -338,10 +451,13 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| Plus '0' .. '9' ->
(* Integer literal*)
L.update_acc lexbuf;
INT_LITERAL (Int64.of_string (Utf8.lexeme lexbuf))
| _ -> L.raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
INT_LITERAL (Z.of_string (Utf8.lexeme lexbuf))
| _ -> L.raise_lexer_error prev_pos prev_lexeme
(** Main lexing function used outside code blocks *)
let lex_law_fr (lexbuf : lexbuf) : token =
let prev_lexeme = Utf8.lexeme lexbuf in
let prev_pos = lexing_positions lexbuf in
match%sedlex lexbuf with
| "/*" ->
L.is_code := true;
@ -411,7 +527,9 @@ let lex_law_fr (lexbuf : lexbuf) : token =
LAW_ARTICLE (title, article_id, article_expiration_date)
| Plus (Compl ('@' | '/')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> L.raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
| _ -> L.raise_lexer_error prev_pos prev_lexeme
(** Entry point of the lexer, distributes to {!val: lex_code_fr} or {!val: lex_law_fr} depending of
{!val: Surface.Lexer.is_code}. *)
let lexer_fr (lexbuf : lexbuf) : token =
if !L.is_code then lex_code_fr lexbuf else lex_law_fr lexbuf

429
src/catala/catala_surface/name_resolution.ml
View File

@ -18,41 +18,107 @@
module Pos = Utils.Pos
module Errors = Utils.Errors
(** {1 Name resolution context} *)
type ident = string
type typ = Dcalc.Ast.typ
type def_context = { var_idmap : Scopelang.Ast.Var.t Desugared.Ast.IdentMap.t }
(** Inside a definition, local variables can be introduced by functions arguments or pattern
matching *)
type typ = Scopelang.Ast.typ
type scope_context = {
var_idmap : Scopelang.Ast.ScopeVar.t Desugared.Ast.IdentMap.t;
var_idmap : Scopelang.Ast.ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *)
label_idmap : Desugared.Ast.RuleName.t Desugared.Ast.IdentMap.t;
sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Desugared.Ast.IdentMap.t;
(** Sub-scopes variables *)
sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
definitions : def_context Desugared.Ast.ScopeDefMap.t;
(** Contains the local variables in all the definitions *)
(** 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 = {
scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t;
scopes : scope_context Scopelang.Ast.ScopeMap.t;
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 Scopelang.Ast.ScopeVarMap.t;
(** The types of each scope variable declared *)
}
(** Main context used throughout {!module: Surface.Desugaring} *)
(** {1 Helpers} *)
(** Temporary function raising an error message saying that a feature is not supported yet *)
let raise_unsupported_feature (msg : string) (pos : Pos.t) =
Errors.raise_spanned_error (Printf.sprintf "unsupported feature: %s" msg) pos
Errors.raise_spanned_error (Printf.sprintf "Unsupported feature: %s" msg) pos
(** Function to call whenever an identifier used somewhere has not been declared in the program
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" (Pos.unmark ident) msg)
(Pos.get_position ident)
(** Get the type associated to an uid *)
(** Gets the type associated to an uid *)
let get_var_typ (ctxt : context) (uid : Scopelang.Ast.ScopeVar.t) : typ Pos.marked =
Scopelang.Ast.ScopeVarMap.find uid ctxt.var_typs
(** Get the variable uid inside the scope given in argument *)
let get_var_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
((x, pos) : ident Pos.marked) : Scopelang.Ast.ScopeVar.t =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt x scope.var_idmap with
| None -> raise_unknown_identifier "for a var of this scope" (x, pos)
| Some uid -> uid
(** Get the subscope uid inside the scope given in argument *)
let get_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
((y, pos) : ident Pos.marked) : Scopelang.Ast.SubScopeName.t =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt y scope.sub_scopes_idmap with
| None -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
| Some sub_uid -> sub_uid
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the subscopes of [scope_uid]. *)
let is_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context) (y : ident) : bool =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
Desugared.Ast.IdentMap.mem y scope.sub_scopes_idmap
(** Checks if the var_uid belongs to the scope scope_uid *)
let belongs_to (ctxt : context) (uid : Scopelang.Ast.ScopeVar.t)
(scope_uid : Scopelang.Ast.ScopeName.t) : bool =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
Desugared.Ast.IdentMap.exists
(fun _ var_uid -> Scopelang.Ast.ScopeVar.compare uid var_uid = 0)
scope.var_idmap
(** Retrieves the type of a scope definition from the context *)
let get_def_typ (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : typ Pos.marked =
match def with
| Desugared.Ast.ScopeDef.SubScopeVar (_, x)
(* we don't need to look at the subscope prefix because [x] is already the uid referring back to
the original subscope *)
| Desugared.Ast.ScopeDef.Var x ->
Scopelang.Ast.ScopeVarMap.find x ctxt.var_typs
(** {1 Declarations pass} *)
(** Process a subscope declaration *)
let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
(decl : Ast.scope_decl_context_scope) : context =
@ -61,7 +127,7 @@ 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 "Subscope name already used"
[
(Some "first use", Pos.get_position (Scopelang.Ast.SubScopeName.get_info use));
(Some "second use", s_pos);
@ -84,30 +150,46 @@ let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
in
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes }
let process_base_typ ((typ, typ_pos) : Ast.base_typ Pos.marked) : Dcalc.Ast.typ Pos.marked =
(** Process a basic type (all types except function types) *)
let process_base_typ (ctxt : context) ((typ, typ_pos) : Ast.base_typ Pos.marked) :
Scopelang.Ast.typ Pos.marked =
match typ with
| Ast.Condition -> (Dcalc.Ast.TBool, typ_pos)
| Ast.Condition -> (Scopelang.Ast.TLit TBool, typ_pos)
| Ast.Data (Ast.Collection _) -> raise_unsupported_feature "collection type" typ_pos
| Ast.Data (Ast.Optional _) -> raise_unsupported_feature "option type" typ_pos
| Ast.Data (Ast.Primitive prim) -> (
match prim with
| Ast.Integer -> (Dcalc.Ast.TInt, typ_pos)
| Ast.Decimal | Ast.Money | Ast.Date -> raise_unsupported_feature "value type" typ_pos
| Ast.Boolean -> (Dcalc.Ast.TBool, typ_pos)
| Ast.Integer -> (Scopelang.Ast.TLit TInt, typ_pos)
| Ast.Decimal -> (Scopelang.Ast.TLit TRat, typ_pos)
| Ast.Money -> (Scopelang.Ast.TLit TMoney, typ_pos)
| Ast.Duration -> (Scopelang.Ast.TLit TDuration, typ_pos)
| Ast.Date -> (Scopelang.Ast.TLit TDate, typ_pos)
| Ast.Boolean -> (Scopelang.Ast.TLit TBool, typ_pos)
| Ast.Text -> raise_unsupported_feature "text type" typ_pos
| Ast.Named _ -> raise_unsupported_feature "struct or enum types" typ_pos )
| Ast.Named ident -> (
match Desugared.Ast.IdentMap.find_opt ident ctxt.struct_idmap with
| Some s_uid -> (Scopelang.Ast.TStruct s_uid, typ_pos)
| None -> (
match Desugared.Ast.IdentMap.find_opt ident ctxt.enum_idmap with
| 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 ) ) )
let process_type ((typ, typ_pos) : Ast.typ Pos.marked) : Dcalc.Ast.typ Pos.marked =
(** Process a type (function or not) *)
let process_type (ctxt : context) ((typ, typ_pos) : Ast.typ Pos.marked) :
Scopelang.Ast.typ Pos.marked =
match typ with
| Ast.Base base_typ -> process_base_typ (base_typ, typ_pos)
| Ast.Base base_typ -> process_base_typ ctxt (base_typ, typ_pos)
| Ast.Func { arg_typ; return_typ } ->
(Dcalc.Ast.TArrow (process_base_typ arg_typ, process_base_typ return_typ), typ_pos)
( Scopelang.Ast.TArrow (process_base_typ ctxt arg_typ, process_base_typ ctxt return_typ),
typ_pos )
(** Process data declaration *)
let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
(decl : Ast.scope_decl_context_data) : context =
(* First check the type of the context data *)
let data_typ = process_type decl.scope_decl_context_item_typ in
let data_typ = process_type ctxt decl.scope_decl_context_item_typ in
let name, pos = decl.scope_decl_context_item_name in
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt name scope_ctxt.var_idmap with
@ -136,21 +218,16 @@ let process_item_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
| Ast.ContextScope sub_decl -> process_subscope_decl scope ctxt sub_decl
(** Adds a binding to the context *)
let add_def_local_var (ctxt : context) (scope_uid : Scopelang.Ast.ScopeName.t)
(def_uid : Desugared.Ast.ScopeDef.t) (name : ident Pos.marked) : context =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
let def_ctx = Desugared.Ast.ScopeDefMap.find def_uid scope_ctxt.definitions in
let add_def_local_var (ctxt : context) (name : ident Pos.marked) : context * Scopelang.Ast.Var.t =
let local_var_uid = Scopelang.Ast.Var.make name in
let def_ctx =
{ var_idmap = Desugared.Ast.IdentMap.add (Pos.unmark name) local_var_uid def_ctx.var_idmap }
in
let scope_ctxt =
let ctxt =
{
scope_ctxt with
definitions = Desugared.Ast.ScopeDefMap.add def_uid def_ctx scope_ctxt.definitions;
ctxt with
local_var_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark name) local_var_uid ctxt.local_var_idmap;
}
in
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add scope_uid scope_ctxt ctxt.scopes }
(ctxt, local_var_uid)
(** Process a scope declaration *)
let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
@ -173,8 +250,8 @@ let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
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;
definitions = Desugared.Ast.ScopeDefMap.empty;
sub_scopes = Scopelang.Ast.SubScopeMap.empty;
}
ctxt.scopes;
@ -184,72 +261,113 @@ let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
(fun ctxt item -> process_item_decl scope_uid ctxt (Pos.unmark item))
ctxt decl.scope_decl_context
let qident_to_scope_def (ctxt : context) (scope_uid : Scopelang.Ast.ScopeName.t)
(id : Ast.qident Pos.marked) : Desugared.Ast.ScopeDef.t =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match Pos.unmark id with
| [ x ] -> (
match Desugared.Ast.IdentMap.find_opt (Pos.unmark x) scope_ctxt.var_idmap with
| None -> raise_unknown_identifier "for a var of the scope" x
| Some id -> Desugared.Ast.ScopeDef.Var id )
| [ s; x ] -> (
let sub_scope_uid =
match Desugared.Ast.IdentMap.find_opt (Pos.unmark s) scope_ctxt.sub_scopes_idmap with
| None -> raise_unknown_identifier "for a subscope of this scope" s
| Some id -> id
in
let real_sub_scope_uid = Scopelang.Ast.SubScopeMap.find sub_scope_uid scope_ctxt.sub_scopes in
let sub_scope_ctx = Scopelang.Ast.ScopeMap.find real_sub_scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt (Pos.unmark x) sub_scope_ctx.var_idmap with
| None -> raise_unknown_identifier "for a var of this subscope" x
| Some id -> Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_uid, id) )
| _ -> raise_unsupported_feature "wrong qident" (Pos.get_position id)
let process_scope_use (ctxt : context) (use : Ast.scope_use) : context =
let scope_uid =
match Desugared.Ast.IdentMap.find_opt (Pos.unmark use.scope_use_name) ctxt.scope_idmap with
| None -> raise_unknown_identifier "for a scope" use.scope_use_name
| Some id -> id
(** 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
List.fold_left
(fun ctxt use_item ->
match Pos.unmark use_item with
| Ast.Definition def ->
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
let def_uid = qident_to_scope_def ctxt scope_uid def.definition_name in
let def_ctxt = { var_idmap = Desugared.Ast.IdentMap.empty } in
let scope_ctxt =
{
scope_ctxt with
definitions = Desugared.Ast.ScopeDefMap.add def_uid def_ctxt scope_ctxt.definitions;
}
in
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add scope_uid scope_ctxt ctxt.scopes }
| _ -> raise_unsupported_feature "unsupported item" (Pos.get_position use_item))
ctxt use.scope_use_items
(fun ctxt (fdecl, _) ->
let f_uid = Scopelang.Ast.StructFieldName.fresh fdecl.Ast.struct_decl_field_name in
let ctxt =
{
ctxt with
field_idmap =
Desugared.Ast.IdentMap.update
(Pos.unmark fdecl.Ast.struct_decl_field_name)
(fun uids ->
match uids with
| None -> Some (Scopelang.Ast.StructMap.singleton s_uid f_uid)
| Some uids -> Some (Scopelang.Ast.StructMap.add s_uid f_uid uids))
ctxt.field_idmap;
}
in
{
ctxt with
structs =
Scopelang.Ast.StructMap.update s_uid
(fun fields ->
match fields with
| None ->
Some
(Scopelang.Ast.StructFieldMap.singleton f_uid
(process_type ctxt fdecl.Ast.struct_decl_field_typ))
| Some fields ->
Some
(Scopelang.Ast.StructFieldMap.add f_uid
(process_type ctxt fdecl.Ast.struct_decl_field_typ)
fields))
ctxt.structs;
})
ctxt sdecl.struct_decl_fields
(** Process a code item : for now it only handles scope decls *)
let process_use_item (ctxt : context) (item : Ast.code_item Pos.marked) : context =
match Pos.unmark item with
| ScopeDecl _ -> ctxt
| ScopeUse use -> process_scope_use ctxt use
| _ -> raise_unsupported_feature "item not supported" (Pos.get_position item)
(** 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
List.fold_left
(fun ctxt (cdecl, cdecl_pos) ->
let c_uid = Scopelang.Ast.EnumConstructor.fresh cdecl.Ast.enum_decl_case_name in
let ctxt =
{
ctxt with
constructor_idmap =
Desugared.Ast.IdentMap.update
(Pos.unmark cdecl.Ast.enum_decl_case_name)
(fun uids ->
match uids with
| None -> Some (Scopelang.Ast.EnumMap.singleton e_uid c_uid)
| Some uids -> Some (Scopelang.Ast.EnumMap.add e_uid c_uid uids))
ctxt.constructor_idmap;
}
in
{
ctxt with
enums =
Scopelang.Ast.EnumMap.update e_uid
(fun cases ->
let typ =
match cdecl.Ast.enum_decl_case_typ with
| None -> (Scopelang.Ast.TLit TUnit, cdecl_pos)
| Some typ -> process_type ctxt typ
in
match cases with
| None -> Some (Scopelang.Ast.EnumConstructorMap.singleton c_uid typ)
| Some fields -> Some (Scopelang.Ast.EnumConstructorMap.add c_uid typ fields))
ctxt.enums;
})
ctxt edecl.enum_decl_cases
(** Process a code item : for now it only handles scope decls *)
(** 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 ScopeDecl decl -> process_scope_decl ctxt decl | _ -> ctxt
match Pos.unmark item with
| ScopeDecl decl -> process_scope_decl ctxt decl
| StructDecl sdecl -> process_struct_decl ctxt sdecl
| EnumDecl edecl -> process_enum_decl ctxt edecl
| ScopeUse _ -> ctxt
(** Process a code block *)
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 program item *)
(** 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 *)
(** 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
@ -260,20 +378,110 @@ let rec process_law_structure (ctxt : context) (s : Ast.law_structure)
(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 _ -> ctxt
| Ast.IntermediateText _ | Ast.LawInclude _ -> ctxt
(** Process a program item *)
(** 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
(** Derive the context from metadata, in two passes *)
(** {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
(Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
r.rule_name)
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 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
(Pos.map_under_mark
(fun qident -> String.concat "." (List.map (fun i -> Pos.unmark i) qident))
d.definition_name)
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 process_scope_use_item (s_name : Scopelang.Ast.ScopeName.t) (ctxt : context)
(sitem : Ast.scope_use_item Pos.marked) : context =
match Pos.unmark sitem with
| Rule r -> process_rule ctxt s_name r
| Definition d -> process_definition ctxt s_name d
| _ -> ctxt
let process_scope_use (ctxt : context) (suse : Ast.scope_use) : context =
let s_name =
try Desugared.Ast.IdentMap.find (Pos.unmark suse.Ast.scope_use_name) ctxt.scope_idmap
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))
(Pos.get_position suse.Ast.scope_use_name)
in
List.fold_left (process_scope_use_item s_name) ctxt suse.Ast.scope_use_items
let process_use_item (ctxt : context) (item : Ast.code_item Pos.marked) : context =
match Pos.unmark item with
| ScopeDecl _ | StructDecl _ | EnumDecl _ -> ctxt
| ScopeUse suse -> process_scope_use ctxt suse
(** {1 API} *)
(** Derive the context from metadata, in one pass over the declarations *)
let form_context (prgm : Ast.program) : context =
let empty_ctxt =
{
local_var_idmap = Desugared.Ast.IdentMap.empty;
scope_idmap = Desugared.Ast.IdentMap.empty;
scopes = Scopelang.Ast.ScopeMap.empty;
var_typs = Scopelang.Ast.ScopeVarMap.empty;
structs = Scopelang.Ast.StructMap.empty;
struct_idmap = Desugared.Ast.IdentMap.empty;
field_idmap = Desugared.Ast.IdentMap.empty;
enums = Scopelang.Ast.EnumMap.empty;
enum_idmap = Desugared.Ast.IdentMap.empty;
constructor_idmap = Desugared.Ast.IdentMap.empty;
}
in
let ctxt =
@ -281,38 +489,9 @@ let form_context (prgm : Ast.program) : context =
(fun ctxt item -> process_program_item ctxt item process_decl_item)
empty_ctxt prgm.program_items
in
List.fold_left
(fun ctxt item -> process_program_item ctxt item process_use_item)
ctxt prgm.program_items
(** Get the variable uid inside the scope given in argument *)
let get_var_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
((x, pos) : ident Pos.marked) : Scopelang.Ast.ScopeVar.t =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt x scope.var_idmap with
| None -> raise_unknown_identifier "for a var of this scope" (x, pos)
| Some uid -> uid
(** Get the subscope uid inside the scope given in argument *)
let get_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
((y, pos) : ident Pos.marked) : Scopelang.Ast.SubScopeName.t =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt y scope.sub_scopes_idmap with
| None -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
| Some sub_uid -> sub_uid
(** Checks if the var_uid belongs to the scope scope_uid *)
let belongs_to (ctxt : context) (uid : Scopelang.Ast.ScopeVar.t)
(scope_uid : Scopelang.Ast.ScopeName.t) : bool =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
Desugared.Ast.IdentMap.exists
(fun _ var_uid -> Scopelang.Ast.ScopeVar.compare uid var_uid = 0)
scope.var_idmap
let get_def_typ (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : typ Pos.marked =
match def with
| Desugared.Ast.ScopeDef.SubScopeVar (_, x)
(* we don't need to look at the subscope prefix because [x] is already the uid referring back to
the original subscope *)
| Desugared.Ast.ScopeDef.Var x ->
Scopelang.Ast.ScopeVarMap.find x ctxt.var_typs
let ctxt =
List.fold_left
(fun ctxt item -> process_program_item ctxt item process_use_item)
ctxt prgm.program_items
in
ctxt

677
src/catala/catala_surface/parser.messages
View File

File diff suppressed because it is too large Load Diff

120
src/catala/catala_surface/parser.mly
View File

@ -34,26 +34,35 @@
%token<string> LAW_TEXT
%token<string> CONSTRUCTOR IDENT
%token<string> END_CODE
%token<Int64.t> INT_LITERAL
%token<Z.t> INT_LITERAL
%token TRUE FALSE
%token<Int64.t * Int64.t> DECIMAL_LITERAL
%token<Int64.t * Int64.t> MONEY_AMOUNT
%token<Z.t * Z.t> DECIMAL_LITERAL
%token<Z.t * Z.t> MONEY_AMOUNT
%token BEGIN_CODE TEXT MASTER_FILE
%token COLON ALT DATA VERTICAL
%token OF INTEGER COLLECTION
%token RULE CONDITION DEFINED_AS
%token EXISTS IN SUCH THAT NOW LESSER GREATER
%token LESSER GREATER LESSER_EQUAL GREATER_EQUAL
%token LESSER_DEC GREATER_DEC LESSER_EQUAL_DEC GREATER_EQUAL_DEC
%token LESSER_MONEY GREATER_MONEY LESSER_EQUAL_MONEY GREATER_EQUAL_MONEY
%token LESSER_DATE GREATER_DATE LESSER_EQUAL_DATE GREATER_EQUAL_DATE
%token LESSER_DURATION GREATER_DURATION LESSER_EQUAL_DURATION GREATER_EQUAL_DURATION
%token EXISTS IN SUCH THAT NOW
%token DOT AND OR LPAREN RPAREN OPTIONAL EQUAL
%token CARDINAL LESSER_EQUAL GREATER_EQUAL
%token ASSERTION FIXED BY YEAR
%token PLUS MINUS MULT DIV MATCH WITH VARIES WITH_V
%token CARDINAL ASSERTION FIXED BY YEAR MONTH DAY
%token PLUS MINUS MULT DIV
%token PLUSDEC MINUSDEC MULTDEC DIVDEC
%token PLUSMONEY MINUSMONEY MULTMONEY DIVMONEY
%token MINUSDATE PLUSDATE PLUSDURATION MINUSDURATION
%token MATCH WITH VARIES WITH_V
%token FOR ALL WE_HAVE INCREASING DECREASING
%token NOT BOOLEAN PERCENT ARROW
%token NOT BOOLEAN PERCENT ARROW DURATION
%token SCOPE FILLED NOT_EQUAL DEFINITION
%token STRUCT CONTENT IF THEN DEPENDS DECLARATION
%token CONTEXT ENUM ELSE DATE SUM
%token BEGIN_METADATA END_METADATA MONEY DECIMAL
%token UNDER_CONDITION CONSEQUENCE
%token UNDER_CONDITION CONSEQUENCE LBRACKET RBRACKET
%token LABEL EXCEPTION
%type <Ast.source_file_or_master> source_file_or_master
@ -65,6 +74,7 @@ typ_base:
| INTEGER { (Integer, $sloc) }
| BOOLEAN { (Boolean, $sloc) }
| MONEY { (Money, $sloc) }
| DURATION { (Duration, $sloc) }
| TEXT { (Text, $sloc) }
| DECIMAL { (Decimal, $sloc) }
| DATE { (Date, $sloc) }
@ -120,16 +130,15 @@ enum_inject_content:
struct_or_enum_inject_content:
| e = option(enum_inject_content) { EnumContent e }
| CONTENT LPAREN ALT fields = separated_nonempty_list(ALT, struct_content_field) RPAREN {
| LBRACKET ALT fields = separated_nonempty_list(ALT, struct_content_field) RBRACKET {
StructContent fields
}
struct_or_enum_inject:
| c = constructor data = struct_or_enum_inject_content {
match data with
| EnumContent data ->
(EnumInject (c, data), $sloc)
| _ -> assert false (* should not happen *)
| EnumContent data -> (EnumInject (c, data), $sloc)
| StructContent fields -> (StructLit (c, fields), $sloc)
}
primitive_expression:
@ -152,9 +161,11 @@ num_literal:
unit_literal:
| PERCENT { (Percent, $sloc) }
| YEAR { (Year, $sloc)}
| MONTH { (Month, $sloc) }
| DAY { (Day, $sloc) }
date_int:
| d = INT_LITERAL { (Int64.to_int d, $sloc) }
| d = INT_LITERAL { (Z.to_int d, $sloc) }
literal:
| l = num_literal u = option(unit_literal) {
@ -178,10 +189,26 @@ literal:
| FALSE { (Bool false, $sloc) }
compare_op:
| LESSER { (Lt, $sloc) }
| LESSER_EQUAL { (Lte, $sloc) }
| GREATER { (Gt, $sloc) }
| GREATER_EQUAL { (Gte, $sloc) }
| LESSER { (Lt KInt, $sloc) }
| LESSER_EQUAL { (Lte KInt, $sloc) }
| GREATER { (Gt KInt, $sloc) }
| GREATER_EQUAL { (Gte KInt, $sloc) }
| LESSER_DEC { (Lt KDec, $sloc) }
| LESSER_EQUAL_DEC { (Lte KDec, $sloc) }
| GREATER_DEC { (Gt KDec, $sloc) }
| GREATER_EQUAL_DEC { (Gte KDec, $sloc) }
| LESSER_MONEY { (Lt KMoney, $sloc) }
| LESSER_EQUAL_MONEY { (Lte KMoney, $sloc) }
| GREATER_MONEY { (Gt KMoney, $sloc) }
| GREATER_EQUAL_MONEY { (Gte KMoney, $sloc) }
| LESSER_DATE { (Lt KDate, $sloc) }
| LESSER_EQUAL_DATE { (Lte KDate, $sloc) }
| GREATER_DATE { (Gt KDate, $sloc) }
| GREATER_EQUAL_DATE { (Gte KDate, $sloc) }
| LESSER_DURATION { (Lt KDuration, $sloc) }
| LESSER_EQUAL_DURATION { (Lte KDuration, $sloc) }
| GREATER_DURATION { (Gt KDuration, $sloc) }
| GREATER_EQUAL_DURATION { (Gte KDuration, $sloc) }
| EQUAL { (Eq, $sloc) }
| NOT_EQUAL { (Neq, $sloc) }
@ -209,8 +236,12 @@ base_expression:
}
mult_op:
| MULT { (Mult, $sloc) }
| DIV { (Div, $sloc) }
| MULT { (Mult KInt, $sloc) }
| DIV { (Div KInt, $sloc) }
| MULTDEC { (Mult KDec, $sloc) }
| DIVDEC { (Div KDec, $sloc) }
| MULTMONEY { (Mult KMoney, $sloc) }
| DIVMONEY { (Div KMoney, $sloc) }
mult_expression:
| e = base_expression { e }
@ -219,11 +250,22 @@ mult_expression:
}
sum_op:
| PLUS { (Add, $sloc) }
| MINUS { (Sub, $sloc) }
| PLUSDURATION { (Add KDuration, $sloc) }
| MINUSDURATION { (Sub KDuration, $sloc) }
| PLUSDATE { (Add KDate, $sloc) }
| MINUSDATE { (Sub KDate, $sloc) }
| PLUSMONEY { (Add KMoney, $sloc) }
| MINUSMONEY { (Sub KMoney, $sloc) }
| PLUSDEC { (Add KDec, $sloc) }
| MINUSDEC { (Sub KDec, $sloc) }
| PLUS { (Add KInt, $sloc) }
| MINUS { (Sub KInt, $sloc) }
sum_unop:
| MINUS { (Minus, $sloc) }
| MINUS { (Minus KInt, $sloc) }
| MINUSDEC { (Minus KDec, $sloc) }
| MINUSMONEY { (Minus KMoney, $sloc) }
| MINUSDURATION { (Minus KDuration, $sloc) }
sum_expression:
| e = mult_expression { e }
@ -330,11 +372,16 @@ rule_consequence:
}
rule:
| name_and_param = rule_expr cond = option(condition_consequence)
| 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
({
rule_label = label;
rule_exception_to = except;
rule_parameter = param_applied;
rule_condition = cond;
rule_name = name;
@ -345,10 +392,21 @@ rule:
definition_parameters:
| OF i = ident { i }
label:
| LABEL i = ident { i }
exception_to:
| EXCEPTION i = ident { i }
definition:
| name = qident param = option(definition_parameters)
| label = option(label)
except = option(exception_to)
DEFINITION
name = qident param = option(definition_parameters)
cond = option(condition_consequence) DEFINED_AS e = expression {
({
definition_label = label;
definition_exception_to = except;
definition_name = name;
definition_parameter = param;
definition_condition = cond;
@ -376,10 +434,10 @@ assertion:
}
scope_item:
| RULE r = rule {
| r = rule {
let (r, _) = r in (Rule r, $sloc)
}
| DEFINITION d = definition {
| d = definition {
let (d, _) = d in (Definition d, $sloc)
}
| ASSERTION contents = assertion {
@ -505,9 +563,6 @@ law_article_item:
let (code, pos) = code_and_pos in
CodeBlock (code, (text, pos))
}
| includ = LAW_INCLUDE {
LawInclude includ
}
law_article:
| title = LAW_ARTICLE {
@ -549,6 +604,9 @@ source_file_item:
let (code, source_repr) = code in
LawStructure (MetadataBlock (code, source_repr))
}
| includ = LAW_INCLUDE {
LawStructure (LawInclude includ)
}
source_file_after_text:
| i = source_file_article f = source_file_after_text {
@ -591,7 +649,7 @@ source_file_or_master:
| [] -> assert false (* there should be at least one rest element *)
| rest_head::rest_tail ->
begin match first_item with
| LawStructure (LawArticle _ | MetadataBlock _ | IntermediateText _) ->
| LawStructure (LawArticle _ | MetadataBlock _ | IntermediateText _ | LawInclude _) ->
(* if an article or an include is just before a new heading or a new article,
then we don't merge it with what comes next *)
first_item::rest_head::rest_tail

160
src/catala/catala_surface/parser_driver.ml
View File

@ -12,20 +12,27 @@
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
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
module I = Parser.MenhirInterpreter
(** {1 Internal functions} *)
(** 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
(** Computes the levenshtein distance between two strings *)
(** 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
@ -53,19 +60,33 @@ let levenshtein_distance (s : string) (t : string) : int =
d.(m).(n)
(** 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)
( ( match last_good_loc with
| None -> []
| Some last_good_loc -> [ (Some "Last good token:", last_good_loc) ] )
@ [ (Some "Error token:", error_loc) ] )
( (Some "Error token:", error_loc)
::
( match last_good_loc with
| None -> []
| Some last_good_loc -> [ (Some "Last good token:", last_good_loc) ] ) )
(** 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.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 * Parser.token) list)
(last_input_needed : 'semantic_value I.env option) : 'a =
let wrong_token = Utf8.lexeme lexbuf in
@ -97,7 +118,6 @@ let fail (lexbuf : lexbuf) (env : 'semantic_value I.env) (token_list : (string *
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
@ -125,6 +145,7 @@ let fail (lexbuf : lexbuf) (env : 'semantic_value I.env) (token_list : (string *
in
raise_parser_error (lexing_positions lexbuf) last_positions (Utf8.lexeme lexbuf) msg
(** Main parsing loop *)
let rec loop (next_token : unit -> Parser.token * Lexing.position * Lexing.position)
(token_list : (string * Parser.token) list) (lexbuf : lexbuf)
(last_input_needed : 'semantic_value I.env option) (checkpoint : 'semantic_value I.checkpoint) :
@ -143,6 +164,8 @@ let rec loop (next_token : unit -> Parser.token * Lexing.position * Lexing.posit
(* 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 -> Parser.token) (token_list : (string * Parser.token) list)
(target_rule : Lexing.position -> 'semantic_value I.checkpoint) (lexbuf : lexbuf) :
Ast.source_file_or_master =
@ -151,54 +174,91 @@ let sedlex_with_menhir (lexer' : lexbuf -> Parser.token) (token_list : (string *
in
try loop lexer token_list lexbuf None (target_rule (fst @@ Sedlexing.lexing_positions lexbuf))
with Sedlexing.MalFormed | Sedlexing.InvalidCodepoint _ ->
Lexer.raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "malformed token"
Lexer.raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf)
let rec parse_source_files (source_files : string list) (language : Cli.frontend_lang) : Ast.program
=
match source_files with
| [] -> { program_items = []; program_source_files = [] }
| source_file :: rest -> (
Cli.debug_print (Printf.sprintf "Parsing %s" source_file);
let input = try open_in source_file with Sys_error msg -> Errors.raise_error msg in
let lexbuf = Sedlexing.Utf8.from_channel input in
Sedlexing.set_filename lexbuf source_file;
Parse_utils.current_file := source_file;
let lexer_lang =
match language with
| `Fr -> Lexer_fr.lexer_fr
| `En -> Lexer_en.lexer_en
| `NonVerbose -> Lexer.lexer
(** {1 API} *)
(** Parses a single source file *)
let rec parse_source_file (source_file : string) (language : Cli.frontend_lang) : Ast.program =
Cli.debug_print (Printf.sprintf "Parsing %s" source_file);
let input = try open_in source_file with Sys_error msg -> Errors.raise_error msg in
let lexbuf = Sedlexing.Utf8.from_channel input in
Sedlexing.set_filename lexbuf source_file;
Parse_utils.current_file := source_file;
let lexer_lang =
match language with
| `Fr -> Lexer_fr.lexer_fr
| `En -> Lexer_en.lexer_en
| `NonVerbose -> Lexer.lexer
in
let token_list_lang =
match language with
| `Fr -> Lexer_fr.token_list_fr
| `En -> Lexer_en.token_list_en
| `NonVerbose -> Lexer.token_list
in
let commands_or_includes =
sedlex_with_menhir lexer_lang token_list_lang Parser.Incremental.source_file_or_master lexbuf
in
close_in input;
match commands_or_includes with
| Ast.SourceFile commands ->
let program = expand_includes source_file commands language in
{
program_items = program.Ast.program_items;
program_source_files = source_file :: program.Ast.program_source_files;
}
| Ast.MasterFile includes ->
let current_source_file_dirname = Filename.dirname source_file in
let includes =
List.map
(fun includ ->
(if current_source_file_dirname = "./" then "" else current_source_file_dirname ^ "/")
^ Pos.unmark includ)
includes
in
let token_list_lang =
match language with
| `Fr -> Lexer_fr.token_list_fr
| `En -> Lexer_en.token_list_en
| `NonVerbose -> Lexer.token_list
let new_program =
List.fold_left
(fun acc includ_file ->
let includ_program = parse_source_file includ_file 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.program_source_files = []; Ast.program_items = [] }
includes
in
let commands_or_includes =
sedlex_with_menhir lexer_lang token_list_lang Parser.Incremental.source_file_or_master
lexbuf
in
close_in input;
match commands_or_includes with
| Ast.SourceFile commands ->
let rest_program = parse_source_files rest language in
{ new_program with program_source_files = source_file :: new_program.program_source_files }
(** Expands the include directives in a parsing result, thus parsing new source files *)
and expand_includes (source_file : string) (commands : Ast.program_item list)
(language : Cli.frontend_lang) : Ast.program =
List.fold_left
(fun acc command ->
match command with
| Ast.LawStructure (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 sub_source language in
{
program_items = commands @ rest_program.Ast.program_items;
program_source_files = source_file :: rest_program.Ast.program_source_files;
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.MasterFile includes ->
let current_source_file_dirname = Filename.dirname source_file in
let includes =
List.map
(fun includ ->
( if current_source_file_dirname = "./" then ""
else current_source_file_dirname ^ "/" )
^ Pos.unmark includ)
includes
| Ast.LawStructure (Ast.LawHeading (heading, commands')) ->
let { Ast.program_items = commands'; Ast.program_source_files = new_sources } =
expand_includes source_file (List.map (fun x -> Ast.LawStructure x) commands') language
in
let new_program = parse_source_files (includes @ rest) language in
{
new_program with
program_source_files = source_file :: new_program.program_source_files;
} )
Ast.program_source_files = acc.Ast.program_source_files @ new_sources;
Ast.program_items =
acc.Ast.program_items
@ [
Ast.LawStructure
(Ast.LawHeading (heading, List.map (fun (Ast.LawStructure x) -> x) commands'));
];
}
| i -> { acc with Ast.program_items = acc.Ast.program_items @ [ i ] })
{ Ast.program_source_files = []; Ast.program_items = [] }
commands

260
src/catala/catala_surface/parser_errors.ml
View File

@ -11,152 +11,146 @@ let message s =
| 7 ->
"expected another inclusion of a Catala file, since this file is a master file which can \
only contain inclusions of other Catala files\n"
| 283 -> "expected some text, another heading or a law article\n"
| 288 -> "expected a code block, a metadata block, more law text or a heading\n"
| 295 -> "expected a code block, a metadata block, more law text or a heading\n"
| 290 -> "expected a declaration or a scope use\n"
| 21 -> "expected the name of the scope you want to use\n"
| 23 -> "expected a scope use precondition or a colon\n"
| 24 -> "expected an expression which will act as the condition\n"
| 25 -> "expected the first component of the date literal\n"
| 27 -> "expected a \"/\"\n"
| 28 -> "expected the second component of the date literal\n"
| 29 -> "expected a \"/\"\n"
| 30 -> "expected the third component of the date literal\n"
| 31 -> "expected a delimiter to finish the date literal\n"
| 53 -> "expected an operator to compose the expression on the left with\n"
| 59 -> "expected an enum constructor to test if the expression on the left\n"
| 58 -> "expected an operator to compose the expression on the left with\n"
| 89 -> "expected an expression on the right side of the sum or minus operator\n"
| 113 -> "expected an expression on the right side of the logical operator\n"
| 61 -> "expected an expression for the argument of this function call\n"
| 85 -> "expected an expression on the right side of the comparison operator\n"
| 94 -> "expected an expression on the right side of the multiplication or division operator\n"
| 91 -> "expected an operator to compose the expression on the left\n"
| 140 -> "expected an expression standing for the set you want to test for membership\n"
| 54 -> "expected an identifier standing for a struct field or a subscope name\n"
| 164 -> "expected a colon after the scope use precondition\n"
| 56 -> "expected a constructor, to get the payload of this enum case\n"
| 97 -> "expected the \"for\" keyword to spell the aggregation\n"
| 98 -> "expected an identifier for the aggregation bound variable\n"
| 99 -> "expected the \"in\" keyword\n"
| 100 ->
| 326 -> "expected some text, another heading or a law article\n"
| 331 -> "expected a code block, a metadata block, more law text or a heading\n"
| 337 -> "expected a code block, a metadata block, more law text or a heading\n"
| 332 -> "expected a declaration or a scope use\n"
| 22 -> "expected the name of the scope you want to use\n"
| 24 -> "expected a scope use precondition or a colon\n"
| 25 -> "expected an expression which will act as the condition\n"
| 26 -> "expected the first component of the date literal\n"
| 28 -> "expected a \"/\"\n"
| 29 -> "expected the second component of the date literal\n"
| 30 -> "expected a \"/\"\n"
| 31 -> "expected the third component of the date literal\n"
| 32 -> "expected a delimiter to finish the date literal\n"
| 57 -> "expected an operator to compose the expression on the left with\n"
| 63 -> "expected an enum constructor to test if the expression on the left\n"
| 62 -> "expected an operator to compose the expression on the left with\n"
| 118 -> "expected an expression on the right side of the sum or minus operator\n"
| 146 -> "expected an expression on the right side of the logical operator\n"
| 65 -> "expected an expression for the argument of this function call\n"
| 106 -> "expected an expression on the right side of the comparison operator\n"
| 127 -> "expected an expression on the right side of the multiplication or division operator\n"
| 120 -> "expected an operator to compose the expression on the left\n"
| 156 -> "expected an expression standing for the set you want to test for membership\n"
| 58 -> "expected an identifier standing for a struct field or a subscope name\n"
| 198 -> "expected a colon after the scope use precondition\n"
| 60 -> "expected a constructor, to get the payload of this enum case\n"
| 130 -> "expected the \"for\" keyword to spell the aggregation\n"
| 131 -> "expected an identifier for the aggregation bound variable\n"
| 132 -> "expected the \"in\" keyword\n"
| 133 ->
"expected an expression standing for the set over which to compute the aggregation operation\n"
| 102 -> "expected the \"for\" keyword and the expression to compute the aggregate\n"
| 103 -> "expected an expression to compute its aggregation over the set\n"
| 107 -> "expected an expression to take the negation of\n"
| 50 -> "expected an expression to take the opposite of\n"
| 39 -> "expected an expression to match with\n"
| 148 -> "expected a pattern matching case\n"
| 149 -> "expected the name of the constructor for the enum case in the pattern matching\n"
| 155 ->
| 135 -> "expected the \"for\" keyword and the expression to compute the aggregate\n"
| 136 -> "expected an expression to compute its aggregation over the set\n"
| 140 -> "expected an expression to take the negation of\n"
| 54 -> "expected an expression to take the opposite of\n"
| 43 -> "expected an expression to match with\n"
| 182 -> "expected a pattern matching case\n"
| 183 -> "expected the name of the constructor for the enum case in the pattern matching\n"
| 189 ->
"expected a binding for the constructor payload, or a colon and the matching case expression\n"
| 156 -> "expected an identifier for this enum case binding\n"
| 152 -> "expected a colon and then the expression for this matching case\n"
| 158 -> "expected a colon or a binding for the enum constructor payload\n"
| 153 -> "expected an expression for this pattern matching case\n"
| 150 ->
| 190 -> "expected an identifier for this enum case binding\n"
| 186 -> "expected a colon and then the expression for this matching case\n"
| 192 -> "expected a colon or a binding for the enum constructor payload\n"
| 187 -> "expected an expression for this pattern matching case\n"
| 184 ->
"expected another match case or the rest of the expression since the previous match case is \
complete\n"
| 147 -> "expected the \"with patter\" keyword to complete the pattern matching expression\n"
| 40 -> "expected an expression inside the parenthesis\n"
| 133 -> "unmatched parenthesis that should have been closed by here\n"
| 62 -> "expected a unit for this literal, or a valid operator to complete the expression \n"
| 42 -> "expected an expression for the test of the conditional\n"
| 143 -> "expected an expression the for the \"then\" branch of the conditiona\n"
| 144 ->
| 181 -> "expected the \"with patter\" keyword to complete the pattern matching expression\n"
| 44 -> "expected an expression inside the parenthesis\n"
| 179 -> "unmatched parenthesis that should have been closed by here\n"
| 66 -> "expected a unit for this literal, or a valid operator to complete the expression \n"
| 46 -> "expected an expression for the test of the conditional\n"
| 175 -> "expected an expression the for the \"then\" branch of the conditiona\n"
| 176 ->
"expected the \"else\" branch of this conditional expression as the \"then\" branch is \
complete\n"
| 145 -> "expected an expression for the \"else\" branch of this conditional construction\n"
| 142 -> "expected the \"then\" keyword as the conditional expression is complete\n"
| 44 ->
| 177 -> "expected an expression for the \"else\" branch of this conditional construction\n"
| 174 -> "expected the \"then\" keyword as the conditional expression is complete\n"
| 48 ->
"expected the \"all\" keyword to mean the \"for all\" construction of the universal test\n"
| 119 -> "expected an identifier for the bound variable of the universal test\n"
| 120 -> "expected the \"in\" keyword for the rest of the universal test\n"
| 121 -> "expected the expression designating the set on which to perform the universal test\n"
| 122 -> "expected the \"we have\" keyword for this universal test\n"
| 118 -> "expected an expression for the universal test\n"
| 127 -> "expected an identifier that will designate the existential witness for the test\n"
| 128 -> "expected the \"in\" keyword to continue this existential test\n"
| 129 -> "expected an expression that designates the set subject to the existential test\n"
| 130 -> "expected a keyword to form the \"such that\" expression for the existential test\n"
| 131 -> "expected a keyword to complete the \"such that\" construction\n"
| 125 -> "expected an expression for the existential test\n"
| 69 ->
| 160 -> "expected an identifier for the bound variable of the universal test\n"
| 161 -> "expected the \"in\" keyword for the rest of the universal test\n"
| 162 -> "expected the expression designating the set on which to perform the universal test\n"
| 163 -> "expected the \"we have\" keyword for this universal test\n"
| 159 -> "expected an expression for the universal test\n"
| 168 -> "expected an identifier that will designate the existential witness for the test\n"
| 169 -> "expected the \"in\" keyword to continue this existential test\n"
| 170 -> "expected an expression that designates the set subject to the existential test\n"
| 171 -> "expected a keyword to form the \"such that\" expression for the existential test\n"
| 172 -> "expected a keyword to complete the \"such that\" construction\n"
| 166 -> "expected an expression for the existential test\n"
| 75 ->
"expected a payload for the enum case constructor, or the rest of the expression (with an \
operator ?)\n"
| 70 -> "expected an expression for the content of this enum case\n"
| 135 ->
| 150 -> "expected an expression for the content of this enum case\n"
| 151 ->
"the expression for the content of the enum case is already well-formed, expected an \
operator to form a bigger expression\n"
| 71 -> "expected a struct field creation introduced by a dash\n"
| 72 -> "expected the name of field of the struct that you are building\n"
| 76 -> "expected a colon and then the expression for the field of the struct\n"
| 77 -> "expected an expression for the field of the struct\n"
| 73 -> "expected another field of the struct or the end of the struct literal\n"
| 74 -> "expected another field of the struct\n"
| 49 -> "expected the keyword following cardinal to compute the number of elements in a set\n"
| 165 -> "expected a scope use item: a rule, definition or assertion\n"
| 166 -> "expected the name of the variable subject to the rule\n"
| 185 ->
| 53 -> "expected the keyword following cardinal to compute the number of elements in a set\n"
| 199 -> "expected a scope use item: a rule, definition or assertion\n"
| 234 -> "expected the name of the variable subject to the rule\n"
| 212 ->
"expected a condition or a consequence for this rule, or the rest of the variable qualified \
name\n"
| 180 -> "expected a condition or a consequence for this rule\n"
| 171 -> "expected filled or not filled for a rule consequence\n"
| 181 -> "expected the name of the parameter for this dependent variable \n"
| 168 -> "expected the expression of the rule\n"
| 174 -> "expected the filled keyword the this rule \n"
| 186 -> "expected a struct field or a sub-scope context item after the dot\n"
| 188 -> "expected the name of the variable you want to define\n"
| 189 -> "expected the defined as keyword to introduce the definition of this variable\n"
| 191 -> "expected an expression for the consequence of this definition under condition\n"
| 190 ->
| 241 -> "expected a condition or a consequence for this rule\n"
| 236 -> "expected filled or not filled for a rule consequence\n"
| 242 -> "expected the name of the parameter for this dependent variable \n"
| 235 -> "expected the expression of the rule\n"
| 239 -> "expected the filled keyword the this rule \n"
| 213 -> "expected a struct field or a sub-scope context item after the dot\n"
| 246 -> "expected the name of the variable you want to define\n"
| 247 -> "expected the defined as keyword to introduce the definition of this variable\n"
| 249 -> "expected an expression for the consequence of this definition under condition\n"
| 248 ->
"expected a expression for defining this function, introduced by the defined as keyword\n"
| 192 -> "expected an expression for the definition\n"
| 195 -> "expected an expression that shoud be asserted during execution\n"
| 196 -> "expecting the name of the varying variable\n"
| 198 -> "the variable varies with an expression that was expected here\n"
| 199 -> "expected an indication about the variation sense of the variable, or a new scope item\n"
| 197 -> "expected an indication about what this variable varies with\n"
| 169 -> "expected an expression for this condition\n"
| 177 -> "expected a consequence for this definition under condition\n"
| 208 -> "expected an expression for this definition under condition\n"
| 204 -> "expected the name of the variable that should be fixed\n"
| 205 -> "expected the legislative text by which the value of the variable is fixed\n"
| 206 -> "expected the legislative text by which the value of the variable is fixed\n"
| 212 -> "expected a new scope use item \n"
| 215 -> "expected the kind of the declaration (struct, scope or enum)\n"
| 216 -> "expected the struct name\n"
| 217 -> "expected a colon\n"
| 218 -> "expected struct data or condition\n"
| 219 -> "expected the name of this struct data \n"
| 220 -> "expected the type of this struct data, introduced by the content keyword\n"
| 221 -> "expected the type of this struct data\n"
| 245 -> "expected the name of this struct condition\n"
| 238 -> "expected a new struct data, or another declaration or scope use\n"
| 239 -> "expected the type of the parameter of this struct data function\n"
| 243 -> "expected a new struct data, or another declaration or scope use\n"
| 232 -> "expected a new struct data, or another declaration or scope use\n"
| 235 -> "expected a new struct data, or another declaration or scope use\n"
| 248 -> "expected the name of the scope you are declaring\n"
| 249 -> "expected a colon followed by the list of context items of this scope\n"
| 250 -> "expected a context item introduced by \"context\"\n"
| 251 -> "expected the name of this new context item\n"
| 252 -> "expected the kind of this context item: is it a condition, a sub-scope or a data?\n"
| 253 -> "expected the name of the subscope for this context item\n"
| 260 -> "expected the next context item, or another declaration or scope use\n"
| 255 -> "expected the type of this context item\n"
| 256 -> "expected the next context item or a dependency declaration for this item\n"
| 258 -> "expected the next context item or a dependency declaration for this item\n"
| 263 -> "expected the name of your enum\n"
| 264 -> "expected a colon\n"
| 265 -> "expected an enum case\n"
| 266 -> "expected the name of an enum case \n"
| 267 -> "expected a payload for your enum case, or another case or declaration \n"
| 268 -> "expected a content type\n"
| 273 -> "expected another enum case, or a new declaration or scope use\n"
| 17 -> "expected a declaration or a scope use\n"
| 19 -> "expected a declaration or a scope use\n"
| 279 ->
| 250 -> "expected an expression for the definition\n"
| 202 -> "expected an expression that shoud be asserted during execution\n"
| 203 -> "expecting the name of the varying variable\n"
| 206 -> "the variable varies with an expression that was expected here\n"
| 207 -> "expected an indication about the variation sense of the variable, or a new scope item\n"
| 205 -> "expected an indication about what this variable varies with\n"
| 215 -> "expected an expression for this condition\n"
| 225 -> "expected a consequence for this definition under condition\n"
| 221 -> "expected an expression for this definition under condition\n"
| 217 -> "expected the name of the variable that should be fixed\n"
| 218 -> "expected the legislative text by which the value of the variable is fixed\n"
| 219 -> "expected the legislative text by which the value of the variable is fixed\n"
| 228 -> "expected a new scope use item \n"
| 257 -> "expected the kind of the declaration (struct, scope or enum)\n"
| 258 -> "expected the struct name\n"
| 259 -> "expected a colon\n"
| 260 -> "expected struct data or condition\n"
| 261 -> "expected the name of this struct data \n"
| 262 -> "expected the type of this struct data, introduced by the content keyword\n"
| 263 -> "expected the type of this struct data\n"
| 288 -> "expected the name of this struct condition\n"
| 281 -> "expected a new struct data, or another declaration or scope use\n"
| 282 -> "expected the type of the parameter of this struct data function\n"
| 286 -> "expected a new struct data, or another declaration or scope use\n"
| 275 -> "expected a new struct data, or another declaration or scope use\n"
| 278 -> "expected a new struct data, or another declaration or scope use\n"
| 291 -> "expected the name of the scope you are declaring\n"
| 292 -> "expected a colon followed by the list of context items of this scope\n"
| 293 -> "expected a context item introduced by \"context\"\n"
| 294 -> "expected the name of this new context item\n"
| 295 -> "expected the kind of this context item: is it a condition, a sub-scope or a data?\n"
| 296 -> "expected the name of the subscope for this context item\n"
| 303 -> "expected the next context item, or another declaration or scope use\n"
| 298 -> "expected the type of this context item\n"
| 299 -> "expected the next context item or a dependency declaration for this item\n"
| 301 -> "expected the next context item or a dependency declaration for this item\n"
| 306 -> "expected the name of your enum\n"
| 307 -> "expected a colon\n"
| 308 -> "expected an enum case\n"
| 309 -> "expected the name of an enum case \n"
| 310 -> "expected a payload for your enum case, or another case or declaration \n"
| 311 -> "expected a content type\n"
| 316 -> "expected another enum case, or a new declaration or scope use\n"
| 18 -> "expected a declaration or a scope use\n"
| 20 -> "expected a declaration or a scope use\n"
| 322 ->
"should not happen, please file an issue at https://github.com/CatalaLang/catala/issues\n"
| _ -> raise Not_found

77
src/catala/catala_surface/surface.mld Normal file
View File

@ -0,0 +1,77 @@
{0 Catala surface representation }
This representation is the first in the compilation chain
(see {{: index.html#architecture} Architecture}). Its purpose is to
host the output of the Catala parser, before any transformations have been made.
The module describing the abstract syntax tree is:
{!modules: Surface.Ast}
This representation can also be weaved into literate programming outputs
using the {{:literate.html} literate programming modules}.
{1 Lexing }
Relevant modules:
{!modules: Surface.Lexer Surface.Lexer_fr Surface.Lexer_en}
The lexing in the Catala compiler is done using
{{: https://github.com/ocaml-community/sedlex} sedlex}, the modern OCaml lexer
that offers full support for UTF-8. This support enables users of non-English
languages to use their favorite diacritics and symbols in their code.
While the parser of Catala is unique, three different lexers can be used to
produce the parser tokens.
{ul
{li {!module: Surface.Lexer} corresponds to a concise and programming-language-like
syntax for Catala. Examples of this syntax can be found in the test suite
of the compiler.}
{li {!module: Surface.Lexer_en} is the adaptation of {!module: Surface.Lexer}
with verbose English keywords matching legal concepts.}
{li {!module: Surface.Lexer_fr} is the adaptation of {!module: Surface.Lexer}
with verbose French keywords matching legal concepts.}
}
{1 Parsing }
Relevant modules:
{!modules: Surface.Parser Surface.Parser_driver Surface.Parser_errors}
The Catala compiler uses {{: http://cambium.inria.fr/~fpottier/menhir/} Menhir}
to perform its parsing.
{!module: Surface.Parser} is the main file where the parser tokens and the
grammar is declared. It is automatically translated into its parsing automata
equivalent by Menhir.
In order to provide decent syntax error messages, the Catala compiler uses the
novel error handling provided by Menhir and detailed in Section 11 of the
{{: http://cambium.inria.fr/~fpottier/menhir/manual.pdf} Menhir manual}.
A [parser.messages] source file has been manually annotated with custom
error message for every potential erroneous state of the parser, and Menhir
automatically generated the {!module: Surface.Parser_errors} module containing
the function linking the erroneous parser states to the custom error message.
To wrap it up, {!module: Surface.Parser_driver} glues all the parsing and
lexing together to perform the translation from source code to abstract syntax
tree, with meaningful error messages.
{1 Name resolution and translation }
Relevant modules:
{!modules: Surface.Name_resolution Surface.Desugaring}
The desugaring consists of translating {!module: Surface.Ast} to
{!module: Desugared.Ast} of the {{: desugared.html} desugared representation}.
The translation is implemented in
{!module: Surface.Desugaring}, but it relies on a helper module to perform the
name resolution: {!module: Surface.Name_resolution}. Indeed, in
{!module: Surface.Ast}, the variables identifiers are just [string], whereas in
{!module: Desugared.Ast} they have been turned into well-categorized types
with an unique identifier like {!type: Scopelang.Ast.ScopeName.t}.

72
src/catala/default_calculus/ast.ml
View File

@ -13,33 +13,87 @@
the License. *)
module Pos = Utils.Pos
module Uid = Utils.Uid
(** Abstract syntax tree for the default calculus *)
(** {1 Abstract syntax tree} *)
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type typ =
| TBool
| TUnit
| TInt
| TLit of typ_lit
| TTuple of typ Pos.marked list
| TEnum of typ Pos.marked list
| TArrow of typ Pos.marked * typ Pos.marked
type lit = LBool of bool | LEmptyError | LInt of Int64.t | LUnit
type date = ODate.Unix.t
type binop = And | Or | Add | Sub | Mult | Div | Lt | Lte | Gt | Gte | Eq | Neq
type duration = Z.t
type unop = Not | Minus
type lit =
| LBool of bool
| LEmptyError
| LInt of Z.t
| LRat of Q.t
| LMoney of Z.t
| 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 binop =
| And
| Or
| 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
type log_entry = VarDef | BeginCall | EndCall
type unop =
| Not
| Minus of op_kind
| ErrorOnEmpty
| Log of log_entry * Utils.Uid.MarkedString.info list
type operator = 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
| ETupleAccess of expr Pos.marked * int
| ETuple of (expr Pos.marked * Uid.MarkedString.info option) list
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of expr Pos.marked * int * Uid.MarkedString.info option
(** The [MarkedString.info] is the former struct field name*)
| EInj of expr Pos.marked * int * Uid.MarkedString.info * typ Pos.marked list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of expr Pos.marked * (expr Pos.marked * Uid.MarkedString.info) list
(** The [MarkedString.info] is the former enum case name *)
| ELit of lit
| EAbs of Pos.t * (expr, expr Pos.marked) Bindlib.mbinder * 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 * expr Pos.marked * expr Pos.marked list
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
(** {1 Variable helpers} *)
module Var = struct
type t = expr Bindlib.var

40
src/catala/default_calculus/dcalc.mld Normal file
View File

@ -0,0 +1,40 @@
{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
have been lowered into regular functions, and enums and structs have been
lowered to sum and product types.
The module describing the abstract syntax tree is:
{!modules: Dcalc.Ast}
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}.
{1 Typing }
Related modules:
{!modules: Dcalc.Typing}
This representation is where the typing is performed. Indeed, {!module: Dcalc.Typing}
implements the classical {{: https://en.wikipedia.org/wiki/Hindley%E2%80%93Milner_type_system} W algorithm}
corresponding to a Hindley-Milner type system, without type constraints.
{1 Interpreter}
Related modules:
{!modules: Dcalc.Interpreter}
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.
Later, translations to a regular lambda calculus and/or a simple imperative
language are bound to be added.

2
src/catala/default_calculus/dune
View File

@ -1,7 +1,7 @@
(library
(name dcalc)
(public_name catala.dcalc)
(libraries bindlib unionFind utils))
(libraries bindlib unionFind utils zarith odate))
(documentation
(package catala))

269
src/catala/default_calculus/interpreter.ml
View File

@ -12,48 +12,170 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Reference interpreter for the default calculus *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
module A = Ast
(** {1 Helpers} *)
let is_empty_error (e : A.expr Pos.marked) : bool =
match Pos.unmark e with ELit LEmptyError -> true | _ -> false
let empty_thunked_term : Ast.expr Pos.marked =
let silent = Ast.Var.make ("_", Pos.no_pos) in
Bindlib.unbox
(Ast.make_abs
(Array.of_list [ silent ])
(Bindlib.box (Ast.ELit Ast.LEmptyError, Pos.no_pos))
Pos.no_pos
[ (Ast.TLit Ast.TUnit, Pos.no_pos) ]
Pos.no_pos)
(** {1 Evaluation} *)
let evaluate_operator (op : A.operator Pos.marked) (args : A.expr Pos.marked list) :
A.expr Pos.marked =
Pos.same_pos_as
( match (Pos.unmark op, List.map Pos.unmark args) with
| 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, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Int64.add i1 i2))
| A.Binop A.Sub, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Int64.sub i1 i2))
| A.Binop A.Mult, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Int64.mul i1 i2))
| A.Binop A.Div, [ ELit (LInt i1); ELit (LInt i2) ] ->
if i2 <> Int64.zero then A.ELit (LInt (Int64.div i1 i2))
| 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.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.Lt, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 < i2))
| A.Binop A.Lte, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 <= i2))
| A.Binop A.Gt, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 > i2))
| A.Binop A.Gte, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 >= i2))
| 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))
| 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 (Z.( + ) i1 i2))
| A.Binop (A.Sub KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit (LDuration (Z.( - ) i1 i2))
| A.Binop (A.Sub KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LDuration (Z.of_int (ODuration.To.day (ODate.Unix.between i2 i1))))
| A.Binop (A.Add KDate), [ ELit (LDate i1); ELit (LDuration i2) ] ->
A.ELit (LDate (ODate.Unix.advance_by_days i1 (Z.to_int 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 (i1 < i2))
| A.Binop (A.Lte KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit (LBool (i1 <= i2))
| A.Binop (A.Gt KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit (LBool (i1 > i2))
| A.Binop (A.Gte KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] ->
A.ELit (LBool (i1 >= i2))
| A.Binop (A.Lt KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (ODate.Unix.compare i1 i2 < 0))
| A.Binop (A.Lte KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (ODate.Unix.compare i1 i2 <= 0))
| A.Binop (A.Gt KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (ODate.Unix.compare i1 i2 > 0))
| A.Binop (A.Gte KDate), [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (ODate.Unix.compare i1 i2 >= 0))
| 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 (ODate.Unix.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 (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 = b2))
| A.Binop A.Eq, [ _; _ ] -> A.ELit (LBool false) (* comparing functions return false *)
| A.Binop A.Neq, [ ELit (LDuration i1); ELit (LDuration i2) ] -> A.ELit (LBool (i1 <> i2))
| A.Binop A.Neq, [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (ODate.Unix.compare i1 i2 <> 0))
| A.Binop A.Neq, [ ELit (LMoney i1); ELit (LMoney i2) ] -> A.ELit (LBool (i1 <> i2))
| A.Binop A.Neq, [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 <> i2))
| A.Binop A.Neq, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 <> i2))
| A.Binop A.Neq, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 <> b2))
| A.Binop A.Neq, [ _; _ ] -> A.ELit (LBool true)
| 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.Not, [ ELit (LBool b) ] -> A.ELit (LBool (not b))
| A.Unop A.Minus, [ ELit (LInt i) ] -> A.ELit (LInt (Int64.sub Int64.zero 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.Log (entry, infos)), [ e' ] ->
if !Cli.trace_flag then
match entry with
| VarDef ->
Cli.log_print
(Format.asprintf "%a %a = %a" Print.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 Print.format_expr (e', Pos.no_pos))
| _ ->
Cli.log_print
(Format.asprintf "%a %a" Print.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)
else ();
e'
| A.Unop _, [ ELit LEmptyError ] -> A.ELit LEmptyError
| _ ->
Errors.raise_multispanned_error
"operator applied to the wrong arguments (should not happen if the term was well-typed)"
[ (Some "Operator:", Pos.get_position op) ]
@@ List.mapi (fun i arg -> Some ("Argument n°" ^ string_of_int i, Pos.get_position arg)) )
"Operator applied to the wrong arguments\n(should nothappen if the term was well-typed)"
( [ (Some "Operator:", Pos.get_position op) ]
@ List.mapi
(fun i arg ->
( Some (Format.asprintf "Argument n°%d, value %a" (i + 1) Print.format_expr arg),
Pos.get_position arg ))
args ) )
op
let rec evaluate_expr (e : A.expr Pos.marked) : A.expr Pos.marked =
@ -65,7 +187,6 @@ let rec evaluate_expr (e : A.expr Pos.marked) : A.expr Pos.marked =
| EApp (e1, args) -> (
let e1 = evaluate_expr e1 in
let args = List.map evaluate_expr args in
match Pos.unmark e1 with
| EAbs (_, binder, _) ->
if Bindlib.mbinder_arity binder = List.length args then
@ -75,7 +196,7 @@ let rec evaluate_expr (e : A.expr Pos.marked) : A.expr Pos.marked =
(Format.asprintf "wrong function call, expected %d arguments, got %d"
(Bindlib.mbinder_arity binder) (List.length args))
(Pos.get_position e)
| EOp op -> evaluate_operator (Pos.same_pos_as op e1) args
| EOp op -> Pos.same_pos_as (Pos.unmark (evaluate_operator (Pos.same_pos_as op e1) args)) e
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error
@ -83,13 +204,13 @@ let rec evaluate_expr (e : A.expr Pos.marked) : A.expr Pos.marked =
term was well-typed"
(Pos.get_position e) )
| EAbs _ | ELit _ | EOp _ -> e (* thse are values *)
| ETuple es -> Pos.same_pos_as (A.ETuple (List.map evaluate_expr es)) e
| ETupleAccess (e1, n) -> (
| ETuple es -> Pos.same_pos_as (A.ETuple (List.map (fun (e', i) -> (evaluate_expr e', i)) es)) e
| ETupleAccess (e1, n, _) -> (
let e1 = evaluate_expr e1 in
match Pos.unmark e1 with
| ETuple es -> (
match List.nth_opt es n with
| Some e' -> e'
| Some (e', _) -> e'
| None ->
Errors.raise_spanned_error
(Format.asprintf
@ -104,44 +225,54 @@ let rec evaluate_expr (e : A.expr Pos.marked) : A.expr Pos.marked =
if the term was well-typed)"
n)
(Pos.get_position e1) )
| EDefault (just, cons, subs) -> (
let just = evaluate_expr just in
match Pos.unmark just with
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| ELit (LBool true) -> (
match evaluate_expr cons with
| ELit LEmptyError, pos ->
evaluate_expr
(Pos.same_pos_as
(Ast.EDefault ((ELit (LBool false), pos), (Ast.ELit LEmptyError, pos), subs))
e)
| e' -> e' )
| ELit (LBool false) -> (
let subs_orig = subs in
let subs = List.map evaluate_expr subs in
let empty_count = List.length (List.filter is_empty_error subs) in
match List.length subs - empty_count with
| 0 -> Pos.same_pos_as (A.ELit LEmptyError) e
| 1 -> List.find (fun sub -> not (is_empty_error sub)) subs
| _ ->
Errors.raise_multispanned_error
"There is a conflict between multiple rules for assigning the same variable."
( ( if Pos.get_position e = Pos.no_pos then []
else
[
( Some "This rule is not triggered, so we consider rules of lower priority:",
Pos.get_position e );
] )
@ List.map
(fun (_, sub) -> (Some "This justification is true:", Pos.get_position sub))
(List.filter
(fun (sub, _) -> not (is_empty_error sub))
(List.map2 (fun x y -> (x, y)) subs subs_orig)) ) )
| EInj (e1, n, i, ts) ->
let e1' = evaluate_expr e1 in
Pos.same_pos_as (A.EInj (e1', n, i, ts)) e
| EMatch (e1, es) -> (
let e1 = evaluate_expr e1 in
match Pos.unmark e1 with
| A.EInj (e1, n, _, _) ->
let es_n, _ =
match List.nth_opt es n with
| Some es_n -> es_n
| None ->
Errors.raise_spanned_error
"sum type index error (should not happend if the term was well-typed)"
(Pos.get_position e)
in
let new_e = Pos.same_pos_as (A.EApp (es_n, [ e1 ])) e in
evaluate_expr new_e
| A.ELit A.LEmptyError -> Pos.same_pos_as (A.ELit A.LEmptyError) e
| _ ->
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) )
"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) )
| EDefault (exceptions, just, cons) -> (
let exceptions_orig = exceptions in
let exceptions = List.map evaluate_expr exceptions in
let empty_count = List.length (List.filter is_empty_error exceptions) in
match List.length exceptions - empty_count with
| 0 -> (
let just = evaluate_expr just in
match Pos.unmark just with
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| ELit (LBool true) -> evaluate_expr cons
| ELit (LBool false) -> Pos.same_pos_as (A.ELit LEmptyError) e
| _ ->
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) )
| 1 -> List.find (fun sub -> not (is_empty_error sub)) exceptions
| _ ->
Errors.raise_multispanned_error
"There is a conflict between multiple exceptions for assigning the same variable."
(List.map
(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))) )
| EIfThenElse (cond, et, ef) -> (
match Pos.unmark (evaluate_expr cond) with
| ELit (LBool true) -> evaluate_expr et
@ -151,15 +282,29 @@ let rec evaluate_expr (e : A.expr Pos.marked) : A.expr Pos.marked =
"Expected a boolean literal for the result of this condition (should not happen if the \
term was well-typed)"
(Pos.get_position cond) )
| EAssert e' -> (
match Pos.unmark (evaluate_expr e') with
| ELit (LBool true) -> Pos.same_pos_as (Ast.ELit LUnit) e'
| ELit (LBool false) -> (
match Pos.unmark e' with
| EApp ((Ast.EOp (Binop op), pos_op), [ e1; e2 ]) ->
Errors.raise_spanned_error
(Format.asprintf "Assertion failed: %a %a %a" Print.format_expr e1
Print.format_binop (op, pos_op) Print.format_expr e2)
(Pos.get_position e')
| _ ->
Errors.raise_spanned_error (Format.asprintf "Assertion failed") (Pos.get_position 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') )
let empty_thunked_term : Ast.expr Pos.marked =
let silent = Ast.Var.make ("_", Pos.no_pos) in
Bindlib.unbox
(Ast.make_abs
(Array.of_list [ silent ])
(Bindlib.box (Ast.ELit Ast.LEmptyError, Pos.no_pos))
Pos.no_pos [ (Ast.TUnit, Pos.no_pos) ] Pos.no_pos)
(** {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 (e : Ast.expr Pos.marked) : (Ast.Var.t * Ast.expr Pos.marked) list =
match Pos.unmark (evaluate_expr e) with
| Ast.EAbs (_, binder, taus) -> (
@ -168,7 +313,7 @@ let interpret_program (e : Ast.expr Pos.marked) : (Ast.Var.t * Ast.expr Pos.mark
match Pos.unmark (evaluate_expr to_interpret) with
| Ast.ETuple args ->
let vars, _ = Bindlib.unmbind binder in
List.map2 (fun arg var -> (var, arg)) args (Array.to_list vars)
List.map2 (fun (arg, _) var -> (var, arg)) args (Array.to_list vars)
| _ ->
Errors.raise_spanned_error "The interpretation of a program should always yield a tuple"
(Pos.get_position e) )

141
src/catala/default_calculus/print.ml
View File

@ -18,50 +18,122 @@ open Ast
let typ_needs_parens (e : typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ -> true | _ -> false
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
match l with
| TUnit -> Format.fprintf fmt "unit"
| TBool -> Format.fprintf fmt "boolean"
| TInt -> Format.fprintf fmt "integer"
| TRat -> Format.fprintf fmt "decimal"
| TMoney -> Format.fprintf fmt "money"
| TDuration -> Format.fprintf fmt "duration"
| TDate -> Format.fprintf fmt "date"
let rec format_typ (fmt : Format.formatter) (typ : typ Pos.marked) : unit =
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
| TUnit -> Format.fprintf fmt "unit"
| TBool -> Format.fprintf fmt "bool"
| TInt -> Format.fprintf fmt "int"
| TLit l -> Format.fprintf fmt "%a" format_tlit l
| TTuple ts ->
Format.fprintf fmt "(%a)"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " *@ ") format_typ)
ts
| TEnum ts ->
Format.fprintf fmt "(%a)"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " +@ ") format_typ)
ts
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a →@ %a@]" format_typ_with_parens t1 format_typ t2
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" (Int64.to_string i)
| LInt i -> Format.fprintf fmt "%s" (Z.to_string i)
| LEmptyError -> Format.fprintf fmt "∅"
| LUnit -> Format.fprintf fmt "()"
| LRat i ->
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 < !Utils.Cli.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.fprintf fmt "%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 = !Utils.Cli.max_prec_digits then "…"
else "" )
| LMoney e -> Format.fprintf fmt "$%.2f" Q.(to_float (of_bigint e / of_int 100))
| LDate d ->
Format.fprintf fmt "%s"
(ODate.Unix.To.string (Option.get (ODate.Unix.To.generate_printer "%Y-%m-%d")) d)
| LDuration d -> Format.fprintf fmt "%a days" Z.pp_print 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 =
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 -> 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
let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Format.fprintf fmt "%s"
( match Pos.unmark op with
| Add -> "+"
| Sub -> "-"
| Mult -> "*"
| Div -> "/"
| And -> "&&"
| Or -> "||"
| Eq -> "=="
| Neq -> "!="
| Lt -> "<"
| Lte -> "<="
| Gt -> ">"
| Gte -> ">=" )
( match entry with
| VarDef -> "Defining variable"
| BeginCall -> "Calling subscope"
| EndCall -> "Returned from subscope" )
let format_unop (fmt : Format.formatter) (op : unop Pos.marked) : unit =
Format.fprintf fmt "%s" (match Pos.unmark op with Minus -> "-" | Not -> "~")
Format.fprintf fmt "%s"
( match Pos.unmark op with
| Minus _ -> "-"
| Not -> "~"
| ErrorOnEmpty -> "error_empty"
| 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 )
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with EAbs _ -> true | _ -> false
match Pos.unmark e with EAbs _ | EApp _ -> true | _ -> false
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
Format.fprintf fmt "%s" (Bindlib.name_of v)
@ -75,9 +147,27 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
| ETuple es ->
Format.fprintf fmt "(%a)"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",") format_expr)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
(fun fmt (e, struct_field) ->
match struct_field with
| Some struct_field ->
Format.fprintf fmt "@[<hov 2>\"%a\":@ %a@]" Uid.MarkedString.format_info
struct_field format_expr e
| None -> Format.fprintf fmt "@[%a@]" format_expr e))
es
| ETupleAccess (e1, n, i) -> (
match i with
| None -> Format.fprintf fmt "%a.%d" format_expr e1 n
| Some i -> Format.fprintf fmt "%a.\"%a\"" format_expr e1 Uid.MarkedString.format_info i )
| EInj (e, _n, i, _ts) -> Format.fprintf fmt "%a %a" Uid.MarkedString.format_info i format_expr e
| EMatch (e, es) ->
Format.fprintf fmt "@[<hov 2>match %a with %a@]" format_expr e
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " |@ ")
(fun fmt (e, c) ->
Format.fprintf fmt "%a %a" Uid.MarkedString.format_info c format_expr e))
es
| ETupleAccess (e1, n) -> Format.fprintf fmt "%a.%d" format_expr e1 n
| 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
@ -112,10 +202,11 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
e1 format_expr e2 format_expr e3
| 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 (just, cons, subs) ->
if List.length subs = 0 then
| EDefault (exceptions, just, cons) ->
if List.length exceptions = 0 then
Format.fprintf fmt "@[⟨%a ⊢ %a⟩@]" format_expr just format_expr cons
else
Format.fprintf fmt "@[<hov 2>⟨%a ⊢ %a |@ %a⟩@]" format_expr just format_expr cons
Format.fprintf fmt "@[<hov 2>⟨%a@ |@ %a ⊢ %a ⟩@]"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_expr)
subs
exceptions format_expr just format_expr cons
| EAssert e' -> Format.fprintf fmt "@[<hov 2>assert@ (%a)@]" format_expr e'

342
src/catala/default_calculus/typing.ml
View File

@ -20,37 +20,52 @@ module Errors = Utils.Errors
module A = Ast
module Cli = Utils.Cli
(** {1 Types and unification} *)
(** We do not reuse {!type: Dcalc.Ast.typ} because we have to include a new [TAny] variant. Indeed,
error terms can have any type and this has to be captured by the type sytem. *)
type typ =
| TUnit
| TInt
| TBool
| TLit of A.typ_lit
| TArrow of typ Pos.marked UnionFind.elem * typ Pos.marked UnionFind.elem
| TTuple of typ Pos.marked UnionFind.elem list
| TEnum of typ Pos.marked UnionFind.elem list
| TAny
let rec format_typ (fmt : Format.formatter) (ty : typ Pos.marked UnionFind.elem) : unit =
let ty_repr = UnionFind.get (UnionFind.find ty) in
match Pos.unmark ty_repr with
| TUnit -> Format.fprintf fmt "unit"
| TBool -> Format.fprintf fmt "bool"
| TInt -> Format.fprintf fmt "int"
| TAny -> Format.fprintf fmt "α"
| TLit l -> Format.fprintf fmt "%a" Print.format_tlit l
| TAny -> Format.fprintf fmt "any type"
| TTuple ts ->
Format.fprintf fmt "(%a)"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " * ") format_typ)
ts
| TEnum ts ->
Format.fprintf fmt "(%a)"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " + ") format_typ)
ts
| TArrow (t1, t2) -> Format.fprintf fmt "%a → %a" format_typ t1 format_typ t2
(** Raises an error if unification cannot be performed *)
let rec unify (t1 : typ Pos.marked UnionFind.elem) (t2 : typ Pos.marked UnionFind.elem) : unit =
(* Cli.debug_print (Format.asprintf "Unifying %a and %a" format_typ t1 format_typ t2); *)
let t1_repr = UnionFind.get (UnionFind.find t1) in
let t2_repr = UnionFind.get (UnionFind.find t2) in
match (t1_repr, t2_repr) with
| (TUnit, _), (TUnit, _) | (TBool, _), (TBool, _) | (TInt, _), (TInt, _) -> ()
| (TArrow (t11, t12), _), (TArrow (t21, t22), _) ->
unify t11 t21;
unify t12 t22
| (TLit tl1, _), (TLit tl2, _) when tl1 = tl2 -> ()
| (TArrow (t11, t12), t1_pos), (TArrow (t21, t22), t2_pos) -> (
try
unify t11 t21;
unify t12 t22
with Errors.StructuredError (msg, err_pos) ->
Errors.raise_multispanned_error msg
( err_pos
@ [
(Some (Format.asprintf "Type %a coming from expression:" format_typ t1), t1_pos);
(Some (Format.asprintf "Type %a coming from expression:" format_typ t2), t2_pos);
] ) )
| (TTuple ts1, _), (TTuple ts2, _) -> List.iter2 unify ts1 ts2
| (TEnum ts1, _), (TEnum ts2, _) -> List.iter2 unify ts1 ts2
| (TAny, _), (TAny, _) -> ignore (UnionFind.union t1 t2)
| (TAny, _), t_repr | t_repr, (TAny, _) ->
let t_union = UnionFind.union t1 t2 in
@ -59,134 +74,190 @@ let rec unify (t1 : typ Pos.marked UnionFind.elem) (t2 : typ Pos.marked UnionFin
(* TODO: if we get weird error messages, then it means that we should use the persistent
version of the union-find data structure. *)
Errors.raise_multispanned_error
(Format.asprintf "Error during typechecking, type mismatch: cannot unify %a and %a"
format_typ t1 format_typ t2)
(Format.asprintf "Error during typechecking, types %a and %a are incompatible" format_typ t1
format_typ t2)
[
(Some (Format.asprintf "Type %a coming from expression:" format_typ t1), t1_pos);
(Some (Format.asprintf "Type %a coming from expression:" format_typ t2), t2_pos);
]
(** Operators have a single type, instead of being polymorphic with constraints. This allows us to
have a simpler type system, while we argue the syntactic burden of operator annotations helps
the programmer visualize the type flow in the code. *)
let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem =
let pos = Pos.get_position op in
let bt = UnionFind.make (TBool, pos) in
let it = UnionFind.make (TInt, pos) in
let bt = UnionFind.make (TLit TBool, pos) in
let it = UnionFind.make (TLit TInt, pos) in
let rt = UnionFind.make (TLit TRat, pos) in
let mt = UnionFind.make (TLit TMoney, pos) in
let dut = UnionFind.make (TLit TDuration, pos) in
let dat = UnionFind.make (TLit TDate, pos) in
let any = UnionFind.make (TAny, pos) in
let arr x y = UnionFind.make (TArrow (x, y), pos) in
match Pos.unmark op with
| A.Binop (A.And | A.Or) -> arr bt (arr bt bt)
| A.Binop (A.Add | A.Sub | A.Mult | A.Div) -> arr it (arr it it)
| A.Binop (A.Lt | A.Lte | A.Gt | A.Gte) -> arr it (arr it 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 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)
| A.Binop (A.Lt KRat | A.Lte KRat | A.Gt KRat | A.Gte KRat) -> arr rt (arr rt bt)
| A.Binop (A.Lt KMoney | A.Lte KMoney | A.Gt KMoney | A.Gte KMoney) -> arr mt (arr mt bt)
| A.Binop (A.Lt KDate | A.Lte KDate | A.Gt KDate | A.Gte KDate) -> arr dat (arr dat bt)
| A.Binop (A.Lt KDuration | A.Lte KDuration | A.Gt KDuration | A.Gte KDuration) ->
arr dut (arr dut bt)
| A.Binop (A.Eq | A.Neq) -> arr any (arr any bt)
| A.Unop A.Minus -> arr it it
| 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 _) -> arr any any
| Binop (Mult (KDate | KDuration)) | Binop (Div (KDate | KDuration)) | Unop (Minus KDate) ->
Errors.raise_spanned_error "This operator is not available!" pos
let rec ast_to_typ (ty : A.typ) : typ =
match ty with
| A.TUnit -> TUnit
| A.TBool -> TBool
| A.TInt -> TInt
| A.TLit l -> TLit l
| A.TArrow (t1, t2) ->
TArrow
( UnionFind.make (Pos.map_under_mark ast_to_typ t1),
UnionFind.make (Pos.map_under_mark ast_to_typ t2) )
| A.TTuple ts -> TTuple (List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts)
| A.TEnum ts -> TEnum (List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts)
let rec typ_to_ast (ty : typ Pos.marked UnionFind.elem) : A.typ Pos.marked =
Pos.map_under_mark
(fun ty ->
match ty with
| TUnit -> A.TUnit
| TBool -> A.TBool
| TInt -> A.TInt
| TLit l -> A.TLit l
| TTuple ts -> A.TTuple (List.map typ_to_ast ts)
| TEnum ts -> A.TEnum (List.map typ_to_ast ts)
| TArrow (t1, t2) -> A.TArrow (typ_to_ast t1, typ_to_ast t2)
| TAny -> A.TUnit)
| TAny -> A.TLit A.TUnit)
(UnionFind.get (UnionFind.find ty))
(** {1 Double-directed typing} *)
type env = typ Pos.marked A.VarMap.t
(** Infers the most permissive type from an expression *)
let rec typecheck_expr_bottom_up (env : env) (e : A.expr Pos.marked) : typ Pos.marked UnionFind.elem
=
(* Cli.debug_print (Format.asprintf "Up begin: %a" Print.format_expr e); *)
let out =
match Pos.unmark e with
| EVar v -> (
match A.VarMap.find_opt (Pos.unmark v) env with
| Some t -> UnionFind.make t
| None ->
Errors.raise_spanned_error "Variable not found in the current context"
(Pos.get_position e) )
| ELit (LBool _) -> UnionFind.make (Pos.same_pos_as TBool e)
| ELit (LInt _) -> UnionFind.make (Pos.same_pos_as TInt e)
| ELit LUnit -> UnionFind.make (Pos.same_pos_as TUnit e)
| ELit LEmptyError -> UnionFind.make (Pos.same_pos_as TAny e)
| ETuple es ->
let ts = List.map (typecheck_expr_bottom_up env) es in
UnionFind.make (Pos.same_pos_as (TTuple ts) e)
| ETupleAccess (e1, n) -> (
let t1 = typecheck_expr_bottom_up env e1 in
match Pos.unmark (UnionFind.get (UnionFind.find t1)) with
| TTuple ts -> (
match List.nth_opt ts n with
| Some t' -> t'
| None ->
Errors.raise_spanned_error
(Format.asprintf
"expression should have a tuple type with at least %d elements but only has %d"
n (List.length ts))
(Pos.get_position e1) )
| _ ->
Errors.raise_spanned_error
(Format.asprintf "exprected a tuple, got a %a" format_typ t1)
(Pos.get_position e1) )
| EAbs (pos_binder, binder, taus) ->
let xs, body = Bindlib.unmbind binder in
if Array.length xs = List.length taus then
let xstaus = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
let env =
List.fold_left
(fun env (x, tau) -> A.VarMap.add x (ast_to_typ (Pos.unmark tau), pos_binder) env)
env xstaus
in
List.fold_right
(fun t_arg (acc : typ Pos.marked UnionFind.elem) ->
UnionFind.make
(TArrow (UnionFind.make (Pos.map_under_mark ast_to_typ t_arg), acc), pos_binder))
taus
(typecheck_expr_bottom_up env body)
else
match Pos.unmark e with
| EVar v -> (
match A.VarMap.find_opt (Pos.unmark v) env with
| Some t -> UnionFind.make t
| None ->
Errors.raise_spanned_error "Variable not found in the current context"
(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)
| ELit (LMoney _) -> UnionFind.make (Pos.same_pos_as (TLit TMoney) e)
| ELit (LDate _) -> UnionFind.make (Pos.same_pos_as (TLit TDate) e)
| ELit (LDuration _) -> UnionFind.make (Pos.same_pos_as (TLit TDuration) e)
| ELit LUnit -> UnionFind.make (Pos.same_pos_as (TLit TUnit) e)
| ELit LEmptyError -> UnionFind.make (Pos.same_pos_as TAny e)
| ETuple es ->
let ts = List.map (fun (e, _) -> typecheck_expr_bottom_up env e) es in
UnionFind.make (Pos.same_pos_as (TTuple ts) e)
| ETupleAccess (e1, n, _) -> (
let t1 = typecheck_expr_bottom_up env e1 in
match Pos.unmark (UnionFind.get (UnionFind.find t1)) with
| TTuple ts -> (
match List.nth_opt ts n with
| Some t' -> t'
| None ->
Errors.raise_spanned_error
(Format.asprintf
"Expression should have a tuple type with at least %d elements but only has %d" n
(List.length ts))
(Pos.get_position e1) )
| _ ->
Errors.raise_spanned_error
(Format.asprintf "function has %d variables but was supplied %d types" (Array.length xs)
(List.length taus))
pos_binder
| EApp (e1, args) ->
let t_args = List.map (typecheck_expr_bottom_up env) args in
let t_ret = UnionFind.make (Pos.same_pos_as TAny e) in
let t_app =
List.fold_right
(fun t_arg acc -> UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e))
t_args t_ret
(Format.asprintf "Expected a tuple, got a %a" format_typ t1)
(Pos.get_position e1) )
| EInj (e1, n, _, ts) ->
let ts = List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts in
let ts_n =
match List.nth_opt ts n with
| Some ts_n -> ts_n
| None ->
Errors.raise_spanned_error
(Format.asprintf
"Expression should have a sum type with at least %d cases but only has %d" n
(List.length ts))
(Pos.get_position e)
in
typecheck_expr_top_down env e1 ts_n;
UnionFind.make (Pos.same_pos_as (TEnum ts) e)
| EMatch (e1, es) ->
let enum_cases = List.map (fun (e', _) -> UnionFind.make (Pos.same_pos_as TAny e')) es in
let t_e1 = UnionFind.make (Pos.same_pos_as (TEnum enum_cases) e1) in
typecheck_expr_top_down env e1 t_e1;
let t_ret = UnionFind.make (Pos.same_pos_as TAny e) in
List.iteri
(fun i (es', _) ->
let enum_t = List.nth enum_cases i in
let t_es' = UnionFind.make (Pos.same_pos_as (TArrow (enum_t, t_ret)) es') in
typecheck_expr_top_down env es' t_es')
es;
t_ret
| EAbs (pos_binder, binder, taus) ->
let xs, body = Bindlib.unmbind binder in
if Array.length xs = List.length taus then
let xstaus = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
let env =
List.fold_left
(fun env (x, tau) ->
A.VarMap.add x (ast_to_typ (Pos.unmark tau), Pos.get_position tau) env)
env xstaus
in
typecheck_expr_top_down env e1 t_app;
t_ret
| EOp op -> op_type (Pos.same_pos_as op e)
| EDefault (just, cons, subs) ->
typecheck_expr_top_down env just (UnionFind.make (Pos.same_pos_as TBool just));
let tcons = typecheck_expr_bottom_up env cons in
List.iter (fun sub -> typecheck_expr_top_down env sub tcons) subs;
tcons
| EIfThenElse (cond, et, ef) ->
typecheck_expr_top_down env cond (UnionFind.make (Pos.same_pos_as TBool cond));
let tt = typecheck_expr_bottom_up env et in
typecheck_expr_top_down env ef tt;
tt
in
(* Cli.debug_print (Format.asprintf "Up result: %a | %a" Print.format_expr e format_typ out); *)
out
List.fold_right
(fun t_arg (acc : typ Pos.marked UnionFind.elem) ->
UnionFind.make
(TArrow (UnionFind.make (Pos.map_under_mark ast_to_typ t_arg), acc), pos_binder))
taus
(typecheck_expr_bottom_up env body)
else
Errors.raise_spanned_error
(Format.asprintf "function has %d variables but was supplied %d types" (Array.length xs)
(List.length taus))
pos_binder
| EApp (e1, args) ->
let t_args = List.map (typecheck_expr_bottom_up env) args in
let t_ret = UnionFind.make (Pos.same_pos_as TAny e) in
let t_app =
List.fold_right
(fun t_arg acc -> UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e))
t_args t_ret
in
typecheck_expr_top_down env e1 t_app;
t_ret
| EOp op -> op_type (Pos.same_pos_as op e)
| EDefault (excepts, just, cons) ->
typecheck_expr_top_down env just (UnionFind.make (Pos.same_pos_as (TLit TBool) just));
let tcons = typecheck_expr_bottom_up env cons in
List.iter (fun except -> typecheck_expr_top_down env except tcons) excepts;
tcons
| EIfThenElse (cond, et, ef) ->
typecheck_expr_top_down env cond (UnionFind.make (Pos.same_pos_as (TLit TBool) cond));
let tt = typecheck_expr_bottom_up env et in
typecheck_expr_top_down env ef tt;
tt
| EAssert e' ->
typecheck_expr_top_down env e' (UnionFind.make (Pos.same_pos_as (TLit TBool) e'));
UnionFind.make (Pos.same_pos_as (TLit TUnit) e')
(** Checks whether the expression can be typed with the provided type *)
and typecheck_expr_top_down (env : env) (e : A.expr Pos.marked)
(tau : typ Pos.marked UnionFind.elem) : unit =
(* Cli.debug_print (Format.asprintf "Down: %a | %a" Print.format_expr e format_typ tau); *)
match Pos.unmark e with
| EVar v -> (
match A.VarMap.find_opt (Pos.unmark v) env with
@ -194,19 +265,29 @@ and typecheck_expr_top_down (env : env) (e : A.expr Pos.marked)
| None ->
Errors.raise_spanned_error "Variable not found in the current context"
(Pos.get_position e) )
| ELit (LBool _) -> unify tau (UnionFind.make (Pos.same_pos_as TBool e))
| ELit (LInt _) -> unify tau (UnionFind.make (Pos.same_pos_as TInt e))
| ELit LUnit -> unify tau (UnionFind.make (Pos.same_pos_as TUnit e))
| ELit (LBool _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TBool) e))
| ELit (LInt _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TInt) e))
| ELit (LRat _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TRat) e))
| ELit (LMoney _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TMoney) e))
| ELit (LDate _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TDate) e))
| ELit (LDuration _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TDuration) e))
| ELit LUnit -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TUnit) e))
| ELit LEmptyError -> unify tau (UnionFind.make (Pos.same_pos_as TAny e))
| ETuple es -> (
let tau' = UnionFind.get (UnionFind.find tau) in
match Pos.unmark tau' with
| TTuple ts -> List.iter2 (typecheck_expr_top_down env) es ts
| TTuple ts -> List.iter2 (fun (e, _) t -> typecheck_expr_top_down env e t) es ts
| TAny ->
unify tau
(UnionFind.make
(Pos.same_pos_as
(TTuple (List.map (fun (arg, _) -> typecheck_expr_bottom_up env arg) es))
e))
| _ ->
Errors.raise_spanned_error
(Format.asprintf "exprected %a, got a tuple" format_typ tau)
(Format.asprintf "expected %a, got a tuple" format_typ tau)
(Pos.get_position e) )
| ETupleAccess (e1, n) -> (
| ETupleAccess (e1, n, _) -> (
let t1 = typecheck_expr_bottom_up env e1 in
match Pos.unmark (UnionFind.get (UnionFind.find t1)) with
| TTuple t1s -> (
@ -218,10 +299,42 @@ and typecheck_expr_top_down (env : env) (e : A.expr Pos.marked)
"expression should have a tuple type with at least %d elements but only has %d" n
(List.length t1s))
(Pos.get_position e1) )
| TAny ->
(* Include total number of cases in ETupleAccess to continue typechecking at this point *)
Errors.raise_spanned_error
"The precise type of this expression cannot be inferred.\n\
Please raise an issue one https://github.com/CatalaLang/catala/issues"
(Pos.get_position e1)
| _ ->
Errors.raise_spanned_error
(Format.asprintf "exprected a tuple , got %a" format_typ tau)
(Format.asprintf "expected a tuple , got %a" format_typ tau)
(Pos.get_position e) )
| EInj (e1, n, _, ts) ->
let ts = List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts in
let ts_n =
match List.nth_opt ts n with
| Some ts_n -> ts_n
| None ->
Errors.raise_spanned_error
(Format.asprintf
"Expression should have a sum type with at least %d cases but only has %d" n
(List.length ts))
(Pos.get_position e)
in
typecheck_expr_top_down env e1 ts_n;
unify (UnionFind.make (Pos.same_pos_as (TEnum ts) e)) tau
| EMatch (e1, es) ->
let enum_cases = List.map (fun (e', _) -> UnionFind.make (Pos.same_pos_as TAny e')) es in
let t_e1 = UnionFind.make (Pos.same_pos_as (TEnum enum_cases) e1) in
typecheck_expr_top_down env e1 t_e1;
let t_ret = UnionFind.make (Pos.same_pos_as TAny e) in
List.iteri
(fun i (es', _) ->
let enum_t = List.nth enum_cases i in
let t_es' = UnionFind.make (Pos.same_pos_as (TArrow (enum_t, t_ret)) es') in
typecheck_expr_top_down env es' t_es')
es;
unify tau t_ret
| EAbs (pos_binder, binder, t_args) ->
let xs, body = Bindlib.unmbind binder in
if Array.length xs = List.length t_args then
@ -259,18 +372,25 @@ and typecheck_expr_top_down (env : env) (e : A.expr Pos.marked)
| EOp op ->
let op_typ = op_type (Pos.same_pos_as op e) in
unify op_typ tau
| EDefault (just, cons, subs) ->
typecheck_expr_top_down env just (UnionFind.make (Pos.same_pos_as TBool just));
| EDefault (excepts, just, cons) ->
typecheck_expr_top_down env just (UnionFind.make (Pos.same_pos_as (TLit TBool) just));
typecheck_expr_top_down env cons tau;
List.iter (fun sub -> typecheck_expr_top_down env sub tau) subs
List.iter (fun except -> typecheck_expr_top_down env except tau) excepts
| EIfThenElse (cond, et, ef) ->
typecheck_expr_top_down env cond (UnionFind.make (Pos.same_pos_as TBool cond));
typecheck_expr_top_down env cond (UnionFind.make (Pos.same_pos_as (TLit TBool) cond));
typecheck_expr_top_down env et tau;
typecheck_expr_top_down env ef tau
| EAssert e' ->
typecheck_expr_top_down env e' (UnionFind.make (Pos.same_pos_as (TLit TBool) e'));
unify tau (UnionFind.make (Pos.same_pos_as (TLit TUnit) e'))
(** {1 API} *)
(* Infer the type of an expression *)
let infer_type (e : A.expr Pos.marked) : A.typ Pos.marked =
let ty = typecheck_expr_bottom_up A.VarMap.empty e in
typ_to_ast ty
(** Typechecks an expression given an expected type *)
let check_type (e : A.expr Pos.marked) (tau : A.typ Pos.marked) =
typecheck_expr_top_down A.VarMap.empty e (UnionFind.make (Pos.map_under_mark ast_to_typ tau))

67
src/catala/desugared/ast.ml
View File

@ -12,13 +12,20 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Abstract syntax tree of the desugared representation *)
module Pos = Utils.Pos
module Uid = Utils.Uid
module IdentMap = Map.Make (String)
module RuleName = Uid.Make (Uid.MarkedString) ()
(** {1 Names, Maps and Keys} *)
module RuleMap = Map.Make (RuleName)
module IdentMap : Map.S with type key = String.t = Map.Make (String)
module RuleName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
module RuleMap : Map.S with type key = RuleName.t = Map.Make (RuleName)
module RuleSet : Set.S with type elt = RuleName.t = Set.Make (RuleName)
(** Inside a scope, a definition can refer either to a scope def, or a subscope def *)
module ScopeDef = struct
@ -34,6 +41,11 @@ module ScopeDef = struct
Scopelang.Ast.ScopeVar.compare x y
| SubScopeVar (_, x), SubScopeVar (_, y) -> Scopelang.Ast.ScopeVar.compare x y
let get_position x =
match x with
| Var x -> Pos.get_position (Scopelang.Ast.ScopeVar.get_info x)
| SubScopeVar (x, _) -> Pos.get_position (Scopelang.Ast.SubScopeName.get_info x)
let format_t fmt x =
match x with
| Var v -> Scopelang.Ast.ScopeVar.format_t fmt v
@ -47,19 +59,20 @@ module ScopeDef = struct
| SubScopeVar (_, v) -> Scopelang.Ast.ScopeVar.hash v
end
module ScopeDefMap = Map.Make (ScopeDef)
module ScopeDefSet = Set.Make (ScopeDef)
module ScopeDefMap : Map.S with type key = ScopeDef.t = Map.Make (ScopeDef)
(* Scopes *)
module ScopeDefSet : Set.S with type elt = ScopeDef.t = Set.Make (ScopeDef)
(** {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 * Dcalc.Ast.typ Pos.marked) option;
parent_rule : RuleName.t option;
parameter : (Scopelang.Ast.Var.t * Scopelang.Ast.typ Pos.marked) option;
exception_to_rule : RuleName.t option;
}
let empty_rule (pos : Pos.t) (have_parameter : Dcalc.Ast.typ Pos.marked option) : rule =
let empty_rule (pos : Pos.t) (have_parameter : Scopelang.Ast.typ Pos.marked option) : rule =
{
just = Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool false), pos);
cons = Bindlib.box (Scopelang.Ast.ELit Dcalc.Ast.LEmptyError, pos);
@ -67,10 +80,10 @@ let empty_rule (pos : Pos.t) (have_parameter : Dcalc.Ast.typ Pos.marked option)
( match have_parameter with
| Some typ -> Some (Scopelang.Ast.Var.make ("dummy", pos), typ)
| None -> None );
parent_rule = None;
exception_to_rule = None;
}
type assertion = Scopelang.Ast.expr Pos.marked
type assertion = Scopelang.Ast.expr Pos.marked Bindlib.box
type variation_typ = Increasing | Decreasing
@ -84,42 +97,38 @@ 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 * Dcalc.Ast.typ Pos.marked) ScopeDefMap.t;
scope_defs : (rule RuleMap.t * Scopelang.Ast.typ Pos.marked) ScopeDefMap.t;
scope_assertions : assertion list;
scope_meta_assertions : meta_assertion list;
}
let empty_scope (scope_uid : Scopelang.Ast.ScopeName.t) (scope_vars : Scopelang.Ast.ScopeVarSet.t)
(scope_sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t) : scope =
{
scope_uid;
scope_vars;
scope_sub_scopes;
scope_defs = ScopeDefMap.empty;
scope_assertions = [];
scope_meta_assertions = [];
}
type program = {
program_scopes : scope Scopelang.Ast.ScopeMap.t;
program_enums : Scopelang.Ast.enum_ctx;
program_structs : Scopelang.Ast.struct_ctx;
}
type program = scope Scopelang.Ast.ScopeMap.t
(** {1 Helpers} *)
let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
let add_locs (acc : Pos.t ScopeDefMap.t) (locs : Scopelang.Ast.location Pos.marked list) :
let add_locs (acc : Pos.t ScopeDefMap.t) (locs : Scopelang.Ast.LocationSet.t) :
Pos.t ScopeDefMap.t =
List.fold_left
(fun acc (loc, loc_pos) ->
Scopelang.Ast.LocationSet.fold
(fun (loc, loc_pos) acc ->
ScopeDefMap.add
( 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) )
loc_pos acc)
acc locs
locs acc
in
RuleMap.fold
(fun _ rule acc ->
let locs =
Scopelang.Ast.locations_used (Bindlib.unbox rule.just)
@ Scopelang.Ast.locations_used (Bindlib.unbox rule.cons)
Scopelang.Ast.LocationSet.union
(Scopelang.Ast.locations_used (Bindlib.unbox rule.just))
(Scopelang.Ast.locations_used (Bindlib.unbox rule.cons))
in
add_locs acc locs)
def ScopeDefMap.empty

26
src/catala/desugared/dependency.ml
View File

@ -12,18 +12,21 @@
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} *)
module Pos = Utils.Pos
module Errors = Utils.Errors
(** The vertices of the scope dependency graph are either :
(** {1 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.
In the graph, x -> y if x is used in the definition of y. *)
Indeed, during interpretation, subscopes are executed atomically. *)
module Vertex = struct
type t = Var of Scopelang.Ast.ScopeVar.t | SubScope of Scopelang.Ast.SubScopeName.t
@ -46,7 +49,8 @@ module Vertex = struct
| SubScope v -> Scopelang.Ast.SubScopeName.format_t fmt v
end
(** On the edges, the label is the expression responsible for the use of the variable *)
(** 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 Edge = struct
type t = Pos.t
@ -56,11 +60,18 @@ module Edge = struct
end
module ScopeDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (Vertex) (Edge)
(** Module of the graph, provided by OCamlGraph *)
module TopologicalTraversal = Graph.Topological.Make (ScopeDependencies)
(** Module of the topological traversal of the graph, provided by OCamlGraph *)
module SCC = Graph.Components.Make (ScopeDependencies)
(** Tarjan's stongly connected components algorithm, provided by OCamlGraph *)
(** {1 Graph computations} *)
(** Returns an ordering of the scope variables and subscope compatible with the dependencies of the
computation *)
let correct_computation_ordering (g : ScopeDependencies.t) : Vertex.t list =
List.rev (TopologicalTraversal.fold (fun sd acc -> sd :: acc) g [])
@ -71,7 +82,7 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
if List.length sccs < ScopeDependencies.nb_vertex g then
let scc = List.find (fun scc -> List.length scc > 1) sccs in
Errors.raise_multispanned_error
(Format.asprintf "Cyclic dependency detected between variables of scope %a !"
(Format.asprintf "Cyclic dependency detected between variables of scope %a!"
Scopelang.Ast.ScopeName.format_t scope.scope_uid)
(List.flatten
(List.map
@ -99,6 +110,7 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
])
scc))
(** Builds the dependency graph of a particular scope *)
let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
let g = ScopeDependencies.empty in
(* Add all the vertices to the graph *)

30
src/catala/desugared/desugared.mld Normal file
View File

@ -0,0 +1,30 @@
{0 Desugared representation }
This representation is the second in the compilation chain
(see {{: index.html#architecture} Architecture}). Its main difference
with {{: surface.html} the surface representation} is that the legislative
text has been discarded and all the definitions of each variables have been
collected in the same place rather than being scattered across the code base.
The module describing the abstract syntax tree is:
{!modules: Desugared.Ast}
{1 Translation to the scope language}
Related modules:
{!modules: Desugared.Dependency Desugared.Desugared_to_scope}
Before the translation to the {{: scopelang.html} scope language},
{!module: Desugared.Dependency} checks that within
a scope, there is no computational circular dependency between the variables
of the scope. When the dependency graph is a DAG,
{!module: Desugared.Desugared_to_scope} performs a topological ordering to
produce an ordered list of the scope definitions compatible with the
computation order. All the graph computations are done using the
{{:http://ocamlgraph.lri.fr/} Ocamlgraph} library.
The other important piece of work performed by
{!module: Desugared.Desugared_to_scope} is the construction of the default trees
(see {!constructor: Dcalc.Ast.EDefault}) from the list of prioritized rules.

195
src/catala/desugared/desugared_to_scope.ml
View File

@ -12,44 +12,93 @@
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} *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
type rule_tree = Leaf of Ast.rule | Node of Ast.rule * rule_tree list
(** {1 Rule tree construction} *)
(* invariant: one rule in def does not have any parent rule *)
(* invariant: there are no dandling pointer parents in the rules *)
let rec def_map_to_tree (def : Ast.rule Ast.RuleMap.t) : rule_tree =
(* first we look to the only rule that does not have any parent *)
let has_no_parent _ (r : Ast.rule) = Option.is_none r.Ast.parent_rule in
let no_parent = Ast.RuleMap.filter has_no_parent def in
let no_parent_name, no_parent =
if Ast.RuleMap.cardinal no_parent = 1 then Ast.RuleMap.choose no_parent else assert false
in
let def = Ast.RuleMap.remove no_parent_name def in
(* we look for all the direct children of no_parent *)
let children, rest =
Ast.RuleMap.partition (fun _ r -> r.Ast.parent_rule = Some no_parent_name) def
in
if Ast.RuleMap.cardinal children = 0 then Leaf no_parent
(* it doesn't matter that [rest] contains more rules since each rule in [rest] is supposed to
have a parent rule containted in the original tree, so it will get treated at some point *)
else
let children_no_parent =
Ast.RuleMap.map (fun r -> { r with Ast.parent_rule = None }) children
in
let tree_children =
List.map
(fun (child_no_parent_name, child_no_parent) ->
def_map_to_tree (Ast.RuleMap.add child_no_parent_name child_no_parent rest))
(Ast.RuleMap.bindings children_no_parent)
in
Node (no_parent, tree_children)
type rule_tree = Leaf of Ast.rule | Node of rule_tree list * Ast.rule
(** Transforms a flat list of rules into a tree, taking into account the priorities declared between
rules
{e Invariant:} there are no exceptions cycles
{e Invariant:} there are no dandling exception pointers in the rules *)
let rec def_map_to_tree (def_info : Ast.ScopeDef.t)
(is_def_func : Scopelang.Ast.typ Pos.marked option) (def : Ast.rule Ast.RuleMap.t) :
rule_tree list =
(* first we look to the rules that don't have any exceptions *)
let has_no_exception (r : Ast.RuleName.t) _ =
not
(Ast.RuleMap.exists
(fun _ r' -> match r'.Ast.exception_to_rule with Some r_ex -> r_ex = r | None -> false)
def)
in
let no_exceptions = Ast.RuleMap.filter has_no_exception def in
(* Then, for each top-level rule (that has no exceptions), we build a rule tree *)
(* Among the top-level rules are the base rules that are exceptions to nothing *)
let base_rules, rules_that_are_exceptions =
Ast.RuleMap.partition (fun _ r -> Option.is_none r.Ast.exception_to_rule) no_exceptions
in
let base_trees : rule_tree Ast.RuleMap.t =
Ast.RuleMap.map
(fun r ->
(* we look at the the eventual rule of which r is an exception *)
match r.Ast.exception_to_rule with None -> Leaf r | Some _ -> assert false
(* should not happen *))
base_rules
in
(* Now let's deal with the rules that are exceptions but have no exception. We have to bucket
these, each bucket containing all the rules that are exception to the same rule *)
let exception_targets =
Ast.RuleMap.fold
(fun _ r acc ->
match r.Ast.exception_to_rule with
| None -> assert false (* should not happen *)
| Some r' -> Ast.RuleMap.add r' () acc)
rules_that_are_exceptions Ast.RuleMap.empty
in
(* In each bucket corresponding to an exception target, we have all the rules that are exceptions
to the target *)
let exception_trees =
Ast.RuleMap.mapi
(fun r' _ ->
(* we recursively call the function of a def where we have removed exception edges: this is
why the function should terminate *)
let def_rec =
Ast.RuleMap.map
(fun r ->
{
r with
Ast.exception_to_rule =
( match r.Ast.exception_to_rule with
| None -> None
| Some r'' -> if r'' = r' then None else Some r'' );
})
def
in
let def_rec =
Ast.RuleMap.filter (fun r _ -> not (Ast.RuleMap.mem r exception_targets)) def_rec
in
let exceptions = def_map_to_tree def_info is_def_func def_rec in
Node (exceptions, Ast.RuleMap.find r' def))
exception_targets
in
List.map snd (Ast.RuleMap.bindings base_trees)
@ List.map snd (Ast.RuleMap.bindings exception_trees)
(** From the {!type: rule_tree}, builds an {!constructor: Dcalc.Ast.EDefault} expression in the
scope language. The [~toplevel] parameter is used to know when to place the toplevel binding in
the case of functions. *)
let rec rule_tree_to_expr ~(toplevel : bool) (is_func : Scopelang.Ast.Var.t option)
(tree : rule_tree) : Scopelang.Ast.expr Pos.marked Bindlib.box =
let rule, children = match tree with Leaf r -> (r, []) | Node (r, child) -> (r, child) in
let exceptions, rule =
match tree with Leaf r -> ([], r) | Node (exceptions, r) -> (exceptions, r)
in
(* because each rule has its own variable parameter and we want to convert the whole rule tree
into a function, we need to perform some alpha-renaming of all the expressions *)
let substitute_parameter (e : Scopelang.Ast.expr Pos.marked Bindlib.box) :
@ -66,12 +115,14 @@ let rec rule_tree_to_expr ~(toplevel : bool) (is_func : Scopelang.Ast.Var.t opti
in
let just = substitute_parameter rule.Ast.just in
let cons = substitute_parameter rule.Ast.cons in
let children = Bindlib.box_list (List.map (rule_tree_to_expr ~toplevel:false is_func) children) in
let exceptions =
Bindlib.box_list (List.map (rule_tree_to_expr ~toplevel:false is_func) exceptions)
in
let default =
Bindlib.box_apply3
(fun just cons children ->
(Scopelang.Ast.EDefault (just, cons, children), Pos.get_position just))
just cons children
(fun exceptions just cons ->
(Scopelang.Ast.EDefault (exceptions, just, cons), Pos.get_position just))
exceptions just cons
in
match (is_func, rule.parameter) with
| None, None -> default
@ -79,35 +130,28 @@ let rec rule_tree_to_expr ~(toplevel : bool) (is_func : Scopelang.Ast.Var.t opti
if toplevel then
Scopelang.Ast.make_abs (Array.of_list [ new_param ]) default Pos.no_pos [ typ ] Pos.no_pos
else default
| _ -> assert false
| _ -> (* should not happen *) assert false
(* should not happen *)
(** {1 AST translation} *)
let translate_def (def : Ast.rule Ast.RuleMap.t) : Scopelang.Ast.expr Pos.marked =
(** Translates a definition inside a scope, the resulting expression should be an {!constructor:
Dcalc.Ast.EDefault} *)
let translate_def (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.RuleMap.t)
(typ : Scopelang.Ast.typ Pos.marked) : Scopelang.Ast.expr Pos.marked =
(* Here, we have to transform this list of rules into a default tree. *)
(* Because we can have multiple rules at the top-level and our syntax does not allow that, we
insert a dummy rule at the top *)
let is_func _ (r : Ast.rule) : bool = Option.is_some r.Ast.parameter in
let all_rules_func = Ast.RuleMap.for_all is_func def in
let all_rules_not_func = Ast.RuleMap.for_all (fun n r -> not (is_func n r)) def in
let is_def_func : Dcalc.Ast.typ Pos.marked option =
if all_rules_func then
let typ = (snd (Ast.RuleMap.choose def)).Ast.parameter in
match typ with
| Some (_, typ) ->
let is_typ _ r = snd (Option.get r.Ast.parameter) = typ in
if Ast.RuleMap.for_all is_typ def then Some typ
else
Errors.raise_multispanned_error
"the type of these parameters should be the same, but they \n are different"
(List.map
(fun (_, r) ->
( Some
(Format.asprintf "The type of the parameter of this expression is %a"
Dcalc.Print.format_typ typ),
Pos.get_position (Bindlib.unbox r.Ast.cons) ))
(Ast.RuleMap.bindings (Ast.RuleMap.filter (fun n r -> not (is_typ n r)) def)))
| None -> assert false (* should not happen *)
let is_def_func : Scopelang.Ast.typ Pos.marked option =
if all_rules_func && Ast.RuleMap.cardinal def > 0 then
match Pos.unmark typ with
| Scopelang.Ast.TArrow (t_param, _) -> Some t_param
| _ ->
Errors.raise_spanned_error
(Format.asprintf
"The definitions of %a are function but its type, %a, is not a function type"
Ast.ScopeDef.format_t def_info Scopelang.Print.format_typ typ)
(Pos.get_position typ)
else if all_rules_not_func then None
else
Errors.raise_multispanned_error
@ -122,23 +166,17 @@ let translate_def (def : Ast.rule Ast.RuleMap.t) : Scopelang.Ast.expr Pos.marked
Pos.get_position (Bindlib.unbox r.Ast.cons) ))
(Ast.RuleMap.bindings (Ast.RuleMap.filter (fun n r -> not (is_func n r)) def)) )
in
let dummy_rule = Ast.empty_rule Pos.no_pos is_def_func in
let dummy_rule_name = Ast.RuleName.fresh ("dummy", Pos.no_pos) in
let def =
Ast.RuleMap.add dummy_rule_name dummy_rule
(Ast.RuleMap.map
(fun r ->
match r.Ast.parent_rule with
| Some _ -> r
| None -> { r with parent_rule = Some dummy_rule_name })
def)
in
let def_tree = def_map_to_tree def in
let top_list = def_map_to_tree def_info is_def_func def in
Bindlib.unbox
(rule_tree_to_expr ~toplevel:true
(Option.map (fun _ -> Scopelang.Ast.Var.make ("ρ", Pos.no_pos)) is_def_func)
def_tree)
( match top_list with
| [] ->
(* In this case, there are no rules to define the expression *)
Leaf (Ast.empty_rule Pos.no_pos is_def_func)
| _ -> Node (top_list, Ast.empty_rule Pos.no_pos is_def_func) ))
(** Translates a scope *)
let translate_scope (scope : Ast.scope) : Scopelang.Ast.scope_decl =
let scope_dependencies = Dependency.build_scope_dependencies scope in
Dependency.check_for_cycle scope scope_dependencies;
@ -152,7 +190,7 @@ let translate_scope (scope : Ast.scope) : Scopelang.Ast.scope_decl =
let var_def, var_typ =
Ast.ScopeDefMap.find (Ast.ScopeDef.Var var) scope.scope_defs
in
let expr_def = translate_def var_def in
let expr_def = translate_def (Ast.ScopeDef.Var var) var_def var_typ in
[
Scopelang.Ast.Definition
( ( Scopelang.Ast.ScopeVar
@ -173,7 +211,7 @@ let translate_scope (scope : Ast.scope) : Scopelang.Ast.scope_decl =
match def_key with
| Ast.ScopeDef.Var _ -> assert false (* should not happen *)
| Ast.ScopeDef.SubScopeVar (_, sub_scope_var) ->
let expr_def = translate_def def in
let expr_def = translate_def def_key def def_typ in
let subscop_real_name =
Scopelang.Ast.SubScopeMap.find sub_scope_index scope.scope_sub_scopes
in
@ -202,6 +240,11 @@ let translate_scope (scope : Ast.scope) : Scopelang.Ast.scope_decl =
sub_scope_vars_redefs @ [ Scopelang.Ast.Call (sub_scope, sub_scope_index) ])
scope_ordering)
in
(* Then, after having computed all the scopes variables, we add the assertions *)
let scope_decl_rules =
scope_decl_rules
@ List.map (fun e -> Scopelang.Ast.Assertion (Bindlib.unbox e)) scope.Ast.scope_assertions
in
let scope_sig =
Scopelang.Ast.ScopeVarSet.fold
(fun var acc ->
@ -215,5 +258,11 @@ let translate_scope (scope : Ast.scope) : Scopelang.Ast.scope_decl =
Scopelang.Ast.scope_sig;
}
(** {1 API} *)
let translate_program (pgrm : Ast.program) : Scopelang.Ast.program =
Scopelang.Ast.ScopeMap.map translate_scope pgrm
{
Scopelang.Ast.program_scopes = Scopelang.Ast.ScopeMap.map translate_scope pgrm.program_scopes;
Scopelang.Ast.program_structs = pgrm.program_structs;
Scopelang.Ast.program_enums = pgrm.program_enums;
}

3
src/catala/desugared/dune
View File

@ -4,4 +4,5 @@
(libraries utils dcalc scopelang ocamlgraph))
(documentation
(package catala))
(package catala)
(mld_files desugared))

13
src/catala/driver.ml
View File

@ -18,11 +18,14 @@ module Errors = Utils.Errors
(** Entry function for the executable. Returns a negative number in case of error. *)
let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_output : bool)
(pygmentize_loc : string option) (backend : string) (language : string option)
(ex_scope : string option) (output_file : string option) : int =
(max_prec_digits : int option) (trace : 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.debug_print "Reading files...";
(match max_prec_digits with None -> () | Some i -> Cli.max_prec_digits := i);
let language =
match language with
| Some l ->
@ -43,7 +46,7 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
Errors.raise_error
(Printf.sprintf "The selected backend (%s) is not supported by Catala" backend)
in
let program = Surface.Parser_driver.parse_source_files [ source_file ] language in
let program = Surface.Parser_driver.parse_source_file source_file language in
match backend with
| Cli.Makefile ->
let backend_extensions_list = [ ".tex" ] in
@ -129,10 +132,14 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
(fun (v1, _) (v2, _) -> String.compare (Bindlib.name_of v1) (Bindlib.name_of v2))
results
in
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 "%s -> %a" (Bindlib.name_of var) Dcalc.Print.format_expr result))
(Format.asprintf "@[<hov 2>%s@ =@ %a@]" (Bindlib.name_of var) Dcalc.Print.format_expr
result))
results;
0
with Errors.StructuredError (msg, pos) ->

73
src/catala/index.mld Normal file
View File

@ -0,0 +1,73 @@
{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 |
| |
+----------------------+ 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 }
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}}
}
The main compilation chain is defined in:
{!modules: Catala.Driver}
Last, two more modules contain additional features for the compiler:
{ul
{li {{: literate.html} Literate programming}}
{li {{: utils.html} Compiler utilities}}
}

4
src/catala/literate_programming/dune
View File

@ -2,3 +2,7 @@
(name literate)
(public_name catala.literate)
(libraries re utils surface))
(documentation
(package catala)
(mld_files literate))

14
src/catala/literate_programming/html.ml
View File

@ -23,17 +23,24 @@ module P = Printf
module R = Re.Pcre
module C = Cli
(** {1 Helpers} *)
(** Converts double lines into HTML newlines. *)
let pre_html (s : string) =
let s = String.trim s in
let doublenewline = R.regexp "\n\n" in
let s = R.substitute ~rex:doublenewline ~subst:(fun _ -> "<br/>\n") s in
s
(** Raise an error if pygments cannot be found *)
let raise_failed_pygments (command : string) (error_code : int) : 'a =
Errors.raise_error
(Printf.sprintf "Weaving to HTML failed: pygmentize command \"%s\" returned with error code %d"
command error_code)
(** 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 =
@ -91,6 +98,7 @@ let wrap_html (source_files : string list) (custom_pygments : string option)
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 =
C.debug_print (Printf.sprintf "Pygmenting the code chunk %s" (Pos.to_string (Pos.get_position c)));
@ -125,7 +133,7 @@ let pygmentize_code (c : string Pos.marked) (language : C.backend_lang)
close_in oc;
output
type program_state = InsideArticle | OutsideArticle
(** {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 =
@ -150,7 +158,6 @@ let law_article_item_to_html (custom_pygments : string option) (language : C.bac
Format.fprintf fmt "<div class='code-wrapper'>\n<div class='filename'>%s</div>\n%s\n</div>"
(Pos.get_file (Pos.get_position c))
(pygmentize_code (Pos.same_pos_as ("/*" ^ pprinted_c ^ "*/") c) language custom_pygments)
| A.LawInclude _ -> ()
let rec law_structure_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (i : A.law_structure) : unit =
@ -164,6 +171,7 @@ let rec law_structure_to_html (custom_pygments : string option) (language : C.ba
~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"
@ -189,6 +197,8 @@ let program_item_to_html (custom_pygments : string option) (language : C.backend
(fmt : Format.formatter) (i : A.program_item) : unit =
match i with A.LawStructure s -> law_structure_to_html custom_pygments language fmt s
(** {1 API} *)
let ast_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (program : A.program) : unit =
Format.pp_print_list

34
src/catala/literate_programming/latex.ml
View File

@ -22,6 +22,9 @@ module A = Surface.Ast
module R = Re.Pcre
module C = Cli
(** {1 Helpers} *)
(** Espaces various LaTeX-sensitive characters *)
let pre_latexify (s : string) =
let percent = R.regexp "%" in
let s = R.substitute ~rex:percent ~subst:(fun _ -> "\\%") s in
@ -33,6 +36,9 @@ let pre_latexify (s : string) =
let s = R.substitute ~rex:underscore ~subst:(fun _ -> "\\_") s in
s
(** 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) =
Format.fprintf fmt
@ -57,7 +63,6 @@ let wrap_latex (source_files : string list) (custom_pygments : string option)
\\newunicodechar{→}{$\\rightarrow$}\n\
\\newunicodechar{≠}{$\\neq$}\n\n\
\\fvset{\n\
commandchars=\\\\\\{\\},\n\
numbers=left,\n\
frame=lines,\n\
framesep=3mm,\n\
@ -107,6 +112,7 @@ let wrap_latex (source_files : string list) (custom_pygments : string option)
wrapped fmt;
Format.fprintf fmt "\n\n\\end{document}"
(** Replaces math operators by their nice unicode counterparts *)
let math_syms_replace (c : string) : string =
let date = "\\d\\d/\\d\\d/\\d\\d\\d\\d" in
let syms = R.regexp (date ^ "|!=|<=|>=|--|->|\\*|/") in
@ -122,6 +128,8 @@ let math_syms_replace (c : string) : string =
in
R.substitute ~rex:syms ~subst:syms2cmd c
(** {1 Weaving} *)
let law_article_item_to_latex (language : C.backend_lang) (fmt : Format.formatter)
(i : A.law_article_item) : unit =
match i with
@ -132,18 +140,9 @@ let law_article_item_to_latex (language : C.backend_lang) (fmt : Format.formatte
/*%s*/\n\
\\end{minted}"
(pre_latexify (Filename.basename (Pos.get_file (Pos.get_position c))))
(Pos.get_start_line (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))
| A.LawInclude (A.PdfFile ((file, _), page)) ->
let label = file ^ match page with None -> "" | Some p -> Format.sprintf "_page_%d," p in
Format.fprintf fmt
"\\begin{center}\\textit{Annexe incluse, retranscrite page \\pageref{%s}}\\end{center} \
\\begin{figure}[p]\\begin{center}\\includegraphics[%swidth=\\textwidth]{%s}\\label{%s}\\end{center}\\end{figure}"
label
(match page with None -> "" | Some p -> Format.sprintf "page=%d," p)
file label
| A.LawInclude (A.CatalaFile _ | A.LegislativeText _) -> ()
let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatter)
(i : A.law_structure) : unit =
@ -160,6 +159,15 @@ let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatt
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_latex language) fmt children
| A.LawInclude (A.PdfFile ((file, _), page)) ->
let label = file ^ match page with None -> "" | Some p -> Format.sprintf "_page_%d," p in
Format.fprintf fmt
"\\begin{center}\\textit{Annexe incluse, retranscrite page \\pageref{%s}}\\end{center} \
\\begin{figure}[p]\\begin{center}\\includegraphics[%swidth=\\textwidth]{%s}\\label{%s}\\end{center}\\end{figure}"
label
(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
@ -177,7 +185,7 @@ let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatt
\\end{minted}\n\
\\end{tcolorbox}"
metadata_title metadata_title
(Pos.get_start_line (Pos.get_position c))
(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")
(math_syms_replace (Pos.unmark c))
@ -187,6 +195,8 @@ let program_item_to_latex (language : C.backend_lang) (fmt : Format.formatter) (
: 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")

9
src/catala/literate_programming/literate.mld Normal file
View File

@ -0,0 +1,9 @@
{0 Literate programming}
Related modules:
{!modules: Literate.Html Literate.Latex}
These module take the {{:surface.html} surface representation} of the Catala
program and process it into different literate programming outputs, like
an HTML page or a LaTeX document.

144
src/catala/scope_language/ast.ml
View File

@ -12,53 +12,143 @@
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
module ScopeName = Uid.Make (Uid.MarkedString) ()
(** {1 Identifiers} *)
module ScopeNameSet = Set.Make (ScopeName)
module ScopeMap = Map.Make (ScopeName)
module ScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
module SubScopeName = Uid.Make (Uid.MarkedString) ()
module ScopeNameSet : Set.S with type elt = ScopeName.t = Set.Make (ScopeName)
module SubScopeNameSet = Set.Make (SubScopeName)
module SubScopeMap = Map.Make (SubScopeName)
module ScopeMap : Map.S with type key = ScopeName.t = Map.Make (ScopeName)
module ScopeVar = Uid.Make (Uid.MarkedString) ()
module SubScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
module ScopeVarSet = Set.Make (ScopeVar)
module ScopeVarMap = Map.Make (ScopeVar)
module SubScopeNameSet : Set.S with type elt = SubScopeName.t = Set.Make (SubScopeName)
module SubScopeMap : Map.S with type key = SubScopeName.t = Map.Make (SubScopeName)
module ScopeVar : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
module ScopeVarSet : Set.S with type elt = ScopeVar.t = Set.Make (ScopeVar)
module ScopeVarMap : Map.S with type key = ScopeVar.t = Map.Make (ScopeVar)
module StructName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
module StructMap : Map.S with type key = StructName.t = Map.Make (StructName)
module StructFieldName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module StructFieldMap : Map.S with type key = StructFieldName.t = Map.Make (StructFieldName)
module EnumName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
module EnumMap : Map.S with type key = EnumName.t = Map.Make (EnumName)
module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module EnumConstructorMap : Map.S with type key = EnumConstructor.t = Map.Make (EnumConstructor)
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 = Set.Make (struct
type t = location Pos.marked
let compare x y =
match (Pos.unmark x, Pos.unmark y) with
| ScopeVar (vx, _), ScopeVar (vy, _) -> ScopeVar.compare vx vy
| SubScopeVar (_, (xsubindex, _), (xsubvar, _)), SubScopeVar (_, (ysubindex, _), (ysubvar, _))
->
let c = SubScopeName.compare xsubindex ysubindex in
if c = 0 then ScopeVar.compare xsubvar ysubvar else c
| ScopeVar _, SubScopeVar _ -> -1
| SubScopeVar _, ScopeVar _ -> 1
end)
(** {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
(** 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 Pos.t * (expr, expr Pos.marked) Bindlib.mbinder * Dcalc.Ast.typ Pos.marked list
| EAbs of Pos.t * (expr, expr Pos.marked) Bindlib.mbinder * typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EOp of Dcalc.Ast.operator
| EDefault of expr Pos.marked * expr Pos.marked * expr Pos.marked list
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
let rec locations_used (e : expr Pos.marked) : location Pos.marked list =
let rec locations_used (e : expr Pos.marked) : LocationSet.t =
match Pos.unmark e with
| ELocation l -> [ (l, Pos.get_position e) ]
| EVar _ | ELit _ | EOp _ -> []
| ELocation l -> LocationSet.singleton (l, Pos.get_position e)
| EVar _ | ELit _ | EOp _ -> LocationSet.empty
| EAbs (_, binder, _) ->
let _, body = Bindlib.unmbind binder in
locations_used body
| EStruct (_, es) ->
StructFieldMap.fold
(fun _ e' acc -> LocationSet.union acc (locations_used e'))
es LocationSet.empty
| EStructAccess (e1, _, _) -> locations_used e1
| EEnumInj (e1, _, _) -> locations_used e1
| EMatch (e1, _, es) ->
EnumConstructorMap.fold
(fun _ e' acc -> LocationSet.union acc (locations_used e'))
es (locations_used e1)
| EApp (e1, args) ->
List.fold_left (fun acc arg -> locations_used arg @ acc) (locations_used e1) args
| EIfThenElse (e1, e2, e3) -> locations_used e1 @ locations_used e2 @ locations_used e3
| EDefault (just, cons, subs) ->
List.fold_left
(fun acc sub -> locations_used sub @ acc)
(locations_used just @ locations_used cons)
subs
(fun acc arg -> LocationSet.union (locations_used arg) acc)
(locations_used e1) args
| EIfThenElse (e1, e2, e3) ->
LocationSet.union (locations_used e1)
(LocationSet.union (locations_used e2) (locations_used e3))
| EDefault (excepts, just, cons) ->
List.fold_left
(fun acc except -> LocationSet.union (locations_used except) acc)
(LocationSet.union (locations_used just) (locations_used cons))
excepts
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 = struct
type t = expr Bindlib.var
@ -77,7 +167,7 @@ let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun v -> (v, pos)) (Bindlib.box_var x)
let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t)
(taus : Dcalc.Ast.typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box =
(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)
let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t)
@ -85,15 +175,3 @@ let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box
Bindlib.box_apply2 (fun e u -> (EApp (e, u), pos)) e (Bindlib.box_list u)
module VarMap = Map.Make (Var)
type rule =
| Definition of location Pos.marked * Dcalc.Ast.typ Pos.marked * expr Pos.marked
| Call of ScopeName.t * SubScopeName.t
type scope_decl = {
scope_decl_name : ScopeName.t;
scope_sig : Dcalc.Ast.typ Pos.marked ScopeVarMap.t;
scope_decl_rules : rule list;
}
type program = scope_decl ScopeMap.t

169
src/catala/scope_language/dependency.ml
View File

@ -18,12 +18,12 @@
module Pos = Utils.Pos
module Errors = Utils.Errors
module Vertex = struct
module SVertex = struct
type t = Ast.ScopeName.t
let hash x = Ast.ScopeName.hash x
let compare = compare
let compare = Ast.ScopeName.compare
let equal x y = Ast.ScopeName.compare x y = 0
@ -31,7 +31,7 @@ module Vertex = struct
end
(** On the edges, the label is the expression responsible for the use of the function *)
module Edge = struct
module SEdge = struct
type t = Pos.t
let compare = compare
@ -39,27 +39,29 @@ module Edge = struct
let default = Pos.no_pos
end
module Dependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (Vertex) (Edge)
module TopologicalTraversal = Graph.Topological.Make (Dependencies)
module SDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (SVertex) (SEdge)
module STopologicalTraversal = Graph.Topological.Make (SDependencies)
module SCC = Graph.Components.Make (Dependencies)
module SSCC = Graph.Components.Make (SDependencies)
(** Tarjan's stongly connected components algorithm, provided by OCamlGraph *)
let build_program_dep_graph (prgm : Ast.program) : Dependencies.t =
let g = Dependencies.empty in
let g = Ast.ScopeMap.fold (fun v _ g -> Dependencies.add_vertex g v) prgm g in
let build_program_dep_graph (prgm : Ast.program) : SDependencies.t =
let g = SDependencies.empty in
let g = Ast.ScopeMap.fold (fun v _ g -> SDependencies.add_vertex g v) prgm.program_scopes g in
Ast.ScopeMap.fold
(fun scope_name scope g ->
let subscopes =
List.fold_left
(fun acc r ->
match r with
| Ast.Definition _ -> acc
| Ast.Definition _ | Ast.Assertion _ -> acc
| Ast.Call (subscope, subindex) ->
if subscope = scope_name then
Errors.raise_spanned_error
"The scope %a is calling into itself as a subscope, which is forbidden since \
Catala does not provide recursion"
(Format.asprintf
"The scope %a is calling into itself as a subscope, which is forbidden \
since Catala does not provide recursion"
Ast.ScopeName.format_t scope.Ast.scope_decl_name)
(Pos.get_position (Ast.ScopeName.get_info scope.Ast.scope_decl_name))
else
Ast.ScopeMap.add subscope
@ -69,15 +71,15 @@ let build_program_dep_graph (prgm : Ast.program) : Dependencies.t =
in
Ast.ScopeMap.fold
(fun subscope pos g ->
let edge = Dependencies.E.create subscope pos scope_name in
Dependencies.add_edge_e g edge)
let edge = SDependencies.E.create subscope pos scope_name in
SDependencies.add_edge_e g edge)
subscopes g)
prgm g
prgm.program_scopes g
let check_for_cycle (g : Dependencies.t) : unit =
let check_for_cycle_in_scope (g : SDependencies.t) : unit =
(* if there is a cycle, there will be an strongly connected component of cardinality > 1 *)
let sccs = SCC.scc_list g in
if List.length sccs < Dependencies.nb_vertex g then
let sccs = SSCC.scc_list g in
if List.length sccs < SDependencies.nb_vertex g then
let scc = List.find (fun scc -> List.length scc > 1) sccs in
Errors.raise_multispanned_error "Cyclic dependency detected between scopes!"
(List.flatten
@ -86,7 +88,7 @@ let check_for_cycle (g : Dependencies.t) : unit =
let var_str, var_info =
(Format.asprintf "%a" Ast.ScopeName.format_t v, Ast.ScopeName.get_info v)
in
let succs = Dependencies.succ_e g v in
let succs = SDependencies.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" Ast.ScopeName.format_t succ in
[
@ -96,5 +98,130 @@ let check_for_cycle (g : Dependencies.t) : unit =
])
scc))
let get_scope_ordering (g : Dependencies.t) : Ast.ScopeName.t list =
List.rev (TopologicalTraversal.fold (fun sd acc -> sd :: acc) g [])
let get_scope_ordering (g : SDependencies.t) : Ast.ScopeName.t list =
List.rev (STopologicalTraversal.fold (fun sd acc -> sd :: acc) g [])
module TVertex = struct
type t = Struct of Ast.StructName.t | Enum of Ast.EnumName.t
let hash x = match x with Struct x -> Ast.StructName.hash x | Enum x -> Ast.EnumName.hash x
let compare x y =
match (x, y) with
| Struct x, Struct y -> Ast.StructName.compare x y
| Enum x, Enum y -> Ast.EnumName.compare x y
| Struct _, Enum _ -> 1
| Enum _, Struct _ -> -1
let equal x y =
match (x, y) with
| Struct x, Struct y -> Ast.StructName.compare x y = 0
| Enum x, Enum y -> Ast.EnumName.compare x y = 0
| _ -> false
let format_t (fmt : Format.formatter) (x : t) : unit =
match x with Struct x -> Ast.StructName.format_t fmt x | Enum x -> Ast.EnumName.format_t fmt x
let get_info (x : t) =
match x with Struct x -> Ast.StructName.get_info x | Enum x -> Ast.EnumName.get_info x
end
module TVertexSet = Set.Make (TVertex)
(** On the edges, the label is the expression responsible for the use of the function *)
module TEdge = struct
type t = Pos.t
let compare = compare
let default = Pos.no_pos
end
module TDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (TVertex) (TEdge)
module TTopologicalTraversal = Graph.Topological.Make (TDependencies)
module TSCC = Graph.Components.Make (TDependencies)
(** Tarjan's stongly connected components algorithm, provided by OCamlGraph *)
let rec get_structs_or_enums_in_type (t : Ast.typ Pos.marked) : TVertexSet.t =
match Pos.unmark t with
| Ast.TStruct s -> TVertexSet.singleton (TVertex.Struct s)
| Ast.TEnum e -> TVertexSet.singleton (TVertex.Enum e)
| Ast.TArrow (t1, t2) ->
TVertexSet.union (get_structs_or_enums_in_type t1) (get_structs_or_enums_in_type t2)
| Ast.TLit _ -> TVertexSet.empty
let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TDependencies.t =
let g = TDependencies.empty in
let g =
Ast.StructMap.fold
(fun s fields g ->
List.fold_left
(fun g (_, typ) ->
let def = TVertex.Struct s in
let g = TDependencies.add_vertex g def in
let used = get_structs_or_enums_in_type typ in
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Errors.raise_spanned_error
(Format.asprintf
"The type %a is defined using itself, which is forbidden since Catala does \
not provide recursive types"
TVertex.format_t used)
(Pos.get_position typ)
else
let edge = TDependencies.E.create used (Pos.get_position typ) def in
TDependencies.add_edge_e g edge)
used g)
g fields)
structs g
in
let g =
Ast.EnumMap.fold
(fun e cases g ->
List.fold_left
(fun g (_, typ) ->
let def = TVertex.Enum e in
let g = TDependencies.add_vertex g def in
let used = get_structs_or_enums_in_type typ in
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Errors.raise_spanned_error
(Format.asprintf
"The type %a is defined using itself, which is forbidden since Catala does \
not provide recursive types"
TVertex.format_t used)
(Pos.get_position typ)
else
let edge = TDependencies.E.create used (Pos.get_position typ) def in
TDependencies.add_edge_e g edge)
used g)
g cases)
enums g
in
g
let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : unit =
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))

3
src/catala/scope_language/dune
View File

@ -4,4 +4,5 @@
(libraries utils dcalc ocamlgraph))
(documentation
(package catala))
(package catala)
(mld_files scopelang))

48
src/catala/scope_language/print.ml
View File

@ -28,6 +28,21 @@ let format_location (fmt : Format.formatter) (l : location) : unit =
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Pos.unmark subindex) ScopeVar.format_t
(Pos.unmark subvar)
let typ_needs_parens (e : typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : typ Pos.marked) : unit =
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 -> Dcalc.Print.format_tlit fmt l
| TStruct 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@]" format_typ_with_parens t1 format_typ t2
let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
if needs_parens e then Format.fprintf fmt "(%a)" format_expr e
@ -37,6 +52,26 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
| ELocation l -> Format.fprintf fmt "%a" format_location l
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
| ELit l -> Format.fprintf fmt "%a" Dcalc.Print.format_lit (Pos.same_pos_as l e)
| EStruct (name, fields) ->
Format.fprintf fmt "@[%a @[<hov 2>{@ %a@ }@]@]" Ast.StructName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt (field_name, field_expr) ->
Format.fprintf fmt "%a = %a" Ast.StructFieldName.format_t field_name format_expr
field_expr))
(Ast.StructFieldMap.bindings fields)
| EStructAccess (e1, field, _) ->
Format.fprintf fmt "%a.%a" format_expr e1 Ast.StructFieldName.format_t field
| EEnumInj (e1, cons, _) ->
Format.fprintf fmt "%a@ %a" Ast.EnumConstructor.format_t cons format_expr e1
| EMatch (e1, _, cases) ->
Format.fprintf fmt "@[<hov 2>@[match@ %a@ with@]@ %a@]" format_expr e1
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ |@ ")
(fun fmt (cons_name, case_expr) ->
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) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
@ -46,7 +81,7 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
~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
Dcalc.Print.format_typ tau format_expr arg))
format_typ tau format_expr arg))
xs_tau_arg format_expr body
| EAbs (_, binder, taus) ->
let xs, body = Bindlib.unmbind binder in
@ -54,8 +89,7 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
Format.fprintf fmt "@[<hov 2>λ@ %a@ →@ %a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " ")
(fun fmt (x, tau) ->
Format.fprintf fmt "@[(%a:@ %a)@]" format_var x Dcalc.Print.format_typ tau))
(fun fmt (x, tau) -> Format.fprintf fmt "@[(%a:@ %a)@]" format_var x format_typ tau))
xs_tau format_expr body
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 Dcalc.Print.format_binop
@ -72,10 +106,10 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
e1 format_expr e2 format_expr e3
| 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)
| EDefault (just, cons, subs) ->
if List.length subs = 0 then
| EDefault (excepts, just, cons) ->
if List.length excepts = 0 then
Format.fprintf fmt "@[⟨%a ⊢ %a⟩@]" format_expr just format_expr cons
else
Format.fprintf fmt "@[<hov 2>⟨%a ⊢ %a |@ %a⟩@]" format_expr just format_expr cons
Format.fprintf fmt "@[<hov 2>⟨%a@ |@ %a ⊢ %a⟩@]"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_expr)
subs
excepts format_expr just format_expr cons

303
src/catala/scope_language/scope_to_dcalc.ml
View File

@ -19,14 +19,21 @@ module Cli = Utils.Cli
type scope_sigs_ctx = ((Ast.ScopeVar.t * Dcalc.Ast.typ) list * Dcalc.Ast.Var.t) Ast.ScopeMap.t
type ctx = {
structs : Ast.struct_ctx;
enums : Ast.enum_ctx;
scope_name : Ast.ScopeName.t;
scopes_parameters : scope_sigs_ctx;
scope_vars : (Dcalc.Ast.Var.t * Dcalc.Ast.typ) Ast.ScopeVarMap.t;
subscope_vars : (Dcalc.Ast.Var.t * Dcalc.Ast.typ) Ast.ScopeVarMap.t Ast.SubScopeMap.t;
local_vars : Dcalc.Ast.Var.t Ast.VarMap.t;
}
let empty_ctx (scopes_ctx : scope_sigs_ctx) =
let empty_ctx (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) (scopes_ctx : scope_sigs_ctx)
(scope_name : Ast.ScopeName.t) =
{
structs = struct_ctx;
enums = enum_ctx;
scope_name;
scopes_parameters = scopes_ctx;
scope_vars = Ast.ScopeVarMap.empty;
subscope_vars = Ast.SubScopeMap.empty;
@ -37,6 +44,19 @@ 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
| 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 ->
let s_fields = Ast.StructMap.find s_uid ctx.structs in
Dcalc.Ast.TTuple (List.map (fun (_, t) -> translate_typ ctx t) s_fields)
| Ast.TEnum e_uid ->
let e_cases = Ast.EnumMap.find e_uid ctx.enums in
Dcalc.Ast.TEnum (List.map (fun (_, t) -> translate_typ ctx t) e_cases) )
t
let merge_defaults (caller : Dcalc.Ast.expr Pos.marked Bindlib.box)
(callee : Dcalc.Ast.expr Pos.marked Bindlib.box) : Dcalc.Ast.expr Pos.marked Bindlib.box =
let caller =
@ -48,7 +68,7 @@ let merge_defaults (caller : Dcalc.Ast.expr Pos.marked Bindlib.box)
Bindlib.box_apply2
(fun caller callee ->
( Dcalc.Ast.EDefault
((Dcalc.Ast.ELit (Dcalc.Ast.LBool true), Pos.no_pos), caller, [ callee ]),
([ caller ], (Dcalc.Ast.ELit (Dcalc.Ast.LBool true), Pos.no_pos), callee),
Pos.no_pos ))
caller callee
in
@ -56,12 +76,117 @@ let merge_defaults (caller : Dcalc.Ast.expr Pos.marked Bindlib.box)
let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Pos.marked Bindlib.box
=
(* Cli.debug_print (Format.asprintf "Translating: %a" Print.format_expr e); *)
Bindlib.box_apply
(fun (x : Dcalc.Ast.expr) -> Pos.same_pos_as x e)
( 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) ->
let struct_sig = Ast.StructMap.find struct_name ctx.structs in
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 "The field %a does not belong to the structure %a"
Ast.StructFieldName.format_t field_name Ast.StructName.format_t struct_name)
(Pos.get_position e)
in
let field_d = translate_expr ctx field_e in
let field_d =
Bindlib.box_apply
(fun field_d -> (field_d, Some (Ast.StructFieldName.get_info field_name)))
field_d
in
(field_d :: d_fields, Ast.StructFieldMap.remove field_name e_fields))
struct_sig ([], e_fields)
in
if Ast.StructFieldMap.cardinal remaining_e_fields > 0 then
Errors.raise_spanned_error
(Format.asprintf "Missing fields for structure %a: %a" Ast.StructName.format_t
struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (field_name, _) ->
Format.fprintf fmt "%a" Ast.StructFieldName.format_t field_name))
(Ast.StructFieldMap.bindings remaining_e_fields))
(Pos.get_position e)
else
Bindlib.box_apply (fun d_fields -> Dcalc.Ast.ETuple d_fields) (Bindlib.box_list d_fields)
| EStructAccess (e1, field_name, struct_name) ->
let struct_sig = Ast.StructMap.find struct_name ctx.structs in
let _, field_index =
try List.assoc field_name (List.mapi (fun i (x, y) -> (x, (y, i))) struct_sig)
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "The field %a does not belong to the structure %a"
Ast.StructFieldName.format_t field_name Ast.StructName.format_t struct_name)
(Pos.get_position e)
in
let e1 = translate_expr ctx e1 in
Bindlib.box_apply
(fun e1 ->
Dcalc.Ast.ETupleAccess (e1, field_index, Some (Ast.StructFieldName.get_info field_name)))
e1
| EEnumInj (e1, constructor, enum_name) ->
let enum_sig = Ast.EnumMap.find enum_name ctx.enums in
let _, constructor_index =
try List.assoc constructor (List.mapi (fun i (x, y) -> (x, (y, i))) enum_sig)
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "The constructor %a does not belong to the enum %a"
Ast.EnumConstructor.format_t constructor Ast.EnumName.format_t enum_name)
(Pos.get_position e)
in
let e1 = translate_expr ctx e1 in
Bindlib.box_apply
(fun e1 ->
Dcalc.Ast.EInj
( e1,
constructor_index,
Ast.EnumConstructor.get_info constructor,
List.map (fun (_, t) -> translate_typ ctx t) enum_sig ))
e1
| EMatch (e1, enum_name, cases) ->
let enum_sig = Ast.EnumMap.find enum_name ctx.enums in
let d_cases, remaining_e_cases =
List.fold_right
(fun (constructor, _) (d_cases, e_cases) ->
let case_e =
try Ast.EnumConstructorMap.find constructor e_cases
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf
"The constructor %a of enum %a is missing from this pattern matching"
Ast.EnumConstructor.format_t constructor Ast.EnumName.format_t enum_name)
(Pos.get_position e)
in
let case_d = translate_expr ctx case_e in
let case_d =
Bindlib.box_apply
(fun case_d -> (case_d, Ast.EnumConstructor.get_info constructor))
case_d
in
(case_d :: d_cases, Ast.EnumConstructorMap.remove constructor e_cases))
enum_sig ([], cases)
in
if Ast.EnumConstructorMap.cardinal remaining_e_cases > 0 then
Errors.raise_spanned_error
(Format.asprintf "Patter matching is incomplete for enum %a: missing cases %a"
Ast.EnumName.format_t enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (case_name, _) ->
Format.fprintf fmt "%a" Ast.EnumConstructor.format_t case_name))
(Ast.EnumConstructorMap.bindings remaining_e_cases))
(Pos.get_position e)
else
let e1 = translate_expr ctx e1 in
Bindlib.box_apply2
(fun d_fields e1 -> Dcalc.Ast.EMatch (e1, d_fields))
(Bindlib.box_list d_cases) e1
| EApp (e1, args) ->
Bindlib.box_apply2
(fun e u -> Dcalc.Ast.EApp (e, u))
@ -83,12 +208,14 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
body
in
let binder = Bindlib.bind_mvar new_xs body in
Bindlib.box_apply (fun b -> Dcalc.Ast.EAbs (pos_binder, b, typ)) binder
| EDefault (just, cons, subs) ->
Bindlib.box_apply
(fun b -> Dcalc.Ast.EAbs (pos_binder, b, List.map (translate_typ ctx) typ))
binder
| EDefault (excepts, just, cons) ->
Bindlib.box_apply3
(fun j c s -> Dcalc.Ast.EDefault (j, c, s))
(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)
(Bindlib.box_list (List.map (translate_expr ctx) subs))
| ELocation (ScopeVar a) ->
Bindlib.box_var (fst (Ast.ScopeVarMap.find (Pos.unmark a) ctx.scope_vars))
| ELocation (SubScopeVar (_, s, a)) -> (
@ -100,10 +227,10 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf
"The variable %a.%a cannot be used here, 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))
"The variable %a.%a cannot be used here,\n\
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) )
| EIfThenElse (cond, et, ef) ->
Bindlib.box_apply3
@ -111,22 +238,45 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
(translate_expr ctx cond) (translate_expr ctx et) (translate_expr ctx ef)
| EOp op -> Bindlib.box (Dcalc.Ast.EOp op) )
let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list) (pos_sigma : Pos.t) :
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 =
match rule with
| Definition ((ScopeVar a, var_def_pos), tau, e) ->
let a_name = Ast.ScopeVar.get_info (Pos.unmark a) in
let a_var = Dcalc.Ast.Var.make a_name in
let tau = translate_typ ctx tau in
let new_ctx =
{
ctx with
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 pos_sigma in
let next_e, new_ctx = translate_rules new_ctx rest (sigma_name, pos_sigma) 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
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
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) ->
@ -136,6 +286,7 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list) (pos
(Ast.SubScopeName.get_info (Pos.unmark subs_index))
in
let a_var = (Dcalc.Ast.Var.make a_name, var_def_pos) in
let tau = translate_typ ctx tau in
let new_ctx =
{
ctx with
@ -155,21 +306,33 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list) (pos
ctx.subscope_vars;
}
in
let next_e, new_ctx = translate_rules new_ctx rest pos_sigma in
let next_e, new_ctx = translate_rules new_ctx rest (sigma_name, pos_sigma) in
let intermediate_e =
Dcalc.Ast.make_abs
(Array.of_list [ Pos.unmark a_var ])
next_e var_def_pos
[ (Dcalc.Ast.TArrow ((TUnit, var_def_pos), tau), var_def_pos) ]
[ (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
in
let silent_var = Dcalc.Ast.Var.make ("_", Pos.no_pos) in
let thunked_new_e =
Dcalc.Ast.make_abs
(Array.of_list [ silent_var ])
new_e var_def_pos
[ (Dcalc.Ast.TUnit, var_def_pos) ]
[ (Dcalc.Ast.TLit TUnit, var_def_pos) ]
var_def_pos
in
let out_e = Dcalc.Ast.make_app intermediate_e [ thunked_new_e ] (Pos.get_position e) in
@ -216,54 +379,102 @@ let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list) (pos
ctx.subscope_vars;
}
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
in
let call_expr =
Bindlib.box_apply2
(fun e u -> (Dcalc.Ast.EApp (e, u), Pos.no_pos))
(Dcalc.Ast.make_var
(scope_dcalc_var, Pos.get_position (Ast.SubScopeName.get_info subindex)))
(Bindlib.box_list subscope_args)
subscope_func (Bindlib.box_list subscope_args)
in
let result_tuple_var = Dcalc.Ast.Var.make ("result", Pos.no_pos) in
let next_e, new_ctx = translate_rules new_ctx rest pos_sigma 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 =
Bindlib.box_apply
(fun r -> (Dcalc.Ast.ETupleAccess (r, i), pos_sigma))
(fun r -> (Dcalc.Ast.ETupleAccess (r, i, None), 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)
in
( Dcalc.Ast.make_let_in result_tuple_var
( Dcalc.Ast.TTuple (List.map (fun (_, tau, _) -> (tau, pos_sigma)) all_subscope_vars_dcalc),
pos_sigma )
call_expr results_bindings,
let results_bindings =
Bindlib.box_apply
(fun results_bindings ->
( 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 results_bindings ),
[ results_bindings ] ),
Pos.get_position results_bindings ))
results_bindings
in
let result_tuple_typ =
( Dcalc.Ast.TTuple (List.map (fun (_, tau, _) -> (tau, pos_sigma)) all_subscope_vars_dcalc),
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 new_e = translate_expr ctx e in
( Dcalc.Ast.make_let_in
(Dcalc.Ast.Var.make ("_", Pos.no_pos))
(Dcalc.Ast.TLit TUnit, Pos.no_pos)
(Bindlib.box_apply (fun new_e -> Pos.same_pos_as (Dcalc.Ast.EAssert new_e) e) new_e)
next_e,
new_ctx )
and translate_rules (ctx : ctx) (rules : Ast.rule list) (pos_sigma : Pos.t) :
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 =
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, pos_sigma))
(fun args -> (Dcalc.Ast.ETuple (List.map (fun arg -> (arg, None)) args), 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 pos_sigma
| hd :: tl -> translate_rule ctx hd tl (sigma_name, pos_sigma)
let translate_scope_decl (sctx : scope_sigs_ctx) (sigma : Ast.scope_decl) :
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 =
let ctx = empty_ctx sctx in
let pos_sigma = Pos.get_position (Ast.ScopeName.get_info sigma.scope_decl_name) in
let rules, ctx = translate_rules ctx sigma.scope_decl_rules pos_sigma in
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 =
List.map
@ -272,12 +483,13 @@ let translate_scope_decl (sctx : scope_sigs_ctx) (sigma : Ast.scope_decl) :
(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))
(Array.of_list (List.map (fun (_, _, x) -> x) scope_variables))
rules pos_sigma
(List.map
(fun (_, tau, _) ->
(Dcalc.Ast.TArrow ((Dcalc.Ast.TUnit, pos_sigma), (tau, pos_sigma)), pos_sigma))
(Dcalc.Ast.TArrow ((Dcalc.Ast.TLit TUnit, pos_sigma), (tau, pos_sigma)), pos_sigma))
scope_variables)
pos_sigma
@ -286,23 +498,30 @@ let build_scope_typ_from_sig (scope_sig : (Ast.ScopeVar.t * Dcalc.Ast.typ) list)
let result_typ = (Dcalc.Ast.TTuple (List.map (fun (_, tau) -> (tau, pos)) scope_sig), pos) in
List.fold_right
(fun (_, arg_t) acc ->
(Dcalc.Ast.TArrow ((Dcalc.Ast.TArrow ((TUnit, pos), (arg_t, pos)), pos), acc), pos))
(Dcalc.Ast.TArrow ((Dcalc.Ast.TArrow ((TLit TUnit, pos), (arg_t, pos)), pos), acc), pos))
scope_sig result_typ
let translate_program (prgm : Ast.program) (top_level_scope_name : Ast.ScopeName.t) :
Dcalc.Ast.expr Pos.marked =
let scope_dependencies = Dependency.build_program_dep_graph prgm in
Dependency.check_for_cycle scope_dependencies;
Dependency.check_for_cycle_in_scope scope_dependencies;
Dependency.check_type_cycles prgm.program_structs prgm.program_enums;
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 sctx : scope_sigs_ctx =
Ast.ScopeMap.map
(fun scope ->
Ast.ScopeMap.mapi
(fun scope_name scope ->
let scope_dvar = Dcalc.Ast.Var.make (Ast.ScopeName.get_info scope.Ast.scope_decl_name) in
( List.map
(fun (scope_var, tau) -> (scope_var, Pos.unmark tau))
(fun (scope_var, tau) ->
let tau =
translate_typ (empty_ctx struct_ctx enum_ctx Ast.ScopeMap.empty scope_name) tau
in
(scope_var, Pos.unmark tau))
(Ast.ScopeVarMap.bindings scope.scope_sig),
scope_dvar ))
prgm
prgm.program_scopes
in
(* the final expression on which we build on is the variable of the top-level scope that we are
returning *)
@ -313,9 +532,9 @@ let translate_program (prgm : Ast.program) (top_level_scope_name : Ast.ScopeName
(let acc =
List.fold_right
(fun scope_name (acc : Dcalc.Ast.expr Pos.marked Bindlib.box) ->
let scope = Ast.ScopeMap.find scope_name prgm in
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 sctx scope 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)

38
src/catala/scope_language/scopelang.mld Normal file
View File

@ -0,0 +1,38 @@
{0 The scope language }
This representation is the third in the compilation chain
(see {{: index.html#architecture} Architecture}). Its main difference
with the previous {{: desugared.html} desugared representation} is that inside
a scope, the definitions are ordered according to their computational
dependency order, and each definition is a {!constructor: Dcalc.Ast.EDefault} tree
instead of a flat list of rules.
The module describing the abstract syntax tree is:
{!modules: Scopelang.Ast}
Printing helpers can be found in {!module: Scopelang.Print}.
This intermediate representation corresponds to the scope language
presented in the {{: https://github.com/CatalaLang/catala/raw/master/doc/formalization/formalization.pdf}
Catala formalization}.
{1 Translation to the default calculus}
Related modules:
{!modules: Scopelang.Dependency Scopelang.Scope_to_dcalc}
The translation from the scope language to the
{{: dcalc.html} default calculus} involves three big features:
{ol
{li Translating structures and enums into simpler sum and product types}
{li Build thunked signatures for the scopes as functions }
{li Transform the list of scopes into a program}
}
1 and 3 involve computing dependency graphs for respectively the structs and
enums on one hand, and the inter-scope dependencies on the other hand. Both
can be found in {!module: Scopelang.Dependency}, while
{!module: Scopelang.Scope_to_dcalc} is mostly responsible for 2.

30
src/catala/utils/cli.ml
View File

@ -21,6 +21,11 @@ let debug_flag = ref false
(* Styles the terminal output *)
let style_flag = ref true
(* Max number of digits to show for decimal results *)
let max_prec_digits = ref 20
let trace_flag = ref false
open Cmdliner
let file =
@ -33,6 +38,9 @@ let debug = Arg.(value & flag & info [ "debug"; "d" ] ~doc:"Prints debug informa
let unstyled = Arg.(value & flag & info [ "unstyled" ] ~doc:"Removes styling from terminal output")
let trace_opt =
Arg.(value & flag & info [ "trace"; "t" ] ~doc:"Displays a trace of the intepreter's computation")
let wrap_weaved_output =
Arg.(
value & flag
@ -53,6 +61,13 @@ let language =
& info [ "l"; "language" ] ~docv:"LANG"
~doc:"Input language among: en, fr, non-verbose (default non-verbose)")
let max_prec_digits_opt =
Arg.(
value
& opt (some int) None
& info [ "p"; "max_digits_printed" ] ~docv:"LANG"
~doc:"Maximum number of significant digits printed for decimal results (default 20)")
let ex_scope =
Arg.(
value & opt (some string) None & info [ "s"; "scope" ] ~docv:"SCOPE" ~doc:"Scope to be executed")
@ -76,13 +91,13 @@ let pygmentize_loc =
Arg.(
value
& opt (some string) None
& info [ "pygmentize"; "p" ] ~docv:"PYGMENTIZE"
& info [ "pygmentize" ] ~docv:"PYGMENTIZE"
~doc:"Location of a custom pygmentize executable for LaTeX source code highlighting")
let catala_t f =
Term.(
const f $ file $ debug $ unstyled $ wrap_weaved_output $ pygmentize_loc $ backend $ language
$ ex_scope $ output)
$ max_prec_digits_opt $ trace_opt $ ex_scope $ output)
let info =
let doc =
@ -96,11 +111,12 @@ let info =
from legislative texts.";
`S Manpage.s_authors;
`P "Denis Merigoux <denis.merigoux@inria.fr>";
`P "Nicolas Chataing <nicolas.chataing@ens.fr>";
`S Manpage.s_examples;
`P "Typical usage:";
`Pre "catala LaTeX file.catala";
`S Manpage.s_bugs;
`P "Please file bug reports at https://gitlab.inria.fr/verifisc/catala/issues";
`P "Please file bug reports at https://github.com/CatalaLang/catala/issues";
]
in
let exits = Term.default_exits @ [ Term.exit_info ~doc:"on error." 1 ] in
@ -130,6 +146,9 @@ let warning_marker () = print_with_style [ ANSITerminal.Bold; ANSITerminal.yello
(** Prints [\[RESULT\]] in green on the terminal standard output *)
let result_marker () = print_with_style [ ANSITerminal.Bold; ANSITerminal.green ] "[RESULT] "
(** Prints [\[LOG\]] in red on the terminal error output *)
let log_marker () = print_with_style [ ANSITerminal.Bold; ANSITerminal.black ] "[LOG] "
(**{2 Printers}*)
(** All the printers below print their argument after the correct marker *)
@ -176,3 +195,8 @@ let result_print (s : string) =
Printf.printf "%s\n" (add_prefix_to_each_line s (fun _ -> result_marker ()));
flush stdout;
flush stdout
let log_print (s : string) =
Printf.printf "%s\n" (add_prefix_to_each_line s (fun _ -> log_marker ()));
flush stdout;
flush stdout

4
src/catala/utils/dune
View File

@ -2,3 +2,7 @@
(name utils)
(public_name catala.utils)
(libraries cmdliner dune-build-info ANSITerminal))
(documentation
(package catala)
(mld_files utils))

7
src/catala/utils/errors.ml
View File

@ -14,7 +14,12 @@
(** Error formatting and helper functions *)
(** {1 Error exception and printing} *)
exception StructuredError of (string * (string option * Pos.t) list)
(** The payload of the expression is a main error message, with a list of secondary positions
related to the error, each carrying an optional secondary message to describe what is pointed by
the position. *)
let print_structured_error (msg : string) (pos : (string option * Pos.t) list) : string =
Printf.sprintf "%s%s%s" msg
@ -27,6 +32,8 @@ let print_structured_error (msg : string) (pos : (string option * Pos.t) list) :
(Pos.retrieve_loc_text pos))
pos))
(** {1 Error exception and printing} *)
let raise_spanned_error (msg : string) ?(span_msg : string option) (span : Pos.t) : 'a =
raise (StructuredError (msg, [ (span_msg, span) ]))

13
src/catala/utils/uid.ml
View File

@ -15,7 +15,7 @@
module type Info = sig
type info
val format_info : info -> string
val format_info : Format.formatter -> info -> unit
end
module type Id = sig
@ -34,12 +34,7 @@ module type Id = sig
val hash : t -> int
end
module Make (X : sig
type info
val format_info : info -> string
end)
() : Id with type info = X.info = struct
module Make (X : Info) () : Id with type info = X.info = struct
type t = { id : int; info : X.info }
type info = X.info
@ -55,7 +50,7 @@ end)
let compare (x : t) (y : t) : int = compare x.id y.id
let format_t (fmt : Format.formatter) (x : t) : unit =
Format.fprintf fmt "%s" (X.format_info x.info)
Format.fprintf fmt "%a" X.format_info x.info
let hash (x : t) : int = x.id
end
@ -63,5 +58,5 @@ end
module MarkedString = struct
type info = string Pos.marked
let format_info (s, _) = s
let format_info fmt (s, _) = Format.fprintf fmt "%s" s
end

12
src/catala/utils/uid.mli
View File

@ -12,14 +12,21 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Global identifiers factories using a generative functor *)
(** The information carried in global identifiers *)
module type Info = sig
type info
val format_info : info -> string
val format_info : Format.formatter -> info -> unit
end
module MarkedString : Info with type info = string Pos.marked
(** The only kind of information carried in Catala identifiers is the original string of the
identifier annotated with the position where it is declared or used. *)
(** Identifiers have abstract types, but are comparable so they can be used as keys in maps or sets.
Their underlying information can be retrieved at any time. *)
module type Id = sig
type t
@ -36,4 +43,7 @@ module type Id = sig
val hash : t -> int
end
(** This is the generative functor that ensures that two modules resulting from two different calls
to [Make] will be viewed as different types [t] by the OCaml typechecker. Prevents mixing up
different sorts of identifiers. *)
module Make (X : Info) () : Id with type info = X.info

38
src/catala/utils/utils.mld Normal file
View File

@ -0,0 +1,38 @@
{0 Compiler utilities}
{1 Unique identifiers}
Related modules:
{!modules: Utils.Uid}
In {{: desugared.html} the desugared representation} or in the
{{: scopelang.html} the scope language}, a number of things are named using
global identifiers. These identifiers use OCaml's type system to statically
distinguish e.g. a scope identifier from a struct identifier.
The {!module: Utils.Uid} module provides a generative functor whose output is
a fresh sort of global identifiers.
{1 Source code positions}
Related modules:
{!modules: Utils.Pos}
This module is used throughout the compiler to annotate the abstract syntax
trees with information about the position of the element in the original source
code. These annotations are critical to produce readable error messages.
{1 Error messages}
Related modules:
{!modules: Utils.Errors}
Error handling is critical in a compiler. The Catala compiler uses an architecture
of error messages inspired by the Rust compiler, where error messages all
correspond to the same exception. This exception carries messages and positions
that are displayed in the end in a nicely-formatted error message.
Hence, all error thrown by the compiler should use {!module: Utils.Errors}

1
src/dune
View File

@ -1,5 +1,6 @@
(executable
(name catala)
(modes native js)
(package catala)
(modules catala)
(public_name catala)

15
src/legifrance_catala.ml
View File

@ -1,15 +0,0 @@
(* 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. *)
let _ = Legifrance_catala.Main.main ()

6
syntax_highlighting/en/atom/grammars/catala_en.cson
View File

@ -100,7 +100,7 @@
'name' : 'keyword.control.catala_en'
}
{
'match' : '\\b(scope|depends\\s+on|declaration|includes|collection|content|optional|structure|enumeration|context|rule|under\\s+condition|condition|data|consequence|fulfilled|equals|assertion|definition)\\b'
'match' : '\\b(scope|depends\\s+on|declaration|includes|collection|content|optional|structure|enumeration|context|rule|under\\s+condition|condition|data|consequence|fulfilled|equals|assertion|definition|label|exception)\\b'
'name' : 'keyword.other.catala_en'
}
{
@ -120,11 +120,11 @@
'name' : 'punctuation.catala_en'
}
{
'match' : '(\\-\\>|\\+|\\-|\\*|/|\\!|not|or|and|=|>|<|\\$|%|year|month|day)'
'match' : '(\\-\\>|\\+|\\-|\\*|/|\\!|not|or|and|=|>|<|\$|%|year|month|day)'
'name' : 'keyword.operator.catala_en'
}
{
'match' : '\\b(integer|boolean|date|amount|text|decimal|number|sum|now)\\b'
'match' : '\\b(integer|boolean|date|money|text|decimal|number|sum|now)\\b'
'name' : 'support.type.catala_en'
}
{

6
syntax_highlighting/en/catala_en.iro
View File

@ -213,7 +213,7 @@ code : context {
}
: pattern {
regex \= \b(scope|depends\s+on|declaration|includes|collection|content|optional|structure|enumeration|context|rule|under\s+condition|condition|data|consequence|fulfilled|equals|assertion|definition)\b
regex \= \b(scope|depends\s+on|declaration|includes|collection|content|optional|structure|enumeration|context|rule|under\s+condition|condition|data|consequence|fulfilled|equals|assertion|definition|label|exception)\b
styles [] = .keyword_rule ;
}
@ -240,12 +240,12 @@ code : context {
}
: pattern {
regex \= (\-\>|\+|\-|\*|/|\!|not|or|and|=|>|<|\\$|%|year|month|day)
regex \= (\-\>|\+|\-|\*|/|\!|not|or|and|=|>|<|\$|%|year|month|day)
styles [] = .operator;
}
: pattern {
regex \= \b(integer|boolean|date|amount|text|decimal|number|sum|now)\b
regex \= \b(integer|boolean|date|money|text|decimal|number|sum|now)\b
styles [] = .primitive;
}

22
syntax_highlighting/en/pygments/catala_en.py
View File

@ -3,7 +3,8 @@ from pygments.token import *
import re
__all__=['CatalaEnLexer']
__all__ = ['CatalaEnLexer']
class CatalaEnLexer(RegexLexer):
name = 'CatalaEn'
@ -12,7 +13,7 @@ class CatalaEnLexer(RegexLexer):
flags = re.MULTILINE | re.UNICODE
tokens = {
'root' : [
'root': [
(u'(@@)', bygroups(Generic.Heading), 'main__1'),
(u'(@)', bygroups(Generic.Heading), 'main__2'),
(u'([^\\/\\n\\r])', bygroups(Text)),
@ -20,18 +21,21 @@ class CatalaEnLexer(RegexLexer):
('(\n|\r|\r\n)', Text),
('.', Text),
],
'code' : [
'code': [
(u'(\\*\\/)', bygroups(Text), 'root'),
(u'(\\s*\\#.*$)', bygroups(Comment.Single)),
(u'(context)(\\s+)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)', bygroups(Keyword.Declaration, Text, Name.Variable)),
(u'(context)(\\s+)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)',
bygroups(Keyword.Declaration, Text, Name.Variable)),
(u'\\b(match|with\\s+pattern|fixed|by|decreasing|increasing|varies|with|we\\s+have|in|such\\s+that|exists|for|all|of|if|then|else)\\b', bygroups(Keyword.Reserved)),
(u'\\b(scope|depends\\s+on|declaration|includes|collection|content|optional|structure|enumeration|context|rule|under\\s+condition|condition|data|consequence|fulfilled|equals|assertion|definition)\\b', bygroups(Keyword.Declaration)),
(u'\\b(scope|depends\\s+on|declaration|includes|collection|content|optional|structure|enumeration|context|rule|under\\s+condition|condition|data|consequence|fulfilled|equals|assertion|definition|label|exception)\\b', bygroups(Keyword.Declaration)),
(u'(\\|[0-9]+/[0-9]+/[0-9]+\\|)', bygroups(Number.Integer)),
(u'\\b(true|false)\\b', bygroups(Keyword.Constant)),
(u'\\b([0-9]+(,[0.9]*|))\\b', bygroups(Number.Integer)),
(u'(\\-\\-|\\;|\\.|\\,|\\:|\\(|\\))', bygroups(Operator)),
(u'(\\-\\>|\\+|\\-|\\*|/|\\!|not|or|and|=|>|<|\\$|%|year|month|day)', bygroups(Operator)),
(u'\\b(integer|boolean|date|amount|text|decimal|number|sum|now)\\b', bygroups(Keyword.Type)),
(u'(\\-\\>|\\+|\\-|\\*|/|\\!|not|or|and|=|>|<|\$|%|year|month|day)',
bygroups(Operator)),
(u'\\b(integer|boolean|date|money|text|decimal|number|sum|now)\\b',
bygroups(Keyword.Type)),
(u'\\b([A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)(\\.)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)\\b', bygroups(Name.Class, Operator, Name.Variable)),
(u'\\b([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)(\\.)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\'\\.]*)\\b', bygroups(Name.Variable, Operator, Text)),
(u'\\b([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)\\b', bygroups(Name.Variable)),
@ -39,13 +43,13 @@ class CatalaEnLexer(RegexLexer):
('(\n|\r|\r\n)', Text),
('.', Text),
],
'main__1' : [
'main__1': [
(u'(@@)', bygroups(Generic.Heading), 'root'),
(u'(.)', bygroups(Generic.Heading)),
('(\n|\r|\r\n)', Text),
('.', Text),
],
'main__2' : [
'main__2': [
(u'(@)', bygroups(Generic.Heading), 'root'),
(u'(.)', bygroups(Generic.Heading)),
('(\n|\r|\r\n)', Text),

6
syntax_highlighting/en/vscode/syntaxes/catalavs.xml
View File

@ -161,7 +161,7 @@
</dict>
<dict>
<key>match</key>
<string>\b(scope|depends\s+on|declaration|includes|collection|content|optional|structure|enumeration|context|rule|under\s+condition|condition|data|consequence|fulfilled|equals|assertion|definition)\b</string>
<string>\b(scope|depends\s+on|declaration|includes|collection|content|optional|structure|enumeration|context|rule|under\s+condition|condition|data|consequence|fulfilled|equals|assertion|definition|label|exception)\b</string>
<key>name</key>
<string>keyword.other.catala_en</string>
</dict>
@ -191,13 +191,13 @@
</dict>
<dict>
<key>match</key>
<string>(\-\&gt;|\+|\-|\*|/|\!|not|or|and|=|&gt;|&lt;|\\$|%|year|month|day)</string>
<string>(\-\&gt;|\+|\-|\*|/|\!|not|or|and|=|&gt;|&lt;|\$|%|year|month|day)</string>
<key>name</key>
<string>keyword.operator.catala_en</string>
</dict>
<dict>
<key>match</key>
<string>\b(integer|boolean|date|amount|text|decimal|number|sum|now)\b</string>
<string>\b(integer|boolean|date|money|text|decimal|number|sum|now)\b</string>
<key>name</key>
<string>support.type.catala_en</string>
</dict>

4
syntax_highlighting/fr/atom/grammars/catala_fr.cson
View File

@ -100,7 +100,7 @@
'name' : 'keyword.control.catala_fr'
}
{
'match' : '\\b(champ\\s+d\'application|si\\s+et\\s+seulement\\s+si|dépend\\s+de|déclaration|inclus|collection|contenu|optionnel|structure|énumération|contexte|règle|sous\\s+condition|condition|donnée|conséquence|rempli|égal\\s+à|assertion|définition)\\b'
'match' : '\\b(champ\\s+d\'application|si\\s+et\\s+seulement\\s+si|dépend\\s+de|déclaration|inclus|collection|contenu|optionnel|structure|énumération|contexte|règle|sous\\s+condition|condition|donnée|conséquence|rempli|égal\\s+à|assertion|définition|étiquette|exception)\\b'
'name' : 'keyword.other.catala_fr'
}
{
@ -124,7 +124,7 @@
'name' : 'keyword.operator.catala_fr'
}
{
'match' : '\\b(entier|booléen|date|montant|texte|décimal|décret|loi|nombre|somme|date_aujourd_hui)\\b'
'match' : '\\b(entier|booléen|date|argent|texte|décimal|décret|loi|nombre|somme|date_aujourd_hui)\\b'
'name' : 'support.type.catala_fr'
}
{

4
syntax_highlighting/fr/catala_fr.iro
View File

@ -213,7 +213,7 @@ code : context {
}
: pattern {
regex \= \b(champ\s+d'application|si\s+et\s+seulement\s+si|dépend\s+de|déclaration|inclus|collection|contenu|optionnel|structure|énumération|contexte|règle|sous\s+condition|condition|donnée|conséquence|rempli|égal\s+à|assertion|définition)\b
regex \= \b(champ\s+d'application|si\s+et\s+seulement\s+si|dépend\s+de|déclaration|inclus|collection|contenu|optionnel|structure|énumération|contexte|règle|sous\s+condition|condition|donnée|conséquence|rempli|égal\s+à|assertion|définition|étiquette|exception)\b
styles [] = .keyword_rule ;
}
@ -245,7 +245,7 @@ code : context {
}
: pattern {
regex \= \b(entier|booléen|date|montant|texte|décimal|décret|loi|nombre|somme|date_aujourd_hui)\b
regex \= \b(entier|booléen|date|argent|texte|décimal|décret|loi|nombre|somme|date_aujourd_hui)\b
styles [] = .primitive;
}

22
syntax_highlighting/fr/pygments/catala_fr.py
View File

@ -3,7 +3,8 @@ from pygments.token import *
import re
__all__=['CatalaFrLexer']
__all__ = ['CatalaFrLexer']
class CatalaFrLexer(RegexLexer):
name = 'CatalaFr'
@ -12,7 +13,7 @@ class CatalaFrLexer(RegexLexer):
flags = re.MULTILINE | re.UNICODE
tokens = {
'root' : [
'root': [
(u'(@@)', bygroups(Generic.Heading), 'main__1'),
(u'(@)', bygroups(Generic.Heading), 'main__2'),
(u'([^\\/\\n\\r])', bygroups(Text)),
@ -20,18 +21,21 @@ class CatalaFrLexer(RegexLexer):
('(\n|\r|\r\n)', Text),
('.', Text),
],
'code' : [
'code': [
(u'(\\*\\/)', bygroups(Text), 'root'),
(u'(\\s*\\#.*$)', bygroups(Comment.Single)),
(u'(contexte)(\\s+)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)', bygroups(Keyword.Declaration, Text, Name.Variable)),
(u'(contexte)(\\s+)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)',
bygroups(Keyword.Declaration, Text, Name.Variable)),
(u'\\b(selon|sous\\s+forme|fix\xe9|par|d\xe9croissante|croissante|varie|avec|on\\s+a|dans|tel\\s+que|existe|pour|tout|de|si|alors|sinon)\\b', bygroups(Keyword.Reserved)),
(u'\\b(champ\\s+d\'application|si\\s+et\\s+seulement\\s+si|d\xe9pend\\s+de|d\xe9claration|inclus|collection|contenu|optionnel|structure|\xe9num\xe9ration|contexte|r\xe8gle|sous\\s+condition|condition|donn\xe9e|cons\xe9quence|rempli|\xe9gal\\s+\xe0|assertion|d\xe9finition)\\b', bygroups(Keyword.Declaration)),
(u'\\b(champ\\s+d\'application|si\\s+et\\s+seulement\\s+si|d\xe9pend\\s+de|d\xe9claration|inclus|collection|contenu|optionnel|structure|\xe9num\xe9ration|contexte|r\xe8gle|sous\\s+condition|condition|donn\xe9e|cons\xe9quence|rempli|\xe9gal\\s+\xe0|assertion|d\xe9finition|\xe9tiquette|exception)\\b', bygroups(Keyword.Declaration)),
(u'(\\|[0-9]+/[0-9]+/[0-9]+\\|)', bygroups(Number.Integer)),
(u'\\b(vrai|faux)\\b', bygroups(Keyword.Constant)),
(u'\\b([0-9]+(,[0.9]*|))\\b', bygroups(Number.Integer)),
(u'(\\-\\-|\\;|\\.|\\,|\\:|\\(|\\))', bygroups(Operator)),
(u'(\\-\\>|\\+|\\-|\\*|/|\\!|non|ou|et|=|>|<|\u20ac|%|an|mois|jour)', bygroups(Operator)),
(u'\\b(entier|bool\xe9en|date|montant|texte|d\xe9cimal|d\xe9cret|loi|nombre|somme|date_aujourd_hui)\\b', bygroups(Keyword.Type)),
(u'(\\-\\>|\\+|\\-|\\*|/|\\!|non|ou|et|=|>|<|\u20ac|%|an|mois|jour)',
bygroups(Operator)),
(u'\\b(entier|bool\xe9en|date|argent|texte|d\xe9cimal|d\xe9cret|loi|nombre|somme|date_aujourd_hui)\\b',
bygroups(Keyword.Type)),
(u'\\b([A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)(\\.)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)\\b', bygroups(Name.Class, Operator, Name.Variable)),
(u'\\b([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)(\\.)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\'\\.]*)\\b', bygroups(Name.Variable, Operator, Text)),
(u'\\b([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)\\b', bygroups(Name.Variable)),
@ -39,13 +43,13 @@ class CatalaFrLexer(RegexLexer):
('(\n|\r|\r\n)', Text),
('.', Text),
],
'main__1' : [
'main__1': [
(u'(@@)', bygroups(Generic.Heading), 'root'),
(u'(.)', bygroups(Generic.Heading)),
('(\n|\r|\r\n)', Text),
('.', Text),
],
'main__2' : [
'main__2': [
(u'(@)', bygroups(Generic.Heading), 'root'),
(u'(.)', bygroups(Generic.Heading)),
('(\n|\r|\r\n)', Text),

4
syntax_highlighting/fr/vscode/syntaxes/catalavs.xml
View File

@ -161,7 +161,7 @@
</dict>
<dict>
<key>match</key>
<string>\b(champ\s+d&apos;application|si\s+et\s+seulement\s+si|dépend\s+de|déclaration|inclus|collection|contenu|optionnel|structure|énumération|contexte|règle|sous\s+condition|condition|donnée|conséquence|rempli|égal\s+à|assertion|définition)\b</string>
<string>\b(champ\s+d&apos;application|si\s+et\s+seulement\s+si|dépend\s+de|déclaration|inclus|collection|contenu|optionnel|structure|énumération|contexte|règle|sous\s+condition|condition|donnée|conséquence|rempli|égal\s+à|assertion|définition|étiquette|exception)\b</string>
<key>name</key>
<string>keyword.other.catala_fr</string>
</dict>
@ -197,7 +197,7 @@
</dict>
<dict>
<key>match</key>
<string>\b(entier|booléen|date|montant|texte|décimal|décret|loi|nombre|somme|date_aujourd_hui)\b</string>
<string>\b(entier|booléen|date|argent|texte|décimal|décret|loi|nombre|somme|date_aujourd_hui)\b</string>
<key>name</key>
<string>support.type.catala_fr</string>
</dict>

6
syntax_highlighting/nv/atom/grammars/catala_nv.cson
View File

@ -100,7 +100,7 @@
'name' : 'keyword.control.catala_nv'
}
{
'match' : '\\b(scope|fun\\s+of|new|includes|set|type|option|struct|enume|param|rule|condition|data|ok|assert|def)\\b'
'match' : '\\b(scope|fun\\s+of|new|includes|set|content|option|struct|enum|param|rule|condition|data|ok|assert|def|label|exception)\\b'
'name' : 'keyword.other.catala_nv'
}
{
@ -120,11 +120,11 @@
'name' : 'punctuation.catala_nv'
}
{
'match' : '(\\-\\>|\\+|\\-|\\*|/|\\!|not|or|and|=|>|<|\\\\$|%|year|month|day)'
'match' : '(\\-\\>|\\+|\\-|\\*|/|\\!|not|or|and|=|>|<|\\$|%|year|month|day)'
'name' : 'keyword.operator.catala_nv'
}
{
'match' : '\\b(int|bool|date|amount|text|decimal|number|sum|now)\\b'
'match' : '\\b(int|bool|date|money|text|decimal|number|sum|now)\\b'
'name' : 'support.type.catala_nv'
}
{

6
syntax_highlighting/nv/catala_nv.iro
View File

@ -213,7 +213,7 @@ code : context {
}
: pattern {
regex \= \b(scope|fun\s+of|new|includes|set|type|option|struct|enume|param|rule|condition|data|ok|assert|def)\b
regex \= \b(scope|fun\s+of|new|includes|set|content|option|struct|enum|param|rule|condition|data|ok|assert|def|label|exception)\b
styles [] = .keyword_rule ;
}
@ -240,12 +240,12 @@ code : context {
}
: pattern {
regex \= (\-\>|\+|\-|\*|/|\!|not|or|and|=|>|<|\\$|%|year|month|day)
regex \= (\-\>|\+|\-|\*|/|\!|not|or|and|=|>|<|\$|%|year|month|day)
styles [] = .operator;
}
: pattern {
regex \= \b(int|bool|date|amount|text|decimal|number|sum|now)\b
regex \= \b(int|bool|date|money|text|decimal|number|sum|now)\b
styles [] = .primitive;
}

26
syntax_highlighting/nv/pygments/catala_nv.py
View File

@ -3,7 +3,8 @@ from pygments.token import *
import re
__all__=['CatalaNvLexer']
__all__ = ['CatalaNvLexer']
class CatalaNvLexer(RegexLexer):
name = 'CatalaNv'
@ -12,7 +13,7 @@ class CatalaNvLexer(RegexLexer):
flags = re.MULTILINE | re.UNICODE
tokens = {
'root' : [
'root': [
(u'(@@)', bygroups(Generic.Heading), 'main__1'),
(u'(@)', bygroups(Generic.Heading), 'main__2'),
(u'([^\\/\\n\\r])', bygroups(Text)),
@ -20,17 +21,22 @@ class CatalaNvLexer(RegexLexer):
('(\n|\r|\r\n)', Text),
('.', Text),
],
'code' : [
'code': [
(u'(\\s*\\#.*$)', bygroups(Comment.Single)),
(u'(param)(\\s+)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)', bygroups(Keyword.Declaration, Text, Name.Variable)),
(u'(param)(\\s+)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)',
bygroups(Keyword.Declaration, Text, Name.Variable)),
(u'\\b(match|with|fixed|by|decreasing|increasing|varies|with\\s+param|we\\s+have|in|such\\s+that|exists|for|all|of|if|then|else)\\b', bygroups(Keyword.Reserved)),
(u'\\b(scope|fun\\s+of|new|includes|set|type|option|struct|enume|param|rule|condition|data|ok|assert|def)\\b', bygroups(Keyword.Declaration)),
(u'\\b(scope|fun\\s+of|new|includes|set|content|option|struct|enum|param|rule|condition|data|ok|assert|def|label|exception)\\b',
bygroups(Keyword.Declaration)),
(u'(\\|[0-9]+/[0-9]+/[0-9]+\\|)', bygroups(Number.Integer)),
(u'\\b(true|false)\\b', bygroups(Keyword.Constant)),
(u'\\b([0-9]+(,[0.9]*|))\\b', bygroups(Number.Integer)),
(u'(\\-\\-|\\;|\\.|\\,|\\:=|\\:|\\(|\\)|\\[|\\])', bygroups(Operator)),
(u'(\\-\\>|\\+|\\-|\\*|/|\\!|not|or|and|=|>|<|\\\\$|%|year|month|day)', bygroups(Operator)),
(u'\\b(int|bool|date|amount|text|decimal|number|sum|now)\\b', bygroups(Keyword.Type)),
(u'(\\-\\-|\\;|\\.|\\,|\\:=|\\:|\\(|\\)|\\[|\\])',
bygroups(Operator)),
(u'(\\-\\>|\\+|\\-|\\*|/|\\!|not|or|and|=|>|<|\\$|%|year|month|day)',
bygroups(Operator)),
(u'\\b(int|bool|date|money|text|decimal|number|sum|now)\\b',
bygroups(Keyword.Type)),
(u'\\b([A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)(\\.)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)\\b', bygroups(Name.Class, Operator, Name.Variable)),
(u'\\b([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)(\\.)([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\'\\.]*)\\b', bygroups(Name.Variable, Operator, Text)),
(u'\\b([a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7][a-z\xe9\xe8\xe0\xe2\xf9\xee\xea\u0153\xe7A-Z\xc9\xc8\xc0\xc2\xd9\xce\xca\u0152\xc70-9_\\\']*)\\b', bygroups(Name.Variable)),
@ -38,12 +44,12 @@ class CatalaNvLexer(RegexLexer):
('(\n|\r|\r\n)', Text),
('.', Text),
],
'main__1' : [
'main__1': [
(u'(.)', bygroups(Generic.Heading)),
('(\n|\r|\r\n)', Text),
('.', Text),
],
'main__2' : [
'main__2': [
(u'(.)', bygroups(Generic.Heading)),
('(\n|\r|\r\n)', Text),
('.', Text),

6
syntax_highlighting/nv/vscode/syntaxes/catalavs.xml
View File

@ -161,7 +161,7 @@
</dict>
<dict>
<key>match</key>
<string>\b(scope|fun\s+of|new|includes|set|type|option|struct|enume|param|rule|condition|data|ok|assert|def)\b</string>
<string>\b(scope|fun\s+of|new|includes|set|content|option|struct|enum|param|rule|condition|data|ok|assert|def|label|exception)\b</string>
<key>name</key>
<string>keyword.other.catala_nv</string>
</dict>
@ -191,13 +191,13 @@
</dict>
<dict>
<key>match</key>
<string>(\-\&gt;|\+|\-|\*|/|\!|not|or|and|=|&gt;|&lt;|\\$|%|year|month|day)</string>
<string>(\-\&gt;|\+|\-|\*|/|\!|not|or|and|=|&gt;|&lt;|\$|%|year|month|day)</string>
<key>name</key>
<string>keyword.operator.catala_nv</string>
</dict>
<dict>
<key>match</key>
<string>\b(int|bool|date|amount|text|decimal|number|sum|now)\b</string>
<string>\b(int|bool|date|money|text|decimal|number|sum|now)\b</string>
<key>name</key>
<string>support.type.catala_nv</string>
</dict>

61
tests/Makefile
View File

@ -2,36 +2,45 @@
# Preamble
############################################
CATALA=dune exec --no-print-director ../src/catala.exe -- Interpret
BLACK := $(shell tput -Txterm setaf 0)
RED := $(shell tput -Txterm setaf 1)
GREEN := $(shell tput -Txterm setaf 2)
YELLOW := $(shell tput -Txterm setaf 3)
LIGHTPURPLE := $(shell tput -Txterm setaf 4)
PURPLE := $(shell tput -Txterm setaf 5)
BLUE := $(shell tput -Txterm setaf 6)
WHITE := $(shell tput -Txterm setaf 7)
tests: $(wildcard */*.catala)
RESET := $(shell tput -Txterm sgr0)
CATALA_OPTS?=
CATALA=dune exec --no-buffer --no-print-director ../src/catala.exe -- Interpret $(CATALA_OPTS)
pass_tests: $(wildcard */*.out)
reset_tests: $(subst .out,.in,$(wildcard */*.out))
# Forces all the tests to be redone
.FORCE:
*/*.catala: .FORCE
interpret_with_scope =\
-$(CATALA) $(if $(filter $(1),nv),,-l $(1)) $@ -s $(2)
%.run: .FORCE
$(CATALA) $(word 1,$(subst ., ,$*)).catala -s $(word 3,$(subst ., ,$*))
interpret_with_scope_and_compare =\
$(CATALA) $(if $(filter $(1),nv),,-l $(1)) --unstyled $@ -s $(2) 2>&1 | \
colordiff -u -b $@.$(2).out -
# Usage: make <test_dir>/<test_name>.catala.<scope_name>.out
# This rule runs the test and compares against the expected output. If the
# Catala program is <test_dir>/<test_name>.catala and the scope to run is
# <scope_name>, then the expected output should be in the file
# <test_dir>/<test_name>.catala.<scope_name>.out
%.out: .FORCE
@$(CATALA) --unstyled $(word 1,$(subst ., ,$*)).catala -s $(word 3,$(subst ., ,$*)) 2>&1 | \
colordiff -u -b $@ - || { echo "${RED}FAIL${RESET} ${PURPLE}$*${RESET}"; exit 1; }
@echo "${GREEN}PASS${RESET} ${PURPLE}$*${RESET}"
############################################
# Tests have to be registered here
############################################
test_bool/test_bool.catala:
$(call interpret_with_scope_and_compare,nv,TestBool)
test_func/func.catala:
$(call interpret_with_scope_and_compare,nv,S)
$(call interpret_with_scope_and_compare,nv,R)
test_scope/scope.catala:
$(call interpret_with_scope_and_compare,nv,A)
test_scope/sub_scope.catala:
$(call interpret_with_scope_and_compare,nv,A)
$(call interpret_with_scope_and_compare,nv,B)
test_scope/sub_sub_scope.catala:
$(call interpret_with_scope_and_compare,nv,A)
$(call interpret_with_scope_and_compare,nv,B)
$(call interpret_with_scope_and_compare,nv,C)
# Usage: make <test_dir>/<test_name>.catala.<scope_name>.in
# This rule runs the test <test_dir>/<test_name>.catala, prints its output and
# writes this output to the <test_dir>/<test_name>.catala.<scope_name>.out file
%.in: .FORCE
@-$(CATALA) $(word 1,$(subst ., ,$*)).catala -s $(word 3,$(subst ., ,$*))
@-$(CATALA) --unstyled $(word 1,$(subst ., ,$*)).catala -s $(word 3,$(subst ., ,$*)) \
> $*.out 2>&1

43
tests/README.md
View File

@ -1,8 +1,45 @@
# Catala test suite
This folder contains Catala source files designed to test the features of the language.
This folder contains Catala source files designed to test the features of the
language.
It uses `make pass_tests` to launch tests and compare the test terminal output
with an expected output.
When you create a new test, please register it in the `Makefile` following the
other examples. Expected outputs are stored using the convention
`<name_of_test>.catala.<name_of_scope>.out` in the corresponding test folder.
For both workflows: use `CATALA_OPTS="..." make ...` to pass in Catala compiler
options when debugging.
## Workflow for adding new tests
1. Create a new test file in `foo/bar.catala` (pick the right directory and
an informative name for your test)
2. Write your test, and pick a toplevel scope `A` to run.
3. From this directory, launch `make foo/bar.catala.A.run` to get the output of
your test.
4. When you're happy with the output, launch `make foo/bar.catala.A.in`. This
will record the content of the output of your test into a file.
5. Check that your test pass with `make foo/bar.catala.A.out`.
6. That's it, you've added a new test for the Catala language!
It uses `make` to launch tests and compare the test terminal output with an expected output.
## Workflow for fixing regressions
When you create a new test, please register it in the `Makefile` following the other examples. Expected outputs are stored using the convention `<name_of_test>.catala.<name_of_scope>.out` in the corresponding test folder.
1. Run `make`, if a test fails you should see something like
`[FAIL foo/bar.catala.A]`.
2. Compare the computed and expected output with `make foo/bar.catala.A.out`.
3. Debug the compiler and/or the test, running `make foo/bar.catala.A.run`
periodically to check the output of Catala on the test case.
4. When you're finished debugging, record the new test output with
`make foo/bar.catala.A.in`.
5. Re-reun `make` to check that everything passes.
6. That's it, you've fixed the Catala test suite to adapt for changes in the
language.
If a compiler change causes a lot of regressions (error message formatting changes
for instance), you can mass-reset the expected the outputs with `make reset_tests`.
**Caution**: use at your own risk, regressions should be fixed one by one in
general.

4
tests/test_bool/test_bool.catala
View File

@ -2,8 +2,8 @@
/*
new scope TestBool :
param foo type bool
param bar type int
param foo content bool
param bar content int
scope TestBool :
def bar := 1

5
tests/test_bool/test_bool.catala.TestBool.out
View File

@ -1,2 +1,3 @@
[RESULT] bar -> 1
[RESULT] foo -> true
[RESULT] Computation successful! Results:
[RESULT] bar = 1
[RESULT] foo = true

15
tests/test_date/durations.catala Normal file
View File

@ -0,0 +1,15 @@
@Article@
/*
new scope A:
param x content date
param y content date
param z content bool
param z2 content bool
scope A:
def x := |01/01/2019|
def y := |30/09/2002|
def z := y +@ (x -@ y) = x
def z2 := x -@ y = 16 year +^ 3 month +^ 7 day
*/

5
tests/test_date/durations.catala.A.out Normal file
View File

@ -0,0 +1,5 @@
[RESULT] Computation successful! Results:
[RESULT] x = 2019-01-01
[RESULT] y = 2002-09-30
[RESULT] z = true
[RESULT] z2 = true

13
tests/test_date/simple.catala Normal file
View File

@ -0,0 +1,13 @@
@Article@
/*
new scope A:
param x content date
param y content date
param z content duration
scope A:
def x := |01/01/2019|
def y := |30/09/2002|
def z := x -@ y
*/

4
tests/test_date/simple.catala.A.out Normal file
View File

@ -0,0 +1,4 @@
[RESULT] Computation successful! Results:
[RESULT] x = 2019-01-01
[RESULT] y = 2002-09-30
[RESULT] z = 5937 days

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