CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-09 01:35:56 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into pair_programming_section_121

Browse Source
This commit is contained in:
Denis Merigoux 2021-01-05 14:37:30 +01:00
commit 7213f2850b
195 changed files with 9969 additions and 4030 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -44,7 +44,7 @@ jobs:
- name: Install dependencies
run: |
eval $(opam env)
make install-dependencies
make dependencies
sudo apt update
sudo apt install python3-dev python3-setuptools man2html rsync colordiff
sudo python3 -m pip install --upgrade pip
@ -54,18 +54,12 @@ jobs:
run: |
eval $(opam env)
make build
- name: Run tests
run: |
eval $(opam env)
make tests
- name: Make examples
run: |
eval $(opam env)
make all_examples
- name: Make assets and documentation
run: |
eval $(opam env)
make all
make website-assets doc

1
.gitignore vendored
View File

@ -1,4 +1,5 @@
_build/
_opam/
*.install
src/**/.merlin
legifrance_oauth*

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.

68
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`.
make install-dependencies
Next, install all the OCaml packages that Catala depend on, as well as some
git submodules, with
This should ensure everything is set up for developping on the Catala compiler !
make dependencies
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

89
Makefile
View File

@ -9,23 +9,28 @@ K := $(foreach exec,$(EXECUTABLES),\
$(if $(shell which $(exec)),some string,$(warning [WARNING] No "$(exec)" executable found. \
Please install this executable for everything to work smoothly)))
install-dependencies-ocaml:
dependencies-ocaml:
opam install \
ocamlformat \
ANSITerminal \
sedlex \
menhir \
menhirLib \
dune dune-build-info \
dune \
cmdliner obelisk \
re reason\
obelisk\
ocamlgraph
re \
obelisk \
unionfind \
bindlib \
zarith zarith_stubs_js \
ocamlgraph \
js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx \
odate
init-submodules:
git submodule update --init
install-dependencies: install-dependencies-ocaml init-submodules
dependencies: dependencies-ocaml init-submodules
##########################################
@ -36,14 +41,18 @@ format:
dune build @fmt --auto-promote | true
build:
$(MAKE) -C src/catala/catala_surface parser_errors.ml
$(MAKE) format
@$(MAKE) --no-print-directory -C src/catala/catala_surface parser_errors.ml
@$(MAKE) --no-print-directory format
dune build
doc: build
dune build @doc
release_build:
dune build --profile release
install: build
doc:
dune build @doc
ln -sf $(PWD)/_build/default/_doc/_html/index.html doc/odoc.html
install:
dune build @install
##########################################
@ -103,25 +112,32 @@ EXAMPLES_DIR=examples
ALLOCATIONS_FAMILIALES_DIR=$(EXAMPLES_DIR)/allocations_familiales
CODE_GENERAL_IMPOTS_DIR=$(EXAMPLES_DIR)/code_general_impots
US_TAX_CODE_DIR=$(EXAMPLES_DIR)/us_tax_code
TUTORIAL_DIR=$(EXAMPLES_DIR)/tutorial
TUTORIAL_EN_DIR=$(EXAMPLES_DIR)/tutorial_en
TUTORIEL_FR_DIR=$(EXAMPLES_DIR)/tutoriel_fr
allocations_familiales: pygments build
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) $@.tex
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) $@.html
code_general_impots: pygments build
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) $@.tex
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) $@.html
literate_allocations_familiales: pygments build
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.tex
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.html
us_tax_code: pygments build
$(MAKE) -C $(US_TAX_CODE_DIR) $@.tex
$(MAKE) -C $(US_TAX_CODE_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
tutorial_en: pygments build
$(MAKE) -C $(TUTORIAL_DIR) $@.tex
$(MAKE) -C $(TUTORIAL_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
all_examples: allocations_familiales code_general_impots us_tax_code tutorial_en
literate_tutorial_en: pygments build
$(MAKE) -C $(TUTORIAL_EN_DIR) tutorial_en.tex
$(MAKE) -C $(TUTORIAL_EN_DIR) tutorial_en.html
literate_tutoriel_fr: pygments build
$(MAKE) -C $(TUTORIEL_FR_DIR) tutoriel_fr.tex
$(MAKE) -C $(TUTORIEL_FR_DIR) tutoriel_fr.html
literate_examples: literate_allocations_familiales literate_code_general_impots \
literate_us_tax_code literate_tutorial_en literate_tutoriel_fr
##########################################
# Execute test suite
@ -129,8 +145,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
@ -139,17 +160,17 @@ tests: build .FORCE
grammar.html: src/catala/catala_surface/parser.mly
obelisk html -o $@ $<
catala.html: src/catala/cli.ml
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 release_build
##########################################
# Misceallenous
##########################################
all: install-dependencies build doc tests all_examples website-assets
all: dependencies build doc tests literate_examples website-assets
clean:
dune clean
@ -159,11 +180,11 @@ clean:
$(MAKE) -C $(CODE_GENERAL_IMPOTS_DIR) clean
inspect:
gitinspector -f ml,mli,mly,iro,tex,catala,md,ir --grading
gitinspector -f ml,mli,mly,iro,tex,catala,catala_en,catala_fr,md,fst,mld --grading
##########################################
# 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 dependencies 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

16
catala.opam
View File

@ -1,27 +1,31 @@
# 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"
license: "Apache-2.0"
homepage: "https://github.com/CatalaLang/catala"
bug-reports: "https://github.com/CatalaLang/catala/issues"
depends: [
"ocaml" {>= "4.07.0"}
"ocaml" {>= "4.08.0"}
"ANSITerminal" {>= "0.8.2"}
"sedlex" {>= "2.1"}
"menhir" {>= "20200211"}
"menhirLib" {>= "20200211"}
"dune-build-info" {>= "2.0.1"}
"unionFind" {>= "20200320"}
"bindlib" {>= "5.0.1"}
"cmdliner" {>= "1.0.4"}
"re" {>= "1.9.0"}
"dune" {build}
"zarith" {>= "1.10"}
"zarith_stubs_js" {>= "0.14.0"}
"dune" {>= "2.2"}
"ocamlgraph" {>= "1.8.8"}
"odate" {>= "0.6"}
]
build: [
["dune" "subst"] {pinned}

BIN
doc/ScreenShotVSCode.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 128 KiB

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

BIN
doc/images/ScreenShotVSCode.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 115 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

21
dune-project
View File

@ -1,14 +1,16 @@
(lang dune 2.2)
(name catala)
(version 0.1.1)
(version 0.2.0)
(generate_opam_files true)
(formatting)
(source (uri git+https://github.com/CatalaLang/catala.git))
(homepage https://github.com/CatalaLang/catala)
(bug_reports https://github.com/CatalaLang/catala/issues)
(authors "Denis Merigoux")
(maintainers "denis.merigoux@inria.fr")
(license Apache2)
(maintainers "contact@catala-lang.org")
(license Apache-2.0)
(package
@ -18,18 +20,21 @@
"\| higher-level specification languages for fiscal legislation.
)
(depends
(ocaml (>= 4.07.0))
(ocaml (>= 4.08.0))
(ANSITerminal (>= 0.8.2))
(sedlex (>= 2.1))
(menhir (>= 20200211))
(menhirLib (>= 20200211))
(dune-build-info (>= 2.0.1))
(unionFind (>= 20200320))
(bindlib (>= 5.0.1))
(cmdliner (>= 1.0.4))
(re (>= 1.9.0))
(dune (and :build ))
(zarith (>= 1.10))
(zarith_stubs_js (>= 0.14.0))
(dune (>= 2.2))
(ocamlgraph (>= 1.8.8))
(odate (>= 0.6))
)
)
(using menhir 2.1)
(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>.run`
# 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 4), \
$(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

3
examples/allocations_familiales/allocations_familiales.catala_fr
View File

@ -2,10 +2,11 @@
@@Inclusion: metadata.catala_fr@@
@@Inclusion: decrets_divers.catala_fr@@
@@Inclusion: securite_sociale_L.catala_fr@@
@@Inclusion: securite_sociale_R.catala_fr@@
@@Inclusion: securite_sociale_D.catala_fr@@
@@Inclusion: decrets_divers.catala_fr@@

156
examples/allocations_familiales/decrets_divers.catala_fr
View File

@ -10,11 +10,11 @@ Au titre de l’année 2020, l’article 81 de la loi du 24 décembr
Le montant précité de la base mensuelle de calcul des allocations familiales (BMAF), en pourcentage duquel sont fxés les montants des prestations familiales, est ainsi porté de 413,16 € à 414,4 € au 1er avril 2020.
/*
champ d'application CalculAllocationsFamiliales :
définition prestations_familiales.base_mensuelle
champ d'application PrestationsFamiliales :
définition base_mensuelle
sous condition
date_calcul >= |01/04/2020| et
date_calcul < |01/04/2021|
date_courante >=@ |01/04/2020| et
date_courante <@ |01/04/2021|
conséquence égal à 414,4 €
*/
@ -32,79 +32,77 @@ 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.
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.base sous condition
ménage.résidence = Mayotte et
allocations_familiales.droits_ouverts
conséquence égal à
si nombre de ménage.enfants = 1 alors
allocations_familiales.montant_premier_enfant
sinon (
allocations_familiales.montant_deuxieme_enfant +
allocations_familiales.montant_troisième_enfant_et_plus
)
# champ d'application CalculAllocationsFamiliales :
# définition allocations_familiales.base sous condition
# ménage.résidence = Mayotte et
# allocations_familiales.droits_ouverts
# conséquence égal à
# si nombre de ménage.enfants = 1 alors
# allocations_familiales.montant_premier_enfant
# sinon (
# allocations_familiales.montant_deuxieme_enfant +
# allocations_familiales.montant_troisième_enfant_et_plus
# )
définition allocations_familiales.montant_deuxieme_enfant sous condition
ménage.résidence = Mayotte et
date_calcul > |30/04/2020| et
date_calcul <= |31/12/2020|
conséquence égal à
prestations_familiales.base_mensuelle * 30,68 %
# définition allocations_familiales.montant_deuxieme_enfant sous condition
# ménage.résidence = Mayotte et
# date_calcul > |30/04/2020| et
# date_calcul <= |31/12/2020|
# conséquence égal à
# prestations_familiales.base_mensuelle * 30,68 %
définition allocations_familiales.montant_troisième_enfant_et_plus sous condition
ménage.résidence = Mayotte et
date_calcul > |30/04/2020| et
date_calcul <= |31/12/2020|
conséquence égal à
prestations_familiales.base_mensuelle * 14,3 % +
(si nombre de ménage.enfants >= 4 alors
prestations_familiales.base_mensuelle * 4,63 % *
(nombre de ménage.enfants - 3)
sinon 0 €)
# définition allocations_familiales.montant_troisième_enfant_et_plus sous condition
# ménage.résidence = Mayotte et
# date_calcul > |30/04/2020| et
# date_calcul <= |31/12/2020|
# conséquence égal à
# prestations_familiales.base_mensuelle * 14,3 % +
# (si nombre de ménage.enfants >= 4 alors
# prestations_familiales.base_mensuelle * 4,63 % *
# (nombre de ménage.enfants - 3)
# sinon 0 €)
définition allocations_familiales.montant_deuxieme_enfant sous condition
ménage.résidence = Mayotte et
date_calcul > |01/01/2021| et
date_calcul <= |31/03/2021|
conséquence égal à
prestations_familiales.base_mensuelle * 32 %
# définition allocations_familiales.montant_deuxieme_enfant sous condition
# ménage.résidence = Mayotte et
# date_calcul > |01/01/2021| et
# date_calcul <= |31/03/2021|
# conséquence égal à
# prestations_familiales.base_mensuelle * 32 %
définition allocations_familiales.montant_troisième_enfant_et_plus sous condition
ménage.résidence = Mayotte et
date_calcul > |01/01/2021| et
date_calcul <= |31/03/2021|
conséquence égal à
prestations_familiales.base_mensuelle * 16 % +
(si nombre de ménage.enfants >= 4 alors
prestations_familiales.base_mensuelle * 4,63 % *
(nombre de ménage.enfants - 3)
sinon 0 €)
# définition allocations_familiales.montant_troisième_enfant_et_plus sous condition
# ménage.résidence = Mayotte et
# date_calcul > |01/01/2021| et
# date_calcul <= |31/03/2021|
# conséquence égal à
# prestations_familiales.base_mensuelle * 16 % +
# (si nombre de ménage.enfants >= 4 alors
# prestations_familiales.base_mensuelle * 4,63 % *
# (nombre de ménage.enfants - 3)
# sinon 0 €)
définition allocations_familiales.montant_premier_enfant sous condition
ménage.résident = Mayotte et
allocations_familiales.date_ouverture_droits < |01/01/2012|
conséquence égal à 57,28 €
# définition allocations_familiales.montant_premier_enfant sous condition
# ménage.résident = Mayotte et
# allocations_familiales.date_ouverture_droits < |01/01/2012|
# conséquence égal à 57,28 €
définition allocations_familiales.montant_premier_enfant sous condition
ménage.résident = Mayotte et
allocations_familiales.date_ouverture_droits >= |01/01/2012| et
date_calcul > |30/04/2020| et
date_calcul <= |31/12/2020|
conséquence égal à
prestations_familiales.base_mensuelle * 7,17 %
# définition allocations_familiales.montant_premier_enfant sous condition
# ménage.résident = Mayotte et
# allocations_familiales.date_ouverture_droits >= |01/01/2012| et
# date_calcul > |30/04/2020| et
# date_calcul <= |31/12/2020|
# conséquence égal à
# prestations_familiales.base_mensuelle * 7,17 %
définition allocations_familiales.montant_premier_enfant sous condition
ménage.résident = Mayotte et
allocations_familiales.date_ouverture_droits >= |01/01/2012| et
date_calcul > |01/01/2021| et
date_calcul <= |31/03/2021|
conséquence égal à
prestations_familiales.base_mensuelle * 5,88 %
# définition allocations_familiales.montant_premier_enfant sous condition
# ménage.résident = Mayotte et
# allocations_familiales.date_ouverture_droits >= |01/01/2012| et
# date_calcul > |01/01/2021| et
# date_calcul <= |31/03/2021|
# conséquence égal à
# prestations_familiales.base_mensuelle * 5,88 %
*/
@ -114,21 +112,21 @@ champ d'application CalculAllocationsFamiliales :
A compter du 1er janvier 2020, pour les catégories de travailleurs mentionnés à l' article L. 2211-1 du code du travail , le montant du salaire minimum de croissance est relevé dans les conditions ci-après :
1° En métropole, en Guadeloupe, en Guyane, en Martinique, à La Réunion, à Saint-Barthélemy, à Saint-Martin et à Saint-Pierre-et-Miquelon, son montant est porté à 10,15 € l'heure ;
/*
champ d'application CalculAllocationsFamiliales :
définition smic.brut_horaire sous condition
(ménage.résidence = Métropole) ou
(ménage.résidence = Guyane) ou
(ménage.résidence = Martinique) ou
(ménage.résidence = LaRéunion) ou
(ménage.résidence = SaintBarthélemy) ou
(ménage.résidence = SaintMartin) ou
(ménage.résidence = SaintPierreEtMiquelon)
champ d'application Smic :
définition brut_horaire sous condition
(résidence = Métropole) ou
(résidence = Guyane) ou
(résidence = Martinique) ou
(résidence = LaRéunion) ou
(résidence = SaintBarthélemy) ou
(résidence = SaintMartin) ou
(résidence = SaintPierreEtMiquelon)
conséquence égal à 10,15 €
*/
2° A Mayotte, son montant est fixé à 7,66 € l'heure.
/*
champ d'application CalculAllocationsFamiliales :
définition smic.brut_horaire sous condition
(ménage.résidence = Mayotte)
champ d'application Smic :
définition brut_horaire sous condition
(résidence = Mayotte)
conséquence égal à 7,66 €
*/

318
examples/allocations_familiales/metadata.catala_fr
View File

@ -1,25 +1,26 @@
@@Début métadonnées@@
/*
déclaration structure Personne :
donnée prénom contenu texte
donnée nom contenu texte
donnée date_de_naissance contenu date
déclaration structure Personne:
donnée numéro_sécurité_sociale contenu entier
déclaration structure ParentsGardeAlternée :
donnée parent1 contenu Personne
donnée parent2 contenu Personne
déclaration énumération GardeAlternée :
-- OuiPartageAllocations
-- OuiAllocataireUnique
-- NonGardeUnique
déclaration énumération PriseEnCharge :
-- Complète contenu Personne
-- GardeAlternée contenu ParentsGardeAlternée
déclaration énumération PriseEnChargeServiceSociaux:
-- OuiAllocationVerséeÀLaFamille
-- OuiAllocationVerséeAuxServicesSociaux
-- NonPriseEnChargeFamille
# Une structure regroupe des données ensemble
déclaration structure Enfant :
donnée fin_obligation_scolaire contenu date
donnée rémuneration_mensuelle contenu argent
donnée date_de_naissance contenu date
donnée âge contenu entier
donnée rémuneration_mensuelle contenu montant
donnée prise_en_charge contenu PriseEnCharge
condition confié_service_social
donnée garde_alternée contenu GardeAlternée
donnée pris_en_charge_par_services_sociaux contenu
PriseEnChargeServiceSociaux
déclaration énumération Collectivité :
-- Guadeloupe
@ -32,198 +33,147 @@ déclaration énumération Collectivité :
-- SaintPierreEtMiquelon
-- Mayotte
déclaration structure Ménage :
donnée enfants contenu collection Enfant
donnée parent_en_charge contenu Personne dépend de Enfant
donnée enfant_plus_âgé contenu optionnel Enfant
donnée parents contenu collection Personne
donnée parent1 contenu Personne
donnée parent2 contenu optionnel Personne
donnée résidence contenu Collectivité
# Le mot optionnel permet de prévoir le cas où le
# ménage n'a pas d'enfants
déclaration champ d'application Smic :
contexte résidence contenu Collectivité
contexte brut_horaire contenu argent
déclaration champ d'application MénageBienFormé :
contexte ménage contenu Ménage
champ d'application MénageBienFormé :
assertion nombre de parents > 0 et nombre de parents <= 2
# Les champs parent1 et parent2 sont cohérents
assertion ménage.parent1 dans ménage.parents
assertion (
selon ménage.parent2 sous forme
-- Présent de parent2 :
parent2 dans ménage.parents et parent2 != ménage.parent1
-- Absent : vrai
)
# Dans la traduction informatique, le ménage est en charge de chacun
# des enfants
assertion (pour tout enfant dans enfants on a
selon enfant.prise_en_charge sous forme
-- Complète de parent : parent dans ménage.parents
-- GardeAlternée de parents_garde_alternée :
parents_garde_alternée.parent1 dans ménage.parents ou
parents_garde_alternée.parent2 dans ménage.parents
)
# parent_en_charge permet de savoir quel parent du ménage
# est en charge de quel enfant
définition parent_en_charge de enfant égal à (
selon enfant.prise_en_charge sous forme
-- Complète de parent : parent
-- GardeAlternée de parents_garde_alternée : (
si parents_garde_alternée.parent1 dans ménage.parents
alors parents_garde_alternée.parent1
sinon parents_garde_alternée.parent2
))
# Lorsqu'un enfant est confié au service social, il ne peut être
# en garde alternée
assertion pour tout enfant dans enfants on a
si enfant.confié_service_social
alors enfant.prise_en_charge = Complète contenu service_social
sinon vrai
déclaration énumération Prestation:
-- PrestationAccueilJeuneEnfant
-- AllocationFamiliale
-- ComplémentFamilial
-- AllocationLogement
-- AllocationÉducationEnfantHandicapé
-- AllocationSoutienFamilial
-- AllocationRentréeScolaire
-- AllocationJournalièrePresenceParentale
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
déclaration énumération ChargeAllocation :
déclaration énumération PriseEnCompteÉvaluationMontant:
-- Complète
-- Partagée
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 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
déclaration énumération VersementAllocations:
-- Normal
-- AllocationVerséeAuxServicesSociaux
déclaration structure AllocationForfaitaire :
condition droits_ouverts dépend de Enfant
donnée montant_versé contenu montant
déclaration énumération ÂgeAlternatif:
-- Absent
-- Présent contenu entier
déclaration énumération ChoixParentAllocataire :
-- UnParent contenu Personne
-- DeuxParents
déclaration énumération ÉlémentPrestationsFamiliales:
-- PrestationAccueilJeuneEnfant
-- AllocationsFamiliales
-- ComplémentFamilial
-- AllocationLogement
-- AllocationÉducationEnfantHandicapé
-- AllocationSoutienFamilial
-- AllocationRentréeScolaire
-- AllocationJournalièrePresenceParentale
déclaration structure AllocationsGardeAlternée :
donnée choix_allocataire contenu optionnel ChoixParentAllocataire
dépend de Enfant
condition unique_allocataire dépend de Enfant
condition allocataire_double dépend de Enfant
condition demande_conjointe_partage_charge dépend de Enfant
condition desaccord_charge dépend de Enfant
déclaration champ d'application PrestationsFamiliales:
contexte droit_ouvert condition dépend de Enfant
contexte conditions_hors_âge condition dépend de Enfant
contexte plafond_l512_3_2 contenu argent
contexte âge_l512_3_2 contenu entier
contexte âge_l512_3_2_alternatif contenu ÂgeAlternatif
contexte régime_outre_mer_l751_1 condition
contexte date_courante contenu date
contexte prestation_courante contenu ÉlémentPrestationsFamiliales
contexte résidence contenu Collectivité
contexte smic champ d'application Smic
contexte base_mensuelle contenu argent
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
champ d'application PrestationsFamiliales:
définition smic.résidence égal à résidence
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
déclaration champ d'application AllocationFamilialesAvril2008:
contexte âge_limite_alinéa_1_l521_3 contenu entier
déclaration structure TitreI:
condition droits_ouverts_allocations_familiales dépend de Personne
déclaration énumération StockageEnfant:
-- PasEnfant
-- UnEnfant contenu Enfant
déclaration structure L511_1:
donnée prestation_courante contenu Prestation
déclaration champ d'application EnfantLePlusÂgé:
contexte enfants contenu collection Enfant
contexte est_le_plus_âgé contenu booléen dépend de Enfant
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
champ d'application EnfantLePlusÂgé:
définition est_le_plus_âgé de enfant égal à
faux # TODO: changer!
déclaration structure L521_1 :
donnée nombre_minimum_enfants contenu montant
donnée ressources_ménage contenu montant
déclaration champ d'application AllocationsFamiliales:
contexte enfants_à_charge contenu collection Enfant
contexte date_courante contenu date
contexte résidence contenu Collectivité
contexte ressources_ménage contenu argent
contexte prise_en_compte contenu
PriseEnCompteÉvaluationMontant dépend de Enfant
contexte versement contenu
VersementAllocations dépend de Enfant
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
contexte montant_versé contenu argent
déclaration structure L751_1 :
condition régime_outre_mer
contexte droit_ouvert_base condition
contexte droit_ouvert_majoration condition dépend de Enfant
contexte montant_versé_base contenu argent
contexte montant_avec_garde_alternée_base contenu argent
contexte montant_initial_base contenu argent
contexte montant_initial_base_premier_enfant contenu argent
contexte montant_initial_base_deuxième_enfant contenu argent
contexte montant_initial_base_troisième_enfant_et_plus contenu argent
contexte rapport_enfants_total_moyen contenu décimal
contexte nombre_moyen_enfants contenu décimal
contexte nombre_total_enfants contenu décimal
déclaration structure D521_3 :
donnée plafond_I contenu montant
donnée plafond_II contenu montant
contexte droit_ouvert_forfaitaire condition dépend de Enfant
contexte montant_versé_forfaitaire contenu argent
déclaration structure SMIC :
donnée brut_horaire contenu montant dépend de Collectivité
contexte montant_versé_majoration contenu argent
contexte montant_avec_garde_alternée_majoration contenu argent dépend de Enfant
contexte montant_initial_majoration contenu argent dépend de Enfant
déclaration champ d'application CalculPrestationsFamiliales :
# Les règles déclarées dans PrestationsFamiliales pourront utiliser
# ménage et l512_3 et leur données associées
contexte date_calcul contenu date
contexte ménage contenu Ménage
contexte prestations_familiales contenu PrestationsFamiliales
contexte l511_1 contenu L511_1
contexte l512_3 contenu L512_3
contexte ménage_bien_formé champ d'application MénageBienFormé
contexte droit_ouvert_complément condition
contexte montant_versé_complément_pour_base_et_majoration contenu argent
contexte montant_base_complément_pour_base_et_majoration contenu argent
contexte montant_versé_complément_pour_forfaitaire contenu argent
contexte dépassement_plafond_ressources contenu argent dépend de argent
champ d'application CalculPrestationsFamiliales:
définition ménage_bien_formé.ménage égal à ménage
contexte prestations_familiales champ d'application PrestationsFamiliales
contexte version_avril_2008 champ d'application AllocationFamilialesAvril2008
contexte enfant_le_plus_âgé champ d'application EnfantLePlusÂgé
déclaration champ d'application CalculAllocationsFamilialesAvril2008 :
contexte l521_3 contenu L521_3
contexte conditions_hors_âge condition dépend de Enfant
contexte nombre_enfants_l521_1 contenu entier
contexte âge_limite_alinéa_1_l521_3 contenu entier dépend de Enfant
contexte nombre_enfants_alinéa_2_l521_3 contenu entier
contexte est_enfant_le_plus_âgé contenu booléen dépend de Enfant
contexte plafond_I_d521_3 contenu argent
contexte plafond_II_d521_3 contenu argent
déclaration champ d'application CalculAllocationsFamiliales :
contexte date_calcul contenu date
contexte ménage contenu Ménage
contexte allocations_familiales contenu AllocationsFamiliales
contexte allocation_forfaitaire contenu AllocationForfaitaire
contexte allocations_garde_alternée contenu AllocationsGardeAlternée
contexte majorations_allocations_familiales
contenu MajorationsAllocationsFamiliales
contexte smic contenu SMIC
contexte titre_I contenu TitreI
contexte l521_1 contenu L521_1
contexte l521_3 contenu L521_3
contexte l751_1 contenu L751_1
contexte d521_1 contenu D521_1
contexte d521_3 contenu D521_3
contexte calcul_prestations_familiales
champ d'application CalculPrestationsFamiliales
contexte calcul_avril_2008
champ d'application CalculAllocationsFamilialesAvril2008
## Code non défini dans la loi
champ d'application PrestationsFamiliales:
définition âge_l512_3_2_alternatif égal à Absent
champ d'application CalculAllocationsFamiliales:
définition calcul_prestations_familiales.ménage égal à ménage
définition calcul_prestations_familiales.date_calcul égal à date_calcul
# AllocationsFamiliales est un cas particulier de PrestationsFamiliales,
# le dernier est donc inclus dans l'autre. Il est nécessaire de préciser
# que les deux contextes parlent du même ménage pour caractériser
# l'inclusion.
champ d'application AllocationsFamiliales:
définition prestations_familiales.prestation_courante égal à
AllocationsFamiliales
définition prestations_familiales.date_courante égal à
date_courante
définition prestations_familiales.résidence égal à
résidence
assertion (pour tout enfant dans enfants_à_charge on a
prestations_familiales.droit_ouvert de enfant)
définition enfant_le_plus_âgé.enfants égal à enfants_à_charge
définition est_enfant_le_plus_âgé de enfant égal à
enfant_le_plus_âgé.est_le_plus_âgé de enfant
définition montant_versé_base égal à
si droit_ouvert_base alors montant_avec_garde_alternée_base sinon 0€
définition montant_versé_majoration égal à
si droit_ouvert_base alors
somme argent pour enfant dans enfants_à_charge de
montant_avec_garde_alternée_majoration de enfant
sinon 0€
définition montant_versé égal à
si droit_ouvert_base alors
montant_versé_base +€
montant_versé_majoration +€
montant_versé_forfaitaire +€
montant_versé_complément_pour_base_et_majoration +€
montant_versé_complément_pour_forfaitaire
sinon 0€
*/
@@Fin métadonnées@@

372
examples/allocations_familiales/securite_sociale_D.catala_fr
View File

@ -8,237 +8,267 @@
@@Chapitre 1er : Allocations familiales@@++++
@Article D521-1|LEGIARTI000030680318@
I.-Pour l'application de l'article L. 521-1 , le montant des allocations familiales et de la majoration pour âge prévue à l'article L. 521-3 est défini selon le barème suivant :
I.-Pour l'application de l'article L. 521-1 , le montant des allocations
familiales et de la majoration pour âge prévue à l'article L. 521-3
est défini selon le barème suivant :
/*
# Composantes des allocations familiales
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.base sous condition
allocations_familiales.droits_ouverts
conséquence égal à
allocations_familiales.montant_deuxieme_enfant +
allocations_familiales.montant_troisième_enfant_et_plus
champ d'application AllocationsFamiliales :
étiquette définition_montant_initial_base
définition montant_initial_base égal à
montant_initial_base_deuxième_enfant +€
montant_initial_base_troisième_enfant_et_plus
*/
1° Lorsque le ménage ou la personne a disposé d'un montant de ressources inférieur ou égal au plafond défini au I de l'article D. 521-3, les taux servant au calcul des allocations familiales sont fixés, en pourcentage de la base mensuelle prévue à l'article L. 551-1, à :
1° Lorsque le ménage ou la personne a disposé d'un montant de ressources
inférieur ou égal au plafond défini au I de l'article D. 521-3, les taux
servant au calcul des allocations familiales sont fixés, en pourcentage
de la base mensuelle prévue à l'article L. 551-1, à :
a) 32 % pour le deuxième enfant à charge ;
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.montant_deuxieme_enfant sous condition
l521_1.ressources_ménage <= d521_3.plafond_I
champ d'application AllocationsFamiliales :
définition montant_initial_base_deuxième_enfant sous condition
ressources_ménage <=€ plafond_I_d521_3
conséquence égal à
si nombre de ménage.enfants >= 2
alors prestations_familiales.base_mensuelle * 32 %
si nombre de enfants_à_charge >= 2
alors prestations_familiales.base_mensuelle *€ 32 %
sinon 0 €
*/
b) 41 % pour le troisième enfant à charge et chacun des suivants.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.montant_troisième_enfant_et_plus
champ d'application AllocationsFamiliales :
définition montant_initial_base_troisième_enfant_et_plus
sous condition
l521_1.ressources_ménage <= d521_3.plafond_I
ressources_ménage <=€ plafond_I_d521_3
conséquence égal à
si nombre de ménage.enfants >= 3
alors prestations_familiales.base_mensuelle * 41 % * (
(nombre de ménage.enfants) - 2
si nombre de enfants_à_charge >= 3
alors (prestations_familiales.base_mensuelle *€ 41 %) *€ (
entier_vers_décimal de ((nombre de enfants_à_charge) - 2)
) sinon 0 €
*/
La majoration pour âge est fixée à 16 % de la base mensuelle de calcul des prestations familiales ;
La majoration pour âge est fixée à 16 % de la base mensuelle de calcul des
prestations familiales ;
/*
champ d'application CalculAllocationsFamiliales :
définition
majorations_allocations_familiales.base_par_enfant de enfant
sous condition
l521_1.ressources_ménage <= d521_3.plafond_I
champ d'application AllocationsFamiliales :
définition montant_initial_majoration de enfant
sous condition
ressources_ménage <=€ plafond_I_d521_3 et
(nombre de enfants_à_charge >= 2)
conséquence égal à
prestations_familiales.base_mensuelle * 16 %
prestations_familiales.base_mensuelle *€ 16 %
*/
2° Lorsque le ménage ou la personne a disposé d'un montant de ressources supérieur au plafond défini au I de l'article D. 521-3 et inférieur ou égal à celui défini au II du même article, les taux servant au calcul des allocations familiales sont fixés, en pourcentage de la base mensuelle prévue à l'article L. 551-1, à :
2° Lorsque le ménage ou la personne a disposé d'un montant de ressources
supérieur au plafond défini au I de l'article D. 521-3 et inférieur ou égal
à celui défini au II du même article, les taux servant au calcul des
allocations familiales sont fixés, en pourcentage de la base mensuelle
prévue à l'article L. 551-1, à :
a) 16 % pour le deuxième enfant à charge ;
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.montant_deuxieme_enfant sous condition
(l521_1.ressources_ménage > d521_3.plafond_I) et
(l521_1.ressources_ménage <= d521_3.plafond_II)
champ d'application AllocationsFamiliales :
définition montant_initial_base_deuxième_enfant sous condition
(ressources_ménage >€ plafond_I_d521_3) et
(ressources_ménage <=€ plafond_II_d521_3)
conséquence égal à
si nombre de ménage.enfants >= 2
alors prestations_familiales.base_mensuelles * 32 %
si nombre de enfants_à_charge >= 2
alors prestations_familiales.base_mensuelle *€ 32 %
sinon 0 €
*/
b) 20,5 % pour le troisième enfant à charge et chacun des suivants.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.montant_troisième_enfant_et_plus
champ d'application AllocationsFamiliales :
définition montant_initial_base_troisième_enfant_et_plus
sous condition
(l521_1.ressources_ménage > d521_3.plafond_I) et
(l521_1.ressources_ménage <= d521_3.plafond_II)
(ressources_ménage >€ plafond_I_d521_3) et
(ressources_ménage <=€ plafond_II_d521_3)
conséquence égal à
si nombre de ménage.enfants >= 3
alors prestations_familiales.base_mensuelle * 20,5 % * (
(nombre de ménage.enfants) - 2
si nombre de enfants_à_charge >= 3
alors (prestations_familiales.base_mensuelle *€ 20,5 %) *€ (
entier_vers_décimal de ((nombre de enfants_à_charge) - 2)
) sinon 0 €
*/
La majoration pour âge est fixée à 8 % de la base mensuelle de calcul des prestations familiales ;
La majoration pour âge est fixée à 8 % de la base mensuelle de calcul des
prestations familiales ;
/*
champ d'application CalculAllocationsFamiliales :
définition
majorations_allocations_familiales.base_par_enfant de enfant
sous condition
(l521_1.ressources_ménage > d521_3.plafond_I) et
(l521_1.ressources_ménage <= d521_3.plafond_II)
champ d'application AllocationsFamiliales :
définition montant_initial_majoration de enfant sous condition
(ressources_ménage >€ plafond_I_d521_3) et
(ressources_ménage <=€ plafond_II_d521_3) et
(nombre de enfants_à_charge >= 2)
conséquence égal à
prestations_familiales.base_mensuelle * 8 %
prestations_familiales.base_mensuelle *€ 8 %
*/
3° Lorsque le ménage ou la personne a disposé d'un montant de ressources supérieur au plafond défini au II de l'article D. 521-3, les taux servant au calcul des allocations familiales sont fixés, en pourcentage de la base mensuelle prévue à l'article L. 551-1, à :
3° Lorsque le ménage ou la personne a disposé d'un montant de ressources
supérieur au plafond défini au II de l'article D. 521-3, les taux servant
au calcul des allocations familiales sont fixés, en pourcentage de la base
mensuelle prévue à l'article L. 551-1, à :
a) 8 % pour le deuxième enfant à charge ;
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.montant_deuxieme_enfant sous condition
(l521_1.ressources_ménage > d521_3.plafond_II)
champ d'application AllocationsFamiliales :
définition montant_initial_base_deuxième_enfant sous condition
(ressources_ménage >€ plafond_II_d521_3)
conséquence égal à
si nombre de ménage.enfants >= 2
alors prestations_familiales.base_mensuelle * 8 %
si nombre de enfants_à_charge >= 2
alors prestations_familiales.base_mensuelle *€ 8 %
sinon 0 €
*/
b) 10,25 % pour le troisième enfant à charge et chacun des suivants.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.montant_troisième_enfant_et_plus
champ d'application AllocationsFamiliales :
définition montant_initial_base_troisième_enfant_et_plus
sous condition
(l521_1.ressources_ménage > d521_3.plafond_II)
(ressources_ménage >€ plafond_II_d521_3)
conséquence égal à
si nombre de ménage.enfants >= 3
alors prestations_familiales.base_mensuelle * 10,25 % * (
(nombre de ménage.enfants) - 2
si nombre de enfants_à_charge >= 3
alors (prestations_familiales.base_mensuelle *€ 10,25 %) *€ (
entier_vers_décimal de ((nombre de enfants_à_charge) - 2)
) sinon 0 €
*/
La majoration pour âge est fixée à 4 % de la base mensuelle de calcul des prestations familiales.
La majoration pour âge est fixée à 4 % de la base mensuelle de calcul des
prestations familiales.
/*
champ d'application CalculAllocationsFamiliales :
définition
majorations_allocations_familiales.base_par_enfant de enfant
sous condition
(l521_1.ressources_ménage > d521_3.plafond_II)
champ d'application AllocationsFamiliales :
définition montant_initial_majoration de enfant sous condition
(ressources_ménage >€ plafond_II_d521_3) et
(nombre de enfants_à_charge >= 2)
conséquence égal à
prestations_familiales.base_mensuelle * 4 %
prestations_familiales.base_mensuelle *€ 4 %
*/
II.-En application du sixième alinéa de l'article L. 521-1, le montant mensuel des allocations familiales et, le cas échéant, de la majoration pour âge est majoré d'un complément dégressif, lorsque les ressources annuelles du ménage ou de la personne dépassent l'un des plafonds défini au I ou au II de l'article D. 521-3 d'une somme inférieure à douze fois le montant mensuel des allocations familiales augmenté, le cas échéant, de la ou des majorations pour âge.
II.-En application du sixième alinéa de l'article L. 521-1, le montant
mensuel des allocations familiales et, le cas échéant, de la majoration
pour âge est majoré d'un complément dégressif, lorsque les ressources
annuelles du ménage ou de la personne dépassent l'un des plafonds défini
au I ou au II de l'article D. 521-3 d'une somme inférieure à douze fois
le montant mensuel des allocations familiales augmenté, le cas échéant,
de la ou des majorations pour âge.
Ce complément dégressif est égal, pour chaque mois, au douzième de la différence entre, d'une part, ce plafond de ressources majoré de la somme définie à l'alinéa précédent et, d'autre part, le montant des ressources.
Ce complément dégressif est égal, pour chaque mois, au douzième de la
différence entre, d'une part, ce plafond de ressources majoré de la somme
définie à l'alinéa précédent et, d'autre part, le montant des ressources.
/*
champ d'application CalculAllocationsFamiliales :
définition complément_dégressif.dépassement de allocation
champ d'application AllocationsFamiliales :
exception base_dépassement
définition dépassement_plafond_ressources de allocation
sous condition
(l521_1.ressources_ménage > d521_3.plafond_I) et
(l521_1.ressources_ménage <= d521_3.plafond_I + 12 * allocation)
(ressources_ménage >€ plafond_I_d521_3) et
(ressources_ménage <=€ plafond_I_d521_3 +€ allocation *€ 12,0 )
conséquence égal à
d521_3.plafond_I + 12 * allocation - l521_1.ressources_ménage
plafond_I_d521_3 +€ allocation *€ 12,0 -€ ressources_ménage
définition complément_dégressif.dépassement de allocation
exception base_dépassement
définition dépassement_plafond_ressources de allocation
sous condition
(l521_1.ressources_ménage > d521_3.plafond_II) et
(l521_1.ressources_ménage <= d521_3.plafond_II + 12 * allocation)
(ressources_ménage >€ plafond_II_d521_3) et
(ressources_ménage <=€ plafond_II_d521_3 +€ allocation *€ 12,0)
conséquence égal à
d521_3.plafond_II + 12 * allocation - l521_1.ressources_ménage
plafond_II_d521_3 +€ allocation *€ 12,0 -€ ressources_ménage
# Dans les autres cas, le dépassement est nul
définition complément_dégressif.dépassement de allocations égal à 0 €
étiquette base_dépassement
définition dépassement_plafond_ressources de allocations égal à 0 €
règle complément_dégressif.droits_ouverts de allocation
sous condition complément_dégressif.dépassement de allocation > 0 €
conséquence rempli
définition montant_versé_complément_pour_base_et_majoration égal à
(dépassement_plafond_ressources de
montant_base_complément_pour_base_et_majoration) *€ (1,0 /. 12,0)
définition
complément_dégressif.pour_allocations_familiales_et_majorations
sous condition complément_dégressif.droits_ouverts de complément_dégressif.base
conséquence égal à
(complément_dégressif.dépassement de complément_dégressif.base) / 12
définition complément_dégressif.base
égal à
(si allocations_familiales.droits_ouverts alors
allocations_familiales.montant_versé
sinon 0 €) +
(si majorations_allocations_familiales.droits_ouverts alors
majorations_allocations_familiales.montant_versé
sinon 0 €)
définition montant_base_complément_pour_base_et_majoration égal à
montant_versé_base +€ montant_versé_majoration
*/
@Article D521-2|LEGIARTI000030680324@
I.-Le montant mensuel de l'allocation forfaitaire prévue au deuxième alinéa de l'article L. 521-1 est défini selon le barème suivant :
I.-Le montant mensuel de l'allocation forfaitaire prévue au deuxième alinéa de
l'article L. 521-1 est défini selon le barème suivant :
1° Lorsque le ménage ou la personne a disposé d'un montant de ressources inférieur ou égal au plafond défini au I de l'article D. 521-3, le montant mensuel de l'allocation forfaitaire est fixé à 20,234 % de la base mensuelle de calcul des allocations familiales par enfant ;
1° Lorsque le ménage ou la personne a disposé d'un montant de ressources
inférieur ou égal au plafond défini au I de l'article D. 521-3, le montant
mensuel de l'allocation forfaitaire est fixé à 20,234 % de la base mensuelle
de calcul des allocations familiales par enfant ;
/*
champ d'application CalculAllocationsFamiliales :
définition allocation_forfaitaire.montant_versé sous condition
l521_1.ressources_ménage <= d521_3.plafond_I
champ d'application AllocationsFamiliales :
définition montant_versé_forfaitaire sous condition
ressources_ménage <=€ plafond_I_d521_3
conséquence égal à
prestations_familiales.base_mensuelle * 20,234 % *
nombre pour enfant dans ménage.enfants de
allocation_forfaitaire.droits_ouverts de enfant
(prestations_familiales.base_mensuelle *€ 20,234 %) *€
entier_vers_décimal de (nombre pour enfant dans enfants_à_charge de
droit_ouvert_forfaitaire de enfant)
*/
2° Lorsque le ménage ou la personne a disposé d'un montant de ressources supérieur au plafond défini au I de l'article D. 521-3 et inférieur ou égal à celui défini au II du même article, le montant mensuel de l'allocation forfaitaire est fixé à 10,117 % de la base mensuelle de calcul des allocations familiales par enfant ;
2° Lorsque le ménage ou la personne a disposé d'un montant de ressources
supérieur au plafond défini au I de l'article D. 521-3 et inférieur ou égal
à celui défini au II du même article, le montant mensuel de l'allocation
forfaitaire est fixé à 10,117 % de la base mensuelle de calcul des allocations
familiales par enfant ;
/*
champ d'application CalculAllocationsFamiliales :
définition allocation_forfaitaire.montant_versé sous condition
(l521_1.ressources_ménage > d521_3.plafond_I) et
(l521_1.ressources_ménage <= d521_3.plafond_II)
champ d'application AllocationsFamiliales :
définition montant_versé_forfaitaire sous condition
(ressources_ménage >€ plafond_I_d521_3) et
(ressources_ménage <=€ plafond_II_d521_3)
conséquence égal à
prestations_familiales.base_mensuelle * 10,117 % *
nombre pour enfant dans ménage.enfants de
allocation_forfaitaire.droits_ouvert de enfant
(prestations_familiales.base_mensuelle *€ 10,117 %) *€
entier_vers_décimal de (nombre pour enfant dans enfants_à_charge de
droit_ouvert_forfaitaire de enfant)
*/
3° Lorsque le ménage ou la personne a disposé d'un montant de ressources supérieur au plafond défini au II de l'article D. 521-3, le montant mensuel de l'allocation forfaitaire est fixé à 5,059 % de la base mensuelle de calcul des allocations familiales par enfant.
3° Lorsque le ménage ou la personne a disposé d'un montant de ressources
supérieur au plafond défini au II de l'article D. 521-3, le montant mensuel
de l'allocation forfaitaire est fixé à 5,059 % de la base mensuelle de calcul
des allocations familiales par enfant.
/*
champ d'application CalculAllocationsFamiliales :
définition allocation_forfaitaire.montant_versé sous condition
l521_1.ressources_ménage > d521_3.plafond_II
champ d'application AllocationsFamiliales :
définition montant_versé_forfaitaire sous condition
ressources_ménage >€ plafond_II_d521_3
conséquence égal à
prestations_familiales.base_mensuelle * 5,059 % *
nombre pour enfant dans ménage.enfants de
allocation_forfaitaire.droits_ouvert de enfant
(prestations_familiales.base_mensuelle *€ 5,059 %) *€
entier_vers_décimal de (nombre pour enfant dans enfants_à_charge de
droit_ouvert_forfaitaire de enfant)
*/
II.-En application du sixième alinéa de l'article L. 521-1, le montant mensuel de l'allocation forfaitaire est majoré d'un complément dégressif lorsque les ressources annuelles du ménage ou de la personne dépassent l'un des plafonds défini au I ou au II de l'article D. 521-3 d'une somme inférieure à douze fois le montant mensuel de l'allocation forfaitaire auquel l'enfant ouvre droit.
Ce complément dégressif est égal, pour chaque mois, au douzième de la différence entre, d'une part, ce plafond de ressources majoré de la somme définie à l'alinéa précédent et, d'autre part, le montant des ressources.
II.-En application du sixième alinéa de l'article L. 521-1, le montant mensuel
de l'allocation forfaitaire est majoré d'un complément dégressif lorsque les
ressources annuelles du ménage ou de la personne dépassent l'un des plafonds
défini au I ou au II de l'article D. 521-3 d'une somme inférieure à douze fois
le montant mensuel de l'allocation forfaitaire auquel l'enfant ouvre droit.
Ce complément dégressif est égal, pour chaque mois, au douzième de la différence
entre, d'une part, ce plafond de ressources majoré de la somme définie à
l'alinéa précédent et, d'autre part, le montant des ressources.
/*
champ d'application CalculAllocationsFamiliales :
définition
complément_dégressif.pour_allocation_forfaitaire
sous condition
allocation_forfaitaire.droits_ouverts et
complément_dégressif.droits_ouverts de allocation_forfaitaire.droits_ouverts
conséquence égal à
(complément_dégressif.dépassement
de allocation_forfaitaire.montant_versé) / 12
champ d'application AllocationsFamiliales :
définition montant_versé_complément_pour_forfaitaire égal à
(dépassement_plafond_ressources de montant_versé_forfaitaire) *€
(1,0 /. 12,0)
*/
III.-Le nombre minimum d'enfants à charge mentionné au deuxième alinéa de l'article L. 521-1 est fixé à trois.
III.-Le nombre minimum d'enfants à charge mentionné au deuxième alinéa de
l'article L. 521-1 est fixé à trois.
/*
champ d'application CalculAllocationsFamiliales :
définition l521_1.nombre_minimum_enfants égal à 3
champ d'application AllocationsFamiliales :
définition nombre_enfants_l521_1 égal à 3
*/
@Article D521-3|LEGIARTI000030678079@
I.-Le plafond prévu au 1° du I des articles D. 521-1 et D. 521-2 est fixé à 55 950 euros. Il est majoré de 5 595 euros par enfant à charge.
I.-Le plafond prévu au 1° du I des articles D. 521-1 et D. 521-2 est fixé à
55 950 euros. Il est majoré de 5 595 euros par enfant à charge.
/*
champ d'application CalculAllocationsFamiliales :
définition d521_3.plafond_I égal à 55 950 € +
5 595 € * nombre de ménage.enfants
champ d'application AllocationsFamiliales :
définition plafond_I_d521_3 égal à 55 950 € +€
5 595 € *€ (entier_vers_décimal de (nombre de enfants_à_charge))
*/
II.-Le plafond prévu au 2° du I des articles D. 521-1 et D. 521-2 est fixé à 78 300 euros. Il est majoré de 5 595 euros par enfant à charge.
II.-Le plafond prévu au 2° du I des articles D. 521-1 et D. 521-2 est fixé à
78 300 euros. Il est majoré de 5 595 euros par enfant à charge.
/*
champ d'application CalculAllocationsFamiliales :
définition d521_3.plafond_II égal à 78 300 € +
5 595 € * nombre de ménage.enfants
champ d'application AllocationsFamiliales :
définition plafond_II_d521_3 égal à 78 300 € +€
5 595 € *€ (entier_vers_décimal de (nombre de enfants_à_charge))
*/
III.-Les montants des plafonds et de leur majoration respective fixés au présent article sont revalorisés au 1er janvier de chaque année, conformément à l'évolution en moyenne annuelle des prix à la consommation hors tabac de l'année civile de référence, par arrêté des ministres chargés de la sécurité sociale, du budget et de l'agriculture.
III.-Les montants des plafonds et de leur majoration respective fixés au présent
article sont revalorisés au 1er janvier de chaque année, conformément à
l'évolution en moyenne annuelle des prix à la consommation hors tabac de
l'année civile de référence, par arrêté des ministres chargés de la sécurité
sociale, du budget et de l'agriculture.
@@Livre 7 : Régimes divers - Dispositions diverses@@++
@ -247,47 +277,51 @@ III.-Les montants des plafonds et de leur majoration respective fixés au prése
@@Chapitre 5 : Prestations familiales et prestations assimilées@@++++
@Article D755-5|LEGIARTI000006738575@
I. - Les taux servant au calcul des allocations familiales et de la majoration prévue à l'article L. 755-11 sont identiques à ceux mentionnés à l'article D. 521-1.
I. - Les taux servant au calcul des allocations familiales et de la majoration
prévue à l'article L. 755-11 sont identiques à ceux mentionnés à l'article
D. 521-1.
/*
# Pas de changement à déclarer
*/
II. - En application de l'article L. 755-11, 2e alinéa, le taux servant au calcul des allocations familiales servies pour un seul enfant à charge est fixé à 5,88 p. 100 de la base mensuelle prévue à l'article L. 755-3.
II. - En application de l'article L. 755-11, 2e alinéa, le taux servant au
calcul des allocations familiales servies pour un seul enfant à charge est
fixé à 5,88 p. 100 de la base mensuelle prévue à l'article L. 755-3.
/*
# Composantes des allocations familiales
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.base sous condition
l751_1.régime_outre_mer et
allocations_familiales.droits_ouverts
champ d'application AllocationsFamiliales :
exception définition_montant_initial_base
définition montant_initial_base sous condition
prestations_familiales.régime_outre_mer_l751_1 et
nombre de enfants_à_charge = 1
conséquence égal à
si nombre de ménage.enfants = 1 alors
allocations_familiales.montant_premier_enfant
sinon (
allocations_familiales.montant_deuxieme_enfant +
allocations_familiales.montant_troisième_enfant_et_plus
)
montant_initial_base_premier_enfant
définition allocations_familiales.montant_premier_enfant égal à
prestations_familiales.base_mensuelle_dom * 5,88 %
définition montant_initial_base_premier_enfant égal à
prestations_familiales.base_mensuelle *€ 5,88 %
# Question : le complément dégressif s'applique-t-il ici ? Car le complément
# est basé sur les plafonds du taux de base qui ne s'appliquent pas ici,
# donc il serait logique que le plafond ne s'applique pas.
*/
La majoration des allocations familiales pour un seul enfant à charge est fixée à 3,69 p. 100 de la base mensuelle prévue à l'article L. 755-3 à partir de onze ans et à 5,67 p. 100 à partir de seize ans.
La majoration des allocations familiales pour un seul enfant à charge est
fixée à 3,69 p. 100 de la base mensuelle prévue à l'article L. 755-3 à
partir de onze ans et à 5,67 p. 100 à partir de seize ans.
/*
champ d'application CalculAllocationsFamiliales :
définition l521_3.âge_limite_alinéa_1 de enfant
sous condition l751_1.régime_outre_mer
conséquence égal à 11 an
définition
majorations_allocations_familiales.base_par_enfant de enfant
sous condition
l751_1.régime_outre_mer et
(majorations_allocations_familiales.droits_ouverts de enfant)
conséquence égal à
prestations_familiales.base_mensuelle_dom *
(si enfant.âge >= 16 an alors 5,67 % sinon 3,69 %)
champ d'application AllocationsFamiliales :
définition âge_limite_alinéa_1_l521_3 de enfant
sous condition prestations_familiales.régime_outre_mer_l751_1
conséquence égal à 11
définition
montant_initial_majoration de enfant
sous condition
prestations_familiales.régime_outre_mer_l751_1 et
(nombre de enfants_à_charge = 1)
conséquence égal à
prestations_familiales.base_mensuelle *€
(si enfant.âge >= 16 alors 5,67 % sinon 3,69 %)
*/

407
examples/allocations_familiales/securite_sociale_L.catala_fr
View File

@ -11,70 +11,75 @@
@Article L511-1|LEGIARTI000038834530@
Les prestations familiales comprennent :
1°) la prestation d'accueil du jeune enfant ;
2°) les allocations familiales ;
3°) le complément familial ;
4°) L'allocation de logement régie par les dispositions du livre VIII du code de la construction et de l'habitation ;
5°) l'allocation d'éducation de l'enfant handicapé ;
6°) l'allocation de soutien familial ;
7°) l'allocation de rentrée scolaire ;
8°) (Abrogé) ;
9°) l'allocation journalière de présence parentale.
/*
# Voir métadonnnée L511_1.prestation_courante
# Voir l'énumération ÉlémentPrestationsFamiliale
*/
@@Chapitre 2 : Champ d'application@@++++
@Article L512-3|LEGIARTI000038834523@
Sous réserve des règles particulières à chaque prestation, ouvre droit aux prestations familiales :
/*
champ d'application CalculPrestationsFamiliales :
# On suppose dans le programme que tous les enfants déclarés dans
# ménage.enfants ouvrent droit aux allocations familiales
assertion pour tout enfant dans ménage.enfants on a
prestations_familiales.droits_ouverts de enfant
*/
Sous réserve des règles particulières à chaque prestation,
ouvre droit aux prestations familiales :
1°) tout enfant jusqu'à la fin de l'obligation scolaire ;
/*
champ d'application CalculPrestationsFamiliales :
règle prestations_familiales.droits_ouverts de enfant sous condition
(enfant dans ménage.enfants) et
(date_calcul <= enfant.fin_obligation_scolaire)
champ d'application PrestationsFamiliales :
règle droit_ouvert de enfant sous condition
(date_courante <=@ enfant.fin_obligation_scolaire)
conséquence rempli
*/
2°) après la fin de l'obligation scolaire, et jusqu'à un âge limite, tout enfant dont la rémunération éventuelle n'excède pas un plafond.
2°) après la fin de l'obligation scolaire, et jusqu'à un âge limite,
tout enfant dont la rémunération éventuelle n'excède pas un plafond.
/*
champ d'application CalculPrestationsFamiliales :
champ d'application PrestationsFamiliales :
# On définit les conditions hors âge d'abord car elles
# sont référencées dans l'article L521-1
règle prestations_familiales.conditions_hors_âge de enfant sous condition
(enfant dans ménage.enfants) et (
(date_calcul <= enfant.fin_obligation_scolaire) ou
(enfant.rémuneration_mensuelle <
l512_3.plafond_rémunération_mensuelle_alinéa_2)
)
# sont référencées plus tard dans l'article L521-1
règle conditions_hors_âge de enfant sous condition
(date_courante <=@ enfant.fin_obligation_scolaire) ou
(enfant.rémuneration_mensuelle <=€ plafond_l512_3_2)
conséquence rempli
règle prestations_familiales.droits_ouverts de enfant sous condition
(enfant dans ménage.enfants) et
(date_calcul > enfant.fin_obligation_scolaire) et
(l512_3.conditions_hors_âge de enfant) et
(enfant.âge < l512_3.âge_limite_alinéa_2)
règle droit_ouvert de enfant sous condition
(date_courante >@ enfant.fin_obligation_scolaire) et
(conditions_hors_âge de enfant) et
(enfant.âge <= âge_l512_3_2)
conséquence rempli
*/
Toutefois, pour l'attribution du complément familial et de l'allocation de logement mentionnés aux 3° et 4° de l'article L. 511-1 , l'âge limite peut être différent de celui mentionné au 2° du présent article.
Toutefois, pour l'attribution du complément familial et de l'allocation
de logement mentionnés aux 3° et 4° de l'article L. 511-1 , l'âge limite
peut être différent de celui mentionné au 2° du présent article.
/*
champ d'application CalculPrestationsFamiliales :
définition l512_3.âge_limite_alinéa_2 sous condition
l512_3.âge_limite_alinéa_2_alternatif_utilisé et
(l511_1.prestation_courante = ComplémentFamilial ou
l511_1.prestation_courante = AllocationLogement)
champ d'application PrestationsFamiliales :
définition âge_l512_3_2 sous condition
(selon âge_l512_3_2_alternatif sous forme
-- Présent de âge : vrai
-- Absent: faux) et
(prestation_courante = ComplémentFamilial ou
prestation_courante = AllocationLogement)
conséquence égal à
l512_3.âge_limite_alinéa_2_alternatif
selon âge_l512_3_2_alternatif sous forme
-- Présent de âge : âge
-- Absent: 0
*/
@@Titre 2 : Prestations générales d'entretien@@+++
@ -84,62 +89,62 @@ champ d'application CalculPrestationsFamiliales :
@Article L521-1|LEGIARTI000029963006@
Les allocations familiales sont dues à partir du deuxième enfant à charge.
/*
champ d'application CalculAllocationsFamiliales :
règle allocations_familiales.droits_ouverts sous condition
nombre de ménage.enfants >= 2
champ d'application AllocationsFamiliales :
étiquette définitition_droit_ouvert_base
règle droit_ouvert_base sous condition
nombre de enfants_à_charge >= 2
conséquence rempli
# Les droits doivent être ouverts pour appliquer le champ
# CalculAllocationsFamiliales. Si cette condition n'est pas remplie,
# alors il est inutile de calculer le reste
assertion allocations_familiales.droits_ouverts
# Le champ d'application CalculAllocationsFamiliales inclus
# PrestationsFamiliales, mais à condition que la prestation courante
# soit cohérente
définition l511_1.prestation_courante égal à AllocationFamiliale
*/
Une allocation forfaitaire par enfant d'un montant fixé par décret est versée pendant un an à la personne ou au ménage qui assume la charge d'un nombre minimum d'enfants également fixé par décret lorsque l'un ou plusieurs des enfants qui ouvraient droit aux allocations familiales atteignent l'âge limite mentionné au 2° de l'article L. 512-3 . Cette allocation est versée à la condition que le ou les enfants répondent aux conditions autres que celles de l'âge pour l'ouverture du droit aux allocations familiales.
Une allocation forfaitaire par enfant d'un montant fixé par décret est versée
pendant un an à la personne ou au ménage qui assume la charge d'un nombre
minimum d'enfants également fixé par décret lorsque l'un ou plusieurs des
enfants qui ouvraient droit aux allocations familiales atteignent l'âge
limite mentionné au 2° de l'article L. 512-3 . Cette allocation est versée
à la condition que le ou les enfants répondent aux conditions autres que
celles de l'âge pour l'ouverture du droit aux allocations familiales.
/*
champ d'application CalculAllocationsFamiliales :
assertion fixé allocation_forfaitaire.montant_versé par décret
champ d'application AllocationsFamiliales :
assertion fixé montant_versé par décret
# Ici, l'ouverture du droit aux allocations familiales est conditionné
# au fait d'avoir deux enfants à charges qui répondent aux conditions
# d'ouverture du droit à une prestation familiale. Pour cette raison,
# nous nous référons ici aux conditions_hors_âge de prestations_familiales
# et non pas de allocations_familiales
règle allocations_familiales.conditions_hors_âge de enfant sous condition
règle conditions_hors_âge de enfant sous condition
prestations_familiales.conditions_hors_âge de enfant
conséquence rempli
règle allocation_forfaitaire.droits_ouverts de enfant sous condition
(nombre de ménage.enfants >= l512_1.nombre_minimum_enfants) et
(enfant dans ménage.enfants) et
(enfant.âge = l512_3.âge_limite_alinéa_2) et
(allocations_familiales.conditions_hors_âge de enfant)
règle droit_ouvert_forfaitaire de enfant sous condition
(nombre de enfants_à_charge >= nombre_enfants_l521_1) et
(enfant.âge = prestations_familiales.âge_l512_3_2) et
(conditions_hors_âge de enfant)
conséquence rempli
*/
Le montant des allocations mentionnées aux deux premiers alinéas du présent article, ainsi que celui des majorations mentionnées à l'article L. 521-3 varient en fonction des ressources du ménage ou de la personne qui a la charge des enfants, selon un barème défini par décret.
Le montant des allocations mentionnées aux deux premiers alinéas du présent
article, ainsi que celui des majorations mentionnées à l'article L. 521-3
varient en fonction des ressources du ménage ou de la personne qui a la charge
des enfants, selon un barème défini par décret.
/*
champ d'application CalculAllocationsFamiliales :
assertion fixé allocations_familiales.montant_versé par décret
assertion varie allocations_familiales.montant_versé avec
l521_1.ressources_ménage
assertion fixé majorations_allocations_familiales.montant_versé par décret
assertion varie majorations_allocations_familiales.montant_versé avec
l521_1.ressources_ménage
champ d'application AllocationsFamiliales :
assertion fixé montant_versé_base par décret
assertion varie montant_versé_base avec ressources_ménage
assertion fixé montant_versé_majorations par décret
assertion varie montant_versé_majorations avec ressources_ménage
*/
Le montant des allocations familiales varie en fonction du nombre d'enfants à charge.
Le montant des allocations familiales varie en fonction du nombre d'enfants
à charge.
/*
champ d'application CalculAllocationsFamiliales :
assertion varie allocations_familiales.montant_versé avec
nombre de ménage.enfants
champ d'application AllocationsFamiliales :
assertion varie montant_versé_base.montant_versé avec
nombre de enfants_à_charge
*/
Les niveaux des plafonds de ressources, qui varient en fonction du nombre d'enfants à charge, sont révisés conformément à l'évolution annuelle de l'indice des prix à la consommation, hors tabac.
Les niveaux des plafonds de ressources, qui varient en fonction du nombre
d'enfants à charge, sont révisés conformément à l'évolution annuelle de
l'indice des prix à la consommation, hors tabac.
/*
# Pour formaliser l'évolution des prix, il faudrait recopier ici
# tous les décrets d'application qui fixent la valeur des plafonds
@ -147,108 +152,111 @@ Les niveaux des plafonds de ressources, qui varient en fonction du nombre d'enfa
# nous avons choisi de ne pas inclure tout ce code dans ce document.
*/
Un complément dégressif est versé lorsque les ressources du bénéficiaire dépassent l'un des plafonds, dans la limite de montants définis par décret. Les modalités de calcul de ces montants et celles du complément dégressif sont définies par décret.
Un complément dégressif est versé lorsque les ressources du bénéficiaire
dépassent l'un des plafonds, dans la limite de montants définis par décret.
Les modalités de calcul de ces montants et celles du complément dégressif
sont définies par décret.
/*
# Ditto, le volume du code à inclure pour formaliser cette assertion
# est assez important et nous avons choisi de ne pas l'inclure dans ce
# document.
champ d'application CalculAllocationsFamiliales :
assertion fixé complément_dégressif.montant_versé par décret
champ d'application AllocationsFamiliales :
assertion fixé montant_versé_complément par décret
*/
@Article L521-2|LEGIARTI000006743210@
Les allocations sont versées à la personne qui assume, dans quelques conditions que ce soit, la charge effective et permanente de l'enfant.
Les allocations sont versées à la personne qui assume, dans quelques conditions
que ce soit, la charge effective et permanente de l'enfant.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.charge_par_enfant de enfant
sous condition
(enfant dans ménage.enfants) et
(enfant.prise_en_charge sous forme Complète)
conséquence égal à Complète
champ d'application AllocationsFamiliales :
étiquette définition_prise_en_compte
définition prise_en_compte de enfant égal à Complète
définition allocations_familiales.récipiendaire_par_enfant de enfant
sous condition enfant dans ménage.enfants
conséquence égal à ménage.parent_en_charge
étiquette définition_versement
définition versement de enfant égal à Normal
*/
En cas de résidence alternée de l'enfant au domicile de chacun des parents telle que prévue à l'article 373-2-9 du code civil, mise en oeuvre de manière effective, les parents désignent l'allocataire. Cependant, la charge de l'enfant pour le calcul des allocations familiales est partagée par moitié entre les deux parents soit sur demande conjointe des parents, soit si les parents sont en désaccord sur la désignation de l'allocataire. Un décret en Conseil d'Etat fixe les conditions d'application du présent alinéa.
En cas de résidence alternée de l'enfant au domicile de chacun des parents telle
que prévue à l'article 373-2-9 du code civil, mise en oeuvre de manière
effective, les parents désignent l'allocataire. Cependant, la charge de l'enfant
pour le calcul des allocations familiales est partagée par moitié entre les deux
parents soit sur demande conjointe des parents, soit si les parents sont en
désaccord sur la désignation de l'allocataire. Un décret en Conseil d'Etat fixe
les conditions d'application du présent alinéa.
/*
champ d'application CalculAllocationsFamiliales :
# Premier cas : garde alternée, parents désignent un unique allocataire
règle allocations_garde_alternée.unique_allocataire de enfant sous condition
(enfant dans ménage.enfants) et
(enfant.prise_en_charge sous forme GardeAlternée) et
((allocations_garde_alternée.choix_allocataire de enfant)
sous forme Présent) et
((allocations_garde_alternée.choix_allocataire de enfant) -> Présent
sous forme UnParent) et
(((allocations_garde_alternée.choix_allocataire de enfant) -> Présent -> UnParent)
dans ménage.parents)
conséquence rempli
champ d'application AllocationsFamiliales :
# Premier cas : garde alternée, parents désignent un unique allocataire
exception définition_prise_en_compte
définition prise_en_compte de enfant sous condition
selon enfant.garde_alternée sous forme
-- OuiAllocataireUnique: vrai
-- OuiPartageAllocations: faux
-- NonGardeUnique: faux
conséquence égal à Complète
définition allocations_familiales.charge_par_enfant de enfant
sous condition allocations_garde_alternée.unique_allocataire de enfant
conséquence égal à Complète
exception définition_versement
définition versement de enfant sous condition
selon enfant.garde_alternée sous forme
-- OuiAllocataireUnique: vrai
-- OuiPartageAllocations: faux
-- NonGardeUnique: faux
conséquence égal à Normal
# Deuxième cas : garde alternée, parents partagent la charge pour
# l'allocation
règle allocations_garde_alternée.allocataire_double de enfant sous condition
(enfant dans ménage.enfants) et
(enfant.prise_en_charge sous forme GardeAlternée) et
(enfant.choix_allocataire_garde_alternée sous forme Présent) et
(enfant.choix_allocataire_garde_alternée -> Présent sous forme DeuxParents)
conséquence rempli
définition allocations_familiales.charge_par_enfant de enfant
sous condition
(enfant dans ménage.enfants) et
(allocations_garde_alternée.allocataire_double de enfant)
conséquence égal à Partagée
définition allocations_familiales.charge_par_enfant de enfant sous condition
(enfant dans ménage.enfants) et
(enfant.prise_en_charge sous forme GardeAlternée) et
(allocations_garde_alternée.demande_conjointe_partage_charge de enfant ou
allocations_garde_alternée.desaccord_charge de enfant)
# Deuxième cas : garde alternée, parents partagent la charge pour
# l'allocation
exception définition_prise_en_compte
définition prise_en_compte de enfant sous condition
selon enfant.garde_alternée sous forme
-- OuiPartageAllocations: vrai
-- OuiAllocataireUnique: faux
-- NonGardeUnique: faux
conséquence égal à Partagée
# Quelles variables fixées par R521_2 ?
exception définition_versement
définition versement de enfant sous condition
selon enfant.garde_alternée sous forme
-- OuiPartageAllocations: vrai
-- OuiAllocataireUnique: faux
-- NonGardeUnique: faux
conséquence égal à Partagée
*/
Lorsque la personne qui assume la charge effective et permanente de l'enfant ne remplit pas les conditions prévues au titre I du présent livre pour l'ouverture du droit aux allocations familiales, ce droit s'ouvre du chef du père ou, à défaut, du chef de la mère.
Lorsque la personne qui assume la charge effective et permanente de l'enfant ne
remplit pas les conditions prévues au titre I du présent livre pour l'ouverture
du droit aux allocations familiales, ce droit s'ouvre du chef du père ou,
à défaut, du chef de la mère.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.récipiendaire_par_enfant de enfant
sous condition
(enfant dans ménage.enfants) et
(titre_I.droits_ouverts_allocations_familiales de
(ménage.parent_en_charge de enfant))
conséquence égal à ménage.parent1
# ménage.parent1 est le père ou à défaut la mère
# (ménage.parent2 est optionnel)
# Non formalisé pour le calcul du montant des allocations
*/
Lorsqu'un enfant est confié au service d'aide sociale à l'enfance, les allocations familiales continuent d'être évaluées en tenant compte à la fois des enfants présents au foyer et du ou des enfants confiés au service de l'aide sociale à l'enfance. La part des allocations familiales dues à la famille pour cet enfant est versée à ce service. Toutefois, le juge peut décider, d'office ou sur saisine du président du conseil général, à la suite d'une mesure prise en application des articles 375-3 et 375-5 du code civil ou des articles 15,16,16 bis et 28 de l' ordonnance n° 45-174 du 2 février 1945 relative à l'enfance délinquante, de maintenir le versement des allocations à la famille, lorsque celle-ci participe à la prise en charge morale ou matérielle de l'enfant ou en vue de faciliter le retour de l'enfant dans son foyer.
Lorsqu'un enfant est confié au service d'aide sociale à l'enfance, les
allocations familiales continuent d'être évaluées en tenant compte à la fois
des enfants présents au foyer et du ou des enfants confiés au service de
l'aide sociale à l'enfance. La part des allocations familiales dues à la
famille pour cet enfant est versée à ce service. Toutefois, le juge peut
décider, d'office ou sur saisine du président du conseil général, à la
suite d'une mesure prise en application des articles 375-3 et 375-5 du code
civil ou des articles 15,16,16 bis et 28 de l' ordonnance n° 45-174 du 2
février 1945 relative à l'enfance délinquante, de maintenir le versement
des allocations à la famille, lorsque celle-ci participe à la prise en
charge morale ou matérielle de l'enfant ou en vue de faciliter le retour
de l'enfant dans son foyer.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.charge_par_enfant de enfant
sous condition
(enfant dans ménage.enfants) et
(enfant.confié_service_social)
conséquence égal à Complète
définition allocations_familiales.récipiendaire_par_enfant de enfant
sous condition
(enfant dans ménage.enfants) et
(enfant.confié_service_social)
conséquence égal à service_social
champ d'application AllocationsFamiliales :
exception définition_versement
définition versement de enfant sous condition
selon enfant.pris_en_charge_par_services_sociaux sous forme
-- OuiAllocationVerséeAuxServicesSociaux: vrai
-- OuiAllocationVerséeÀLaFamille: faux
-- NonPriseEnChargeFamille: faux
conséquence égal à AllocationVerséeAuxServicesSociaux
*/
Un décret en Conseil d'Etat fixe les conditions d'application du présent article, notamment dans les cas énumérés ci-dessous :
Un décret en Conseil d'Etat fixe les conditions d'application du présent
article, notamment dans les cas énumérés ci-dessous :
a) retrait total de l'autorité parentale des parents ou de l'un d'eux ;
@ -263,25 +271,27 @@ d) enfants confiés à un service public, à une institution privée, à un part
# est confié à un service social.
*/
@Article L521-3|LEGIARTI000006743289@ Chacun des enfants à charge, à l'exception du plus âgé, ouvre droit à partir d'un âge minimum à une majoration des allocations familiales.
@Article L521-3|LEGIARTI000006743289@ Chacun des enfants à charge, à
l'exception du plus âgé, ouvre droit à partir d'un âge minimum à une
majoration des allocations familiales.
/*
champ d'application CalculAllocationsFamiliales :
règle majorations_allocations_familiales.droits_ouverts de enfant
champ d'application AllocationsFamiliales :
règle droit_ouvert_majoration de enfant
sous condition
(enfant dans ménage.enfants) et
(enfant != ménage.enfant_plus_âgé) et
(enfant.âge >= l521_3.âge_limite_alinéa_1 de enfant)
(non (est_enfant_le_plus_âgé de enfant)) et
(enfant.âge >= âge_limite_alinéa_1_l521_3 de enfant)
conséquence rempli
*/
Toutefois, les personnes ayant un nombre déterminé d'enfants à charge bénéficient de ladite majoration pour chaque enfant à charge à partir de l'âge mentionné au premier alinéa.
Toutefois, les personnes ayant un nombre déterminé d'enfants à charge
bénéficient de ladite majoration pour chaque enfant à charge à partir
de l'âge mentionné au premier alinéa.
/*
champ d'application CalculAllocationsFamiliales :
règle majorations_allocations_familiales.droits_ouverts de enfant
champ d'application AllocationsFamiliales :
règle droit_ouvert_majoration de enfant
sous condition
(enfant dans ménage.enfants) et
(nombre de ménage.enfants >= l521_3.minimum_alinéa_2) et
(enfant.âge >= l521_3.âge_limite_alinéa_1 de enfant)
(nombre de enfants_à_charge >= nombre_enfants_alinéa_2_l521_3) et
(enfant.âge >= âge_limite_alinéa_1_l521_3 de enfant)
conséquence rempli
*/
@ -290,7 +300,9 @@ champ d'application CalculAllocationsFamiliales :
@@Chapitre 1er : Etablissement du salaire de base@@++++
@Article L551-1|LEGIARTI000031688371@
Le montant des prestations familiales est déterminé d'après des bases mensuelles de calcul revalorisées au 1er avril de chaque année par application du coefficient mentionné à l'article L. 161-25 .
Le montant des prestations familiales est déterminé d'après des bases
mensuelles de calcul revalorisées au 1er avril de chaque année par application
du coefficient mentionné à l'article L. 161-25 .
/*
# Idem que L521-1, on ne formalise pas ici l'évolution de la BMPA
champ d'application PrestationsFamiliales :
@ -299,70 +311,77 @@ champ d'application PrestationsFamiliales :
@@Livre 7 : Régimes divers - Dispositions diverses@@++
@@Titre 5 : Dispositions particulières à la Guadeloupe, à la Guyane, à la
Martinique, à La Réunion, à Saint-Barthélemy et à Saint-Martin@@+++
@@Titre 5 : Dispositions particulières à la Guadeloupe, à la Guyane, à la Martinique, à La Réunion, à Saint-Barthélemy et à Saint-Martin@@+++
@@Chapitre 1er : Généralités@@++++
@Article L751-1|LEGIARTI000031323778@
Les dispositions du présent titre s'appliquent en Guadeloupe, en Guyane, en Martinique, à La Réunion, à Saint-Barthélemy et à Saint-Martin à l'ensemble des bénéficiaires de la législation générale de sécurité sociale, y compris les membres des professions agricoles.
Les dispositions du présent titre s'appliquent en Guadeloupe, en Guyane,
en Martinique, à La Réunion, à Saint-Barthélemy et à Saint-Martin à
l'ensemble des bénéficiaires de la législation générale de sécurité
sociale, y compris les membres des professions agricoles.
/*
champ d'application CalculPrestationsFamiliales :
règle l751_1.régime_outre_mer sous condition
(ménage.résidence = Guadeloupe) ou
(ménage.résidence = Guyane) ou
(ménage.résidence = Martinique) ou
(ménage.résidence = LaRéunion) ou
(ménage.résidence = SaintBarthélemy) ou
(ménage.résidence = SaintMartin)
champ d'application PrestationsFamiliales :
règle régime_outre_mer_l751_1 sous condition
(résidence = Guadeloupe) ou
(résidence = Guyane) ou
(résidence = Martinique) ou
(résidence = LaRéunion) ou
(résidence = SaintBarthélemy) ou
(résidence = SaintMartin)
conséquence rempli
*/
@@Chapitre 5 : Prestations familiales et prestations assimilées@@++++
@Article L755-3|LEGIARTI000033728786@
Les dispositions des articles L. 512-1 à L. 512-4 , L. 513-1 , L. 521-2 , L. 552-1 , L. 553-1 , L. 553-2 , L. 553-4 , L. 582-1 , L. 582-2 , L. 583-3 et L. 583-5 sont applicables aux collectivités mentionnées à l'article L. 751-1 .
Les dispositions des articles L. 512-1 à L. 512-4 , L. 513-1 , L. 521-2 ,
L. 552-1 , L. 553-1 , L. 553-2 , L. 553-4 , L. 582-1 , L. 582-2 , L. 583-3
et L. 583-5 sont applicables aux collectivités mentionnées à l'article L. 751-1 .
La base de calcul des prestations familiales est la même que celle qui est fixée en application de l'article L. 551-1 .
La base de calcul des prestations familiales est la même que celle qui est
fixée en application de l'article L. 551-1 .
/*
champ d'application CalculPrestationsFamiliales :
définition prestations_familiales.base_mensuelle_dom égal à
prestations_familiales.base_mensuelle
*/
@Article L755-11|LEGIARTI000031323803@
Les conditions d'attribution des allocations familiales et de leurs majorations fixées par les articles L. 521-1 et L. 521-3 sont applicables dans les collectivités mentionnées à l'article L. 751-1 .
/*
# Aucun changement dans le code, puisque les articles restent applicables
*/
Toutefois, les dispositions de l'article L. 755-12 restent en vigueur aussi longtemps que le présent chapitre V est applicable.
@Article L755-11|LEGIARTI000031323803@
Les conditions d'attribution des allocations familiales et de leurs majorations
fixées par les articles L. 521-1 et L. 521-3 sont applicables dans les
collectivités mentionnées à l'article L. 751-1 .
/*
# Aucun changement dans le code, puisque les articles restent applicables
*/
Toutefois, les dispositions de l'article L. 755-12 restent en vigueur aussi
longtemps que le présent chapitre V est applicable.
@Article L755-12|LEGIARTI000029962999@
Les allocations familiales sont dues, pour tout enfant, à la personne qui a effectivement la charge de celui-ci.
Les allocations familiales sont dues, pour tout enfant, à la personne qui a
effectivement la charge de celui-ci.
/*
champ d'application CalculAllocationsFamiliales :
règle allocations_familiales.droits_ouverts sous condition
(l751_1.régime_outre_mer) et
(nombre de ménage.enfants >= 1)
champ d'application AllocationsFamiliales:
exception définitition_droit_ouvert_base
règle droit_ouvert_base sous condition
prestations_familiales.régime_outre_mer_l751_1 et
(nombre de enfants_à_charge >= 1)
conséquence rempli
*/
Toutefois, les quatre derniers alinéas de l'article L. 521-1 ne sont pas applicables lorsque le ménage ou la personne a un seul enfant à charge.
Toutefois, les quatre derniers alinéas de l'article L. 521-1 ne sont pas
applicables lorsque le ménage ou la personne a un seul enfant à charge.
/*
# Ceci concerne l'ouverture du droit à l'allocation forfaitaire
# et au complément dégressif.
champ d'application CalculAllocationsFamiliales :
règle allocation_forfaitaire.droits_ouverts de enfant sous condition
(l751_1.régime_outre_mer) et
(nombre de ménage.enfants = 1)
champ d'application AllocationsFamiliales :
règle droit_ouvert_forfaitaire de enfant sous condition
prestations_familiales.régime_outre_mer_l751_1 et
(nombre de enfants_à_charge = 1)
conséquence non rempli
règle
complément_dégressif.droits_ouvert de allocation
sous condition
(l751_1.régime_outre_mer) et
(nombre de ménage.enfants = 1)
règle droit_ouvert_complément sous condition
prestations_familiales.régime_outre_mer_l751_1 et
(nombre de enfants_à_charge = 1)
conséquence non rempli
*/

165
examples/allocations_familiales/securite_sociale_R.catala_fr
View File

@ -7,21 +7,28 @@
@@Chapitre 2 : Champ d'application.@@++++
@Article R512-2|LEGIARTI000006750602@
Les enfants ouvrent droit aux prestations familiales jusqu'à l'âge de vingt ans sous réserve que leur rémunération n'excède pas le plafond fixé au deuxième alinéa du présent article.
Les enfants ouvrent droit aux prestations familiales jusqu'à l'âge de vingt
ans sous réserve que leur rémunération n'excède pas le plafond fixé au deuxième
alinéa du présent article.
/*
champ d'application CalculAllocationsFamiliales :
définition l512_3.âge_limite_alinéa_2 égal à 20 an
champ d'application PrestationsFamiliales :
définition âge_l512_3_2 égal à 20
*/
Le plafond de rémunération mentionné au 2° de l'article L. 512-3 est égal, pour un mois, à 55 % du salaire minimum interprofessionnel de croissance défini aux articles L. 141-1 à L. 141-9 du code du travail, multiplié par 169.
Le plafond de rémunération mentionné au 2° de l'article L. 512-3 est égal, pour
un mois, à 55 % du salaire minimum interprofessionnel de croissance défini aux
articles L. 141-1 à L. 141-9 du code du travail, multiplié par 169.
/*
champ d'application CalculAllocationsFamiliales :
définition l512_3.plafond_rémunération_mensuelle_alinéa_2 égal à
55 % * smic.brut_horaire de ménage.résidence * 169
champ d'application PrestationsFamiliales :
étiquette définition_plafond_l512_3_2
définition plafond_l512_3_2 égal à
(smic.brut_horaire *€ 55 %) *€ 169,0
*/
Pour ceux des enfants qui bénéficient d'avantages en nature, l'évaluation de ces avantages devra être faite suivant les barèmes fixés pour l'application de la législation sur les assurances sociales.
Pour ceux des enfants qui bénéficient d'avantages en nature, l'évaluation de ces
avantages devra être faite suivant les barèmes fixés pour l'application de la
législation sur les assurances sociales.
/*
# Le programme ne tient pas en compte des avantages en nature
@ -32,115 +39,125 @@ Pour ceux des enfants qui bénéficient d'avantages en nature, l'évaluation de
@@Chapitre 1er : Allocations familiales@@++++
@Article R521-1|LEGIARTI000018735853@
L'âge mentionné au premier alinéa de l'article L. 521-3 à partir duquel les enfants ouvrent droit à la majoration des allocations familiales est fixé à 14 ans.
L'âge mentionné au premier alinéa de l'article L. 521-3 à partir duquel les
enfants ouvrent droit à la majoration des allocations familiales est fixé à
14 ans.
/*
champ d'application CalculAllocationsFamiliales :
définition l521_3.âge_limite_alinéa_1 de enfant égal à 14 an
champ d'application AllocationsFamiliales :
définition âge_limite_alinéa_1_l521_3 de enfant égal à 14
*/
Le nombre minimum d'enfants à charge, mentionné au deuxième alinéa de l'article L. 521-3 ouvrant droit à ladite majoration pour chaque enfant est fixé à trois.
Le nombre minimum d'enfants à charge, mentionné au deuxième alinéa de l'article
L. 521-3 ouvrant droit à ladite majoration pour chaque enfant est fixé à trois.
/*
champ d'application CalculAllocationsFamiliales :
définition l521_3.minimum_alinéa_2 égal à 3
champ d'application AllocationsFamiliales :
définition nombre_enfants_alinéa_2_l521_3 égal à 3
*/
NOTA : Décret n° 2008-409 du 28 avril 2008 JORF du 29 avril 2008 art. 2 : Les modifications induites par le décret n° 2008-409 s'appliquent aux enfants dont le onzième anniversaire est postérieur au 30 avril 2008.
NOTA : Décret n° 2008-409 du 28 avril 2008 JORF du 29 avril 2008 art. 2 : Les
modifications induites par le décret n° 2008-409 s'appliquent aux enfants dont
le onzième anniversaire est postérieur au 30 avril 2008.
/*
# Notons ici un champ d'application différent, correspondant à une ancienne
# version du corpus législatif dont un morceau s'applique encore. Nous avons
# choisi de montrer ce vieux champ d'application ici plutôt qu'à côté du texte
# du décret de 2008 pour des raisons de place seulement.
champ d'application CalculAllocationFamilialesAvril2008:
# Âge limite avant décret n° 2008-409 du 28 avril 2008
définition l521_3.minimum_alinéa_2 de enfant égal à 16 an
champ d'application AllocationFamilialesAvril2008:
# Âge limite avant décret n° 2008-409 du 28 avril 2008
définition âge_limite_alinéa_1_l521_3 égal à 16
champ d'application CalculAllocationsFamiliales :
définition l521_3.minimum_alinéa_2 de enfant
sous condition (enfant.date_naissance + 11 an <= |30/04/2008|)
champ d'application AllocationsFamiliales :
définition âge_limite_alinéa_1_l521_3 de enfant
sous condition (enfant.date_de_naissance +@ 11 an <=@ |30/04/2008|)
conséquence égal à
calcul_avril_2008.l521_3.minimum_alinéa_2 de enfant
version_avril_2008.âge_limite_alinéa_1_l521_3
*/
@Article R521-2|LEGIARTI000006750608@
Dans les situations visées au deuxième alinéa de l'article L. 521-2 , l'allocataire est celui des deux parents qu'ils désignent d'un commun accord. A défaut d'accord sur la désignation d'un allocataire unique, chacun des deux parents peut se voir reconnaître la qualité d'allocataire :
Dans les situations visées au deuxième alinéa de l'article L. 521-2 ,
l'allocataire est celui des deux parents qu'ils désignent d'un commun accord.
A défaut d'accord sur la désignation d'un allocataire unique, chacun des deux
parents peut se voir reconnaître la qualité d'allocataire :
1° Lorsque les deux parents en ont fait la demande conjointe ;
2° Lorsque les deux parents n'ont ni désigné un allocataire unique, ni fait une demande conjointe de partage.
2° Lorsque les deux parents n'ont ni désigné un allocataire unique, ni fait
une demande conjointe de partage.
/*
# Le fait que l'allocataire dans le cas d'un commun accord soit celui des
# deux parents désigné par l'accord est déjà modélisé dans L512-2.
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.charge_par_enfant de enfant sous condition
(enfant dans ménage.enfants) et
(enfant.prise_en_charge sous forme GardeAlternée) et
(
(allocations_garde_alternée.demande_conjointe_partage_charge) ou
(
(non allocations_garde_alternée.demande_conjointe_partage_charge) et
(enfant.choix_allocataire_garde_alternée sous forme Absent)
)
)
conséquence égal à Partagée
*/
Lorsque les parents ont désigné un allocataire unique ou fait une demande conjointe de partage, ils ne peuvent remettre en cause les modalités ainsi choisies qu'au bout d'un an, sauf modification des modalités de résidence du ou des enfants.
Lorsque les parents ont désigné un allocataire unique ou fait une demande
conjointe de partage, ils ne peuvent remettre en cause les modalités ainsi
choisies qu'au bout d'un an, sauf modification des modalités de résidence du
ou des enfants.
/*
# On ne modélise pas le délai minimal entre changement de situation dans
# ce programme.
*/
@Article R521-3|LEGIARTI000006750610@
Sous réserve de l'article R. 521-4, dans les situations visées aux 1° et 2° de l'article R. 521-2 , la prestation due à chacun des parents est égale au montant des allocations familiales dues pour le total des enfants à charge, multiplié par un coefficient résultant du rapport entre le nombre moyen d'enfants et le nombre total d'enfants.
Sous réserve de l'article R. 521-4, dans les situations visées aux 1° et 2° de
l'article R. 521-2 , la prestation due à chacun des parents est égale au
montant des allocations familiales dues pour le total des enfants à charge,
multiplié par un coefficient résultant du rapport entre le nombre moyen
d'enfants et le nombre total d'enfants.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.avec_garde_alternée égal à
allocations_familiales.base *
allocations_familiales.rapport_enfants_total_moyen
champ d'application AllocationsFamiliales :
définition montant_avec_garde_alternée_base égal à
montant_initial_base *€ rapport_enfants_total_moyen
définition allocations_familiales.rapport_enfants_total_moyen égal à
allocations_familiales.nombre_moyen_enfants /
allocations_familiales.nombre_total_enfants
définition rapport_enfants_total_moyen égal à
nombre_moyen_enfants /. nombre_total_enfants
*/
Le nombre moyen d'enfants, pour chaque foyer, est obtenu en faisant la somme du nombre d'enfants à charge dans les conditions suivantes :
Le nombre moyen d'enfants, pour chaque foyer, est obtenu en faisant la somme
du nombre d'enfants à charge dans les conditions suivantes :
1° Chaque enfant en résidence alternée compte pour 0,5 ;
2° Les autres enfants à charge comptent pour 1.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.nombre_moyen_enfants égal à
somme pour enfant dans ménage.enfants de (
selon enfant.prise_en_charge sous forme
-- Complète : 1
-- GardeAlternée de parents : 0,5
champ d'application AllocationsFamiliales :
définition nombre_moyen_enfants égal à
somme décimal pour enfant dans enfants_à_charge de (
selon (prise_en_compte de enfant) sous forme
-- Complète : 1,0
-- Partagée : 0,5
)
*/
Le nombre total d'enfants, pour chaque foyer, est obtenu en faisant la somme du ou des enfants en résidence alternée et, le cas échéant, du ou des autres enfants à charge.
Le nombre total d'enfants, pour chaque foyer, est obtenu en faisant la somme du
ou des enfants en résidence alternée et, le cas échéant, du ou des autres
enfants à charge.
/*
champ d'application CalculAllocationsFamiliales :
définition allocations_familiales.nombre_total_enfants égal à
nombre de ménage.enfants
champ d'application AllocationsFamiliales :
définition nombre_total_enfants égal à
entier_vers_décimal de (nombre de enfants_à_charge)
*/
@Article R521-4|LEGIARTI000006750613@
Pour l'ouverture du droit à la majoration prévue à l'article L. 521-3 , le nombre d'enfants à charge est évalué dans les conditions prévues au premier alinéa de l'article R. 521-3.
Pour l'ouverture du droit à la majoration prévue à l'article L. 521-3 , le
nombre d'enfants à charge est évalué dans les conditions prévues au premier
alinéa de l'article R. 521-3.
/*
# ménage.enfants ne contient que des enfants à charge donc rien à formaliser
# enfants_à_charge ne contient que des enfants à charge donc rien à formaliser
# ici
*/
Lorsque le ou les enfants ouvrant droit à ladite majoration sont en résidence alternée, le montant servi au titre de cette majoration est réduit de moitié.
Lorsque le ou les enfants ouvrant droit à ladite majoration sont en résidence
alternée, le montant servi au titre de cette majoration est réduit de moitié.
/*
champ d'application CalculAllocationsFamiliales :
champ d'application AllocationsFamiliales :
définition
majorations_allocations_familiales.avec_garde_alternée de enfant
sous condition enfant dans ménage.enfants
montant_avec_garde_alternée_majoration de enfant
sous condition enfant dans enfants_à_charge
conséquence égal à (
selon enfant.prise_en_charge sous forme
-- Complète : majorations_allocations_familiales.base_par_enfant
-- GardeAlternée de parents:
majorations_allocations_familiales.base_par_enfant / 2
selon (prise_en_compte de enfant) sous forme
-- Complète : montant_initial_majoration de enfant
-- Partagée : montant_initial_majoration de enfant *€ 50%
)
*/
@ -151,11 +168,15 @@ champ d'application CalculAllocationsFamiliales :
@@Chapitre 5 : Prestations familiales et prestations assimilées@@++++
@Article R755-0-2|LEGIARTI000006752633@
Le plafond de rémunération des enfants à charge mentionnés à l'article L. 512-3 est égal, pour un mois, à 55 % du salaire minimum de croissance en vigueur dans chacun des départements mentionnés à l'article L. 751-1 , multiplié par 169.
Le plafond de rémunération des enfants à charge mentionnés à l'article
L. 512-3 est égal, pour un mois, à 55 % du salaire minimum de croissance en
vigueur dans chacun des départements mentionnés à l'article L. 751-1 ,
multiplié par 169.
/*
champ d'application CalculAllocationsFamiliales :
définition l512_3.plafond_rémunération_mensuelle_alinéa_2
sous condition l751_1.régime_outre_mer
champ d'application PrestationsFamiliales :
exception définition_plafond_l512_3_2
définition plafond_l512_3_2
sous condition régime_outre_mer_l751_1
conséquence égal à
55 % * smic.brut_horaire de ménage.résidence * 169
(smic.brut_horaire *€ 55%) *€ 169,0
*/

70
examples/allocations_familiales/tests/tests_allocations_familiales.catala_fr Normal file
View File

@ -0,0 +1,70 @@
@@Inclusion: ../allocations_familiales.catala_fr@@
@Tests@
/*
déclaration champ d'application Données:
contexte enfant1 contenu Enfant
contexte enfant2 contenu Enfant
contexte enfant3 contenu Enfant
champ d'application Données:
définition enfant1 égal à Enfant {
-- fin_obligation_scolaire : |01/08/2023|
-- date_de_naissance: |01/01/2007|
-- âge: 13
-- rémuneration_mensuelle: 0€
-- pris_en_charge_par_services_sociaux: NonPriseEnChargeFamille
-- garde_alternée: NonGardeUnique
}
définition enfant2 égal à Enfant {
-- fin_obligation_scolaire : |01/08/2021|
-- date_de_naissance: |01/01/2009|
-- âge: 15
-- rémuneration_mensuelle: 0€
-- pris_en_charge_par_services_sociaux: NonPriseEnChargeFamille
-- garde_alternée: OuiPartageAllocations
}
définition enfant3 égal à Enfant {
-- fin_obligation_scolaire : |01/08/2019|
-- date_de_naissance: |01/01/2003|
-- âge: 18
-- rémuneration_mensuelle: 400€
-- pris_en_charge_par_services_sociaux: NonPriseEnChargeFamille
-- garde_alternée: NonGardeUnique
}
déclaration champ d'application Test1:
contexte f champ d'application AllocationsFamiliales
contexte données champ d'application Données
champ d'application Test1:
définition f.enfants_à_charge égal à
[données.enfant1;données.enfant2;données.enfant3]
définition f.ressources_ménage égal à 30 000 €
définition f.date_courante égal à |01/05/2020|
définition f.résidence égal à Métropole
assertion f.montant_versé = 417,51€
déclaration champ d'application Test2:
contexte f champ d'application AllocationsFamiliales
contexte données champ d'application Données
champ d'application Test2:
définition f.enfants_à_charge égal à [données.enfant1]
définition f.ressources_ménage égal à 30 000 €
définition f.date_courante égal à |01/05/2020|
définition f.résidence égal à Guyane
assertion f.montant_versé = 39,63€
déclaration champ d'application Test3:
contexte f champ d'application AllocationsFamiliales
contexte données champ d'application Données
champ d'application Test3:
définition f.enfants_à_charge égal à [données.enfant1; données.enfant3]
définition f.ressources_ménage égal à 67 250 €
définition f.date_courante égal à |01/05/2020|
définition f.résidence égal à Métropole
assertion f.montant_versé = 388,29€
*/

59
examples/allocations_familiales/tests/tests_ouverture_droits.catala_fr Normal file
View File

@ -0,0 +1,59 @@
@@Inclusion: ../allocations_familiales.catala_fr@@
@Tests@
/*
déclaration champ d'application Données:
contexte enfant1 contenu Enfant
contexte enfant2 contenu Enfant
contexte enfant3 contenu Enfant
contexte enfant4 contenu Enfant
champ d'application Données:
définition enfant1 égal à Enfant {
-- fin_obligation_scolaire : |01/08/2023|
-- date_de_naissance: |01/01/2007|
-- âge: 13
-- rémuneration_mensuelle: 0€
-- pris_en_charge_par_services_sociaux: NonPriseEnChargeFamille
-- garde_alternée: NonGardeUnique
}
définition enfant2 égal à Enfant {
-- fin_obligation_scolaire : |01/08/2019|
-- date_de_naissance: |01/01/2003|
-- âge: 18
-- rémuneration_mensuelle: 1000€
-- pris_en_charge_par_services_sociaux: NonPriseEnChargeFamille
-- garde_alternée: NonGardeUnique
}
définition enfant3 égal à Enfant {
-- fin_obligation_scolaire : |01/08/2019|
-- date_de_naissance: |01/01/2003|
-- âge: 18
-- rémuneration_mensuelle: 400€
-- pris_en_charge_par_services_sociaux: NonPriseEnChargeFamille
-- garde_alternée: NonGardeUnique
}
définition enfant4 égal à Enfant {
-- fin_obligation_scolaire : |01/08/2016|
-- date_de_naissance: |01/01/1999|
-- âge: 21
-- rémuneration_mensuelle: 0€
-- pris_en_charge_par_services_sociaux: NonPriseEnChargeFamille
-- garde_alternée: NonGardeUnique
}
déclaration champ d'application Test1:
contexte données champ d'application Données
contexte f champ d'application PrestationsFamiliales
champ d'application Test1:
définition f.âge_l512_3_2_alternatif égal à Absent
définition f.date_courante égal à |01/05/2020|
définition f.prestation_courante égal à AllocationsFamiliales
définition f.résidence égal à Métropole
assertion (f.droit_ouvert de données.enfant1)
assertion (non (f.droit_ouvert de données.enfant2))
assertion (f.droit_ouvert de données.enfant3)
assertion (non (f.droit_ouvert de données.enfant4))
*/

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

33
examples/code_general_impots/Section_I_Dispositions_generales.catala_fr
View File

@ -7,15 +7,20 @@
@@0I : Définition du revenu net global@@++++++
@Article 1 A@
Il est établi un impôt annuel unique sur le revenu des personnes physiques désigné sous le nom d'impôt sur le revenu. Cet impôt frappe le revenu net global du contribuable déterminé conformément aux dispositions des articles 156 à 168.
Il est établi un impôt annuel unique sur le revenu des personnes physiques
désigné sous le nom d'impôt sur le revenu. Cet impôt frappe le revenu net
global du contribuable déterminé conformément aux dispositions des
articles 156 à 168.
Ce revenu net global est constitué par le total des revenus nets des catégories suivantes :
Ce revenu net global est constitué par le total des revenus nets des
catégories suivantes :
– Revenus fonciers ;
– Bénéfices industriels et commerciaux ;
– Rémunérations, d'une part, des gérants majoritaires des sociétés à responsabilité limitée n'ayant pas opté pour le régime fiscal des sociétés de personnes dans les conditions prévues au IV de l'article 3 du décret n° 55-594 du 20 mai 1955 modifié et des gérants des sociétés en commandite par actions et, d'autre part, des associés en nom des sociétés de personnes et des membres des sociétés en participation lorsque ces sociétés ont opté pour le régime fiscal des sociétés de capitaux ;
– Rémunérations, d'une part, des gérants majoritaires des sociétés à
responsabilité limitée n'ayant pas opté pour le régime fiscal des sociétés de personnes dans les conditions prévues au IV de l'article 3 du décret n° 55-594 du 20 mai 1955 modifié et des gérants des sociétés en commandite par actions et, d'autre part, des associés en nom des sociétés de personnes et des membres des sociétés en participation lorsque ces sociétés ont opté pour le régime fiscal des sociétés de capitaux ;
– Bénéfices de l'exploitation agricole ;
@ -25,19 +30,21 @@ Ce revenu net global est constitué par le total des revenus nets des catégorie
– Revenus de capitaux mobiliers ;
– Plus-values de cession à titre onéreux de biens ou de droits de toute nature, déterminés conformément aux dispositions des articles 14 à 155, total dont sont retranchées les charges énumérées à l'article 156.
– Plus-values de cession à titre onéreux de biens ou de droits de toute
nature, déterminés conformément aux dispositions des articles 14 à 155,
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

177
examples/tutorial/tutorial_en.catala_en
View File

@ -1,177 +0,0 @@
@@The Catala language tutorial@@
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.
@@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.
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.
@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
*/
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.
@@Defining a fictional income tax@@+
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 "metadata" section that defines the shape and types of the data used 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
declaration structure Article1:
data fixed_percentage content decimal
data income_tax content amount
*/
@@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 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, but you should aim to optimize code readability.
Sometimes, the law gives an enumeration of different situations. These enumerations are modeled in Catala using an enumeration type, like:
@@Begin metadata@@
/*
declaration enumeration TaxCredit:
-- NoTaxCredit
-- ChildrenTaxCredit content integer # the integer corresponds
# to the number of children
*/
@@End metadata@@
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:
@@Begin metadata@@
/*
declaration scope IncomeTaxComputation:
context individual content Individual
context article1 content Article1
*/
@@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.
@Article 1@
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
*/
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 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 %
*/
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@@
So far so good, but now the legislative text introduces some trickyness. Let us 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?
*/
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:
/*
scope IncomeTaxComputation:
definition article1.fixed_percentage under condition
individual.number_of_children >= 2
consequence equals 15 %
*/
When the Catala program will execute, the right definition will be dynamically chosen by looking at which condition is true. A correctly drafted legislative source should always ensure that at most one condition is true at all times. 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@@
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 computation:
@@Begin metadata@@
/*
declaration structure TwoBrackets:
data breakpoint content amount
data rate1 content decimal
data rate2 content decimal
declaration scope TwoBracketsTaxComputation :
context brackets content TwoBrackets
context tax_formula content amount depends on amount
*/
@@End metadata@@
And in the code:
@Article4@ The tax amount for a two-brackets computation is equal to the amount 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
else (
breakpoint * rate1 + (income - breakpoint) * rate2
)
*/
@@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.
/*
declaration scope IncomeTaxComputation:
# The scope inclusion has to be added in the scope declaration
context two_brackets_for_rich scope TwoBracketsTaxComputation
scope IncomeTaxComputation :
definition article1.income_tax under condition
individual.income >= $100,000
consequence equals
two_brackets_for_rich.tax 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
*/
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.

0
examples/tutorial/.gitignore → examples/tutorial_en/.gitignore vendored
View File

2
examples/tutorial/Makefile → examples/tutorial_en/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_en/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
*/

384
examples/tutorial_en/tutorial_en.catala_en Normal file
View File

@ -0,0 +1,384 @@
@@The Catala language tutorial@@
Welcome to this tutorial, whose objective is to guide you through the features
of the Catala language and teach you how to annotate a legislative text using
the language. This document is addressed primarily to developers or people that
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. 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. 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.
/*
# 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.
*/
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 literate 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
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
"metadata" section that defines the shape and types of the data used
inside the law.
Let's start our metadata section by declaring the type information for the
individual:
@@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@@
This structure contains two data fields, "income" and "number_of_children". 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). 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
enumerations are modeled in Catala using an enumeration type, like:
@@Begin metadata@@
/*
declaration enumeration TaxCredit:
# The name "TaxCredit" is also written in CamlCase
-- NoTaxCredit
# 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 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
# This line declares a context element of the scope, which is akin 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@@
We now have everything to annotate the contents of article 1, which is copied
over below.
@Article 1@
The income tax for an individual is defined as a fixed percentage of the
individual's income over a year.
/*
scope IncomeTaxComputation:
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: 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 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@@+
So far so good, but now the legislative text introduces some trickyness. Let us
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 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:
/*
scope IncomeTaxComputation:
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
chosen by looking at which condition is true. A correctly drafted legislative
source should always ensure that at most one condition is true at all times.
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@@+
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
computation:
@@Begin metadata@@
/*
declaration structure TwoBrackets:
data breakpoint content money
data rate1 content decimal
data rate2 content decimal
declaration scope TwoBracketsTaxComputation :
context brackets content TwoBrackets
context tax_formula content money depends on money
*/
@@End metadata@@
And in the code:
@Article4@ The tax amount for a two-brackets computation is equal to the amount
of income in each bracket multiplied by the rate of each bracket.
/*
scope TwoBracketsTaxComputation :
definition tax_formula of income equals
if income <=$ brackets.breakpoint then
income *$ brackets.rate1
else (
brackets.breakpoint *$ brackets.rate1 +$
(income -$ brackets.breakpoint) *$ brackets.rate2
)
*/
@@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 40% of the income above $100,000. Below $100,000, the
income tax is 20% of the income.
/*
declaration scope NewIncomeTaxComputation:
context two_brackets scope TwoBracketsTaxComputation
# This line says that we add the item two_brackets 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 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
*/
@Article 6@
Individuals earning less than $10,000 are exempted of the income tax mentionned
at article 1.
/*
scope NewIncomeTaxComputation:
definition income_tax under condition
individual.income <=$ $10,000
consequence equals $0
*/
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 presents the basic concepts and syntax of the Catala language
features. It is then up to you 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.

13
examples/tutoriel_fr/.gitignore vendored Normal file
View File

@ -0,0 +1,13 @@
*.aux
*.dvi
*.fdb_latexmk
*.fls
*.log
*.out
*.fls
*.tex
*.pdf
_minted*
*.toc
*.pyg
*.d

4
examples/tutoriel_fr/Makefile Normal file
View File

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

29
examples/tutoriel_fr/tests/test_tutoriel.catala_fr Normal file
View File

@ -0,0 +1,29 @@
@@Inclusion: ../tutoriel_fr.catala_fr@@
@Test@
/*
déclaration champ d'application TestUnitaire1:
contexte calcul_impôt champ d'application NouveauCalculImpôtRevenu
champ d'application TestUnitaire1:
définition
calcul_impôt.personne
égal à
Personne {
-- revenu: 230 000€
-- nombre_enfants: 0
}
assertion calcul_impôt.impôt_revenu = 72 000€
déclaration champ d'application TestUnitaire2:
contexte calcul_impôt champ d'application NouveauCalculImpôtRevenuCorrect
champ d'application TestUnitaire2:
définition calcul_impôt.personne égal à Personne {
-- revenu: 4 000 €
-- nombre_enfants: 0
}
assertion calcul_impôt.impôt_revenu = 0,00 €
*/

407
examples/tutoriel_fr/tutoriel_fr.catala_fr Normal file
View File

@ -0,0 +1,407 @@
@@Tutoriel d'utilisation du langage Catala@@
Bienvenue dans ce tutoriel, son objectif est de vous accompagner dans les
fonctionnalités du langage Catala et de vous apprendre à annoter des textes
législatifs avec ce langage. Ce document s'adresse principalement à des développeurs
ou des personnes ayant déjà programmé, même si des juristes avec des appétences
en informatique devraient pouvoir s'en sortir.
@@Programmation littéraire@@+
Pour commencer à écrire un programme Catala, vous devez partir du texte
d'une source législative qui va justifier le code que vous écrirez.
Concrètement, cela signifie faire un copier-coller du texte de la loi dans
un fichier de source Catala et le formatter afin que Catala puisse le comprendre.
Les fichiers de source Catala ont l'extension ".catala_en" en version anglaise.
Si vous écriviez un programme Catala pour une loi française, vous devrez utiliser
l'extension ".catala_fr".
Vous pouvez écrire n'importe quel texte simple en Catala, cela sera affiché
sans modification dans une sortie PDF ou HTML. Vous pouvez découper votre texte
en de courtes lignes, cela apparaîtera comme un seul paragraphe dans la sortie.
Si vous voulez créer un nouveau paragraphe laisser une ligne vierge dans la source.
Catala vous permet de déclarer des entêtes de section ou de sous-section,
en les précédant et les suivant de deux arobases. Vous pouvez
diminuer l'importance du titre en augmentant le nombre de "+" après le titre de
l'entête.
L'unité de division fondamentale est l'article, encadré par un simple arobase.
Étudions un exemple ficitif qui définit un impôt sur le revenu.
@Article 1@
L'impôt sur le revenu d'un individu est calculé en tant qu'un pourcentage
fixe des revenus d'une personne pour une année.
/*
# Bienvenue dans le mode code de Catala.
# Ceci est un commentaire car la ligne débute par le caractère #.
# Nous allons bientôt apprendre ce que l'on doit écrire ici pour traduire
# le sens d'un article de loi en code Catala.
*/
Afin de faire cela, nous allons entremêler courts bouts de code et phrases
du texte législatif. Chaque bout de code devra être aussi court que possible
et aussi proche que possible de la phrase qui justifie le code. Ce style
s'appelle programmation littéraire, un paradigme de programmation inventé par le
célèbre informaticien Donald Knuth dans les années 70.
@@Définir un impôt sur le revenu fictif@@+
Le contenu de l'article 1 utilise beaucoup d'éléments du contexte implicite :
il existe une personne avec un revenu et en même temps un impôt sur le revenu,
qu'une personne doit acquitter chaque année. Même si ce contexte implicite n'est
pas inscrit en tant que tel dans la loi, nous devons l'expliciter pour le traduire
en code. Concrètement, nous avons besoin d'une section "métadonnées" qui définit
la forme et les types de données contenues dans la loi.
Commençons notre section métadonnées en déclarant l'information sur le type
personne :
@@Début métadonnées@@
/*
déclaration structure Personne:
# Le nom de la structure "Personne", doit commencer
# par une lettre majuscule: c'est la convention CamlCase.
donnée revenu contenu argent
# A cette ligne, revenu est le nom du champ de la structure et
# "argent" est le type de de données de ce champ.
# On peut utiliser d'autres types comme : entier, décimal,
# argent, date, durée ou tout autre structure ou énumération
# que vous aurez déclaré
donnée nombre_enfants contenu entier
# "revenu" and "nombre_enfants" commençent par une lettre minuscule,
# ils adhèrent à la convention snake_case
*/
@@Fin métadonnées@@
Cette structure contient deux champs de de données, "revenu" et "nombre_enfants".
Les structures sont utiles pour regrouper des données qui vont ensemble.
Typiquement, vous aurez une structure pour une entité concrète sur laquelle
s'applique la loi (comme une personne). C'est à vous de décider comment regrouper
les données mais vous devrez viser à optimiser la lisibilité du code.
Parfois, la loi donne une énumération de différentes situations. Ces énumérations
sont modélisés en Catala par le type énumération, comme suit :
@@Début métadonnées@@
/*
déclaration énumération CréditImpôt:
# Le nom "CréditImpôt" s'écrit aussi en CamlCase
-- AucunCréditImpôt
# Cette ligne indique que "CréditImpôt" peut être en situation
# "AucunCréditImpôt"
-- CréditImpôtEnfants contenu entier
# Cette ligne indique, de manière alternative, que "CréditImpôt" peut aussi
# être une situation "CréditImpôtEnfants". Cette situation porte un contenu
# de type entier qui correspond au nombre d'enfants concernés par le crédit
# d'impôt. Cela signifie que si vous êtes dans la situation
# "CréditImpôtEnfants", vous aurez aussi accès à ce nombre d'enfants.
*/
@@Fin métadonnées@@
En informatique, une telle énumération est appelée "type somme" ou simplement
énumération. La combinaison de structures et d'énumération permet au programmeur
Catala de déclarer toutes les formes possibles de données, car cette combinaison
est équivalente à la puissante notion de types de données algébriques.
Nous avons défini et typé les données que le programme va manipuler. Maintenant,
nous devons définir un contexte logique dans lequel ces données vont évoluer.
On effectue cela par la notion de "champs d'application" en Catala.
Les champs d'application sont proches des fonctions en termes de programmation
traditionnelle. Les champs d'application doivent avoir été déclarés
préalablement dans les métadonnées, de la manière suivante:
@@Début métadonnées@@
/*
déclaration champ d'application CalculImpôtRevenu:
# Les champs d'application utilisent le CamlCase
contexte personne contenu Personne
# Cette ligne déclare un élémént de contexte du champ d'application,
# cela ressemble à un paramètre de fonction en informatique. C'est la
# donnée sur laquelle le champ d'application va intervenir
contexte pourcentage_fixe contenu décimal
contexte impôt_revenu contenu argent
*/
@@Fin métadonnées@@
Nous avons maintenant tout ce dont nous avons besoin pour annoter le contenu
de l'article 1 qui a été copié ci-dessous.
@Article 1@
L'impôt sur le revenu pour une personne est défini comme un pourcentage fixe
des revenus de la personne pour une année.
/*
champ d'application CalculImpôtRevenu:
définition impôt_revenu égal à
personne.revenu *€ pourcentage_fixe
*/
Dans le code, nous définissons à l'intérieur de notre champ d'application
le montant d'impôt sur le revenu selon la formule décrit dans l'article.
Quand nous définissons des fomules, vous avez accès à tous les opérateurs
arithmétiques habituels : addition "+", soustraction "-", multiplication "*"
et division (barre oblique).
Toutefois, dans le code Catala, vous pouvez voir que nous utilisons "*€"
pour multiplier les revenus d'une personne par le pourcentage fixe. Le
suffixe € inique que nous effectuons une multiplication sur une somme d'argent.
En effet, en Catala, vous devez rester conscient de la donnée manipulée :
est-ce de l'argent ? est-ce un entier ? Utiliser simple "+" ou "*" est ambigu
en termes d'arrondis car l'argent est habituellement arrondi au centime.
Ainsi, afin d'être clair, nous suffixons ces opérations avec quelque chose
qui indique le type de donnée manipulé. Les suffixes sont "€" pour de l'argent,
"." pour les décimales, arobase (comme dans les adresses mail) pour les dates et
le symbole chapeau pour les durées. Si vous oubliez le suffixe, le vérificateur
de types de Catala va afficher une message d'erreur afin de vous aider à le placer
comme il le faut.
Mais dans l'article 1, une question reste sans réponse: quelle est la valeur
de la pourcentage fixe? Souvent, des valeurs précises sont définis ailleurs
dans les sources législatives. Ici, supposons que nous avons:
@Article 2@
Le pourcentage fixe mentionné à l'article 1 est égal à 20%.
/*
champ d'application CalculImpôtRevenu:
définition pourcentage_fixe égal à 20%
# Ecrire 20% est juste une abbréviation pour 0.20
*/
Vous pouvez voir ici que Catala permet des définitions réparties dans toute
l'annotation du texte législatif, afin que chaque définition soit le plus
proche possible de sa localisation dans le texte.
@@Définitions conditionnelles@@+
Jusqu'à là tout va bien mais maintenant le texte législatif présente quelques
difficultés. Supposons que le troisième article dispose :
@Article 3@ Si l'individu a à sa charge deux ou plus enfants alors
le pourcentage fixe mentionné à l'article 1 vaut 15 %.
/*
# Comment redéfinir pourcentage_fixe ?
*/
Cet article donne en réalité une autre définition pour le pourcentage fixe,
préalablement défini à l'article 2. Toutefois, si l'article 3 définit le pourcentage
de manière conditionnelle pour la personne ayant plus de deux enfants.
Catala permet de redéfinir précisément une variable sous une condition :
/*
champ d'application CalculImpôtRevenu:
définition pourcentage_fixe sous condition
personne.nombre_enfants >= 2
conséquence égal à 15%
# Ecrire 15% est juste une abbréviation pour 0.15
*/
Quand le programme Catala va s'exécuter, la juste définition sera choisie
dynamiquement en déterminant laquelle des condition est vraie dans le contexte.
Une source législative rédigée correctement doit toujours garantir qu'au maximum
une seule condition soit vraie à tout moment. Toutefois, si ce n'est pas le cas,
Catala vous permettra de définir un ordre des priorités sur les conditions,
qui doit être justifié par un raisonnement juridique.
@@Fonctions@@+
Catala vous permet de définir des fonctions partout dans vos données. Voici
à quoi cela ressemble dans la définition des métadonnées quand nous voulons
définir un calcul de l'impôt sur le revenu à deux tranches :
@@Début métadonnées@@
/*
déclaration structure DeuxTranches:
donnée seuil contenu argent
donnée taux1 contenu décimal
donnée taux2 contenu décimal
déclaration champ d'application CalculImpôtDeuxTranches :
contexte tranches contenu DeuxTranches
contexte formule_imposition contenu argent dépend de argent
*/
@@Fin métadonnées@@
Et dans le code :
@Article4@ Le montant d'impôt pour le calcul à deux tranches
est égal au montant d'impôt dans chaque tranche multiplié
par le taux de chaque branche.
/*
champ d'application CalculImpôtDeuxTranches :
définition formule_imposition de revenu égal à
si revenu <=€ tranches.seuil alors
revenu *€ tranches.taux1
sinon (
tranches.seuil *€ tranches.taux1 +€
(revenu -€ tranches.seuil) *€ tranches.taux2
)
*/
@@Inclusion de champ d'application@@+
Maintenant que nous avons défini notre champ d'application utilitaire pour
calculer un impôt à deux tranches, nous voulons l'utiliser dans notre champ
d'application principal de calcul de l'impôt.
@Article 5@ Pour les individus dont le revenu est supérieur à 100 000€,
l'impôt sur le revenu de l'article 1 est de 40% du revenu au-dessus de
100 000€. En dessous de 100 000€, l'impôt sur le revenu est de 20% du revenu.
/*
déclaration champ d'application NouveauCalculImpôtRevenu:
contexte deux_tranches champ d'application CalculImpôtDeuxTranches
# Cette ligne indique que nous ajoutons l'élément deux_tranches au contexte.
# Toutefois, les mots clé "champ d'application" indique que l'élément n'est
# pas une donnée mais plutôt un sous-champ d'application qui peut être
# utilisé pour calculer des choses.
contexte personne contenu Personne
contexte impôt_revenu contenu argent
champ d'application NouveauCalculImpôtRevenu :
définition deux_tranches.tranches égal à DeuxTranches {
-- seuil: 100 000€
-- taux1: 20%
-- taux2: 40%
}
définition impôt_revenu égal à
deux_tranches.formule_imposition de personne.revenu
*/
@Article 6@
Les personnes ayant moins de 10 000€ de revenus sont exemptés de l'impôt
sur le revenu prévu à l'article 1.
/*
champ d'application NouveauCalculImpôtRevenu:
définition impôt_revenu sous condition
personne.revenu <=€ 10 000€
conséquence égal à 0€
*/
Et voilà ! Nous avons défini un calcul d'impôt à deux tranches en annotant
tout simplement un texte législatif par des bouts de code Catala.
Cependant, les lecteurs attentifs auront vu quelque chose de curieux dans les
articles 5 et 6. Que se passe-t-il si le revenu d'une personne se situe entre
10 000€ et 100 000€ ?
La loi ne le précise pas; nos articles sont clairement mal rédigés.
Mais Catala vous aide à trouver ce genre d'erreur par de simples tests ou
même la vérification formelle. Commençons par les tests.
@@Tester les programmes Catala@@+
Tester les programmes Catala peut se faire directement en Catala. En effet,
écrire des cas de tests pour chaque champ d'application Catala que vous
définissez est une bonne pratique appelée "tests unitaires" dans la
communauté du génie logicielle. Les cas de test sont définis dans des
champ d'application :
@Tester NouveauCalculImpotRevenu@
/*
déclaration champ d'application Test1:
contexte calcul_impôt champ d'application NouveauCalculImpôtRevenu
champ d'application Test1:
définition
calcul_impôt.personne
# L'on définit le paramètre au sous-champ d'application
égal à
# Les quatre lignes ci-dessous définissent une structure entière
# en valorisant chacun des champs
Personne {
-- revenu: 230 000€
-- nombre_enfants: 0
}
# Ensuite, nous récupérons le montant d'impôt, calculé par
# sous-champ d'application et nous assertons qu'il vaut bien
# la valeur attendue :
# (230 000€ - 100 000€) * 40% + 100 000€ * 20% = 72 000€
assertion calcul_impôt.impôt_revenu = 72 000€
*/
Ce test devrait être bon. Maintenant étudions un test en échec :
/*
déclaration champ d'application Test2:
contexte calcul_impôt champ d'application NouveauCalculImpôtRevenu
champ d'application Test2:
définition calcul_impôt.personne égal à Personne {
-- revenu: 4 000€
-- nombre_enfants: 0
}
assertion calcul_impôt.impôt_revenu = 0€
*/
Ce cas de test devrait calculer un impôt sur le revenu de 0€,
en raison de l'article 6. Mais au lieu de cela, l'exécution produira
une erreur car il y a un conflit entre les règles.
@@Définir des exceptions à des règles@@+
En effet, la définition d'un impôt sur le revenu à l'article 6 entre en
conflit avec la définition de l'article 5. Mais en réalité, l'article 6
est une simple exception à l'article 5. Dans la loi, il est implicite que
si l'article 6 est applicable, alors son application est prioritaire
sur l'article 5.
@Régler correctement le calcul@
Cette priorité implicite doit être explicitement déclaré en Catala. Voici une
version correcte du champ d'application NouveauCalculImpotRevenu :
/*
déclaration champ d'application NouveauCalculImpôtRevenuCorrect:
contexte deux_tranches champ d'application CalculImpôtDeuxTranches
contexte personne contenu Personne
contexte impôt_revenu contenu argent
champ d'application NouveauCalculImpôtRevenuCorrect :
définition deux_tranches.tranches égal à DeuxTranches {
-- seuil: 100 000€
-- taux1: 20%
-- taux2: 40%
}
# Pour définir une exception à une règle, vous devez d'abord étiquetter
# la règle à laquelle vous voulez attacher l'exception. Vous pouvez mettre
# n'importe quel identifiant en snake_case pour l'étiquette.
étiquette article_5
définition impôt_revenu égal à
deux_tranches.formule_imposition de personne.revenu
# Puis, vous pouvez déclarez l'exception par référence à l'étiquette
exception article_5
définition impôt_revenu sous condition
personne.revenu <=€ 10 000€
conséquence égal à 0€
*/
Le test devrait désormais fonctionner :
/*
déclaration champ d'application Test3:
contexte calcul_impôt champ d'application NouveauCalculImpôtRevenuCorrect
champ d'application Test3:
définition calcul_impôt.personne égal à Personne {
-- revenu: 4 000€
-- nombre_enfants: 0
}
assertion calcul_impôt.impôt_revenu = 0€
*/
@@Conclusion@@+
Ce tutoriel présente les concepts de base et la syntaxe des fonctionnalités
du langage Catala. C'est à vous de les utiliser pour annoter du texte
législatif avec leur traduction algorithmique.
Il n'y pas une seule bonne façon d'écrire des programmes Catala car le style de
programmation doit être adapté au texte de loi annoté. Cependant, Catala est un
langage basé sur la programmation fonctionnelle, donc suivre les
patrons de conception habituels de la programmation fonctionnelle
devrait aider à obtenir du code concis et lisible.

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@@

108
examples/us_tax_code/section_1015.catala_en
View File

@ -13,28 +13,33 @@ 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 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@@
@(a) Gifts after December 31, 1920@
If the property was acquired by gift after December 31, 1920, the basis shall be the same as it would be in the hands of the donor or the last preceding owner by whom it was not acquired by gift, except that if such basis (adjusted for the period before the date of the gift as provided in section 1016) is greater than the fair market value of the property at the time of the gift, then for the purpose of determining loss the basis shall be such fair market value.
If the property was acquired by gift after December 31, 1920, the basis shall be
the same as it would be in the hands of the donor or the last preceding owner by
whom it was not acquired by gift, except that if such basis (adjusted for the
period before the date of the gift as provided in section 1016) is greater than
the fair market value of the property at the time of the gift, then for the
purpose of determining loss the basis shall be such fair market value.
/*
scope BasisOfGift:
definition basis_subsection_a equals
@ -44,12 +49,20 @@ scope BasisOfGift:
transferor.basis
definition basis under condition
acquisition.moment > |01/31/1920| and
acquisition.moment > |12/31/1920| and
acquisition.method = Gift
consequence equals basis_subsection_a
*/
If the facts necessary to determine the basis in the hands of the donor or the last preceding owner are unknown to the donee, the Secretary shall, if possible, obtain such facts from such donor or last preceding owner, or any other person cognizant thereof. If the Secretary finds it impossible to obtain such facts, the basis in the hands of such donor or last preceding owner shall be the fair market value of such property as found by the Secretary as of the date or approximate date at which, according to the best information that the Secretary is able to obtain, such property was acquired by such donor or last preceding owner.
If the facts necessary to determine the basis in the hands of the donor or the
last preceding owner are unknown to the donee, the Secretary shall, if
possible, obtain such facts from such donor or last preceding owner, or any
other person cognizant thereof. If the Secretary finds it impossible to obtain
such facts, the basis in the hands of such donor or last preceding owner shall
be the fair market value of such property as found by the Secretary as of the
date or approximate date at which, according to the best information that the
Secretary is able to obtain, such property was acquired by such donor or last
preceding owner.
/*
scope BasisOfGift under condition
acquisition.moment > |01/31/1920| and
@ -63,7 +76,12 @@ scope BasisOfGift under condition
@(b) Transfer in trust after December 31, 1920@
If the property was acquired after December 31, 1920, by a transfer in trust (other than by a transfer in trust by a gift, bequest, or devise), the basis shall be the same as it would be in the hands of the grantor increased in the amount of gain or decreased in the amount of loss recognized to the grantor on such transfer under the law applicable to the year in which the transfer was made.
If the property was acquired after December 31, 1920, by a transfer in trust
(other than by a transfer in trust by a gift, bequest, or devise), the basis
shall be the same as it would be in the hands of the grantor increased in the
amount of gain or decreased in the amount of loss recognized to the grantor on
such transfer under the law applicable to the year in which the transfer was
made.
/*
scope BasisOfGift under condition
acquisition.moment > |01/31/1920| and
@ -74,7 +92,9 @@ scope BasisOfGift under condition
*/
@(c) Gift or transfer in trust before January 1, 1921@
If the property was acquired by gift or transfer in trust on or before December 31, 1920, the basis shall be the fair market value of such property at the time of such acquisition.
If the property was acquired by gift or transfer in trust on or before December
31, 1920, the basis shall be the fair market value of such property at the time
of such acquisition.
/*
scope BasisOfGift under condition acquisition.moment <= |01/31/1920|:
definition basis equals
@ -84,7 +104,10 @@ scope BasisOfGift under condition acquisition.moment <= |01/31/1920|:
@@(d) Increased basis for gift tax paid@@+
@(1) In general@ If—
(A) the property is acquired by gift on or after September 2, 1958, the basis shall be the basis determined under subsection (a), increased (but not above the fair market value of the property at the time of the gift) by the amount of gift tax paid with respect to such gift, or
(A) the property is acquired by gift on or after September 2, 1958, the basis
shall be the basis determined under subsection (a), increased (but not above
the fair market value of the property at the time of the gift) by the amount
of gift tax paid with respect to such gift, or
/*
scope BasisOfGift under condition
acquisition.moment >= |09/02/1958| and
@ -98,7 +121,13 @@ scope BasisOfGift under condition
gift_tax_paid
)
*/
(B) the property was acquired by gift before September 2, 1958, and has not been sold, exchanged, or otherwise disposed of before such date, the basis of the property shall be increased on such date by the amount of gift tax paid with respect to such gift, but such increase shall not exceed an amount equal to the amount by which the fair market value of the property at the time of the gift exceeded the basis of the property in the hands of the donor at the time of the gift.
(B) the property was acquired by gift before September 2, 1958, and has not been
sold, exchanged, or otherwise disposed of before such date, the basis of the
property shall be increased on such date by the amount of gift tax paid with
respect to such gift, but such increase shall not exceed an amount equal to the
amount by which the fair market value of the property at the time of the gift
exceeded the basis of the property in the hands of the donor at the time of the
gift.
/*
scope BasisOfGift under condition
acquisition.moment < |09/02/1958| and
@ -118,26 +147,46 @@ scope BasisOfGift under condition
*/
@(2) Amount of tax paid with respect to gift@
For purposes of paragraph (1), the amount of gift tax paid with respect to any gift is an amount which bears the same ratio to the amount of gift tax paid under chapter 12 with respect to all gifts made by the donor for the calendar year (or preceding calendar period) in which such gift is made as the amount of such gift bears to the taxable gifts (as defined in section 2503(a) but computed without the deduction allowed by section 2521) made by the donor during such calendar year or period. For purposes of the preceding sentence, the amount of any gift shall be the amount included with respect to such gift in determining (for the purposes of section 2503(a)) the total amount of gifts made during the calendar year or period, reduced by the amount of any deduction allowed with respect to such gift under section 2522 (relating to charitable deduction) or under section 2523 (relating to marital deduction).
For purposes of paragraph (1), the amount of gift tax paid with respect to any
gift is an amount which bears the same ratio to the amount of gift tax paid under
chapter 12 with respect to all gifts made by the donor for the calendar year
(or preceding calendar period) in which such gift is made as the amount of such
gift bears to the taxable gifts (as defined in section 2503(a) but computed
without the deduction allowed by section 2521) made by the donor during such
calendar year or period. For purposes of the preceding sentence, the amount of
any gift shall be the amount included with respect to such gift in determining
(for the purposes of section 2503(a)) the total amount of gifts made during the
calendar year or period, reduced by the amount of any deduction allowed with
respect to such gift under section 2522 (relating to charitable deduction) or
under section 2523 (relating to marital deduction).
/*
# We don't formalize the amount of gift tax since it would require formalizing other sections of the code
# We don't formalize the amount of gift tax since it would require
#formalizing other sections of the code
*/
@(3) Gifts treated as made one-half by each spouse@
For purposes of paragraph (1), where the donor and his spouse elected, under section 2513 to have the gift considered as made one-half by each, the amount of gift tax paid with respect to such gift under chapter 12 shall be the sum of the amounts of tax paid with respect to each half of such gift (computed in the manner provided in paragraph (2)).
For purposes of paragraph (1), where the donor and his spouse elected, under
section 2513 to have the gift considered as made one-half by each, the amount
of gift tax paid with respect to such gift under chapter 12 shall be the sum
of the amounts of tax paid with respect to each half of such gift (computed in
the manner provided in paragraph (2)).
/*
# Same here
*/
@(4) Treatment as adjustment to basis@
For purposes of section 1016(b), an increase in basis under paragraph (1) shall be treated as an adjustment under section 1016(a).
For purposes of section 1016(b), an increase in basis under paragraph (1) shall
be treated as an adjustment under section 1016(a).
/*
# Same here
*/
@(5) Application to gifts before 1955@
With respect to any property acquired by gift before 1955, references in this subsection to any provision of this title shall be deemed to refer to the corresponding provision of the Internal Revenue Code of 1939 or prior revenue laws which was effective for the year in which such gift was made.
With respect to any property acquired by gift before 1955, references in this
subsection to any provision of this title shall be deemed to refer to the
corresponding provision of the Internal Revenue Code of 1939 or prior revenue
laws which was effective for the year in which such gift was made.
/*
# Same here
*/
@ -145,8 +194,13 @@ With respect to any property acquired by gift before 1955, references in this su
@@(6) Special rule for gifts made after December 31, 1976@@++
@(A) In general@
In the case of any gift made after December 31, 1976, the increase in basis provided by this subsection with respect to any gift for the gift tax paid under chapter 12 shall be an amount (not in excess of the amount of tax so paid) which bears the same ratio to the amount of tax so paid as—
In the case of any gift made after December 31, 1976, the increase in basis
provided by this subsection with respect to any gift for the gift tax paid under
chapter 12 shall be an amount (not in excess of the amount of tax so paid) which
bears the same ratio to the amount of tax so paid as—
(i) the net appreciation in value of the gift, bears to
(ii) the amount of the gift.
/*
scope BasisOfGift under condition
@ -161,7 +215,9 @@ scope BasisOfGift under condition
*/
@(B) Net appreciation@
For purposes of paragraph (1), the net appreciation in value of any gift is the amount by which the fair market value of the gift exceeds the donor’s adjusted basis immediately before the gift.
For purposes of paragraph (1), the net appreciation in value of any gift is the
amount by which the fair market value of the gift exceeds the donor’s adjusted
basis immediately before the gift.
/*
scope BasisOfGift:
definition value.net_appreciation equals
@ -169,7 +225,9 @@ scope BasisOfGift:
*/
@(e) Gifts between spouses@
In the case of any property acquired by gift in a transfer described in section 1041(a), the basis of such property in the hands of the transferee shall be determined under section 1041(b)(2) and not this section.
In the case of any property acquired by gift in a transfer described in section
1041(a), the basis of such property in the hands of the transferee shall be
determined under section 1041(b)(2) and not this section.
/*
# Same here
*/

62
examples/us_tax_code/section_121.catala_en
View File

@ -24,7 +24,10 @@ declaration scope Section121:
@(a) Exclusion@
Gross income shall not include gain from the sale or exchange of property if, during the 5-year period ending on the date of the sale or exchange, such property has been owned and used by the taxpayer as the taxpayer’s principal residence for periods aggregating 2 years or more.
Gross income shall not include gain from the sale or exchange of property if,
during the 5-year period ending on the date of the sale or exchange, such
property has been owned and used by the taxpayer as the taxpayer’s principal
residence for periods aggregating 2 years or more.
/*
# Regulation 1.121-1(c)(1): 2 years = 730 days
# Regulation 1.121-1(c)(1): the periods of ownage and usage
@ -61,7 +64,8 @@ scope Section121:
@(1) In general@
The amount of gain excluded from gross income under subsection (a) with respect to any sale or exchange shall not exceed $250,000.
The amount of gain excluded from gross income under subsection (a) with
respect to any sale or exchange shall not exceed $250,000.
/*
scope Section121:
definition gain_cap equals $250,000
@ -79,7 +83,8 @@ scope Section121:
@(2) Special rules for joint returns@
In the case of a husband and wife who make a joint return for the taxable year of the sale or exchange of the property—
In the case of a husband and wife who make a joint return for the taxable year
of the sale or exchange of the property—
/*
# What if the current taxable year is not the taxable
@ -115,26 +120,41 @@ scope Section1 under condition
*/
@(B) Other joint returns@
If such spouses do not meet the requirements of subparagraph (A), the limitation under paragraph (1) shall be the sum of the limitations under paragraph (1) to which each spouse would be entitled if such spouses had not been married. For purposes of the preceding sentence, each spouse shall be treated as owning the property during the period that either spouse owned the property.
If such spouses do not meet the requirements of subparagraph (A), the limitation
under paragraph (1) shall be the sum of the limitations under paragraph (1) to
which each spouse would be entitled if such spouses had not been married. For
purposes of the preceding sentence, each spouse shall be treated as owning the
property during the period that either spouse owned the property.
@@(3) Application to only 1 sale or exchange every 2 years@@++
Subsection (a) shall not apply to any sale or exchange by the taxpayer if, during the 2-year period ending on the date of such sale or exchange, there was any other sale or exchange by the taxpayer to which subsection (a) applied.
Subsection (a) shall not apply to any sale or exchange by the taxpayer if,
during the 2-year period ending on the date of such sale or exchange, there
was any other sale or exchange by the taxpayer to which subsection (a) applied.
@@(4) Special rule for certain sales by surviving spouses@@++
In the case of a sale or exchange of property by an unmarried individual whose spouse is deceased on the date of such sale, paragraph (1) shall be applied by substituting “$500,000” for “$250,000” if such sale occurs not later than 2 years after the date of death of such spouse and the requirements of paragraph (2)(A) were met immediately before such date of death.
In the case of a sale or exchange of property by an unmarried individual whose
spouse is deceased on the date of such sale, paragraph (1) shall be applied by
substituting “$500,000” for “$250,000” if such sale occurs not later than 2
years after the date of death of such spouse and the requirements of paragraph
(2)(A) were met immediately before such date of death.
@@(5) Exclusion of gain allocated to nonqualified use@@++
@(A) In general@
Subsection (a) shall not apply to so much of the gain from the sale or exchange of property as is allocated to periods of nonqualified use.
Subsection (a) shall not apply to so much of the gain from the sale or exchange
of property as is allocated to periods of nonqualified use.
@(B) Gain allocated to periods of nonqualified use@
For purposes of subparagraph (A), gain shall be allocated to periods of nonqualified use based on the ratio which—
(i) the aggregate periods of nonqualified use during the period such property was owned by the taxpayer, bears to
For purposes of subparagraph (A), gain shall be allocated to periods of
nonqualified use based on the ratio which—
(i) the aggregate periods of nonqualified use during the period such property
was owned by the taxpayer, bears to
(ii) the period such property was owned by the taxpayer.
@@(C) Period of nonqualified use@@+++
@ -143,21 +163,33 @@ For purposes of this paragraph—
@(i) In general@
The term “period of nonqualified use” means any period (other than the portion of any period preceding January 1, 2009) during which the property is not used as the principal residence of the taxpayer or the taxpayer’s spouse or former spouse.
The term “period of nonqualified use” means any period (other than the portion
of any period preceding January 1, 2009) during which the property is not used
as the principal residence of the taxpayer or the taxpayer’s spouse or former
spouse.
@(ii) Exceptions@
The term “period of nonqualified use” does not include—
(I) any portion of the 5-year period described in subsection (a) which is after the last date that such property is used as the principal residence of the taxpayer or the taxpayer’s spouse,
(I) any portion of the 5-year period described in subsection (a) which is after
the last date that such property is used as the principal residence of the
taxpayer or the taxpayer’s spouse,
(II) any period (not to exceed an aggregate period of 10 years) during which the taxpayer or the taxpayer’s spouse is serving on qualified official extended duty (as defined in subsection (d)(9)(C)) described in clause (i), (ii), or (iii) of subsection (d)(9)(A), and
(II) any period (not to exceed an aggregate period of 10 years) during which the
taxpayer or the taxpayer’s spouse is serving on qualified official extended duty
(as defined in subsection (d)(9)(C)) described in clause (i), (ii), or (iii) of
subsection (d)(9)(A), and
(III) any other period of temporary absence (not to exceed an aggregate period of 2 years) due to change of employment, health conditions, or such other unforeseen circumstances as may be specified by the Secretary.
(III) any other period of temporary absence (not to exceed an aggregate period
of 2 years) due to change of employment, health conditions, or such other
unforeseen circumstances as may be specified by the Secretary.
@(D) Coordination with recognition of gain attributable to depreciation@
For purposes of this paragraph—
(i) subparagraph (A) shall be applied after the application of subsection (d)(6), and
(i) subparagraph (A) shall be applied after the application of subsection
(d)(6), and
(ii) subparagraph (B) shall be applied without regard to any gain to which subsection (d)(6) applies.
(ii) subparagraph (B) shall be applied without regard to any gain to which
subsection (d)(6) applies.

87
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@@
@ -23,46 +33,61 @@ declaration scope QualifiedEmployeeDiscount:
For purposes of this section—
@(1) Qualified employee discount@
The term “qualified employee discount” means any employee discount with respect to qualified property or services to the extent such discount does not exceed—
(A) in the case of property, the gross profit percentage of the price at which the property is being offered by the employer to customers, or
The term “qualified employee discount” means any employee discount with respect
to qualified property or services to the extent such discount does not exceed—
(A) in the case of property, the gross profit percentage of the price at which
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 being offered by the employer to customers.
(B) in the case of services, 20 percent of the price at which the services are
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@@++
@(A) In general@
The term “gross profit percentage” means the percent which—
(i) the excess of the aggregate sales price of property sold by the employer to customers over the aggregate cost of such property to the employer, is of
(i) the excess of the aggregate sales price of property sold by the employer
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—
(i) all property offered to customers in the ordinary course of the line of business of the employer in which the employee is performing services (or a reasonable classification of property selected by the employer), and
(i) all property offered to customers in the ordinary course of the line of
business of the employer in which the employee is performing services (or a
reasonable classification of property selected by the employer), and
(ii) the employer’s experience during a representative period.
/*
# (i) and (ii) are subjective criteria for determining the gross profit
@ -70,17 +95,25 @@ Gross profit percentage shall be determined on the basis of—
*/
@(3) Employee discount defined@
The term “employee discount” means the amount by which—
(A) the price at which the property or services are provided by the employer to an employee for use by such employee, is less than
(B) the price at which such property or services are being offered by the employer to customers.
(A) the price at which the property or services are provided by the employer to
an employee for use by such employee, is less than
(B) the price at which such property or services are being offered by the
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 property and other than personal property of a kind held for investment) or services which are offered for sale to customers in the ordinary course of the line of business of the employer in which the employee is performing services.
The term “qualified property or services” means any property (other than real
property and other than personal property of a kind held for investment) or
services which are offered for sale to customers in the ordinary course of
the line of business of the employer in which the employee is performing
services.
/*
# Again, this is for subjectively determining what item qualifies for a
# discount, not formalizing

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
*/

11
generate_website_assets.sh
View File

@ -7,12 +7,15 @@ if [[ $1 == "" ]]; then
exit 1
fi
make website-assets
rsync -a _build/default/_doc/_html/ $1/ocaml_docs/
scp examples/allocations_familiales/allocations_familiales.html $1/
scp examples/us_tax_code/us_tax_code.html $1/
scp examples/tutorial/tutorial_en.html $1/
scp examples/tutorial_en/tutorial_en.html $1/
scp examples/tutoriel_fr/tutoriel_fr.html $1/
scp grammar.html $1/
scp catala.html $1/
scp legifrance_catala.html $1/
scp _build/default/src/catala_web/catala_web.bc.js $1/playground/
scp examples/tutorial_en/tutorial_en.catala_en $1/playground/
scp examples/tutoriel_fr/tutoriel_fr.catala_fr $1/playground/
scp syntax_highlighting/en/ace/mode-catala_en.js $1/playground/
scp syntax_highlighting/fr/ace/mode-catala_fr.js $1/playground/

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)

75
src/catala/catala_surface/catala_ast.ml → src/catala/catala_surface/ast.ml
View File

@ -12,18 +12,29 @@
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
| Collection of base_typ_data Pos.marked
| Optional of base_typ_data Pos.marked
type base_typ_data = Primitive of primitive_typ | Collection of base_typ_data Pos.marked
type base_typ = Condition | Data of base_typ_data
@ -53,13 +64,35 @@ 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 builtin_expression = Cardinal | Now
type unop = Not | Minus of op_kind
type aggregate_func = AggregateSum | AggregateCount
type builtin_expression = Cardinal | IntToDec
type aggregate_func =
| AggregateSum of primitive_typ
| AggregateCount
| AggregateExtremum of bool (* true if max *) * primitive_typ
type literal_date = {
literal_date_day : int Pos.marked;
@ -67,13 +100,13 @@ type literal_date = {
literal_date_year : int Pos.marked;
}
type literal_number = Int of int | Dec of int * int
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 : int; money_amount_cents : int }
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
@ -88,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
@ -107,12 +135,15 @@ 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
| ArrayLit of 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;
@ -120,6 +151,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;
@ -189,14 +222,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

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

@ -12,223 +12,745 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Catala_ast
open Lambda_ast
(** Translation from {!module: Surface.Ast} to {!module: Desugaring.Ast}.
(** The optional argument subdef allows to choose between differents uids in case the expression is
a redefinition of a subvariable *)
let rec expr_to_lambda (scope : Uid.Scope.t) (def_key : Uid.ScopeDef.t option)
(ctxt : Name_resolution.context) ((expr, pos) : Catala_ast.expression Pos.marked) :
Lambda_ast.term =
let scope_ctxt = Uid.ScopeMap.find scope ctxt.scopes in
let rec_helper = expr_to_lambda scope def_key ctxt in
- Removes syntactic sugars
- Separate code from legislation *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
(** {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 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 l -> Minus (translate_op_kind l)
(** 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 ctxt in
match expr with
| IfThenElse (e_if, e_then, e_else) ->
((EIfThenElse (rec_helper e_if, rec_helper e_then, rec_helper e_else), pos), TDummy)
Bindlib.box_apply3
(fun e_if e_then e_else -> (Scopelang.Ast.EIfThenElse (e_if, e_then, e_else), pos))
(rec_helper e_if) (rec_helper e_then) (rec_helper e_else)
| Binop (op, e1, e2) ->
let op_term = (Pos.same_pos_as (EOp (Binop (Pos.unmark op))) op, TDummy) in
((EApp (op_term, [ rec_helper e1; rec_helper e2 ]), pos), TDummy)
let op_term =
Pos.same_pos_as (Scopelang.Ast.EOp (Dcalc.Ast.Binop (translate_binop (Pos.unmark op)))) op
in
Bindlib.box_apply2
(fun e1 e2 -> (Scopelang.Ast.EApp (op_term, [ e1; e2 ]), pos))
(rec_helper e1) (rec_helper e2)
| Unop (op, e) ->
let op_term = (Pos.same_pos_as (EOp (Unop (Pos.unmark op))) op, TDummy) in
((EApp (op_term, [ rec_helper e ]), pos), TDummy)
let op_term =
Pos.same_pos_as (Scopelang.Ast.EOp (Dcalc.Ast.Unop (translate_unop (Pos.unmark op)))) op
in
Bindlib.box_apply (fun e -> (Scopelang.Ast.EApp (op_term, [ e ]), pos)) (rec_helper e)
| Literal l ->
let untyped_term =
match l with
| Number ((Int i, _), _) -> EInt i
| Number ((Dec (i, f), _), _) -> EDec (i, f)
| Bool b -> EBool b
| _ -> Name_resolution.raise_unsupported_feature "literal" 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 =
try int_of_float (ceil (float_of_int (Z.log2 f) *. log 2.0 /. log 10.0))
with Invalid_argument _ -> 0
in
Scopelang.Ast.ELit
(Dcalc.Ast.LRat
Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f))))
| Number ((Dec (i, f), _), Some (Percent, _)) ->
let digits_f =
try int_of_float (ceil (float_of_int (Z.log2 f) *. log 2.0 /. log 10.0))
with Invalid_argument _ -> 0
in
Scopelang.Ast.ELit
(Dcalc.Ast.LRat
(Q.div
Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f)))
(Q.of_int 100)))
| Bool b -> Scopelang.Ast.ELit (Dcalc.Ast.LBool b)
| MoneyAmount i ->
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
((untyped_term, pos), TDummy)
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 = Uid.ScopeDefMap.find def_key scope_ctxt.definitions in
match Uid.IdentMap.find_opt x def_ctxt.var_idmap with
| None -> (
match Uid.IdentMap.find_opt x scope_ctxt.var_idmap with
| Some uid -> ((EVar (NoPrefix, uid), pos), TDummy)
| None ->
Name_resolution.raise_unknown_identifier "for a local or scope-wide variable"
(x, pos) )
| Some uid -> ((ELocalVar uid, pos), TDummy) )
match Desugared.Ast.IdentMap.find_opt x ctxt.local_var_idmap with
| None -> (
match Uid.IdentMap.find_opt x scope_ctxt.var_idmap with
| Some uid -> ((EVar (NoPrefix, uid), pos), TDummy)
| None -> Name_resolution.raise_unknown_identifier "for a scope-wide variable" (x, pos) )
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 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 ->
let subscope_uid : Uid.SubScope.t =
| 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
let subscope_real_uid : Uid.Scope.t =
Uid.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
let subscope_real_uid : Scopelang.Ast.ScopeName.t =
Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
in
let subscope_var_uid = Name_resolution.get_var_uid subscope_real_uid ctxt x in
((EVar (SubScopePrefix subscope_uid, subscope_var_uid), pos), TDummy)
Bindlib.box
( Scopelang.Ast.ELocation
(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 identifier" pos )
| FunCall (f, arg) -> ((EApp (rec_helper f, [ rec_helper arg ]), pos), TDummy)
| _ -> Name_resolution.raise_unsupported_feature "unsupported expression" 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)
| 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)
| ArrayLit es ->
Bindlib.box_apply
(fun es -> (Scopelang.Ast.EArray es, pos))
(Bindlib.box_list (List.map rec_helper es))
| CollectionOp (op', param', collection, predicate) ->
let ctxt, param = Name_resolution.add_def_local_var ctxt param' in
let collection = rec_helper collection in
let init =
match Pos.unmark op' with
| Ast.Exists ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool false), Pos.get_position op')
| Ast.Forall -> Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool true), Pos.get_position op')
| Ast.Aggregate (Ast.AggregateSum Ast.Integer) ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LInt Z.zero), Pos.get_position op')
| Ast.Aggregate (Ast.AggregateSum Ast.Decimal) ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LRat Q.zero), Pos.get_position op')
| Ast.Aggregate (Ast.AggregateSum Ast.Money) ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LMoney Z.zero), Pos.get_position op')
| Ast.Aggregate (Ast.AggregateExtremum _) ->
Errors.raise_spanned_error "Unsupported feature: minimum and maximum"
(Pos.get_position op')
| Ast.Aggregate (Ast.AggregateSum t) ->
Errors.raise_spanned_error
(Format.asprintf "It is impossible to sum two values of type %a together"
Print.format_primitive_typ t)
pos
| Ast.Aggregate Ast.AggregateCount ->
Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LInt Z.zero), Pos.get_position op')
in
let acc_var = Scopelang.Ast.Var.make ("acc", Pos.get_position param') in
let acc = Scopelang.Ast.make_var (acc_var, Pos.get_position param') in
let f_body =
let make_body (op : Dcalc.Ast.binop) =
Bindlib.box_apply2
(fun predicate acc ->
( Scopelang.Ast.EApp
( (Scopelang.Ast.EOp (Dcalc.Ast.Binop op), Pos.get_position op'),
[ acc; predicate ] ),
pos ))
(translate_expr scope ctxt predicate)
acc
in
match Pos.unmark op' with
| Ast.Exists -> make_body Dcalc.Ast.Or
| Ast.Forall -> make_body Dcalc.Ast.And
| Ast.Aggregate (Ast.AggregateSum Ast.Integer) -> make_body (Dcalc.Ast.Add Dcalc.Ast.KInt)
| Ast.Aggregate (Ast.AggregateSum Ast.Decimal) -> make_body (Dcalc.Ast.Add Dcalc.Ast.KRat)
| Ast.Aggregate (Ast.AggregateSum Ast.Money) -> make_body (Dcalc.Ast.Add Dcalc.Ast.KMoney)
| Ast.Aggregate (Ast.AggregateSum _) -> assert false (* should not happen *)
| Ast.Aggregate (Ast.AggregateExtremum _) ->
Errors.raise_spanned_error "Unsupported feature: minimum and maximum"
(Pos.get_position op')
| Ast.Aggregate Ast.AggregateCount ->
Bindlib.box_apply2
(fun predicate acc ->
( Scopelang.Ast.EIfThenElse
( predicate,
( Scopelang.Ast.EApp
( ( Scopelang.Ast.EOp (Dcalc.Ast.Binop (Dcalc.Ast.Add Dcalc.Ast.KInt)),
Pos.get_position op' ),
[
acc;
(Scopelang.Ast.ELit (Dcalc.Ast.LInt Z.one), Pos.get_position predicate);
] ),
pos ),
acc ),
pos ))
(translate_expr scope ctxt predicate)
acc
in
let f =
let make_f (t : Dcalc.Ast.typ_lit) =
Bindlib.box_apply
(fun binder ->
( Scopelang.Ast.EAbs
( pos,
binder,
[
(Scopelang.Ast.TLit t, Pos.get_position op');
(Scopelang.Ast.TAny, pos)
(* we put any here because the type of the elements of the arrays is not
always the type of the accumulator; for instance in AggregateCount. *);
] ),
pos ))
(Bindlib.bind_mvar [| acc_var; param |] f_body)
in
match Pos.unmark op' with
| Ast.Exists -> make_f Dcalc.Ast.TBool
| Ast.Forall -> make_f Dcalc.Ast.TBool
| Ast.Aggregate (Ast.AggregateSum Ast.Integer) -> make_f Dcalc.Ast.TInt
| Ast.Aggregate (Ast.AggregateSum Ast.Decimal) -> make_f Dcalc.Ast.TRat
| Ast.Aggregate (Ast.AggregateSum Ast.Money) -> make_f Dcalc.Ast.TMoney
| Ast.Aggregate (Ast.AggregateExtremum _) ->
Errors.raise_spanned_error "Unsupported feature: minimum and maximum"
(Pos.get_position op')
| Ast.Aggregate (Ast.AggregateSum _) -> assert false (* should not happen *)
| Ast.Aggregate Ast.AggregateCount -> make_f Dcalc.Ast.TInt
in
Bindlib.box_apply3
(fun f collection init ->
( Scopelang.Ast.EApp
((Scopelang.Ast.EOp (Dcalc.Ast.Ternop Dcalc.Ast.Fold), pos), [ f; init; collection ]),
pos ))
f collection init
| MemCollection (member, collection) ->
let param_var = Scopelang.Ast.Var.make ("collection_member", pos) in
let param = Scopelang.Ast.make_var (param_var, pos) in
let collection = rec_helper collection in
let init = Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool false), pos) in
let acc_var = Scopelang.Ast.Var.make ("acc", pos) in
let acc = Scopelang.Ast.make_var (acc_var, pos) in
let f_body =
Bindlib.box_apply3
(fun member acc param ->
( Scopelang.Ast.EApp
( (Scopelang.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.Or), pos),
[
( Scopelang.Ast.EApp
((Scopelang.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.Eq), pos), [ member; param ]),
pos );
acc;
] ),
pos ))
(translate_expr scope ctxt member)
acc param
in
let f =
Bindlib.box_apply
(fun binder ->
( Scopelang.Ast.EAbs
( pos,
binder,
[ (Scopelang.Ast.TLit Dcalc.Ast.TBool, pos); (Scopelang.Ast.TAny, pos) ] ),
pos ))
(Bindlib.bind_mvar [| acc_var; param_var |] f_body)
in
Bindlib.box_apply3
(fun f collection init ->
( Scopelang.Ast.EApp
((Scopelang.Ast.EOp (Dcalc.Ast.Ternop Dcalc.Ast.Fold), pos), [ f; init; collection ]),
pos ))
f collection init
| Builtin IntToDec -> Bindlib.box (Scopelang.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.IntToRat), pos)
| Builtin Cardinal -> Bindlib.box (Scopelang.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.Length), pos)
| _ ->
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} *)
let merge_conditions (precond : Lambda_ast.term option) (cond : Lambda_ast.term option)
(default_pos : Pos.t) : Lambda_ast.term =
(** 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 =
match (precond, cond) with
| Some precond, Some cond ->
let op_term = ((EOp (Binop And), Pos.get_position (fst precond)), TDummy) in
((EApp (op_term, [ precond; cond ]), Pos.get_position (fst precond)), TDummy)
let op_term =
(Scopelang.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.And), Pos.get_position (Bindlib.unbox precond))
in
Bindlib.box_apply2
(fun precond cond ->
(Scopelang.Ast.EApp (op_term, [ precond; cond ]), Pos.get_position precond))
precond cond
| Some cond, None | None, Some cond -> cond
| None, None -> ((EBool true, default_pos), TBool)
| None, None -> Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool true), default_pos)
let process_default (ctxt : Name_resolution.context) (scope : Uid.Scope.t)
(def_key : Uid.ScopeDef.t) (def : Lambda_ast.default_term) (param_uid : Uid.LocalVar.t option)
(precond : Lambda_ast.term option) (just : Catala_ast.expression Pos.marked option)
(body : Catala_ast.expression Pos.marked) : Lambda_ast.default_term =
let just =
match just with
| Some cond -> Some (expr_to_lambda scope (Some def_key) ctxt cond)
| None -> None
in
let condition = merge_conditions precond just (Pos.get_position body) in
let body = expr_to_lambda scope (Some def_key) ctxt body in
(* if there's a parameter, we have to wrap the justifiction and the body in a func *)
let condition, body =
match param_uid with
| None -> (condition, body)
| Some param_uid ->
( ((EFun ([ (param_uid, TDummy) ], condition), Pos.get_position (fst condition)), TDummy),
((EFun ([ (param_uid, TDummy) ], body), Pos.get_position (fst body)), TDummy) )
in
Lambda_ast.add_default condition body def
(** 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 Pos.marked)
(param_uid : Scopelang.Ast.Var.t Pos.marked option)
(precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
(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 (Pos.unmark def_key) in
match (Pos.unmark def_key_typ, param_uid) with
| 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))
| _, Some _ ->
Errors.raise_spanned_error
"This definition has a parameter but its type is not a function"
(Pos.get_position (Bindlib.unbox cons))
| _ -> None);
exception_to_rule;
}
(* Process a definition *)
let process_def (precond : Lambda_ast.term option) (scope_uid : Uid.Scope.t)
(ctxt : Name_resolution.context) (prgm : Scope_ast.program) (def : Catala_ast.definition) :
Scope_ast.program =
let scope : Scope_ast.scope = Uid.ScopeMap.find scope_uid prgm in
let scope_ctxt = Uid.ScopeMap.find scope_uid ctxt.scopes in
(** 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.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 param_uid (def_uid : Uid.ScopeDef.t) : Uid.LocalVar.t option =
match def.definition_parameter with
| None -> None
| Some param ->
let def_ctxt = Uid.ScopeDefMap.find def_uid scope_ctxt.definitions in
Some (Uid.IdentMap.find (Pos.unmark param) def_ctxt.var_idmap)
in
let def_key =
match Pos.unmark def.definition_name with
| [ x ] ->
let x_uid = Name_resolution.get_var_uid scope_uid ctxt x in
Uid.ScopeDef.Var x_uid
Desugared.Ast.ScopeDef.Var x_uid
| [ y; x ] ->
let subscope_uid : Uid.SubScope.t = Name_resolution.get_subscope_uid scope_uid ctxt y in
let subscope_real_uid : Uid.Scope.t =
Uid.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
let subscope_uid : Scopelang.Ast.SubScopeName.t =
Name_resolution.get_subscope_uid scope_uid ctxt y
in
let subscope_real_uid : Scopelang.Ast.ScopeName.t =
Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
in
let x_uid = Name_resolution.get_var_uid subscope_real_uid ctxt x in
Uid.ScopeDef.SubScopeVar (subscope_uid, x_uid)
Desugared.Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid)
| _ -> Errors.raise_spanned_error "Structs are not handled yet" default_pos
in
(* We add to the name resolution context the name of the parameter variable *)
let param_uid, new_ctxt =
match def.definition_parameter with
| None -> (None, ctxt)
| Some param ->
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 =
match Uid.ScopeDefMap.find_opt def_key scope.scope_defs with
let x_def, x_type, is_cond =
match Desugared.Ast.ScopeDefMap.find_opt def_key scope.scope_defs with
| Some def -> def
| None ->
let typ = Name_resolution.get_def_typ ctxt def_key in
Scope_ast.empty_def default_pos typ
( Desugared.Ast.RuleMap.empty,
Name_resolution.get_def_typ ctxt def_key,
Name_resolution.is_def_cond ctxt def_key )
in
let rule_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
( try Desugared.Ast.IdentMap.find (Pos.unmark label) scope_ctxt.label_idmap
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "Unknown label: \"%s\"" (Pos.unmark label))
(Pos.get_position label) )
in
let x_def =
Lambda_ast.map_untype
(fun t ->
match t with
| EDefault default ->
EDefault
(process_default ctxt scope_uid def_key default (param_uid def_key) precond
def.definition_condition def.definition_expr)
| _ -> assert false
(* should not happen *))
Desugared.Ast.RuleMap.add rule_name
(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
{ scope with scope_defs = Uid.ScopeDefMap.add def_key x_def scope.scope_defs }
{
scope with
scope_defs = Desugared.Ast.ScopeDefMap.add def_key (x_def, x_type, is_cond) scope.scope_defs;
}
in
Uid.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 *)
let process_rule (precond : Lambda_ast.term option) (scope : Uid.Scope.t)
(ctxt : Name_resolution.context) (prgm : Scope_ast.program) (rule : Catala_ast.rule) :
Scope_ast.program =
let consequence_expr = Catala_ast.Literal (Catala_ast.Bool (Pos.unmark rule.rule_consequence)) in
(** 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 =
{
definition_name = rule.rule_name;
definition_parameter = rule.rule_parameter;
definition_condition = rule.rule_condition;
definition_expr = (consequence_expr, Pos.get_position rule.rule_consequence);
Ast.definition_label = rule.rule_label;
Ast.definition_exception_to = rule.rule_exception_to;
Ast.definition_name = rule.rule_name;
Ast.definition_parameter = rule.rule_parameter;
Ast.definition_condition = rule.rule_condition;
Ast.definition_expr = (consequence_expr, Pos.get_position rule.rule_consequence);
}
in
process_def precond scope ctxt prgm def
let process_scope_use_item (cond : Lambda_ast.term option) (scope : Uid.Scope.t)
(ctxt : Name_resolution.context) (prgm : Scope_ast.program)
(item : Catala_ast.scope_use_item Pos.marked) : Scope_ast.program =
(** 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 ctxt) precond in
match Pos.unmark item with
| Catala_ast.Rule rule -> process_rule cond scope ctxt prgm rule
| Catala_ast.Definition def -> process_def cond scope ctxt prgm def
| 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
let process_scope_use (ctxt : Name_resolution.context) (prgm : Scope_ast.program)
(use : Catala_ast.scope_use) : Scope_ast.program =
(** {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 = Uid.IdentMap.find name ctxt.scope_idmap in
let scope_uid = Desugared.Ast.IdentMap.find name ctxt.scope_idmap in
(* Make sure the scope exists *)
let prgm =
match Uid.ScopeMap.find_opt scope_uid prgm with
match Scopelang.Ast.ScopeMap.find_opt scope_uid prgm.program_scopes with
| Some _ -> prgm
| None -> Uid.ScopeMap.add scope_uid (Scope_ast.empty_scope scope_uid) prgm
| None -> assert false
(* should not happen *)
in
let cond =
match use.scope_use_condition with
| Some expr ->
let untyped_term = expr_to_lambda scope_uid None ctxt expr in
Some untyped_term
| None -> None
in
List.fold_left (process_scope_use_item cond scope_uid ctxt) prgm use.scope_use_items
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 *)
let translate_program_to_scope (ctxt : Name_resolution.context) (prgm : Catala_ast.program) :
Scope_ast.program =
let empty_prgm = Uid.ScopeMap.empty in
let processer_article_item (prgm : Scope_ast.program) (item : Catala_ast.law_article_item) :
Scope_ast.program =
(** Main function of this module *)
let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desugared.Ast.program =
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 ->
let x, y = Scopelang.Ast.ScopeVarMap.find v ctxt.Name_resolution.var_typs in
Desugared.Ast.ScopeDefMap.add (Desugared.Ast.ScopeDef.Var v)
(Desugared.Ast.RuleMap.empty, x, y)
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
| CodeBlock (block, _) ->
List.fold_left
(fun prgm item ->
match Pos.unmark item with ScopeUse use -> process_scope_use ctxt prgm use | _ -> prgm)
match Pos.unmark item with
| Ast.ScopeUse use -> process_scope_use ctxt prgm use
| _ -> prgm)
prgm block
| _ -> prgm
in
let rec processer_structure (prgm : Scope_ast.program) (item : Catala_ast.law_structure) :
Scope_ast.program =
let rec processer_structure (prgm : Desugared.Ast.program) (item : Ast.law_structure) :
Desugared.Ast.program =
match item with
| LawHeading (_, children) ->
List.fold_left (fun prgm child -> processer_structure prgm child) prgm children
| LawArticle (_, children) ->
List.fold_left (fun prgm child -> processer_article_item prgm child) prgm children
| MetadataBlock (b, c) -> processer_article_item prgm (CodeBlock (b, c))
| IntermediateText _ -> prgm
| IntermediateText _ | LawInclude _ -> prgm
in
let processer_item (prgm : Scope_ast.program) (item : Catala_ast.program_item) : Scope_ast.program
=
let processer_item (prgm : Desugared.Ast.program) (item : Ast.program_item) :
Desugared.Ast.program =
match item with LawStructure s -> processer_structure prgm s
in

12
src/catala/catala_surface/dune
View File

@ -1,3 +1,15 @@
(library
(name surface)
(libraries utils menhirLib sedlex re desugared scopelang zarith
zarith_stubs_js odate)
(public_name catala.surface)
(preprocess
(pps sedlex.ppx)))
(menhir
(modules parser)
(flags --table))
(documentation
(package catala)
(mld_files surface))

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

@ -12,19 +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);
@ -36,47 +51,59 @@ let token_list_language_agnostic : (string * token) list =
("=", EQUAL);
("(", LPAREN);
(")", RPAREN);
("{", LBRACKET);
("}", RBRACKET);
("{", LSQUARE);
("}", RSQUARE);
("+", PLUS);
("-", MINUS);
("*", MULT);
("/", DIV);
("|", VERTICAL);
(":", COLON);
(";", SEMICOLON);
("--", 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);
("]", CONSEQUENCE);
("|]", CONSEQUENCE);
("data", DATA);
("fun of", DEPENDS);
("new", DECLARATION);
("param", CONTEXT);
("decreasing", DECREASING);
("increasing", INCREASING);
("int_to_dec", INT_TO_DEC);
("maximum", MAXIMUM);
("minimum", MAXIMUM);
("of", OF);
("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);
("[", UNDER_CONDITION);
("[|", UNDER_CONDITION);
("if", IF);
("then", THEN);
("else", ELSE);
("type", CONTENT);
("content", CONTENT);
("struct", STRUCT);
("option", OPTIONAL);
("assert", ASSERTION);
("varies", VARIES);
("with parameter", WITH_V);
@ -89,18 +116,22 @@ let token_list : (string * token) list =
("exists", EXISTS);
("such", SUCH);
("that", THAT);
("now", NOW);
("&&", AND);
("||", OR);
("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 *)
@ -147,7 +178,7 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "int" ->
update_acc lexbuf;
INTEGER
| "amount" ->
| "money" ->
update_acc lexbuf;
MONEY
| "text" ->
@ -159,6 +190,9 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "date" ->
update_acc lexbuf;
DATE
| "duration" ->
update_acc lexbuf;
DURATION
| "bool" ->
update_acc lexbuf;
BOOLEAN
@ -171,13 +205,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" ->
@ -186,7 +226,7 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "with" ->
update_acc lexbuf;
WITH
| "[" ->
| "[|" ->
update_acc lexbuf;
UNDER_CONDITION
| "if" ->
@ -201,15 +241,12 @@ 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" ->
update_acc lexbuf;
OPTIONAL
| "assert" ->
update_acc lexbuf;
ASSERTION
@ -244,9 +281,6 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "that" ->
update_acc lexbuf;
THAT
| "now" ->
update_acc lexbuf;
NOW
| "&&" ->
update_acc lexbuf;
AND
@ -256,9 +290,18 @@ let rec lex_code (lexbuf : lexbuf) : token =
| "not" ->
update_acc lexbuf;
NOT
| "]" ->
| "|]" ->
update_acc lexbuf;
CONSEQUENCE
| "int_to_dec" ->
update_acc lexbuf;
INT_TO_DEC
| "maximum" ->
update_acc lexbuf;
MAXIMUM
| "minimum" ->
update_acc lexbuf;
MINIMUM
| "number" ->
update_acc lexbuf;
CARDINAL
@ -271,6 +314,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
@ -280,8 +329,8 @@ let rec lex_code (lexbuf : lexbuf) : token =
(* Integer literal*)
let units = parts 1 in
let remove_commas = R.regexp "," in
let units = int_of_string (R.substitute ~rex:remove_commas ~subst:(fun _ -> "") units) in
let cents = try int_of_string (parts 4) with Not_found -> 0 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' ->
@ -289,13 +338,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 (int_of_string (dec_parts 1), int_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
@ -308,18 +438,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
@ -329,21 +447,51 @@ 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;
LSQUARE
| ']' ->
update_acc lexbuf;
RSQUARE
| '|' ->
update_acc lexbuf;
VERTICAL
| ':' ->
update_acc lexbuf;
COLON
| ';' ->
update_acc lexbuf;
SEMICOLON
| "--" ->
update_acc lexbuf;
ALT
| '.' ->
update_acc lexbuf;
DOT
| uppercase, Star (uppercase | lowercase | '0' .. '9' | '_' | '\'') ->
(* Name of constructor *)
update_acc lexbuf;
@ -355,12 +503,14 @@ let rec lex_code (lexbuf : lexbuf) : token =
| Plus '0' .. '9' ->
(* Integer literal*)
update_acc lexbuf;
INT_LITERAL (int_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
let rec lex_law (lexbuf : lexbuf) : token =
(** 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
| '\n' -> lex_law lexbuf
| "/*" ->
is_code := true;
code_string_acc := "";
@ -384,8 +534,8 @@ let rec lex_law (lexbuf : lexbuf) : token =
let name = get_component 1 in
let pages = try Some (int_of_string (get_component 3)) with Not_found -> None in
let pos = lexing_positions lexbuf in
if Filename.extension name = ".pdf" then LAW_INCLUDE (Catala_ast.PdfFile ((name, pos), pages))
else LAW_INCLUDE (Catala_ast.CatalaFile (name, pos))
if Filename.extension name = ".pdf" then LAW_INCLUDE (Ast.PdfFile ((name, pos), pages))
else LAW_INCLUDE (Ast.CatalaFile (name, pos))
| "@@", Plus (Compl '@'), "@@", Star '+' ->
let extract_code_title = R.regexp "@@([^@]+)@@([\\+]*)" in
let get_match = R.get_substring (R.exec ~rex:extract_code_title (Utf8.lexeme lexbuf)) in
@ -413,7 +563,9 @@ let rec lex_law (lexbuf : lexbuf) : token =
done;
LAW_ARTICLE (title, None, None)
| Plus (Compl ('@' | '/' | '\n')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
| Plus (Compl ('@' | '/')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> 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

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

@ -14,9 +14,13 @@
open Parser
open Sedlexing
module Pos = Utils.Pos
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);
@ -31,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);
@ -48,7 +55,6 @@ let token_list_en : (string * token) list =
("else", ELSE);
("content", CONTENT);
("structure", STRUCT);
("optional", OPTIONAL);
("assertion", ASSERTION);
("varies", VARIES);
("with", WITH_V);
@ -61,18 +67,25 @@ let token_list_en : (string * token) list =
("exists", EXISTS);
("such", SUCH);
("that", THAT);
("now", NOW);
("and", AND);
("or", OR);
("not", NOT);
("integer_to_decimal", INT_TO_DEC);
("maximum", MAXIMUM);
("minimum", MAXIMUM);
("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 *)
@ -119,7 +132,7 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "integer" ->
L.update_acc lexbuf;
INTEGER
| "amount" ->
| "money" ->
L.update_acc lexbuf;
MONEY
| "text" ->
@ -131,6 +144,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
@ -143,6 +159,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
@ -176,9 +198,6 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "structure" ->
L.update_acc lexbuf;
STRUCT
| "optional" ->
L.update_acc lexbuf;
OPTIONAL
| "assertion" ->
L.update_acc lexbuf;
ASSERTION
@ -219,9 +238,6 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "that" ->
L.update_acc lexbuf;
THAT
| "now" ->
L.update_acc lexbuf;
NOW
| "and" ->
L.update_acc lexbuf;
AND
@ -231,6 +247,15 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| "not" ->
L.update_acc lexbuf;
NOT
| "integer_to_decimal" ->
L.update_acc lexbuf;
INT_TO_DEC
| "maximum" ->
L.update_acc lexbuf;
MAXIMUM
| "minimum" ->
L.update_acc lexbuf;
MINIMUM
| "number" ->
L.update_acc lexbuf;
CARDINAL
@ -243,6 +268,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
@ -252,8 +283,8 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
(* Integer literal*)
let units = parts 1 in
let remove_commas = R.regexp "," in
let units = int_of_string (R.substitute ~rex:remove_commas ~subst:(fun _ -> "") units) in
let cents = try int_of_string (parts 4) with Not_found -> 0 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' ->
@ -261,13 +292,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 (int_of_string (dec_parts 1), int_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
@ -280,18 +392,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
@ -301,21 +401,51 @@ 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;
LSQUARE
| ']' ->
L.update_acc lexbuf;
RSQUARE
| '|' ->
L.update_acc lexbuf;
VERTICAL
| ':' ->
L.update_acc lexbuf;
COLON
| ';' ->
L.update_acc lexbuf;
SEMICOLON
| "--" ->
L.update_acc lexbuf;
ALT
| '.' ->
L.update_acc lexbuf;
DOT
| uppercase, Star (uppercase | lowercase | '0' .. '9' | '_' | '\'') ->
(* Name of constructor *)
L.update_acc lexbuf;
@ -327,12 +457,14 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| Plus '0' .. '9' ->
(* Integer literal*)
L.update_acc lexbuf;
INT_LITERAL (int_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
let rec lex_law_en (lexbuf : lexbuf) : token =
(** 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
| '\n' -> lex_law_en lexbuf
| "/*" ->
L.is_code := true;
L.code_string_acc := "";
@ -356,8 +488,8 @@ let rec lex_law_en (lexbuf : lexbuf) : token =
let name = get_component 1 in
let pages = try Some (int_of_string (get_component 3)) with Not_found -> None in
let pos = lexing_positions lexbuf in
if Filename.extension name = ".pdf" then LAW_INCLUDE (Catala_ast.PdfFile ((name, pos), pages))
else LAW_INCLUDE (Catala_ast.CatalaFile (name, pos))
if Filename.extension name = ".pdf" then LAW_INCLUDE (Ast.PdfFile ((name, pos), pages))
else LAW_INCLUDE (Ast.CatalaFile (name, pos))
| "@@", Plus (Compl '@'), "@@", Star '+' ->
let extract_code_title = R.regexp "@@([^@]+)@@([\\+]*)" in
let get_match = R.get_substring (R.exec ~rex:extract_code_title (Utf8.lexeme lexbuf)) in
@ -385,7 +517,7 @@ let rec lex_law_en (lexbuf : lexbuf) : token =
done;
LAW_ARTICLE (title, None, None)
| Plus (Compl ('@' | '/' | '\n')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> L.raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
| Plus (Compl ('@' | '/')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> 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

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

@ -14,9 +14,13 @@
open Parser
open Sedlexing
module Pos = Utils.Pos
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);
@ -31,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);
@ -48,7 +53,6 @@ let token_list_fr : (string * token) list =
("sinon", ELSE);
("contenu", CONTENT);
("structure", STRUCT);
("optionnel", OPTIONAL);
("assertion", ASSERTION);
("varie", VARIES);
("avec", WITH_V);
@ -61,18 +65,25 @@ let token_list_fr : (string * token) list =
("existe", EXISTS);
("tel", SUCH);
("que", THAT);
("maintenant", NOW);
("et", AND);
("ou", OR);
("non", NOT);
("nombre", CARDINAL);
("entier_vers_décimal", INT_TO_DEC);
("maximum", MAXIMUM);
("minimum", MINIMUM);
("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 *)
@ -120,7 +131,7 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| "entier" ->
L.update_acc lexbuf;
INTEGER
| "montant" ->
| "argent" ->
L.update_acc lexbuf;
MONEY
| "texte" ->
@ -132,6 +143,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
@ -145,6 +159,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;
@ -181,9 +201,6 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| "structure" ->
L.update_acc lexbuf;
STRUCT
| "optionnel" ->
L.update_acc lexbuf;
OPTIONAL
| "assertion" ->
L.update_acc lexbuf;
ASSERTION
@ -225,9 +242,6 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| "que" ->
L.update_acc lexbuf;
THAT
| "maintenant" ->
L.update_acc lexbuf;
NOW
| "et" ->
L.update_acc lexbuf;
AND
@ -240,6 +254,15 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| "nombre" ->
L.update_acc lexbuf;
CARDINAL
| "maximum" ->
L.update_acc lexbuf;
MAXIMUM
| "minimum" ->
L.update_acc lexbuf;
MINIMUM
| "entier_vers_d", 0xE9, "cimal" ->
L.update_acc lexbuf;
INT_TO_DEC
| "vrai" ->
L.update_acc lexbuf;
TRUE
@ -249,6 +272,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)),
@ -261,8 +290,8 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
(* Integer literal*)
let units = parts 1 in
let remove_spaces = R.regexp " " in
let units = int_of_string (R.substitute ~rex:remove_spaces ~subst:(fun _ -> "") units) in
let cents = try int_of_string (parts 4) with Not_found -> 0 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' ->
@ -270,13 +299,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 (int_of_string (dec_parts 1), int_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
@ -289,18 +399,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
@ -310,21 +408,51 @@ 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;
LSQUARE
| ']' ->
L.update_acc lexbuf;
RSQUARE
| '|' ->
L.update_acc lexbuf;
VERTICAL
| ':' ->
L.update_acc lexbuf;
COLON
| ';' ->
L.update_acc lexbuf;
SEMICOLON
| "--" ->
L.update_acc lexbuf;
ALT
| '.' ->
L.update_acc lexbuf;
DOT
| uppercase, Star (uppercase | lowercase | '0' .. '9' | '_' | '\'') ->
(* Name of constructor *)
L.update_acc lexbuf;
@ -336,12 +464,14 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| Plus '0' .. '9' ->
(* Integer literal*)
L.update_acc lexbuf;
INT_LITERAL (int_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
let rec lex_law_fr (lexbuf : lexbuf) : token =
(** 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
| '\n' -> lex_law_fr lexbuf
| "/*" ->
L.is_code := true;
L.code_string_acc := "";
@ -371,10 +501,9 @@ let rec lex_law_fr (lexbuf : lexbuf) : token =
let name = get_component 1 in
let pages = try Some (int_of_string (get_component 3)) with Not_found -> None in
let pos = lexing_positions lexbuf in
if R.pmatch ~rex:jorftext name then LAW_INCLUDE (Catala_ast.LegislativeText (name, pos))
else if Filename.extension name = ".pdf" then
LAW_INCLUDE (Catala_ast.PdfFile ((name, pos), pages))
else LAW_INCLUDE (Catala_ast.CatalaFile (name, pos))
if R.pmatch ~rex:jorftext name then LAW_INCLUDE (Ast.LegislativeText (name, pos))
else if Filename.extension name = ".pdf" then LAW_INCLUDE (Ast.PdfFile ((name, pos), pages))
else LAW_INCLUDE (Ast.CatalaFile (name, pos))
| "@@", Plus (Compl '@'), "@@", Star '+' ->
let extract_code_title = R.regexp "@@([^@]+)@@([\\+]*)" in
let get_match = R.get_substring (R.exec ~rex:extract_code_title (Utf8.lexeme lexbuf)) in
@ -410,8 +539,10 @@ let rec lex_law_fr (lexbuf : lexbuf) : token =
done;
LAW_ARTICLE (title, article_id, article_expiration_date)
| Plus (Compl ('@' | '/' | '\n')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> L.raise_lexer_error (lexing_positions lexbuf) (Utf8.lexeme lexbuf) "unknown token"
| Plus (Compl ('@' | '/')) -> LAW_TEXT (Utf8.lexeme lexbuf)
| _ -> 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

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

@ -15,152 +15,263 @@
(** Builds a context that allows for mapping each name to a precise uid, taking lexical scopes into
account *)
module Pos = Utils.Pos
module Errors = Utils.Errors
(** {1 Name resolution context} *)
type ident = string
type typ = Lambda_ast.typ
type def_context = { var_idmap : Uid.LocalVar.t Uid.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 : Uid.Var.t Uid.IdentMap.t;
sub_scopes_idmap : Uid.SubScope.t Uid.IdentMap.t;
sub_scopes : Uid.Scope.t Uid.SubScopeMap.t;
definitions : def_context Uid.ScopeDefMap.t;
(** Contains the local variables in all the definitions *)
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;
(** 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 : Uid.Scope.t Uid.IdentMap.t;
scopes : scope_context Uid.ScopeMap.t;
var_typs : typ Uid.VarMap.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 * bool) (* is it a condition? *) Scopelang.Ast.ScopeVarMap.t;
(** The types of each scope variable declared *)
}
(** Main context used throughout {!module: Surface.Desugaring} *)
(** {1 Helpers} *)
(** 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 *)
let get_var_typ (ctxt : context) (uid : Uid.Var.t) : typ = Uid.VarMap.find uid ctxt.var_typs
(** Gets the type associated to an uid *)
let get_var_typ (ctxt : context) (uid : Scopelang.Ast.ScopeVar.t) : typ Pos.marked =
fst (Scopelang.Ast.ScopeVarMap.find uid ctxt.var_typs)
let is_var_cond (ctxt : context) (uid : Scopelang.Ast.ScopeVar.t) : bool =
snd (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 ->
get_var_typ ctxt x
let is_def_cond (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : bool =
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 ->
is_var_cond ctxt x
(** {1 Declarations pass} *)
(** Process a subscope declaration *)
let process_subscope_decl (scope : Uid.Scope.t) (ctxt : context)
(decl : Catala_ast.scope_decl_context_scope) : context =
let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
(decl : Ast.scope_decl_context_scope) : context =
let name, name_pos = decl.scope_decl_context_scope_name in
let subscope, s_pos = decl.scope_decl_context_scope_sub_scope in
let scope_ctxt = Uid.ScopeMap.find scope ctxt.scopes in
match Uid.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap with
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 (Uid.SubScope.get_info use));
(Some "first use", Pos.get_position (Scopelang.Ast.SubScopeName.get_info use));
(Some "second use", s_pos);
]
| None ->
let sub_scope_uid = Uid.SubScope.fresh (name, name_pos) in
let sub_scope_uid = Scopelang.Ast.SubScopeName.fresh (name, name_pos) in
let original_subscope_uid =
match Uid.IdentMap.find_opt subscope ctxt.scope_idmap with
match Desugared.Ast.IdentMap.find_opt subscope ctxt.scope_idmap with
| None -> raise_unknown_identifier "for a scope" (subscope, s_pos)
| Some id -> id
in
let scope_ctxt =
{
scope_ctxt with
sub_scopes_idmap = Uid.IdentMap.add name sub_scope_uid scope_ctxt.sub_scopes_idmap;
sub_scopes = Uid.SubScopeMap.add sub_scope_uid original_subscope_uid scope_ctxt.sub_scopes;
sub_scopes_idmap =
Desugared.Ast.IdentMap.add name sub_scope_uid scope_ctxt.sub_scopes_idmap;
sub_scopes =
Scopelang.Ast.SubScopeMap.add sub_scope_uid original_subscope_uid scope_ctxt.sub_scopes;
}
in
{ ctxt with scopes = Uid.ScopeMap.add scope scope_ctxt ctxt.scopes }
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes }
let process_base_typ ((typ, typ_pos) : Catala_ast.base_typ Pos.marked) : Lambda_ast.typ =
let is_type_cond ((typ, _) : Ast.typ Pos.marked) =
match typ with
| Catala_ast.Condition -> Lambda_ast.TBool
| Catala_ast.Data (Catala_ast.Collection _) -> raise_unsupported_feature "collection type" typ_pos
| Catala_ast.Data (Catala_ast.Optional _) -> raise_unsupported_feature "option type" typ_pos
| Catala_ast.Data (Catala_ast.Primitive prim) -> (
| Ast.Base Ast.Condition | Ast.Func { arg_typ = _; return_typ = Ast.Condition, _ } -> true
| _ -> false
(** Process a basic type (all types except function types) *)
let rec process_base_typ (ctxt : context) ((typ, typ_pos) : Ast.base_typ Pos.marked) :
Scopelang.Ast.typ Pos.marked =
match typ with
| Ast.Condition -> (Scopelang.Ast.TLit TBool, typ_pos)
| Ast.Data (Ast.Collection t) ->
( Scopelang.Ast.TArray
(Pos.unmark (process_base_typ ctxt (Ast.Data (Pos.unmark t), Pos.get_position t))),
typ_pos )
| Ast.Data (Ast.Primitive prim) -> (
match prim with
| Catala_ast.Integer | Catala_ast.Decimal | Catala_ast.Money | Catala_ast.Date ->
Lambda_ast.TInt
| Catala_ast.Boolean -> Lambda_ast.TBool
| Catala_ast.Text -> raise_unsupported_feature "text type" typ_pos
| Catala_ast.Named _ -> raise_unsupported_feature "struct or enum types" 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 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) : Catala_ast.typ Pos.marked) : Lambda_ast.typ =
(** 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
| Catala_ast.Base base_typ -> process_base_typ (base_typ, typ_pos)
| Catala_ast.Func { arg_typ; return_typ } ->
Lambda_ast.TArrow (process_base_typ arg_typ, process_base_typ return_typ)
| Ast.Base base_typ -> process_base_typ ctxt (base_typ, typ_pos)
| Ast.Func { arg_typ; return_typ } ->
( 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 : Uid.Scope.t) (ctxt : context)
(decl : Catala_ast.scope_decl_context_data) : context =
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 is_cond = is_type_cond decl.scope_decl_context_item_typ in
let name, pos = decl.scope_decl_context_item_name in
let scope_ctxt = Uid.ScopeMap.find scope ctxt.scopes in
match Uid.IdentMap.find_opt name scope_ctxt.var_idmap with
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt name scope_ctxt.var_idmap with
| Some use ->
Errors.raise_multispanned_error "var name already used"
[ (Some "first use", Pos.get_position (Uid.Var.get_info use)); (Some "second use", pos) ]
[
(Some "first use", Pos.get_position (Scopelang.Ast.ScopeVar.get_info use));
(Some "second use", pos);
]
| None ->
let uid = Uid.Var.fresh (name, pos) in
let uid = Scopelang.Ast.ScopeVar.fresh (name, pos) in
let scope_ctxt =
{ scope_ctxt with var_idmap = Uid.IdentMap.add name uid scope_ctxt.var_idmap }
{ scope_ctxt with var_idmap = Desugared.Ast.IdentMap.add name uid scope_ctxt.var_idmap }
in
{
ctxt with
scopes = Uid.ScopeMap.add scope scope_ctxt ctxt.scopes;
var_typs = Uid.VarMap.add uid data_typ ctxt.var_typs;
scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes;
var_typs = Scopelang.Ast.ScopeVarMap.add uid (data_typ, is_cond) ctxt.var_typs;
}
(** Process an item declaration *)
let process_item_decl (scope : Uid.Scope.t) (ctxt : context)
(decl : Catala_ast.scope_decl_context_item) : context =
let process_item_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
(decl : Ast.scope_decl_context_item) : context =
match decl with
| Catala_ast.ContextData data_decl -> process_data_decl scope ctxt data_decl
| Catala_ast.ContextScope sub_decl -> process_subscope_decl scope ctxt sub_decl
| Ast.ContextData data_decl -> process_data_decl scope ctxt data_decl
| 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 : Uid.Scope.t) (def_uid : Uid.ScopeDef.t)
(name : ident Pos.marked) : context =
let scope_ctxt = Uid.ScopeMap.find scope_uid ctxt.scopes in
let def_ctx = Uid.ScopeDefMap.find def_uid scope_ctxt.definitions in
let local_var_uid = Uid.LocalVar.fresh name in
let def_ctx =
{ var_idmap = Uid.IdentMap.add (Pos.unmark name) local_var_uid def_ctx.var_idmap }
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 ctxt =
{
ctxt with
local_var_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark name) local_var_uid ctxt.local_var_idmap;
}
in
let scope_ctxt =
{ scope_ctxt with definitions = Uid.ScopeDefMap.add def_uid def_ctx scope_ctxt.definitions }
in
{ ctxt with scopes = Uid.ScopeMap.add scope_uid scope_ctxt ctxt.scopes }
(ctxt, local_var_uid)
(** Process a scope declaration *)
let process_scope_decl (ctxt : context) (decl : Catala_ast.scope_decl) : context =
let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
let name, pos = decl.scope_decl_name in
(* Checks if the name is already used *)
match Uid.IdentMap.find_opt name ctxt.scope_idmap with
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| Some use ->
Errors.raise_multispanned_error "scope name already used"
[ (Some "first use", Pos.get_position (Uid.Scope.get_info use)); (Some "second use", pos) ]
[
(Some "first use", Pos.get_position (Scopelang.Ast.ScopeName.get_info use));
(Some "second use", pos);
]
| None ->
let scope_uid = Uid.Scope.fresh (name, pos) in
let scope_uid = Scopelang.Ast.ScopeName.fresh (name, pos) in
let ctxt =
{
ctxt with
scope_idmap = Uid.IdentMap.add name scope_uid ctxt.scope_idmap;
scope_idmap = Desugared.Ast.IdentMap.add name scope_uid ctxt.scope_idmap;
scopes =
Uid.ScopeMap.add scope_uid
Scopelang.Ast.ScopeMap.add scope_uid
{
var_idmap = Uid.IdentMap.empty;
sub_scopes_idmap = Uid.IdentMap.empty;
definitions = Uid.ScopeDefMap.empty;
sub_scopes = Uid.SubScopeMap.empty;
var_idmap = Desugared.Ast.IdentMap.empty;
label_idmap = Desugared.Ast.IdentMap.empty;
sub_scopes_idmap = Desugared.Ast.IdentMap.empty;
sub_scopes = Scopelang.Ast.SubScopeMap.empty;
}
ctxt.scopes;
}
@ -169,137 +280,237 @@ let process_scope_decl (ctxt : context) (decl : Catala_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 : Uid.Scope.t)
(id : Catala_ast.qident Pos.marked) : Uid.ScopeDef.t =
let scope_ctxt = Uid.ScopeMap.find scope_uid ctxt.scopes in
match Pos.unmark id with
| [ x ] -> (
match Uid.IdentMap.find_opt (Pos.unmark x) scope_ctxt.var_idmap with
| None -> raise_unknown_identifier "for a var of the scope" x
| Some id -> Uid.ScopeDef.Var id )
| [ s; x ] -> (
let sub_scope_uid =
match Uid.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 = Uid.SubScopeMap.find sub_scope_uid scope_ctxt.sub_scopes in
let sub_scope_ctx = Uid.ScopeMap.find real_sub_scope_uid ctxt.scopes in
match Uid.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 -> Uid.ScopeDef.SubScopeVar (sub_scope_uid, id) )
| _ -> raise_unsupported_feature "wrong qident" (Pos.get_position id)
let process_scope_use (ctxt : context) (use : Catala_ast.scope_use) : context =
let scope_uid =
match Uid.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
| Catala_ast.Definition def ->
let scope_ctxt = Uid.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 =
( match def.definition_parameter with
| None -> Uid.IdentMap.empty
| Some param -> Uid.IdentMap.singleton (Pos.unmark param) (Uid.LocalVar.fresh param)
);
}
in
let scope_ctxt =
{
scope_ctxt with
definitions = Uid.ScopeDefMap.add def_uid def_ctxt scope_ctxt.definitions;
}
in
{ ctxt with scopes = Uid.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 : Catala_ast.code_item Pos.marked) : context =
(** Process an enum declaration *)
let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
let e_uid = Scopelang.Ast.EnumName.fresh edecl.enum_decl_name in
let ctxt =
{
ctxt with
enum_idmap =
Desugared.Ast.IdentMap.add (Pos.unmark edecl.enum_decl_name) e_uid ctxt.enum_idmap;
}
in
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 that is a declaration *)
let process_decl_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 a code item : for now it only handles scope decls *)
let process_decl_item (ctxt : context) (item : Catala_ast.code_item Pos.marked) : context =
match Pos.unmark item with ScopeDecl decl -> process_scope_decl ctxt decl | _ -> ctxt
| 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 : Catala_ast.code_block)
(process_item : context -> Catala_ast.code_item Pos.marked -> context) : context =
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 *)
let process_law_article_item (ctxt : context) (item : Catala_ast.law_article_item)
(process_item : context -> Catala_ast.code_item Pos.marked -> context) : context =
(** 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 *)
let rec process_law_structure (ctxt : context) (s : Catala_ast.law_structure)
(process_item : context -> Catala_ast.code_item Pos.marked -> context) : context =
(** 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
| Catala_ast.LawHeading (_, children) ->
| Ast.LawHeading (_, children) ->
List.fold_left (fun ctxt child -> process_law_structure ctxt child process_item) ctxt children
| Catala_ast.LawArticle (_, children) ->
| Ast.LawArticle (_, children) ->
List.fold_left
(fun ctxt child -> process_law_article_item ctxt child process_item)
ctxt children
| Catala_ast.MetadataBlock (b, c) ->
process_law_article_item ctxt (Catala_ast.CodeBlock (b, c)) process_item
| Catala_ast.IntermediateText _ -> ctxt
| Ast.MetadataBlock (b, c) -> process_law_article_item ctxt (Ast.CodeBlock (b, c)) process_item
| Ast.IntermediateText _ | Ast.LawInclude _ -> ctxt
(** Process a program item *)
let process_program_item (ctxt : context) (item : Catala_ast.program_item)
(process_item : context -> Catala_ast.code_item Pos.marked -> context) : context =
match item with Catala_ast.LawStructure s -> process_law_structure ctxt s process_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 *)
let form_context (prgm : Catala_ast.program) : context =
(** {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 =
{ scope_idmap = Uid.IdentMap.empty; scopes = Uid.ScopeMap.empty; var_typs = Uid.VarMap.empty }
{
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 =
List.fold_left
(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 : Uid.Scope.t) (ctxt : context) ((x, pos) : ident Pos.marked) : Uid.Var.t
=
let scope = Uid.ScopeMap.find scope_uid ctxt.scopes in
match Uid.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 : Uid.Scope.t) (ctxt : context) ((y, pos) : ident Pos.marked) :
Uid.SubScope.t =
let scope = Uid.ScopeMap.find scope_uid ctxt.scopes in
match Uid.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 : Uid.Var.t) (scope_uid : Uid.Scope.t) : bool =
let scope = Uid.ScopeMap.find scope_uid ctxt.scopes in
Uid.IdentMap.exists (fun _ var_uid -> Uid.Var.compare uid var_uid = 0) scope.var_idmap
let get_def_typ (ctxt : context) (def : Uid.ScopeDef.t) : typ =
match def with
| Uid.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 *)
| Uid.ScopeDef.Var x ->
Uid.VarMap.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

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

File diff suppressed because it is too large Load Diff

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

@ -17,7 +17,9 @@
*)
%{
open Catala_ast
open Ast
module Errors = Utils.Errors
type struct_or_enum_inject_content =
| StructContent of (ident Pos.marked * expression Pos.marked) list
@ -28,32 +30,42 @@
%token EOF
%token<string * string option * string option> LAW_ARTICLE
%token<string * int> LAW_HEADING
%token<Catala_ast.law_include> LAW_INCLUDE
%token<Ast.law_include> LAW_INCLUDE
%token<string> LAW_TEXT
%token<string> CONSTRUCTOR IDENT
%token<string> END_CODE
%token<int> INT_LITERAL
%token<Z.t> INT_LITERAL
%token TRUE FALSE
%token<int * int> DECIMAL_LITERAL
%token<int * int> 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 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 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
%token DOT AND OR LPAREN RPAREN EQUAL
%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 LSQUARE RSQUARE SEMICOLON
%token INT_TO_DEC MAXIMUM MINIMUM
%type <Catala_ast.source_file_or_master> source_file_or_master
%type <Ast.source_file_or_master> source_file_or_master
%start source_file_or_master
@ -63,6 +75,7 @@ typ_base:
| INTEGER { (Integer, $sloc) }
| BOOLEAN { (Boolean, $sloc) }
| MONEY { (Money, $sloc) }
| DURATION { (Duration, $sloc) }
| TEXT { (Text, $sloc) }
| DECIMAL { (Decimal, $sloc) }
| DATE { (Date, $sloc) }
@ -74,18 +87,12 @@ typ_base:
collection_marked:
| COLLECTION { $sloc }
optional_marked:
| OPTIONAL { $sloc }
typ:
| t = typ_base {
let t, loc = t in
(Primitive t, loc)
}
| collection_marked t = typ {
(Optional t, $sloc)
}
| optional_marked t = typ {
(Collection t, $sloc)
}
@ -118,27 +125,31 @@ 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
| EnumContent data -> (EnumInject (c, data), $sloc)
| StructContent fields -> (StructLit (c, fields), $sloc)
}
primitive_expression:
| e = small_expression { e }
| NOW { (Builtin Now, $sloc) }
| CARDINAL {
(Builtin Cardinal, $sloc)
}
| INT_TO_DEC {
(Builtin IntToDec, $sloc)
}
| e = struct_or_enum_inject {
e
}
| LSQUARE l = separated_list(SEMICOLON, expression) RSQUARE {
(ArrayLit l, $sloc)
}
num_literal:
| d = INT_LITERAL { (Int d, $sloc) }
@ -150,9 +161,11 @@ num_literal:
unit_literal:
| PERCENT { (Percent, $sloc) }
| YEAR { (Year, $sloc)}
| MONTH { (Month, $sloc) }
| DAY { (Day, $sloc) }
date_int:
| d = INT_LITERAL { (d, $sloc) }
| d = INT_LITERAL { (Z.to_int d, $sloc) }
literal:
| l = num_literal u = option(unit_literal) {
@ -176,15 +189,33 @@ 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) }
aggregate_func:
| SUM { (Aggregate AggregateSum, $sloc) }
| MAXIMUM t = typ_base { (Aggregate (AggregateExtremum (true, Pos.unmark t)), $sloc) }
| MINIMUM t = typ_base { (Aggregate (AggregateExtremum (false, Pos.unmark t)), $sloc) }
| SUM t = typ_base { (Aggregate (AggregateSum (Pos.unmark t)), $sloc) }
| CARDINAL { (Aggregate AggregateCount, $sloc) }
aggregate:
@ -207,8 +238,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 }
@ -217,11 +252,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 }
@ -328,11 +374,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;
@ -343,10 +394,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;
@ -374,10 +436,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 {
@ -410,9 +472,9 @@ struct_scope:
struct_decl_field_name = name;
struct_decl_field_typ = match func_typ with
| None -> (Base typ, typ_pos)
| Some (return_typ, return_pos) -> (Func {
arg_typ = (typ, typ_pos);
return_typ = (Data return_typ, return_pos);
| Some (arg_typ, arg_pos) -> (Func {
arg_typ = (Data arg_typ, arg_pos);
return_typ = (typ, typ_pos);
}, $sloc) ;
}, $sloc)
}
@ -424,9 +486,9 @@ scope_decl_item:
let (typ, typ_pos) = t in
match func_typ with
| None -> (Base (Data typ), typ_pos)
| Some (return_typ, return_pos) -> (Func {
arg_typ = (Data typ, typ_pos);
return_typ = (Data return_typ, return_pos);
| Some (arg_typ, arg_pos) -> (Func {
arg_typ = (Data arg_typ, arg_pos);
return_typ = (Data typ, typ_pos);
}, $sloc);
}), $sloc) }
| CONTEXT i = ident SCOPE c = constructor {
@ -440,9 +502,9 @@ scope_decl_item:
scope_decl_context_item_typ =
match func_typ with
| None -> (Base (Condition), $loc(_condition))
| Some (return_typ, return_pos) -> (Func {
arg_typ = (Condition, $loc(_condition));
return_typ = (Data return_typ, return_pos);
| Some (arg_typ, arg_pos) -> (Func {
arg_typ = (Data arg_typ, arg_pos);
return_typ = (Condition, $loc(_condition));
}, $sloc);
}), $sloc) }
@ -492,20 +554,17 @@ code:
| code = list(code_item) { (code, $sloc) }
metadata_block:
| BEGIN_CODE code_and_pos = code text = END_CODE END_METADATA {
| BEGIN_CODE option(law_text) code_and_pos = code text = END_CODE option(law_text) END_METADATA {
let (code, pos) = code_and_pos in
(code, (text, pos))
}
law_article_item:
| text = LAW_TEXT { LawText text }
| text = law_text { LawText text }
| BEGIN_CODE code_and_pos = code text = END_CODE {
let (code, pos) = code_and_pos in
CodeBlock (code, (text, pos))
}
| includ = LAW_INCLUDE {
LawInclude includ
}
law_article:
| title = LAW_ARTICLE {
@ -528,7 +587,11 @@ law_articles_items:
| { [] }
law_text:
| text = LAW_TEXT { LawStructure (IntermediateText text) }
| text = LAW_TEXT { String.trim text }
law_intermediate_text:
| text = law_text { LawStructure (IntermediateText text) }
source_file_article:
| article = law_article items = law_articles_items {
@ -539,22 +602,25 @@ source_file_item:
| heading = law_heading {
LawStructure (LawHeading (heading, []))
}
| BEGIN_METADATA code = metadata_block {
| BEGIN_METADATA option(law_text) code = metadata_block {
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 {
i::f
}
| i = source_file_item l = list(law_text) f = source_file_after_text {
| i = source_file_item l = list(law_intermediate_text) f = source_file_after_text {
i::l@f
}
| EOF { [] }
source_file:
| l = list(law_text) f = source_file_after_text { l@f }
| l = list(law_intermediate_text) f = source_file_after_text { l@f }
master_file_include:
| includ = LAW_INCLUDE {
@ -564,11 +630,11 @@ master_file_include:
}
master_file_includes:
| i = master_file_include is = master_file_includes { i::is }
| i = master_file_include option(law_text) is = master_file_includes { i::is }
| EOF { [] }
source_file_or_master:
| MASTER_FILE is = master_file_includes { MasterFile is }
| MASTER_FILE option(law_text) is = master_file_includes { MasterFile is }
| f = source_file {
(*
now here the heading structure is completely flat because of the
@ -585,7 +651,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

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

@ -12,17 +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
@ -50,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
@ -94,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
@ -122,10 +145,11 @@ 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) :
Catala_ast.source_file_or_master =
Ast.source_file_or_master =
match checkpoint with
| I.InputNeeded env ->
let token = next_token () in
@ -140,62 +164,114 @@ 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) :
Catala_ast.source_file_or_master =
Ast.source_file_or_master =
let lexer : unit -> Parser.token * Lexing.position * Lexing.position =
with_tokenizer lexer' lexbuf
in
try loop lexer token_list lexbuf None (target_rule (fst @@ Sedlexing.lexing_positions lexbuf))
with Sedlexing.MalFormed | Sedlexing.InvalidCodepoint _ ->
Lexer.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) :
Catala_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 : Pos.input_file) (language : Cli.frontend_lang) :
Ast.program =
Cli.debug_print
(Printf.sprintf "Parsing %s" (match source_file with FileName s | Contents s -> s));
let lexbuf, input =
match source_file with
| FileName source_file -> (
try
let input = open_in source_file in
(Sedlexing.Utf8.from_channel input, Some input)
with Sys_error msg -> Errors.raise_error msg )
| Contents contents -> (Sedlexing.Utf8.from_gen (Gen.of_string contents), None)
in
let source_file_name = match source_file with FileName s -> s | Contents _ -> "stdin" in
Sedlexing.set_filename lexbuf source_file_name;
Parse_utils.current_file := source_file_name;
let 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
(match input with Some input -> close_in input | None -> ());
match commands_or_includes with
| Ast.SourceFile commands ->
let program = expand_includes source_file_name commands language in
{
program_items = program.Ast.program_items;
program_source_files = source_file_name :: program.Ast.program_source_files;
}
| Ast.MasterFile includes ->
let current_source_file_dirname = Filename.dirname source_file_name 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 (FileName 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
| Catala_ast.SourceFile commands ->
let rest_program = parse_source_files rest language in
{
new_program with
program_source_files = source_file_name :: 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 (FileName sub_source) language in
{
program_items = commands @ rest_program.Catala_ast.program_items;
program_source_files = source_file :: rest_program.Catala_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;
}
| Catala_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

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

@ -8,155 +8,157 @@ let message s =
| 1 ->
"expected an inclusion of a Catala file, since this file is a master file which can only \
contain inclusions of other Catala files\n"
| 5 ->
| 3 -> "expected some text or includes only\n"
| 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"
| 277 -> "expected some text, another heading or a law article\n"
| 282 -> "expected a code block, a metadata block, more law text or a heading\n"
| 289 -> "expected a code block, a metadata block, more law text or a heading\n"
| 285 -> "expected a declaration or a scope use\n"
| 16 -> "expected the name of the scope you want to use\n"
| 18 -> "expected a scope use precondition or a colon\n"
| 19 -> "expected an expression which will act as the condition\n"
| 20 -> "expected the first component of the date literal\n"
| 22 -> "expected a \"/\"\n"
| 23 -> "expected the second component of the date literal\n"
| 24 -> "expected a \"/\"\n"
| 25 -> "expected the third component of the date literal\n"
| 26 -> "expected a delimiter to finish the date literal\n"
| 48 -> "expected an operator to compose the expression on the left with\n"
| 54 -> "expected an enum constructor to test if the expression on the left\n"
| 53 -> "expected an operator to compose the expression on the left with\n"
| 84 -> "expected an expression on the right side of the sum or minus operator\n"
| 108 -> "expected an expression on the right side of the logical operator\n"
| 56 -> "expected an expression for the argument of this function call\n"
| 80 -> "expected an expression on the right side of the comparison operator\n"
| 89 -> "expected an expression on the right side of the multiplication or division operator\n"
| 86 -> "expected an operator to compose the expression on the left\n"
| 135 -> "expected an expression standing for the set you want to test for membership\n"
| 49 -> "expected an identifier standing for a struct field or a subscope name\n"
| 159 -> "expected a colon after the scope use precondition\n"
| 51 -> "expected a constructor, to get the payload of this enum case\n"
| 92 -> "expected the \"for\" keyword to spell the aggregation\n"
| 93 -> "expected an identifier for the aggregation bound variable\n"
| 94 -> "expected the \"in\" keyword\n"
| 95 ->
"expected an expression standing for the set over which to compute the aggregation operation\n"
| 97 -> "expected the \"for\" keyword and the expression to compute the aggregate\n"
| 98 -> "expected an expression to compute its aggregation over the set\n"
| 102 -> "expected an expression to take the negation of\n"
| 45 -> "expected an expression to take the opposite of\n"
| 34 -> "expected an expression to match with\n"
| 143 -> "expected a pattern matching case\n"
| 144 -> "expected the name of the constructor for the enum case in the pattern matching\n"
| 150 ->
| 8 -> "expected some text, another heading or a law article\n"
| 350 -> "expected a heading, an article title or some text\n"
| 335 -> "expected an article title, another heading or some text\n"
| 340 -> "expected a code block, a metadata block, more law text or a heading\n"
| 346 -> "expected a code block, a metadata block, more law text or a heading\n"
| 341 -> "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"
| 71 -> "expected an operator to compose the expression on the left with\n"
| 77 -> "expected an enum constructor to test if the expression on the left\n"
| 76 -> "expected an operator to compose the expression on the left with\n"
| 132 -> "expected an expression on the right side of the sum or minus operator\n"
| 160 -> "expected an expression on the right side of the logical operator\n"
| 79 -> "expected an expression for the argument of this function call\n"
| 120 -> "expected an expression on the right side of the comparison operator\n"
| 141 -> "expected an expression on the right side of the multiplication or division operator\n"
| 134 -> "expected an operator to compose the expression on the left\n"
| 170 -> "expected an expression standing for the set you want to test for membership\n"
| 72 -> "expected an identifier standing for a struct field or a subscope name\n"
| 218 -> "expected a colon after the scope use precondition\n"
| 74 -> "expected a constructor, to get the payload of this enum case\n"
| 35 -> "expected the \"for\" keyword to spell the aggregation\n"
| 154 -> "expected an expression to take the negation of\n"
| 68 -> "expected an expression to take the opposite of\n"
| 55 -> "expected an expression to match with\n"
| 202 -> "expected a pattern matching case\n"
| 203 -> "expected the name of the constructor for the enum case in the pattern matching\n"
| 209 ->
"expected a binding for the constructor payload, or a colon and the matching case expression\n"
| 151 -> "expected an identifier for this enum case binding\n"
| 147 -> "expected a colon and then the expression for this matching case\n"
| 153 -> "expected a colon or a binding for the enum constructor payload\n"
| 148 -> "expected an expression for this pattern matching case\n"
| 145 ->
| 210 -> "expected an identifier for this enum case binding\n"
| 206 -> "expected a colon and then the expression for this matching case\n"
| 212 -> "expected a colon or a binding for the enum constructor payload\n"
| 207 -> "expected an expression for this pattern matching case\n"
| 204 ->
"expected another match case or the rest of the expression since the previous match case is \
complete\n"
| 142 -> "expected the \"with patter\" keyword to complete the pattern matching expression\n"
| 35 -> "expected an expression inside the parenthesis\n"
| 128 -> "unmatched parenthesis that should have been closed by here\n"
| 57 -> "expected a unit for this literal, or a valid operator to complete the expression \n"
| 37 -> "expected an expression for the test of the conditional\n"
| 138 -> "expected an expression the for the \"then\" branch of the conditiona\n"
| 139 ->
| 201 -> "expected the \"with patter\" keyword to complete the pattern matching expression\n"
| 57 -> "expected an expression inside the parenthesis\n"
| 193 -> "unmatched parenthesis that should have been closed by here\n"
| 80 -> "expected a unit for this literal, or a valid operator to complete the expression \n"
| 60 -> "expected an expression for the test of the conditional\n"
| 189 -> "expected an expression the for the \"then\" branch of the conditiona\n"
| 190 ->
"expected the \"else\" branch of this conditional expression as the \"then\" branch is \
complete\n"
| 140 -> "expected an expression for the \"else\" branch of this conditional construction\n"
| 137 -> "expected the \"then\" keyword as the conditional expression is complete\n"
| 39 ->
| 191 -> "expected an expression for the \"else\" branch of this conditional construction\n"
| 188 -> "expected the \"then\" keyword as the conditional expression is complete\n"
| 62 ->
"expected the \"all\" keyword to mean the \"for all\" construction of the universal test\n"
| 114 -> "expected an identifier for the bound variable of the universal test\n"
| 115 -> "expected the \"in\" keyword for the rest of the universal test\n"
| 116 -> "expected the expression designating the set on which to perform the universal test\n"
| 117 -> "expected the \"we have\" keyword for this universal test\n"
| 113 -> "expected an expression for the universal test\n"
| 122 -> "expected an identifier that will designate the existential witness for the test\n"
| 123 -> "expected the \"in\" keyword to continue this existential test\n"
| 124 -> "expected an expression that designates the set subject to the existential test\n"
| 125 -> "expected a keyword to form the \"such that\" expression for the existential test\n"
| 126 -> "expected a keyword to complete the \"such that\" construction\n"
| 120 -> "expected an expression for the existential test\n"
| 64 ->
| 174 -> "expected an identifier for the bound variable of the universal test\n"
| 175 -> "expected the \"in\" keyword for the rest of the universal test\n"
| 176 -> "expected the expression designating the set on which to perform the universal test\n"
| 177 -> "expected the \"we have\" keyword for this universal test\n"
| 173 -> "expected an expression for the universal test\n"
| 182 -> "expected an identifier that will designate the existential witness for the test\n"
| 183 -> "expected the \"in\" keyword to continue this existential test\n"
| 184 -> "expected an expression that designates the set subject to the existential test\n"
| 185 -> "expected a keyword to form the \"such that\" expression for the existential test\n"
| 186 -> "expected a keyword to complete the \"such that\" construction\n"
| 180 -> "expected an expression for the existential test\n"
| 89 ->
"expected a payload for the enum case constructor, or the rest of the expression (with an \
operator ?)\n"
| 65 -> "expected an expression for the content of this enum case\n"
| 130 ->
| 90 -> "expected structure fields introduced by --\n"
| 91 -> "expected the name of the structure field\n"
| 95 -> "expected a colon\n"
| 96 -> "expected the expression for this struct field\n"
| 92 -> "expected another structure field or the closing bracket\n"
| 93 -> "expected the name of the structure field\n"
| 164 -> "expected an expression for the content of this enum case\n"
| 165 ->
"the expression for the content of the enum case is already well-formed, expected an \
operator to form a bigger expression\n"
| 66 -> "expected a struct field creation introduced by a dash\n"
| 67 -> "expected the name of field of the struct that you are building\n"
| 71 -> "expected a colon and then the expression for the field of the struct\n"
| 72 -> "expected an expression for the field of the struct\n"
| 68 -> "expected another field of the struct or the end of the struct literal\n"
| 69 -> "expected another field of the struct\n"
| 44 -> "expected the keyword following cardinal to compute the number of elements in a set\n"
| 160 -> "expected a scope use item: a rule, definition or assertion\n"
| 161 -> "expected the name of the variable subject to the rule\n"
| 180 ->
| 67 -> "expected the keyword following cardinal to compute the number of elements in a set\n"
| 219 -> "expected a scope use item: a rule, definition or assertion\n"
| 254 -> "expected the name of the variable subject to the rule\n"
| 232 ->
"expected a condition or a consequence for this rule, or the rest of the variable qualified \
name\n"
| 175 -> "expected a condition or a consequence for this rule\n"
| 166 -> "expected filled or not filled for a rule consequence\n"
| 176 -> "expected the name of the parameter for this dependent variable \n"
| 163 -> "expected the expression of the rule\n"
| 169 -> "expected the filled keyword the this rule \n"
| 181 -> "expected a struct field or a sub-scope context item after the dot\n"
| 183 -> "expected the name of the variable you want to define\n"
| 184 -> "expected the defined as keyword to introduce the definition of this variable\n"
| 186 -> "expected an expression for the consequence of this definition under condition\n"
| 185 ->
| 261 -> "expected a condition or a consequence for this rule\n"
| 256 -> "expected filled or not filled for a rule consequence\n"
| 262 -> "expected the name of the parameter for this dependent variable \n"
| 255 -> "expected the expression of the rule\n"
| 259 -> "expected the filled keyword the this rule \n"
| 233 -> "expected a struct field or a sub-scope context item after the dot\n"
| 220 -> "expected the name of the label\n"
| 250 -> "expected a rule or a definition after the label declaration\n"
| 251 -> "expected the label to which the exception is referring back\n"
| 253 -> "expected a rule or a definition after the exception declaration\n"
| 266 -> "expected the name of the variable you want to define\n"
| 267 -> "expected the defined as keyword to introduce the definition of this variable\n"
| 269 -> "expected an expression for the consequence of this definition under condition\n"
| 268 ->
"expected a expression for defining this function, introduced by the defined as keyword\n"
| 187 -> "expected an expression for the definition\n"
| 190 -> "expected an expression that shoud be asserted during execution\n"
| 191 -> "expecting the name of the varying variable\n"
| 193 -> "the variable varies with an expression that was expected here\n"
| 194 -> "expected an indication about the variation sense of the variable, or a new scope item\n"
| 192 -> "expected an indication about what this variable varies with\n"
| 164 -> "expected an expression for this condition\n"
| 172 -> "expected a consequence for this definition under condition\n"
| 203 -> "expected an expression for this definition under condition\n"
| 199 -> "expected the name of the variable that should be fixed\n"
| 200 -> "expected the legislative text by which the value of the variable is fixed\n"
| 201 -> "expected the legislative text by which the value of the variable is fixed\n"
| 207 -> "expected a new scope use item \n"
| 210 -> "expected the kind of the declaration (struct, scope or enum)\n"
| 211 -> "expected the struct name\n"
| 212 -> "expected a colon\n"
| 213 -> "expected struct data or condition\n"
| 214 -> "expected the name of this struct data \n"
| 215 -> "expected the type of this struct data, introduced by the content keyword\n"
| 216 -> "expected the type of this struct data\n"
| 240 -> "expected the name of this struct condition\n"
| 233 -> "expected a new struct data, or another declaration or scope use\n"
| 234 -> "expected the type of the parameter of this struct data function\n"
| 238 -> "expected a new struct data, or another declaration or scope use\n"
| 227 -> "expected a new struct data, or another declaration or scope use\n"
| 230 -> "expected a new struct data, or another declaration or scope use\n"
| 243 -> "expected the name of the scope you are declaring\n"
| 244 -> "expected a colon followed by the list of context items of this scope\n"
| 245 -> "expected a context item introduced by \"context\"\n"
| 246 -> "expected the name of this new context item\n"
| 247 -> "expected the kind of this context item: is it a condition, a sub-scope or a data?\n"
| 248 -> "expected the name of the subscope for this context item\n"
| 255 -> "expected the next context item, or another declaration or scope use\n"
| 250 -> "expected the type of this context item\n"
| 251 -> "expected the next context item or a dependency declaration for this item\n"
| 253 -> "expected the next context item or a dependency declaration for this item\n"
| 258 -> "expected the name of your enum\n"
| 259 -> "expected a colon\n"
| 260 -> "expected an enum case\n"
| 261 -> "expected the name of an enum case \n"
| 262 -> "expected a payload for your enum case, or another case or declaration \n"
| 263 -> "expected a content type\n"
| 268 -> "expected another enum case, or a new declaration or scope use\n"
| 14 -> "expected a declaration or a scope use\n"
| 15 -> "expected a declaration or a scope use\n"
| 274 ->
"should not happen, please file an issue at https://github.com/CatalaLang/catala/issues\n"
| 270 -> "expected an expression for the definition\n"
| 222 -> "expected an expression that shoud be asserted during execution\n"
| 223 -> "expecting the name of the varying variable\n"
| 226 -> "the variable varies with an expression that was expected here\n"
| 227 -> "expected an indication about the variation sense of the variable, or a new scope item\n"
| 225 -> "expected an indication about what this variable varies with\n"
| 235 -> "expected an expression for this condition\n"
| 245 -> "expected a consequence for this definition under condition\n"
| 241 -> "expected an expression for this definition under condition\n"
| 237 -> "expected the name of the variable that should be fixed\n"
| 238 -> "expected the legislative text by which the value of the variable is fixed\n"
| 239 -> "expected the legislative text by which the value of the variable is fixed\n"
| 248 -> "expected a new scope use item \n"
| 277 -> "expected the kind of the declaration (struct, scope or enum)\n"
| 278 -> "expected the struct name\n"
| 279 -> "expected a colon\n"
| 280 -> "expected struct data or condition\n"
| 281 -> "expected the name of this struct data \n"
| 282 -> "expected the type of this struct data, introduced by the content keyword\n"
| 283 -> "expected the type of this struct data\n"
| 297 -> "expected the name of this struct condition\n"
| 290 -> "expected a new struct data, or another declaration or scope use\n"
| 291 -> "expected the type of the parameter of this struct data function\n"
| 295 -> "expected a new struct data, or another declaration or scope use\n"
| 287 -> "expected a new struct data, or another declaration or scope use\n"
| 300 -> "expected the name of the scope you are declaring\n"
| 301 -> "expected a colon followed by the list of context items of this scope\n"
| 302 -> "expected a context item introduced by \"context\"\n"
| 303 -> "expected the name of this new context item\n"
| 304 -> "expected the kind of this context item: is it a condition, a sub-scope or a data?\n"
| 305 -> "expected the name of the subscope for this context item\n"
| 312 -> "expected another scope context item or the end of the scope declaration\n"
| 307 -> "expected the type of this context item\n"
| 308 -> "expected the next context item or a dependency declaration for this item\n"
| 310 -> "expected the next context item or a dependency declaration for this item\n"
| 315 -> "expected the name of your enum\n"
| 316 -> "expected a colon\n"
| 317 -> "expected an enum case\n"
| 318 -> "expected the name of an enum case \n"
| 319 -> "expected a payload for your enum case, or another case or declaration \n"
| 320 -> "expected a content type\n"
| 325 -> "expected another enum case, or a new declaration or scope use\n"
| 18 -> "expected a declaration or a scope use\n"
| 19 -> "expected some text or the beginning of a code section\n"
| 20 -> "expected a declaration or a scope use\n"
| 21 -> "should not happen\n"
| 331 -> "expected a metadata-closing tag\n"
| 332 -> "expected a metadata-closing tag\n"
| _ -> raise Not_found

13
src/legifrance_catala.ml → src/catala/catala_surface/print.ml
View File

@ -12,4 +12,15 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
let _ = Legifrance_catala.Main.main ()
open Ast
let format_primitive_typ (fmt : Format.formatter) (t : primitive_typ) : unit =
match t with
| Integer -> Format.fprintf fmt "integer"
| Decimal -> Format.fprintf fmt "decimal"
| Boolean -> Format.fprintf fmt "boolean"
| Money -> Format.fprintf fmt "money"
| Duration -> Format.fprintf fmt "duration"
| Text -> Format.fprintf fmt "text"
| Date -> Format.fprintf fmt "date"
| Named constructor -> Format.fprintf fmt "%s" constructor

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}.

143
src/catala/default_calculus/ast.ml Normal file
View File

@ -0,0 +1,143 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
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 =
| TLit of typ_lit
| TTuple of typ Pos.marked list
| TEnum of typ Pos.marked list
| TArrow of typ Pos.marked * typ Pos.marked
| TArray of typ Pos.marked
| TAny
type date = ODate.Unix.t
type duration = Z.t
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 ternop = Fold
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
| Map
type log_entry = VarDef | BeginCall | EndCall
type unop =
| Not
| Minus of op_kind
| ErrorOnEmpty
| Log of log_entry * Utils.Uid.MarkedString.info list
| Length
| IntToRat
type operator = Ternop of ternop | Binop of binop | Unop of unop
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on
higher-order abstract syntax*)
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of (expr Pos.marked * 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 *)
| EArray of expr Pos.marked list
| 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 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
let make (s : string Pos.marked) : t =
Bindlib.new_var
(fun (x : expr Bindlib.var) : expr -> EVar (x, Pos.get_position s))
(Pos.unmark s)
let compare x y = Bindlib.compare_vars x y
end
module VarMap = Map.Make (Var)
type vars = expr Bindlib.mvar
let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun x -> (x, pos)) (Bindlib.box_var x)
let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t)
(taus : 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)
: expr Pos.marked Bindlib.box =
Bindlib.box_apply2 (fun e u -> (EApp (e, u), pos)) e (Bindlib.box_list u)
let make_let_in (x : Var.t) (tau : typ Pos.marked) (e1 : expr Pos.marked Bindlib.box)
(e2 : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box =
Bindlib.box_apply2
(fun e u -> (EApp (e, u), Pos.get_position (Bindlib.unbox e2)))
(make_abs
(Array.of_list [ x ])
e2
(Pos.get_position (Bindlib.unbox e2))
[ tau ]
(Pos.get_position (Bindlib.unbox e2)))
(Bindlib.box_list [ e1 ])
type binder = (expr, expr Pos.marked) Bindlib.binder

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.

7
src/catala/default_calculus/dune Normal file
View File

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

378
src/catala/default_calculus/interpreter.ml Normal file
View File

@ -0,0 +1,378 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Reference interpreter for the default calculus *)
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)
let rec type_eq (t1 : A.typ Pos.marked) (t2 : A.typ Pos.marked) : bool =
match (Pos.unmark t1, Pos.unmark t2) with
| A.TLit tl1, A.TLit tl2 -> tl1 = tl2
| A.TTuple ts1, A.TTuple ts2 | A.TEnum ts1, A.TEnum ts2 -> (
try List.for_all2 type_eq ts1 ts2 with Invalid_argument _ -> false )
| A.TArray t1, A.TArray t2 -> type_eq t1 t2
| A.TArrow (t11, t12), A.TArrow (t21, t22) -> type_eq t11 t12 && type_eq t21 t22
| _, _ -> false
(** {1 Evaluation} *)
let rec 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.Ternop A.Fold, [ _f; _init; EArray es ] ->
Pos.unmark
(List.fold_left
(fun acc e' ->
evaluate_expr (Pos.same_pos_as (A.EApp (List.nth args 0, [ acc; e' ])) e'))
(List.nth args 1) es)
| A.Binop A.And, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 && b2))
| A.Binop A.Or, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 || b2))
| A.Binop (A.Add KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Z.add i1 i2))
| A.Binop (A.Sub KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Z.sub i1 i2))
| A.Binop (A.Mult KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt (Z.mul i1 i2))
| A.Binop (A.Div KInt), [ ELit (LInt i1); ELit (LInt i2) ] ->
if i2 <> Z.zero then A.ELit (LInt (Z.div i1 i2))
else
Errors.raise_multispanned_error "division by zero at runtime"
[
(Some "The division operator:", Pos.get_position op);
(Some "The null denominator:", Pos.get_position (List.nth args 2));
]
| A.Binop (A.Add KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat (Q.add i1 i2))
| A.Binop (A.Sub KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat (Q.sub i1 i2))
| A.Binop (A.Mult KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat (Q.mul i1 i2))
| 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 LUnit; ELit LUnit ] -> A.ELit (LBool true)
| A.Binop A.Eq, [ ELit (LDuration i1); ELit (LDuration i2) ] -> A.ELit (LBool (i1 = i2))
| A.Binop A.Eq, [ ELit (LDate i1); ELit (LDate i2) ] ->
A.ELit (LBool (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, [ EArray es1; EArray es2 ] ->
A.ELit
(LBool
( try
List.for_all2
(fun e1 e2 ->
match Pos.unmark (evaluate_operator op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false ))
| A.Binop A.Eq, [ ETuple es1; ETuple es2 ] ->
A.ELit
(LBool
( try
List.for_all2
(fun (e1, _) (e2, _) ->
match Pos.unmark (evaluate_operator op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false ))
| A.Binop A.Eq, [ EInj (e1, i1, _, ts1); EInj (e2, i2, _, ts2) ] ->
A.ELit
(LBool
( try
List.for_all2 type_eq ts1 ts2 && i1 = i2
&&
match Pos.unmark (evaluate_operator op [ e1; e2 ]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *)
with Invalid_argument _ -> false ))
| A.Binop A.Eq, [ _; _ ] -> A.ELit (LBool false) (* comparing anything else return false *)
| A.Binop A.Neq, [ _; _ ] -> (
match Pos.unmark (evaluate_operator (Pos.same_pos_as (A.Binop A.Eq) op) args) with
| A.ELit (A.LBool b) -> A.ELit (A.LBool (not b))
| _ -> assert false (*should not happen *) )
| A.Binop A.Map, [ _; A.EArray es ] ->
A.EArray
(List.map
(fun e' -> evaluate_expr (Pos.same_pos_as (A.EApp (List.nth args 0, [ e' ])) e'))
es)
| A.Binop _, ([ ELit LEmptyError; _ ] | [ _; ELit LEmptyError ]) -> A.ELit LEmptyError
| A.Unop (A.Minus KInt), [ ELit (LInt i) ] -> A.ELit (LInt (Z.sub Z.zero i))
| A.Unop (A.Minus KRat), [ ELit (LRat i) ] -> A.ELit (LRat (Q.sub Q.zero i))
| A.Unop A.Not, [ ELit (LBool b) ] -> A.ELit (LBool (not b))
| A.Unop A.Length, [ EArray es ] -> A.ELit (LInt (Z.of_int (List.length es)))
| A.Unop A.IntToRat, [ ELit (LInt i) ] -> A.ELit (LRat (Q.of_bigint i))
| A.Unop A.ErrorOnEmpty, [ e' ] ->
if e' = A.ELit LEmptyError then
Errors.raise_spanned_error
"This variable evaluated to an empty term (no rule that defined it applied in this \
situation)"
(Pos.get_position op)
else e'
| A.Unop (A.Log (entry, infos)), [ e' ] ->
if !Cli.trace_flag then
match entry with
| VarDef ->
Cli.log_print
(Format.asprintf "@[<hov 2>%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 "@[<hov 2>%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\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
and evaluate_expr (e : A.expr Pos.marked) : A.expr Pos.marked =
match Pos.unmark e with
| EVar _ ->
Errors.raise_spanned_error
"free variable found at evaluation (should not happen if term was well-typed"
(Pos.get_position e)
| 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
evaluate_expr (Bindlib.msubst binder (Array.of_list (List.map Pos.unmark args)))
else
Errors.raise_spanned_error
(Format.asprintf "wrong function call, expected %d arguments, got %d"
(Bindlib.mbinder_arity binder) (List.length args))
(Pos.get_position e)
| 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
"function has not been reduced to a lambda at evaluation (should not happen if the \
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 (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'
| None ->
Errors.raise_spanned_error
(Format.asprintf
"the tuple has %d components but the %i-th element was requested (should not \
happen if the term was well-type)"
(List.length es) n)
(Pos.get_position e1) )
| _ ->
Errors.raise_spanned_error
(Format.asprintf
"the expression should be a tuple with %d components but is not (should not happen \
if the term was well-typed)"
n)
(Pos.get_position e1) )
| 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
"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
| ELit (LBool false) -> evaluate_expr ef
| _ ->
Errors.raise_spanned_error
"Expected a boolean literal for the result of this condition (should not happen if the \
term was well-typed)"
(Pos.get_position cond) )
| EArray es -> Pos.same_pos_as (A.EArray (List.map evaluate_expr es)) e
| 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), [ ((ELit _, _) as e1); ((ELit _, _) as 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') )
(** {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) -> (
let application_term = List.map (fun _ -> empty_thunked_term) taus in
let to_interpret = (Ast.EApp (e, application_term), Pos.no_pos) in
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)
| _ ->
Errors.raise_spanned_error "The interpretation of a program should always yield a tuple"
(Pos.get_position e) )
| _ ->
Errors.raise_spanned_error
"The interpreter can only interpret terms starting with functions having thunked arguments"
(Pos.get_position e)

228
src/catala/default_calculus/print.ml Normal file
View File

@ -0,0 +1,228 @@
(* 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. *)
module Pos = Utils.Pos
open Ast
let typ_needs_parens (e : typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ | TArray _ -> 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
| 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
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ t1
| TAny -> Format.fprintf fmt "any"
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" (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
| Map -> Format.fprintf fmt "map"
let format_ternop (fmt : Format.formatter) (op : ternop Pos.marked) : unit =
match Pos.unmark op with Fold -> Format.fprintf fmt "fold"
let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Format.fprintf fmt "%s"
( 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 -> "~"
| 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
| Length -> "length"
| IntToRat -> "int_to_rat" )
let needs_parens (e : expr Pos.marked) : bool =
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)
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
else Format.fprintf fmt "%a" format_expr e
in
match Pos.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
| ETuple es ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(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
| EArray es ->
Format.fprintf fmt "@[<hov 2>[%a]@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "@[%a@]" format_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
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
| EApp ((EAbs (_, binder, taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in
Format.fprintf fmt "@[%a%a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau, arg) ->
Format.fprintf fmt "@[@[<hov 2>let@ %a@ :@ %a@ =@ %a@]@ in@\n@]" format_var x
format_typ tau format_expr arg))
xs_tau_arg format_expr body
| EAbs (_, binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>λ@ %a →@ %a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau) ->
Format.fprintf fmt "@[<hov 2>(%a:@ %a)@]" format_var x format_typ tau))
xs_tau format_expr body
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
(op, Pos.no_pos) format_with_parens arg2
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]" format_expr
e1 format_expr e2 format_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
| EDefault (exceptions, just, cons) ->
if List.length exceptions = 0 then
Format.fprintf fmt "@[<hov 2>⟨%a@ ⊢@ %a⟩@]" format_expr just format_expr cons
else
Format.fprintf fmt "@[<hov 2>⟨%a@ |@ %a@ ⊢@ %a@ ⟩@]"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_expr)
exceptions format_expr just format_expr cons
| EAssert e' -> Format.fprintf fmt "@[<hov 2>assert@ (%a)@]" format_expr e'

446
src/catala/default_calculus/typing.ml Normal file
View File

@ -0,0 +1,446 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Typing for the default calculus. Because of the error terms, we perform type inference using the
classical W algorithm with union-find unification. *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module A = Ast
module Cli = Utils.Cli
(** {1 Types and unification} *)
module Any =
Utils.Uid.Make
(struct
type info = unit
let format_info fmt () = Format.fprintf fmt "any"
end)
()
(** 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 =
| 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
| TArray of typ Pos.marked UnionFind.elem
| TAny of Any.t
let typ_needs_parens (t : typ Pos.marked UnionFind.elem) : bool =
let t = UnionFind.get (UnionFind.find t) in
match Pos.unmark t with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : typ Pos.marked UnionFind.elem) : unit =
let format_typ_with_parens (fmt : Format.formatter) (t : typ Pos.marked UnionFind.elem) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
let typ = UnionFind.get (UnionFind.find typ) in
match Pos.unmark typ with
| TLit l -> Format.fprintf fmt "%a" Print.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
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ t1
| TAny d -> Format.fprintf fmt "any[%d]" (Any.hash d)
(** 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
let repr =
match (t1_repr, t2_repr) with
| (TLit tl1, _), (TLit tl2, _) when tl1 = tl2 -> None
| (TArrow (t11, t12), _), (TArrow (t21, t22), _) ->
unify t11 t21;
unify t12 t22;
None
| (TTuple ts1, _), (TTuple ts2, _) ->
List.iter2 unify ts1 ts2;
None
| (TEnum ts1, _), (TEnum ts2, _) ->
List.iter2 unify ts1 ts2;
None
| (TArray t1', _), (TArray t2', _) ->
unify t1' t2';
None
| (TAny _, _), (TAny _, _) -> None
| (TAny _, _), t_repr | t_repr, (TAny _, _) -> Some t_repr
| (_, t1_pos), (_, t2_pos) ->
(* 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, 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);
]
in
let t_union = UnionFind.union t1 t2 in
match repr with None -> () | Some t_repr -> UnionFind.set t_union t_repr
(** 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 (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 (Any.fresh ()), pos) in
let array_any = UnionFind.make (TArray any, pos) in
let any2 = UnionFind.make (TAny (Any.fresh ()), pos) in
let arr x y = UnionFind.make (TArrow (x, y), pos) in
match Pos.unmark op with
| A.Ternop A.Fold -> arr (arr any2 (arr any any2)) (arr any2 (arr array_any any2))
| A.Binop (A.And | A.Or) -> arr bt (arr bt bt)
| A.Binop (A.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.Binop A.Map -> arr (arr any any2) (arr array_any any2)
| 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
| A.Unop A.Length -> arr array_any it
| A.Unop A.IntToRat -> arr it rt
| 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.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)
| A.TArray t -> TArray (UnionFind.make (Pos.map_under_mark ast_to_typ t))
| A.TAny -> TAny (Any.fresh ())
let rec typ_to_ast (ty : typ Pos.marked UnionFind.elem) : A.typ Pos.marked =
Pos.map_under_mark
(fun ty ->
match ty with
| 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.TAny
| TArray t1 -> A.TArray (typ_to_ast t1))
(UnionFind.get (UnionFind.find ty))
(** {1 Double-directed typing} *)
type env = typ Pos.marked UnionFind.elem 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
=
let out =
match Pos.unmark e with
| EVar v -> (
match A.VarMap.find_opt (Pos.unmark v) env with
| Some t -> 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 (Any.fresh ())) 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 "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 (Any.fresh ())) 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 (Any.fresh ())) 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, UnionFind.make (ast_to_typ (Pos.unmark tau), Pos.get_position tau)))
(Array.to_list xs) taus
in
let env = List.fold_left (fun env (x, tau) -> A.VarMap.add x tau env) env xstaus in
List.fold_right
(fun (_, t_arg) (acc : typ Pos.marked UnionFind.elem) ->
UnionFind.make (TArrow (t_arg, acc), pos_binder))
xstaus
(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 (Any.fresh ())) 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')
| EArray es ->
let cell_type = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in
List.iter
(fun e' ->
let t_e' = typecheck_expr_bottom_up env e' in
unify cell_type t_e')
es;
UnionFind.make (Pos.same_pos_as (TArray cell_type) e)
in
(* Cli.debug_print (Format.asprintf "Found type of %a: %a" Print.format_expr e format_typ out); *)
out
(** 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 "Typechecking %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
| Some tau' -> ignore (unify tau tau')
| 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 (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 (Any.fresh ())) e))
| ETuple es -> (
let tau' = UnionFind.get (UnionFind.find tau) in
match Pos.unmark tau' with
| 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 "expected %a, got a tuple" format_typ tau)
(Pos.get_position e) )
| ETupleAccess (e1, n, _) -> (
let t1 = typecheck_expr_bottom_up env e1 in
match Pos.unmark (UnionFind.get (UnionFind.find t1)) with
| TTuple t1s -> (
match List.nth_opt t1s n with
| Some t1n -> unify t1n tau
| 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 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 "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 (Any.fresh ())) 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 (Any.fresh ())) 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
let xstaus =
List.map2
(fun x t_arg -> (x, UnionFind.make (Pos.map_under_mark ast_to_typ t_arg)))
(Array.to_list xs) t_args
in
let env = List.fold_left (fun env (x, t_arg) -> A.VarMap.add x t_arg env) env xstaus in
let t_out = typecheck_expr_bottom_up env body in
let t_func =
List.fold_right
(fun (_, t_arg) acc -> UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e))
xstaus t_out
in
unify t_func tau
else
Errors.raise_spanned_error
(Format.asprintf "function has %d variables but was supplied %d types" (Array.length xs)
(List.length t_args))
pos_binder
| EApp (e1, args) ->
let t_args = List.map (typecheck_expr_bottom_up env) args in
let te1 = typecheck_expr_bottom_up env e1 in
let t_func =
List.fold_right
(fun t_arg acc -> UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e))
t_args tau
in
unify te1 t_func
| EOp op ->
let op_typ = op_type (Pos.same_pos_as op e) in
unify op_typ tau
| 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 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 (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'))
| EArray es ->
let cell_type = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in
List.iter
(fun e' ->
let t_e' = typecheck_expr_bottom_up env e' in
unify cell_type t_e')
es;
unify tau (UnionFind.make (Pos.same_pos_as (TArray cell_type) 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))

146
src/catala/desugared/ast.ml Normal file
View File

@ -0,0 +1,146 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Abstract syntax tree of the desugared representation *)
module Pos = Utils.Pos
module Uid = Utils.Uid
(** {1 Names, Maps and Keys} *)
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
type t =
| Var of Scopelang.Ast.ScopeVar.t
| SubScopeVar of Scopelang.Ast.SubScopeName.t * Scopelang.Ast.ScopeVar.t
(** In this case, the [Uid.Var.t] lives inside the context of the subscope's original
declaration *)
let compare x y =
match (x, y) with
| Var x, Var y | Var x, SubScopeVar (_, y) | SubScopeVar (_, x), Var y ->
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
| SubScopeVar (s, v) ->
Format.fprintf fmt "%a.%a" Scopelang.Ast.SubScopeName.format_t s
Scopelang.Ast.ScopeVar.format_t v
let hash x =
match x with
| Var v -> Scopelang.Ast.ScopeVar.hash v
| SubScopeVar (_, v) -> Scopelang.Ast.ScopeVar.hash v
end
module ScopeDefMap : Map.S with type key = ScopeDef.t = Map.Make (ScopeDef)
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 * Scopelang.Ast.typ Pos.marked) option;
exception_to_rule : RuleName.t option;
}
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);
parameter =
( match have_parameter with
| Some typ -> Some (Scopelang.Ast.Var.make ("dummy", pos), typ)
| None -> None );
exception_to_rule = None;
}
let always_false_rule (pos : Pos.t) (have_parameter : Scopelang.Ast.typ Pos.marked option) : rule =
{
just = Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool true), pos);
cons = Bindlib.box (Scopelang.Ast.ELit (Dcalc.Ast.LBool false), pos);
parameter =
( match have_parameter with
| Some typ -> Some (Scopelang.Ast.Var.make ("dummy", pos), typ)
| None -> None );
exception_to_rule = None;
}
type assertion = Scopelang.Ast.expr Pos.marked Bindlib.box
type variation_typ = Increasing | Decreasing
type reference_typ = Decree | Law
type meta_assertion =
| FixedBy of reference_typ Pos.marked
| VariesWith of unit * variation_typ Pos.marked option
type scope = {
scope_vars : Scopelang.Ast.ScopeVarSet.t;
scope_sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
scope_uid : Scopelang.Ast.ScopeName.t;
scope_defs :
(rule RuleMap.t * Scopelang.Ast.typ Pos.marked * bool) (* is it a condition? *) ScopeDefMap.t;
scope_assertions : assertion list;
scope_meta_assertions : meta_assertion list;
}
type program = {
program_scopes : scope Scopelang.Ast.ScopeMap.t;
program_enums : Scopelang.Ast.enum_ctx;
program_structs : Scopelang.Ast.struct_ctx;
}
(** {1 Helpers} *)
let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
let add_locs (acc : Pos.t ScopeDefMap.t) (locs : Scopelang.Ast.LocationSet.t) :
Pos.t ScopeDefMap.t =
Scopelang.Ast.LocationSet.fold
(fun (loc, loc_pos) acc ->
ScopeDefMap.add
( match loc with
| 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)
locs acc
in
RuleMap.fold
(fun _ rule acc ->
let locs =
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

181
src/catala/desugared/dependency.ml Normal file
View File

@ -0,0 +1,181 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/} OCamlgraph} *)
module Pos = Utils.Pos
module Errors = Utils.Errors
(** {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. *)
module Vertex = struct
type t = Var of Scopelang.Ast.ScopeVar.t | SubScope of Scopelang.Ast.SubScopeName.t
let hash x =
match x with
| Var x -> Scopelang.Ast.ScopeVar.hash x
| SubScope x -> Scopelang.Ast.SubScopeName.hash x
let compare = compare
let equal x y =
match (x, y) with
| Var x, Var y -> Scopelang.Ast.ScopeVar.compare x y = 0
| SubScope x, SubScope y -> Scopelang.Ast.SubScopeName.compare x y = 0
| _ -> false
let format_t (fmt : Format.formatter) (x : t) : unit =
match x with
| Var v -> Scopelang.Ast.ScopeVar.format_t fmt v
| SubScope v -> Scopelang.Ast.SubScopeName.format_t fmt v
end
(** 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
let compare = compare
let default = Pos.no_pos
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 [])
(** Outputs an error in case of cycles. *)
let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.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 < 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!"
Scopelang.Ast.ScopeName.format_t scope.scope_uid)
(List.flatten
(List.map
(fun v ->
let var_str, var_info =
match v with
| Vertex.Var v ->
( Format.asprintf "%a" Scopelang.Ast.ScopeVar.format_t v,
Scopelang.Ast.ScopeVar.get_info v )
| Vertex.SubScope v ->
( Format.asprintf "%a" Scopelang.Ast.SubScopeName.format_t v,
Scopelang.Ast.SubScopeName.get_info v )
in
let succs = ScopeDependencies.succ_e g v in
let _, edge_pos, succ = List.find (fun (_, _, succ) -> List.mem succ scc) succs in
let succ_str =
match succ with
| Vertex.Var v -> Format.asprintf "%a" Scopelang.Ast.ScopeVar.format_t v
| Vertex.SubScope v -> Format.asprintf "%a" Scopelang.Ast.SubScopeName.format_t v
in
[
(Some ("Cycle variable " ^ var_str ^ ", declared:"), Pos.get_position var_info);
( Some ("Used here in the definition of another cycle variable " ^ succ_str ^ ":"),
edge_pos );
])
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 *)
let g =
Scopelang.Ast.ScopeVarSet.fold
(fun (v : Scopelang.Ast.ScopeVar.t) g -> ScopeDependencies.add_vertex g (Vertex.Var v))
scope.scope_vars g
in
let g =
Scopelang.Ast.SubScopeMap.fold
(fun (v : Scopelang.Ast.SubScopeName.t) _ g ->
ScopeDependencies.add_vertex g (Vertex.SubScope v))
scope.scope_sub_scopes g
in
let g =
Ast.ScopeDefMap.fold
(fun def_key (def, _, _) g ->
let fv = Ast.free_variables def in
Ast.ScopeDefMap.fold
(fun fv_def fv_def_pos g ->
match (def_key, fv_def) with
| Ast.ScopeDef.Var defined, Ast.ScopeDef.Var used ->
(* simple case *)
if used = defined then
(* variable definitions cannot be recursive *)
Errors.raise_spanned_error
(Format.asprintf
"The variable %a is used in one of its definitions, but recursion is \
forbidden in Catala"
Scopelang.Ast.ScopeVar.format_t defined)
fv_def_pos
else
let edge =
ScopeDependencies.E.create (Vertex.Var used) fv_def_pos (Vertex.Var defined)
in
ScopeDependencies.add_edge_e g edge
| Ast.ScopeDef.SubScopeVar (defined, _), Ast.ScopeDef.Var used ->
(* here we are defining the input of a subscope using a var of the scope *)
let edge =
ScopeDependencies.E.create (Vertex.Var used) fv_def_pos (Vertex.SubScope defined)
in
ScopeDependencies.add_edge_e g edge
| Ast.ScopeDef.SubScopeVar (defined, _), Ast.ScopeDef.SubScopeVar (used, _) ->
(* here we are defining the input of a scope with the output of another subscope *)
if used = defined then
(* subscopes are not recursive functions *)
Errors.raise_spanned_error
(Format.asprintf
"The subscope %a is used when defining one of its inputs, but recursion is \
forbidden in Catala"
Scopelang.Ast.SubScopeName.format_t defined)
fv_def_pos
else
let edge =
ScopeDependencies.E.create (Vertex.SubScope used) fv_def_pos
(Vertex.SubScope defined)
in
ScopeDependencies.add_edge_e g edge
| Ast.ScopeDef.Var defined, Ast.ScopeDef.SubScopeVar (used, _) ->
(* finally we define a scope var with the output of a subscope *)
let edge =
ScopeDependencies.E.create (Vertex.SubScope used) fv_def_pos (Vertex.Var defined)
in
ScopeDependencies.add_edge_e g edge)
fv g)
scope.scope_defs g
in
g

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.

283
src/catala/desugared/desugared_to_scope.ml Normal file
View File

@ -0,0 +1,283 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module Cli = Utils.Cli
(** {1 Rule tree construction} *)
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) (def_pos : Pos.t)
(is_func : Scopelang.Ast.Var.t option) (tree : rule_tree) :
Scopelang.Ast.expr Pos.marked Bindlib.box =
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) :
Scopelang.Ast.expr Pos.marked Bindlib.box =
match (is_func, rule.parameter) with
| Some new_param, Some (old_param, _) ->
let binder = Bindlib.bind_var old_param e in
Bindlib.box_apply2
(fun binder new_param -> Bindlib.subst binder new_param)
binder (Bindlib.box_var new_param)
| None, None -> e
| _ -> assert false
(* should not happen *)
in
let just = substitute_parameter rule.Ast.just in
let cons = substitute_parameter rule.Ast.cons in
let exceptions =
Bindlib.box_list (List.map (rule_tree_to_expr ~toplevel:false def_pos is_func) exceptions)
in
let default =
Bindlib.box_apply3
(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
| Some new_param, Some (_, typ) ->
if toplevel then
(* When we're creating a function from multiple defaults, we must check that the result
returned by the function is not empty *)
let default =
Bindlib.box_apply
(fun (default : Scopelang.Ast.expr * Pos.t) ->
( Scopelang.Ast.EApp
((Scopelang.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.ErrorOnEmpty), def_pos), [ default ]),
def_pos ))
default
in
Scopelang.Ast.make_abs (Array.of_list [ new_param ]) default def_pos [ typ ] def_pos
else default
| _ -> (* should not happen *) assert false
(** {1 AST translation} *)
(** 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) (is_cond : bool) : Scopelang.Ast.expr Pos.marked =
(* Here, we have to transform this list of rules into a default tree. *)
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 : 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
"some definitions of the same variable are functions while others aren't"
( List.map
(fun (_, r) ->
(Some "This definition is a function:", Pos.get_position (Bindlib.unbox r.Ast.cons)))
(Ast.RuleMap.bindings (Ast.RuleMap.filter is_func def))
@ List.map
(fun (_, r) ->
( Some "This definition is not a function:",
Pos.get_position (Bindlib.unbox r.Ast.cons) ))
(Ast.RuleMap.bindings (Ast.RuleMap.filter (fun n r -> not (is_func n r)) def)) )
in
let top_list = def_map_to_tree def_info is_def_func def in
let top_value =
(if is_cond then Ast.always_false_rule else Ast.empty_rule) Pos.no_pos is_def_func
in
Bindlib.unbox
(rule_tree_to_expr ~toplevel:true
(Ast.ScopeDef.get_position def_info)
(Option.map (fun _ -> Scopelang.Ast.Var.make ("ρ", Pos.no_pos)) is_def_func)
( match top_list with
| [] ->
(* In this case, there are no rules to define the expression *)
Leaf top_value
| _ -> Node (top_list, top_value) ))
(** 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;
let scope_ordering = Dependency.correct_computation_ordering scope_dependencies in
let scope_decl_rules =
List.flatten
(List.map
(fun vertex ->
match vertex with
| Dependency.Vertex.Var (var : Scopelang.Ast.ScopeVar.t) ->
let var_def, var_typ, is_cond =
Ast.ScopeDefMap.find (Ast.ScopeDef.Var var) scope.scope_defs
in
let expr_def = translate_def (Ast.ScopeDef.Var var) var_def var_typ is_cond in
[
Scopelang.Ast.Definition
( ( Scopelang.Ast.ScopeVar
(var, Pos.get_position (Scopelang.Ast.ScopeVar.get_info var)),
Pos.get_position (Scopelang.Ast.ScopeVar.get_info var) ),
var_typ,
expr_def );
]
| Dependency.Vertex.SubScope sub_scope_index ->
(* Before calling the sub_scope, we need to include all the re-definitions of
subscope parameters*)
let sub_scope =
Scopelang.Ast.SubScopeMap.find sub_scope_index scope.scope_sub_scopes
in
let sub_scope_vars_redefs =
Ast.ScopeDefMap.mapi
(fun def_key (def, def_typ, is_cond) ->
match def_key with
| Ast.ScopeDef.Var _ -> assert false (* should not happen *)
| Ast.ScopeDef.SubScopeVar (_, sub_scope_var) ->
let expr_def = translate_def def_key def def_typ is_cond in
let subscop_real_name =
Scopelang.Ast.SubScopeMap.find sub_scope_index scope.scope_sub_scopes
in
let var_pos =
Pos.get_position (Scopelang.Ast.ScopeVar.get_info sub_scope_var)
in
Scopelang.Ast.Definition
( ( Scopelang.Ast.SubScopeVar
( subscop_real_name,
(sub_scope_index, var_pos),
(sub_scope_var, var_pos) ),
var_pos ),
def_typ,
expr_def ))
(Ast.ScopeDefMap.filter
(fun def_key _def ->
match def_key with
| Ast.ScopeDef.Var _ -> false
| Ast.ScopeDef.SubScopeVar (sub_scope_index', _) ->
sub_scope_index = sub_scope_index')
scope.scope_defs)
in
let sub_scope_vars_redefs =
List.map snd (Ast.ScopeDefMap.bindings sub_scope_vars_redefs)
in
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 ->
let _, typ, _ = Ast.ScopeDefMap.find (Ast.ScopeDef.Var var) scope.scope_defs in
Scopelang.Ast.ScopeVarMap.add var typ acc)
scope.scope_vars Scopelang.Ast.ScopeVarMap.empty
in
{
Scopelang.Ast.scope_decl_name = scope.scope_uid;
Scopelang.Ast.scope_decl_rules;
Scopelang.Ast.scope_sig;
}
(** {1 API} *)
let translate_program (pgrm : Ast.program) : Scopelang.Ast.program =
{
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;
}

8
src/catala/desugared/dune Normal file
View File

@ -0,0 +1,8 @@
(library
(name desugared)
(public_name catala.desugared)
(libraries utils dcalc scopelang ocamlgraph))
(documentation
(package catala)
(mld_files desugared))

108
src/catala/driver.ml
View File

@ -12,14 +12,22 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
module Cli = Utils.Cli
module Errors = Utils.Errors
module Pos = Utils.Pos
(** 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)
let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
(wrap_weaved_output : bool) (pygmentize_loc : string option) (backend : string)
(language : string option) (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 source_file with FileName _ -> () | Contents c -> Cli.contents := c);
(match max_prec_digits with None -> () | Some i -> Cli.max_prec_digits := i);
let language =
match language with
| Some l ->
@ -35,15 +43,21 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
if backend = "Makefile" then Cli.Makefile
else if backend = "LaTeX" then Cli.Latex
else if backend = "HTML" then Cli.Html
else if backend = "run" then Cli.Run
else if backend = "Interpret" then Cli.Run
else
Errors.raise_error
(Printf.sprintf "The selected backend (%s) is not supported by Catala" backend)
in
let program = 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
let source_file =
match source_file with
| FileName f -> f
| Contents _ ->
Errors.raise_error "The Makefile backend does not work if the input is not a file"
in
let output_file =
match output_file with
| Some f -> f
@ -61,72 +75,94 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
0
| Cli.Latex | Cli.Html ->
let language : Cli.backend_lang = Cli.to_backend_lang language in
let source_file =
match source_file with
| FileName f -> f
| Contents _ ->
Errors.raise_error
"The literate programming backends do not work if the input is not a file"
in
Cli.debug_print
(Printf.sprintf "Weaving literate program into %s"
(match backend with Cli.Latex -> "LaTeX" | Cli.Html -> "HTML" | _ -> assert false));
( match backend with
| Cli.Latex -> "LaTeX"
| Cli.Html -> "HTML"
| _ -> assert false (* should not happen *) ));
let output_file =
match output_file with
| Some f -> f
| None -> (
Filename.remove_extension source_file
^ match backend with Cli.Latex -> ".tex" | Cli.Html -> ".html" | _ -> assert false )
^
match backend with Cli.Latex -> ".tex" | Cli.Html -> ".html" | _ -> assert false
(* should not happen *) )
in
let oc = open_out output_file in
let weave_output =
match backend with
| Cli.Latex -> Latex.ast_to_latex language
| Cli.Html -> Html.ast_to_html pygmentize_loc language
| Cli.Latex -> Literate.Latex.ast_to_latex language
| Cli.Html -> Literate.Html.ast_to_html pygmentize_loc language
| _ -> assert false
(* should not happen *)
in
Cli.debug_print (Printf.sprintf "Writing to %s" output_file);
let fmt = Format.formatter_of_out_channel oc in
if wrap_weaved_output then
match backend with
| Cli.Latex ->
Latex.wrap_latex program.Catala_ast.program_source_files pygmentize_loc language fmt
(fun fmt -> weave_output fmt program)
Literate.Latex.wrap_latex program.Surface.Ast.program_source_files pygmentize_loc
language fmt (fun fmt -> weave_output fmt program)
| Cli.Html ->
Html.wrap_html program.Catala_ast.program_source_files pygmentize_loc language fmt
(fun fmt -> weave_output fmt program)
| _ -> assert false
Literate.Html.wrap_html program.Surface.Ast.program_source_files pygmentize_loc
language fmt (fun fmt -> weave_output fmt program)
| _ -> assert false (* should not happen *)
else weave_output fmt program;
close_out oc;
0
| Cli.Run ->
let ctxt = Name_resolution.form_context program in
Cli.debug_print "Name resolution...";
let ctxt = Surface.Name_resolution.form_context program in
let scope_uid =
match ex_scope with
| None -> Errors.raise_error "No scope was provided for execution."
| Some name -> (
match Uid.IdentMap.find_opt name ctxt.scope_idmap with
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| None ->
Errors.raise_error
(Printf.sprintf "There is no scope %s inside the program." name)
(Printf.sprintf "There is no scope \"%s\" inside the program." name)
| Some uid -> uid )
in
let prgm = Desugaring.translate_program_to_scope ctxt program in
let scope =
match Uid.ScopeMap.find_opt scope_uid prgm with
| Some scope -> scope
| None ->
let scope_info = Uid.Scope.get_info scope_uid in
Errors.raise_spanned_error
(Printf.sprintf
"Scope %s does not define anything, and therefore cannot be executed"
(Pos.unmark scope_info))
(Pos.get_position scope_info)
Cli.debug_print "Desugaring...";
let prgm = Surface.Desugaring.desugar_program ctxt program in
Cli.debug_print "Collecting rules...";
let prgm = Desugared.Desugared_to_scope.translate_program prgm in
Cli.debug_print "Translating to default calculus...";
let prgm = Scopelang.Scope_to_dcalc.translate_program prgm scope_uid in
(* Cli.debug_print (Format.asprintf "Output program:@\n%a" Dcalc.Print.format_expr prgm); *)
Cli.debug_print "Typechecking...";
let _typ = Dcalc.Typing.infer_type prgm in
(* Cli.debug_print (Format.asprintf "Typechecking results :@\n%a" Dcalc.Print.format_typ
typ); *)
Cli.debug_print "Starting interpretation...";
let results = Dcalc.Interpreter.interpret_program prgm in
let results =
List.sort
(fun (v1, _) (v2, _) -> String.compare (Bindlib.name_of v1) (Bindlib.name_of v2))
results
in
let exec_ctxt = Scope_interpreter.execute_scope ctxt prgm scope in
Lambda_interpreter.ExecContext.iter
(fun context_key value ->
Cli.result_print
(Format.asprintf "Computation successful!%s"
(if List.length results > 0 then " Results:" else ""));
List.iter
(fun (var, result) ->
Cli.result_print
(Printf.sprintf "%s -> %s"
(Lambda_interpreter.ExecContextKey.format_t context_key)
(Format_lambda.print_term ((value, Pos.no_pos), TDummy))))
exec_ctxt;
(Format.asprintf "@[<hov 2>%s@ =@ %a@]" (Bindlib.name_of var) Dcalc.Print.format_expr
result))
results;
0
with Errors.StructuredError (msg, pos) ->
Cli.error_print (Errors.print_structured_error msg pos);
exit (-1)
-1
let main () = Cmdliner.Term.exit @@ Cmdliner.Term.eval (Cli.catala_t driver, Cli.info)
let main () =
Cmdliner.Term.exit @@ Cmdliner.Term.eval (Cli.catala_t (fun f -> driver (FileName f)), Cli.info)

8
src/catala/dune
View File

@ -1,11 +1,7 @@
(include_subdirs unqualified)
(library
(public_name catala)
(libraries ANSITerminal sedlex menhirLib re cmdliner dune-build-info
ocamlgraph)
(preprocess
(pps sedlex.ppx)))
(libraries catala.utils catala.surface catala.desugared catala.literate
catala.dcalc))
(documentation
(package catala))

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}}
}

84
src/catala/lambda_calculus/format_lambda.ml
View File

@ -1,84 +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: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
module IdentMap = Map.Make (String)
(* Printing functions for Lambda_ast.term *)
let rec format_typ (ty : Lambda_ast.typ) : string =
match ty with
| TBool -> "bool"
| TInt -> "int"
| TArrow (t1, t2) -> Format.sprintf "(%s) -> (%s)" (format_typ t1) (format_typ t2)
| TDummy -> "??"
(** Operator printer *)
let print_op (op : Lambda_ast.op) : string =
match op with
| Binop binop -> (
match binop with
| And -> "and"
| Or -> "or"
| Add -> "+"
| Sub -> "-"
| Mult -> "*"
| Div -> "/"
| Lt -> "<"
| Lte -> "<="
| Gt -> ">"
| Gte -> ">="
| Eq -> "="
| Neq -> "!=" )
| Unop Not -> "not"
| Unop Minus -> "-"
let rec repeat_string n s = if n = 0 then "" else s ^ repeat_string (n - 1) s
let print_prefix (prefix : Lambda_ast.var_prefix) : string =
match prefix with
| NoPrefix -> ""
| SubScopePrefix s -> Uid.SubScope.format_t s ^ "."
| CallerPrefix (i, s) -> (
repeat_string i "CALLER."
^ match s with None -> "" | Some s -> Uid.SubScope.format_t s ^ "." )
(** Print Lambda_ast.term *)
let rec print_term (((t, _), _) : Lambda_ast.term) : string =
match t with
| EVar (s, uid) -> Printf.sprintf "%s%s" (print_prefix s) (Uid.Var.format_t uid)
| ELocalVar uid -> Uid.LocalVar.format_t uid
| EFun (binders, body) ->
let sbody = print_term body in
Printf.sprintf "fun %s -> %s"
(binders |> List.map (fun (uid, _) -> Uid.LocalVar.format_t uid) |> String.concat " ")
sbody
| EApp (f, args) ->
Printf.sprintf "(%s) [%s]" (print_term f) (args |> List.map print_term |> String.concat ";")
| EIfThenElse (tif, tthen, telse) ->
Printf.sprintf "IF %s THEN %s ELSE %s" (print_term tif) (print_term tthen) (print_term telse)
| EInt i -> Printf.sprintf "%d" i
| EBool b -> if b then "true" else "false"
| EDec (i, f) -> Printf.sprintf "%d.%d" i f
| EOp op -> print_op op
| EDefault t -> print_default_term t
and print_default_term (term : Lambda_ast.default_term) : string =
( term.defaults
|> List.mapi (fun i (cond, body) ->
Printf.sprintf "[%d]\t%s => %s" i (print_term cond) (print_term body))
|> String.concat "\n" )
^ "\n"
^ ( term.ordering
|> List.map (fun (hi, lo) -> Printf.sprintf "%d > %d" hi lo)
|> String.concat ", " )

120
src/catala/lambda_calculus/lambda_ast.ml
View File

@ -1,120 +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: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(* TDummy means the term is not typed *)
type typ = TBool | TInt | TArrow of typ * typ | TDummy
type literal = Catala_ast.literal
type binop = Catala_ast.binop
type unop = Catala_ast.unop
type op = Binop of binop | Unop of unop
type binding = Uid.LocalVar.t * typ
type var_prefix =
(* See [Scope_interpreter] for details about the meaning of this case. The `int` means the number
of times you have to go to the parent caller to get the variable *)
| CallerPrefix of int * Uid.SubScope.t option
| NoPrefix
| SubScopePrefix of Uid.SubScope.t
type term = untyped_term Pos.marked * typ
and untyped_term =
| EVar of var_prefix * Uid.Var.t
(** This case is only for terms embedded in the scope language *)
| ELocalVar of Uid.LocalVar.t
| EFun of binding list * term
| EApp of term * term list
| EIfThenElse of term * term * term
| EInt of int
| EBool of bool
| EDec of int * int
| EOp of op
| EDefault of default_term
(* (x,y) in ordering means that default x has precedence over default y : if both are true then x
would be choser over y *)
and default_term = { defaults : (term * term) list; ordering : (int * int) list }
let untype (((term, _), _) : term) : untyped_term = term
let get_pos (((_, pos), _) : term) : Pos.t = pos
let get_typ ((_, typ) : term) : typ = typ
let map_untype (f : untyped_term -> untyped_term) (((term, pos), typ) : term) : term =
((f term, pos), typ)
let map_untype2 (f : untyped_term -> untyped_term -> untyped_term) (((t1, pos), typ) : term)
(((t2, _), _) : term) : term =
((f t1 t2, pos), typ)
let empty_default_term : default_term = { defaults = []; ordering = [] }
let add_default (just : term) (cons : term) (term : default_term) =
{ term with defaults = term.defaults @ [ (just, cons) ] }
(** Merge two defalts terms, taking into account that one has higher precedence than the other *)
let merge_default_terms (lo_term : default_term) (hi_term : default_term) : default_term =
let n = List.length lo_term.defaults in
let n' = List.length hi_term.defaults in
let defaults = lo_term.defaults @ hi_term.defaults in
let rec add_hi_prec = function
| [] -> lo_term.ordering
| (k, k') :: xs -> (n + k, n + k') :: add_hi_prec xs
in
let prec = add_hi_prec hi_term.ordering in
let gen_prec lo hi =
List.fold_left
(fun acc x_lo ->
let sub_list = List.fold_left (fun acc' x_hi -> (x_hi, x_lo) :: acc') [] hi in
sub_list :: acc)
[] lo
|> List.flatten
in
let rec gen_list i j acc = if i = j then acc else gen_list (i + 1) j (i :: acc) in
let gen_list i j = gen_list i j [] in
let prec' = gen_prec (gen_list 0 n) (gen_list n (n + n')) in
{ defaults; ordering = prec @ prec' }
(** Returns the free variables (scope language variables) of a term. Used to build the dependency
graph *)
let rec term_fv (term : term) : Uid.ScopeDefSet.t =
match untype term with
| EVar (NoPrefix, uid) -> Uid.ScopeDefSet.singleton (Uid.ScopeDef.Var uid)
| EVar (SubScopePrefix sub_uid, uid) ->
Uid.ScopeDefSet.singleton (Uid.ScopeDef.SubScopeVar (sub_uid, uid))
| EVar (CallerPrefix _, _) ->
Uid.ScopeDefSet.empty
(* here we return an empty dependency because when calling a subscope, the variables of the
caller graph needed for it are already computed *)
| ELocalVar _ -> Uid.ScopeDefSet.empty
| EFun (_, body) -> term_fv body
| EApp (f, args) ->
List.fold_left (fun fv arg -> Uid.ScopeDefSet.union fv (term_fv arg)) (term_fv f) args
| EIfThenElse (t_if, t_then, t_else) ->
Uid.ScopeDefSet.union (term_fv t_if) (Uid.ScopeDefSet.union (term_fv t_then) (term_fv t_else))
| EDefault default -> default_term_fv default
| EBool _ | EInt _ | EDec _ | EOp _ -> Uid.ScopeDefSet.empty
and default_term_fv (term : default_term) : Uid.ScopeDefSet.t =
List.fold_left
(fun acc (cond, body) ->
let fv = Uid.ScopeDefSet.union (term_fv cond) (term_fv body) in
Uid.ScopeDefSet.union fv acc)
Uid.ScopeDefSet.empty term.defaults

218
src/catala/lambda_calculus/lambda_interpreter.ml
View File

@ -1,218 +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: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
open Lambda_ast
type uid = int
type scope_uid = int
module ExecContextKey = struct
type t = LocalVar of Uid.LocalVar.t | ScopeVar of var_prefix * Uid.Var.t
let compare x y =
match (x, y) with
| LocalVar x, LocalVar y -> Uid.LocalVar.compare x y
| ScopeVar (x1, x2), ScopeVar (y1, y2) -> (
match (x1, y1) with
| NoPrefix, NoPrefix | CallerPrefix _, CallerPrefix _ -> Uid.Var.compare x2 y2
| SubScopePrefix x1, SubScopePrefix y1 ->
let sub_comp = Uid.SubScope.compare x1 y1 in
if sub_comp = 0 then Uid.Var.compare x2 y2 else sub_comp
| _ -> compare x y )
| _ -> compare x y
let format_t (x : t) : string =
match x with
| LocalVar x -> Uid.LocalVar.format_t x
| ScopeVar (prefix, var) -> Format_lambda.print_prefix prefix ^ Uid.Var.format_t var
end
module ExecContext = Map.Make (ExecContextKey)
type exec_context = Lambda_ast.untyped_term ExecContext.t
let format_exec_context (ctx : exec_context) =
String.concat "\n"
(List.map
(fun (key, value) ->
Printf.sprintf "%s -> %s" (ExecContextKey.format_t key)
(Format_lambda.print_term ((value, Pos.no_pos), TDummy)))
(ExecContext.bindings ctx))
let empty_exec_ctxt = ExecContext.empty
let raise_default_conflict (def : Uid.ScopeDef.t) (true_pos : Pos.t list) (false_pos : Pos.t list) =
let var_str = Uid.ScopeDef.format_t def in
let var_pos =
match def with
| Uid.ScopeDef.SubScopeVar (_, v) | Uid.ScopeDef.Var v -> Pos.get_position (Uid.Var.get_info v)
in
if List.length true_pos = 0 then
let justifications : (string option * Pos.t) list =
List.map (fun pos -> (Some "This justification is false:", pos)) false_pos
in
Errors.raise_multispanned_error
(Printf.sprintf "Default logic error for variable %s: no justification is true." var_str)
( (Some (Printf.sprintf "The error concerns this variable %s" var_str), var_pos)
:: justifications )
else
let justifications : (string option * Pos.t) list =
List.map (fun pos -> (Some "This justification is true:", pos)) true_pos
in
Errors.raise_multispanned_error
"Default logic conflict, multiple justifications are true but are not related by a precedence"
( (Some (Printf.sprintf "The conflict concerns this variable %s" var_str), var_pos)
:: justifications )
let rec eval_term (top_uid : Uid.ScopeDef.t) (exec_ctxt : exec_context) (term : Lambda_ast.term) :
Lambda_ast.term =
let (term, pos), typ = term in
let evaled_term =
match term with
| EFun _ | EInt _ | EDec _ | EBool _ | EOp _ -> term (* already a value *)
| ELocalVar uid -> (
let ctxt_key = ExecContextKey.LocalVar uid in
match ExecContext.find_opt ctxt_key exec_ctxt with
| Some t -> t
| None ->
Errors.raise_spanned_error
(Printf.sprintf "Local Variable %s is not defined" (Uid.LocalVar.format_t uid))
pos )
| EVar (prefix, uid) -> (
let ctxt_key = ExecContextKey.ScopeVar (prefix, uid) in
match ExecContext.find_opt ctxt_key exec_ctxt with
| Some t -> t
| None ->
Errors.raise_spanned_error
(Printf.sprintf "Variable %s is not defined" (Uid.Var.format_t uid))
pos )
| EApp (f, args) -> (
(* First evaluate and match the function body *)
let f = f |> eval_term top_uid exec_ctxt |> Lambda_ast.untype in
match f with
| EFun (bindings, body) ->
let exec_ctxt =
List.fold_left2
(fun ctxt arg (uid, _) ->
ExecContext.add (ExecContextKey.LocalVar uid)
(arg |> eval_term top_uid exec_ctxt |> Lambda_ast.untype)
ctxt)
exec_ctxt args bindings
in
eval_term top_uid exec_ctxt body |> Lambda_ast.untype
| EOp op -> (
let args =
List.map (fun arg -> arg |> eval_term top_uid exec_ctxt |> Lambda_ast.untype) args
in
match op with
| Binop binop -> (
match binop with
| And | Or ->
let b1, b2 =
match args with [ EBool b1; EBool b2 ] -> (b1, b2) | _ -> assert false
(* should not happen *)
in
EBool (if binop = And then b1 && b2 else b1 || b2)
| _ -> (
let i1, i2 =
match args with [ EInt i1; EInt i2 ] -> (i1, i2) | _ -> assert false
(* should not happen *)
in
match binop with
| Add | Sub | Mult | Div ->
let op_arith =
match binop with
| Add -> ( + )
| Sub -> ( - )
| Mult -> ( * )
| Div -> ( / )
| _ -> assert false
(* should not happen *)
in
EInt (op_arith i1 i2)
| _ ->
let op_comp =
match binop with
| Lt -> ( < )
| Lte -> ( <= )
| Gt -> ( > )
| Gte -> ( >= )
| Eq -> ( = )
| Neq -> ( <> )
| _ -> assert false
(* should not happen *)
in
EBool (op_comp i1 i2) ) )
| Unop Minus -> (
match args with
| [ EInt i ] -> EInt (-i)
| _ -> assert false (* should not happen *) )
| Unop Not -> (
match args with
| [ EBool b ] -> EBool (not b)
| _ -> assert false (* should not happen *) ) )
| _ -> assert false )
| EIfThenElse (t_if, t_then, t_else) ->
( match eval_term top_uid exec_ctxt t_if |> Lambda_ast.untype with
| EBool b ->
if b then eval_term top_uid exec_ctxt t_then else eval_term top_uid exec_ctxt t_else
| _ -> assert false (* should not happen *) )
|> Lambda_ast.untype
| EDefault t -> (
match eval_default_term top_uid exec_ctxt t with
| Ok value -> value |> Lambda_ast.untype
| Error (true_pos, false_pos) -> raise_default_conflict top_uid true_pos false_pos )
in
((evaled_term, pos), typ)
(* Evaluates a default term : see the formalization for an insight about this operation *)
and eval_default_term (top_uid : Uid.ScopeDef.t) (exec_ctxt : exec_context)
(term : Lambda_ast.default_term) : (Lambda_ast.term, Pos.t list * Pos.t list) result =
(* First filter out the term which justification are false *)
let defaults_numbered : (int * (term * term)) list =
List.mapi (fun (x : int) (y : term * term) -> (x, y)) term.defaults
in
let candidates : 'a list =
List.filter
(fun (_, (cond, _)) ->
match eval_term top_uid exec_ctxt cond |> Lambda_ast.untype with
| EBool b -> b
| _ -> assert false
(* should not happen *))
defaults_numbered
in
(* Now filter out the terms that have a predecessor which justification is true *)
let module ISet = Set.Make (Int) in
let key_candidates = List.fold_left (fun acc (x, _) -> ISet.add x acc) ISet.empty candidates in
let chosen_one =
List.fold_left
(fun set (lo, hi) -> if ISet.mem lo set && ISet.mem hi set then ISet.remove hi set else set)
key_candidates term.ordering
in
match ISet.elements chosen_one with
| [ x ] ->
let _, (_, cons) = List.find (fun (i, _) -> i = x) defaults_numbered in
Ok (eval_term top_uid exec_ctxt cons)
| xs ->
let true_pos =
xs
|> List.map (fun x ->
List.find (fun (i, _) -> i = x) defaults_numbered |> snd |> fst |> Lambda_ast.get_pos)
in
let false_pos : Pos.t list =
List.map (fun (_, (cond, _)) -> Lambda_ast.get_pos cond) defaults_numbered
in
Error (true_pos, false_pos)

138
src/catala/lambda_calculus/lambda_typechecker.ml
View File

@ -1,138 +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: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Checks that a term is well typed and annotate it *)
let rec type_term (ctxt : Name_resolution.context) (local_ctx : Lambda_ast.typ Uid.LocalVarMap.t)
(((t, pos), _) : Lambda_ast.term) : Lambda_ast.term =
match t with
| EVar (s, uid) ->
(* so here we can ignore the subscope uid because the uid of the variable already corresponds
to the uid of the variable in its original scope *)
let typ = Name_resolution.get_var_typ ctxt uid in
((EVar (s, uid), pos), typ)
| ELocalVar uid ->
let typ = Uid.LocalVarMap.find uid local_ctx in
((ELocalVar uid, pos), typ)
| EFun (bindings, body) ->
let local_ctx =
List.fold_left
(fun local_ctx (binding, ty) -> Uid.LocalVarMap.add binding ty local_ctx)
local_ctx bindings
in
let body = type_term ctxt local_ctx body in
let ret_typ = Lambda_ast.get_typ body in
let rec build_typ = function
| [] -> ret_typ
| (_, arg_t) :: args -> TArrow (arg_t, build_typ args)
in
let fun_typ = build_typ bindings in
((EFun (bindings, body), pos), fun_typ)
| EApp (f, args) ->
let f = type_term ctxt local_ctx f in
let f_typ = Lambda_ast.get_typ f in
let args = List.map (type_term ctxt local_ctx) args in
let args_typ =
List.map (fun arg -> (Lambda_ast.get_typ arg, Pos.get_position (fst arg))) args
in
let rec check_arrow_typ f_typ args_typ =
match (f_typ, args_typ) with
| typ, [] -> typ
| Lambda_ast.TArrow (arg_typ, ret_typ), fst_typ :: typs ->
let fst_typ_s = Pos.unmark fst_typ in
if arg_typ = fst_typ_s then check_arrow_typ ret_typ typs
else
Errors.raise_multispanned_error "error when comparing types of function arguments"
[
( Some (Printf.sprintf "expected type %s" (Format_lambda.format_typ f_typ)),
Pos.get_position (fst f) );
( Some (Printf.sprintf "got type %s" (Format_lambda.format_typ fst_typ_s)),
Pos.get_position fst_typ );
]
| _ ->
Errors.raise_multispanned_error "wrong number of arguments for function call"
[
( Some (Printf.sprintf "expected type %s" (Format_lambda.format_typ f_typ)),
Pos.get_position (fst f) );
( Some
(Printf.sprintf "got type %s"
(String.concat " -> "
(List.map (fun (ty, _) -> Format_lambda.format_typ ty) args_typ))),
Pos.get_position (List.hd args_typ) );
]
in
let ret_typ = check_arrow_typ f_typ args_typ in
((EApp (f, args), pos), ret_typ)
| EIfThenElse (t_if, t_then, t_else) ->
let t_if = type_term ctxt local_ctx t_if in
let typ_if = Lambda_ast.get_typ t_if in
let t_then = type_term ctxt local_ctx t_then in
let typ_then = Lambda_ast.get_typ t_then in
let t_else = type_term ctxt local_ctx t_else in
let typ_else = Lambda_ast.get_typ t_else in
if typ_if <> TBool then
Errors.raise_spanned_error
(Format.sprintf "expecting type bool, got type %s" (Format_lambda.format_typ typ_if))
(Pos.get_position (fst t_if))
else if typ_then <> typ_else then
Errors.raise_multispanned_error
"expecting same types for the true and false branches of the conditional"
[
( Some (Format.sprintf "the true branch has type %s" (Format_lambda.format_typ typ_then)),
Pos.get_position (fst t_then) );
( Some
(Format.sprintf "the false branch has type %s" (Format_lambda.format_typ typ_else)),
Pos.get_position (fst t_else) );
]
else ((EIfThenElse (t_if, t_then, t_else), pos), typ_then)
| EInt _ | EDec _ -> ((t, pos), TInt)
| EBool _ -> ((t, pos), TBool)
| EOp op ->
let typ =
match op with
| Binop binop -> (
match binop with
| And | Or -> Lambda_ast.TArrow (TBool, TArrow (TBool, TBool))
| Add | Sub | Mult | Div -> TArrow (TInt, TArrow (TInt, TInt))
| Lt | Lte | Gt | Gte | Eq | Neq -> TArrow (TInt, TArrow (TInt, TBool)) )
| Unop Minus -> TArrow (TInt, TInt)
| Unop Not -> TArrow (TBool, TBool)
in
((t, pos), typ)
| EDefault t ->
let defaults =
List.map
(fun (just, cons) ->
let just_t = type_term ctxt local_ctx just in
if Lambda_ast.get_typ just_t <> TBool then
let cons = type_term ctxt local_ctx cons in
(just_t, cons)
else
Errors.raise_spanned_error
(Format.sprintf "expected type of default condition to be bool, got %s"
(Format_lambda.format_typ (Lambda_ast.get_typ just)))
(Pos.get_position (fst just)))
t.defaults
in
let typ_cons = List.hd defaults |> snd |> snd in
List.iter
(fun (_, cons) ->
if Lambda_ast.get_typ cons <> typ_cons then
Errors.raise_spanned_error
(Format.sprintf "expected default condition to be of type %s, got type %s"
(Format_lambda.format_typ (Lambda_ast.get_typ cons))
(Format_lambda.format_typ typ_cons))
(Pos.get_position (fst cons))
else ())
defaults;
((EDefault { t with defaults }, pos), typ_cons)

8
src/catala/literate_programming/dune Normal file
View File

@ -0,0 +1,8 @@
(library
(name literate)
(public_name catala.literate)
(libraries re utils surface))
(documentation
(package catala)
(mld_files literate))

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

@ -15,18 +15,32 @@
(** This modules weaves the source code and the legislative text together into a document that law
professionals can understand. *)
module A = Catala_ast
module Pos = Utils.Pos
module Cli = Utils.Cli
module Errors = Utils.Errors
module A = Surface.Ast
module P = Printf
module R = Re.Pcre
module C = Cli
let pre_html (s : string) = s
(** {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 =
@ -62,9 +76,7 @@ let wrap_html (source_files : string list) (custom_pygments : string option)
| `Fr -> "Implémentation de texte législatif"
| `En -> "Legislative text implementation" )
(match language with `Fr -> "Document généré par" | `En -> "Document generated by")
( match Build_info.V1.version () with
| None -> "n/a"
| Some v -> Build_info.V1.Version.to_string v )
Utils.Cli.version
( match language with
| `Fr -> "Fichiers sources tissés dans ce document"
| `En -> "Source files weaved in this document" )
@ -84,6 +96,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)));
@ -118,12 +131,14 @@ 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 =
match i with
| A.LawText t -> Format.fprintf fmt "<p class='law-text'>%s</p>" (pre_html t)
| A.LawText t ->
let t = pre_html t in
if t = "" then () else Format.fprintf fmt "<p class='law-text'>%s</p>" t
| A.CodeBlock (_, c) ->
let date = "\\d\\d/\\d\\d/\\d\\d\\d\\d" in
let syms = R.regexp (date ^ "|!=|<=|>=|--|->|\\*|\\/") in
@ -141,7 +156,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 =
@ -155,6 +169,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"
@ -172,12 +187,16 @@ let rec law_structure_to_html (custom_pygments : string option) (language : C.ba
Format.fprintf fmt "\n</div>"
| A.MetadataBlock (b, c) ->
law_article_item_to_html custom_pygments language fmt (A.CodeBlock (b, c))
| A.IntermediateText t -> Format.fprintf fmt "<p class='law-text'>%s</p>" (pre_html t)
| A.IntermediateText t ->
let t = pre_html t in
if t = "" then () else Format.fprintf fmt "<p class='law-text'>%s</p>" t
let program_item_to_html (custom_pygments : string option) (language : C.backend_lang)
(fmt : Format.formatter) (i : A.program_item) : unit =
match i with A.LawStructure s -> law_structure_to_html custom_pygments language fmt s
(** {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

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

@ -15,10 +15,16 @@
(** This modules weaves the source code and the legislative text together into a document that law
professionals can understand. *)
module A = Catala_ast
module Pos = Utils.Pos
module Cli = Utils.Cli
module Errors = Utils.Errors
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
@ -30,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
@ -54,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\
@ -81,9 +89,7 @@ let wrap_latex (source_files : string list) (custom_pygments : string option)
| `Fr -> "Implémentation de texte législatif"
| `En -> "Legislative text implementation" )
(match language with `Fr -> "Document généré par" | `En -> "Document generated by")
( match Build_info.V1.version () with
| None -> "n/a"
| Some v -> Build_info.V1.Version.to_string v )
Utils.Cli.version
( match language with
| `Fr -> "Fichiers sources tissés dans ce document"
| `En -> "Source files weaved in this document" )
@ -104,6 +110,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
@ -119,6 +126,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
@ -129,18 +138,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 =
@ -157,6 +157,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
@ -174,7 +183,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))
@ -184,6 +193,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.

152
src/catala/pos.ml
View File

@ -1,152 +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. *)
type t = Lexing.position * Lexing.position
let from_info (file : string) (sline : int) (scol : int) (eline : int) (ecol : int) : t =
let spos =
{ Lexing.pos_fname = file; Lexing.pos_lnum = sline; Lexing.pos_cnum = scol; Lexing.pos_bol = 1 }
in
let epos =
{ Lexing.pos_fname = file; Lexing.pos_lnum = eline; Lexing.pos_cnum = ecol; Lexing.pos_bol = 1 }
in
(spos, epos)
let get_start_line (pos : t) : int =
let s, _ = pos in
s.Lexing.pos_lnum
let get_start_column (pos : t) : int =
let s, _ = pos in
s.Lexing.pos_cnum - s.Lexing.pos_bol + 1
let get_end_line (pos : t) : int =
let _, e = pos in
e.Lexing.pos_lnum
let get_end_column (pos : t) : int =
let _, e = pos in
e.Lexing.pos_cnum - e.Lexing.pos_bol + 1
let get_file (pos : t) : string = (fst pos).Lexing.pos_fname
let to_string (pos : t) : string =
let s, e = pos in
Printf.sprintf "in file %s, from %d:%d to %d:%d" s.Lexing.pos_fname s.Lexing.pos_lnum
(s.Lexing.pos_cnum - s.Lexing.pos_bol + 1)
e.Lexing.pos_lnum
(e.Lexing.pos_cnum - e.Lexing.pos_bol + 1)
let to_string_short (pos : t) : string =
let s, e = pos in
Printf.sprintf "%s;%d:%d--%d:%d" s.Lexing.pos_fname s.Lexing.pos_lnum
(s.Lexing.pos_cnum - s.Lexing.pos_bol + 1)
e.Lexing.pos_lnum
(e.Lexing.pos_cnum - e.Lexing.pos_bol + 1)
let indent_number (s : string) : int =
try
let rec aux (i : int) = if s.[i] = ' ' then aux (i + 1) else i in
aux 0
with Invalid_argument _ -> String.length s
let retrieve_loc_text (pos : t) : string =
let filename = get_file pos in
let blue_style = [ ANSITerminal.Bold; ANSITerminal.blue ] in
if filename = "" then "No position information"
else
let sline = get_start_line pos in
let eline = get_end_line pos in
let oc =
try open_in filename
with Sys_error _ ->
Cli.error_print (Printf.sprintf "File not found : \"%s\"" filename);
exit (-1)
in
let input_line_opt () : string option = try Some (input_line oc) with End_of_file -> None in
let print_matched_line (line : string) (line_no : int) : string =
let line_indent = indent_number line in
let error_indicator_style = [ ANSITerminal.red; ANSITerminal.Bold ] in
line
^
if line_no >= sline && line_no <= eline then
"\n"
^
if line_no = sline && line_no = eline then
Cli.print_with_style error_indicator_style "%*s"
(get_end_column pos - 1)
(String.make (get_end_column pos - get_start_column pos) '^')
else if line_no = sline && line_no <> eline then
Cli.print_with_style error_indicator_style "%*s"
(String.length line - 1)
(String.make (String.length line - get_start_column pos) '^')
else if line_no <> sline && line_no <> eline then
Cli.print_with_style error_indicator_style "%*s%s" line_indent ""
(String.make (String.length line - line_indent) '^')
else if line_no <> sline && line_no = eline then
Cli.print_with_style error_indicator_style "%*s%*s" line_indent ""
(get_end_column pos - 1 - line_indent)
(String.make (get_end_column pos - line_indent) '^')
else assert false (* should not happen *)
else ""
in
let include_extra_count = 0 in
let rec get_lines (n : int) : string list =
match input_line_opt () with
| Some line ->
if n < sline - include_extra_count then get_lines (n + 1)
else if n >= sline - include_extra_count && n <= eline + include_extra_count then
print_matched_line line n :: get_lines (n + 1)
else []
| None -> []
in
let pos_lines = get_lines 1 in
let spaces = int_of_float (log10 (float_of_int eline)) + 1 in
close_in oc;
Cli.print_with_style blue_style "%*s--> %s\n%s" spaces "" filename
(Cli.add_prefix_to_each_line
(Printf.sprintf "\n%s" (String.concat "\n" pos_lines))
(fun i ->
let cur_line = sline - include_extra_count + i - 1 in
if
cur_line >= sline
&& cur_line <= sline + (2 * (eline - sline))
&& cur_line mod 2 = sline mod 2
then Cli.print_with_style blue_style "%*d | " spaces (sline + ((cur_line - sline) / 2))
else if cur_line >= sline - include_extra_count && cur_line < sline then
Cli.print_with_style blue_style "%*d | " spaces cur_line
else if
cur_line <= sline + (2 * (eline - sline)) + 1 + include_extra_count
&& cur_line > sline + (2 * (eline - sline)) + 1
then Cli.print_with_style blue_style "%*d | " spaces (cur_line - (eline - sline + 1))
else Cli.print_with_style blue_style "%*s | " spaces ""))
type 'a marked = 'a * t
let no_pos : t =
let zero_pos =
{ Lexing.pos_fname = ""; Lexing.pos_lnum = 0; Lexing.pos_cnum = 0; Lexing.pos_bol = 0 }
in
(zero_pos, zero_pos)
let unmark ((x, _) : 'a marked) : 'a = x
let get_position ((_, x) : 'a marked) : t = x
let map_under_mark (f : 'a -> 'b) ((x, y) : 'a marked) : 'b marked = (f x, y)
let same_pos_as (x : 'a) ((_, y) : 'b marked) : 'a marked = (x, y)
let unmark_option (x : 'a marked option) : 'a option =
match x with Some x -> Some (unmark x) | None -> None

182
src/catala/scope_language/ast.ml Normal file
View File

@ -0,0 +1,182 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Abstract syntax tree of the scope language *)
module Pos = Utils.Pos
module Uid = Utils.Uid
(** {1 Identifiers} *)
module ScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
module ScopeNameSet : Set.S with type elt = ScopeName.t = Set.Make (ScopeName)
module ScopeMap : Map.S with type key = ScopeName.t = Map.Make (ScopeName)
module SubScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
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
| TArray of typ
| TAny
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on
higher-order abstract syntax*)
type expr =
| ELocation of location
| EVar of expr Bindlib.var Pos.marked
| EStruct of StructName.t * expr Pos.marked StructFieldMap.t
| EStructAccess of expr Pos.marked * StructFieldName.t * StructName.t
| EEnumInj of expr Pos.marked * EnumConstructor.t * EnumName.t
| EMatch of expr Pos.marked * EnumName.t * expr Pos.marked EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of 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 list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EArray of expr Pos.marked list
let rec locations_used (e : expr Pos.marked) : LocationSet.t =
match Pos.unmark e with
| ELocation l -> LocationSet.singleton (l, Pos.get_position e)
| EVar _ | ELit _ | EOp _ -> LocationSet.empty
| EAbs (_, binder, _) ->
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 -> 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
| EArray es ->
List.fold_left (fun acc e' -> LocationSet.union acc (locations_used e')) LocationSet.empty es
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
let make (s : string Pos.marked) : t =
Bindlib.new_var
(fun (x : expr Bindlib.var) : expr -> EVar (x, Pos.get_position s))
(Pos.unmark s)
let compare x y = Bindlib.compare_vars x y
end
type vars = expr Bindlib.mvar
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 : 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)
: 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)

228
src/catala/scope_language/dependency.ml Normal file
View File

@ -0,0 +1,228 @@
(* This file is part of the Catala compiler, a specification language for tax and social benefits
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
<denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** Graph representation of the dependencies between scopes in the Catala program. Vertices are
functions, x -> y if x is used in the definition of y. *)
module Pos = Utils.Pos
module Errors = Utils.Errors
module SVertex = struct
type t = Ast.ScopeName.t
let hash x = Ast.ScopeName.hash x
let compare = Ast.ScopeName.compare
let equal x y = Ast.ScopeName.compare x y = 0
let format_t (fmt : Format.formatter) (x : t) : unit = Ast.ScopeName.format_t fmt x
end
(** On the edges, the label is the expression responsible for the use of the function *)
module SEdge = struct
type t = Pos.t
let compare = compare
let default = Pos.no_pos
end
module SDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (SVertex) (SEdge)
module STopologicalTraversal = Graph.Topological.Make (SDependencies)
module SSCC = Graph.Components.Make (SDependencies)
(** Tarjan's stongly connected components algorithm, provided by OCamlGraph *)
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 _ | Ast.Assertion _ -> acc
| Ast.Call (subscope, subindex) ->
if subscope = scope_name then
Errors.raise_spanned_error
(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
(Pos.get_position (Ast.SubScopeName.get_info subindex))
acc)
Ast.ScopeMap.empty scope.Ast.scope_decl_rules
in
Ast.ScopeMap.fold
(fun subscope pos g ->
let edge = SDependencies.E.create subscope pos scope_name in
SDependencies.add_edge_e g edge)
subscopes g)
prgm.program_scopes g
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 = 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
(List.map
(fun v ->
let var_str, var_info =
(Format.asprintf "%a" Ast.ScopeName.format_t v, Ast.ScopeName.get_info 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
[
(Some ("Cycle variable " ^ var_str ^ ", declared:"), Pos.get_position var_info);
( Some ("Used here in the definition of another cycle variable " ^ succ_str ^ ":"),
edge_pos );
])
scc))
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 _ | Ast.TAny -> TVertexSet.empty
| Ast.TArray t1 -> get_structs_or_enums_in_type (Pos.same_pos_as t1 t)
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))

8
src/catala/scope_language/dune Normal file
View File

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

32
src/catala/scope_language/format_scope.ml
View File

@ -1,32 +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. *)
(** Print a scope program *)
let print_scope (scope : Scope_ast.scope) : string =
let print_defs (defs : Scope_ast.definition Uid.ScopeDefMap.t) : string =
defs |> Uid.ScopeDefMap.bindings
|> List.map (fun (uid, term) ->
Printf.sprintf "%s:\n%s" (Uid.ScopeDef.format_t uid) (Format_lambda.print_term term))
|> String.concat ""
in
"___Variables Definition___\n" ^ print_defs scope.scope_defs ^ "___Subscope (Re)definition___\n"
^ "\n"
(** Print the whole program *)
let print_program (prgm : Scope_ast.program) : string =
prgm |> Uid.ScopeMap.bindings
|> List.map (fun (uid, scope) ->
Printf.sprintf "Scope %s:\n%s" (Uid.Scope.format_t uid) (print_scope scope))
|> String.concat "\n"
|> Printf.sprintf "Scope program\n%s"

124
src/catala/scope_language/print.ml Normal file
View File

@ -0,0 +1,124 @@
(* 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. *)
module Pos = Utils.Pos
open Ast
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with EAbs _ -> true | _ -> false
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
let format_location (fmt : Format.formatter) (l : location) : unit =
match l with
| ScopeVar v -> Format.fprintf fmt "%a" ScopeVar.format_t (Pos.unmark v)
| SubScopeVar (_, subindex, subvar) ->
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
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ (Pos.same_pos_as t1 typ)
| TAny -> Format.fprintf fmt "any"
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
else Format.fprintf fmt "%a" format_expr e
in
match Pos.unmark e with
| 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
let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in
Format.fprintf fmt "@[%a%a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " ")
(fun fmt (x, tau, arg) ->
Format.fprintf fmt "@[@[<hov 2>let@ %a@ :@ %a@ =@ %a@]@ in@\n@]" format_var x
format_typ tau format_expr arg))
xs_tau_arg format_expr body
| EAbs (_, binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>λ@ %a@ →@ %a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " ")
(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
(op, Pos.no_pos) format_with_parens arg2
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop (op, Pos.no_pos) format_with_parens
arg1
| EApp (f, args) ->
Format.fprintf fmt "@[%a@ %a@]" format_expr f
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]" format_expr
e1 format_expr e2 format_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos)
| 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.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_expr)
excepts format_expr just format_expr cons
| EArray es ->
Format.fprintf fmt "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";")
(fun fmt e -> Format.fprintf fmt "@[%a@]" format_expr e))
es

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

@ -1,48 +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: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(* Scopes *)
type binder = Uid.LocalVar.t
type definition = Lambda_ast.term
let empty_def (pos : Pos.t) (typ : Lambda_ast.typ) : definition =
((EDefault Lambda_ast.empty_default_term, pos), typ)
type assertion = Lambda_ast.term
type variation_typ = Increasing | Decreasing
type reference_typ = Decree | Law
type meta_assertion =
| FixedBy of reference_typ Pos.marked
| VariesWith of Lambda_ast.term * variation_typ Pos.marked option
type scope = {
scope_uid : Uid.Scope.t;
scope_defs : definition Uid.ScopeDefMap.t;
scope_assertions : assertion list;
scope_meta_assertions : meta_assertion list;
}
let empty_scope (uid : Uid.Scope.t) : scope =
{
scope_uid = uid;
scope_defs = Uid.ScopeDefMap.empty;
scope_assertions = [];
scope_meta_assertions = [];
}
type program = scope Uid.ScopeMap.t

301
src/catala/scope_language/scope_interpreter.ml
View File

@ -1,301 +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: Nicolas Chataing
<nicolas.chataing@ens.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
(** 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. *)
module Vertex = struct
type t = Var of Uid.Var.t | SubScope of Uid.SubScope.t
let hash x = match x with Var x -> Uid.Var.hash x | SubScope x -> Uid.SubScope.hash x
let compare = compare
let equal x y =
match (x, y) with
| Var x, Var y -> Uid.Var.compare x y = 0
| SubScope x, SubScope y -> Uid.SubScope.compare x y = 0
| _ -> false
let format_t (x : t) : string =
match x with Var v -> Uid.Var.format_t v | SubScope v -> Uid.SubScope.format_t v
end
(** On the edges, the label is the expression responsible for the use of the variable *)
module Edge = struct
type t = Pos.t
let compare = compare
let default = Pos.no_pos
end
module ScopeDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (Vertex) (Edge)
module TopologicalTraversal = Graph.Topological.Make (ScopeDependencies)
module SCC = Graph.Components.Make (ScopeDependencies)
(** Tarjan's stongly connected components algorithm, provided by OCamlGraph *)
(** Outputs an error in case of cycles. *)
let check_for_cycle (g : ScopeDependencies.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 < ScopeDependencies.nb_vertex g then
let scc = List.find (fun scc -> List.length scc > 1) sccs in
Errors.raise_multispanned_error "cyclic dependency dected between variables!"
(List.flatten
(List.map
(fun v ->
let var_str, var_info =
match v with
| Vertex.Var v -> (Uid.Var.format_t v, Uid.Var.get_info v)
| Vertex.SubScope v -> (Uid.SubScope.format_t v, Uid.SubScope.get_info v)
in
let succs = ScopeDependencies.succ_e g v in
let _, edge_pos, succ = List.find (fun (_, _, succ) -> List.mem succ scc) succs in
let succ_str =
match succ with
| Vertex.Var v -> Uid.Var.format_t v
| Vertex.SubScope v -> Uid.SubScope.format_t v
in
[
(Some ("cycle variable " ^ var_str ^ ", declared:"), Pos.get_position var_info);
( Some ("used here in the definition of another cycle variable " ^ succ_str ^ ":"),
edge_pos );
])
scc))
let build_scope_dependencies (scope : Scope_ast.scope) (ctxt : Name_resolution.context) :
ScopeDependencies.t =
let g = ScopeDependencies.empty in
let scope_uid = scope.scope_uid in
(* Add all the vertices to the graph *)
let scope_ctxt = Uid.ScopeMap.find scope_uid ctxt.scopes in
let g =
Uid.IdentMap.fold
(fun _ (v : Uid.Var.t) g -> ScopeDependencies.add_vertex g (Vertex.Var v))
scope_ctxt.var_idmap g
in
let g =
Uid.IdentMap.fold
(fun _ (v : Uid.SubScope.t) g -> ScopeDependencies.add_vertex g (Vertex.SubScope v))
scope_ctxt.sub_scopes_idmap g
in
let g =
Uid.ScopeDefMap.fold
(fun def_key def g ->
let fv = Lambda_ast.term_fv def in
Uid.ScopeDefSet.fold
(fun fv_def g ->
match (def_key, fv_def) with
| Uid.ScopeDef.Var defined, Uid.ScopeDef.Var used ->
(* simple case *)
ScopeDependencies.add_edge g (Vertex.Var used) (Vertex.Var defined)
| Uid.ScopeDef.SubScopeVar (defined, _), Uid.ScopeDef.Var used ->
(* here we are defining the input of a subscope using a var of the scope *)
ScopeDependencies.add_edge g (Vertex.Var used) (Vertex.SubScope defined)
| Uid.ScopeDef.SubScopeVar (defined, _), Uid.ScopeDef.SubScopeVar (used, _) ->
(* here we are defining the input of a scope with the output of another subscope *)
ScopeDependencies.add_edge g (Vertex.SubScope used) (Vertex.SubScope defined)
| Uid.ScopeDef.Var defined, Uid.ScopeDef.SubScopeVar (used, _) ->
(* finally we define a scope var with the output of a subscope *)
ScopeDependencies.add_edge g (Vertex.SubScope used) (Vertex.Var defined))
fv g)
scope.scope_defs g
in
g
let rec rewrite_subscope_redef_before_call (ctxt : Name_resolution.context)
(parent_scope : Uid.Scope.t) (subscope : Scope_ast.scope)
((redef, redef_ty) : Scope_ast.definition) : Scope_ast.definition =
let parent_scope_ctx = Uid.ScopeMap.find parent_scope ctxt.scopes in
let rec_call = rewrite_subscope_redef_before_call ctxt parent_scope subscope in
match Pos.unmark redef with
| Lambda_ast.EVar (prefix, var) -> (
match prefix with
| Lambda_ast.NoPrefix ->
(* this is a variable of the parent scope, we add the prefix *)
( Pos.same_pos_as (Lambda_ast.EVar (Lambda_ast.CallerPrefix (1, None), var)) redef,
redef_ty )
| Lambda_ast.SubScopePrefix parent_sub ->
let parent_sub_real = Uid.SubScopeMap.find parent_sub parent_scope_ctx.sub_scopes in
(* two cases here *)
if parent_sub_real = subscope.scope_uid then
(* we remove the prefix since we're calling this precise subscope *)
(Pos.same_pos_as (Lambda_ast.EVar (Lambda_ast.NoPrefix, var)) redef, redef_ty)
else
(* we add the caller prefix*)
( Pos.same_pos_as
(Lambda_ast.EVar (Lambda_ast.CallerPrefix (1, Some parent_sub), var))
redef,
redef_ty )
| Lambda_ast.CallerPrefix (i, grand_parent_sub) ->
(* In this tricky case, we are trying to call a subscope while being executed as a
subscope of a "grand-parent" scope. See [tests/scopes/grand_parent_scope.catala] for an
exemple. What we do in this case is that we propagate the prefix while adding 1 to the
generation counter *)
( Pos.same_pos_as
(Lambda_ast.EVar (Lambda_ast.CallerPrefix (i + 1, grand_parent_sub), var))
redef,
redef_ty ) )
| Lambda_ast.EInt _ | Lambda_ast.EBool _ | Lambda_ast.EDec _ | Lambda_ast.EOp _
| Lambda_ast.ELocalVar _ ->
(redef, redef_ty)
| Lambda_ast.EFun (bindings, body) ->
(Pos.same_pos_as (Lambda_ast.EFun (bindings, rec_call body)) redef, redef_ty)
| Lambda_ast.EApp (f, args) ->
(Pos.same_pos_as (Lambda_ast.EApp (rec_call f, List.map rec_call args)) redef, redef_ty)
| Lambda_ast.EIfThenElse (if_t, then_t, else_t) ->
( Pos.same_pos_as
(Lambda_ast.EIfThenElse (rec_call if_t, rec_call then_t, rec_call else_t))
redef,
redef_ty )
| Lambda_ast.EDefault default ->
( Pos.same_pos_as
(Lambda_ast.EDefault
{
default with
defaults = List.map (fun (x, y) -> (rec_call x, rec_call y)) default.defaults;
})
redef,
redef_ty )
(** In this function, the keys of the [redefs] maps are variables of the [subscope] *)
let merge_var_redefs_before_subscope_call (ctxt : Name_resolution.context)
(parent_scope : Uid.Scope.t) (subscope : Scope_ast.scope)
(redefs : Scope_ast.definition Uid.VarMap.t) : Scope_ast.scope =
let merge_defaults : Lambda_ast.term -> Lambda_ast.term -> Lambda_ast.term =
Lambda_ast.map_untype2 (fun old_t new_t ->
match (old_t, new_t) with
| EDefault old_def, EDefault new_def ->
EDefault (Lambda_ast.merge_default_terms old_def new_def)
| _ -> assert false
(* should not happen *))
in
(* when merging redefinitions inside a subscope for execution, we need to annotate the variables
of the parent scope with the caller prefix *)
{
subscope with
scope_defs =
Uid.VarMap.fold
(fun new_def_var new_def sub_defs ->
let new_def = rewrite_subscope_redef_before_call ctxt parent_scope subscope new_def in
match Uid.ScopeDefMap.find_opt (Uid.ScopeDef.Var new_def_var) sub_defs with
| None -> Uid.ScopeDefMap.add (Uid.ScopeDef.Var new_def_var) new_def sub_defs
| Some old_def ->
let def = merge_defaults old_def new_def in
Uid.ScopeDefMap.add (Uid.ScopeDef.Var new_def_var) def sub_defs)
redefs subscope.scope_defs;
}
let rewrite_context_before_executing_subscope (subscope : Uid.SubScope.t)
(exec_context : Lambda_interpreter.exec_context) : Lambda_interpreter.exec_context =
Lambda_interpreter.ExecContext.fold
(fun key value acc ->
match key with
| Lambda_interpreter.ExecContextKey.LocalVar _ ->
(* we can forget local vars when entering a subscope *)
acc
| Lambda_interpreter.ExecContextKey.ScopeVar (prefix, var) ->
let new_prefix =
(* note: this has to match with the behavior of [rewrite_subscope_redef_before_call] *)
match prefix with
| Lambda_ast.NoPrefix -> Lambda_ast.CallerPrefix (1, None)
| Lambda_ast.CallerPrefix (i, sub) -> Lambda_ast.CallerPrefix (i + 1, sub)
| Lambda_ast.SubScopePrefix sub ->
if sub = subscope then Lambda_ast.NoPrefix else Lambda_ast.CallerPrefix (1, Some sub)
in
Lambda_interpreter.ExecContext.add
(Lambda_interpreter.ExecContextKey.ScopeVar (new_prefix, var))
value acc)
exec_context Lambda_interpreter.ExecContext.empty
let rewrite_context_after_executing_subscope (subscope : Uid.SubScope.t)
(exec_context : Lambda_interpreter.exec_context) : Lambda_interpreter.exec_context =
Lambda_interpreter.ExecContext.fold
(fun key value acc ->
match key with
| Lambda_interpreter.ExecContextKey.LocalVar _ ->
(* we can forget local vars when entering a subscope *)
acc
| Lambda_interpreter.ExecContextKey.ScopeVar (prefix, var) -> (
let new_prefix =
match prefix with
| Lambda_ast.NoPrefix -> Some (Lambda_ast.SubScopePrefix subscope)
| Lambda_ast.CallerPrefix (i, sub) -> (
if i > 1 then Some (Lambda_ast.CallerPrefix (i - 1, sub))
else
match sub with
| None -> Some Lambda_ast.NoPrefix
| Some sub -> Some (Lambda_ast.SubScopePrefix sub) )
| Lambda_ast.SubScopePrefix _ -> None
(* we drop the subscope's subscopes since they can't be accessed *)
in
match new_prefix with
| None -> acc
| Some new_prefix ->
Lambda_interpreter.ExecContext.add
(Lambda_interpreter.ExecContextKey.ScopeVar (new_prefix, var))
value acc ))
exec_context Lambda_interpreter.ExecContext.empty
let rec execute_scope ?(exec_context = Lambda_interpreter.empty_exec_ctxt)
(ctxt : Name_resolution.context) (prgm : Scope_ast.program) (scope_prgm : Scope_ast.scope) :
Lambda_interpreter.exec_context =
let scope_ctxt = Uid.ScopeMap.find scope_prgm.scope_uid ctxt.scopes in
let deps = build_scope_dependencies scope_prgm ctxt in
check_for_cycle deps;
TopologicalTraversal.fold
(fun v exec_context ->
match v with
| Vertex.Var var -> (
match Uid.ScopeDefMap.find_opt (Uid.ScopeDef.Var var) scope_prgm.scope_defs with
| Some def ->
(* we evaluate a variable of the scope, no tricky business here *)
Lambda_interpreter.ExecContext.add
(Lambda_interpreter.ExecContextKey.ScopeVar (Lambda_ast.NoPrefix, var))
( Lambda_interpreter.eval_term (Uid.ScopeDef.Var var) exec_context def
|> Lambda_ast.untype )
exec_context
| None -> assert false (* should not happen *) )
| Vertex.SubScope subscope_uid ->
(* this is the tricky case where we have to the the bookkeeping of rewriting the context
and additional defaults that we pass for the subscope for execution. See formalization
for more details *)
let subscope_real_uid = Uid.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes in
let subscope = Uid.ScopeMap.find subscope_real_uid prgm in
let redefs_to_include_to_subscope =
Uid.ScopeDefMap.fold
(fun def_key def acc ->
match def_key with
| Uid.ScopeDef.Var _ -> acc
| Uid.ScopeDef.SubScopeVar (def_sub_uid, var) ->
if def_sub_uid = subscope_uid then Uid.VarMap.add var def acc else acc)
scope_prgm.scope_defs Uid.VarMap.empty
in
let subscope =
merge_var_redefs_before_subscope_call ctxt scope_prgm.scope_uid subscope
redefs_to_include_to_subscope
in
let exec_context = rewrite_context_before_executing_subscope subscope_uid exec_context in
let exec_context = execute_scope ~exec_context ctxt prgm subscope in
let exec_context = rewrite_context_after_executing_subscope subscope_uid exec_context in
exec_context)
deps exec_context

550
src/catala/scope_language/scope_to_dcalc.ml Normal file
View File

@ -0,0 +1,550 @@
(* 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. *)
module Pos = Utils.Pos
module Errors = Utils.Errors
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 (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;
local_vars = Ast.VarMap.empty;
}
type scope_ctx = Dcalc.Ast.Var.t Ast.ScopeMap.t
let hole_var : Dcalc.Ast.Var.t = Dcalc.Ast.Var.make ("·", Pos.no_pos)
let rec translate_typ (ctx : ctx) (t : Ast.typ Pos.marked) : Dcalc.Ast.typ Pos.marked =
Pos.same_pos_as
( match Pos.unmark t with
| 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)
| Ast.TArray t1 -> Dcalc.Ast.TArray (translate_typ ctx (Pos.same_pos_as t1 t))
| Ast.TAny -> Dcalc.Ast.TAny )
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 =
Dcalc.Ast.make_app caller
[ Bindlib.box (Dcalc.Ast.ELit Dcalc.Ast.LUnit, Pos.no_pos) ]
Pos.no_pos
in
let body =
Bindlib.box_apply2
(fun caller callee ->
( Dcalc.Ast.EDefault
([ caller ], (Dcalc.Ast.ELit (Dcalc.Ast.LBool true), Pos.no_pos), callee),
Pos.no_pos ))
caller callee
in
body
let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Pos.marked Bindlib.box
=
Bindlib.box_apply
(fun (x : Dcalc.Ast.expr) -> Pos.same_pos_as x e)
( match Pos.unmark e with
| 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 "Missing field for structure %a: \"%a\""
Ast.StructName.format_t struct_name Ast.StructFieldName.format_t field_name)
(Pos.get_position e)
in
let field_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 "The fields \"%a\" do not belong to the structure %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))
(translate_expr ctx e1)
(Bindlib.box_list (List.map (translate_expr ctx) args))
| EAbs (pos_binder, binder, typ) ->
let xs, body = Bindlib.unmbind binder in
let new_xs = Array.map (fun x -> Dcalc.Ast.Var.make (Bindlib.name_of x, Pos.no_pos)) xs in
let both_xs = Array.map2 (fun x new_x -> (x, new_x)) xs new_xs in
let body =
translate_expr
{
ctx with
local_vars =
Array.fold_left
(fun local_vars (x, new_x) -> Ast.VarMap.add x new_x local_vars)
ctx.local_vars both_xs;
}
body
in
let binder = Bindlib.bind_mvar new_xs body in
Bindlib.box_apply
(fun b -> Dcalc.Ast.EAbs (pos_binder, b, List.map (translate_typ ctx) typ))
binder
| EDefault (excepts, just, cons) ->
Bindlib.box_apply3
(fun e j c -> Dcalc.Ast.EDefault (e, j, c))
(Bindlib.box_list (List.map (translate_expr ctx) excepts))
(translate_expr ctx just) (translate_expr ctx cons)
| ELocation (ScopeVar a) ->
Bindlib.box_var (fst (Ast.ScopeVarMap.find (Pos.unmark a) ctx.scope_vars))
| ELocation (SubScopeVar (_, s, a)) -> (
try
Bindlib.box_var
(fst
(Ast.ScopeVarMap.find (Pos.unmark a)
(Ast.SubScopeMap.find (Pos.unmark s) ctx.subscope_vars)))
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf
"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
(fun c t f -> Dcalc.Ast.EIfThenElse (c, t, f))
(translate_expr ctx cond) (translate_expr ctx et) (translate_expr ctx ef)
| EOp op -> Bindlib.box (Dcalc.Ast.EOp op)
| EArray es ->
Bindlib.box_apply
(fun es -> Dcalc.Ast.EArray es)
(Bindlib.box_list (List.map (translate_expr ctx) es)) )
let rec translate_rule (ctx : ctx) (rule : Ast.rule) (rest : Ast.rule list)
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info) :
Dcalc.Ast.expr Pos.marked Bindlib.box * ctx =
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 (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) ->
let a_name =
Pos.map_under_mark
(fun str -> str ^ "." ^ Pos.unmark (Ast.ScopeVar.get_info (Pos.unmark subs_var)))
(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
subscope_vars =
Ast.SubScopeMap.update (Pos.unmark subs_index)
(fun map ->
match map with
| Some map ->
Some
(Ast.ScopeVarMap.add (Pos.unmark subs_var)
(Pos.unmark a_var, Pos.unmark tau)
map)
| None ->
Some
(Ast.ScopeVarMap.singleton (Pos.unmark subs_var)
(Pos.unmark a_var, Pos.unmark tau)))
ctx.subscope_vars;
}
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 ((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.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
(out_e, new_ctx)
| Call (subname, subindex) ->
let all_subscope_vars, scope_dcalc_var = Ast.ScopeMap.find subname ctx.scopes_parameters in
let subscope_vars_defined =
try Ast.SubScopeMap.find subindex ctx.subscope_vars
with Not_found -> Ast.ScopeVarMap.empty
in
let subscope_var_not_yet_defined subvar =
not (Ast.ScopeVarMap.mem subvar subscope_vars_defined)
in
let subscope_args =
List.map
(fun (subvar, _) ->
if subscope_var_not_yet_defined subvar then
Bindlib.box Dcalc.Interpreter.empty_thunked_term
else
let a_var, _ = Ast.ScopeVarMap.find subvar subscope_vars_defined in
Dcalc.Ast.make_var (a_var, Pos.get_position (Ast.SubScopeName.get_info subindex)))
all_subscope_vars
in
let all_subscope_vars_dcalc =
List.map
(fun (subvar, tau) ->
let sub_dcalc_var =
Dcalc.Ast.Var.make
(Pos.map_under_mark
(fun s -> Pos.unmark (Ast.SubScopeName.get_info subindex) ^ "." ^ s)
(Ast.ScopeVar.get_info subvar))
in
(subvar, tau, sub_dcalc_var))
all_subscope_vars
in
let new_ctx =
{
ctx with
subscope_vars =
Ast.SubScopeMap.add subindex
(List.fold_left
(fun acc (var, tau, dvar) -> Ast.ScopeVarMap.add var (dvar, tau) acc)
Ast.ScopeVarMap.empty all_subscope_vars_dcalc)
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))
subscope_func (Bindlib.box_list subscope_args)
in
let call_expr =
Bindlib.box_apply
(fun call_expr ->
( Dcalc.Ast.EApp
( ( Dcalc.Ast.EOp
(Dcalc.Ast.Unop
(Dcalc.Ast.Log
( Dcalc.Ast.EndCall,
[
(sigma_name, pos_sigma);
Ast.SubScopeName.get_info subindex;
Ast.ScopeName.get_info subname;
] ))),
Pos.get_position call_expr ),
[ call_expr ] ),
Pos.get_position call_expr ))
call_expr
in
let result_tuple_var = Dcalc.Ast.Var.make ("result", Pos.no_pos) in
let next_e, new_ctx = translate_rules new_ctx rest (sigma_name, pos_sigma) in
let results_bindings, _ =
List.fold_right
(fun (_, tau, dvar) (acc, i) ->
let result_access =
Bindlib.box_apply
(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
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)
((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 (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 (sigma_name, pos_sigma)
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 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
(fun (x, tau) ->
let dcalc_x, _ = Ast.ScopeVarMap.find x ctx.scope_vars in
(x, tau, dcalc_x))
scope_variables
in
let pos_sigma = Pos.get_position sigma_info in
Dcalc.Ast.make_abs
(Array.of_list (List.map (fun (_, _, x) -> x) scope_variables))
rules pos_sigma
(List.map
(fun (_, tau, _) ->
(Dcalc.Ast.TArrow ((Dcalc.Ast.TLit TUnit, pos_sigma), (tau, pos_sigma)), pos_sigma))
scope_variables)
pos_sigma
let build_scope_typ_from_sig (scope_sig : (Ast.ScopeVar.t * Dcalc.Ast.typ) list) (pos : Pos.t) :
Dcalc.Ast.typ Pos.marked =
let result_typ = (Dcalc.Ast.TTuple (List.map (fun (_, tau) -> (tau, pos)) scope_sig), pos) in
List.fold_right
(fun (_, arg_t) acc ->
(Dcalc.Ast.TArrow ((Dcalc.Ast.TArrow ((TLit TUnit, pos), (arg_t, pos)), pos), acc), pos))
scope_sig result_typ
let 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_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.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) ->
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.program_scopes
in
(* the final expression on which we build on is the variable of the top-level scope that we are
returning *)
let acc = Dcalc.Ast.make_var (snd (Ast.ScopeMap.find top_level_scope_name sctx), Pos.no_pos) in
(* the resulting expression is the list of definitions of all the scopes, ending with the
top-level scope. *)
Bindlib.unbox
(let acc =
List.fold_right
(fun scope_name (acc : Dcalc.Ast.expr Pos.marked Bindlib.box) ->
let scope = Ast.ScopeMap.find scope_name prgm.program_scopes in
let pos_scope = Pos.get_position (Ast.ScopeName.get_info scope.scope_decl_name) in
let scope_expr = translate_scope_decl struct_ctx enum_ctx sctx scope_name scope in
let scope_sig, dvar = Ast.ScopeMap.find scope_name sctx in
let scope_typ = build_scope_typ_from_sig scope_sig pos_scope in
Dcalc.Ast.make_let_in dvar scope_typ scope_expr acc)
scope_ordering acc
in
acc)

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.

98
src/catala/scope_language/uid.ml
View File

@ -1,98 +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. *)
module IdentMap = Map.Make (String)
module type Id = sig
type t
type info
val fresh : info -> t
val get_info : t -> info
val compare : t -> t -> int
val format_t : t -> string
val hash : t -> int
end
module Make (X : sig
type info
val format_info : info -> string
end) : Id with type info = X.info = struct
type t = { id : int; info : X.info }
type info = X.info
let counter = ref 0
let fresh (info : X.info) : t =
incr counter;
{ id = !counter; info }
let get_info (uid : t) : X.info = uid.info
let compare (x : t) (y : t) : int = compare x.id y.id
let format_t (x : t) : string = Printf.sprintf "%s" (X.format_info x.info)
let hash (x : t) : int = x.id
end
module MarkedString = struct
type info = string Pos.marked
let format_info (s, _) = s
end
module Scope = Make (MarkedString)
module ScopeSet = Set.Make (Scope)
module ScopeMap = Map.Make (Scope)
module Var = Make (MarkedString)
module VarSet = Set.Make (Var)
module VarMap = Map.Make (Var)
module LocalVar = Make (MarkedString)
module LocalVarSet = Set.Make (LocalVar)
module LocalVarMap = Map.Make (LocalVar)
module SubScope = Make (MarkedString)
module SubScopeSet = Set.Make (SubScope)
module SubScopeMap = Map.Make (SubScope)
(** Inside a scope, a definition can refer either to a scope def, or a subscope def *)
module ScopeDef = struct
type t =
| Var of Var.t
| SubScopeVar of SubScope.t * Var.t
(** In this case, the [Uid.Var.t] lives inside the context of the subscope's original
declaration *)
let compare x y =
match (x, y) with
| Var x, Var y | Var x, SubScopeVar (_, y) | SubScopeVar (_, x), Var y -> Var.compare x y
| SubScopeVar (_, x), SubScopeVar (_, y) -> SubScope.compare x y
let format_t x =
match x with
| Var v -> Var.format_t v
| SubScopeVar (s, v) -> Printf.sprintf "%s.%s" (SubScope.format_t s) (Var.format_t v)
let hash x = match x with Var v -> Var.hash v | SubScopeVar (_, v) -> Var.hash v
end
module ScopeDefMap = Map.Make (ScopeDef)
module ScopeDefSet = Set.Make (ScopeDef)

79
src/catala/scope_language/uid.mli
View File

@ -1,79 +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. *)
module IdentMap : Map.S with type key = String.t
module MarkedString : sig
type info = string Pos.marked
val format_info : 'a * 'b -> 'a
end
module type Id = sig
type t
type info
val fresh : info -> t
val get_info : t -> info
val compare : t -> t -> int
val format_t : t -> string
val hash : t -> int
end
module Scope : Id with type info = MarkedString.info
module ScopeSet : Set.S with type elt = Scope.t
module ScopeMap : Map.S with type key = Scope.t
module Var : Id with type info = MarkedString.info
module VarSet : Set.S with type elt = Var.t
module VarMap : Map.S with type key = Var.t
module LocalVar : Id with type info = MarkedString.info
module LocalVarSet : Set.S with type elt = LocalVar.t
module LocalVarMap : Map.S with type key = LocalVar.t
module SubScope : Id with type info = MarkedString.info
module SubScopeSet : Set.S with type elt = SubScope.t
module SubScopeMap : Map.S with type key = SubScope.t
module ScopeDef : sig
type t =
| Var of Var.t
| SubScopeVar of SubScope.t * Var.t
(** In this case, the [Uid.Var.t] lives inside the context of the subscope's original
declaration *)
val compare : t -> t -> int
val format_t : t -> string
val hash : t -> int
end
module ScopeDefMap : Map.S with type key = ScopeDef.t
module ScopeDefSet : Set.S with type elt = ScopeDef.t

41
src/catala/cli.ml → src/catala/utils/cli.ml
View File

@ -15,12 +15,19 @@
(** Ssource files to be compiled *)
let source_files : string list ref = ref []
let contents : string ref = ref ""
(** Prints debug information *)
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 +40,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 +63,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 +93,15 @@ 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 version = "0.2.0"
let info =
let doc =
@ -96,20 +115,16 @@ 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
Term.info "catala"
~version:
( match Build_info.V1.version () with
| None -> "n/a"
| Some v -> Build_info.V1.Version.to_string v )
~doc ~exits ~man
Term.info "catala" ~version ~doc ~exits ~man
(**{1 Terminal formatting}*)
@ -130,6 +145,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 +194,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

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